!======================================================================== !************************************************************************ !************************************************************************ !**************** **************** !************** USER DEFINED FUNCTIONS ************** !**************** **************** !************************************************************************ !************************************************************************ !************************************************************************ ! HEADER$(T$) * ! - clears the screen and prints top line header in inverse video * ! and double wide large letters. * ! T$ - title * !************************************************************************ ! local var: ! DEF HEADER$(T$) PRINT CLS$; PRINT INV$; PRINT LRG$; PRINT USING C2$,T$ PRINT NRM$; END DEF !************************************************************************ ! BANNER$(T$,D$,S$) * ! - clears the screen and SCROLLS top line header in inverse video * ! and double wide large letters. * ! T$ - title * ! D$ - scroll direction ! S$ - screen size * !************************************************************************ ! local var: ! DEF BANNER$(T$,D$,S$) D$ = EDIT$(D$,188) len_banner = LEN(T$) IF S$ = "132" THEN PRINT TRM132$; len_line = 65 ELSE PRINT TRM80$; len_line = 39 END IF PRINT CLS$; IF D$ = "L" THEN FOR X = 0 TO len_line subtitle$ = RIGHT$(T$,len_banner - X) title$ = subtitle$ + SPACE$(len_line - X) PRINT L1$; PRINT INV$; PRINT BOLD$; PRINT LRG$; SELECT S$ CASE "132" PRINT USING C4$,title$ CASE ELSE PRINT USING C2$,title$ END SELECT PRINT NRM$; NEXT X ELSE FOR X = 0 TO len_line subtitle$ = LEFT$(T$,X) title$ = SPACE$(len_line - X) + subtitle$ PRINT L1$; PRINT INV$; PRINT BOLD$; PRINT LRG$; SELECT S$ CASE "132" PRINT USING C4$,title$ CASE ELSE PRINT USING C2$,title$ END SELECT PRINT NRM$; NEXT X END IF END DEF !************************************************************************ ! SEL_HDR$(T$,S$) * ! - clears the screen and prints top line header in inverse video * ! and double wide large letters. * ! T$ - title * ! S$ - screen size * !************************************************************************ ! local var: ! DEF SEL_HDR$(T$,S$) PRINT CLS$; IF S$ = "132" THEN PRINT TRM132$; ELSE PRINT TRM80$; END IF PRINT INV$; PRINT LRG$; SELECT S$ CASE "132" PRINT USING C4$,T$ CASE ELSE PRINT USING C2$,T$ END SELECT PRINT NRM$; END DEF !************************************************************************ ! TESTHDR$(T$) * ! - clears the screen from line 2 and print test id in invere video * ! and double wide large letters. * ! T$ - test id * !************************************************************************ ! local var: ! DEF TESTHDR$(T$) PRINT CLS2$; PRINT INV$; PRINT LRG$; PRINT USING C2$,T$ PRINT NRM$; END DEF !************************************************************************ ! INSTRUCT$(D$) * ! - clears from line 5 to to the end of screen and prints * ! - D$ in large letters * ! D$ - actual instructions to be printed * !************************************************************************ ! local var: ! DEF INSTRUCT$(D$) PRINT CLS5$; PRINT LRG$; PRINT USING C2$,D$; PRINT EL$ END DEF !************************************************************************ ! LRG_INST$(D$) * ! - clears from line 5 to to the end of screen and prints * ! - D$ in double height letters * ! D$ - actual instructions to be printed * !************************************************************************ ! local var: ! DEF LRG_INST$(D$) PRINT CLS5$; PRINT LTOP$; PRINT USING C2$,D$; PRINT EL$ PRINT LBOT$; PRINT USING C2$,D$; PRINT EL$ END DEF !************************************************************************ ! INSTRT$(D$) * ! - prints instructions on line 3 and clears to end of line * ! D$ - actual instructions to be printed * !************************************************************************ DEF INSTRT$(D$) PRINT L3$; PRINT D$; PRINT EL$ END DEF !************************************************************************ ! STOP$ * ! - display stop message on command line, erase to end of line, * ! receive input, return value entered * ! CMDLN$ - line # 23 of the display * !************************************************************************ ! local var: REPLY$ - operator's response to question ! DEF STOP$ PRINT BEL;CMDLN$; PRINT "Press '";INV$;"RETURN";NRM$;"' to continue"; PRINT EL$; SET NO PROMPT INPUT REPLY$ SET PROMPT PRINT CMDLN$;EL$;L22$; STOP$ = EDIT$(REPLY$,184%) END DEF !************************************************************************ ! MVE$(X$,Y$) * ! - positions the cursor at the coordinates x,y on the screen * ! X$ - column * ! Y$ - line (row) * !************************************************************************ ! local var: ! DEF MVE$(X$,Y$) !**************************** remove all leading and trailing spaces X$ = EDIT$(X$,184) Y$ = EDIT$(Y$,184) PRINT ESC + "[";Y$;";";X$;"H";SV$; END DEF !************************************************************************ ! CHAR_CLEAR(X$,Y$,Z$) * ! - save current cursor position * ! - positions the cursor at the coordinates x,y on the screen * ! - display (reset) character string with normal attributes * ! - restore saved cursor position * ! X$ - column * ! Y$ - line (row) * ! Z$ - character string * !************************************************************************ ! local var: ! DEF CHAR_CLEAR(X$,Y$,Z$) !**************************** remove all leading and trailing spaces X$ = EDIT$(X$,184) Y$ = EDIT$(Y$,184) PRINT SV$; PRINT ESC + "[";Y$;";";X$;"H"; PRINT NRM$;Z$;RS$; END DEF !************************************************************************ ! CHAR_BLINK(X$,Y$,Z$) * ! - save current cursor position * ! - positions the cursor at the coordinates x,y on the screen * ! - display character string with bold/blinking attributes * ! - restore saved cursor position * ! X$ - column * ! Y$ - line (row) * ! Z$ - character string * !************************************************************************ ! local var: ! DEF CHAR_BLINK(X$,Y$,Z$) !**************************** remove all leading and trailing spaces X$ = EDIT$(X$,184) Y$ = EDIT$(Y$,184) PRINT SV$; PRINT ESC + "[";Y$;";";X$;"H"; PRINT BNK$;BOLD$;Z$;NRM$;RS$; END DEF !************************************************************************ ! ENTER$(PROMPT$) * ! - display prompt and return response * ! PROMPT$ - question/prompt to be displayed * ! CMDLN$ - line # 23 of the display * !************************************************************************ ! local var: REPLY$ - operator's response to question ! DEF ENTER$(PROMPT$) PRINT CMDLN$; PRINT BEL;PROMPT$;" ";EL$; SET NO PROMPT LINPUT REPLY$ SET PROMPT PRINT CMDLN$;EL$;L22$; ENTER$ = EDIT$(REPLY$,184%) END DEF !************************************************************************ ! INPT$ * ! - input a string and edit the value entered based on the value * ! of the EDIT function's integer argument: * ! * ! 8 - discard leading spaces and tabs * ! 16 - reduce spaces and tabs to one space * ! 32 - convert lowercase to uppercase * ! 128 - discard trailing spaces and tabs * ! -------- * ! 184 - integer argument of EDIT function (system function) * !************************************************************************ ! local var: REPLY$ - operator's response to question ! DEF INPT$ SET NO PROMPT INPUT REPLY$ SET PROMPT INPT$ = EDIT$(REPLY$,184) END DEF !************************************************************************ ! INPT_CHAR$ * ! - input a char with no use of the enter key - uses the INKEY$ * ! cmd and returns the ASCII char or escape sequence mnemonic * ! string * !************************************************************************ ! local var: KEYSTROKE$ - string variable to except the INKEY$ input ! DEF STRING INPT_CHAR$ KEYSTROKE$ = INKEY$(0%,WAIT) SELECT KEYSTROKE$ CASE CR KEYSTROKE$ = "CR" CASE LF KEYSTROKE$ = "LF" CASE VT KEYSTROKE$ = "VT" CASE FF KEYSTROKE$ = "FF" CASE ESC KEYSTROKE$ = "ESC" CASE '0'C KEYSTROKE$ = "NUL" CASE '1'C KEYSTROKE$ = "SOH" CASE '2'C KEYSTROKE$ = "STX" CASE '3'C KEYSTROKE$ = "ETX" CASE '4'C KEYSTROKE$ = "EOT" CASE '5'C KEYSTROKE$ = "ENQ" CASE '6'C KEYSTROKE$ = "ACK" CASE '7'C KEYSTROKE$ = "BEL" CASE '8'C KEYSTROKE$ = "BS" CASE '9'C KEYSTROKE$ = "HT" CASE '14'C KEYSTROKE$ = "SO" CASE '15'C KEYSTROKE$ = "SI" CASE '16'C KEYSTROKE$ = "DLE" CASE '17'C KEYSTROKE$ = "DC1" CASE '18'C KEYSTROKE$ = "DC2" CASE '19'C KEYSTROKE$ = "DC3" CASE '20'C KEYSTROKE$ = "DC4" CASE '21'C KEYSTROKE$ = "NAK" CASE '22'C KEYSTROKE$ = "SYN" CASE '23'C KEYSTROKE$ = "ETB" CASE '24'C KEYSTROKE$ = "CAN" CASE '25'C KEYSTROKE$ = "EM" CASE '26'C KEYSTROKE$ = "SUB" CASE '28'C KEYSTROKE$ = "FS" CASE '29'C KEYSTROKE$ = "GS" CASE '30'C KEYSTROKE$ = "RS" CASE '31'C KEYSTROKE$ = "US" CASE '127'C KEYSTROKE$ = "DEL" END SELECT INPT_CHAR$ = KEYSTROKE$ END DEF !************************************************************************ ! QUEST$(DEFAULT$,PROMPT$) * ! - display prompt and proper default and return "Y" or "N" * ! DEFAULT$ - default ('Y' or 'N') * ! PROMPT$ - question/prompt to be displayed * ! CMDLN$ - line # 23 of the display * !************************************************************************ ! local var: REPLY$ - operator's response to question ! DEF QUEST$(DEFAULT$,PROMPT$) PRINT BEL;CMDLN$;NRM$; IF DEFAULT$ = "Y" THEN PRINT PROMPT$;" (";INV$;"Y";NRM$;"/N) ";EL$; ELSE PRINT PROMPT$;" (Y/";INV$;"N";NRM$;") ";EL$; END IF INPUT REPLY$ PRINT CMDLN$;EL$;L22$; REPLY$ = EDIT$(REPLY$,32%) IF (REPLY$ <> "Y" AND REPLY$ <> "N") THEN REPLY$ = DEFAULT$ END IF QUEST$ = REPLY$ END DEF !************************************************************************ ! PASSWORD$ * ! - clears the screen and asks for the password to have access to * ! the function. Will allow 3 tries and return 'RESET' if failure * ! or 'SET' if pass. * ! * ! pass_word$ is defined in program source code * !************************************************************************ ! local var: PASS% - number of entries tried - 3 tries allowed ! FLAG$ - pass or fail flag ! DEF PASSWORD$ PRINT CLS2$;L10$ PASS% = 0% FLAG$ = "RESET" WHILE (PASS% < 3) AND (FLAG$ = "RESET") PASS% = PASS% + 1 PRINT "Please enter PASSWORD : "; Y% = NOECHO(0) INPUT PASSWRD$ Y% = ECHO(0) IF (EDIT$(PASSWRD$,32) = pass_word$) THEN FLAG$ = "SET" ELSE PRINT " PASSWORD IS INCORRECT, YOU HAVE ";3 - PASS%; PRINT " TRYS LEFT" END IF NEXT IF (FLAG$ = "RESET") THEN PRINT MSGLN$;"<<= authorization failure =>>";EL$; SLEEP 2 END IF PASSWORD$ = FLAG$ END DEF !************************************************************************ ! SGL_KEY_PASSWORD$ * ! - clears the screen and asks for the password to have access to * ! the function. The password consistes of a single key stroke. * ! Will allow 3 tries and return 'RESET' if failure or 'SET' if * ! pass. * ! * ! pass_word$ is defined in program source code * !************************************************************************ ! local var: PASS% - number of entries tried - 3 tries allowed ! FLAG$ - pass or fail flag ! DEF SGL_KEY_PASSWORD$ PRINT CLS2$;L10$ PASS% = 0% FLAG$ = "RESET" WHILE (PASS% < 3) AND (FLAG$ = "RESET") PASS% = PASS% + 1 PRINT "Please enter PASSWORD : "; Y% = NOECHO(0) PASSWRD$ = INPT_CHAR$ Y% = ECHO(0) IF (EDIT$(PASSWRD$,32) = pass_word$) THEN FLAG$ = "SET" ELSE PRINT PRINT " PASSWORD IS INCORRECT, YOU HAVE ";3 - PASS%; PRINT " TRYS LEFT" END IF NEXT IF (FLAG$ = "RESET") THEN PRINT MSGLN$;"<<= authorization failure =>>";EL$; SLEEP 2 END IF SGL_KEY_PASSWORD$ = FLAG$ END DEF !************************************************************************ ! DISPLAY_INFO_BOX$(X$,Y$,PROMPT$) * ! - positions the cursor at the coordinates x,y on the screen * ! X$ - column * ! Y$ - line (row) * ! and display a box with the PROMPT$ in it * !************************************************************************ ! local var: ! DEF DISPLAY_INFO_BOX$(X$,Y$,PROMPT$) top_box$ = "l" + STRING$(LEN(PROMPT$) + 2,ASCII("q")) + "k" center_box$ = "x " + GOFF$ + PROMPT$ + GON$ + " x" bottom_box$ = "m" + STRING$(LEN(PROMPT$) + 2,ASCII("q")) + "j" D$ = MVE$(X$,Y$) PRINT GON$; PRINT top_box$ D$ = MVE$(X$,SUM$(Y$,"1")) PRINT center_box$ D$ = MVE$(X$,SUM$(Y$,"2")) PRINT bottom_box$; PRINT GOFF$;NRM$; END DEF !************************************************************************ ! DISPLAY_BOX$(X$,Y$,X2$,Y2$) * ! - positions the cursor at the coordinates x,y on the screen * ! X$ & X2$ - column * ! Y$ & Y2$ - line (row) * ! and displays a box between cursor coordinates x,y and x2,y2 * !************************************************************************ ! local var: ! DEF DISPLAY_BOX$(X$,Y$,X2$,Y2$) IF COMP%(X$,X2$) = 1 THEN T$ = X2$ X2$ = X$ X$ = T$ END IF IF COMP%(Y$,Y2$) = 1 THEN T$ = Y2$ Y2$ = Y$ Y$ = T$ END IF box_length = ABS%(INTEGER(DIF$(X$,X2$))) + 1 box_height = ABS%(INTEGER(DIF$(Y$,Y2$))) + 1 top_box$ = "l" + STRING$(box_length - 2,ASCII("q")) + "k" side_box$ = "x" bottom_box$ = "m" + STRING$(box_length - 2,ASCII("q")) + "j" D$ = MVE$(X$,Y$) PRINT GON$; PRINT top_box$ Y = 1 UNTIL Y > box_height - 2 D$ = MVE$(X$,SUM$(Y$,NUM1$(Y))) PRINT side_box$ D$ = MVE$(X2$,SUM$(Y$,NUM1$(Y))) PRINT side_box$ Y = Y + 1 NEXT D$ = MVE$(X$,Y2$) PRINT bottom_box$; PRINT GOFF$;NRM$; END DEF !************************************************************************ ! CLEAR_BOX$(X$,Y$,X2$,Y2$) * ! - positions the cursor at the coordinates x,y on the screen * ! X$ & X2$ - column * ! Y$ & Y2$ - line (row) * ! and clears the displayed box between cursor coordinates x,y and x2,y2 * !************************************************************************ ! local var: ! DEF CLEAR_BOX$(X$,Y$,X2$,Y2$) IF COMP%(X$,X2$) = 1 THEN T$ = X2$ X2$ = X$ X$ = T$ END IF IF COMP%(Y$,Y2$) = 1 THEN T$ = Y2$ Y2$ = Y$ Y$ = T$ END IF box_length = ABS%(INTEGER(DIF$(X$,X2$))) + 1 box_height = ABS%(INTEGER(DIF$(Y$,Y2$))) + 1 top_box$ = SPACE$(box_length) side_box$ = " " bottom_box$ = SPACE$(box_length) D$ = MVE$(X$,Y$) PRINT top_box$ Y = 1 UNTIL Y > box_height - 2 D$ = MVE$(X$,SUM$(Y$,NUM1$(Y))) PRINT side_box$ D$ = MVE$(X2$,SUM$(Y$,NUM1$(Y))) PRINT side_box$ Y = Y + 1 NEXT D$ = MVE$(X$,Y2$) PRINT bottom_box$; END DEF !************************************************************************ ! CLEAR_AREA$(X$,Y$,X2$,Y2$) * ! - positions the cursor at the coordinates x,y on the screen * ! X$ & X2$ - column * ! Y$ & Y2$ - line (row) * ! and clears the area between cursor coordinates x,y and x2,y2 * !************************************************************************ ! local var: ! DEF CLEAR_AREA$(X$,Y$,X2$,Y2$) IF COMP%(X$,X2$) = 1 THEN T$ = X2$ X2$ = X$ X$ = T$ END IF IF COMP%(Y$,Y2$) = 1 THEN T$ = Y2$ Y2$ = Y$ Y$ = T$ END IF area_length = ABS%(INTEGER(DIF$(X$,X2$))) + 1 area_height = ABS%(INTEGER(DIF$(Y$,Y2$))) + 1 area$ = SPACE$(area_length) Y = 0 UNTIL Y > area_height D$ = MVE$(X$,SUM$(Y$,NUM1$(Y))) PRINT area$; Y = Y + 1 NEXT END DEF !************************************************************************ ! NUM_SUFFIX_STR$(NUMB) * ! RETURNS - 2 char string suffix for NUMB * ! * ! NUMB - number being checked * !************************************************************************ ! local var: ! DEF STRING NUM_SUFFIX_STR$(NUMB) numb$ = EDIT$(NUM1$(INTEGER(NUMB)),188) IF LEN(numb$) > 1 THEN SELECT RIGHT$(numb$,LEN(numb$) - 1) CASE "1" sec_qualifier$ = "Y" CASE ELSE sec_qualifier$ = "N" END SELECT END IF IF sec_qualifier$ = "Y" THEN NUM_SUFFIX_STR$ = "th" ELSE SELECT RIGHT$(numb$,LEN(numb$)) CASE "1" NUM_SUFFIX_STR$ = "st" CASE "2" NUM_SUFFIX_STR$ = "nd" CASE "3" NUM_SUFFIX_STR$ = "rd" CASE ELSE NUM_SUFFIX_STR$ = "th" END SELECT END IF END DEF !************************************************************************ ! TEMP_CONV(IN_SCALE$,OUT_SCALE$,TEMP_VALUE) * ! - convert a temperature from one scale to another * ! RETURNS - new temperature per OUT_SCALE$ selected * ! * ! TEMP_VALUE - orignal temperature to be converted in selected * ! IN_SCALE$ units * !************************************************************************ ! local var: TEMP_C - temperture in degs Celsius ! TEMP_F - temperture in degs Fahrenheit ! TEMP_K - temperture in degs Kelvin ! TEMP_R - temperture in degs Rankine ! DECLARE REAL FUNCTION TEMP_CONV (STRING,STRING,REAL) DEF REAL TEMP_CONV(IN_SCALE$,OUT_SCALE$,TEMP_VALUE) IF IN_SCALE$ = OUT_SCALE$ THEN TEMP_CONV = TEMP_VALUE EXIT DEF END IF SELECT IN_SCALE$ CASE "C" SELECT OUT_SCALE$ CASE "F" GOSUB DEG_CTOF TEMP_CONV = TEMP_F CASE "K" GOSUB DEG_CTOK TEMP_CONV = TEMP_K CASE "R" GOSUB DEG_CTOF TEMP_VALUE = TEMP_F GOSUB DEG_FTOR TEMP_CONV = TEMP_R END SELECT CASE "F" SELECT OUT_SCALE$ CASE "C" GOSUB DEG_FTOC TEMP_CONV = TEMP_C CASE "K" GOSUB DEG_FTOC TEMP_VALUE = TEMP_C GOSUB DEG_CTOK TEMP_CONV = TEMP_K CASE "R" GOSUB DEG_FTOR TEMP_CONV = TEMP_R END SELECT CASE "K" SELECT OUT_SCALE$ CASE "C" GOSUB DEG_KTOC TEMP_CONV = TEMP_C CASE "F" GOSUB DEG_KTOC TEMP_VALUE = TEMP_C GOSUB DEG_CTOF TEMP_CONV = TEMP_F CASE "R" GOSUB DEG_KTOC TEMP_VALUE = TEMP_C GOSUB DEG_CTOF TEMP_VALUE = TEMP_F GOSUB DEG_FTOR TEMP_CONV = TEMP_R END SELECT CASE "R" SELECT OUT_SCALE$ CASE "F" GOSUB DEG_RTOF TEMP_CONV = TEMP_F CASE "C" GOSUB DEG_RTOF TEMP_VALUE = TEMP_F GOSUB DEG_FTOC TEMP_CONV = TEMP_C CASE "K" GOSUB DEG_RTOF TEMP_VALUE = TEMP_F GOSUB DEG_FTOC TEMP_VALUE = TEMP_C GOSUB DEG_CTOK TEMP_CONV = TEMP_K END SELECT CASE ELSE TEMP_CONV = 0 END SELECT EXIT DEF DEG_CTOF: TEMP_F = (TEMP_VALUE * 9 / 5) + 32 RETURN DEG_FTOC: TEMP_C = (TEMP_VALUE - 32) * 5 / 9 RETURN DEG_CTOK: TEMP_K = TEMP_VALUE + 273.16 RETURN DEG_FTOR: TEMP_R = TEMP_VALUE + 459.67 RETURN DEG_KTOC: TEMP_C = TEMP_VALUE - 273.16 RETURN DEG_RTOF: TEMP_F = TEMP_VALUE - 459.67 RETURN END DEF !************************************************************************ ! ISNUM(ST$) * ! - determine if a character string consists of all numbers * ! RETURNS - 0 if ST$ is not numeric * ! - 1 if ST$ is numeric * ! * ! ST$ - character string being tested * !************************************************************************ ! local var: J - counter for loop ! CH - ascii value of a character ! DEF INTEGER ISNUM(ST$) ISNUM = 1 FOR J = 1 TO LEN(ST$) CH = ASCII(SEG$(ST$,J,J)) SELECT CH CASE 46 CASE 47 TO 57 CASE ELSE ISNUM = 0 J = LEN(ST$) END SELECT NEXT J END DEF !************************************************************************ ! NUMDTE$(CD$) * ! - converts printable form of date (DD-MMM-YY) to stored numeric * ! form: YYMMDD or YYYYMMDD * ! > converts 23-OCT-87 TO 871023 * ! > converts 23-OCT-1987 TO 19871023 * ! > if date sent is blank or 'NCR' then '' is returnd * ! * ! CD$ - date (in form: dd-mmm-yy or dd-mmm-yyyy) to be converted * !************************************************************************ ! local var: DT$ - 'dd' (day) ! YY$ - 'yy' (year) or 'yyyy' (year) ! M$ - 'mmm' (month) ! M% - number of month in year, i.e. 12 => DEC ! MN$ - string format of M% ! DEF NUMDTE$(CD$) MONTHS$ = "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC" DAYS$ = "031029031030031030031031030031030031" CD$ = EDIT$(CD$,32) SELECT CD$ CASE "","NCR" NUMDTE$ = "" CASE ELSE DT$ = LEFT$(CD$,2) YY$ = EDIT$(RIGHT$(CD$,8),6) M$ = EDIT$(SEG$(CD$,4,6),32) M% = POS(MONTHS$,M$,1%) D2% = M% M% = ((M% - 1%)/ 3%) + 1% MN$ = FORMAT$(M%,"<0>#") NUMDTE$ = YY$ + MN$ + DT$ END SELECT END DEF !************************************************************************ ! PRTDTE$(CD$) * ! - converts stored numeric form of date (YYMMDD) or (YYYYMMDD) to * ! printable form: DD-MMM-YY or DD-MMM-YYYY * ! > converts 871112 to 12-NOV-87 * ! > converts 19871112 to 12-NOV-1987 * ! > if date sent is blank or 'NCR' then '' is returnd * ! * ! CD$ - date (in form: yymmdd or yyyymmdd) to be converted * !************************************************************************ ! local var: CD$ - 'dd' (day) ! CY$ - 'yy' (year) or 'yyyy' (year) ! CM$ - 'mm' (month) ! P - position of month in 'month table' ! MON$- abbreviated month 'mmm' ! DEF PRTDTE$(CD$) MONTHS$ = "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC" DAYS$ = "031029031030031030031031030031030031" CD$ = EDIT$(CD$,184) LENDTE = LEN(CD$) SELECT CD$ CASE "","NCR" PRTDTE$ = "" CASE ELSE SELECT LENDTE CASE 6 IF (CD$ <> "") AND (ASCII(CD$) <> 0) THEN CY$ = LEFT$(CD$,2) CM$ = SEG$(CD$,3,4) CD$ = RIGHT$(CD$,5) P = VAL(CM$) * 3 MON$ = SEG$(MONTHS$,P - 2,P) PRTDTE$ = CD$ + "-" + MON$ + "-" + CY$ END IF CASE 8 IF (CD$ <> "") AND (ASCII(CD$) <> 0) THEN CY$ = LEFT$(CD$,4) CM$ = SEG$(CD$,5,6) CD$ = RIGHT$(CD$,7) P = VAL(CM$) * 3 MON$ = SEG$(MONTHS$,P - 2,P) PRTDTE$ = CD$ + "-" + MON$ + "-" + CY$ END IF END SELECT END SELECT END DEF !************************************************************************ ! VALIDATE(DTE$) * ! - checks the validity of a date * ! - a date is valid if: * ! > the month is a proper three character month * ! > the day and year are integers * ! > the day is a valid day for the given month * ! * ! - RETURNS: TRUE - if date is valid * ! FALSE- if date is not valid * ! * ! DTE$ - date to be checked (form: 'dd-mmm-yy' or 'dd-mmm-yyyy')* !************************************************************************ ! local var: LN% - length of date to be checked ! CD$ - 'dd' (day) ! YY$ - 'yy' (year) or 'yyyy' (year) ! CM$ - 'mm' (month) ! M - position of month in 'month table' ! MON$- abbreviated month 'mmm' ! DEF INTEGER VALIDATE(DTE$) MONTHS$ = "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC" DAYS$ = "031029031030031030031031030031030031" VALIDATE = TRUE DTE$ = EDIT$(DTE$,184) LN% = LEN(DTE$) IF ((LN% = 8) OR (LN% = 10)) THEN DTE$ = "0" + DTE$ END IF SELECT LN% CASE 9,11 CD$ = LEFT$(DTE$,2) CM$ = EDIT$(SEG$(DTE$,4,6),32%) YY$ = RIGHT$(DTE$,8) M = POS(MONTHS$,CM$,1%) !* if day and year are numeric and the month is in the month table IF (ISNUM(CD$) AND (M > 0) AND ISNUM(YY$)) THEN !**************************** check for valid day in month IF VAL(CD$) > VAL(SEG$(DAYS$,M,M + 2)) THEN VALIDATE = FALSE END IF ELSE VALIDATE = FALSE END IF CASE ELSE VALIDATE = FALSE END SELECT END DEF !************************************************************************ ! GOOD_EXP_DATE(ED$) * ! - checks to make sure that the expiration date of the standard * ! used is not earlier than the calibration date of the piece of * ! equipment being certified for calibration. * ! - compares the parameter with today's date and returns the * ! following: * ! TRUE - if parameter ED$ > todays date * ! FALSE- if parameter ED$ < todays date (expired date) * ! * ! - functions used: VALIDATE, NUMDTE * ! * ! ED$ - date to be checked (form: 'dd-mmm-yy' or 'dd-mmm-yyyy') * ! * !************************************************************************ DEF INTEGER GOOD_EXP_DATE(ED$) ED$ = EDIT$(ED$,184) LN% = LEN(ED$) !*********************************************** if date is a valid date IF VALIDATE(ED$) THEN !*********************************** if date is later than today SELECT LN% CASE 9 CHK_DTE = INTEGER(NUMDTE$(TODAY$)) CASE 11 NOW$ = EDIT$(LEFT$(NOW$,11),188) CHK_DTE = INTEGER(NUMDTE$(NOW$)) END SELECT IF INTEGER(NUMDTE$(ED$)) > CHK_DTE THEN GOOD_EXP_DATE = TRUE ELSE GOOD_EXP_DATE = FALSE END IF ELSE GOOD_EXP_DATE = FALSE END IF END DEF !************************************************************************ ! WEEKDAY_NAME$(DAY_NUM%) * ! Returns the name string of the day of the week. The numbers * ! correspond to the values returned by LIB$DAY_OF_WEEK. * ! ON ENTRY: DAY_NUM% - must be an integer between 1 and 7. * ! ON EXIT : WEEKDAY_NAME$ - is the printable form of the day of the * ! week. * !************************************************************************ DEF STRING WEEKDAY_NAME$(DAY_NUM%) SELECT DAY_NUM% CASE 1 WEEKDAY_NAME$ = "MONDAY" CASE 2 WEEKDAY_NAME$ = "TUESDAY" CASE 3 WEEKDAY_NAME$ = "WEDNESDAY" CASE 4 WEEKDAY_NAME$ = "THURSDAY" CASE 5 WEEKDAY_NAME$ = "FRIDAY" CASE 6 WEEKDAY_NAME$ = "SATURDAY" CASE 7 WEEKDAY_NAME$ = "SUNDAY" CASE ELSE WEEKDAY_NAME$ = "ERROR" END SELECT END DEF !************************************************************************ ! CONV_DTE$(DTE$) * ! - converts inputed date to an acceptable format or returns an error * ! Input Returned * ! Format Example Date * ! DD-MMM-YY 28-Apr-93 28-Apr-93 * ! MM-DD-YY 04-28-93 28-Apr-93 * ! DD 28 28-Apr-93 * ! MM-DD 04-28 28-Apr-93 * ! DD-MMM 28-Apr 28-Apr-93 * ! MMM-DD Apr-28 28-Apr-93 * ! * ! TOD*AY tod 28-Apr-93 * ! YES*TERDAY yes 27-Apr-93 * ! TOM*ORROW tom 29-Apr-93 * ! * !The dash (-) in the above formats can be replaced with any of the * !following separaters: - / \ | : , . or a space (IE. 24 Apr/93). A * !separater must be used where indicated. * !************************************************************************ ! local var: ! DEF CONV_DTE$(DTE$) DIM sep_pos(2), sep$(2) Dte$ = EDIT$(DTE$,188) LenDate = LEN(Dte$) SELECT LEFT$(Dte$,3) CASE "YES" CALL CALC_DATE(LEFT$(NOW$,11),"-1D",TMP_DTE$,DATE_ERR%) DTE$ = LEFT$(TMP_DTE$,7) + RIGHT$(TMP_DTE$,10) CASE "TOD" DTE$ = TODAY$ CASE "TOM" CALL CALC_DATE(LEFT$(NOW$,11),"+1D",TMP_DTE$,DATE_ERR%) DTE$ = LEFT$(TMP_DTE$,7) + RIGHT$(TMP_DTE$,10) END SELECT IF VALIDATE(DTE$) = TRUE THEN CONV_DTE$ = DTE$ EXIT DEF END IF GOSUB parse_today SELECT LenDate CASE = 0 CONV_DTE$ = "" EXIT DEF CASE < 3 DD$ = Dte$ IF LenDate < 2 THEN DD$ = "0" + DD$ END IF IF ISNUM(DD$) = 0 ! is not a number THEN CONV_DTE$ = DTE$ ELSE TMP_DTE$ = Tmp_Year$ + Tmp_Mon$ + DD$ CONV_DTE$ = PRTDTE$(TMP_DTE$) END IF EXIT DEF CASE ELSE TMP_DTE$ = "" GOSUB cnt_seps fst_dte$ = LEFT$(Dte$,sep_pos(1) - 1) fst_dte$ = "0" + fst_dte$ UNTIL LEN(fst_dte$) => 2 Len_fst_dte = LEN(fst_dte$) mid_dte$ = SEG$(Dte$,sep_pos(1) + 1,sep_pos(2) - 1) mid_dte$ = "0" + mid_dte$ UNTIL LEN(mid_dte$) => 2 Len_mid_dte = LEN(mid_dte$) lst_dte$ = RIGHT$(Dte$,sep_pos(2) + 1) Len_lst_dte = LEN(lst_dte$) IF lst_dte$ = "" THEN lst_dte$ = Tmp_Year$ END IF ! check for word month sec in input IF (Len_mid_dte > 2) AND & (ISNUM(mid_dte$) = 0) AND & (Len_fst_dte < 3) AND & (ISNUM(fst_dte$) = 1) THEN TMP_DTE$ = fst_dte$ + "-" + LEFT$(mid_dte$,3) + "-" + lst_dte$ END IF ! check for word month first in input IF (Len_fst_dte > 2) AND & (ISNUM(fst_dte$) = 0) AND & (Len_mid_dte < 3) AND & (ISNUM(mid_dte$) = 1) THEN TMP_DTE$ = mid_dte$ + "-" + LEFT$(fst_dte$,3) + "-" + lst_dte$ END IF ! check for number month input IF (Len_fst_dte < 3) AND & (ISNUM(fst_dte$) = 1) AND & (Len_mid_dte < 3) AND & (ISNUM(mid_dte$) = 1) THEN TMP_DTE$ = lst_dte$ + fst_dte$ + mid_dte$ TMP_DTE$ = PRTDTE$(TMP_DTE$) END IF ! check if input format accepted IF TMP_DTE$ = "" OR & VALIDATE(TMP_DTE$) = FALSE THEN CONV_DTE$ = DTE$ ELSE CONV_DTE$ = TMP_DTE$ END IF END SELECT EXIT DEF !=========================================================================== ! parse today's date !=========================================================================== parse_today: TMP_DTE$ = NUMDTE$(TODAY$) ! format today$ = dd-mmm-yy LenTMP_DTE = LEN(TMP_DTE$) SELECT LenTMP_DTE CASE 8 Tmp_Year$ = LEFT$(TMP_DTE$,4) Tmp_Mon$ = MID$(TMP_DTE$,5,2) Tmp_day$ = RIGHT$(TMP_DTE$,7) CASE 6 Tmp_Year$ = LEFT$(TMP_DTE$,2) Tmp_Mon$ = MID$(TMP_DTE$,3,2) Tmp_day$ = RIGHT$(TMP_DTE$,5) END SELECT RETURN !=========================================================================== ! count the number of separators in input !=========================================================================== cnt_seps: sep_cnt = 0 FOR XZ = 1 TO LenDate IF ((MID$(Dte$,XZ,1) = "-") OR & (MID$(Dte$,XZ,1) = "/") OR & (MID$(Dte$,XZ,1) = "\") OR & (MID$(Dte$,XZ,1) = "|") OR & (MID$(Dte$,XZ,1) = ":") OR & (MID$(Dte$,XZ,1) = ",") OR & (MID$(Dte$,XZ,1) = ".") OR & (MID$(Dte$,XZ,1) = " ")) THEN sep_cnt = sep_cnt + 1 sep_pos(sep_cnt) = XZ sep$(sep_cnt) = MID$(Dte$,XZ,1) END IF NEXT XZ SELECT sep_cnt CASE < 1, > 2 CONV_DTE$ = DTE$ EXIT DEF CASE 1 sep_pos(2) = LenDate + 1 END SELECT RETURN END DEF !************************************************************************ ! Mod_date$ * ! - determines what program file is currently running and passes * ! the file spec to a DCL command string which defines a symbol * ! with the last modification date of the program file. This * ! date is returned. * !************************************************************************ ! local var: JPI$_IMAGNAME - defined in BASIC$STARLET.TLB ! FILE_NAME$ - receives file spec ! FILE_RDT - DCL symbol for prog mod date ! FILE_RDT$ - BASIC var for prog mod date ! DEF Mod_date$ EXTERNAL SUB LIB$GETJPI(LONG BY REF,,,,STRING BY DESC) EXTERNAL LONG FUNCTION LIB$SPAWN(STRING) CALL LIB$GETJPI(JPI$_IMAGNAME,,,,FILE_NAME$) CMD$ = "@SYS$CALIB:GET_FILE_RDT_DATE.COM " + FILE_NAME$ RET_STATUS% = LIB$SPAWN(CMD$) OPEN "SYS$LOGIN:DATE.TMP" FOR INPUT AS FILE #2, RECORDTYPE ANY RESTORE #2 LINPUT #2, FILE_RDT$ CLOSE #2 KILL "SYS$LOGIN:DATE.TMP" Mod_date$ = FILE_RDT$ END DEF !************************************************************************ ! Owner_name$ * ! - determines what account is running the current image and returns * ! the account owner field. * !************************************************************************ ! local var: Equiv_len - variable to receive buffer length ! Buffer_length - buffer length ! UAI_ITEMS - variable to hold buffer uai_items ! JPI$_USERNAME - defined in BASIC$STARLET.TLB ! USER_NAME$ - returned user name string ! Owner$ - returned owner name string ! QUIT$ - loop controller ! DEF Owner_name$ EXTERNAL SUB LIB$GETJPI(LONG BY REF,,,,STRING BY DESC) EXTERNAL LONG FUNCTION SYS$GETUAI(,,STRING BY DESC,ITEM_LIST BY REF,,,) DECLARE WORD Equiv_len DECLARE WORD CONSTANT Buffer_length = 32% RECORD item_list GROUP item(1) VARIANT CASE WORD Buf_len WORD Code LONG Buffer_address LONG Length_address CASE LONG Terminator END VARIANT END GROUP item END RECORD item_list DECLARE ITEM_LIST UAI_ITEMS COMMON (UAI_buffer) STRING UAI_info_buffer = Buffer_length UAI_ITEMS::item(0)::Buf_len = Buffer_length UAI_ITEMS::item(0)::Code = UAI$_OWNER UAI_ITEMS::item(0)::Buffer_address = LOC(UAI_info_buffer) UAI_ITEMS::item(0)::Length_address = LOC(Equiv_len) UAI_ITEMS::item(1)::Terminator = 0% CALL LIB$GETJPI (JPI$_USERNAME,,,,USER_NAME$) RET_STATUS = SYS$GETUAI(,,USER_NAME$,UAI_ITEMS,,,) IF RET_STATUS AND SS$_NORMAL THEN Owner$ = EDIT$(LEFT$(UAI_info_buffer,Equiv_len),140) ELSE Owner$ = " " END IF QUIT$ = "F" UNTIL QUIT$ = "T" IF ASCII(Owner$) < 32 OR ASCII(Owner$) > 126 THEN Owner$ = SEG$(Owner$,2,LEN(Owner$)) ELSE QUIT$ = "T" END IF NEXT Owner_name$ = Owner$ END DEF !************************************************************************ ! Node_name$ * ! - determines what node the program is currently running on and * ! returns a char string of that node name. * !************************************************************************ ! local var: SYI$_NODENAME - defined in BASIC$STARLET.TLB ! LOC_NODE_VALUE - filler variable ! LOC_NODE_NAME$ - receives the node name ! DEF Node_name$ EXTERNAL SUB LIB$GETSYI(LONG BY REF,ANY,STRING BY DESC) CALL LIB$GETSYI (SYI$_NODENAME,LOC_NODE_VALUE,LOC_NODE_NAME$) Node_name$ = EDIT$(LOC_NODE_NAME$,38) END DEF !************************************************************************ ! Term_type$ * ! - determines what type of terminal is being used. * !************************************************************************ ! local var: JPI$_TERMINAL - defined in BASIC$STARLET.TLB ! DVI$_DEVTYPE - defined in BASIC$STARLET.TLB ! TERM_NAME$ - returned terminal name string ! DEV_TYPE$ - returned terminal type number string ! DEF Term_type$ EXTERNAL SUB LIB$GETJPI(LONG BY REF,,,,STRING BY DESC) EXTERNAL SUB LIB$GETDVI(LONG BY REF,,STRING BY DESC,,STRING BY DESC,) CALL LIB$GETJPI (JPI$_TERMINAL,,,,TERM_NAME$) CALL LIB$GETDVI (DVI$_DEVTYPE,,TERM_NAME$,,DEV_TYPE$,) SELECT INTEGER(DEV_TYPE$) CASE 0 Term_type$ = "Unkown" CASE 110 Term_type$ = "VT200_Series" CASE 112 Term_type$ = "VT300_Series" CASE 113 Term_type$ = "VT400_Series" CASE ELSE Term_type$ = "Other" END SELECT END DEF !************** END USER DEFINED FUNCTIONS ************** !************************************************************************ !========================================================================