PROC SFORM;
# TITLE SFORM - SCREEN FORMATTING OBJECT ROUTINES. #
BEGIN # SFORM #
#
*** SFORM - SCREEN FORMATTING OBJECT ROUTINES.
*
* COPYRIGHT CONTROL DATA SYSTEMS INC. 1992.
#
DEF EDITORVDT #0#; # STAND ALONE VERSION OF VIRTERM #
DEF EUROPEAN #0#; # NOT EUROPEAN NUMERIC FORMAT #
*IF DEF,LIST
DEF LISTCON #1#; # EXPANDED COMMON DECKS #
*ELSE
DEF LISTCON #0#; # NO EXPANDED COMMON DECKS #
*ENDIF
DEF SINGLE #1#; # SINGLE USER (VIRTERM) #
DEF MULTI #0#; # NOT A MULTI-USER #
*IF UNDEF,QTRM
DEF QTRMV #0#; # NOT QTRM VERSION #
*ELSE
DEF QTRMV #1#; # QTRM VERSION #
*ENDIF
XDEF
BEGIN
PROC SFATTR$; # SET FIELD ATTRIBUTES #
PROC SFCLOS$; # UNLOAD PANEL #
PROC SFCSET$; # SET CHARACTER SET #
*IF DEF,QTRM
PROC SFDQUE$; # QTRM DEQUEUE TERMINAL DATA #
*ENDIF
PROC SFGETF$; # GET FIELD CHARACTER STRING #
PROC SFGETI$; # GET INTEGER VALUE #
PROC SFGETK; # GET FUNCTION KEY INPUT #
PROC SFGETN$; # GET TERMINAL MODEL NAME #
PROC SFGETP$; # GET FUNCTION KEY POSITION #
PROC SFGETR$; # GET REAL VALUE #
PROC SFLUSH$; # FLUSH OUTPUT TO SCREEN #
*IF DEF,QTRM
PROC SFMODE$; # QTRM SET TERMINAL MODE #
PROC SFNQUE$; # QTRM ENQUEUE TERMINAL DATA #
*ENDIF
PROC SFOPEN$; # LOAD PANEL AND OPEN FOR USE #
PROC SFPOSR$; # POSITION TABLE ROW #
PROC SFSETF$; # SET FIELD CHARACTER STRING #
*IF DEF,QTRM
PROC SFQTRM$; # QTRM IDENTIFY USER #
*ENDIF
PROC SFSETP$; # SET CURSOR POSITION FOR READ #
PROC SFSREA$; # READ PANEL FROM TERMINAL #
*IF UNDEF,QTRM
PROC SFSSHO$; # WRITE AND READ PANEL #
*ENDIF
PROC SFSWRI$; # WRITE PANEL TO TERMINAL #
END
XREF
BEGIN
*CALL COMFXVT
*IF DEF,QTRM
PROC CMMALF; # CMM ALLOCATE A BLOCK #
PROC CMMFRF; # CMM FREE A BLOCK #
*ENDIF
PROC VDTCLO; # CLOSE TERMINAL #
PROC VDTFOS; # FLUSH OUTPUT TO SCREEN #
*IF UNDEF,QTRM
PROC VDTGSL; # GET TERMINAL MODEL #
*ENDIF
PROC VDTMSG$; # DAYFILE AND B-DISPLAY MESSAGE #
*IF UNDEF,QTRM
PROC VDTOPN; # OPEN TERMINAL #
*ENDIF
END
XREF
BEGIN
PROC ABORT; # ABORT THE PROGRAM/USER #
FUNC GFP; # GENERATE FLOATING POINT VALUE #
PROC LCP; # LOAD CAPSULE #
PROC PLT; # PANEL LOAD TABLE #
PROC UCP; # UNLOAD CAPSULE #
END
CONTROL EJECT;
# DEFINITIONS FOR COMMONLY USED CHARACTER VALUES, PSEUDO WHILE LOOP, #
# AND VALIDFIELD (DEFINED AS =FIELD GQ 0= ) WHICH IS FREQUENTLY USED #
# IN THE CODE TO DETERMINE IF THE FIELD IN QUESTION IS A VALID ONE. #
DEF ASTERISK #O"0052"#; # 12 BIT ASTERISK #
DEF BLANK #O"0040"#; # 12 BIT BLANK #
DEF CAPA #O"0101"#; # 12 BIT UPPER CASE A #
DEF CAPE #O"0105"#; # 12 BIT UPPER CASE E #
DEF CAPZ #O"0132"#; # 12 BIT UPPER CASE Z #
DEF CSMR #O"0067"#; # SYSTEM CHARACTER SET MODE WORD #
DEF COMMA #O"0054"#; # 12 BIT COMMA #
DEF DOLLAR #O"0044"#; # 12 BIT DOLLAR SIGN #
DEF LOWA #O"0141"#; # 12 BIT LOWER CASE A #
DEF LOWZ #O"0172"#; # 12 BIT LOWER CASE Z #
DEF MINUS #O"0055"#; # 12 BIT MINUS SIGN #
DEF NINECH #O"0071"#; # 12 BIT NINE (CHARACTER) #
DEF PANHEADLEN #5#; # LENGTH OF PANEL HEADER #
DEF PERIOD #O"0056"#; # 12 BIT PERIOD #
DEF PLUS #O"0053"#; # 12 BIT PLUS SIGN #
DEF VALIDFIELD #FIELD GQ 0#; # VALID INPUT FIELD #
DEF WHYLE #FOR DUMMY = DUMMY WHILE#; # PSUEDO WHILE LOOP #
DEF XMASKOF #B<51,9>#; # X COORDINATE PART OF FLDPOS #
DEF YMASKOF #B<45,6>#; # Y COORDINATE PART OF FLDPOS #
DEF ZEROCH #O"0060"#; # 12 BIT ZERO (CHARACTER) #
# COMFVDT CONTAINS STATUS SWITCHES USED BY SFORM, VIRTERM AND FSE. #
*CALL COMFVDT
*IF DEF,QTRM
# COMFVD3 CONTAINS STORAGE LOCATIONS USED BY BOTH VIRTERM AND SFORM. #
*ENDIF
*IFCALL QTRM,COMFVD3
CONTROL EJECT;
ITEM DUMMY I; # DUMMY PARAMETER #
BASED ARRAY ARRLIST [0:0] S(2); # ARRAY LIST #
BEGIN
ITEM ARRNAME C(00,00,07); # ARRAY NAME #
ITEM ARRCURROW U(01,00,12); # CURRENT ROW ON SCREEN #
ITEM ARRTOPROW U(01,18,18); # TOP ROW ON SCREEN #
ITEM ARRNUMROWS U(01,36,08); # NUMBER OF ROWS ON SCREEN #
ITEM ARRNUMVARS U(01,44,08); # NUMBER OF VARIABLES PER ROW #
END
BASED ARRAY ARR2LIST [0:0] S(2); # ARRAY LIST FOR *SFATTR* #
BEGIN
ITEM ARR2CURROW U(01,00,12); # CURRENT ROW ON SCREEN #
ITEM ARR2NUMVAR U(01,44,08); # NUMBER OF VARIABLES PER ROW #
END
BASED ARRAY ATTLIST [0:0] P(1); # ATTRIBUTE LIST #
BEGIN
ITEM ATTMASK U(00,00,12); # ATTRIBUTE MASK FOR *VDTSAM* #
ITEM ATTLINEWT U(00,58,02); # LINE WEIGHT FOR *VDTBOX* #
END
BASED ARRAY ATT2LIST [0:0] P(1); # ATTRIBUTE LIST FOR *SFATTR* #
BEGIN
ITEM ATT2MASK U(00,00,12); # ATTRIBUTE MASK FOR VDTSAM #
END
BASED ARRAY BOXLIST [0:0] P(1); # BOX LIST #
BEGIN
ITEM BOXWORD U(00,00,60); # FULL WORD #
ITEM BOXATTORD U(00,00,12); # ATTRIBUTE ORDINAL #
ITEM BOXCHAR U(00,12,04); # LINE DRAWING CHARACTER #
ITEM BOXYCORD U(00,16,06); # Y COORDINATE #
ITEM BOXXCORD U(00,22,09); # X COORDINATE #
ITEM BOXREPEAT U(00,31,09); # REPEAT COUNT FOR THIS CHAR. #
END
BASED ARRAY CORE[0:0] P(1); # MEMORY #
BEGIN
ITEM COREWORD I(00,00,60); # FULL WORD #
END
BASED ARRAY FLDLIST [0:0] P(1); # FIELD LIST #
BEGIN
ITEM FLDENTRY U(00,00,60); # FULL WORD #
ITEM FLDVARFLAG B(00,00,01); # VARIABLE FIELD FLAG #
ITEM FLDATTORD U(00,01,07); # FIELD ATTRIBUTE ORDINAL #
ITEM FLDINPUTV B(00,08,01); # INPUT FIELD FLAG #
ITEM FLDOUTPUTV B(00,09,01); # OUTPUT FIELD FLAG #
ITEM FLDSTFLAGS U(00,10,04); # FIELD STATUS FLAGS #
ITEM FLDENTERED B(00,10,01); # INPUT ENTERED IN FIELD FLAG #
ITEM FLDVALID B(00,11,01); # INPUT PASSED VALIDATION #
ITEM FLDREWRITE B(00,12,01); # REWRITE FIELD ON SCREEN FLAG #
ITEM FLDACTIVE B(00,13,01); # ACTIVE FIELD FLAG #
ITEM FLDVARORD U(00,15,08); # ORDINAL INTO VARLIST FOR FIELD #
ITEM FLDCONOS U(00,18,18); # CONSTANT OFFSET INTO RECORD #
ITEM FLDVDTCORD U(00,23,13); # CHARACTER ORDINAL IN VARDATA #
ITEM FLDLENGTH U(00,36,09); # LENGTH IN 12 BIT CHARACTERS #
ITEM FLDPOS U(00,45,15); # COORDINATES OF FIELD #
ITEM FLDYCORD U(00,45,06); # Y COORDINATE OF FIELD #
ITEM FLDXCORD U(00,51,09); # X COORDINATE OF FIELD #
END
BASED ARRAY FLD2LIST [0:0] P(1); # FIELD LIST FOR *SFATTR* #
BEGIN
ITEM FLD2ATTORD U(00,01,07); # FIELD ATTRIBUTE ORDINAL #
ITEM FLD2INPUTV B(00,08,01); # INPUT FIELD FLAG #
ITEM FLD2OUTPUT B(00,09,01); # OUTPUT FIELD FLAG #
ITEM FLD2ENTERE B(00,10,01); # INPUT ENTERED IN FIELD FLAG #
ITEM FLD2VALID B(00,11,01); # INPUT PASSED VALIDATION #
ITEM FLD2REWRIT B(00,12,01); # REWRITE FIELD ON SCREEN FLAG #
ITEM FLD2VARORD U(00,15,08); # ORDINAL INTO VARLIST FOR FIELD #
END
BASED ARRAY FROMSTRING [0:0] P(1); # FROM STRING #
BEGIN
ITEM FROMSTRIU U(00,00,60); # FROMSTRING WORD (INTEGER) #
END
BASED ARRAY FUNLIST [0:0] S(1); # FUNCTION LIST #
BEGIN
ITEM FUNWORD U(00,00,60); # FIRST WORD OF ENTRY #
ITEM FUNASG U(00,26,18); # VARIABLE ASSIGNMENT OFFSET #
ITEM FUNACT U(00,44,09); # FUNCTION ACTION TO BE TAKEN #
ITEM FUNGENERIC B(00,53,01); # GENERIC FUNTION KEY FLAG #
ITEM FUNNUMBER I(00,54,06); # FUNCTION NUMBER #
END
BASED ARRAY MATCHLIST [0:0] S(2); # MATCH LIST #
BEGIN
ITEM MATCHWORD U(00,00,60); # FIRST WORD OF MATCH LIST ENTRY #
ITEM MATCH C(00,00,20); # TWO WORD MATCH ITEM #
END
BASED ARRAY PANELHEADR [0:0] S(5); # PANEL HEADER #
BEGIN
ITEM PANELNME C(00,00,07); # PANEL NAME #
ITEM PANPRIPAN B(00,58,01); # PRIMARY PANEL (NOT OVERLAY) #
ITEM PANNUMLNES U(01,00,06); # NUMBER OF LINES IN PANEL #
ITEM PANRECLEN U(01,06,18); # LENGTH OF PANEL IN WORDS #
ITEM PANSTRFUN U(01,24,18); # START OF FUNCTION LIST OFFSET #
ITEM PANSTRVAR U(01,42,18); # START OF VARIABLE LIST OFFSET #
ITEM PANVERSION U(02,00,06); # VERSION NUMBER #
ITEM PANSTRATT U(02,06,18); # START OF ATTRIBUTE LIST OFFSET #
ITEM PANSTRARR U(02,24,18); # START OF ARRAY LIST OFFSET #
ITEM PANSTRFLD U(02,42,18); # START OF FIELD LIST OFFSET #
ITEM PANSTRBOX U(03,06,18); # START OF BOX LIST OFFSET #
ITEM PANMSGLEN U(03,36,09); # MESSAGE FIELD LENGTH #
ITEM PANMSGYCRD U(03,45,06); # MESSAGE Y COORDINATE #
ITEM PANMSGXCRD U(03,51,09); # MESSAGE X CORRDINATE #
ITEM PANNUMBYTE U(04,00,13); # NUMBER OF BYTES IN VAR DATA #
ITEM PANNUMCOLS U(04,13,09); # NUMBER OF COLUMNS IN PANEL #
END
CONTROL EJECT;
BASED ARRAY PANEL2HEAD [0:0] S(5); # PANEL HEADER FOR *SFATTR* #
BEGIN
ITEM PANEL2NME C(00,00,07); # PANEL NAME #
ITEM PAN2RECLEN U(01,06,18); # LENGTH OF PANEL IN WORDS #
ITEM PAN2STRFUN U(01,24,18); # START OF FUNCTION LIST OFFSET #
ITEM PAN2STRVAR U(01,42,18); # START OF VARIABLE LIST OFFSET #
ITEM PAN2STRATT U(02,06,18); # START OF ATTRIBUTE LIST OFFSET #
ITEM PAN2STRARR U(02,24,18); # START OF ARRAY LIST OFFSET #
ITEM PAN2STRFLD U(02,42,18); # START OF FIELD LIST OFFSET #
ITEM PAN2STRBOX U(03,06,18); # START OF BOX LIST OFFSET #
END
BASED ARRAY PLTABLE [0:0] S(2); # PANEL LOAD TABLE #
BEGIN
ITEM PLTWORDONE U(00,00,60); # WORD ONE OF TWO #
ITEM PLTENAME C(00,00,07); # PANEL NAME #
ITEM PLTENTRYNM U(00,48,12); # SEQUENCE NUMBER ON SCREEN #
ITEM PLTWORDTWO U(01,00,60); # WORD TWO OF TWO #
ITEM PLTSLFLAG B(01,00,01); # STATIC LOAD FLAG #
ITEM PLTOPENFLG B(01,01,01); # PANEL OPEN FLAG #
ITEM PLTNUMQTRM I(01,24,12); # NUMBER OF QTRM USERS OF PANEL #
ITEM PLTNUMONSC U(01,36,12); # NUMBER OF PANELS ON SCREEN #
ITEM PLTADDR U(01,42,18); # MEMORY ADDRESS OF PANEL #
ITEM PLTNUMENT U(01,48,12); # CURRENT NUMBER OF ENTRIES #
END
BASED ARRAY RECORD [0:0] P(1); # PANEL RECORD #
BEGIN
ITEM RECWORDC C(00,00,10); # PANEL RECORD WORD (CHARACTER) #
ITEM RECWORDR R(00,00,60); # PANEL RECORD WORD (REAL) #
ITEM RECWORDU U(00,00,60); # PANEL RECORD WORD (INTEGER) #
END
BASED ARRAY TOSTRING [0:0] P(1); # TO STRING #
BEGIN
ITEM TOSTRIU U(00,00,60); # TOSTRING WORD (INTEGER) #
END
BASED ARRAY VARLIST [0:0] S(2); # VARIABLE LIST #
BEGIN
ITEM VARMUSCON B(00,00,01); # MUST CONTAIN (A VALUE) #
ITEM VARFLDNUM U(00,01,09); # FIELD ORDINAL #
ITEM VARROWNUM U(00,10,08); # ROW NUMBER #
ITEM VARARRORD U(00,18,05); # ARRAY ORDINAL #
ITEM VARMUSENTR B(00,23,01); # MUST ENTER DATA IN FIELD #
ITEM VARMUSFILL B(00,24,01); # MUST FILL FIELD WITH DATA #
ITEM VARMUSKNOW B(00,25,01); # * NOT ALLOWED #
ITEM VARTYPE U(00,26,02); # VARIABLE TYPE (INT CHAR REAL) #
ITEM VARPICTYPE U(00,28,08); # PICTURE TYPE #
ITEM VARVALTYPE U(00,36,06); # VALIDATION TYPE #
ITEM VARVALR B(00,40,01); # RANGE VALIDATION #
ITEM VARVALM B(00,41,01); # MATCH VALIDATION #
ITEM VARVALOS U(00,42,18); # VALIDATION OFFSET #
ITEM VARNME C(01,00,07); # VARIABLE NAME (DISPLAY CODE) #
ITEM VARHSOS U(01,42,18); # HELP STRING OFFSET #
END
BASED ARRAY VAR2LIST [0:0] S(2); # VARIABLE LIST FOR *SFATTR* #
BEGIN
ITEM VAR2FLDNUM U(00,01,09); # FIELD ORDINAL #
ITEM VAR2ARRORD U(00,18,05); # ARRAY ORDINAL #
ITEM VAR2TYPE U(00,26,02); # VARIABLE TYPE (INT CHAR REAL) #
ITEM VAR2NME C(01,00,07); # VARIABLE NAME (DISPLAY CODE) #
END
BASED ARRAY VDATA [0:0] P(1); # VAR DATA #
BEGIN
ITEM VDATAC C(00,00,10); # VARDATA WORD (CHARACTER) #
ITEM VDATAU U(00,00,60); # VARDATA WORD (INTEGER) #
END
ARRAY CHARCONV1 [0:127] P(1); # DISPLAY CODE TO ASCII8 #
BEGIN
ITEM DC2A8 U(00,00,60)= [
O"0072", O"0101", O"0102", O"0103", # COLON A B C #
O"0104", O"0105", O"0106", O"0107", # D E F G #
O"0110", O"0111", O"0112", O"0113", # H I J K #
O"0114", O"0115", O"0116", O"0117", # L M N O #
O"0120", O"0121", O"0122", O"0123", # P Q R S #
O"0124", O"0125", O"0126", O"0127", # T U V W #
O"0130", O"0131", O"0132", O"0060", # X Y Z 0 #
O"0061", O"0062", O"0063", O"0064", # 1 2 3 4 #
O"0065", O"0066", O"0067", O"0070", # 5 6 7 8 #
O"0071", O"0053", O"0055", O"0052", # 9 PLUS MINUS ASTERISK #
O"0057", O"0050", O"0051", O"0044", # SLANT LPAREN RPAREN DOLLAR #
O"0075", O"0040", O"0054", O"0056", # EQUAL BLANK COMMA PERIOD #
O"0043", O"0133", O"0135", O"0045", # POUND LBRAC RBRAC PERCENT #
O"0042", O"0137", O"0041", O"0046", # QUOTE UNDERLINE XPOINT AMPER #
O"0047", O"0077", O"0074", O"0076", # APOSTROPHE QMARK LTHAN GTHAN #
O"0100", O"0134", O"0136", O"0073", # ATSIGN REVSLANT CIRCUM SEMI #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040", # BLANK FILL #
O"0040", O"0040", O"0040", O"0040"]; # BLANK FILL #
END
ARRAY CHARCONV2 [0:127] P(1); # ASCII8 TO DISPLAY CODE #
BEGIN
ITEM A82DC U(00,00,60)= [
O"55", O"55", O"55", O"55", # BLANK FILL #
O"55", O"55", O"55", O"55", # BLANK FILL #
O"55", O"55", O"55", O"55", # BLANK FILL #
O"55", O"55", O"55", O"55", # BLANK FILL #
O"55", O"55", O"55", O"55", # BLANK FILL #
O"55", O"55", O"55", O"55", # BLANK FILL #
O"55", O"55", O"55", O"55", # BLANK FILL #
O"55", O"55", O"55", O"55", # BLANK FILL #
O"55", O"66", O"64", O"60", # BLANK XMARK QUOTE POUND #
O"53", O"63", O"67", O"70", # DOLLAR PERCENT AMPER APOS #
O"51", O"52", O"47", O"45", # LPAREN RPAREN ASTERISK PLUS #
O"56", O"46", O"57", O"50", # COMMA MINUS PERIOD SLANT #
O"33", O"34", O"35", O"36", # 0 1 2 3 #
O"37", O"40", O"41", O"42", # 4 5 6 7 #
O"43", O"44", O"00", O"77", # 8 9 COLON SEMI #
O"72", O"54", O"73", O"71", # LTHAN EQUAL GTHAN QMARK #
O"74", O"01", O"02", O"03", # ATSIGN UCA UCB UCC #
O"04", O"05", O"06", O"07", # UCD UCE UCF UCG #
O"10", O"11", O"12", O"13", # UCH UCI UCJ UCK #
O"14", O"15", O"16", O"17", # UCL UCM UCN UCO #
O"20", O"21", O"22", O"23", # UCP UCQ UCR UCS #
O"24", O"25", O"26", O"27", # UCT UCU UCV UCW #
O"30", O"31", O"32", O"61", # UCX UCY UCZ LBRAC #
O"75", O"62", O"76", O"65", # RSLANT RBRAC CIRCUM ULINE #
O"74", O"01", O"02", O"03", # GRAVE LCA LCB LCC #
O"04", O"05", O"06", O"07", # LCD LCE LCF LCG #
O"10", O"11", O"12", O"13", # LCH LCI LCJ LCK #
O"14", O"15", O"16", O"17", # LCL LCM LCN LCO #
O"20", O"21", O"22", O"23", # LCP LCQ LCR LCS #
O"24", O"25", O"26", O"27", # LCT LCU LCV LCW #
O"30", O"31", O"32", O"61", # LCX LCY LCZ LBRAC #
O"75", O"62", O"76", O"55"]; # VLINE RBRAC TILDE DEL(NO EQ) #
END
ARRAY CHARCONV3 [1:7] P(1); # SPECIAL ASCII CODES #
BEGIN
ITEM AS2A8 U(00,00,60)= [
O"0100", O"0136", O"0040", # ATSIGN CIRCUMFLEX (BLANK) #
O"0072", O"0040", O"0040", # COLON (BLANK) (BLANK) #
O"0140"]; # RSLANT #
END
CONTROL EJECT;
ARRAY TERMSTAT [0:0] P(15); # TERMINAL STATUS FLAGS #
BEGIN
ITEM TERMSTATWD U(00,00,60) = [0]; # FULL WORD #
ITEM TERABNTERM B(00,00,01); # ABNORMAL TERMINATION #
ITEM TERASCFLAG B(00,01,01); # ASCII CODE SET FLAG #
ITEM TERAS8FLAG B(00,02,01); # ASCII8 CODE SET FLAG #
ITEM TERCURSSET B(00,03,01); # CURSOR SET BY SFSETP$ #
ITEM TERCNWRIOV B(00,04,01); # OVERLAY WRITE ALLOWED #
ITEM TERDONTCLR B(00,05,01); # RESPECT ENTERED/REWRITE #
ITEM TERFUNCGEN B(00,06,01); # GENERIC FUNCTION KEY FLAG #
ITEM TERHELPREQ B(00,07,01); # HELP REQUESTED #
ITEM TERMESREAD B(00,08,01); # MESSAGE READ BY USER #
ITEM TERMESWRIT B(00,09,01); # MESSAGE WRITTEN #
ITEM TERMISSINP B(00,10,01); # INPUT OUTSIDE OF FIELD #
ITEM TERNOINVRS B(00,11,01); # NO INPUT VARIABLES IN PANEL #
ITEM TERNOREWRT B(00,12,01); # NOT REWRITING VARIABLES #
ITEM TERNRMTERM B(00,13,01); # NORMAL TERMINATION #
ITEM TERPENDHLP B(00,14,01); # HELP (AFTER SOFT TABS) #
ITEM TERREADFLG B(00,15,01); # CALLING PROCEDURE IS READ #
ITEM TERREWFLDS B(00,16,01); # REWRITE FIELDS #
ITEM TERREWSCRN B(00,17,01); # COMPLETE SCREEN REWRITE #
ITEM TERSCREENM B(00,18,01); # SCREEN/LINE MODE FLAG #
ITEM TERSHOWFLG B(00,19,01); # CALLING PROCEDURE IS SHOW #
ITEM TERVDTBOOC B(00,20,01); # CALLED VDTBOO YET FLAG #
ITEM TERRESERV0 U(00,21,37); # RESERVED #
ITEM TERQTRMSOL B(00,58,01); # QTRM SCREEN OR LINE FLAG #
ITEM TERWAITINP B(00,59,01); # QTRM WAITING FOR INPUT #
ITEM TERACTPANL C(01,00,07) = [" "]; # ACTIVE PANEL NAME #
ITEM TERACTPLTI I(01,42,18) = [0]; # GLOBAL ACTIVE PLT INDEX #
ITEM TERHEADTHR U(02,00,60); # WORD THREE #
ITEM TERPTRHGTC U(02,00,04); # PROTECTED RIGHT BEHAVIOR #
ITEM TERPTLEFTC U(02,04,04); # PROTECTED LEFT BEHAVIOR #
ITEM TERPTUPCUR U(02,08,04); # PROTECTED UP BEHAVIOR #
ITEM TERPTDNCUR U(02,12,04); # PROTECTED DOWN BEHAVIOR #
ITEM TERUNRHGTC U(02,16,04); # UNPROTECTED RIGHT BEHAVIOR #
ITEM TERUNLEFTC U(02,20,04); # UNPROTECTED LEFT BEHAVIOR #
ITEM TERUNUPCUR U(02,24,04); # UNPROTECTED UP BEHAVIOR #
ITEM TERUNDNCUR U(02,28,04); # UNPROTECTED DOWN BEHAVIOR #
ITEM TERRESERV2 U(02,32,28); # RESERVED #
ITEM TERHEADFOU U(03,00,60); # WORD FOUR #
ITEM TERCURADDT U(03,00,06); # CURSOR ADDRESSING TYPE #
ITEM TERCURBIAS I(03,06,08); # CURSOR BIAS FOR POSTIONING #
ITEM TERLEFTCUR U(03,14,04); # CURSOR LEFT BEHAVIOR #
ITEM TERRGHTCUR U(03,18,04); # CURSOR RIGHT BEHAVIOR #
ITEM TERUPCURSR U(03,22,04); # CURSOR UP BEHAVIOR #
ITEM TERDWNCRSR U(03,26,04); # CURSOR DOWN BEHAVIOR #
ITEM TERLEFTCHR U(03,30,04); # CHARACTER LEFT BEHAVIOR #
ITEM TERRGHTCHR U(03,34,04); # CHARACTER RIGHT BEHAVIOR #
ITEM TERLASTPOS U(03,38,04); # LAST POSITION BEHAVIOR (CHAR) #
ITEM TERXFIRSTY B(03,42,01); # X BEFORE Y IN CURSOR OUTPUT #
ITEM TERXDECIML U(03,43,03); # X COORDINATE COUNT IF DECIMAL #
ITEM TERYDECIML U(03,46,03); # Y COORDINATE COUNT IF DECIMAL #
ITEM TERRESERV3 U(03,49,11); # RESERVED #
ITEM TERHEADFIV U(04,00,60); # WORD FIVE #
ITEM TERVTHOMEU B(04,00,01); # HOME UP FLAG #
ITEM TERPROTECT B(04,01,01); # TERMINAL HAS PROTECT #
ITEM TERVTDIFSS B(04,02,01); # DIFFERENT SCREEN SIZES #
ITEM TERVTUNUSD B(04,03,01); # UNUSED #
ITEM TERGUARDMD B(04,04,01); # TERMINAL HAS GUARD/HIDDEN MODE #
ITEM TERTABHOME B(04,05,01); # PROTECTED TAB GOES TO HOME #
ITEM TERTABPROT B(04,06,01); # TABS TO UNPROTECTED FIELDS #
ITEM TERVTABSTP B(04,07,01); # TABS TO TAB STOP #
ITEM TERSIZECLR B(04,08,01); # SIZE CHANGE CLEARS SCREEN #
ITEM TERTABAUTO B(04,09,01); # TERMINAL HAS AUTOMATIC TABBING #
ITEM TERTYPHEAD B(04,10,01); # TYPE AHEAD ENABLED #
ITEM TERBLCKMDE B(04,11,01); # BLOCK MODE TERMINAL #
ITEM TERPTDWFLN B(04,12,01); # PROT TABS DO NOT WRAP FWD LINE #
ITEM TERPTDWFPG B(04,13,01); # PROT TABS WILL NOT WRAP PAGE #
ITEM TERPTDWBLN B(04,14,01); # PROT TABS DO NOT WRAP BKW LINE #
ITEM TERPTDWBPG B(04,15,01); # PROT TABS DO NOT WRAP BKW PAGE #
ITEM TERUNDWFLN B(04,16,01); # UNPROT TABS DO NOT WRAP FWD LN #
ITEM TERUNDWFPG B(04,17,01); # UNPROT TABS DO NOT WRAP FWD PG #
ITEM TERUNDWBLN B(04,18,01); # UNPROT TABS DO NOT WRAP BKW LN #
ITEM TERUNDWBPG B(04,19,01); # UNPROT TABS DO NOT WRAP BKW PG #
ITEM TERATTRCHR B(04,20,01); # ATTRIBUTE CHARACTER NEEDS BYTE #
ITEM TERATTRSET B(04,21,01); # RESET ATTRIBUTES BEFORE VDTPOS #
ITEM TERSNDSPLR B(04,22,01); # SEND DISPLAY REWRITE FOR SFORM #
ITEM TERSNDSPLH B(04,23,01); # SEND DISPLAY ON HELP FOR SFORM #
ITEM TERNOTMASK B(04,24,01); # ATTRIBUTES ARE NOT MASKABLE #
ITEM TERNOTCHAR B(04,25,01); # ATTRIBUTES ARE LINE/PAGE BASED #
ITEM TERNOVDTEO B(04,26,01); # DISABLE OUTPUT END (ERR. EXIT) #
ITEM TERPROCLRS B(04,27,01); # PROTECT ALL CLEARS THE SCREEN #
ITEM TERCLEARSM B(04,28,01); # CLEARS ACROSS PROTECTED FIELDS #
ITEM TERRSBIT29 B(04,29,01); # RESERVED FOR CDC (FUTURE CODE) #
ITEM TERRSBIT30 B(04,30,01); # RESERVED FOR CDC (FUTURE CODE) #
ITEM TERRSBIT31 B(04,31,01); # RESERVED FOR CDC (FUTURE CODE) #
ITEM TERRSBIT32 B(04,32,01); # RESERVED FOR CDC (FUTURE CODE) #
ITEM TERRSBIT33 B(04,33,01); # RESERVED FOR CDC (FUTURE CODE) #
ITEM TERRSBIT34 B(04,34,01); # RESERVED FOR CDC (FUTURE CODE) #
ITEM TERRSBIT35 B(04,35,01); # RESERVED FOR CDC (FUTURE CODE) #
ITEM TERRSBIT36 B(04,36,01); # RESERVED FOR CDC (FUTURE CODE) #
ITEM TERINSTL01 B(04,37,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL02 B(04,38,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL03 B(04,39,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL04 B(04,40,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL05 B(04,41,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL06 B(04,42,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL07 B(04,43,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL08 B(04,44,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL09 B(04,45,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL10 B(04,46,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL11 B(04,47,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL12 B(04,48,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL13 B(04,49,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL14 B(04,50,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL15 B(04,51,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL16 B(04,52,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL17 B(04,53,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL18 B(04,54,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL19 B(04,55,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERINSTL20 B(04,56,01); # RESERVED FOR INSTALLATION CODE #
ITEM TERLEAVESM U(04,57,03); # FUNCTION KEY MARK COUNT #
ITEM TERSOFTPOS I(05,00,24); # POSITION OF FIRST SOFT TAB #
ITEM TERCURSOFF I(05,24,18); # CURSOR OFFSET POSITION #
ITEM TERCURSROW I(05,42,18); # CURSOR ROW POSITION #
ITEM TERCURSVAR C(06,00,07); # CURSOR VARIABLE POSITION #
ITEM TERASC8ATD U(06,42,06) = [58];# ASCII FOR 6/12 AT/D #
ITEM TERSOFTTAB I(06,48,12); # NUMBER OF SOFT TABS PENDING #
ITEM TERPREVPOS U(07,00,60); # PREVIOUS ATTRIBUTE POSITION #
ITEM TERFLDADDR U(08,00,60); # FIELD LIST ADDRESS #
ITEM TERFLDFRST I(09,00,30); # POSITION OF FIRST INPUT FIELD #
ITEM TERFLDLAST I(09,30,30); # POSITION OF LAST INPUT FIELD #
ITEM TERFUNCPOS U(10,00,24) = [0]; # LAST FUNCTION KEY POSITION #
ITEM TERFUNCORD I(10,24,12); # FUNCTION KEY ORDINAL #
ITEM TERHELPFLD I(10,36,24) = [0]; # HELP FIELD INDEX #
ITEM TERMODNAME C(11,00,07) = [" "]; # TERMINAL MODEL NAME #
ITEM TERXXXXXXX U(11,42,18); # RESERVED FOR FUTURE (CDC) USE #
ITEM TERNUMCOLS U(12,00,60) = [0]; # NUMBER OF COLUMNS ON SCREEN #
ITEM TERNUMLNES U(13,00,60) = [0]; # NUMBER OF LINES ON SCREEN #
ITEM TERCURVORD I(14,00,60); # CURRENT VIDEO ATTR. ORDINAL #
END
*IF DEF,QTRM
CONTROL EJECT;
DEF FDASIZE #17#; # FIELD DATA AREA - QTRM SWAP #
DEF PLTSIZE #22#; # PANEL LOAD TABLE - QTRM SWAP #
DEF Q$HEADLEN #3#; # QTRM QUEUE HEADER LENGTH #
DEF Q$BLKSIZE #1000#; # QTRM BUFFER LENGTH #
DEF SFORMOFFSET #00#; # PANEL CONTROL TABLE OFFSET #
DEF SFORMSIZE #15#; # SFORM VARIABLES - QTRM SWAP #
DEF VDTASIZE #20#; # VARIABLE DATA - QTRM SWAP #
DEF VTERMSIZE #O"336"#; # VIRTERM VARIABLES - QTRM SWAP #
DEF FDAOFFSET #VTERMOFFSET+VTERMSIZE#;
DEF PCTSIZE #SFORMSIZE+VTERMSIZE+FDASIZE+PLTSIZE+VDTASIZE #;
DEF PLTOFFSET #FDAOFFSET+FDASIZE#;
DEF VDTAOFFSET #PLTOFFSET+PLTSIZE#;
DEF VTERMOFFSET #SFORMOFFSET+SFORMSIZE#;
CONTROL EJECT;
COMMON COMVDT; # VIRTERM COMMON AREA #
BEGIN # COMVDT #
ARRAY COMVDT$WDS [0:0] P(VTERMSIZE); # TEMPORARY VIRTERM AREA #
BEGIN
ITEM COMVDT$WD0 U(00,00,60); # WORD ZERO (INTEGER) #
END
END # COMVDT #
ARRAY TERMSTHLD [0:0] P(SFORMSIZE); # TERMSTAT HOLD AREA #
BEGIN
ITEM TERINITHLD U(00,00,60); # WORD ZERO (INTEGER) #
END
ARRAY VDTSTHLD [0:0] P(VTERMSIZE); # VIRTERM HOLD AREA (INIT) #
BEGIN
ITEM VDTINITHLD U(00,00,60); # WORD ZERO (INTEGER) #
END
*ENDIF
CONTROL EJECT;
FUNC NEXTCHAR(FLDIND,INDEX);
# TITLE NEXTCHAR - GET NEXT CHARACTER FROM VARDATA. #
BEGIN # NEXTCHAR #
#
** NEXTCHAR - GETS THE NEXT CHARACTER FROM VARDATA.
*
* THIS FUNCTION RETURNS THE CHARACTER IN POSITION INDEX OF VARIABLE
* FLDIND IN VARDATA.
*
* FUNC NEXTCHAR(FLDIND,INDEX)
*
* FLDIND = POINTER INTO FIELD LIST FOR VARIABLE.
* INDEX = RELATIVE POSITION OF CHARACTER IN VARDATA.
*
* EXIT CHARACTER FROM VARDATA.
#
ITEM FLDIND; # VARLIST POINTER OF VARIABLE #
ITEM INDEX; # RELATIVE POSITION OF CHARACTER #
ITEM CHARIND; # CHARACTER INDEX IN VARDATA #
ITEM CHARNUM; # CHARACTER POSITION IN VARDATA #
ITEM WORDIND; # WORD INDEX IN VARDATA #
CHARNUM = FLDVDTCORD[FLDIND] + INDEX;
WORDIND = CHARNUM / 5;
CHARIND = CHARNUM - 5*WORDIND;
NEXTCHAR = B<12*CHARIND,12>VDATAU[WORDIND];
END # NEXTCHAR #
CONTROL EJECT;
FUNC UPPER(CHARAC);
# TITLE UPPER - CONVERT CHARACTER TO UPPER CASE. #
BEGIN # UPPER #
#
** UPPER - CONVERT CHARACTER TO UPPER CASE.
*
* UPPER CONVERTS LOWER CASE CHARACTERS TO UPPER CASE AND
* LEAVES UPPER CASE CHARACTERS ALONE.
*
* PROC UPPER(CHARAC)
*
* ENTRY CHARAC = CHARACTER TO BE CONVERTED.
*
* EXIT UPPER CASE CHARACTER.
#
ITEM CHARAC; # CHARACTER TO BE CONVERTED #
IF CHARAC GQ LOWA AND CHARAC LQ LOWZ THEN
BEGIN # IF LOWER CASE #
UPPER = CHARAC LXR BLANK; # CONVERT TO LOWER CASE #
END
ELSE
BEGIN # IF UPPER CASE #
UPPER = CHARAC; # DON'T CONVERT #
END
END # UPPER #
CONTROL EJECT;
PROC SFATTR$(NAME,NLENGTH,NOFFSET,NEWORD,OLDORD);
# TITLE SFATTR$ - SET FIELD ATTRIBUTES. #
BEGIN # SFATTR$ #
#
** SFATTR$ - SET FIELD ATTRIBUTES.
*
* THIS PROCEDURE SETS NEW FIELD ATTRIBUTES FOR A VARIABLE FIELD.
*
* PROC SFATTR$(NAME,NLENGTH,NOFFSET,NEWORD,OLDORD)
*
* ENTRY NAME = NAME OF VARIABLE FIELD TO BE CHANGED.
* NLENGTH = LENGTH IN SIX BIT CHARACTERS.
* NOFFSET = OFFSET INTO VARIABLE NAME.
* NEWORD = NEW ATTRIBUTE ORDINAL.
*
* EXIT OLDORD = OLD ATTRIBUTE ORDINAL.
* = - 3 IF ORDINAL NOT LEGAL.
* = - 2 IF FIELD NOT FOUND IN PANEL.
* = - 1 IF ATTRIBUTE NOT FOUND IN PANEL.
*
* USES TERREWFLDS.
#
ITEM NAME C(11); # NAME OF VARIABLE FIELD #
ITEM NLENGTH I; # LENGTH IN SIX BIT CHARACTERS #
ITEM NOFFSET I; # OFFSET INTO NAME #
ITEM NEWORD I; # REQUESTED ATTRIBUTE ORDINAL #
ITEM OLDORD I; # OLD ATTRIBUTE ORDINAL #
ITEM FLDINDEX I; # INDEX INTO FIELD LIST #
ITEM FIELDNAME C(7); # FIELD NAME, LEFT JUSTIFIED #
ITEM I I; # LOOP COUNTER #
ARRAY ATTRIBUTES [0:0] P(1); # HOLDS OLD AND NEW ATTRIBUTES #
BEGIN
ITEM ATTFULLONE U(00,00,60); # FULL WORD #
ITEM ATTUNUSED U(00,00,18); # UNUSED #
ITEM ATTINDEX I(00,18,18); # INDEX INTO ATTRIBUTE LIST #
ITEM ATTNEWMASK U(00,36,12); # TWELVE BIT ATTRIBUTE MASK #
ITEM ATTNEWLOGI B(00,36,01); # LOGICAL OR PHYSICAL ATTRIBUTE #
ITEM ATTNEWPROT B(00,37,01); # PROTECT #
ITEM ATTNEWGARD B(00,38,01); # GUARD MODE #
ITEM ATTNEWLORD U(00,42,06); # LOGICAL ORDINAL #
ITEM ATTOLDMASK U(00,48,12); # TWELVE BIT ATTRIBUTE MASK #
ITEM ATTOLDLOGI B(00,48,01); # LOGICAL OR PHYSICAL ATTRIBUTE #
ITEM ATTOLDPROT B(00,49,01); # PROTECT #
ITEM ATTOLDGARD B(00,50,01); # GUARD MODE #
ITEM ATTOLDLORD U(00,54,06); # LOGICAL ORDINAL #
END
ARRAY ATTMORDNLS [0:35] P(1); # ATTRIBUTE MASK BY ORDINAL #
BEGIN
ITEM ATTMASKORD U(00,00,60) = [
O"6000", O"5000", O"4000", O"6001", O"5001", # 0 1 2 3 4 #
O"4001", O"6002", O"5002", O"4002", O"6003", # 5 6 7 8 9 #
O"5003", O"4003", O"6004", O"5004", O"4004", # 10 11 12 13 14 #
O"6005", O"5005", O"4005", O"6006", O"5006", # 15 16 17 18 19 #
O"4006", O"6007", O"5007", O"4007", O"6010", # 20 21 22 23 24 #
O"5010", O"4010", O"6011", O"5011", O"4011", # 25 26 27 28 29 #
O"6012", O"5012", O"4012", O"6013", O"5013", # 30 31 32 33 34 #
O"4013"]; # 35 #
END
IF NLENGTH LS 1 THEN NLENGTH = 7; # CRACK PARAMETER #
FIELDNAME = C<NOFFSET,NLENGTH>NAME;
OLDORD = - 3; # PRESET ORDINAL NOT LEGAL #
IF NEWORD LS 0 OR NEWORD GQ 36 THEN RETURN;
OLDORD = - 2; # PRESET FIELD NOT FOUND #
ATTFULLONE[0] = 0; # CLEAR WORD #
FLDINDEX = -1;
FOR I = 0 STEP 1 WHILE VAR2TYPE[I] NQ 0 AND FLDINDEX EQ - 1 DO
BEGIN # LOOK FOR VARIABLE VARNAME #
IF VAR2NME[I] EQ FIELDNAME THEN
BEGIN # FOUND SPECIFIED VARIABLE #
FLDINDEX = I;
END
END
IF FLDINDEX NQ -1 THEN
BEGIN # IF FIELD FOUND IN VAR2LIST #
IF VAR2ARRORD[FLDINDEX] NQ 0 THEN
BEGIN # IF ARRAY MEMBER #
FLDINDEX = FLDINDEX + # FIND THAT FIELD #
ARR2NUMVAR[VAR2ARRORD[FLDINDEX]-1] *
ARR2CURROW[VAR2ARRORD[FLDINDEX]-1];
END
FLDINDEX = VAR2FLDNUM[FLDINDEX] - 1;
ATTNEWMASK[0] = ATTMASKORD[NEWORD];
ATTOLDMASK[0] = ATT2MASK[FLD2ATTORD[FLDINDEX]];
IF PAN2STRARR NQ 0 THEN
BEGIN # IF TABLE(S) IN PANEL #
OLDORD = PAN2STRARR[0] - PAN2STRATT[0];
END
ELSE
BEGIN # NO TABLES #
IF PAN2STRBOX NQ 0 THEN
BEGIN # IF BOXES #
OLDORD = PAN2STRBOX[0] - PAN2STRATT[0];
END
ELSE
BEGIN # NO BOXES OR TABLES #
OLDORD = (PAN2RECLEN[0] - PAN2STRATT[0]) - 1;
END
END
ATTINDEX[0] = 0; # SEARCH ATTRIBUTE LIST IN PANEL #
WHYLE ATT2MASK[ATTINDEX[0]] NQ ATTNEWMASK[0] AND
ATTINDEX[0] LS OLDORD DO
BEGIN # UNTIL END OF PANEL ATTRIBUTES #
ATTINDEX[0] = ATTINDEX[0] + 1;
END
IF ATTINDEX[0] LS OLDORD THEN
BEGIN # IF NEW ATTRIBUTE IS IN PANEL #
OLDORD = - 1; # PRESET BAD OLD ATTRIBUTE #
IF ATTOLDLOGI[0] THEN
BEGIN # IF OLD ATTRIBUTE WAS LOGICAL #
OLDORD = 0; # SEARCH ATTMORDNLS LIST #
WHYLE ATTOLDMASK[0] NQ ATTMASKORD[OLDORD] AND OLDORD LS 36 DO
BEGIN # UNTIL END OF ATTMORDNLS #
OLDORD = OLDORD + 1;
END
IF OLDORD GQ 36 THEN OLDORD = - 1;
END
ELSE
BEGIN # PHYSICAL ATTRIBUTES #
IF ATTOLDPROT[0] THEN
BEGIN # IF OUTPUT ONLY #
ATTINDEX[0] = 2;
OLDORD = 3;
END
ELSE
BEGIN # NOT OUTPUT ONLY #
IF NOT ATTOLDGARD[0] THEN
BEGIN # IF INPUT OUTPUT #
ATTINDEX[0] = 1;
OLDORD = 2;
END
END
END
IF OLDORD GQ 0 THEN
BEGIN # IF CHANGE IS INDEED POSSIBLE #
FLD2ATTORD[FLDINDEX] = ATTINDEX[0];
TERREWFLDS[0] = TRUE; # SIGNAL FIELD REWRITE #
FLD2VALID[FLDINDEX] = FALSE; # RESET FIELD STATUS-S #
FLD2REWRIT[FLDINDEX] = TRUE;
FLD2ENTERE[FLDINDEX] = FALSE;
IF ATTNEWGARD[0] THEN
BEGIN # IF NEW MASK SHOWS GUARD #
FLD2INPUTV[FLDINDEX] = TRUE;
FLD2OUTPUT[FLDINDEX] = FALSE;
END
ELSE
BEGIN # NO GUARD #
IF ATTNEWPROT[0] THEN
BEGIN # IF NEW MASK SHOWS PROTECT #
FLD2INPUTV[FLDINDEX] = FALSE;
FLD2OUTPUT[FLDINDEX] = TRUE;
END
ELSE
BEGIN # NO GUARD OR PROTECT #
FLD2INPUTV[FLDINDEX] = TRUE;
FLD2OUTPUT[FLDINDEX] = TRUE;
END
END
END
END
ELSE
BEGIN # NEW ATTRIBUTE NOT IN PANEL #
OLDORD = - 1; # CHANGE NOT POSSIBLE #
END
END
END # SFATTR$ #
CONTROL EJECT;
PROC SFCLOS$(NAME,NLENGTH,NOFFSET,MODEFLAG);
# TITLE SFCLOS$ - CLOSE PANEL. #
BEGIN # SFCLOS$ #
#
** SFCLOS$ - CLOSE PANEL.
*
* THIS PROCEDURE CLOSES THE SPECIFIED PANEL (UNLOADING IT USING
* THE FAST DYNAMIC LOADER IF IT IS NOT A STATICALLY LOADED PANEL)
* AND UPDATES THE PANEL LOAD TABLE TO REFLECT THE UNLOAD. IN ADD-
* ITION IF THE MODEFLAG IS SET TO ONE THE TERMINAL WILL BE RESET
* TO LINE MODE AND THE SCREEN CLEARED, IF THE MODEFLAG IS SET TO
* TWO THE TERMINAL WILL BE RESET TO LINE MODE WITH NO CHANGE TO
* THE DATA ON THE SCREEN.
*
* PROC SFCLOS$(NAME,NLENGTH,NOFFSET,MODEFLAG)
*
* ENTRY NAME = NAME OF PANEL TO BE CLOSED.
* NLENGTH = LENGTH IN SIX BIT CHARACTERS.
* NOFFSET = OFFSET INTO NAME.
* MODEFLAG = 0, REMAIN IN SCREEN MODE.
* 1, RESET TERMINAL TO LINE MODE,
* CLEAR SCREEN.
* 2, RESET TERMINAL TO LINE MODE.
*
* EXIT PANEL UNLOADED IF POSSIBLE, PLT UPDATED, TERMINAL
* SET TO LINE MODE IF MODEFLAG IS NON ZERO, SCREEN
* CLEARED IF MODEFLAG EQUAL TO ONE.
*
* CALLS ERRMSG, UCP, VDTBOO, VDTCLO, VDTCLS, VDTMSG$, VDTPOS,
* VDTSTM.
*
* USES TERACTIVEP, TERACTPANI, TERCNWRIOV, TERREADFLG,
* TERMESREAD, TERMESWRIT, TERSCREENM, TERSHOWFLG.
#
ITEM NAME C(11); # NAME OF PANEL TO CLOSE #
ITEM NLENGTH I; # LENGTH IN SIX BIT CHARACTERS #
ITEM NOFFSET I; # OFFSET INTO NAME #
ITEM MODEFLAG I; # FLUSH OUTPUT/CLEAR SCREEN FLAG #
ITEM BLANKNAME C(7) = " "; # BLANK PANEL NAME #
ITEM FATAL B = FALSE; # NOT A FATAL ERROR #
ITEM LINE I = 0; # INDICATES LINE MODE TO VDT #
ITEM MSG C(25); # DAYFILE ERROR MESSAGE #
ITEM MSGB I = 0; # BLANK B DISPLAY #
ITEM NAMEINDEX I; # INDEX OF PANEL IF FOUND #
ITEM NUMBER I; # ON SCREEN SEQUENCE NUMBER #
ITEM PANELADDR I; # MEMORY ADDRESS OF PANEL #
ITEM PANELNAME C(7); # PANEL NAME, LEFT JUSTIFIED #
ITEM PLTCOUNT I; # COUNTER TO MOVE UP ENTRIES #
ITEM PLTINDEX I; # INDEX INTO PANEL LOAD TABLE #
ITEM PNAME C(6) = "SFCLOS"; # PROCEDURE NAME #
ITEM RECALL I = 1; # RECALL PARAMTER FOR VDTCLO #
ITEM UNLOADSTAT I; # UNLOAD STATUS FROM F.D.L. #
IF NLENGTH LS 1 THEN NLENGTH = 7; # CRACK PARAMETER #
PANELNAME = C<NOFFSET,NLENGTH>NAME; # LEFT JUSTIFY PANEL NAME #
*IF UNDEF,QTRM
P<PLTABLE> = LOC(PLT); # REFERENCE PANEL LOAD TABLE #
*ELSE
P<PLTABLE> = NIT$PCT[NIT$CON] + PLTOFFSET; # REFERENCE USER PLT #
SFCLOS1:
*ENDIF
PANELADDR = 0;
FOR PLTINDEX = 1 STEP 1 WHILE
PANELADDR EQ 0 AND PLTINDEX LQ PLTNUMENT[0] DO
BEGIN # CHECK FOR PANEL NAME IN TABLE #
IF PLTENAME[PLTINDEX] EQ PANELNAME THEN
BEGIN # IF PANEL NAME FOUND #
PANELADDR = PLTADDR[PLTINDEX]; # SAVE ADDRESS OF PANEL RECORD #
NAMEINDEX = PLTINDEX; # SAVE INDEX INTO PLT #
END
END
IF PANELADDR NQ 0 THEN
BEGIN # IF PANEL NAME IN TABLE #
*IF DEF,QTRM
IF P<PLTABLE> NQ LOC(PLT) THEN
BEGIN # IF NOT GLOBAL PLT #
NUMBER = PLTENTRYNM[NAMEINDEX];
FOR PLTCOUNT = NAMEINDEX STEP 1 UNTIL PLTNUMENT[0] DO
BEGIN # MOVE ENTRIES UP #
PLTWORDONE[PLTCOUNT] = PLTWORDONE[PLTCOUNT+1];
PLTWORDTWO[PLTCOUNT] = PLTWORDTWO[PLTCOUNT+1];
END
PLTWORDONE[PLTNUMENT[0]] = 0; # CLEAR LAST ENTRY #
PLTWORDTWO[PLTNUMENT[0]] = 0;
PLTNUMENT[0] = PLTNUMENT[0] - 1;
IF NUMBER NQ 0 THEN
BEGIN # IF PANEL WAS ON SCREEN #
FOR PLTCOUNT = 1 STEP 1 UNTIL PLTNUMENT[0] DO
BEGIN # UPDATE SEQUENCE NUMBERS #
IF PLTENTRYNM[PLTCOUNT] GR NUMBER THEN
BEGIN
PLTENTRYNM[PLTCOUNT] = PLTENTRYNM[PLTCOUNT] -1;
END
END
PLTNUMONSC[0] = PLTNUMONSC[0] - 1;
END
P<PLTABLE> = LOC(PLT); # RESET FOR GLOBAL PLT #
GOTO SFCLOS1; # CONTINUE #
END
# DECREMENT COUNT IN GLOBAL PLT #
PLTNUMQTRM[NAMEINDEX] = PLTNUMQTRM[NAMEINDEX] - 1;
*ENDIF
NUMBER = PLTENTRYNM[NAMEINDEX];
IF PANELNAME EQ TERACTPANL[0] THEN
BEGIN # IF CLOSING ACTIVE PANEL #
TERACTPANL[0] = BLANKNAME;
TERACTPLTI[0] = 0;
END
*IF UNDEF,QTRM
IF NOT PLTSLFLAG[NAMEINDEX] THEN
*ELSE
IF NOT PLTSLFLAG[NAMEINDEX] AND PLTNUMQTRM[NAMEINDEX] EQ 0 THEN
*ENDIF
BEGIN # UNLOAD DYNAMIC PANEL #
UCP(PANELNAME,PANELADDR,UNLOADSTAT);
IF UNLOADSTAT NQ 0 THEN
BEGIN # ISSUE DAYFILE MESSAGE #
MSG = " NOT UNLOADED. ";
ERRMSG(PANELNAME,PNAME,MSG,FATAL);
END
FOR PLTCOUNT = NAMEINDEX STEP 1 UNTIL PLTNUMENT[0] DO
BEGIN # MOVE REMAINING ENTRIES UP ONE #
PLTWORDONE[PLTCOUNT] = PLTWORDONE[PLTCOUNT+1];
PLTWORDTWO[PLTCOUNT] = PLTWORDTWO[PLTCOUNT+1];
END
PLTWORDONE[PLTNUMENT[0]] = 0; # CLEAR LAST ENTRY IN TABLE #
PLTWORDTWO[PLTNUMENT[0]] = 0;
PLTNUMENT[0] = PLTNUMENT[0] - 1; # UPDATE NUMBER OF ENTRIES #
END
ELSE
BEGIN # CHECK STATUS OF STATIC PANEL #
IF PLTOPENFLG[NAMEINDEX] THEN
BEGIN # IF STATIC PANEL IS OPEN #
PLTOPENFLG[NAMEINDEX] = FALSE; # CLOSE STATIC PANEL #
PLTENTRYNM[NAMEINDEX] = 0; # CLEAR SEQUENCE NUMBER #
END
ELSE
BEGIN # IF STATIC PANEL ALREADY CLOSED #
MSG = " ALREADY CLOSED. ";
ERRMSG(PANELNAME,PNAME,MSG,FATAL);
END
END
IF NUMBER NQ 0 THEN
BEGIN # IF PANEL WAS ON SCREEN #
FOR PLTCOUNT = 1 STEP 1 UNTIL PLTNUMENT[0] DO
BEGIN # UPDATE SEQUENCE NUMBERS #
IF PLTENTRYNM[PLTCOUNT] GR NUMBER THEN
BEGIN
PLTENTRYNM[PLTCOUNT] = PLTENTRYNM[PLTCOUNT] - 1;
END
END
PLTNUMONSC[0] = PLTNUMONSC[0] - 1;
END
END
ELSE
BEGIN # IF PANEL NAME NOT IN TABLE #
MSG = " NOT IN PLT. ";
ERRMSG(PANELNAME,PNAME,MSG,FATAL);
END
IF MODEFLAG NQ 0 THEN
BEGIN
IF TERSCREENM[0] THEN
BEGIN # IF REVERSION TO LINE MODE #
TERSCREENM[0] = FALSE; # CLEAR FLAGS #
IF NOT TERVDTBOOC[0] THEN
BEGIN # IF BEGIN OUTPUT NEEDED #
TERVDTBOOC[0] = TRUE;
VDTBOO;
END
IF MODEFLAG EQ 1 THEN
BEGIN # IF SCREEN IS TO BE CLEARED #
VDTCLS; # CLEAR SCREEN #
END
ELSE
BEGIN # POSITION CURSOR TO LAST LINE #
VDTPOS(0,TERNUMLNES[0]);
END
FOR PLTCOUNT = 1 STEP 1 UNTIL PLTNUMENT[0] DO
BEGIN # CLEAR SEQUENCE NUMBERS #
PLTENTRYNM[PLTCOUNT] = 0;
END
PLTNUMONSC[0] = 0; # NO PANELS ON SCREEN #
TERMESWRIT[0] = FALSE;
TERMESREAD[0] = FALSE;
VDTSTM(LINE,DUMMY); # SET LINE MODE #
*IF UNDEF,QTRM
VDTCLO(RECALL); # FLUSH OUTPUT WITH RECALL #
IF TERBLCKMDE[0] THEN TERVDTBOOC[0] = FALSE;
*ENDIF
END
TERACTPANL[0] = " "; # CLEAR ACTIVE PANEL NAME #
TERACTPLTI[0] = 0; # CLEAR PLT INDEX #
TERCNWRIOV[0] = FALSE; # DO NOT ALLOW OVERLAY WRITE #
VDTMSG$(MSGB,1,1); # BLANK B DISPLAY MESSAGE #
TERSHOWFLG[0] = FALSE;
TERREADFLG[0] = FALSE;
END
END # SFCLOS$ #
CONTROL EJECT;
PROC SFCSET$(CSET,CLENGTH,COFFSET);
# TITLE SFCSET$ - SET CHARACTER SET. #
BEGIN # SFCSET$ #
#
** SFCSET$ - SET CHARACTER SET.
*
* THIS PROCEDURE SETS AND CLEARS THE GLOBAL FLAGS THAT INDICATE
* WHAT CHARACTER SET IS IN USE BY THE APPLICATION CALLING THE
* SCREEN FORMATTING OBJECT ROUTINES. IT INTERFACES TO COBOL AND
* FORTRAN APPLICATION PROGRAMS THROUGH A COMPASS INTERFACE MOD-
* ULE CALLED SFCSET.
*
* PROC SFCSET$(CSET,CLENGTH,COFFSET)
*
* ENTRY CSET = "DISPLAY", "ASCII", OR "ASCII8",
* IN DISPLAY CODE.
* CLENGTH = LENGTH IN SIX BIT CHARACTERS IN CHARSET.
* COFFSET = OFFSET INTO CHARSET.
*
* EXIT CORRECT CHARACTER SET FLAG SET, OTHERS CLEARED.
*
* USES TERASCFLAG, TERAS8FLAG.
*
* NOTES IF SFCSET$ IS CALLED WITH AN UNRECOGNIZABLE
* CHARACTER SET THEN THE DEFAULT CHARACTER SET
* (DISPLAY) WILL BE SET AND ALL OTHERS CLEARED.
* SFCSET$ ACCEPTS ONLY BLANK FILLED DISPLAY CODE
* STRINGS FOR THE CHARACTER SET.
#
ITEM CSET C(11); # CHAR. SET NAME IN DISPLAY CODE #
ITEM CLENGTH I; # LENGTH IN SIX BIT CHARACTERS #
ITEM COFFSET I; # OFFSET INTO CSET #
ITEM ASCII C(7) = "ASCII "; # ASCII (IN DISPLAY CODE ) #
ITEM ASCII8 C(7) = "ASCII8 "; # ASCII8 (IN DISPLAY CODE) #
ITEM SET C(7); # CHARACTER SET, LEFT JUSTIFIED #
IF CLENGTH LS 1 THEN CLENGTH = 7; # CRACK PARAMETER #
SET = C<COFFSET,CLENGTH>CSET;
IF SET EQ ASCII THEN
BEGIN # IF SIX TWELVE ASCII #
TERASCFLAG[0] = TRUE;
TERAS8FLAG[0] = FALSE;
END
ELSE
BEGIN
IF SET EQ ASCII8 THEN
BEGIN # IF TWELVE BIT ASCII #
TERASCFLAG[0] = FALSE;
TERAS8FLAG[0] = TRUE;
END
ELSE
BEGIN # SET DISPLAY CODE #
TERASCFLAG[0] = FALSE;
TERAS8FLAG[0] = FALSE;
END
END
END # SFCSET$ #
CONTROL EJECT;
PROC SFGETF$(VNAME,VLEN,VOS,STRG,SLEN,SOS,CSET,CLEN,COS,STAT);
BEGIN
#
** SFGETF$ - GET FIELD CHARACTER STRING.
*
* SFGETF$ TRANSFERS CHARACTERS FROM A SPECIFIED PANEL FIELD TO
* A SPECIFIED STRING, USING *MOVEFLD*.
*
* PROC SFGETF$(VNAME,VLEN,VOS,STRG,SLEN,SOS,CSET,CLEN,COS,STAT)
*
* ENTRY VNAME = VARIABLE NAME OF FIELD.
* VLEN = LENGTH OF VARNAME PARAMETER.
* VOS = OFFSET OF VARNAME PARAMETER.
* STRG = VARIABLE FIELD STRING.
* SLEN = LENGTH OF STRING PARAMETER.
* SOS = OFFSET OF STRING PARAMETER.
* CSET = CHARACTER SET OF STRING (SEE SFCSET$).
* CLEN = LENGTH OF CSET PARAMETER.
* COS = OFFSET OF CSET PARAMETER.
*
* EXIT STAT GQ 0, NUMBER OF 6 BIT CHARACTERS MOVED.
* LS 0, VARIABLE NOT FOUND IN ACTIVE PANELS.
*
* CALLS MOVEFLD.
#
ITEM VNAME I; # VARIABLE NAME #
ITEM VLEN I; # LENGTH OF VARNAME PARAMETER #
ITEM VOS I; # OFFSET INTO VARNAME PARAMETER #
ITEM STRG I; # INSTRING PARAMETER #
ITEM SLEN I; # LENGTH OF INSTRING #
ITEM SOS I; # OFFSET INTO INSTRING #
ITEM CSET I; # CHARACTER SET #
ITEM CLEN I; # LENGTH OF CHARACTER SET #
ITEM COS I; # OFFSET INTO CHARACTER SET #
ITEM STAT I; # STATUS FIELD #
STAT = 0;
MOVEFLD(VNAME,VLEN,VOS,STRG,SLEN,SOS,CSET,CLEN,COS,STAT);
RETURN;
END # SFGETF$#
*IF DEF,QTRM
CONTROL EJECT;
PROC SFDQUE$(QNAME,QLEN,QOFF,BUFFER,RC,LENGTH);
# TITLE SFDQUE$ - DEQUEUE A PIECE OF DATA FOR THIS TERMINAL. #
BEGIN # SFDQUE$ #
#
** SFDQUE$ - DEQUEUE A PIECE OF DATA FOR THIS TERMINAL.
*
* THIS PROCEDURE REMOVES *LENGTH* CHARACTERS FROM THE SPECIFIED
* QUEUE AND PLACES THE CHARACTERS INTO *BUFFER*. IT INTERFACES
* TO COBOL5 AND FTN5 APPLICATION PROGRAMS THROUGH A COMPASS
* INTERFACE CALLED SFDQUE.
*
* PROC SFDQUE$(QNAME,QLEN,QOFF,BUFFER,RC,LENGTH)
*
* ENTRY QNAME = QUEUE TO PLACE DATA INTO (GET OR PUT).
* QLEN = LENGTH OF QUEUE NAME.
* QOFF = OFFSET OF QUEUE NAME.
* LENGTH = BUFFER SIZE IN 12 BIT CHARACTERS.
*
* EXIT NIT$CTLC = COUNT OF CHARACTERS DEQUEUED.
* RC = 0, IF DATA DEQUEUED (NO ERROR).
* 1, IF MORE DATA AVAILABLE.
* 2, IF NO MESSAGES IN THE QUEUE.
* BUFFER = DEQUEUED DATA.
*
* CALLS CMMFRF.
#
ITEM QNAME C(7); # QUEUE NAME #
ITEM QLEN I; # QUEUE NAME LENGTH #
ITEM QOFF I; # QUEUE NAME OFFSET #
ARRAY BUFFER [0:0] P(1); # BUFFER #
BEGIN
ITEM B$WD0 U(00,00,60); # BUFFER WORD (INTEGER) #
END
ITEM RC I; # RETURN CODE #
ITEM LENGTH I; # BUFFER SIZE IN CHARACTERS #
ITEM BIT I; # BIT POSITION #
ITEM B$CURBIT I; # CURRENT BIT #
ITEM B$CURWORD I; # CURRENT WORD #
ITEM I I; # LOOP VARIABLE #
ITEM J I; # LOOP VARIABLE #
ITEM MAX$CHARS I; # MAXIMUM NUMBER OF CHARACTERS #
ITEM QUEUENAME C(7); # QUEUE NAME #
ITEM RCC I; # RETURN CODE #
ITEM WORD I; # BUFFER WORD #
B$CURBIT = 0; # POSITION TO START OF BUFFER #
B$CURWORD = 0;
P<Q$HEADER> = CHAIN;
IF QLEN LS 1 THEN QLEN = 7; # CRACK PARAMETER #
QUEUENAME = C<QOFF,QLEN>QNAME;
WHYLE P<Q$HEADER> NQ 0 DO
BEGIN # SEARCH FOR QUEUE FOR THIS ACN #
IF (( NIT$CON EQ Q$ACN ) AND
( C<0,3>QNAME EQ C<0,3>Q$NAME )) THEN
IF NIT$CON EQ Q$ACN AND QUEUENAME EQ Q$NAME THEN
BEGIN # IF QUEUE IS FOUND #
P<Q$BUFFER> = P<Q$HEADER> + Q$HEADLEN;
FOR I = 1 STEP 1 UNTIL LENGTH DO
BEGIN # MOVE THIS USER-S DATA #
WORD = Q$OUTCHAR / 5;
BIT = (Q$OUTCHAR - (WORD * 5)) * 12;
B<B$CURBIT,12> B$WD0[B$CURWORD] = B<BIT,12>Q$WORD[WORD];
Q$OUTCHAR = Q$OUTCHAR + 1;
B$CURBIT = B$CURBIT + 12;
IF B$CURBIT GQ 60 THEN
BEGIN # IF COMPLETE WORD MOVED #
B$CURBIT = 0;
B$CURWORD = B$CURWORD + 1;
END
IF Q$OUTCHAR GR Q$INCHAR THEN
BEGIN # IF #
NIT$CTLC = I - 1;
RC = 0;
Q$INCHAR = 0;
Q$OUTCHAR = 0;
RCC = P<Q$HEADER>; # ADDRESS FOR CMM #
I = Q$BACK; # BACK POINTER #
J = Q$FORWARD; # FORWARD POINTER #
P<Q$HEADER> = I; # SET TO PREVIOUS PTR WORD #
Q$FORWARD = J; # AND SET TO NEXT PTR WORD #
IF J NQ 0 THEN
BEGIN # IF NEXT PTR WORD EXISTS #
P<Q$HEADER> = J; # SET PTR TO PREVIOUS PTR WORD #
Q$BACK = I;
END
CMMFRF (RCC); # RELEASE BUFFER #
RETURN; # RETURN #
END
END
RC = 1; # USER-S BUFFER IS FULL #
NIT$CTLC = LENGTH;
RETURN; # RETURN #
END
P<Q$HEADER> = Q$FORWARD;
END
RC = 2; # NOTHING TO DEQUEUE #
END # SFDQUE$ #
*ENDIF
CONTROL EJECT;
PROC SFGETI$(VARNAME,VLEN,VOFF,VALUE);
# TITLE SFGETI$ - GET INTEGER VALUE. #
BEGIN # SFGETI$ #
#
** SFGETI$ - GET INTEGER VALUE.
*
* SFGETI$ RETURNS THE INTEGER NUMERIC VALUE OF THE FIELD
* SPECIFIED BY VARNAME AND ROWNUM.
*
* PROC SFGETI$(VARNAME,VLEN,VOFF,VALUE)
*
* ENTRY VARNAME = VARIABLE NAME OF FIELD.
* VLEN = LENGTH OF VARP.
* VOFF = OFFSET OF VARP.
*
* EXIT VALUE = INTEGER VALUE OF SPECIFIED FIELD.
*
* CALLS DATEVL, GFIELD, NCHECK.
#
ITEM VARNAME C(11); # VARIABLE NAME #
ITEM VLEN I; # LENGTH OF VARNAME PARAMETER #
ITEM VOFF I; # OFFSET INTO VARNAME PARAMETER #
ITEM VALUE I; # VALUE OF INPUT #
ITEM ALLBLANK B; # ALL BLANK CHARACTERS IN FIELD #
ITEM CURRENCY B; # TRUE IF DOLLAR SIGN INPUT #
ITEM ERRORVAL I = 0; # RETURNED IF ERROR IN FIELD #
ITEM EVALUE I; # EXPONENT VALUE #
ITEM FLDIND I; # FIELD ORDINAL #
ITEM FORMAT I; # FORMAT OF INPUT #
ITEM HOLDVALID B; # SAVE FLDVALID VALUE #
ITEM I I; # LOOP COUNTER #
ITEM IVALUE I; # INTEGER VALUE #
ITEM USEROW B = FALSE; # DO NOT USE TERCURSROW #
ITEM VNAME C(7); # VARIABLE NAME LEFT JUSTIFIED #
IF VLEN LS 1 THEN VLEN = 7; # CRACK PARAMETER #
VNAME = C<VOFF,VLEN>VARNAME;
GFIELD(VNAME,USEROW,FLDIND); # GET ASSOCIATED FIELD #
IF FLDIND EQ -1 THEN GOTO INTERROR; # FIELD NOT FOUND #
ALLBLANK = TRUE;
FOR I = 0 STEP 1 WHILE ALLBLANK AND I LQ FLDLENGTH[FLDIND] -1 DO
BEGIN # CHECK IF BLANK FIELD #
IF NEXTCHAR(FLDIND,I) NQ BLANK THEN ALLBLANK = FALSE;
END
IF ALLBLANK THEN
BEGIN # BLANK FIELD #
VALUE = 0;
RETURN;
END
HOLDVALID = FLDVALID[FLDIND]; # SAVE VALID FLAG #
FLDVALID[FLDIND] = TRUE;
IF VARPICTYPE[FLDVARORD[FLDIND]] EQ FORMTYPE"Y"
OR VARPICTYPE[FLDVARORD[FLDIND]] EQ FORMTYPE"M"
OR VARPICTYPE[FLDVARORD[FLDIND]] EQ FORMTYPE"D" THEN
BEGIN # DATE FORMAT FIELD #
FORMAT = VARPICTYPE[FLDVARORD[FLDIND]]; # SET FORMAT TYPE #
DATEVL(FLDIND,IVALUE); # GET VALUE #
END
ELSE
BEGIN # NUMERIC FIELD #
NCHECK(FLDIND,IVALUE,EVALUE,FORMAT,CURRENCY);
IF VARPICTYPE[FLDVARORD[FLDIND]] EQ FORMTYPE"$" THEN
BEGIN # WEIGHT CURRENCY INPUT #
IF EVALUE EQ 0 THEN IVALUE = IVALUE * 100;
ELSE IF EVALUE EQ -1 THEN IVALUE = IVALUE * 10;
END
ELSE
BEGIN # NOT CURRENCY #
IF EVALUE LS 0 THEN
BEGIN # TRUNCATE DECIMAL DIGITS #
FOR I = -1 STEP -1 UNTIL EVALUE DO IVALUE = IVALUE/10;
END
ELSE
BEGIN # RAISE TO POWER OF EXPONENT #
FOR I = 1 STEP 1 UNTIL EVALUE DO IVALUE = IVALUE*10;
END
END
END
IF NOT FLDVALID[FLDIND] OR FORMAT EQ FORMTYPE"BAD"THEN
BEGIN # ERRORS IN INPUT #
GOTO INTERROR;
END
FLDVALID[FLDIND] = HOLDVALID; # RESET VALID FLAG #
VALUE = IVALUE;
RETURN;
INTERROR: # CANNOT RETURN VALUE #
IF FLDIND NQ -1 THEN FLDVALID[FLDIND] = HOLDVALID;
VALUE = ERRORVAL;
END # SFGETI$ #
CONTROL EJECT;
PROC SFGETK(GENERIC,ORDINAL);
# TITLE SFGETK - GET FUNCTION KEY. #
BEGIN # SFGETK #
#
** SFGETK - GET FUNCTION KEY.
*
* SFGETK RETURNS THE ORDINAL OF THE LAST FUNCTION KEY PROCESSED.
*
* PROC SFGETK(GENERIC,ORDINAL)
*
* ENTRY TERFUNCGEN = TRUE IF GENERIC FUNCTION KEY.
* TERFUNCORD = ORDINAL OF FUNCTION KEY.
*
* EXIT GENERIC = TRUE IF GENERIC FUNCTION KEY.
* ORDINAL = ORDINAL OF FUNCTION KEY.
#
ITEM GENERIC B; # GENERIC/APPLICATION KEY FLAG #
ITEM ORDINAL I; # FUNCTION KEY ORDINAL #
GENERIC = TERFUNCGEN[0]; # RETURN GENERIC FLAG #
ORDINAL = TERFUNCORD[0]; # RETURN FUNCTION ORDINAL #
END # SFGETK #
CONTROL EJECT;
PROC SFGETN$(MODEL,MLEN,MOFF);
# TITLE SFGETN$ - GET TERMINAL MODEL NAME. #
BEGIN # SFGETN$ #
#
** SFGETN$ - GET TERMINAL MODEL NAME.
*
* SFGETN$ RETURNS THE TERMINAL MODEL NAME LEFT JUSTIFIED BLANK
* FILLED. IF MODEL NAME IS NOT FOUND, SPACES ARE RETURNED.
*
* PROC SFGETN$(MODEL,MLEN,MOFF)
*
* ENTRY MLEN = LENGTH OF MODEL NAME FIELD.
* MOFF = OFFSET OF MODEL NAME FIELD.
*
* EXIT MODEL = TERMINAL MODEL NAME.
*
* CALLS VDTITD.
#
BASED ARRAY TEMP [0:0];
BEGIN
ITEM STRING C(00,00,10); # MODEL NAME TEMPLATE #
END
ITEM MODEL C(6); # TERMINAL MODEL NAME #
ITEM MLEN I; # LENGTH OF MODEL PARAMETER #
ITEM MOFF I; # OFFSET INTO MODEL PARAMETER #
ITEM RETVAL C(6); # RETURNED VALUE #
ITEM OFFIND I; # OFFSET INDEX #
ITEM I I; # LOOP INDEX #
VDTITD(RETVAL); # GET MODEL NAME #
P<TEMP> = LOC(MODEL);
OFFIND = MOFF;
FOR I = 0 STEP 1 UNTIL MLEN - 1 DO
BEGIN # BLANK FILL MODEL NAME #
IF I GR 6 THEN # IF BEYOND POSSIBLE MODEL NAME #
C<OFFIND,1>STRING = " ";
ELSE
IF C<I,1>RETVAL EQ 0 THEN # IF BEYOND ACTUAL MODEL NAME #
C<OFFIND,1>STRING = " ";
ELSE
C<OFFIND,1>STRING = C<I,1>RETVAL;
OFFIND = OFFIND + 1;
IF (OFFIND GR 9) THEN
BEGIN # IF END OF CURRENT WORD #
OFFIND = 0;
P<TEMP> = P<TEMP> + 1;
END
END
END # SFGETN$ #
CONTROL EJECT;
PROC SFGETP$(VARNAME,VLEN,VOFF,OFFSET,ROWNUM);
# TITLE SFGETP$ - GET LAST CURSOR POSITION. #
BEGIN # SFGETP$ #
#
** SFGETP$ - GET LAST CURSOR POSITION.
*
* SFGETP$ RETURNS VALUES THAT DEFINE THE LAST POSITION OF THE
* SCREEN CURSOR.
*
* PROC SFGETP$(VARNAME,VLEN,VOFF,OFFSET,ROWNUM)
*
* ENTRY VARNAME = LOCATION OF VARIABLE PARAMETER.
* VLEN = LENGTH OF VARNAME.
* VOFF = OFFSET OF VARNAME.
*
* EXIT VARNAME = VARIABLE NAME OF FIELD.
* OFFSET = OFFSET OF CURSOR IN FIELD.
* ROWNUM = ROW NUMBER OF FIELD.
*
* CALLS FFIELD.
#
ITEM VARNAME C(11); # VARIABLE NAME #
ITEM VLEN I; # LENGTH OF VARNAME PARAMETER #
ITEM VOFF I; # OFFSET INTO VARNAME PARAMETER #
ITEM OFFSET I; # OFFSET INTO FIELD #
ITEM ROWNUM I; # ROW NUMBER IN ARRAY #
ITEM FIELD I; # FUNCTION FIELD #
ITEM I I; # LOOP COUNTER #
ITEM OUTSEARCH B=TRUE; # INCLUDE OUTPUT ONLY FIELDS #
ITEM VARIND I; # VARIABLE ORDINAL OF FIELD #
IF VLEN LS 1 THEN VLEN = 7; # CRACK PARAMETER #
C<VOFF,VLEN>VARNAME = " ";
ROWNUM = 0; # FIND FIELD #
FFIELD(TERFUNCPOS[0],FIELD,OFFSET,OUTSEARCH);
IF VALIDFIELD THEN
BEGIN # IF FIELD FOUND #
OFFSET = OFFSET + 1;
VARIND = FLDVARORD[FIELD];
C<VOFF,VLEN>VARNAME = VARNME[VARIND];
IF VARARRORD[VARIND] NQ 0 THEN
BEGIN # IF ARRAY MEMBER #
ROWNUM = VARROWNUM[VARIND] + 1;
END
END
END # SFGETP$ #
CONTROL EJECT;
PROC SFGETR$(VARNAME,VLEN,VOFF,VALUE);
# TITLE SFGETR$ - GET REAL VALUE. #
BEGIN # SFGETR$ #
#
** SFGETR$ - GET REAL VALUE.
*
* SFGETR$ RETURNS THE REAL NUMERIC VALUE OF THE FIELD
* SPECIFIED BY VARNAME.
*
* PROC SFGETR$(VARNAME,VLEN,VOFF,VALUE)
*
* ENTRY VARNAME = VARIABLE NAME OF FIELD.
* VLEN = LENGTH OF VARNAME.
* VOFF = OFFSET OF VARNAME.
*
* EXIT VALUE = REAL VALUE OF SPECIFIED FIELD.
*
* CALLS DATEVL, GFIELD, NCHECK.
#
ITEM VARNAME C(11); # VARIABLE NAME #
ITEM VLEN I; # LENGTH OF VARNAME PARAMETER #
ITEM VOFF I; # OFFSET INTO VARNAME PARAMETER #
ITEM VALUE R; # VALUE OF INPUT #
ITEM ALLBLANK B; # ALL CHARACTERS IN FIELD BLANK #
ITEM CURRENCY B; # TRUE IF DOLLAR SIGN INPUT #
ITEM ERRORVAL R = 0; # RETURNED IF ERROR IN FIELD #
ITEM EVALUE I; # EXPONENT VALUE #
ITEM FLDIND I; # FIELD ORDINAL #
ITEM FORMAT I; # FORMAT OF INPUT #
ITEM FPSTAT I; # GFP OVERFLOW STATUS #
ITEM HOLDVALID B; # HOLD FLDVALID VALUE #
ITEM I I; # LOOP COUNTER #
ITEM IVALUE I; # INTEGER VALUE #
ITEM USEROW B = FALSE; # DO NOT USE TERCURSROW #
ITEM VNAME C(7); # VARIABLE NAME LEFT JUSTIFIED #
IF VLEN LS 1 THEN VLEN = 7; # CRACK PARAMETER #
VNAME = C<VOFF,VLEN>VARNAME;
GFIELD(VNAME,USEROW,FLDIND); # GET ASSOCIATED FIELD #
IF FLDIND EQ -1 THEN GOTO REALERROR; # FIELD NOT FOUND #
ALLBLANK = TRUE;
FOR I = 0 STEP 1 WHILE ALLBLANK AND I LQ FLDLENGTH[FLDIND] -1 DO
BEGIN # CHECK IF BLANK FIELD #
IF NEXTCHAR(FLDIND,I) NQ BLANK THEN ALLBLANK = FALSE;
END
IF ALLBLANK THEN
BEGIN # BLANK FIELD #
VALUE = 0;
RETURN;
END
HOLDVALID = FLDVALID[FLDIND]; # SAVE FLDVALID #
FLDVALID[FLDIND] = TRUE;
IF VARPICTYPE[FLDVARORD[FLDIND]] EQ FORMTYPE"Y"
OR VARPICTYPE[FLDVARORD[FLDIND]] EQ FORMTYPE"M"
OR VARPICTYPE[FLDVARORD[FLDIND]] EQ FORMTYPE"D" THEN
BEGIN # IF DATE FORMAT #
DATEVL(FLDIND,IVALUE); # GET VALUE #
EVALUE = 0;
END
ELSE
BEGIN # GET NUMERIC VALUE #
NCHECK(FLDIND,IVALUE,EVALUE,FORMAT,CURRENCY);
END
IF NOT FLDVALID[FLDIND] OR FORMAT EQ FORMTYPE"BAD"THEN
BEGIN # ERRORS IN INPUT #
GOTO REALERROR;
END
FLDVALID[FLDIND] = HOLDVALID;
FPSTAT = GFP(IVALUE,EVALUE,VALUE); # GENERATE REAL VALUE #
IF FPSTAT EQ 0 THEN RETURN; # IF NO OVERFLOW ERROR #
REALERROR: # CANNOT RETURN VALUE #
IF FLDIND NQ -1 THEN FLDVALID[FLDIND] = HOLDVALID;
VALUE = ERRORVAL;
END # SFGETR$ #
*IF DEF,QTRM
CONTROL EJECT;
PROC SFMODE$(MODE,MODEL,MLEN,MOFF);
# TITLE SFMODE$ - QTRM MODE SWITCHING FUNCTION. #
BEGIN # SFMODE$ #
#
** SFMODE$ - QTRM MODE SWITCHING FUNCTION.
*
* THIS PROCEDURE SWITCHES A TERMINAL TO AND FROM SCREEN MODE. IT
* INTERFACES TO COBOL5 AND FTN5 APPLICATION PROGRAMS THROUGH A
* COMPASS INTERFACE CALLED SFMODE.
*
* PROC SFMODE$(MODE,MODEL,MLEN,MOFF)
*
* ENTRY MODE = 0, IF REQUESTED MODE IS SCREEN.
* 1, IF REQUESTED MODE IS LINE.
* MODEL = TERMINAL MODEL NAME.
* MLEN = LENGTH OF MODEL NAME.
* MOFF = OFFSET OF MODEL NAME.
*
* EXIT THE NIT RETURN CODE FIELD IN THE NIT WILL BE SET TO 0 IF
* THE REQUEST WAS SUCCESSFUL, NON-ZERO IF NOT.
#
ITEM MODE I; # REQUESTED MODE #
ITEM MODEL C(7); # TERMINAL MODEL (OR 'NONE') #
ITEM MLEN I; # LENGTH OF MODEL NAME #
ITEM MOFF I; # OFFSET OF MODEL NAME #
ITEM I I; # SCRATCH VARIABLE #
ITEM MODELNAME C(7); # TERMINAL MODEL NAME #
IF MLEN LS 1 THEN MLEN = 7; # CRACK PARAMETER #
MODELNAME = C<MOFF,MLEN>MODEL;
IF NIT$STATE[NIT$CON] NQ 2 THEN
BEGIN # IF CMM BLOCKS TO CLEAR UP #
NIT$RC = NITRTC"OK";
IF NIT$PCT [NIT$CON] EQ 0 THEN RETURN;
P<PCT> = NIT$PCT [NIT$CON];
IF PCT$VRDATA NQ 0 THEN CMMFRF (PCT$VRDATA);
PCT$VRDATA = 0; # INSURE THIS IS DONE ONLY ONCE #
CMMFRF (NIT$PCT[NIT$CON]);
NIT$PCT[NIT$CON] = 0;
RETURN; # RETURN #
END
IF NIT$PCT[NIT$CON] EQ 0 THEN
BEGIN # IF CMM BLOCK NEEDED #
CMMALF (PCTSIZE,0,0,I); # GET A BLOCK FOR THE PCT #
NIT$PCT[NIT$CON] = I;
P<PCT> = I;
FOR I = 0 STEP 1 UNTIL PCTSIZE - 1 DO
BEGIN # ZERO THE ENTIRE PCT #
PCT$WD0[I] = 0;
END
FOR I = 0 STEP 1 UNTIL SFORMSIZE - 1 DO
BEGIN # INITIALIZE TERMSTAT AREA #
TERMSTATWD[I] = TERINITHLD[I];
END
FOR I = 0 STEP 1 UNTIL VTERMSIZE - 1 DO
BEGIN
COMVDT$WD0[I] = VDTINITHLD[I]; # INIT VDT AREAS #
END
TERMODNAME[0] = " ";
TERACTPANL[0] = " ";
TERACTPLTI[0] = 0;
TERFUNCPOS[0] = 0;
TERNUMCOLS[0] = 0;
TERNUMLNES[0] = 0;
P<PLTABLE> = LOC(PLT); # INITIALIZE THE NIT PLT AREA #
I = PLTNUMENT[0];
P<PLTABLE> = NIT$PCT[NIT$CON] + PLTOFFSET;
FOR I = 1 STEP 1 UNTIL 10 DO
BEGIN # ZERO PLT WORD #
PLTWORDONE[I] = 0;
PLTWORDTWO[I] = 0;
END
PLTENTRYNM[0] = 10;
IF MODELNAME NQ "NONE" THEN # SET MODEL #
NIT$TRNAM[NIT$CON] = MODELNAME;
IF MODELNAME EQ "NONE " THEN NIT$MODEL [NIT$CON] = 0;
ELSE IF MODELNAME EQ "721 " THEN NIT$MODEL [NIT$CON] = 2;
ELSE NIT$MODEL [NIT$CON] = 1;
TERQTRMSOL[0] = MODE NQ 1; # SAVE SCREEN/LINE MODE #
END
END # SFMODE$ #
CONTROL EJECT;
PROC SFNQUE$(QNAME,QLEN,QOFF,BUFFER,RC);
# TITLE SFNQUE$ - ENQUEUE A BLOCK FOR A TERMINAL (ACN). #
BEGIN # SFNQUE$ #
#
** SFNQUE$ - ENQUEUE A BLOCK FOR A TERMINAL (ACN).
*
* THIS PROCEDURE ACCUMULATES DATA INTO A QUEUE FOR A SPECIFIED
* TERMINAL. VALID QUEUE NAMES ARE *GET* AND *PUT*. A BLOCK OF
* 1600 WORDS IS ALLOCATED FOR EACH QUEUE. EACH SFNQUE$ CALL ADDS
* DATA TO THE QUEUE WITH THE SPECIFIED QNAME AND TERMINAL NUMBER.
* IT INTERFACES TO COBOL5 AND FTN5 APPLICATION PROGRAMS THROUGH
* A COMPASS INTERFACE CALLED SFNQUE.
*
* PROC SFNQUE$(QNAME,QLEN,QOFF,BUFFER,RC)
*
* ENTRY QNAME = QUEUE TO PLACE DATA INTO (GET OR PUT).
* QLEN = LENGTH OF QUEUE NAME.
* QOFF = OFFSET OF QUEUE NAME.
* BUFFER = DATA TO ADD TO THE QUEUE.
* RC = RETURN CODE.
* NIT$CTLC = COUNT (IN 12 BIT CHARACTERS) IN BUFFER.
*
* EXIT RC = 0, IF DATA ENQUEUED (NO ERROR).
* 1, IF DATA NOT ENQUEUED.
*
* CALLS CMMALF.
#
ITEM QNAME C(7); # QUEUE TO PLACE DATA #
ITEM QLEN I; # LENGTH OF QUEUE NAME #
ITEM QOFF I; # OFFSET OF QUEUE NAME #
ITEM BUFFER U; # DATA TO ADD TO QUEUE #
ITEM RC I; # RETURN CODE #
BASED ARRAY B$BUFF [0:0] P(1); # BUFFER #
BEGIN
ITEM B$WD0 U(00,00,60); # BUFFER WORD (INTEGER) #
END
ITEM BIT I; # BIT POSITION #
ITEM B$CURBIT I; # CURRENT BIT #
ITEM B$CURWORD I; # CURRENT WORD #
ITEM ENTCT I = 0; # QTRM #
ITEM I I = 0; # LOOP VARIABLE #
ITEM QUEUENAME C(7); # QUEUE TO PLACE DATA #
ITEM RCC I; # RETURN CODE #
ITEM WORD I; # BUFFER WORD #
IF QLEN LS 1 THEN QLEN = 7; # LEFT JUSTIFY QUEUE NAME #
QUEUENAME = C<QOFF,QLEN>QNAME;
P<B$BUFF> = LOC(BUFFER);
B$CURBIT = 0; # START AT BEGINNING OF BUFFER #
B$CURWORD = 0;
ENTCT = ENTCT + 1;
SFNQUE1:
I = 0;
P<Q$HEADER> = CHAIN;
WHYLE P<Q$HEADER> NQ 0 DO
BEGIN # FIND QUEUE NAME FOR THIS ACN #
IF (( NIT$CON EQ Q$ACN ) AND
( C<0,3>QNAME EQ C<0,3>Q$NAME )) THEN
IF NIT$CON EQ Q$ACN AND QUEUENAME EQ Q$NAME THEN
BEGIN # IF FOUND #
P<Q$BUFFER> = P<Q$HEADER> + Q$HEADLEN;
FOR I = 1 STEP 1 UNTIL NIT$CTLC DO
BEGIN # ADD DATA TO QUEUE #
WORD = Q$INCHAR / 5;
IF WORD GQ Q$SIZE THEN
BEGIN # IF BLOCK OVERFLOW #
RC = 1; # SET ERROR #
RETURN; # RETURN #
END
BIT = (Q$INCHAR - (WORD * 5)) * 12;
B<BIT,12>Q$WORD[WORD] = B<B$CURBIT,12>B$WD0[B$CURWORD];
Q$INCHAR = Q$INCHAR + 1;
B$CURBIT = B$CURBIT + 12;
IF B$CURBIT GQ 60 THEN
BEGIN # IF FULL WORD #
B$CURBIT = 0;
B$CURWORD = B$CURWORD + 1;
END
END
RC = 0; # CLEAR RETURN CODE #
RETURN; # RETURN #
END
I = P<Q$HEADER>; # QUEUE DOESN-T EXIST, CREATE IT #
P<Q$HEADER> = Q$FORWARD; # ADD BLOCK TO END OF CHAIN #
END
IF CHAIN EQ 0 THEN
BEGIN # IF NO CHAIN HEADER #
P<Q$HEADER> = LOC(CHAIN);
END
ELSE
BEGIN # CHAIN HEADER EXISTS #
P<Q$HEADER> = I;
END
CMMALF (Q$BLKSIZE,0,0,RCC);
Q$FORWARD = RCC;
I = P<Q$HEADER>;
P<Q$HEADER> = Q$FORWARD;
Q$WD0 = 0; # CLEAR THE ENTRY HEADER AREA #
Q$WD1 = 0;
Q$WD2 = 0;
Q$BACK = I; # SET THE BACKWARD POINTER #
Q$ACN = NIT$CON; # SET THE TERMINAL ACN #
Q$NAME = QUEUENAME; # SET QUEUE NAME #
Q$SIZE = Q$BLKSIZE - Q$HEADLEN;
Q$CHARSET = NIT$CH$SET; # DEFAULT IS 12 BIT ASCII #
GOTO SFNQUE1; # ADD THE DATA TO THE QUEUE #
END # SFNQUE$ #
*ENDIF
CONTROL EJECT;
PROC SFLUSH$;
# TITLE SFLUSH$ - FLUSH DATA ALREADY WRITTEN TO SCREEN #
BEGIN # SFLUSH$ #
#
** SFLUSH$ - FLUSH DATA ALREADY WRITTEN TO SCREEN.
*
* THIS PROCEDURE FORCES DATA WHICH HAS ALREADY BEEN WRITTEN TO THE
* SCREEN BY MEANS OF *SFSWRI$* TO BE DISPLAYED UPON THE SCREEN, BY
* WRITING AN *EOR* TO THE SCREEN. NO PARAMETERS ARE REQUIRED.
*
* PROC SFLUSH$
*
* ENTRY NONE.
*
* EXIT PREVIOUSLY WRITTEN PANEL DATA FLUSHED TO SCREEN.
*
* CALLS VDTFOS.
*
* USES TERVDTBOOC.
*
#
*IF UNDEF,QTRM
ITEM RECALL I = 1; # RECALL PARAMETER FOR VDTFOS #
IF TERVDTBOOC[0] THEN
BEGIN # IF DATA IN BUFFER TO FLUSH #
IF NOT TERNOVDTEO[0] THEN VDTEOO;
TERVDTBOOC[0] = FALSE;
VDTFOS(RECALL); # FLUSH OUTPUT TO SCREEN, RECALL #
END
*ELSE
NIT$RC = NITRTC"OK"; # SET RETURN CODE #
*ENDIF
END # SFLUSH$ #
CONTROL EJECT;
PROC SFOPEN$(NAME,NLENGTH,NOFFSET,OPENSTAT);
# TITLE SFOPEN$ - OPEN PANEL. #
BEGIN # SFOPEN$ #
#
** SFOPEN$ - OPEN PANEL.
*
* THIS PROCEDURE CHECKS (VIA VDTGSL/VDTITD) TO SEE IF THE TERMINAL
* IN USE IS SUPPORTED UNDER SCREEN FORMATTING (UNLESS THIS HAS
* ALREADY BEEN DONE BY A PREVIOUS CALL TO SFOPEN.) IF THE TERM-
* INAL IS SUPPORTED THEN *SFLOAD* IS CALLED TO LOAD THE PANEL
* VIA THE FAST DYNAMIC LOADER (EXCEPT FOR THOSE PANELS THAT ARE
* STATICALLY LOADED AND THUS ALWAYS PRESENT IN MEMORY) AND THE
* PANEL LOAD TABLE IS UPDATED IF THE LOAD WAS SUCCESSFUL. THE
* STATUS OF THE OPEN IS RETURNED TO THE CALLING APPLICATION IN
* ALL CASES INDICATING THAT THE OPEN WAS SUCCESSFUL OR AN ERROR
* CODE INDICATING WHY NOT. SFOPEN$ INTERFACES TO COBOL AND FOR-
* TRAN PROGRAMS THROUGH A COMPASS INTERFACE MODULE CALLED SFOPEN.
*
* PROC SFOPEN$(NAME,NLENGTH,NOFFSET,OPENSTAT)
*
* ENTRY NAME = NAME OF PANEL TO BE OPENED.
* NLENGTH = LENGTH IN SIX BIT CHARACTERS.
* NOFFSET = OFFSET INTO NAME.
*
* EXIT PANEL OPENED IF POSSIBLE, OPENSTAT SET REGARDLESS.
*
*IF UNDEF,QTRM
* CALLS SETSRN, SFLOAD, VDTITD, VDTGSL.
*ELSE
* CALLS SETFSF, SETSRN, SFLOAD, VDTITD.
*ENDIF
*
* NOTES OPENSTAT IS SET BY SFOPEN IN SOME CASES AND IS ALSO
* A PARAMETER ON THE CALL TO SFLOAD IN THOSE INSTANCES
* WHERE THE FAST DYNAMIC LOADER IS TO BE CALLED.
*
* OPENSTAT SIGNIFICANCE PROCEDURE
* .....................................................
* . 0 . NO ERROR . BOTH .
* . 1 . UNKNOWN PANEL NAME . SFLOAD .
* . 2 . INCORRECT CAPSULE FORMAT . SFLOAD .
* . 3 . PLT FULL (TOO MANY OPEN PANELS) . SFOPEN .
* . 4 . PANEL ALREADY OPEN . SFOPEN .
* . 5 . INTERNAL (FAST DYNAMIC LOADER) . SFLOAD .
* . 6 . NO SCREEN COMMAND ISSUED . SFOPEN .
* . 7 . UNSUPPORTED TERMINAL . SFOPEN .
* .....................................................
#
ITEM NAME C(11); # NAME OF PANEL TO OPEN #
ITEM NLENGTH I; # LENGTH IN SIX BIT CHARACTERS #
ITEM NOFFSET I; # OFFSET INTO NAME #
ITEM OPENSTAT I; # RETURNS STATUS TO APPLICATION #
ITEM MODELNAME C(7); # MODEL NAME FOR VDTITD CALL #
ITEM NAMEINDEX I; # INDEX OF PANEL IF FOUND #
ITEM PANELADDR I; # MEMORY ADDRESS OF PANEL #
ITEM PANELNAME C(7); # PANEL NAME, LEFT JUSTIFIED #
ITEM PLTINDEX I; # INDEX INTO PANEL LOAD TABLE #
ITEM SCREEN I = 1; # INDICATES SCREEN MODE TO VDT #
ITEM SCREENDIM I; # SCREEN DIMENSIONS FOR SETSRN #
*IF DEF,QTRM
ITEM QTPLTINDEX I; # INDEX INTO QTRM USERS PLT #
*ENDIF
OPENSTAT = OPENSTATUS"NOERROR"; # CLEAR OPEN STATUS #
IF TERMODNAME[0] EQ " " THEN
BEGIN # IF *TDU* TABLE NOT YET READ #
*IF UNDEF,QTRM
VDTGSL(DUMMY,OPENSTAT); # CHECK SYSTEM SCREEN/LINE #
*ELSE
OPENSTAT = NIT$MODEL[NIT$CON]; # GET SCREEN MODE #
MODELNAME = NIT$TRNAM[NIT$CON]; # GET MODEL NAME #
*ENDIF
IF OPENSTAT EQ 0 THEN
BEGIN # IF NO MODEL SPECIFIED #
OPENSTAT = OPENSTATUS"NOSCREEN"; # NONE SPECIFIED #
END
ELSE
BEGIN # MODEL SPECIFIED #
OPENSTAT = OPENSTATUS"NOERROR"; # CLEAR OPEN STATUS #
VDTITD(MODELNAME); # INITIALIZE *TDU* TABLE #
IF C<0,6>MODELNAME EQ " " THEN
BEGIN # IF TERMINAL UNDEFINED #
TERMODNAME[0] = " ";
OPENSTAT = OPENSTATUS"UNSPTERM";
END
ELSE
BEGIN # SUPPORTED TERMINAL #
TERMODNAME[0] = MODELNAME;
P<CORE>=0;
IF COREWORD[CSMR] GQ 0 THEN
BEGIN # IF 63 CHARACTER SET SYSTEM #
DC2A8[00] = O"0040"; # 00B = UNDEFINED #
DC2A8[51] = O"0072"; # 63B = COLON #
A82DC[37] = O"0055"; # PERCENT = UNDEFINED #
A82DC[58] = O"0063"; # COLON = 63B #
AS2A8[03] = O"0045"; # 7404B = PERCENT #
TERASC8ATD[0] = 37; # PERCENT = 7404B #
END
END
END
END
IF OPENSTAT EQ OPENSTATUS"NOERROR" THEN
BEGIN # IF TERMINAL CAN BE USED #
IF NOT TERSCREENM[0] THEN
BEGIN # IF NOT IN SCREEN MODE #
SCREENDIM = 1; # ASK FOR SMALLEST SCREEN SIZE #
SETSRN(SCREENDIM,SCREENDIM); # SET SCREEN MODE #
END
IF NLENGTH LS 1 THEN NLENGTH = 7; # LEFT JUSTIFY PANEL NAME #
PANELNAME = C<NOFFSET,NLENGTH>NAME;
*IF DEF,QTRM
# CHECK FOR PANEL IN THIS USERS PLT AREA #
P<PLTABLE> = NIT$PCT[NIT$CON] + PLTOFFSET;
PANELADDR = 0;
QTPLTINDEX = 0;
FOR PLTINDEX = 1 STEP 1 WHILE
PANELADDR EQ 0 AND PLTINDEX LQ PLTNUMENT[0] DO
BEGIN
IF PLTENAME[PLTINDEX] EQ PANELNAME THEN
BEGIN
PANELADDR = PLTADDR[PLTINDEX];
NAMEINDEX = PLTINDEX;
END
END
IF PANELADDR EQ 0 THEN
BEGIN # IF NOT IN USER PLT #
P<PLTABLE> = LOC(PLT); # CHECK GLOBAL PLT #
FOR PLTINDEX = 1 STEP 1 WHILE
PANELADDR EQ 0 AND PLTINDEX LQ PLTNUMENT[0] DO
BEGIN
IF PLTENAME[PLTINDEX] EQ PANELNAME THEN
BEGIN
PANELADDR = PLTADDR[PLTINDEX];
NAMEINDEX = PLTINDEX;
END
END
END
IF PANELADDR NQ 0 THEN
BEGIN # UPDATE USER PLT FROM GLOBAL #
PLTNUMQTRM[NAMEINDEX] = PLTNUMQTRM[NAMEINDEX] + 1;
P<PLTABLE> = NIT$PCT[NIT$CON] + PLTOFFSET;
PLTNUMENT[0] = PLTNUMENT[0] + 1;
NAMEINDEX = PLTNUMENT[0];
PLTENAME[NAMEINDEX] = PANELNAME;
PLTSLFLAG[NAMEINDEX] = FALSE;
PLTOPENFLG[NAMEINDEX] = TRUE;
PLTADDR[NAMEINDEX] = PANELADDR;
SETFSF(PANELADDR); # SET FIELD STATUS FLAGS #
RETURN;
END
*ENDIF
P<PLTABLE> = LOC(PLT); # REFERENCE PANEL LOAD TABLE #
PANELADDR = 0; # CHECK FOR PANEL NAME IN TABLE #
FOR PLTINDEX = 1 STEP 1 WHILE
PANELADDR EQ 0 AND PLTINDEX LQ PLTNUMENT[0] DO
BEGIN
IF PLTENAME[PLTINDEX] EQ PANELNAME THEN
BEGIN # IF PANEL NAME FOUND #
PANELADDR = PLTADDR[PLTINDEX]; # SET PANEL ADDRESS #
NAMEINDEX = PLTINDEX; # SET INDEX INTO PLT #
END
END
IF PANELADDR EQ 0 THEN
BEGIN # IF PANELNAME NOT IN PLT #
IF PLTNUMENT[0] GQ PLTENTRYNM[0] THEN
BEGIN # IF PANEL LOAD TABLE IS FULL #
OPENSTAT = OPENSTATUS"PLTFULL";
END
ELSE
BEGIN # LOAD VIA FAST DYNAMIC LOADER #
SFLOAD(PANELNAME,PANELADDR,OPENSTAT);
IF OPENSTAT EQ 0 THEN
BEGIN # IF LOADED WITHOUT ERROR #
GETADD(PANELNAME,PANELADDR,NAMEINDEX);
POSTWO(PANELADDR); # POSITION SFATTR ARRAYS #
END
*IF DEF,QTRM
PLTNUMQTRM[PLTINDEX] = PLTNUMQTRM[PLTINDEX] + 1; # USER COUNT #
P<PLTABLE> = NIT$PCT[NIT$CON] + PLTOFFSET;
PLTNUMENT[0] = PLTNUMENT[0] + 1;
NAMEINDEX = PLTNUMENT[0];
PLTENAME[NAMEINDEX] = PANELNAME;
PLTSLFLAG[NAMEINDEX] = FALSE;
PLTOPENFLG[NAMEINDEX] = TRUE;
PLTADDR[NAMEINDEX] = PANELADDR;
*ENDIF
END
END
ELSE
BEGIN # IF PANEL ALREADY IN PLT #
IF PLTOPENFLG[NAMEINDEX] THEN
BEGIN # IF PANEL IS ALREADY OPEN #
OPENSTAT = OPENSTATUS"PANELOPEN";
END
ELSE
BEGIN # OPEN STATICALLY LOADED PANEL #
PLTOPENFLG[NAMEINDEX] = TRUE; # SET PANEL OPEN #
*IF DEF,QTRM
SETFSF(PANELADDR); # SET FIELD STATUS FLAGS #
*ENDIF
END
POSTWO(PANELADDR); # POSITION SFATTR ARRAYS #
END
END
END # SFOPEN$ #
CONTROL EJECT;
PROC SFPOSR$(TABLENAME,TLEN,TOFF,ROWNUMBER);
# TITLE SFPOSR$ - POSITION TABLE ROW. #
BEGIN # SFPOSR$ #
#
** SFPOSR$ - POSITION TABLE ROW.
*
* SFPOSR$ POSITIONS TABLENAME TO ROWNUMBER.
*
* PROC SFPOSR$(TABLENAME,TLEN,TOFF,ROWNUMBER)
*
* ENTRY TABLENAME = TABLE NAME.
* TLEN = LENGTH OF TABLENAME.
* TOFF = OFFSET OF TABLENAME.
* ROWNUMBER = ROW NUMBER.
*
* EXIT ARRCURROW[TABLENAME] = ROWNUMBER.
#
ITEM TABLENAME C(11); # TABLE NAME #
ITEM TLEN I; # LENGTH OF TABLENAME PARAMETER #
ITEM TOFF I; # OFFSET IN TABLENAME PARAMETER #
ITEM ROWNUMBER I; # ROW NUMBER IN ARRAY #
ITEM I I; # LOOP COUNTER #
ITEM NOTFOUND B; # TABLE NOT FOUND #
ITEM TNAME C(7); # TABLE NAME LEFT JUSTIFIED #
IF PANSTRARR[0] EQ 0 THEN RETURN; # IF NO TABLES IN PANEL #
IF TLEN LS 1 THEN TLEN = 7; # CRACK PARAMETER #
TNAME = C<TOFF,TLEN>TABLENAME;
NOTFOUND = TRUE;
FOR I = 0 STEP 1 WHILE ARRNUMVARS[I] NQ 0 AND NOTFOUND DO
BEGIN # SEARCH ARRAY LIST FOR TABLE #
IF ARRNAME[I] EQ TNAME THEN
BEGIN # IF TABLE NAME FOUND #
NOTFOUND = FALSE;
IF ROWNUMBER LS 1 OR ROWNUMBER GR ARRNUMROWS[I] THEN
BEGIN # IF ILLEGAL ROW NUMBER #
ARRCURROW[I] = 0;
END
ELSE ARRCURROW[I] = ROWNUMBER - 1;
END
END
END # SFPOSR$ #
CONTROL EJECT;
PROC SFSETF$(VNAME,VLEN,VOS,STRG,SLEN,SOS,CSET,CLEN,COS,STAT);
BEGIN
#
** SFSETF$ - SET FIELD CHARACTER STRING.
*
* SFGETF$ TRANSFERS CHARACTERS TO A SPECIFIED PANEL FIELD FROM
* A SPECIFIED STRING, USING *MOVEFLD*.
*
* PROC SFGETF$(VNAME,VLEN,VOS,STRG,SLEN,SOS,CSET,CLEN,COS,STAT)
*
* ENTRY VNAME = VARIABLE NAME OF FIELD.
* VLEN = LENGTH OF VARNAME PARAMETER.
* VOS = OFFSET OF VARNAME PARAMETER.
* STRG = VARIABLE FIELD STRING.
* SLEN = LENGTH OF STRING PARAMETER.
* SOS = OFFSET OF STRING PARAMETER.
* CSET = CHARACTER SET OF STRING (SEE SFCSET$).
* CLEN = LENGTH OF CSET PARAMETER.
* COS = OFFSET OF CSET PARAMETER.
*
* EXIT STAT GQ 0, NUMBER OF 6 BIT CHARACTERS MOVED.
* LS 0, VARIABLE NOT FOUND IN ACTIVE PANELS.
*
* CALLS MOVEFLD.
#
ITEM VNAME I; # VARIABLE NAME #
ITEM VLEN I; # LENGTH OF VARNAME PARAMETER #
ITEM VOS I; # OFFSET INTO VARNAME PARAMETER #
ITEM STRG I; # INSTRING PARAMETER #
ITEM SLEN I; # LENGTH OF INSTRING #
ITEM SOS I; # OFFSET INTO INSTRING #
ITEM CSET I; # CHARACTER SET #
ITEM CLEN I; # LENGTH OF CHARACTER SET #
ITEM COS I; # OFFSET INTO CHARACTER SET #
ITEM STAT I; # STATUS FIELD #
STAT = 1; # INDICATE *SFSETF* #
MOVEFLD(VNAME,VLEN,VOS,STRG,SLEN,SOS,CSET,CLEN,COS,STAT);
RETURN;
END # SFSETF$#
*IF DEF,QTRM
CONTROL EJECT;
PROC SFQTRM$(NITADDR,BUFFER);
# TITLE SFQTRM$ - INTERFACE BETWEEN QTRM AND SFORM #
BEGIN # SFQTRM$ #
#
** SFQTRM$ - INTERFACE BETWEEN QTRM AND SFORM.
*
* THIS PROCEDURE IS THE INTERFACE BETWEEN QTRM AND SFORM THAT
* IDENTIFIES THE QTRM NETWORK INFORMATION TABLE, DATA BUFFER,
* AND CURRENT TERMINAL TO SFORM. SFQTRM$ INTERFACES TO COBOL
* AND FORTRAN PROGRAMS THROUGH A COMPASS INTERFACE MODULE
* CALLED SFQTRM.
*
* PROC SFQTRM$(NITADDR,BUFFER)
*
* ENTRY NITADDR = ADDRESS OF QTRM USER-S QTRM NETWORK
* INFORMATION TABLE.
* BUFFER = ADDRESS OF BUFFER FOR THE SCREEN FORMATTING
* ROUTINES SFSREA AND SFSWRI TO USE. THE
*
* EXIT POINTERS TO BUFFER INITIALIZED.
#
ITEM NITADDR U; # ADDRESS OF THE USERS NIT #
ARRAY BUFFER [0:0] P(1);; # BUFFER #
ITEM CHARIND I = 0; # CHAR INDEX FOR FLAG MOVE #
ITEM CURRNT$ACN I = 0; # CURRENT ACN POINTER #
ITEM I I; # LOOP COUNTER #
ITEM HOLDADR U; # HOLDS BUFFER ADDRESS #
ITEM PANELNAME C(7); # PANEL NAME FOR ARRAY RESET #
ITEM PANELADDR I; # PANEL ADDR FOR ARRAY RESET #
ITEM VDATALEN I; # VARDATA LENGTH #
ITEM PLTINDEX I; # ACTIVE PANEL INDEX TO RESET #
ITEM WORDIND I = 0; # WORD INDEX FOR FLAG MOVE #
HOLDADR = LOC(BUFFER); # SAVE BUFFER ADDRESS #
P<NIT> = LOC(NITADDR); # SAVE NIT ADDRESS #
IF CURRNT$ACN EQ 0 THEN
BEGIN # IF FIRST CALL TO SFQTRM$ #
CURRNT$ACN = NIT$CON[0];
P<QTRM$BUFFER> = LOC(BUFFER);
FOR I = 0 STEP 1 UNTIL SFORMSIZE -1 DO
BEGIN # SAVE TERMSTAT DEFAULTS #
TERINITHLD[I] = TERMSTATWD[I];
END
FOR I = 0 STEP 1 UNTIL VTERMSIZE -1 DO
BEGIN # SAVE VDT AREA DEFAULTS #
VDTINITHLD[I] = COMVDT$WD0[I];
END
RETURN;
END
IF CURRNT$ACN NQ NIT$CON[0] THEN
BEGIN # IF NEW USER #
IF CURRNT$ACN NQ 0 AND NIT$PCT[CURRNT$ACN] NQ 0 THEN
BEGIN # IF THERE IS A CURRENT USER #
P<PCT> = NIT$PCT[CURRNT$ACN]; # SAVE PREVIOUS TERMINAL-S STATE #
TERFLDADDR = P<FLDLIST>; # SAVE FIELD LIST ADDRESS #
P<QTRM$BUFFER> = P<PCT> + SFORMOFFSET;
FOR I = 0 STEP 1 UNTIL SFORMSIZE -1 DO
BEGIN # MOVE SFORM DATA #
QTRM$WD0[I] = TERMSTATWD[I];
END
P<QTRM$BUFFER> = P<PCT> + VTERMOFFSET;
FOR I = 0 STEP 1 UNTIL VTERMSIZE - 1 DO
BEGIN # MOVE VIRTERM DATA #
QTRM$WD0[I] = COMVDT$WD0[I];
END
P<QTRM$BUFFER> = P<PCT> + FDAOFFSET;
IF TERFLDADDR[0] NQ 0 THEN
BEGIN # IF FIELD STATUS FLAGS EXIST #
FOR I = 0 STEP 1 WHILE FLDENTRY[I] NQ 0 DO
BEGIN # MOVE FIELD STATUS FLAGS #
WORDIND = I / 15;
CHARIND = I - 15*WORDIND;
B<CHARIND*4,4>QTRM$WD0[WORDIND] = FLDSTFLAGS[I];
END
END
P<QTRM$BUFFER> = P<PCT> + VDTAOFFSET;
PANELADDR = P<VDATA> - PANHEADLEN;
IF PANSTRFLD[0] NQ 0 THEN
BEGIN # IF FIELDS EXISTS #
VDATALEN = P<FLDLIST> - (PANELADDR + PANHEADLEN);
END
ELSE
BEGIN # NO FIELDS #
VDATALEN = P<VARLIST> - (PANELADDR + PANHEADLEN);
END
FOR I = 0 STEP 1 UNTIL VDATALEN -1 DO
BEGIN
QTRM$WD0[I] = VDATAU[I];
END
END
CURRNT$ACN = NIT$CON[0]; # LOAD ITEMS FOR NEW TERMINAL #
IF NIT$PCT[CURRNT$ACN] NQ 0 THEN
BEGIN # IF USER HAS A PCT #
P<PCT> = NIT$PCT[CURRNT$ACN];
P<PLTABLE> = NIT$PCT[CURRNT$ACN] + PLTOFFSET;
P<QTRM$BUFFER> = P<PCT> + SFORMOFFSET;
FOR I = 0 STEP 1 UNTIL SFORMSIZE - 1 DO
BEGIN # MOVE SFORM DATA #
TERMSTATWD[I] = QTRM$WD0[I];
END
P<FLDLIST> = TERFLDADDR; # FLDLIST ADDRESS #
P<QTRM$BUFFER> = P<PCT> + VTERMOFFSET;
FOR I = 0 STEP 1 UNTIL VTERMSIZE - 1 DO
BEGIN # MOVE VIRTERM DATA #
COMVDT$WD0[I] = QTRM$WD0[I];
END
IF TERACTPANL[0] NQ " " THEN
BEGIN # IF PANEL ACTIVE #
P<QTRM$BUFFER> = P<PCT> + FDAOFFSET;
IF TERFLDADDR[0] NQ 0 THEN
BEGIN # IF FIELD STATUS FLAGS EXIST #
FOR I = 0 STEP 1 WHILE FLDENTRY[I] NQ 0 DO
BEGIN # MOVE FIELD STATUS FLAGS #
WORDIND = I / 15;
CHARIND = I - 15*WORDIND;
FLDSTFLAGS[I] = B<CHARIND*4,4>QTRM$WD0[WORDIND];
END
END
PANELNAME = TERACTPANL[0]; # GET PANEL NAME #
GETADD(PANELNAME,PANELADDR,PLTINDEX);
POSARR(PANELADDR);
P<QTRM$BUFFER> = P<PCT> + VDTAOFFSET;
PANELADDR = P<VDATA> - PANHEADLEN;
IF PANSTRFLD[0] NQ 0 THEN
BEGIN
VDATALEN = P<FLDLIST> - (PANELADDR + PANHEADLEN);
END
ELSE
BEGIN
VDATALEN = P<VARLIST> - (PANELADDR + PANHEADLEN);
END
FOR I = 0 STEP 1 UNTIL VDATALEN -1 DO
BEGIN
VDATAU[I] = QTRM$WD0[I];
END
END
END
ELSE
BEGIN # NO PCT FOR THIS USER #
FOR I = 0 STEP 1 UNTIL SFORMSIZE -1 DO
BEGIN # INITIALIZE TERMSTAT #
TERMSTATWD[I] = TERINITHLD[I];
END
FOR I = 0 STEP 1 UNTIL VTERMSIZE -1 DO
BEGIN # INITIALIZE VDT AREA #
COMVDT$WD0[I] = VDTINITHLD[I];
END
TERMODNAME[0] = " ";
TERACTPANL[0] = " ";
TERACTPLTI[0] = 0;
TERFUNCPOS[0] = 0;
TERNUMCOLS[0] = 0;
TERNUMLNES[0] = 0;
END
P<QTRM$BUFFER> = HOLDADR;
END
END # SFQTRM$ #
*ENDIF
CONTROL EJECT;
PROC SFSETP$(VARNAME,VLEN,VOFF,OFFSET,ROWNUM);
# TITLE SFSETP$ - SET CURSOR POSITION. #
BEGIN # SFSETP$ #
#
** SFSETP$ - SET CURSOR POSITION.
*
* SFSETP$ SPECIFIES WHAT FIELD THE CURSOR WILL
* BE POSITIONED AT FOR THE NEXT READ.
*
* PROC SFSETP$(VARNAME,VLEN,VOFF,OFFSET,ROWNUM)
*
* ENTRY VARNAME = VARIABLE NAME OF FIELD.
* VLEN = LENGTH OF VARP.
* VOFF = OFFSET OF VARP.
* OFFSET = OFFSET INTO SPECIFIED FIELD.
* ROWNUM = ROW NUMBER OF SPECIFIED FIELD.
*
* EXIT TERCURSVAR = VARIABLE NAME OF SPECIFIED FIELD.
* TERCURSROW = ROW NUMBER OF SPECIFIED FIELD.
* TERCURSOFF = OFFSET OF SPECIFIED FIELD.
* TERCURSSET = TRUE.
*
* USES TERCURSOFF, TERCURSROW, TERCURSSET, TERCURSVAR.
*
* NOTES ROUTINE READSF WILL SET THE ACTUAL CURSOR POSITION.
#
ITEM VARNAME C(11); # VARIABLE NAME #
ITEM VLEN I; # LENGTH OF VARNAME PARAMETER #
ITEM VOFF I; # OFFSET INTO VARNAME PARAMETER #
ITEM OFFSET I; # OFFSET INTO FIELD #
ITEM ROWNUM I; # ROW NUMBER IN ARRAY #
IF VLEN LS 1 THEN VLEN = 7; # CRACK PARAMETER #
TERCURSVAR[0] = C<VOFF,VLEN>VARNAME;
TERCURSSET[0] = TRUE; # SET GLOBAL VARIABLES #
IF OFFSET GR 0 THEN TERCURSOFF[0] = OFFSET - 1;
ELSE TERCURSOFF[0] = 0;
IF ROWNUM LS 1 THEN TERCURSROW[0] = 0;
ELSE TERCURSROW[0] = ROWNUM - 1;
END # SFSETP$ #
CONTROL EJECT;
PROC SFSREA$(PANELP,PANLEN,PANOFF,INSP,INSLEN,INSOFF);
# TITLE SFSREA$ - READ PANEL USING INSTRING. #
BEGIN # SFSREA$ #
#
** SFSREA$ - READ PANEL USING INSTRING.
*
* SFSREA$ READS A PANEL AND PLACES THE INPUT IN
* INSTRING.
*
* PROC SFSREA$(PANELP,PANLEN,PANOFF,INSP,INSLEN,INSOFF)
*
* ENTRY PANELP = NAME OF PANEL TO READ.
* PANLEN = LENGTH OF PANELP.
* PANOFF = OFFSET OF PANELP.
* INSP = INSTRING TO RECEIVE DATA.
* INSLEN = LENGTH OF INSP.
* INSOFF = OFFSET OF INSP.
*
* EXIT INSP CONTAINS INPUT DATA.
*
* CALLS CPANEL, MOVEST, READSF.
*
* USES TERREADFLG.
#
ITEM PANELP C(11); # PANEL PARAMETER #
ITEM PANLEN I; # LENGTH OF PANEL PARAMETER #
ITEM PANOFF I; # OFFSET OF PANEL PARAMETER #
ITEM INSP I; # ADDRESS OF INSTRING #
ITEM INSLEN I; # LENGTH OF INSTRING #
ITEM INSOFF I; # OFFSET OF INSTRING #
ITEM PANEL C(7); # NAME OF INPUT PANEL #
*IF DEF,QTRM
NIT$RC = NITRTC"OK"; # SET STATUS OK #
*ENDIF
IF PANLEN LS 1 THEN PANLEN = 7; # CRACK PARAMETER #
PANEL = C<PANOFF,PANLEN>PANELP;
READSF(PANEL); # READ PANEL #
CPANEL; # REWRITE SCREEN AS NEEDED #
IF PANNUMBYTE[0] NQ 0 THEN
BEGIN # IF VARIABLES IN PANEL #
TERREADFLG[0] = TRUE;
MOVEST(LOC(INSP),INSOFF,INSLEN); # MOVE VARDATA TO INSTRING #
TERREADFLG[0] = FALSE;
END
END # SFSREA$ #
*IF UNDEF, QTRM
CONTROL EJECT;
PROC SFSSHO$(PANELP,PANLEN,PANOFF,OUTP,OLEN,OOFF,INSP,ILEN,IOFF);
# TITLE SFSSHO$ - SHOW PANEL USING INSTRING AND OUTSTRING. #
BEGIN # SFSSHO$ #
#
** SFSSHO - SHOW PANEL USING INSTRING AND OUTSTRING.
*
* THIS PROCEDURE CALLS SFSWRI$ AND SFSREA$.
*
* PROC SFSSHO$(PANELP,PANLEN,PANOFF,OUTP,OLEN,OOFF,INSP,ILEN,IOFF)
*
* ENTRY PANELP = NAME OF PANEL TO READ.
* PANLEN = LENGTH OF PANELP.
* PANOFF = OFFSET OF PANELP.
* OUTP = OUTSTRING DISPLAY DATA.
* OLEN = LENGTH OF OUTP.
* OOFF = OFFSET OF OUTP.
* ILEN = LENGTH OF INSP.
* IOFF = OFFSET OF INSP.
*
* EXIT INSP = CONTAINS INPUT DATA.
*
* CALLS SFSREA$, SFSWRI$.
*
* USES TERSHOWFLG.
#
ITEM PANELP I; # NAME OF PANEL TO READ #
ITEM PANLEN I; # LENGTH OF PANELP #
ITEM PANOFF I; # OFFSET OF PANELP #
ITEM OUTP I; # OUTSTRING DISPLAY DATA #
ITEM OLEN I; # LENGTH OF OUTP #
ITEM OOFF I; # OFFSET OF OUTP #
ITEM INSP I; # INSTRING TO RECEIVE DATA #
ITEM ILEN I; # LENGTH OF INSP #
ITEM IOFF I; # OFFSET OF INSP #
TERSHOWFLG[0] = TRUE;
SFSWRI$(PANELP,PANLEN,PANOFF,OUTP,OLEN,OOFF); # WRITE PANEL #
SFSREA$(PANELP,PANLEN,PANOFF,INSP,ILEN,IOFF); # READ PANEL #
TERSHOWFLG[0] = FALSE;
END # SFSSHO$ #
*ENDIF
CONTROL EJECT;
PROC SFSWRI$(NAME,NLENGTH,NOFFSET,STRING,SLENGTH,SOFFSET);
# TITLE SFSWRI$ - SCREEN FORMAT STRING WRITE FUNCTION. #
BEGIN # SFSWRI$ #
#
** SFSWRI$ - SCREEN FORMAT WRITE FUNCTION.
*
* THIS PROCEDURE WRITES THE SPECIFIED PANEL USING THE CONCATENATED
* VARIABLE DATA FOUND IN OUTSTRING (OR IN THE CASE OF AN ATTEMPTED
* READ BEFORE WRITE USING THE VARIABLE DATA ALREADY PRESENT IN THE
* VARDATA SECTION OF THE PANEL RECORD) AND THE CONSTANT DATA FOUND
* IN THE PANEL RECORD. IT INTERFACES TO COBOL AND FORTRAN APPLICA-
* TION PROGRAMS THROUGH A COMPASS INTERFACE MODULE CALLED SFSWRI.
*
* PROC SFSWRI$(NAME,NLENGTH,NOFFSET,STRING,SLENGTH,SOFFSET)
*
* ENTRY NAME = THE NAME OF THE PANEL TO BE WRITTEN.
* NLENGTH = LENGTH IN SIX BIT CHARACTERS.
* NOFFSET = OFFSET INTO NAME.
* STRING = CONTAINS THE CONCATENATED VARIABLE DATA.
* SLENGTH = LENGTH IN SIX BIT CHARACTERS.
* SOFFSET = OFFSET INTO STRING.
*
* EXIT PANEL WRITTEN TO SCREEN.
*
* CALLS GETADD, MOVEST, POSARR, WRIPAN.
*
* USES TERACTIVEP, TERACTPANI.
*
* NOTES IF TERREADFLG IS SET SFSWRI HAS BEEN CALLED BY SFSREA
* AND HENCE THERE IS NO OUTSTRING TO MOVE INTO VARDATA
* AND WHATEVER VARIABLE DATA IS PRESENTLY THERE WILL BE
* WRITTEN TO THE SCREEN.
#
ITEM NAME C(11); # NAME OF PANEL TO BE WRITTEN #
ITEM NLENGTH I; # LENGTH IN SIX BIT CHARACTERS #
ITEM NOFFSET I; # OFFSET INTO NAME #
ITEM STRING I; # OUTSTRING PARAMETER #
ITEM SLENGTH I; # LENGTH IN SIX BIT CHARACTERS #
ITEM SOFFSET I; # OFFSET INTO OUTSTRING #
ITEM PANELNAME C(7); # PANEL NAME, LEFT JUSTIFIED #
ITEM PANELADDR I; # ADDRESS OF PANEL RECORD #
ITEM PLTINDEX I; # PANEL LOAD TABLE INDEX #
ITEM STRINGADDR I; # ADDRESS OF OUTSTRING #
*IF DEF,QTRM
NIT$RC = NITRTC"OK"; # SET RETURN CODE #
TERMODNAME[0] = NIT$MODEL[NIT$CON]; # GET THE USERS MODEL FROM NIT #
*ENDIF
IF NLENGTH LS 1 THEN NLENGTH = 7; # CRACK PARAMETER #
PANELNAME = C<NOFFSET,NLENGTH>NAME; # LEFT JUSTIFY PANEL NAME #
IF PANELNAME NQ TERACTPANL[0] THEN
BEGIN # IF NOT THE ACTIVE PANEL #
TERACTPANL[0] = PANELNAME; # UPDATE ACTIVE PANEL NAME #
GETADD(PANELNAME,PANELADDR,PLTINDEX);
TERACTPLTI[0] = PLTINDEX;
POSARR(PANELADDR); # POSITION BASED ARRAYS #
END
IF PANNUMBYTE[0] NQ 0 AND NOT TERREADFLG[0] THEN
BEGIN # IF VARIABLE DATA PRESENT #
STRINGADDR = LOC(STRING); # ADDRESS OF OUTSTRING #
MOVEST(STRINGADDR,SOFFSET,SLENGTH); # MOVE OUTSTRING TO VARDATA #
END
IF NOT TERVDTBOOC[0] THEN
BEGIN # IF FIRST WRITE #
TERVDTBOOC[0] = TRUE;
VDTBOO; # BEGIN OUTPUT SEQUENCE #
END
WRIPAN; # WRITE PANEL #
END # SFSWRI$ #
CONTROL EJECT;
PROC BFIELD(FIELD,STARTCHAR,LASTDIRTY);
# TITLE BFIELD - BLANK FIELD IN VARDATA. #
BEGIN # BFIELD #
#
** BFIELD - BLANK FIELD IN VARDATA.
*
* THIS PROCEDURE BLANK FILLS A FIELD IN VARDATA.
*
* PROC BFIELD(FIELD,STARTCHAR,LASTDIRTY)
*
* ENTRY FIELD = INDEX OF FIELD IN FLDLIST.
* STARTCHAR = POSITION TO START BLANK FILL.
*
* EXIT LASTDIRTY = LAST POSITION WITH PREVIOUS
* NON-BLANK CHARACTER.
#
ITEM FIELD I; # FIELD TO INITIALIZE #
ITEM STARTCHAR I; # STARTING CHARACTER POSITION #
ITEM LASTDIRTY I; # LAST NON-BLANK CHARACTER #
ITEM CHARNUM I; # CHARACTER POSITION IN VARDATA #
ITEM CHARIND I; # CHARACTER INDEX IN VARDATA #
ITEM I I; # LOOP COUNTER #
ITEM WORDIND I; # WORD INDEX IN VARDATA #
LASTDIRTY = -1;
CHARNUM = FLDVDTCORD[FIELD] + STARTCHAR;
WORDIND = CHARNUM / 5;
CHARIND = CHARNUM - (5 * WORDIND);
FOR I = STARTCHAR STEP 1 UNTIL FLDLENGTH[FIELD] -1 DO
BEGIN # BLANK FILL FIELD IN VDATA #
IF NEXTCHAR(FIELD,I) NQ BLANK THEN
BEGIN # NON-BLANK CHARACTER #
LASTDIRTY = I; # UPDATE LAST DIRTY CHARACTER #
END
B<CHARIND*12,12>VDATAU[WORDIND] = BLANK; # BLANK CHARACTER POS #
CHARIND = CHARIND + 1;
IF CHARIND EQ 5 THEN
BEGIN
CHARIND = 0;
WORDIND = WORDIND + 1;
END
END
END # BFIELD #
CONTROL EJECT;
PROC CLRLNS;
# TITLE CLRLNS - CLEAR LINES. #
BEGIN # CLRLNS #
#
** CLRLNS - CLEAR LINES.
*
* THIS PROCEDURE CLEARS THE PROPER LINES BEFORE AN OVERLAY
* WRITE.
*
* PROC CLRLNS
*
* EXIT PROPER LINES CLEARED ON SCREEN.
*
* CALLS VDTCLL.
#
ITEM CURYCORD I; # CURRENT Y COORDINATE #
ITEM FLDINDEX I; # INDEX INTO FIELD LIST #
IF PANSTRFLD[0] EQ 0 THEN RETURN;
CURYCORD = -1; # NO CURRENT Y COORDINATE YET #
FOR FLDINDEX = 0 STEP 1 WHILE FLDENTRY[FLDINDEX] NQ 0 DO
BEGIN
IF FLDACTIVE[FLDINDEX] AND FLDYCORD[FLDINDEX] NQ CURYCORD THEN
BEGIN # IF ACTIVE FIELD ON NEW LINE #
CURYCORD = FLDYCORD[FLDINDEX]; # RESET CURRENT Y COORDINATE #
VDTCLL(0,CURYCORD); # CLEAR LINE #
END
END
IF TERNOTCHAR[0] THEN VDTCAA(0); # IF LINE OR PAGE TYPE ATTRS. #
END # CLRLNS #
CONTROL EJECT;
PROC CPANEL;
# TITLE CPANEL - CLEAN PANEL. #
BEGIN # CPANEL #
#
** CPANEL - CLEAN PANEL.
*
* THIS PROCEDURE CHECKS FLAGS PERTAINING TO REWRITING THE
* SCREEN AND THEN CALLS THE APPROPRIATE PROCEDURES.
*
* PROC CPANEL
*
* ENTRY TERMESWRIT = TRUE, IF THE MESSAGE CONTAINS A MESSAGE.
* TERMESREAD = TRUE, IF THE MESSAGE AREA CAN BE CLEARED.
* TERREWFLDS = TRUE, IF ONE OR MORE FIELDS NEED REWRITING.
* TERREWSCRN = TRUE, IF THE ENTIRE SCREEN NEEDS REWRITING.
*
* EXIT TERMESREAD = FALSE.
* TERREWFLDS = FALSE.
* TERREWSCRN = FALSE.
*
* CALLS REWFLD, MCLEAN, VDTSAM, WRIALL.
*
* USES TERDONTCLR, TERMESREAD, TERNOREWRT, TERREWFLDS,
* TERREWSCRN.
#
ITEM I I; # LOOP COUNTER #
IF TERMESWRIT[0] AND TERMESREAD[0] AND NOT TERREWSCRN[0] THEN
BEGIN # CLEAR MESSAGE AREA #
MCLEAN(DUMMY,DUMMY); # CLEAN MESSAGE LINE #
IF NOT TERBLCKMDE[0] THEN
BEGIN
VDTSAM(0);
END
ELSE
BEGIN
VDTSAM(O"6001");
END
END
IF TERREWFLDS[0] OR TERREWSCRN[0] THEN
BEGIN # REWRITE FLAGGED FIELDS #
TERREADFLG[0] = TRUE;
TERDONTCLR[0] = TRUE; # DO NOT CLEAR REWRITE/ENTERED #
IF TERREWSCRN[0] THEN
BEGIN # FULL REWRITE OF SCREEN #
WRIALL;
TERREWSCRN[0] = FALSE;
END
ELSE # REWRITE FLAGGED FIELDS #
BEGIN
TERNOREWRT[0] = TRUE;
REWFLD; # REWRITE FIELDS #
TERNOREWRT[0] = FALSE;
END
TERDONTCLR[0] = FALSE;
TERREADFLG[0] = FALSE;
END
TERMESREAD[0] = FALSE;
TERREWFLDS[0] = FALSE;
END # CPANEL #
CONTROL EJECT;
PROC DATEVL(FLDIND,IVAL);
# TITLE DATEVL - DATE VALIDATION. #
BEGIN # DATEVL #
#
** DATEVL - DATE VALIDATION.
*
* THIS PROCEDURE CHECKS THAT THE INPUT IS A VALID DATE.
*
* PROC DATEVL(FLDIND,IVAL)
*
* ENTRY FLDIND = INDEX OF CURRENT FIELD IN FLDLIST.
*
* EXIT IVAL = INTEGER VALUE OF INPUT.
* FLDVALID[FLDIND] = FALSE, IF INVALID INPUT.
*
* CALLS GETNUM, SKPBLK.
#
ITEM FLDIND I; # VARIABLE TO BE VALIDATED #
ITEM IVAL I; # INTEGER VALUE OF INPUT #
ITEM CHAR I; # INPUT CHARACTER #
ITEM CHARPOS I; # CHARACTER POSITION IN FIELD #
ITEM DATEIND I; # INDEX TO DATEARRAY #
ITEM DD I; # DAY #
ITEM DIGITS I; # NUMBER OF DIGITS IN SUBFIELD #
ITEM FVAL I; # SUBFIELD VALUE #
ITEM I I; # LOOP COUNTER #
ITEM INPIND I; # INDEX TO NEXT INPUT CHARACTER #
ITEM MM I; # MONTH #
ITEM TEMP1 I; # USED FOR LEAP YEAR CALCULATION #
ITEM VARIND I; # INDEX INTO VARLIST #
ITEM YY I; # YEAR #
ARRAY DATEARRAY[0:7] P(1);
BEGIN
ITEM DATECHAR U(00,00,60); # HOLDS INPUT CHARACTERS #
END
ARRAY DATEDELS[0:2] P(1);
BEGIN
ITEM DATEDEL U(00,00,60); # DATE DELIMETER #
END
ARRAY FIELDARRAY[0:2] P(1);
BEGIN
ITEM FIELD U(00,00,60); # HOLDS MONTH, DAY, YEAR FIELDS #
END
ARRAY MONTHS [0:12] P(1); # NUMBER OF DAYS IN EACH MONTH #
BEGIN # 0TH MONTH = LEAP YEAR FEBRUARY #
ITEM MONLENGTH U(00,00,60) =
[29,31,28,31,30,31,30,31,31,30,31,30,31];
END
SWITCH DATETYPE:FORMTYPE
YYMMDD : Y,
MMDDYY : M,
DDMMYY : D;
DATEIND = 0;
INPIND = 0;
CHARPOS = 0;
VARIND = FLDVARORD[FLDIND]; # SET INDEX TO VARLIST #
IVAL = 0;
SKPBLK(FLDIND,CHARPOS,CHAR);
IF CHARPOS GQ FLDLENGTH[FLDIND] THEN
BEGIN # BLANK FIELD #
FLDVALID[FLDIND] = FALSE;
RETURN;
END
FOR I = 0 STEP 1 UNTIL 2 DO
BEGIN
FVAL = 0;
GETNUM(FLDIND,CHARPOS,FVAL,DIGITS);
IF I NQ 2 THEN
BEGIN
CHAR = NEXTCHAR(FLDIND,CHARPOS);
DATEDEL[I] = CHAR;
END
ELSE CHARPOS = CHARPOS -1;
IF NOT(DIGITS EQ 1 OR DIGITS EQ 2) THEN
BEGIN
FLDVALID[FLDIND] = FALSE;
RETURN;
END
CHARPOS = CHARPOS + 1;
FIELD[I] = FVAL;
END
IF CHARPOS NQ FLDLENGTH[FLDIND] THEN
BEGIN # CHECK FOR EXTRA CHARACTERS #
SKPBLK(FLDIND,CHARPOS,CHAR);
IF CHARPOS LQ FLDLENGTH[FLDIND] - 1 THEN
BEGIN # NON-BLANK CHAR AFTER DATE #
FLDVALID[FLDIND] = FALSE;
RETURN;
END
END
IF DATEDEL[1] NQ DATEDEL[0] THEN
BEGIN
FLDVALID[FLDIND] = FALSE;
RETURN;
END
GOTO DATETYPE[VARPICTYPE[VARIND]];
MMDDYY: # SET MONTH, DAY, YEAR VALUES #
MM = FIELD[0];
DD = FIELD[1];
YY = FIELD[2];
GOTO CHECKDATE;
YYMMDD: # SET MONTH, DAY, YEAR VALUES #
YY = FIELD[0];
MM = FIELD[1];
DD = FIELD[2];
GOTO CHECKDATE;
DDMMYY: # SET MONTH, DAY, YEAR VALUES #
DD = FIELD[0];
MM = FIELD[1];
YY = FIELD[2];
CHECKDATE: # CHECK FOR VALID DATE VALUE #
IF MM GR 12 OR MM LS 1 THEN
BEGIN # INVALID MONTH #
FLDVALID[FLDIND] = FALSE;
RETURN;
END
IF MM EQ 2 THEN # CHECK IF LEAP YEAR FEBRUARY #
BEGIN
TEMP1 = YY / 4;
TEMP1 = YY - (4 * TEMP1);
IF TEMP1 EQ 0 THEN MM = 0;
END
IF DD GR MONLENGTH[MM] OR DD LS 1 THEN
BEGIN # INVALID DAY #
FLDVALID[FLDIND] = FALSE;
RETURN;
END
IF MM EQ 0 THEN MM = 2;
IVAL = YY*10000 + MM*100 + DD;
END # DATEVL #
CONTROL EJECT;
PROC ERRMSG(PANELNAME,PROCNAME,PROCMSG,FATAL);
# TITLE ERRMSG - ERROR MESSAGE PROCEDURE. #
BEGIN # ERRMSG #
#
** ERRMSG - ERROR MESSAGE PROCEDURE.
*
* THIS PROCEDURE ISSUES A DAYFILE MESSAGE INDICATING WHICH
* PANEL CAUSED AN ERROR AND THE PROCEDURE THAT DETECTED IT.
* IT ALSO TERMINATES THE PROGRAM IF THE ERROR IS FATAL.
*
* PROC ERRMSG(PANELNAME,PROCNAME,PROCMSG,FATAL)
*
* ENTRY PANELNAME = THE NAME OF THE PANEL.
* PROCNAME = THE NAME OF THE EXTERNAL PROCEDURE
* THAT DETECTED THE ERROR.
* PROCMSG = THE ERROR MESSAGE.
* FATAL = TRUE IF THE ERROR IS FATAL, FALSE OTHERWISE.
*
* EXIT MESSAGE ISSUED TO DAYFILE, PROGRAM TERMINATED IF FATAL
* IS TRUE.
*
*IF UNDEF,QTRM
* CALLS VDTCLO, VDTCLS, VDTMSG$, VDTSTM.
*ELSE
*ENDIF
*
* USES TERACTIVEP, TERACTPANI, TERCNWRIOV, TERMESREAD,
* TERMESWRIT, TERSCREENM, TERSHOWFLG.
*
* NOTES THIS PROCEDURE IS CALLED BY SFCLOS WHEN A PANEL CANNOT BE
* CLOSED (INFORMATIVE MESSAGE ONLY), BY GETADD WHEN A READ,
* WRITE, OR SHOW OF A PANEL THAT IS NOT IN THE PANEL LOAD
* TABLE IS ATTEMPTED (INFORMATIVE MESSAGE AND TERMINATION
* OF PROGRAM), BY WRIPAN WHEN AN ATTEMPT IS MADE TO WRITE
* AN OVERLAY PANEL BEFORE A PRIMARY PANEL (INFORMATIVE
* MESSAGE AND TERMINATION OF PROGRAM) AND BY SFLOAD IF
* AN INTERNAL FAST DYNAMIC LOADER ERROR HAS OCCURRED
* (INFORMATIVE MESSAGE ONLY).
#
ITEM PANELNAME C(7); # PANEL NAME #
ITEM PROCNAME C(6); # PROCEDURE NAME #
ITEM PROCMSG C(20); # DAYFILE ERROR MESSAGE #
ITEM FATAL B; # PANEL NAME #
ITEM DAYFILE I = 0; # ISSUE MESSAGE TO DAYFILE #
ITEM DAYMESSAGE C(41) = " XXXXXX - PANEL ";
ITEM EMPTY I = O"00"; # OCTAL ZERO / COLON #
*IF UNDEF,QTRM
ITEM LINE I = 0; # INDICATES LINE MODE TO VDT #
ITEM NOMSG I = 0; # NO B-DISPLAY MESSAGE #
*ENDIF
ITEM NONAME C(25) = "NAME IS BLANK. "; # ERROR MSG. #
*IF UNDEF,QTRM
ITEM RECALL I = 1; # RECALL PARAMETER FOR VDTCLO #
*ENDIF
ITEM PANINDEX I; # INDEX INTO PANEL NAME #
ITEM PANLEN I; # LENGTH OF PANEL NAME #
*IF UNDEF,QTRM
ITEM PLTCOUNT I; # COUNTER TO CLEAR PLT #
*ENDIF
ITEM SPACE I = O"55"; # DISPLAY CODE BLANK #
C<1,6>DAYMESSAGE = PROCNAME; # PUT IN PROCEDURE NAME #
PANLEN = 0;
FOR PANINDEX = 0 STEP 1 UNTIL 6 DO
BEGIN # FIND PANEL NAME LENGTH #
IF C<PANINDEX,1>PANELNAME NQ SPACE
AND C<PANINDEX,1>PANELNAME NQ EMPTY THEN
BEGIN # IF NOT AT END OF PANEL NAME #
PANLEN = PANINDEX + 1;
END
END
IF PANLEN EQ 0 OR PANELNAME EQ 0 THEN
BEGIN # IF BLANK PANEL NAME #
C<16,25>DAYMESSAGE = NONAME; # OVER RIDE PROCEDURE MSG. #
END
ELSE
BEGIN # PUT IN NAME AND MESSAGE #
C<16,PANLEN>DAYMESSAGE = PANELNAME;
C<16+PANLEN,25-PANLEN>DAYMESSAGE = PROCMSG;
END
VDTMSG$(DAYMESSAGE,DAYFILE,1); # ISSUE DAYFILE MESSAGE #
IF FATAL THEN
BEGIN # IF FATAL ERROR #
*IF UNDEF,QTRM
IF TERSCREENM[0] THEN
BEGIN # IF IN SCREEN MODE #
IF NOT TERVDTBOOC[0] THEN
BEGIN # IF FIRST WRITE #
VDTBOO; # BEGIN OUTPUT SEQUENCE #
END
VDTCLS; # CLEAR SCREEN #
FOR PLTCOUNT = 1 STEP 1 UNTIL PLTNUMENT[0] DO
BEGIN # CLEAR SEQUENCE NUMBERS #
PLTENTRYNM[PLTCOUNT] = 0;
END
PLTNUMONSC[0] = 0; # NO PANELS ON SCREEN #
TERMESWRIT[0] = FALSE;
TERMESREAD[0] = FALSE;
VDTSTM(LINE,DUMMY); # SET LINE MODE #
IF NOT TERNOVDTEO[0] THEN VDTEOO;
TERVDTBOOC[0] = FALSE;
VDTCLO(RECALL); # FLUSH OUTPUT, RECALL #
END
TERACTPANL[0] = " "; # CLEAR ACTIVE PANEL NAME #
TERACTPLTI[0] = 0; # CLEAR PLT INDEX #
TERCNWRIOV[0] = FALSE; # DO NOT ALLOW OVERLAY WRITE #
VDTMSG$(NOMSG,1,1); # CLEAR B-DISPLAY #
TERSHOWFLG[0] = FALSE;
TERREADFLG[0] = FALSE;
ABORT; # ABORT THE PROGRAM #
*ELSE
ABORT; # ABORT THE USER #
*ENDIF
END
END # ERRMSG #
CONTROL EJECT;
PROC FFIELD(INPOS,FIELD,OFFSET,OUTFLAG);
# TITLE FFIELD - FIND INPUT FIELD. #
BEGIN # FFIELD #
#
** FFIELD - FIND INPUT FIELD.
*
* THIS PROCEDURE FINDS THE ACTIVE INPUT FIELD ASSOCIATED WITH
* THE INPUT RECEIVED FROM SCREEN POSITION INPOS.
*
* PROC FFIELD(INPOS,FIELD,OFFSET)
*
* ENTRY INPOS = X/Y POSITION
* OUTFLAG = TRUE, INCLUDE ACTIVE OUTPUT ONLY
* FIELDS IN THE SEARCH.
*
* EXIT FIELD = FIELD ASSOCIATED WITH INPUT.
* = -1 IF NOT IN A FIELD.
* OFFSET = OFFSET OF INPUT INTO FIELD.
*
* NOTES FFIELD ASSUMES THAT FIELDS DO NOT SPAN LINES.
#
ITEM INPOS I; # X/Y POSITION #
ITEM FIELD I; # INDEX INTO FLDLIST #
ITEM OFFSET I; # OFFSET INTO FIELD #
ITEM OUTFLAG B; # INCLUDE OUT-ONLY FIELDS #
ITEM I I; # LOOP COUNTER #
ITEM NOTEND B; # NOT END OF SEARCH #
FIELD = -1; # NOT FOUND UNTIL PROVEN FOUND #
NOTEND = TRUE;
OFFSET = 0;
FOR I = 0 STEP 1 WHILE NOTEND
AND FLDENTRY[I] NQ 0 DO
BEGIN # FIND FIELD CHAR WAS ENTERED IN #
IF INPOS LS FLDPOS[I] AND FLDACTIVE[I] THEN NOTEND = FALSE;
ELSE
BEGIN
IF (FLDINPUTV[I] AND FLDACTIVE[I])
OR (FLDVARFLAG[I] AND OUTFLAG AND FLDACTIVE[I]) THEN
BEGIN
FIELD = I;
END
END
END
IF VALIDFIELD THEN
BEGIN # IF VALID FIELD FOUND #
OFFSET = INPOS - FLDPOS[FIELD];
IF OFFSET GQ FLDLENGTH[FIELD] THEN
BEGIN # INPUT BEYOND END OF FIELD #
OFFSET = 0;
FIELD = -1;
END
END
END # FFIELD #
CONTROL EJECT;
PROC FFIRST(FLDIND);
# TITLE FFIRST - FIND FIRST INPUT FIELD. #
BEGIN # FFIRST #
#
** FFIRST - FIND FIRST INPUT FIELD.
*
* THIS PROCEDURE FINDS THE FIRST ACTIVE INPUT FIELD IN THE PANEL
* THAT DOES NOT HAVE A VALID ENTRY. IF ALL INPUT FIELDS ARE BOTH
* ENTERED AND VALID THEN THE FIRST ACTIVE INPUT FIELD IS RETURNED.
*
* PROC FFIRST(FLDIND)
*
* EXIT FLDIND = INDEX OF FIRST INPUT FIELD
* = -1, IF NO INPUT FIELD FOUND.
#
ITEM FLDIND I; # FIELD INDEX #
ITEM FIRST B; # STILL LOOKING FOR FIRST FIELD #
ITEM FOUND B; # FOUND AN UNENTERED INPUT FIELD #
ITEM I I; # LOOP COUNTER #
FLDIND = -1;
FIRST = TRUE;
FOUND = FALSE;
FOR I = 0 STEP 1 WHILE NOT FOUND AND FLDENTRY[I] NQ 0 DO
BEGIN # SEARCH FIELD LIST #
IF FLDINPUTV[I] AND NOT FOUND AND FLDACTIVE[I]
AND (NOT FLDENTERED[I] OR NOT FLDVALID[I]) THEN
BEGIN # FIRST AVAILABLE FIELD #
FIRST = FALSE;
FOUND = TRUE;
FLDIND = I;
END
ELSE IF FIRST AND FLDINPUTV[I] AND FLDACTIVE[I] THEN
BEGIN # FIRST INPUT FIELD #
FIRST = FALSE;
FLDIND = I;
END
END
END # FFIRST #
CONTROL EJECT;
PROC FMATCH(FLDIND,MATCHIND,MATCHCOUNT);
# TITLE FMATCH - FIND ENTRY IN MATCH LIST. #
BEGIN # FMATCH #
#
** FMATCH - FIND ENTRY IN MATCH LIST.
*
* THIS PROCEDURE FINDS THE FIRST ENTRY IN THE VARIABLE MATCH LIST
* WHICH MATCHES THE ENTERED CHARACTERS COMPLETELY OR IN PART.
*
* PROC FMATCH(FLDIND,MATCHIND,MATCHCOUNT)
*
* ENTRY FLDIND = POINTER INTO FLDLIST OF CURRENT FIELD.
*
* EXIT MATCHIND = INDEX INTO MATCHLIST OF FIRST VALID MATCH.
* = -1 IF NO VALID MATCH FOUND.
* MATCHCOUNT = NUMBER OF VALID MATCHES FOUND.
* -1 IF EXACT (TO 10 CHARACTERS) MATCH FOUND.
#
ITEM FLDIND I; # INDEX OF FIELD IN FLDLIST #
ITEM MATCHIND I; # INDEX OF MATCH IN MATCHLIST #
ITEM MATCHCOUNT I; # NUMBER OF VALID MATCHES FOUND #
ITEM CHARPOS I; # INPUT CHAR POSITION IN FIELD #
ITEM EXACT B; # EXACT MATCH FOUND #
ITEM I I; # LOOP COUNTER #
ITEM INPCHAR I; # INPUT CHARACTER #
ITEM LASTCHARP I; # LAST INPUT CHARACTER POSITION #
ITEM MATCHCHAR I; # MATCH CHARACTER #
ITEM MATCHCI I; # CHAR INDEX OF MATCH CHARACTER #
ITEM MATCHED B; # INPUT MATCHED LIST ENTRY #
ITEM MATCHLEN I; # LENGTH OF MATCH STRING #
ITEM MATCHMAX I; # EXACT MATCH CHARACTER COUNT #
ITEM MATCHWDS I; # NUMBER OF WORDS TO HOLD FIELD #
ITEM MATCHWI I; # WORD INDEX OF MATCH CHARACTER #
ITEM STARTCHARP I; # FIRST INPUT CHARACTER POSITION #
ITEM VARIND I; # INDEX INTO VARLIST #
VARIND = FLDVARORD[FLDIND];
P<MATCHLIST> = LOC(RECWORDC[0]) + VARVALOS[VARIND];
MATCHCHAR = 0;
LASTCHARP = -1;
STARTCHARP = -1;
FOR I = 0 STEP 1 UNTIL FLDLENGTH[FLDIND] - 1 DO
BEGIN # LOOK FOR FIRST AND LAST CHAR #
IF NEXTCHAR(FLDIND,I) NQ BLANK THEN
BEGIN # NON-BLANK CHARACTER #
LASTCHARP = I;
IF STARTCHARP EQ -1 THEN STARTCHARP = I;
END
END
IF STARTCHARP EQ -1 THEN
BEGIN # NO CHARACTERS FOUND #
STARTCHARP = 0;
LASTCHARP = 0;
END
MATCHLEN = LASTCHARP - STARTCHARP + 1;
MATCHMAX = FLDLENGTH[FLDIND];
IF PANVERSION[0] EQ 0 THEN
BEGIN # IF MATCH ENTRIES ONLY 10 CHAR. #
IF MATCHMAX GR 10 THEN
BEGIN
MATCHMAX = 10;
IF MATCHLEN GR 10 THEN MATCHLEN = 10;
END
END
MATCHWDS = (MATCHMAX+9)/10; # WORDS PER MATCH ENTRY #
MATCHIND = -MATCHWDS; # DEFAULT INDEX IF NO MATCH #
MATCHCOUNT = 0;
FOR MATCHWI = 0 STEP MATCHWDS WHILE MATCHWORD[MATCHWI] NQ 0
AND MATCHCOUNT GQ 0 DO
BEGIN
MATCHED = TRUE;
CHARPOS = STARTCHARP;
FOR MATCHCI = 0 STEP 1 WHILE MATCHED AND MATCHCI LS MATCHLEN DO
BEGIN # CHECK CHARACTERS FOR MATCH #
B<48,12>MATCHCHAR = C<MATCHCI*2,2>MATCH[MATCHWI];
INPCHAR = NEXTCHAR(FLDIND,CHARPOS);
IF UPPER(MATCHCHAR) NQ UPPER(INPCHAR) THEN MATCHED = FALSE;
CHARPOS = CHARPOS + 1;
END
IF MATCHED THEN
BEGIN # FIRST (MATCHLEN) CHARS MATCH #
EXACT = TRUE;
FOR MATCHCI = MATCHLEN STEP 1 UNTIL MATCHMAX-1 DO
BEGIN # CHECK REST OF CHARS FOR BLANKS #
IF C<MATCHCI*2,2>MATCH[MATCHWI] NQ BLANK THEN EXACT = FALSE;
END
IF EXACT THEN
BEGIN # EXACT MATCH FOUND #
MATCHCOUNT = -1; # FLAG ENTRY FOUND #
MATCHIND = MATCHWI;
END
ELSE
BEGIN # PARTIAL MATCH FOUND #
MATCHCOUNT = MATCHCOUNT + 1;
IF MATCHCOUNT EQ 1 THEN MATCHIND = MATCHWI; # IF FIRST ONE #
END
END
END
END # FMATCH #
CONTROL EJECT;
PROC FUNKEY(INPOS,OFFSET,FUNTYPE,ORDINAL,FIELD);
# TITLE FUNKEY - PROCESS FUNCTION KEY ACTION. #
BEGIN # FUNKEY #
#
** FUNKEY - PROCESS FUNCTION KEY ACTION.
*
* THIS PROCEDURE SEARCHES THE FUNCTION LIST TO FIND THE ACTION TO
* AKE FOR THE FUNCTION KEY, IF ANY. IT THEN TAKES THE DEFINED
* ACTION IF NO SOFT TABS ARE PENDING. IF SOFT TABS ARE PENDING
* THE FUNCTION IS IGNORED AND IF THE FUNCTION KEY DOES NOT HAVE
* A DEFINED ACTION THE SOFT TAB COUNTER WILL BE INCREMENTED. THE
* ONLY EXCEPTION IS A HELP REQUEST WHICH WILL SET HELP PENDING
* TO BE PROCESSED AFTER ALL SOFT TABS HAVE BEEN PROCESSED.
*
* PROC FUNKEY(INPOS,OFFSET,FUNTYPE,ORDINAL,FIELD)
*
* ENTRY INPOS = X/Y POSITION WHERE FUNCTION WAS ENTERED.
* OFFSET = OFFSET INTO FIELD WHERE FUNCTION WAS ENTERED.
* FUNTYPE = 24, GENERIC FUNCTION KEY.
* = 23, APPLICATION FUNCTION KEY.
* ORDINAL = FUNCTION KEY ORDINAL.
* FIELD = FIELD WHERE FIELD WAS ENTERED.
* TERSOFTTAB = COUNT OF CURRENT SOFT TABS PENDING.
*
* EXIT INPOS = NEW X/Y POSITION
* FIELD = NEW FIELD POSITION
* TERSOFTTAB = UPDATED SOFT TAB COUNT
* TERSOFTPOS = INPOS IF FIRST SOFT TAB CREATED
* TERABNTERM = TRUE, TERMINATE INPUT ABNORMALLY
* TERNRMTERM = TRUE, TERMINATE INPUT NORMALLY
*
* CALLS FMATCH, MMATCH, TABKEY.
*
* USES TERABNTERM, TERFUNCGEN, TERFUNCORD, TERFUNCPOS,
* TERHELPFLD, TERHELPREQ, TERNRMTERM, TERPENDHLP,
* TERSOFTPOS, TERSOFTTAB.
*
* NOTES FLDENTERED, FLDVALID, FLDREWRITE, TERREWFLDS AND VARDATA
* UPDATED IF MATCH ADVANCE OCCURRED. SWITCH ACTTYPE MUST
* PARALLEL PDU DEFINITION FOR FUNCTION KEY ACTIONS.
#
ITEM INPOS I; # X/Y POSITION OF CURSOR #
ITEM OFFSET I; # OFFSET INTO FIELD #
ITEM FUNTYPE I; # APPLICATION OR GENERIC #
ITEM ORDINAL I; # FUNCTION KEY ORDINAL #
ITEM FIELD I; # INDEX OF FIELD #
DEF FH #9#; # ORDINAL FOR HELP AS AN ACTION #
DEF FM #10#; # ORDINAL FOR MATCH ADVANCE #
ITEM ACTION I; # ORDINAL OF ACTION #
ITEM CHAR I; # 12-BIT CHARACTER #
ITEM I I; # LOOP COUNTER #
ITEM MATCHCOUNT I; # NUMBER OF VALID MATCHES #
ITEM MATCHIND I; # INDEX INTO MATCHLIST #
ITEM NOTDONE B; # FUNCTION LIST ENTRY NOT FOUND #
ITEM SCRPOS I; # SCRATCH POSITION FOR TABKEY #
ITEM VARIND I; # INDEX INTO VARLIST #
SWITCH ACTTYPE # TYPE OF ACTION TO TAKE #
TABSOFTLY, # PROCESS SOFT TAB #
NORMTOAPP, # RETURN NORMALLY TO APPLICATION #
NORMTONOS, # RETURN NORMALLY TO OPER. SYS. #
ABNORTOAPP, # RETURN ABNORMALLY TO APPL. #
ABNORTONOS, # RETURN ABNORMALLY TO OPER. SYS #
PAGEFORWARD, # PAGE TABLE FORWARD #
PAGEBAKWARD, # PAGE TABLE BACKWARD #
INSERTROW, # INSERT ROW IN TABLE #
DELETEROW, # DELETE ROW IN TABLE #
GIVEHELP, # PROVIDE HELP #
MATCHADV; # ADVANCE MATCH ENTRY #
# SAVE FUNCTION KEY ORDINAL AND KEY TYPE #
TERFUNCORD[0] = ORDINAL;
TERFUNCGEN[0] = FUNTYPE EQ SCREENST"GKEY";
TERFUNCPOS[0] = INPOS;
IF TERSOFTTAB[0] NQ 0 AND TERFUNCGEN[0]
AND ORDINAL EQ GENERICST"GNEXT" THEN
BEGIN # NEXT FOLLOWING SOFT TAB #
GOTO NOACTION;
END
IF PANSTRFUN[0] EQ 0 THEN
BEGIN # NO FUNCTION LIST #
IF TERFUNCGEN[0] AND ORDINAL EQ GENERICST"GSTOP" THEN
BEGIN # DEFAULT STOP ACTION #
IF TERSOFTTAB[0] EQ 0 THEN
BEGIN # IF NO SOFT TABS PENDING #
GOTO ABNORTOAPP;
END
ELSE
BEGIN # IF SOFT TABS PENDING #
GOTO NOACTION;
END
END
IF TERFUNCGEN[0] AND ORDINAL EQ GENERICST"GHELP" THEN
BEGIN # IF HELP REQUESTED #
GOTO GIVEHELP; # PROVIDE HELP #
END
GOTO NORMTOAPP; # TAKE DEFAULT ACTION #
END
NOTDONE = TRUE;
FOR I = 0 STEP 1 WHILE NOTDONE AND FUNWORD[I] NQ 0 DO
BEGIN # LOOK FOR ENTRY IN FUNLIST #
IF ((FUNGENERIC[I] AND TERFUNCGEN[0])
OR (NOT FUNGENERIC[I] AND NOT TERFUNCGEN[0]))
AND FUNNUMBER[I] EQ ORDINAL THEN
BEGIN # FOUND FUNLIST ENTRY #
NOTDONE = FALSE;
ACTION = FUNACT[I]; # ASSIGN DEFINED ACTION #
END
END
IF NOTDONE THEN
BEGIN # NOT IN LIST #
IF TERFUNCGEN[0] AND ORDINAL EQ GENERICST"GHELP" THEN
BEGIN
GOTO GIVEHELP;
END
ELSE GOTO TABSOFTLY; # PROCESS SOFT TAB #
END
IF TERFUNCGEN[0] AND ORDINAL EQ GENERICST"GHELP"
AND FIELD NQ -1 THEN
BEGIN # HELP KEY ENTERED IN A FIELD #
IF VARHSOS[FLDVARORD[FIELD]] NQ 0 THEN
BEGIN # HELP STRING DEFINED #
GOTO GIVEHELP; # GIVE HELP #
END
END
IF TERSOFTTAB[0] NQ 0 AND ACTION NQ FM AND ACTION NQ FH THEN
BEGIN # IF SOFT TABS PENDING #
GOTO NOACTION; # IGNORE UNLESS MATCH OR HELP #
END
ELSE
BEGIN # NO SOFT TABS PENDING #
GOTO ACTTYPE[ACTION]; # GO TO ASSIGNED ACTION #
END
PAGEFORWARD: # CURRENTLY A NO-OP #
PAGEBAKWARD: # CURRENTLY A NO-OP #
INSERTROW: # CURRENTLY A NO-OP #
DELETEROW: # CURRENTLY A NO-OP #
TERNRMTERM[0] = FALSE;
TERABNTERM[0] = FALSE;
RETURN;
TABSOFTLY: # PROCESS SOFT TAB #
IF TERSOFTTAB[0] EQ 0 THEN TERSOFTPOS[0] = INPOS;
TERSOFTTAB[0] = TERSOFTTAB[0] + 1; # INCREMENT TAB COUNT #
NOACTION: # NO ACTION TO OCCUR #
TERNRMTERM[0] = FALSE;
TERABNTERM[0] = FALSE;
RETURN;
NORMTOAPP: # NORMAL TERMINATION AND #
# RETURN TO APPLICATION #
TERNRMTERM[0] = TRUE;
TERABNTERM[0] = FALSE;
RETURN;
NORMTONOS: # NORMAL TERMINATION AND RETURN #
# TO OPERATING SYSTEM #
TERNRMTERM[0] = TRUE;
TERABNTERM[0] = FALSE;
RETURN;
ABNORTOAPP: # ABNORMAL TERMINATION AND #
# RETURN TO APPLICATION #
TERNRMTERM[0] = FALSE;
TERABNTERM[0] = TRUE;
RETURN;
ABNORTONOS: # ABNORMAL TERMINATION AND #
# RETURN TO OPERATING SYSTEM #
TERNRMTERM[0] = FALSE;
TERABNTERM[0] = TRUE;
RETURN;
GIVEHELP: # PROVIDE HELP #
IF TERSOFTTAB[0] NQ 0 THEN
BEGIN # IF SOFT TABS PENDING #
TERPENDHLP[0] = TRUE; # SET HELP PENDING FLAG #
END
ELSE
BEGIN # NO SOFT TABS PENDING #
IF FIELD EQ -1 THEN
BEGIN
TABKEY(SCREENST"FTAB",INPOS,FIELD,SCRPOS); # TAB TO NEXT FIELD #
IF FIELD EQ -1 THEN TABKEY(SCREENST"FTAB",SCRPOS,FIELD,SCRPOS);
TERHELPFLD[0] = FIELD;
FIELD = -1;
END
ELSE
BEGIN # GIVE HELP FOR THIS FIELD #
TERHELPFLD[0] = FIELD;
END
TERHELPREQ[0] = TRUE;
END
RETURN;
MATCHADV: # ADVANCE MATCH ENTRY #
IF TERSOFTTAB[0] NQ 0 OR NOT VALIDFIELD THEN GOTO TABSOFTLY;
IF FIELD EQ -1 THEN GOTO TABSOFTLY;
VARIND = FLDVARORD[FIELD];
IF (NOT VARVALM[VARIND]) OR (VARVALOS[VARIND] EQ 0)
THEN GOTO TABSOFTLY;
FMATCH(FIELD,MATCHIND,MATCHCOUNT);
IF PANVERSION[0] GR 0 THEN
BEGIN # IF ENTRIES CAN BE ANY LENGTH #
MATCHIND = MATCHIND + (FLDLENGTH[FIELD]+9)/10;
END
ELSE
BEGIN # IF ENTRIES ONLY 10 CHARACTERS #
MATCHIND = MATCHIND + 1;
END
IF MATCHWORD[MATCHIND] EQ 0 THEN MATCHIND = 0; # IF WRAPAROUND #
MMATCH(MATCHIND,FIELD); # MOVE MATCH ENTRY TO FIELD #
RETURN;
END # FUNKEY#
CONTROL EJECT;
PROC GETADD(PANELNAME,PANELADDR,PLTINDEX);
# TITLE GETADD - GETS PANEL ADDRESS. #
BEGIN # GETADD #
#
** GETADD - GET ADDRESS.
*
* THIS PROCEDURE GETS THE MEMORY ADDRESS FOR THE SPECIFIED
* PANEL FROM THE PANEL LOAD TABLE. IF THE PANEL IS NOT IN
* THE PANEL LOAD TABLE OR HAS NOT BEEN OPENED FOR USE THEN
* A DAYFILE MESSAGE WILL BE ISSUED AND CONTROL WILL BE RE-
* TURNED TO THE OPERATING SYSTEM.
*
* PROC GETADD(PANELNAME,PANELADDR,PLTINDEX)
*
* ENTRY PANELNAME = THE NAME OF THE PANEL.
*
* EXIT PANELADDR = THE ADDRESS OF THE PANEL RECORD.
* TO O.S. IF THE ADDRESS IS NOT FOUND
* OR THE PANEL IS NOT OPEN.
* PLTINDEX = THE PANEL LOAD TABLE INDEX FOR THE PANEL.
*
* CALLS ERRMSG.
*
* NOTES IF THE PANEL IS NOT IN THE PANEL LOAD TABLE THEN
* THE APPLICATION HAS NOT OPENED THE PANEL FOR USE
* OR HAS IGNORED AN ERROR RETURN FROM SFOPEN AFTER
* ATTEMPTING TO DO SO. IF THE PANEL IS IN THE LOAD
* TABLE BUT NOT OPEN IT IS A STATICALLY LOADED PANEL
* THAT THE APPLICATION HAS NOT YET OPENED. IN EITHER
* CASE PROCEDURE ERRMSG IS CALLED TO ISSUE A DAYFILE
* MESSAGE AND RETURN CONTROL TO THE OPERATING SYSTEM.
#
ITEM PANELNAME C(7); # PANEL NAME #
ITEM PANELADDR I; # PANEL ADDRESS #
ITEM PLTINDEX I; # PANEL LOAD TABLE INDEX #
ITEM CHARINDEX I; # CHARACTER INDEX #
ITEM FATAL B = TRUE; # FATAL ERROR #
ITEM INDEX I; # INDEX INTO PANEL LOAD TABLE #
ITEM MSG C(25) = " NOT OPENED. "; # ERROR MSG. #
ITEM PNAME C(6); # PROCEDURE NAME #
PANELADDR = 0;
FOR INDEX = 1 STEP 1 WHILE PANELADDR EQ 0
AND INDEX LQ PLTNUMENT[0] DO
BEGIN # FIND SPECIFIED PANEL #
IF PLTENAME[INDEX] EQ PANELNAME
AND PLTOPENFLG[INDEX] THEN
BEGIN # IF SPECIFIED PANEL FOUND #
PANELADDR = PLTADDR[INDEX]; # RETURN ADDRESS #
PLTINDEX = INDEX;
RETURN;
END
END
IF TERSHOWFLG[0] THEN
BEGIN # IF SFSSHO CALL #
PNAME = "SFSSHO";
END
ELSE
BEGIN # IF SFSREA CALL #
IF TERREADFLG[0] THEN
BEGIN
PNAME = "SFSREA";
END
ELSE # SFSWRI CALL #
BEGIN
PNAME = "SFSWRI";
END
END
ERRMSG(PANELNAME,PNAME,MSG,FATAL); # ISSUE MESSAGE AND ABORT #
END # GETADD #
CONTROL EJECT;
PROC GETNUM(FLDIND,CHARPOS,VALUE,NUMDIG);
# TITLE GETNUM - GET NUMERIC VALUE OF SUBFIELD. #
BEGIN # GETNUM #
#
** GETNUM - GET NUMERIC VALUE OF SUBFIELD.
*
* GETNUM GETS THE NUMERIC VALUE OF A SUBFIELD STARTING AT
* CHARPOS AND ENDING AT THE FIRST NON-NUMERIC INPUT OR AT
* THE END OF THE FIELD.
*
* PROC GETNUM(FLDIND,CHARPOS,VALUE,NUMDIG)
*
* ENTRY FLDIND = INDEX IN FLDLIST.
* CHARPOS = STARTING CHARACTER POSITION IN FIELD.
* VALUE = STARTING VALUE.
*
* EXIT CHARPOS = ENDING CHARACTER POSITION IN FIELD.
* VALUE = ENDING VALUE.
* NUMDIG = NUMBER OF DIGITS IN SUBFIELD.
#
ITEM FLDIND I; # INDEX IN FLDLIST #
ITEM CHARPOS I; # POSITION OF CHARACTER IN FIELD #
ITEM VALUE I; # NUMERIC VALUE OF SUBFIELD #
ITEM NUMDIG I; # NUMBER OF DIGITS IN SUBFIELD #
ITEM CHAR I; # INPUT CHARACTER #
ITEM SAMESUBFLD B; # STILL IN SAME SUBFIELD #
SAMESUBFLD = TRUE;
NUMDIG = 0;
WHYLE SAMESUBFLD AND CHARPOS LQ FLDLENGTH[FLDIND] -1 DO
BEGIN
CHAR = NEXTCHAR(FLDIND,CHARPOS);
IF CHAR GQ ZEROCH AND CHAR LQ NINECH THEN
BEGIN # IF CHARACTER IS NUMERIC #
VALUE = 10 * VALUE + (CHAR LXR ZEROCH);
NUMDIG = NUMDIG + 1;
CHARPOS = CHARPOS + 1;
END
ELSE
BEGIN # END OF SUBFIELD #
SAMESUBFLD = FALSE;
END
END
END # GETNUM #
CONTROL EJECT;
PROC GFIELD(VARNAME,USEROW,FLDIND);
# TITLE GFIELD - GET FIELD INDEX. #
BEGIN # GFIELD #
#
** GFIELD - GET FIELD INDEX.
*
* THIS PROCEDURE GETS THE FIELD INDEX FOR THE VARIABLE VARNAME.
*
* PROC GFIELD(VARNAME,USEROW,FLDIND)
*
* ENTRY VARNAME = VARIABLE NAME OF FIELD.
* USEROW = TRUE, USE TERCURSROW.
* = FALSE, USE ARRCURROW.
*
* EXIT FLDIND = FIELD INDEX.
* = -1 IF NOT FOUND.
#
ITEM VARNAME C(7); # VARIABLE NAME OF FIELD #
ITEM USEROW B; # USE TERCURSROW #
ITEM FLDIND I; # POINTER TO FIELD LIST #
ITEM ARRAYORD I; # ARRAY ORDINAL #
ITEM FOUND B; # FIELD HAS BEEN FOUND #
ITEM I I; # LOOP COUNTER #
ITEM ROWNUMBER I; # ROW NUMBER #
ITEM VARIND I; # POINTER TO VARIABLE LIST #
FLDIND = -1;
FOUND = FALSE;
FOR I = 0 STEP 1 WHILE VARTYPE[I] NQ 0 AND NOT FOUND DO
BEGIN # LOOK FOR VARIABLE VARNAME #
IF VARNME[I] EQ VARNAME THEN
BEGIN # FOUND SPECIFIED VARIABLE #
FOUND = TRUE;
VARIND = I;
END
END
IF FOUND THEN
BEGIN
ARRAYORD = VARARRORD[VARIND];
IF ARRAYORD NQ 0 THEN
BEGIN # ARRAY MEMBER #
ROWNUMBER = 0;
IF USEROW THEN
BEGIN # USE TERCURSROW #
IF TERCURSSET[0] AND TERCURSROW[0] LS ARRNUMROWS[ARRAYORD-1] THEN
BEGIN # VALID ROW NUMBER #
ROWNUMBER = TERCURSROW[0];
END
END
ELSE
BEGIN # USE CURRENT ROW #
ROWNUMBER = ARRCURROW[ARRAYORD-1];
END
VARIND = VARIND + ARRNUMVARS[ARRAYORD-1]*ROWNUMBER;
END
FLDIND = VARFLDNUM[VARIND] - 1; # ADJUST PDU VALUE #
END
END # GFIELD #
CONTROL EJECT;
PROC IRANGE(FLDIND,VALUE,EVALUE);
# TITLE IRANGE - RANGE VALIDATION FOR INTEGER VARIABLES. #
BEGIN # IRANGE #
#
** IRANGE - RANGE VALIDATION FOR INTEGER VARIABLES.
*
* THIS PROCEDURE VALIDATES THAT INPUT TO THE FIELD POINTED TO
* BY FLDIND IS WITHIN THE RANGE SPECIFIED IN THE PANEL RECORD.
*
* PROC IRANGE(FLDIND,VALUE,EVALUE)
*
* ENTRY FLDIND = INDEX OF CURRENT FIELD IN FLDLIST.
* VALUE = THE INTEGER VALUE OF THE INPUT.
* EVALUE = THE EXPONENT VALUE OF THE INPUT
*
* EXIT FLDVALID[FLDIND] = FALSE, IF INPUT IS INVALID.
#
ITEM FLDIND I; # INDEX OF VARIABLE TO VALIDATE #
ITEM VALUE I; # INTEGER VALUE OF INPUT #
ITEM EVALUE I; # EXPONENT VALUE OF INPUT #
ITEM MAXVAL I; # MAXIMUM ALLOWED VALUE #
ITEM MINVAL I; # MINIMUM ALLOWED VALUE #
ITEM OFFSET I; # OFFSET OF VALIDATION IN RECORD #
ITEM VARIND I; # INDEX INTO VARLIST #
VARIND = FLDVARORD[FLDIND];
OFFSET = VARVALOS[VARIND];
MINVAL = RECWORDU[OFFSET]; # MINIMUM VALID VALUE #
MAXVAL = RECWORDU[OFFSET + 1]; # MAXIMUM VALID VALUE #
IF VARPICTYPE[FLDVARORD[FLDIND]] EQ FORMTYPE"$" THEN
BEGIN # WEIGHT CURRENCY INPUT #
IF EVALUE EQ 0 THEN
BEGIN
VALUE = VALUE * 100;
END
ELSE
BEGIN
IF EVALUE EQ -1 THEN VALUE = VALUE * 10;
END
END
IF VALUE LS MINVAL OR VALUE GR MAXVAL THEN
BEGIN # IF VALUE OUTSIDE OF RANGE #
FLDVALID[FLDIND] = FALSE;
END
END # IRANGE #
CONTROL EJECT;
PROC MATCHV(FLDIND);
# TITLE MATCHV - MATCH VALIDATION. #
BEGIN # MATCHV #
#
** MATCHV - MATCH VALIDATION.
*
* THIS PROCEDURE PERFORMS MATCH VALIDATION FOR THE VARIABLE
* USING THE MATCH LIST IN THE PANEL RECORD.
*
* PROC MATCHV(FLDIND)
*
* ENTRY FLDIND = POINTER INTO FLDLIST OF CURRENT FIELD.
*
* EXIT FLDVALID[FLDIND] = FALSE, IF INPUT IS INVALID.
*
* CALLS FMATCH, MMATCH.
#
ITEM FLDIND I; # INDEX OF FIELD IN FLDLIST #
ITEM MATCHIND I; # INDEX INTO MATCHLIST #
ITEM MATCHCOUNT I; # NUMBER OF VALID MATCHES #
IF VARVALOS[FLDVARORD[FLDIND]]
EQ 0 THEN RETURN; # IF NO VALIDATION REQUIRED #
FMATCH(FLDIND,MATCHIND,MATCHCOUNT); # FIND MATCH #
IF ABS(MATCHCOUNT) NQ 1 THEN
BEGIN # NO MATCH OR TOO MANY MATCHES #
FLDVALID[FLDIND] = FALSE;
END
ELSE
BEGIN # EXACT OR PARTIAL MATCH FOUND #
MMATCH(MATCHIND,FLDIND); # RETURN IDENTICAL MATCH VALUE #
END
END # MATCHV #
CONTROL EJECT;
PROC MCLEAN(MCOUNT,MSGFIT);
# TITLE MCLEAN - MESSAGE CLEAN. #
BEGIN # MCLEAN #
#
** MCLEAN - MESSAGE CLEAN.
*
* THIS PROCEDURE CLEANS THE MESSAGE AREA.
*
* PROC MCLEAN(MCOUNT,MSGFIT)
*
* EXIT MCOUNT = THE LENGTH OF THE MESSAGE AREA.
* MSGFIT = TRUE, IF LONGEST MESSAGE WILL FIT.
*
* CALLS VDTCHR, VDTCLL, VDTPOS, VDTSAM.
*
* USES TERMESWRIT.
#
ITEM MCOUNT I; # LENGTH OF MESSAGE AREA #
ITEM MSGFIT B; # TRUNCATION FLAG #
ITEM I I; # LOOP VARIABLE #
IF PANMSGLEN[0] LS TERNUMCOLS[0] THEN
BEGIN # IF LONGEST MESSAGE FITS #
MSGFIT = TRUE;
MCOUNT = PANMSGLEN[0] -1;
IF MCOUNT LS 24 THEN MCOUNT = 24; # LONGEST SMF MESSAGE #
END
ELSE
BEGIN # USER HELP MAY NEED TRUNCATION #
MSGFIT = FALSE;
MCOUNT = TERNUMCOLS[0] - 1;
END
VDTSAM(ATTMASK[0]); # SET MESSAGE ATTRIBUTES #
IF TERTABPROT[0] THEN
BEGIN # IF TABS TO UNPROTECTED TRUE #
VDTPOS(0,0); # POSITION TO MESSAGE AREA #
FOR I = 0 STEP 1 UNTIL MCOUNT DO
BEGIN # BLANK OUT MESSAGE AREA #
VDTCHR(BLANK);
END
END
ELSE
BEGIN # NO PROTECT #
VDTCLL(0,0); # POSITION AND CLEAR LINE #
END
TERMESWRIT[0] = FALSE; # CLEAR MESSAGE WRITTEN FLAG #
END # MCLEAN #
CONTROL EJECT;
PROC MMATCH(MATCHIND,FIELD);
# TITLE MMATCH - MOVE MATCH VALUE INTO VARIABLE FIELD . #
BEGIN # MMATCH #
#
** MMATCH - MOVE MATCH VALUE INTO VARIABLE FIELD.
*
* THIS PROCEDURE MOES THE MATCH VALUE INTO THE VARIABLE FIELD
* IN VARDATA.
*
* PROC MMATCH(MATCHIND,FIELD)
*
* ENTRY MATCHIND = INDEX INTO MATCHLIST FOR MATCH TO MOVE.
* FIELD = INDEX OF FIELD TO RECEIVE MATCH VALUE.
*
* EXIT FLDENTERED, FLDVALID AND FLDREWRITE FLAGS SET FOR
* VARIABLE, AS WELL AS TERREWFLDS, MATCH VALUE MOVED.
*
* CALLS WRIVCH.
*
* USES TERREWFLDS.
#
ITEM MATCHIND I; # INDEX INTO MATCHLIST #
ITEM MATCHLEN I; # MATCH ENTRY LENGTH #
ITEM FIELD I; # INDEX OF FIELD IN FLDLIST #
ITEM CHAR I; # 12-BIT CHARACTER #
ITEM I I; # CHARACTER INDEX #
MATCHLEN = FLDLENGTH[FIELD];
IF PANVERSION[0] EQ 0 THEN MATCHLEN = 10;
FOR I = 0 STEP 1 UNTIL FLDLENGTH[FIELD] - 1 DO
BEGIN # MOVE MATCH ENTRY TO FIELD #
IF I LS MATCHLEN THEN
BEGIN # IF NO BLANK FILL NEEDED #
CHAR = C<I*2,2>MATCH[MATCHIND];
END
ELSE
BEGIN # MORE THAN TEN CHARACTERS #
CHAR = BLANK;
END
WRIVCH(FIELD,I,CHAR); # WRITE CHARACTER INTO VARDATA #
END
TERREWFLDS[0] = TRUE; # SET REWRITE, ENTERED AND VALID #
FLDVALID[FIELD] = TRUE;
FLDENTERED[FIELD] = TRUE;
FLDREWRITE[FIELD] = TRUE;
END # MMATCH #
CONTROL EJECT;
PROC MOVEFLD(VNAME,VLEN,VOS,STRG,SLEN,SOS,CSET,CLEN,COS,IOSTAT);
BEGIN
#
** MOVEFLD - MOVE FIELD.
*
* MOVEFLD TRANSFERS CHARACTERS TO/FROM A SPECIFIED PANEL FIELD
* FROM/TO A SPECIFIED STRING.
*
* PROC MOVEFLD(VNAME,VLEN,VOS,STRG,SLEN,SOS,CSET,CLEN,COS,IOSTAT)
*
* ENTRY VNAME = VARIABLE NAME OF FIELD.
* VLEN = LENGTH OF VARNAME PARAMETER.
* VOS = OFFSET OF VARNAME PARAMETER.
* STRG = VARIABLE FIELD STRING.
* SLEN = LENGTH OF STRING PARAMETER.
* SOS = OFFSET OF STRING PARAMETER.
* CSET = CHARACTER SET OF STRING (SEE SFCSET$).
* CLEN = LENGTH OF CSET PARAMETER.
* COS = OFFSET OF CSET PARAMETER.
* IOSTAT = 0, CALL WAS SFGETF.
* = 1, CALL WAS SFSETF.
*
* EXIT STRING MOVED, AND TRANSLATED IF NECESSARY.
* IOSTAT GQ 0, NUMBER OF 6 BIT CHARACTERS MOVED.
* LS 0, VARIABLE NOT FOUND IN ACTIVE PANELS.
#
ITEM VNAME C(11); # VARIABLE NAME #
ITEM VLEN I; # LENGTH OF VARNAME PARAMETER #
ITEM VOS I; # OFFSET INTO VARNAME PARAMETER #
ITEM STRG C(11); # INSTRING PARAMETER #
ITEM SLEN I; # LENGTH OF INSTRING #
ITEM SOS I; # OFFSET INTO INSTRING #
ITEM CSET C(11); # CHARACTER SET #
ITEM CLEN I; # LENGTH OF CHARACTER SET #
ITEM COS I; # OFFSET INTO CHARACTER SET #
ITEM IOSTAT I; # MOVE DIRECTION, STATUS RETURN #
ITEM ASCFLAG B; # CURRENT DEFAULT CHARACTER SET #
ITEM AS8FLAG B; # FLAGS #
ITEM CHARIND I; # VARDATA WORD CHARACTER INDEX #
ITEM CHARNUM I; # START OF FIELD IN VARDATA #
ITEM FLDIND I; # FIELD ORDINAL #
ITEM FLDLEN I; # FIELD LENGTH #
ITEM FROMCHAROS I; # SOURCE STRING OFFSET #
ITEM I I; # LOOP COUNTER #
ITEM TOCHAROS I; # DESTINATION STRING OFFSET #
ITEM USEROW B = FALSE; # DON-T USE CURSORROW #
ITEM VAR C(7); # VARIABLE NAME LEFT JUSTIFIED #
ITEM WORDIND I; # WORD INDEX INTO VARDATA #
IF VLEN LS 1 THEN VLEN = 7;
VAR = C<VOS,VLEN>VNAME;
GFIELD(VAR,USEROW,FLDIND); # GET ASSOCIATED FIELD #
IF FLDIND LS 0 THEN
BEGIN # IF FIELD NOT FOUND #
IOSTAT = -1;
RETURN;
END
ASCFLAG = TERASCFLAG[0]; # SAVE CURRENT CHARACTER SET #
AS8FLAG = TERAS8FLAG[0];
IF C<COS,1>CSET NQ " " THEN SFCSET$(CSET,CLEN,COS);
CHARNUM = FLDVDTCORD[FLDIND]; # START OF FIELD IN VARDATA #
WORDIND = CHARNUM/5; # WORD INDEX INTO VARDATA #
CHARIND = CHARNUM - (5 * WORDIND); # VARDATA WORD CHARACTER INDEX #
FLDLEN = FLDLENGTH[FLDIND];
IF IOSTAT EQ 0 THEN
BEGIN # IF MOVING VARDATA TO INSTRING #
P<FROMSTRING> = LOC(VDATAU[WORDIND]);
P<TOSTRING> = LOC(STRG);
TOCHAROS = SOS; # CHARACTER OFFSET / TO STRING #
FROMCHAROS = CHARIND*2; # CHARACTER OFFSET / VARDATA #
IF TERAS8FLAG[0] THEN
BEGIN # IF NO TRANSLATION REQUIRED #
IF SLEN LQ 0 THEN SLEN = FLDLEN * 2;
MVA8A8(FROMCHAROS,TOCHAROS,FLDLEN*2,SLEN,TRUE);
END
ELSE
BEGIN
IF TERASCFLAG[0] THEN
BEGIN # IF 6/12 ASCII #
MVA8AS(TOCHAROS,FROMCHAROS,SLEN,FLDLEN,TRUE);
END
ELSE
BEGIN # IF SIX BIT DISPLAY CODE #
MVA8DC(TOCHAROS,FROMCHAROS,SLEN,FLDLEN,TRUE);
END
END
END
ELSE
BEGIN # IF MOVING OUTSTRING TO VARDATA #
P<FROMSTRING> = LOC(STRG);
FROMCHAROS = SOS; # CHARACTER OFFSET / FROM STRING #
P<TOSTRING> = LOC(VDATAU[WORDIND]);
TOCHAROS = CHARIND * 2; # CHARACTER OFFSET / VARDATA #
IF TERAS8FLAG[0] THEN
BEGIN # IF NO TRANSLATION REQUIRED #
IF SLEN LQ 0 THEN SLEN = FLDLEN * 2;
MVA8A8(FROMCHAROS,TOCHAROS,SLEN,FLDLEN*2,TRUE);
END
ELSE
BEGIN
IF TERASCFLAG[0] THEN
BEGIN # IF 6/12 ASCII #
MVASA8(FROMCHAROS,TOCHAROS,SLEN,FLDLEN,TRUE);
END
ELSE
BEGIN # IF SIX BIT DISPLAY CODE #
MVDCA8(FROMCHAROS,TOCHAROS,SLEN,FLDLEN,TRUE);
END
END
FLDREWRITE[FLDIND] = TRUE;
TERREWFLDS[0] = FALSE; # REWRITE UPDATED FIELD #
REWFLD;
TERREWFLDS[0] = TRUE; # RESET FLAG TO DEFAULT #
END
TERASCFLAG[0] = ASCFLAG; # RESTORE INITIAL VALUES #
TERAS8FLAG[0] = AS8FLAG;
IOSTAT = SLEN;
RETURN;
END # MOVEFLD#
CONTROL EJECT;
PROC MOVEST(STRINGADDR,STRINGOS,SLENGTH);
# TITLE MOVEST - MOVE STRING. #
BEGIN # MOVEST #
#
** MOVEST - MOVE STRING.
*
* THIS PROCEDURE POSITIONS THE BASED ARRAYS TOSTRING
* AND FROMSTRING AND THEN CALLS THE PROPER PROCEDURE
* TO DO THE ACTUAL TRANSLATION AND TO MOVE THE STRING
* FROM OUTSTRING TO VARDATA (IF A WRITE OPERATION IS
* STARTING) OR FROM VARDATA TO INSTRING (IF A READ
* OPERATION IS FINISHED).
*
* PROC MOVEST(STRINGADDR,STRINGOS,SLENGTH)
*
* ENTRY STRINGADDR = THE FIRST WORD ADDRESS OF INSTRING
* OR OUTSTRING (DEPENDING ON WHICH
* DIRECTION THE CHARACTER DATA IS
* BEING MOVED).
* STRINGOS = CHARACTER OFFSET (IN SIX BIT CHAR-
* CTERS) INTO EITHER INSTRING OR OUT-
* STRING (DEPENDING ON WHICH DIRECTION
* THE CHARACTER DATA IS BEING MOVED).
* SLENGTH = LENGTH IN SIX BIT CHARACTERS.
* TERREADFLG = TRUE, IF MOVING FROM VARDATA TO INSTRING
* DURING AN SFSREA CALL, FALSE IF MOVING
* FROM OUTSTRING TO VARDATA DURING AN SFS-
* WRI CALL.
*
* EXIT STRING MOVED, AND TRANSLATED IF NECESSARY.
*
* CALLS MVASA8, MVA8AS, MVA8A8, MVA8DC, MVDCA8.
#
ITEM STRINGADDR I; # ADDRESS OF IN/OUTSTRING #
ITEM STRINGOS I; # CHARACTER OFFSET INTO STRING #
ITEM SLENGTH I; # LENGTH IN SIX BIT CHARACTERS #
ITEM FROMCHAROS I; # CHARACTER OFFSET / FROM STRING #
ITEM TOCHAROS I; # CHARACTER OFFSET / TO STRING #
IF NOT TERREADFLG[0] THEN
BEGIN # IF MOVING OUTSTRING TO VARDATA #
P<FROMSTRING> = STRINGADDR; # POSITION FROM AND TO STRING #
P<TOSTRING> = LOC(VDATAU[0]);
FROMCHAROS = STRINGOS; # CHARACTER OFFSET / FROM STRING #
TOCHAROS = 0; # NO CHARACTER OFFSET / VARDATA #
IF TERAS8FLAG[0] THEN
BEGIN # IF NO TRANSLATION REQUIRED #
IF SLENGTH LQ 0 THEN SLENGTH = PANNUMBYTE[0] * 2;
MVA8A8(FROMCHAROS,TOCHAROS,SLENGTH,PANNUMBYTE[0]*2,FALSE);
END
ELSE
BEGIN
IF TERASCFLAG[0] THEN
BEGIN # IF SIX TWELVE ASCII #
MVASA8(FROMCHAROS,TOCHAROS,SLENGTH,PANNUMBYTE[0],FALSE);
END
ELSE
BEGIN # IF SIX BIT DISPLAY CODE #
MVDCA8(FROMCHAROS,TOCHAROS,SLENGTH,PANNUMBYTE[0],FALSE);
END
END
END
ELSE
BEGIN # IF MOVING VARDATA TO INSTRING #
P<FROMSTRING> = LOC(VDATAU[0]); # POSITION FROM AND TO STRING #
P<TOSTRING> = STRINGADDR;
TOCHAROS = STRINGOS; # CHARACTER OFFSET / TO STRING #
FROMCHAROS = 0; # NO CHARACTER OFFSET / VARDATA #
IF TERAS8FLAG[0] THEN
BEGIN # IF NO TRANSLATION REQUIRED #
IF SLENGTH LQ 0 THEN SLENGTH = PANNUMBYTE[0] * 2;
MVA8A8(FROMCHAROS,TOCHAROS,PANNUMBYTE[0]*2,SLENGTH,FALSE);
END
ELSE
BEGIN
IF TERASCFLAG[0] THEN
BEGIN # IF SIX TWELVE ASCII #
MVA8AS(TOCHAROS,FROMCHAROS,SLENGTH,PANNUMBYTE[0],FALSE);
END
ELSE
BEGIN # IF SIX BIT DISPLAY CODE #
MVA8DC(TOCHAROS,FROMCHAROS,SLENGTH,PANNUMBYTE[0],FALSE);
END
END
END
END # MOVEST #
CONTROL EJECT;
PROC MVA8A8(FROMCHAROS,TOCHAROS,FROMLENGTH,TOLENGTH,FILL);
# TITLE MVA8A8 - MOVE ASCII8 STRING. #
BEGIN # MVA8A8 #
#
** MVA8A8 - MOVE ASCII8 STRING.
*
* THIS PROCEDURE MOVES THE ASCII8 CHARACTER DATA FROM OUTSTRING
* TO VARDATA BEFORE A WRITE, OR FROM VARDATA TO INSTRING AFTER
* A READ, USING THE BASED ARRAYS FROMSTRING AND TOSTRING. IF THE
* DESTINATION FIELD IS SHORTER THAN THE SOURCE FIELD, THE STRING
* WILL BE TRUNCATED. IF THE SOURCE FIELD IS SHORTER AND *FILL* IS
* *TRUE*, THE DESTINATION FIELD WILL BE BLANK FILLED.
*
* PROC MVA8A8(FROMCHAROS,TOCHAROS,FROMLENGTH,TOLENGTH,FILL)
*
* ENTRY BASED ARRAYS FROMSTRING AND TOSTRING POSITIONED.
* FROMCHAROS = THE CHARACTER OFFSET INTO FROMSTRING.
* TOCHAROS = THE CHARACTER OFFSET INTO TOSTRING.
* FROMLENGTH = LENGTH OF SOURCE FIELD.
* TOLENGTH = LENGTH OF DESTINATION FIELD.
* FILL = TRUE IF BLANK FILL REQUIRED.
*
* EXIT STRING MOVED.
*
* NOTE THE FIELD LENGTHS SPECIFY THE NUMBER OF SIX-BIT PARCELS
* RATHER THAN THE NUMBER OF TWELVE-BIT CHARACTERS.
#
ITEM FROMCHAROS I; # CHARACTER OFFSET / FROM STRING #
ITEM TOCHAROS I; # CHARACTER OFFSET / TO STRING #
ITEM FROMLENGTH I; # FROM STRING LENGTH #
ITEM TOLENGTH I; # TO STRING LENGTH #
ITEM FILL B; # TRUE IF BLANK FILL REQUIRED #
ITEM FROMINDEX I; # INDEX INTO FROMSTRING #
ITEM NUMCHARS I; # NUMBER OF PARCELS TO MOVE #
ITEM SPACE I = BLANK; # ASCII SPACE FOR BLANK FILL #
ITEM TOINDEX I; # INDEX INTO TOSTRING #
FROMINDEX = 0; # GET FIRST WORD FROM FROMSTRING #
TOINDEX = 0; # SET TOSTRING INDEX #
IF TOLENGTH LS FROMLENGTH THEN FROMLENGTH = TOLENGTH;
FOR NUMCHARS = 1 STEP 2 UNTIL FROMLENGTH DO
BEGIN # TRANSFER SIX BIT PARCELS #
C<TOCHAROS,2>TOSTRIU[TOINDEX] =
C<FROMCHAROS,2>FROMSTRIU[FROMINDEX];
FROMCHAROS = FROMCHAROS + 2; # INCREMENT FROMSTRING OFFSET #
IF FROMCHAROS EQ 10 THEN
BEGIN # IF FROMSTRING WORD IS EMPTY #
FROMCHAROS = 0; # RESET CHARACTER OFFSET #
FROMINDEX = FROMINDEX + 1; # UPDATE FROMSTRING WORD INDEX #
END
TOCHAROS = TOCHAROS + 2; # INCREMENT TOSTRING OFFSET #
IF TOCHAROS EQ 10 THEN
BEGIN # IF TOSTRING WORD IS FULL #
TOCHAROS = 0; # RESET CHARACTER OFFSET #
TOINDEX = TOINDEX + 1; # UPDATE TOSTRING WORD INDEX #
END
END
WHYLE FILL AND FROMLENGTH LS TOLENGTH DO
BEGIN
TOLENGTH = TOLENGTH - 2;
C<TOCHAROS,2>TOSTRIU[TOINDEX] = B<48,12>SPACE;
TOCHAROS = TOCHAROS + 2; # UPDATE TOSTRING OFFSET #
IF TOCHAROS EQ 10 THEN
BEGIN # IF TOSTRING WORD EXHAUSTED #
TOINDEX = TOINDEX + 2; # UPDATE TOSTRING WORD INDEX #
TOCHAROS = 0;
END
END
END # MVA8A8 #
CONTROL EJECT;
PROC MVASA8(STRINGOS,VAROS,SLENGTH,NUMVDCHARS,FILL);
# TITLE MVASA8 - MOVE AND TRANSLATE ASCII TO ASCII8. #
BEGIN # MVASA8 #
#
** MVASA8 - MOVE AND TRANSLATE ASCII TO ASCII8.
*
* THIS PROCEDURE MOVES THE CHARACTER DATA FROM OUTSTRING TO
* VARDATA BEFORE A WRITE, USING THE BASED ARRAYS FROMSTRING
* AND TOSTRING, TRANSLATING FROM ASCII TO ASCII8.
*
* PROC MVASA8(STRINGOS,VAROS,SLENGTH,NUMVDCHARS,FILL)
*
* ENTRY BASED ARRAYS FROMSTRING AND TOSTRING POSITIONED.
* STRINGOS = THE CHARACTER OFFSET INTO OUTSTRING.
* VAROS = THE CHARACTER OFFSET INTO VARDATA.
* SLENGTH = OUTSTRING LENGTH IN SIX BIT CHARACTERS.
* NUMVDCHARS = NUMBER OF CHARACTERS IN VARDATA.
* FILL = TRUE IF BLANK FILL REQUIRED.
*
* EXIT STRING MOVED AND TRANSLATED.
*
* NOTE SLENGTH IS NOT NECESSARILY THE NUMBER OF CHARACTERS
* (SINCE THEY CAN BE EITHER SIX OR TWELVE BITS LONG) BUT
* RATHER THE NUMBER OF SIX BIT PARCELS IN OUTSTRING.
#
ITEM STRINGOS I; # CHARACTER OFFSET / OUTSTRING #
ITEM SLENGTH I; # LENGTH IN SIX BIT CHARACTERS #
ITEM VAROS I; # CHARACTER OFFSET / VARDATA #
ITEM NUMVDCHARS I; # NUMBER OF CHARS. IN VARDATA #
ITEM FILL B; # TRUE IF BLANK FILL REQUIRED #
ITEM ASCIICHR I; # HOLDS AN ASCII CHARACTER #
ITEM ASCII8CHR I; # HOLDS AN ASCII8 CHARACTER #
ITEM ESCAPECODE I; # ESCAPE CODE FOR 12 BIT CHARS. #
ITEM FROMCHAROS I; # CHARACTER OFFSET / FROMSTRING #
ITEM FROMINDEX I; # INDEX INTO FROMSTRING #
ITEM NUMOTCHARS I; # NUMBER OF CHARS. IN OUTSTRING #
ITEM SPACE I = BLANK; # ASCII SPACE FOR BLANK FILL #
ITEM TOCHAROS I; # CHARACTER OFFSET / TOSTRING #
ITEM TOINDEX I; # INDEX INTO TOSTRING #
FROMINDEX = 0; # GET FIRST WORD FROM FROMSTRING #
FROMCHAROS = STRINGOS; # CHARACTER OFFSET IN FROMSTRING #
TOINDEX = 0; # START AT BEGINNING OF VARDATA #
TOCHAROS = VAROS; # CHARACTER OFFSET IN VARDATA #
ESCAPECODE = 0; # CLEAR ESCAPE CODE #
IF SLENGTH GR NUMVDCHARS * 2 OR SLENGTH LQ 0 THEN
SLENGTH = NUMVDCHARS * 2; # IF LENGTH ADJUSTMENT NEEDED #
NUMOTCHARS = 0; # INITIALIZE LOOP #
WHYLE NUMOTCHARS LS SLENGTH AND NUMVDCHARS GR 0 DO
BEGIN # TRANSLATE CHARACTERS #
NUMOTCHARS = NUMOTCHARS + 1; # INCREMENT OUTSTRING COUNT #
ASCIICHR = B<6*FROMCHAROS,6>FROMSTRIU[FROMINDEX];
FROMCHAROS = FROMCHAROS + 1; # UPDATE FROMSTRING CHAR. OFFSET #
IF FROMCHAROS EQ 10 THEN
BEGIN # IF FROMSTRING WORD EXHAUSTED #
FROMINDEX = FROMINDEX + 1; # UPDATE FROMSTRING WORD INDEX #
FROMCHAROS = 0;
END
IF ESCAPECODE NQ 0 THEN
BEGIN # IF HALF WAY THROUGH TWELVE BIT #
IF ESCAPECODE EQ 62 THEN
BEGIN # IF LOWER CASE ALPHABETIC #
ASCII8CHR = ASCIICHR + 96;
END
ELSE
BEGIN # IF SPECIAL ASCII CHARACTER #
ASCII8CHR = AS2A8[ASCIICHR];
END
ESCAPECODE = 0; # CLEAR ESCAPE CODE #
END
ELSE
BEGIN # IF SIX BIT ASCII CHARACTER #
IF ASCIICHR NQ 60 AND ASCIICHR NQ 62 THEN
BEGIN # IF NOT ESCAPE CODE #
ASCII8CHR = DC2A8[ASCIICHR];
END
ELSE
BEGIN
ESCAPECODE = ASCIICHR; # SAVE ESCAPE CODE #
END
END
IF ESCAPECODE EQ 0 THEN
BEGIN # IF CHARACTER TO MOVE #
NUMVDCHARS = NUMVDCHARS - 1; # DECREMENT VARDATA COUNT #
B<6*TOCHAROS,12>TOSTRIU[TOINDEX] = ASCII8CHR;
TOCHAROS = TOCHAROS + 2; # UPDATE TOSTRING CHAR. OFFSET #
IF TOCHAROS EQ 10 THEN
BEGIN # IF TOSTRING WORD IS FULL #
TOINDEX = TOINDEX + 1; # UPDATE TOSTRING WORD INDEX #
TOCHAROS = 0; # RESET CHARACTER OFFSET #
END
END
END
WHYLE FILL AND NUMVDCHARS GR 0 DO
BEGIN
NUMVDCHARS = NUMVDCHARS - 1;
C<TOCHAROS,2>TOSTRIU[TOINDEX] = B<48,12>SPACE;
TOCHAROS = TOCHAROS + 2; # UPDATE TOSTRING OFFSET #
IF TOCHAROS EQ 10 THEN
BEGIN # IF TOSTRING WORD EXHAUSTED #
TOINDEX = TOINDEX + 1; # UPDATE TOSTRING WORD INDEX #
TOCHAROS = 0;
END
END
END # MVASA8 #
CONTROL EJECT;
PROC MVA8AS(STRINGOS,VAROS,SLENGTH,NUMVDCHARS,FILL);
# TITLE MVA8AS - MOVE AND TRANSLATE ASCII8 TO ASCII. #
BEGIN # MVA8AS #
#
** MVA8AS - MOVE AND TRANSLATE ASCII8 TO ASCII.
*
* THIS PROCEDURE MOVES THE CHARACTER DATA FROM VARDATA TO
* INSTRING AFTER A READ, USING THE BASED ARRAYS FROMSTRING
* AND TOSTRING, TRANSLATING FROM ASCII8 TO ASCII.
*
* PROC MVA8AS(STRINGOS,VAROS,SLENGTH,NUMVDCHARS,FILL)
*
* ENTRY BASED ARRAYS FROMSTRING AND TOSTRING POSITIONED.
* STRINGOS = THE CHARACTER OFFSET INTO INSTRING.
* VAROS = THE CHARACTER OFFSET INTO VARDATA.
* SLENGTH = INSTRING LENGTH IN SIX BIT CHARACTERS.
* NUMVDCHARS = NUMBER OF CHARACTERS IN VARDATA.
* FILL = TRUE IF BLANK FILL REQUIRED.
*
* EXIT STRING MOVED AND TRANSLATED.
*
* NOTE SLENGTH IS NOT NECESSARILY THE NUMBER OF CHARACTERS
* (SINCE THEY CAN BE EITHER SIX OR TWELVE BITS LONG) BUT
* RATHER THE NUMBER OF SIX BIT PARCELS IN INSTRING.
#
ITEM STRINGOS I; # CHARACTER OFFSET / OUTSTRING #
ITEM SLENGTH I; # LENGTH IN SIX BIT CHARACTERS #
ITEM VAROS I; # CHARACTER OFFSET / VARDATA #
ITEM NUMVDCHARS I; # NUMBER OF CHARS. IN VARDATA #
ITEM FILL B; # TRUE IF BLANK FILL REQUIRED #
ITEM ASCIICHR I; # HOLDS AN ASCII CHARACTER #
ITEM ASCII8CHR I; # HOLDS AN ASCII8 CHARACTER #
ITEM ESCAPECODE I; # ESCAPE CODE #
ITEM FROMCHAROS I; # CHARACTER OFFSET / FROMSTRING #
ITEM FROMINDEX I; # INDEX INTO FROMSTRING #
ITEM NUMINCHARS I; # NUMBER OF CHARS. IN INSTRING #
ITEM TOCHAROS I; # CHARACTER OFFSET / TOSTRING #
ITEM TOINDEX I; # INDEX INTO TOSTRING #
FROMINDEX = 0; # GET FIRST WORD FROM FROMSTRING #
FROMCHAROS = VAROS; # CHARACTER OFFSET / VARDATA #
TOINDEX = 0;
TOCHAROS = STRINGOS; # CHARACTER OFFSET / INSTRING #
ESCAPECODE = 0; # CLEAR ESCAPE CODE #
IF SLENGTH LQ 0 THEN SLENGTH = NUMVDCHARS * 2;
NUMINCHARS = 0; # INITIALIZE LOOP #
WHYLE NUMINCHARS LS SLENGTH AND NUMVDCHARS GR 0 DO
BEGIN # TRANSLATE CHARACTERS #
ASCII8CHR = B<6*FROMCHAROS,12>FROMSTRIU[FROMINDEX];
NUMVDCHARS = NUMVDCHARS - 1; # DECREMENT VARDATA COUNT #
FROMCHAROS = FROMCHAROS + 2; # UPDATE FROMSTRING CHAR. OFFSET #
IF FROMCHAROS EQ 10 THEN
BEGIN # IF FROMSTRING WORD IS EMPTY #
FROMINDEX = FROMINDEX + 1; # UPDATE FROMSTRING WORD INDEX #
FROMCHAROS = 0; # RESET CHARACTER OFFSET #
END
IF ASCII8CHR GQ 97 THEN
BEGIN # IF LOWER CASE #
ESCAPECODE = 62;
ASCIICHR = ASCII8CHR - 96; # CONVERT TO UPPER CASE #
END
ELSE IF ASCII8CHR EQ TERASC8ATD[0] THEN
BEGIN # IF 64-COLON OR 63-PERCENT #
ESCAPECODE = 60; # SET ESCAPE CODE AND CHAR. #
ASCIICHR = 04;
END
ELSE IF ASCII8CHR EQ 64 THEN
BEGIN # IF AT SIGN #
ESCAPECODE = 60; # SET ESCAPE CODE AND CHAR. #
ASCIICHR = 01;
END
ELSE IF ASCII8CHR EQ 94 THEN
BEGIN # IF CIRCUMFLEX #
ESCAPECODE = 60; # SET ESCAPE CODE AND CHAR. #
ASCIICHR = 02;
END
ELSE IF ASCII8CHR EQ 96 THEN
BEGIN # IF REVERSE SLANT #
ESCAPECODE = 60; # SET ESCAPE CODE AND CHAR. #
ASCIICHR = 07;
END
IF ESCAPECODE NQ 0 THEN
BEGIN # IF TWELVE BIT CHARACTER #
IF NUMINCHARS LS SLENGTH-1 THEN
BEGIN # IF ROOM FOR ALL TWELVE BITS #
NUMINCHARS = NUMINCHARS + 1; # INCREMENT CHARACTER COUNT #
B<6*TOCHAROS,6>TOSTRIU[TOINDEX] = ESCAPECODE;
TOCHAROS = TOCHAROS + 1; # UPDATE TOSTRING CHAR. OFFSET #
IF TOCHAROS EQ 10 THEN
BEGIN # IF TOSTRING WORD IS FULL #
TOCHAROS = 0; # RESET CHARACTER OFFSET #
TOINDEX = TOINDEX + 1; # UPDATE TOSTRING WORD INDEX #
END
END
ESCAPECODE = 0; # CLEAR ESCAPE CODE #
END
ELSE
BEGIN
ASCIICHR = A82DC[ASCII8CHR]; # TRANSLATE CHARACTER #
END
IF ESCAPECODE EQ 0 THEN
BEGIN
NUMINCHARS = NUMINCHARS + 1; # INCREMENT CHARACTER COUNT #
B<6*TOCHAROS,6>TOSTRIU[TOINDEX] = ASCIICHR;
TOCHAROS = TOCHAROS + 1; # UPDATE TOSTRING CHAR. OFFSET #
IF TOCHAROS EQ 10 THEN
BEGIN # IF TOSTRING WORD IS FULL #
TOCHAROS = 0; # RESET CHARACTER OFFSET #
TOINDEX = TOINDEX + 1; # UPDATE TOSTRING WORD INDEX #
END
END
END
WHYLE FILL AND NUMINCHARS LS SLENGTH DO
BEGIN # IF BLANK FILL REQUIRED #
B<6*TOCHAROS,6>TOSTRIU[TOINDEX] = O"55";
SLENGTH = SLENGTH - 1; # DECREMENT CHARACTER COUNT #
TOCHAROS = TOCHAROS + 1; # UPDATE TOSTRING CHAR. OFFSET #
IF TOCHAROS EQ 10 THEN
BEGIN # IF TOSTRING WORD IS FULL #
TOCHAROS = 0; # RESET CHARACTER OFFSET #
TOINDEX = TOINDEX + 1; # UPDATE TOSTRING WORD INDEX #
END
END
END # MVA8AS #
CONTROL EJECT;
PROC MVA8DC(STRINGOS,VAROS,SLENGTH,NUMVDCHARS,FILL);
# TITLE MVA8DC - MOVE AND TRANSLATE ASCII8 TO DISPLAY CODE. #
BEGIN # MVA8DC #
#
** MVA8DC - MOVE AND TRANSLATE ASCII8 TO DISPLAY CODE.
*
* THIS PROCEDURE MOVES THE CHARACTER DATA FROM VARDATA TO
* INSTRING AFTER A READ, USING THE BASED ARRAYS FROMSTRING
* AND TOSTRING, TRANSLATING FROM ASCII8 TO DISPLAY CODE.
*
* PROC MVA8DC(STRINGOS,VAROS,SLENGTH,NUMVDCHARS,FILL)
*
* ENTRY BASED ARRAYS FROMSTRING AND TOSTRING POSITIONED.
* STRINGOS = THE CHARACTER OFFSET INTO INSTRING.
* VAROS = THE CHARACTER OFFSET INTO VARDATA.
* SLENGTH = INSTRING LENGTH IN SIX BIT CHARACTERS.
* NUMVDCHARS = LENGTH OF FIELD OR PANEL STRING.
* FILL = TRUE IF BLANK FILL REQUIRED.
*
* EXIT STRING MOVED AND TRANSLATED.
*
* NOTES SINCE INSTRING IS DEFINED IN THE APPLICATION PROGRAM
* AND THUS DOES NOT NECESSARILY START ON A WORD BOUNDARY
* TOCHAROS IS SET TO STRINGOS BEFORE THE LOOP IS BEGUN.
#
ITEM STRINGOS I; # CHARACTER OFFSET / OUTSTRING #
ITEM SLENGTH I; # LENGTH IN SIX BIT CHARACTERS #
ITEM VAROS I; # VARIABLE CHARACTER OFFSET #
ITEM NUMVDCHARS I; # FIELD/PANEL STRING LENGTH #
ITEM FILL B; # TRUE IF BLANK FILL REQUIRED #
ITEM FROMCHAROS I; # CHARACTER OFFSET / FROMSTRING #
ITEM FROMINDEX I; # INDEX INTO FROMSTRING #
ITEM NUMCHARS I; # NUMBER OF CHARACTERS TO TRANS. #
ITEM TOCHAROS I; # CHARACTER OFFSET / TOSTRING #
ITEM TOINDEX I; # INDEX INTO TOSTRING #
FROMCHAROS = VAROS; # CHARACTER OFFSET / VARDATA #
FROMINDEX = 0; # GET FIRST WORD FROM VARDATA #
TOINDEX = 0;
TOCHAROS = STRINGOS; # CHARACTER OFFSET / INSTRING #
IF SLENGTH LQ 0 THEN SLENGTH = NUMVDCHARS;
IF SLENGTH LS NUMVDCHARS THEN NUMVDCHARS = SLENGTH;
NUMCHARS = 0; # INITIALIZE CHARACTER COUNT #
WHYLE NUMCHARS LS NUMVDCHARS DO
BEGIN # MOVE AND TRANSLATE CHARACTER #
NUMCHARS = NUMCHARS +1; # INCREMENT CHARACTER COUNT #
B<6*TOCHAROS,6>TOSTRIU[TOINDEX] =
A82DC[B<6*FROMCHAROS,12>FROMSTRIU[FROMINDEX]];
FROMCHAROS = FROMCHAROS + 2; # UPDATE FROMSTRING CHAR. OFFSET #
IF FROMCHAROS EQ 10 THEN
BEGIN # IF FROMSTRING WORD IS EMPTY #
FROMCHAROS = 0; # RESET CHARACTER OFFSET #
FROMINDEX = FROMINDEX + 1; # UPDATE FROMSTRING WORD INDEX #
END
TOCHAROS = TOCHAROS + 1; # UPDATE TOSTRING CHAR. OFFSET #
IF TOCHAROS EQ 10 THEN
BEGIN # IF TOSTRING WORD IS FULL #
TOCHAROS = 0; # RESET CHARACTER OFFSET #
TOINDEX = TOINDEX + 1; # UPDATE TOSTRING WORD INDEX #
END
END
WHYLE FILL AND NUMCHARS LS SLENGTH DO
BEGIN # IF BLANK FILL REQUIRED #
SLENGTH = SLENGTH - 1;
B<6*TOCHAROS,6>TOSTRIU[TOINDEX] = O"55";
TOCHAROS = TOCHAROS + 1; # UPDATE TOSTRING OFFSET #
IF TOCHAROS EQ 10 THEN
BEGIN # IF TOSTRING WORD IS FULL #
TOCHAROS = 0; # RESET CHARACTER OFFSET #
TOINDEX = TOINDEX + 1; # UPDATE TOSTRING WORD INDEX #
END
END
END # MVA8DC #
CONTROL EJECT;
PROC MVDCA8(STRINGOS,VAROS,SLENGTH,NUMVDCHARS,FILL);
# TITLE MVDCA8 - MOVE AND TRANSLATE DISPLAY CODE TO ASCII8. #
BEGIN # MVDCA8 #
#
** MVDCA8 - MOVE AND TRANSLATE DISPLAY CODE TO ASCII8.
*
* THIS PROCEDURE MOVES THE CHARACTER DATA FROM OUTSTRING TO
* VARDATA BEFORE A WRITE, USING THE BASED ARRAYS FROMSTRING
* AND TOSTRING, TRANSLATING FROM DISPLAY CODE TO ASCII8.
*
* PROC MVDCA8(STRINGOS,VAROS,SLENGTH,NUMVDCHARS,FILL)
*
* ENTRY BASED ARRAYS FROMSTRING AND TOSTRING POSITIONED.
* STRINGOS = THE CHARACTER OFFSET INTO OUTSTRING.
* VAROS = THE CHARACTER OFFSET INTO VARDATA.
* SLENGTH = OUTSTRING LENGTH IN SIX BIT CHARACTERS.
* NUMVDCHARS = LENGTH OF FIELD OR PANEL STRING.
* FILL = TRUE IF BLANK FILL REQUIRED.
*
* EXIT STRING MOVED AND TRANSLATED.
*
* NOTES SINCE OUTSTRING IS DEFINED IN THE APPLICATION PROGRAM
* AND THUS DOES NOT NECESSARILY START ON A WORD BOUNDARY
* FROMCHAROS IS SET TO STRINGOS BEFORE THE LOOP IS BEGUN.
#
ITEM STRINGOS I; # CHARACTER OFFSET / OUTSTRING #
ITEM SLENGTH I; # LENGTH IN SIX BIT CHARACTERS #
ITEM VAROS I; # VARIABLE CHARACTER OFFSET #
ITEM NUMVDCHARS I; # FIELD/PANEL STRING LENGTH #
ITEM FILL B; # TRUE IF BLANK FILL REQUIRED #
ITEM FROMCHAROS I; # CHARACTER OFFSET / FROMSTRING #
ITEM FROMINDEX I; # INDEX INTO FROMSTRING #
ITEM NUMCHARS I; # NUMBER OF CHARACTERS TO TRANS. #
ITEM SPACE I = BLANK; # ASCII SPACE FOR BLANK FILL #
ITEM TOCHAROS I; # CHARACTER OFFSET / TOSTRING #
ITEM TOINDEX I; # INDEX INTO TOSTRING #
FROMCHAROS = STRINGOS; # CHARACTER OFFSET / OUTSTRING #
FROMINDEX = 0; # GET FIRST WORD FROM FROMSTRING #
TOINDEX = 0;
TOCHAROS = VAROS; # CHARACTER OFFSET / VARDATA #
IF SLENGTH GR NUMVDCHARS OR SLENGTH LQ 0 THEN
SLENGTH = NUMVDCHARS; # IF LENGTH ADJUSTMENT NEEDED #
FOR NUMCHARS = 1 STEP 1 UNTIL SLENGTH DO
BEGIN # TRANSLATE CHARACTERS #
B<6*TOCHAROS,12>TOSTRIU[TOINDEX] =
DC2A8[B<6*FROMCHAROS,6>FROMSTRIU[FROMINDEX]];
FROMCHAROS = FROMCHAROS + 1; # UPDATE FROMSTRING CHAR. OFFSET #
IF FROMCHAROS EQ 10 THEN
BEGIN # IF FROMSTRING WORD IS EMPTY #
FROMCHAROS = 0; # RESET CHARACTER OFFSET #
FROMINDEX = FROMINDEX + 1; # UPDATE FROMSTRING WORD INDEX #
END
TOCHAROS = TOCHAROS + 2; # UPDATE TOSTRING CHAR. OFFSET #
IF TOCHAROS EQ 10 THEN
BEGIN # IF TOSTRING WORD IS FULL #
TOCHAROS = 0; # RESET CHARACTER OFFSET #
TOINDEX = TOINDEX + 1; # UPDATE TOSTRING WORD INDEX #
END
END
WHYLE FILL AND SLENGTH LS NUMVDCHARS DO
BEGIN
NUMVDCHARS = NUMVDCHARS - 1;
B<6*TOCHAROS,12>TOSTRIU[TOINDEX] = B<48,12>SPACE;
TOCHAROS = TOCHAROS + 2; # INCREMENT TOSTRING OFFSET #
IF TOCHAROS EQ 10 THEN
BEGIN # IF FROMSTRING WORD IS EMPTY #
TOCHAROS = 0; # RESET CHARACTER OFFSET #
TOINDEX = TOINDEX + 1; # UPDATE FROMSTRING WORD INDEX #
END
END
END # MVDCA8 #
CONTROL EJECT;
PROC NCHECK(FLDIND,IVAL,EVAL,INPUTTYPE,DOLLARSIGN);
# TITLE NCHECK - NUMERIC CHECK OF INPUT FIELD. #
BEGIN # NCHECK #
#
** NCHECK - CHECK NUMERIC FIELD.
*
* THIS PROCEDURE CHECKS THAT THE INPUT FITS THE FORMAT SPECIFIED
* FOR THE FIELD AND CALULATES THE NUMERIC VALUE OF THE INPUT.
*
* PROC NCHECK(FLDIND,IVAL,EVAL,INPUTTYPE,DOLLARSIGN)
*
* ENTRY FLDIND = INDEX OF CURRENT FIELD IN FLDLIST.
*
* EXIT IVAL = INTEGER VALUE OF INPUT.
* EVAL = EXPONENT VALUE OF INPUT.
* INPUTTYPE = FORMAT TYPE OF INPUT.
* DOLLARSIGN = TRUE IF $ IN INPUT.
* FLDVALID[FLDIND] = FALSE, IF INVALID INPUT.
*
* CALLS GETNUM, SKPBLK.
#
ITEM FLDIND I; # INDEX IN FLDLIST #
ITEM IVAL I; # INTEGER VALUE #
ITEM EVAL I; # EXPONENT VALUE #
ITEM INPUTTYPE I; # FORMAT TYPE (9 N $ E BAD)#
ITEM DOLLARSIGN B; # $ IN INPUT #
ITEM CHAR I; # INPUT CHARACTER #
ITEM CHARPOS I; # CHARACTER POSITION IN FIELD #
ITEM COMMADEL I = O"0054"; # COMMA DELIMETER #
ITEM COMMATHERE B; # COMMA PRESENT FLAG #
ITEM DECIMALPT B; # DECIMAL POINT IN INPUT #
ITEM DIGITINT I; # NUMBER OF DIGITS IN INTEGER #
ITEM DIGITLIMIT I=17; # MAXIMUM DIGITS ALLOWED #
ITEM DIGITS I; # NUMBER OF DIGITS IN SUBFIELD #
ITEM DVAL I; # DECIMAL VALUE #
ITEM ESIGN I; # EXPONENT SIGN VALUE #
ITEM EXPONLIMIT I=322; # MAXIMUM EXPONENT ALLOWED #
ITEM I I; # LOOP COUNTER #
ITEM ISIGN I; # INTEGER SIGN VALUE #
ITEM PERIODDEL I = O"0056"; # PERIOD DELIMITER #
ITEM SOMEDIGITS B; # IF ANY NUMERIC INPUT #
ITEM TVAL I; # TEMPORARY VALUE #
ITEM VARIND I; # INDEX INTO VARLIST OF VARIABLE #
SOMEDIGITS = FALSE; # INITIAL VALUES #
COMMATHERE = FALSE;
DOLLARSIGN = FALSE;
DECIMALPT = FALSE;
VARIND = FLDVARORD[FLDIND];
CONTROL IFEQ EUROPEAN,1; # IF EUROPEAN CURRENCY FORMAT #
IF VARPICTYPE[VARIND] EQ FORMTYPE"$" THEN
BEGIN # CURRENCY FORMAT #
COMMADEL = PERIOD;
PERIODDEL = COMMA;
END
ELSE
BEGIN # NOT CURRENCY FORMAT #
COMMADEL = COMMA;
PERIODDEL = PERIOD;
END
CONTROL FI; # END EUROPEAN #
INPUTTYPE = FORMTYPE"BAD";
IVAL = 0;
DVAL = 0;
EVAL = 0;
TVAL = 0;
ISIGN = 1;
ESIGN = 1;
CHARPOS = 0;
DIGITINT = 0;
SKPBLK(FLDIND,CHARPOS,CHAR); # FIND START OF FIELD #
IF UPPER(CHAR) EQ CAPE THEN GOTO EXPSUBFLD; # START OF EXPONENT #
IF CHAR EQ DOLLAR THEN
BEGIN # CURRENCY INPUT #
DOLLARSIGN = TRUE;
INPUTTYPE = FORMTYPE"$";
CHARPOS = CHARPOS + 1;
END
IF CHAR EQ PLUS OR CHAR EQ MINUS THEN
BEGIN # SIGNED INPUT #
INPUTTYPE = FORMTYPE"N";
IF CHAR EQ MINUS THEN ISIGN = -1;
CHARPOS = CHARPOS + 1;
END
IF CHAR EQ PERIODDEL THEN GOTO DECSUBFLD; # START OF DECIMAL #
INTSUBFLD: # GET VALUE OF INTEGER SUBFIELD #
GETNUM(FLDIND,CHARPOS,IVAL,DIGITS);
DIGITINT = DIGITINT + DIGITS;
IF (COMMATHERE AND DIGITS NQ 3)
OR (DIGITINT GR DIGITLIMIT AND VARTYPE[VARIND] GR 1) THEN
BEGIN
INPUTTYPE = FORMTYPE"BAD";
RETURN;
END
IF DIGITS NQ 0 THEN SOMEDIGITS = TRUE;
IF NEXTCHAR(FLDIND,CHARPOS) EQ COMMADEL THEN
BEGIN # CURRENCY TYPE INPUT #
IF (NOT COMMATHERE AND DIGITS GR 3) OR DIGITS LS 1 THEN
BEGIN
INPUTTYPE = FORMTYPE"BAD";
RETURN;
END
DOLLARSIGN = TRUE;
COMMATHERE = TRUE;
IF CHARPOS GQ FLDLENGTH[FLDIND] - 1 THEN GOTO ENDOFFLD;
CHARPOS = CHARPOS + 1;
CHAR = NEXTCHAR(FLDIND,CHARPOS);
IF CHAR LS ZEROCH OR CHAR GR NINECH THEN
BEGIN # INVALID CHARACTER #
INPUTTYPE = FORMTYPE"BAD";
RETURN;
END
INPUTTYPE = FORMTYPE"$";
GOTO INTSUBFLD;
END
IVAL = ISIGN * IVAL;
IF CHARPOS GQ FLDLENGTH[FLDIND] THEN GOTO ENDOFFLD;
CHAR = NEXTCHAR(FLDIND,CHARPOS); # LOOK AT NEXT CHARACTER #
IF UPPER(CHAR) EQ CAPE THEN GOTO EXPSUBFLD; # START OF EXPONENT #
IF CHAR EQ PERIODDEL THEN GOTO DECSUBFLD; # START OF DECIMAL #
IF CHAR EQ MINUS OR CHAR EQ PLUS AND SOMEDIGITS THEN
BEGIN # START OF EXPONENT #
GOTO EXPSUBFLD;
END
IF CHAR EQ BLANK THEN GOTO ENDOFFLD; # END OF FIELD #
INPUTTYPE = FORMTYPE"BAD"; # BAD INPUT #
RETURN;
DECSUBFLD: # GET VALUE OF DECIMAL SUBFIELD #
DECIMALPT = TRUE;
INPUTTYPE = FORMTYPE"$";
CHARPOS = CHARPOS + 1;
IF CHARPOS GQ FLDLENGTH[FLDIND] THEN GOTO ENDOFFLD;
GETNUM(FLDIND,CHARPOS,DVAL,DIGITS);
DIGITINT = DIGITINT + DIGITS;
IF DIGITINT GR DIGITLIMIT AND VARTYPE[VARIND] GR 1 THEN
BEGIN # TOO MANY DIGITS ENTERED #
INPUTTYPE = FORMTYPE"BAD";
RETURN;
END
IF DIGITS NQ 0 THEN
BEGIN # SOME DECIMAL DIGITS ENTERED #
IF DIGITINT LQ DIGITLIMIT THEN
BEGIN
FOR I = 1 STEP 1 UNTIL DIGITS DO
BEGIN
IVAL = IVAL * 10;
END
IVAL = IVAL + DVAL*ISIGN;
END
SOMEDIGITS = TRUE;
END
EVAL = -DIGITS;
IF DIGITS GR 2 THEN INPUTTYPE = FORMTYPE"E";
IF CHARPOS GQ FLDLENGTH[FLDIND] THEN GOTO ENDOFFLD; # END OF FIELD #
CHAR = NEXTCHAR(FLDIND,CHARPOS);
IF CHAR EQ PLUS OR CHAR EQ MINUS
OR UPPER(CHAR) EQ CAPE THEN
BEGIN # START OF EXPONENT #
GOTO EXPSUBFLD;
END
IF CHAR EQ BLANK THEN GOTO ENDOFFLD; # END OF FIELD #
INPUTTYPE = FORMTYPE"BAD";
RETURN;
EXPSUBFLD: # GET VALUE OF EXPONENT SUBFIELD #
INPUTTYPE = FORMTYPE"E";
IF UPPER(CHAR) EQ CAPE THEN
BEGIN # SKIP E CHARACTER #
CHARPOS = CHARPOS + 1;
CHAR = NEXTCHAR(FLDIND,CHARPOS);
END
IF CHAR EQ MINUS THEN
BEGIN # NEGATIVE EXPONENT #
ESIGN = -1;
CHARPOS = CHARPOS + 1;
CHAR = NEXTCHAR(FLDIND,CHARPOS);
END
ELSE IF CHAR EQ PLUS THEN
BEGIN # POSITIVE EXPONENT #
CHARPOS = CHARPOS + 1;
CHAR = NEXTCHAR(FLDIND,CHARPOS);
END
GETNUM(FLDIND,CHARPOS,TVAL,DIGITS);
IF DIGITS EQ 0 OR DIGITS GR DIGITLIMIT THEN
BEGIN # TOO MANY OR NO DIGITS IN EXP #
INPUTTYPE = FORMTYPE"BAD";
RETURN;
END
EVAL = ESIGN * TVAL + EVAL;
ENDOFFLD: # END OF INPUT FIELD #
IF ABS(EVAL) + DIGITINT GR EXPONLIMIT THEN
BEGIN # INPUT NUMBER TOO LARGE #
INPUTTYPE = FORMTYPE"BAD";
RETURN;
END
IF (DOLLARSIGN AND (INPUTTYPE EQ FORMTYPE"E")) OR NOT SOMEDIGITS THEN
BEGIN # REAL INPUT WITH $ OR NO DIGITS #
INPUTTYPE = FORMTYPE"BAD";
RETURN;
END
IF SOMEDIGITS AND (FORMTYPE"NINE" GR INPUTTYPE) THEN
BEGIN # UNSIGNED INTEGER INPUT #
INPUTTYPE = FORMTYPE"NINE";
END
IF CHARPOS LQ FLDLENGTH[FLDIND] -1 THEN
BEGIN # CHECK FOR EXTRA CHARACTERS #
FOR I = CHARPOS STEP 1 UNTIL FLDLENGTH[FLDIND] -1 DO
BEGIN
IF NEXTCHAR(FLDIND,I) NQ BLANK THEN INPUTTYPE = FORMTYPE"BAD";
END
END
END # NCHECK #
CONTROL EJECT;
PROC PICVAL(FLDIND);
# TITLE PICVAL - PERFORM PICTURE VALIDATION. #
BEGIN # PICVAL #
#
** PICVAL - PERFORM PICTURE VALIDATION.
*
* THIS PROCEDURE VALIDATES THAT INPUT TO THE VARIABLE POINTED TO
* BY FLDIND CONFORMS WITH THE PICTURE TYPE SPECIFIED IN VARLIST.
*
* PROC PICVAL(FLDIND)
*
* ENTRY FLDIND = FLDLIST INDEX FOR FIELD TO BE CHECKED.
*
* EXIT FLDVALID[FLDIND] = FALSE, IF INPUT IS INVALID.
*
* CALLS DATEVL, NCHECK.
#
ITEM FLDIND I; # INDEX OF VARIABLE TO VALIDATE #
ITEM DOLLARSIGN B; # $ IN INPUT #
ITEM EVAL I; # EXPONENT VALUE OF INPUT #
ITEM INPIND I; # INDEX OF CHARACTER IN INPUT #
ITEM INPTYPE I; # FORMAT TYPE OF INPUT #
ITEM IVAL I; # INTEGER VALUE OF INPUT #
ITEM NCHAR I; # NEXT CHARACTER IN VARDATA #
ITEM PTYPE I; # PICTURE TYPE #
ITEM VARIND I; # INDEX INTO VARLIST OF VARIABLE #
SWITCH PICTURTYPE # PICTURE TYPE SWITCH #
,
PICX, # X PICTURE(DEFAULT) #
PICA, # ALPHA PICTURE #
PIC9, # INTEGER PICTURE #
PICN, # NUMERIC PICTURE #
PIC$, # DOLLAR PICTURE #
PICE, # REAL PICTURE #
PICY, # YYMMDD DATE PICTURE #
PICM, # MMDDYY DATE PICTURE #
PICD; # DDMMYY DATE PICTURE #
VARIND = FLDVARORD[FLDIND];
PTYPE = VARPICTYPE[VARIND] ;
GOTO PICTURTYPE[PTYPE];
PICX: # DISPLAYABLE CHARACTER TYPE #
RETURN;
PICA: # ALPHABETIC FORMAT #
FOR INPIND = 0 STEP 1 UNTIL FLDLENGTH[FLDIND] -1 DO
BEGIN
NCHAR = NEXTCHAR(FLDIND,INPIND);
IF NOT(NCHAR GQ CAPA AND NCHAR LQ CAPZ)
AND NOT(NCHAR GQ LOWA AND NCHAR LQ LOWZ)
AND NOT(NCHAR EQ BLANK) THEN
BEGIN # NOT ALPHABETIC INPUT #
FLDVALID[FLDIND] = FALSE;
END
END
RETURN;
PICY:
PICM:
PICD: # DATE FORMATS #
DATEVL(FLDIND,IVAL,EVAL);
RETURN;
PICE: # REAL FORMAT #
PIC9: # INTEGER FORMAT #
PICN: # SIGNED INTEGER FORMAT #
PIC$: # CURRENCY FORMAT #
NCHECK(FLDIND,IVAL,EVAL,INPTYPE,DOLLARSIGN);
IF (VARPICTYPE[VARIND] EQ FORMTYPE"E" AND DOLLARSIGN)
OR INPTYPE GR VARPICTYPE[VARIND] OR INPTYPE EQ FORMTYPE"BAD" THEN
BEGIN
FLDVALID[FLDIND] = FALSE;
END
RETURN;
END # PICVAL #
CONTROL EJECT;
PROC POSARR(PANELADDR);
# TITLE POSARR - POSITION PANEL RECORD BASED ARRAYS. #
BEGIN # POSARR #
#
** POSARR - POSITION PANEL RECORD BASED ARRAYS.
*
* THIS PROCEDURE POSITIONS THE BASED ARRAYS THAT DESCRIBE THE
* FORMAT OF THE INFORMATION IN PANEL RECORD USING THE ADDRESS
* PASSED IN PANELADDR.
*
* PROC POSARR(PANELADDR)
*
* ENTRY PANELADDR = FWA OF THE PANEL RECORD IN MEMORY.
*
* EXIT ALL PANEL RECORD BASED ARRAYS POSITIONED.
#
ITEM PANELADDR I; # THE ADDRESS OF THE PANEL #
ITEM ZEROWORD I = 0; # DUMMY FIELD LIST #
P<RECORD> = PANELADDR; # POSITION BASED ARRAYS #
P<PANELHEADR> = PANELADDR;
P<VDATA> = PANELADDR + PANHEADLEN;
IF PANSTRFLD[0] NQ 0 THEN
BEGIN # IF PANEL HAS FIELD LIST #
P<FLDLIST> = PANELADDR + PANSTRFLD[0];
END
ELSE
BEGIN # NO FIELD LIST, ONLY BOXES #
P<FLDLIST> = LOC(ZEROWORD);
END
P<VARLIST> = PANELADDR + PANSTRVAR[0];
P<FUNLIST> = PANELADDR + PANSTRFUN[0];
P<ATTLIST> = PANELADDR + PANSTRATT[0];
P<ARRLIST> = PANELADDR + PANSTRARR[0];
P<BOXLIST> = PANELADDR + PANSTRBOX[0];
END # POSARR #
CONTROL EJECT;
PROC POSTWO(PANELADDR);
# TITLE POSTWO - POSITION PANEL RECORD BASED ARRAYS FOR SFATTR. #
BEGIN # POSTWO #
#
** POSTWO - POSITION PANEL RECORD BASED ARRAYS FOR SFATTR.
*
* THIS PROCEDURE POSITIONS THE BASED ARRAYS THAT DESCRIBE THE
* FORMAT OF THE INFORMATION IN PANEL RECORD USING THE ADDRESS
* PASSED IN PANELADDR FOR USE BY SFATTR.
*
* PROC POSTWO(PANELADDR)
*
* ENTRY PANELADDR = FWA OF THE PANEL RECORD IN MEMORY.
*
* EXIT ALL PANEL RECORD BASED ARRAYS POSITIONED.
#
ITEM PANELADDR I; # THE ADDRESS OF THE PANEL #
ITEM ZEROWORD I = 0; # DUMMY FIELD LIST #
P<PANEL2HEAD> = PANELADDR;
IF PAN2STRFLD[0] NQ 0 THEN
BEGIN # IF PANEL HAS FIELD LIST #
P<FLD2LIST> = PANELADDR + PAN2STRFLD[0];
END
ELSE
BEGIN # NO FIELD LIST, ONLY BOXES #
P<FLD2LIST> = LOC(ZEROWORD);
END
P<VAR2LIST> = PANELADDR + PAN2STRVAR[0];
P<ATT2LIST> = PANELADDR + PAN2STRATT[0];
P<ARR2LIST> = PANELADDR + PAN2STRARR[0];
END # POSTWO #
CONTROL EJECT;
PROC PSTRNG(FLDIND,MESSNUM);
# TITLE PSTRNG - PRINT MESSAGE STRING. #
BEGIN # PSTRNG #
#
** PSTRNG - PRINT MESSAGE STRING.
*
* THIS PROCEDURE CLEARS THE MESSAGE AREA AND PRINTS A USER OR
* SMF MESSAGE.
*
* PROC PSTRNG(FLDIND,MESSNUM)
*
* ENTRY FLDIND = INDEX OF FIELD FOR HELP STRING.
* MESSNUM = SWITCH VALUE FOR MESSAGE PROMPT.
*
* EXIT MESSAGE TRUNCATED IF NECESSARY AND WRITTEN.
*
* CALLS CPANEL, MCLEAN, VDTCHR, VDTPOS, VDTSAM, VDTSTR.
*
* USES TERHELPREQ, TERMESREAD, TERMESWRIT.
#
ITEM FLDIND I; # INDEX INTO FIELD LIST #
ITEM MESSNUM S:MESSSTAT; # SWITCH FOR MESSAGE PROMPT #
ITEM CINDEX I; # CHARACTER INDEX INTO MESSAGE #
ITEM I I; # LOOP VARIABLE #
ITEM MESCHR I; # HOLDS ONE CHARACTER OF MESSAGE #
ITEM MCOUNT I; # CHARACTER COUNT FOR MESSAGE #
ITEM MSGFIT B; # MESSAGE TRUNCATION FLAG #
ITEM VARIND I; # INDEX INTO VARLIST #
ITEM WINDEX I; # WORD INDEX INTO MESSAGE #
*IF UNDEF,QTRM
ARRAY CONMESS[0:3] P(1);
BEGIN # PLEASE CONFIRM #
ITEM CONMESSAGE U(00,00,60) = [
O"41204154414541414163",
O"41454040414341574156",
O"41464151416241550000"];
END
ARRAY CORMESS[0:3] P(1);
BEGIN # PLEASE CORRECT #
ITEM CORMESSAGE U(00,00,60) = [
O"41204154414541414163",
O"41454040414341574162",
O"41624145414341640000"];
END
ARRAY DEFMESS[0:2] P(1);
BEGIN # PLEASE ENTER #
ITEM DEFMESSAGE U(00,00,60) = [
O"41204154414541414163",
O"41454040414541564164",
O"41454162000000000000"];
END
ARRAY ERRMESS[0:4] P(1);
BEGIN # PLEASE REENTER INPUT #
ITEM ERRMESSAGE U(00,00,60) = [
O"41204154414541414163",
O"41454040416241454145",
O"41564164414541624040",
O"41514156416041654164",
O"00000000000000000000"];
END
ARRAY FUNMESS[0:5] P(1);
BEGIN # PLEASE PRESS FUNCTION KEY #
ITEM FUNMESSAGE U(00,00,60) = [
O"41204154414541414163",
O"41454040416041624145",
O"41634163404041464165",
O"41564143416441514157",
O"41564040415341454171",
O"00000000000000000000"];
END
*ELSE
ARRAY CONMESS[0:3] P(1);
BEGIN # PLEASE CONFIRM #
ITEM CONMESSAGE U(00,00,60) = [
O"40404040412041544145",
O"41414163414540404143",
O"41574156414641514162",
O"41550000000000000000"];
END
ARRAY CORMESS[0:3] P(1);
BEGIN # PLEASE CORRECT #
ITEM CORMESSAGE U(00,00,60) = [
O"40404040412041544145",
O"41414163414540404143",
O"41574162416241454143",
O"41640000000000000000"];
END
ARRAY DEFMESS[0:2] P(1);
BEGIN # PLEASE ENTER #
ITEM DEFMESSAGE U(00,00,60) = [
O"40404040412041544145",
O"41414163414540404145",
O"41564164414541620000"];
END
ARRAY ERRMESS[0:4] P(1);
BEGIN # PLEASE REENTER INPUT #
ITEM ERRMESSAGE U(00,00,60) = [
O"40404040412041544145",
O"41414163414540404162",
O"41454145415641644145",
O"41624040415141564160",
O"41654164000000000000"];
END
ARRAY FUNMESS[0:5] P(1);
BEGIN # PLEASE PRESS FUNCTION KEY #
ITEM FUNMESSAGE U(00,00,60) = [
O"40404040412041544145",
O"41414163414540404160",
O"41624145416341634040",
O"41464165415641434164",
O"41514157415640404153",
O"41454171000000000000"];
END
*ENDIF
BASED ARRAY MESSNAME [0:0] P(1); # MESSAGE STRING #
BEGIN
ITEM MESSWORD U(00,00,60); # MESSAGE WORD #
END
SWITCH JUMPCASE:MESSSTAT
JUMPHELP:HELP, # SMF OR USER HELP #
JUMPCONF:CONFIRM, # PLEASE CONFIRM #
JUMPRENT:REENTER; # PLEASE RENTER INPUT #
MCLEAN(MCOUNT,MSGFIT); # CLEAN MESSAGE AREA #
GOTO JUMPCASE[MESSNUM]; # ISSUE MESSAGE #
JUMPHELP: # PRINT HELP MESSAGE #
IF FLDIND NQ -1 THEN
BEGIN # IF INPUT FIELD #
VARIND = FLDVARORD[FLDIND];
IF VARHSOS[VARIND] NQ 0 THEN
BEGIN # IF USER HELP MESSAGE DEFINED #
P<MESSNAME> = LOC(RECWORDU[0])+ VARHSOS[VARIND];
END
ELSE
BEGIN # NO USER HELP MESSAGE DEFINED #
MSGFIT = TRUE; # SMF MESSAGE WILL FIT #
IF NOT FLDENTERED[FLDIND] THEN
BEGIN # IF DATA NOT ENTERED IN FIELD #
P<MESSNAME> = LOC(DEFMESSAGE[0]); # *PLEASE ENTER* #
END
ELSE
BEGIN # DATA ENTERED IN FIELD #
P<MESSNAME> = LOC(CORMESSAGE[0]); # *PLEASE CORRECT* #
END
END
END
ELSE
BEGIN # NO INPUT FIELD #
MSGFIT = TRUE; # SMF MESSAGE WILL FIT #
P<MESSNAME> = LOC(FUNMESSAGE[0]); # *PLEASE PRESS FUNCTION KEY* #
END
TERHELPREQ[0] = FALSE; # HELP REQUEST HONORED #
GOTO PRINTMSG;
JUMPRENT:
MSGFIT = TRUE; # SMF MESSAGE WILL FIT #
P<MESSNAME> = LOC(ERRMESSAGE[0]); # *PLEASE REENTER INPUT* #
GOTO PRINTMSG;
JUMPCONF:
MSGFIT = TRUE; # SMF MESSAGE WILL FIT #
IF FLDIND NQ -1 THEN
BEGIN # IF INPUT FIELD #
P<MESSNAME> = LOC(CONMESSAGE[0]); # *PLEASE CONFIRM* #
END
ELSE
BEGIN # NO INPUT FIELD #
P<MESSNAME> = LOC(FUNMESSAGE[0]); # *PLEASE PRESS FUNCTION KEY* #
END
PRINTMSG: # PRINT MESSAGE #
VDTPOS(0,0); # POSITION TO MESSAGE LINE #
IF MSGFIT THEN
BEGIN # IF MESSAGE WILL FIT #
VDTSTR(MESSNAME); # PRINT ENTIRE MESSAGE #
END
ELSE
BEGIN # TRUNCATE AS NEEDED #
CONTROL IFEQ QTRMV,0; # IF NOT QTRM VARIANT #
CINDEX = 2; # SKIP 0007 BYTE #
CONTROL FI; # END OF IF NOT QTRM #
CONTROL IFEQ QTRMV,1; # IF QTRM VARIANT #
CINDEX = 0; # START AT BEGINNING OF LINE #
CONTROL FI; # END OF IF QTRM #
WINDEX = 0;
MESCHR = C<CINDEX,2>MESSWORD[WINDEX];
FOR I = 0 STEP 1 WHILE MESCHR NQ 0 AND I LQ MCOUNT DO
BEGIN # WRITE MESSAGE #
VDTCHR(MESCHR);
CINDEX = CINDEX + 2;
IF CINDEX GQ 10 THEN
BEGIN # IF WORD EXHAUSTED #
CINDEX = 0; # RESET CHARACTER INDEX #
WINDEX = WINDEX + 1; # GET NEXT WORD #
END
MESCHR = C<CINDEX,2>MESSWORD[WINDEX];
END
END
TERMESWRIT[0] = TRUE; # MESSAGE WRITTEN #
TERMESREAD[0] = FALSE; # MESSAGE NOT READ BY USER YET #
IF NOT TERBLCKMDE[0] THEN
BEGIN
VDTSAM(0);
END
ELSE
BEGIN
VDTSAM(O"6001");
END
CPANEL; # REWRITE SCREEN AS NEEDED #
END # PSTRNG #
CONTROL EJECT;
PROC READIN(FLDIND,COFFSET);
# TITLE READIN - READ INPUT FROM TERMINAL. #
BEGIN # READIN #
#
** READIN - READ INPUT FROM TERMINAL.
*
* THIS PROCEDURE READS INPUT FROM THE TERMINAL AND STORES
* IT IN THE APPROPRIATE PLACE IN VARDATA.
*
* PROC READIN(FLDIND,COFFSET)
*
* ENTRY FLDIND = INDEX OF FIELD FOR STARTING CURSOR POSITION.
* COFFSET = CURSOR OFFSET IN FIELD.
*
* EXIT FLDIND = LAST FIELD ENTERED.
* VARDATA CONTAINS INPUT DATA.
*
* CALLS BFIELD, CPANEL, FFIELD, FUNKEY, PSTRNG, TABKEY, VDTBOI,
* VDTCOR, VDTEOO, VDTINP, VDTOUT, VDTPOS, WRIVCH.
*
* USES TERABNTERM, TERHELPFLD, TERHELPREQ, TERMESREAD,
* TERMISSINP, TERNRMTERM, TERPENDHLP, TERREWFLDS,
*IF UNDEF,QTRM
* TERREWSCRN, TERSOFTPOS, TERSOFTTAB.
*ELSE
* TERREWSCRN, TERSOFTPOS, TERSOFTTAB, TERWAITINP.
*ENDIF
#
ITEM FLDIND I; # INDEX OF FIELD IN FLDLIST #
ITEM COFFSET I; # CURSOR POSITION OFFSET #
ITEM CHAR I; # VDT INPUT CHARACTER #
ITEM FIELD I; # INDEX OF FIELD IN FLDLIST #
ITEM I I; # LOOP COUNTER #
ITEM INPOS U = 0; # LINE AND COLUMN OF INPUT #
ITEM INPUTERROR B; # ERROR IN INPUT #
ITEM INSEARCH B = FALSE; # DO NOT INCLUDE OUT-ONLY FIELDS #
ITEM LASTFIELD I; # LAST FIELD THAT RECEIVED INPUT #
ITEM LASTORD I; # PREVIOUS INPUT ORDINAL #
ITEM LASTPOS U = 0; # LAST X AND Y POSITION #
ITEM OFFSET I; # CHARACTER OFFSET WITHIN FIELD #
ITEM ORD I; # VDT INPUT ORDINAL #
ITEM SKIPINP B; # SKIP DATA TIL NEXT INPUT READ #
ITEM STARTFIELD I; # FIELD TO START SEARCH #
ITEM STARTPOS I; # X/Y POSITION TO START SEARCH #
ITEM XPOS I; # VDT INPUT COLUMN NUMBER #
ITEM YPOS I; # VDT INPUT LINE NUMBER #
SWITCH INPUTTYPE:SCREENST # VDT INPUT ORDINALS #
CONTINUE : CLRALL, # CLEAR ALL TABS - IGNORED #
CHARACTER : CHAR, # OVERSTRIKE CHARACTER #
INSERTCHAR : INSC, # INSERT CHARACTER #
DELETECHAR : DELC, # DELETE CHARACTER #
INSERTLINE : INSL, # INSERT LINE #
DELETELINE : DELL, # DELETE LINE #
CLEARPAGE : CLRPAG, # CLEAR PAGE #
CLEARPAGE : CLREOP, # CLEAR TO END OF PAGE #
CLEARPAGE : CLRUNP, # CLEAR UNPROTECTED #
CLEAREOL : CLREOL, # CLEAR TO END OF LINE #
CONTINUE : POS, # POSITION CURSOR #
HOMEKEY : HOME, # POSITION HOME #
CONTINUE : UP, # CURSOR UP #
CONTINUE : DOWN, # CURSOR DOWN #
LEFTKEY : LEFT, # CURSOR LEFT #
RIGHTKEY : RIGHT, # CURSOR RIGHT #
FORWARDTAB : FTAB, # TAB FORWARD #
BACKWRDTAB : BTAB, # TAB BACKWARD #
CONTINUE : RET, # RETURN #
ERASECHAR : ERAC, # ERASE CHARACTER #
ERASELINE : ERAL, # ERASE LINE #
ENDOFINPUT : EOI, # END OF INFORMATION #
CONTINUE : RESET, # RESET #
APPLICFUN : FKEY, # FUNCTION KEY #
GENERICFUN : GKEY, # GENERIC KEY #
BADINPUT : BAD, # BAD #
CONTINUE : NOOP, # NOOP #
CONTINUE : COORD, # COORDINATES #
CONTINUE : PROTECT, # PROTECT ALL #
NEWFIELD : STRTFLD, # START OF NEW FIELD #
CONTINUE : CLRTAB, # CLEAR TAB STOP - IGNORED #
CONTINUE : SETTAB; # SET TAB STOP - IGNORED #
INPOS = 0;
FIELD = FLDIND;
LASTFIELD = FLDIND;
INPUTERROR = FALSE;
TERHELPREQ[0] = FALSE;
*IF DEF,QTRM
IF TERWAITINP[0] THEN
BEGIN # IF INPUT RECEIVED #
TERWAITINP[0] = FALSE; # CLEAR FLAG #
GOTO DOREAD1; # CONTINUE #
END
*ENDIF
DOREAD: # READ INPUT FROM TERMINAL #
ORD = SCREENST"EOI"; # SET LAST ORDINAL TO EOI #
TERSOFTTAB[0] = 0; # NUMBER OF SOFT TABS PENDING #
SKIPINP = FALSE;
TERMISSINP[0] = FALSE;
IF INPUTERROR THEN
BEGIN # BAD INPUT #
PSTRNG(DUMMY,MESSSTAT"REENTER");
INPUTERROR = FALSE;
END
ELSE
BEGIN # NO INPUT ERROR #
IF TERHELPREQ[0] THEN
BEGIN # HELP REQUESTED FOR FIELD #
PSTRNG(TERHELPFLD[0],MESSSTAT"HELP");
FIELD = TERHELPFLD[0];
END
ELSE
BEGIN # NO HELP REQUESTED #
CPANEL; # REWRITE SCREEN AS NEEDED #
END
END
IF VALIDFIELD THEN
BEGIN # VALID FIELD #
XPOS = COFFSET + FLDXCORD[FIELD];
YPOS = FLDYCORD[FIELD];
END
ELSE
BEGIN # INVALID FIELD #
XPOS = 0;
YPOS = 0;
END
VDTPOS(XPOS,YPOS); # POSITION CURSOR #
VDTEOO;
*IF DEF,QTRM
TERWAITINP[0] = TRUE; # SET WAITING FOR INPUT #
NIT$RC = 23; # SET RETURN CODE #
RETURN; # RETURN #
DOREAD1: # CONTINUE AFTER QTRM INPUT #
*ENDIF
VDTBOI(LASTORD); # CHECK FOR TYPE AHEAD #
VDTBOO; # BEGIN OUTPUT SEQUENCE #
IF LASTORD NQ 0 THEN
BEGIN # TYPE AHEAD WAS ENTERED #
PSTRNG(FIELD,MESSSTAT"REENTER"); # PLEASE REENTER #
GOTO DOREAD;
END
COFFSET = 0; # OFFSET NO LONGER VALID #
TERMESREAD[0] = TRUE; # MESSAGE HAS BEEN SEEN BY USER #
TERNRMTERM[0] = FALSE;
TERABNTERM[0] = FALSE;
GETINP: # WHILE STILL LOOKING FOR INPUT #
YMASKOF TERPREVPOS = YPOS; # RETAIN PREVIOUS Y POSITION #
XMASKOF TERPREVPOS = XPOS; # RETAIN PREVIOUS X POSITION #
LASTORD = ORD; # RETAIN PREVIOUS ORDINAL #
VDTINP(ORD,XPOS,YPOS,CHAR,DUMMY); # GET INPUT FROM BUFFER #
SKIPREAD:
YMASKOF INPOS = YPOS;
XMASKOF INPOS = XPOS;
FFIELD(INPOS,FIELD,OFFSET,INSEARCH); # FIND INPUT FIELD #
IF VALIDFIELD THEN LASTFIELD = FIELD; # UPDATE LAST FIELD #
GOTO INPUTTYPE[ORD]; # PROCESS INPUT BY TYPE #
CHARACTER: # DISPLAYABLE CHARACTER INPUT #
IF (NOT SKIPINP) AND (TERSOFTTAB[0] EQ 0) THEN
BEGIN # PROCESS CHARACTER #
IF NOT VALIDFIELD THEN
BEGIN # CHAR NOT IN AN INPUT FIELD #
IF TERTABAUTO[0] AND NOT TERNOINVRS[0] THEN
BEGIN # IF AUTOMATIC TABBING #
TABKEY(SCREENST"FTAB",INPOS,FIELD,INPOS);
IF INPOS EQ 0 AND NOT TERTABHOME[0] THEN
BEGIN # IF TAB DOES NOT STOP AT HOME #
TABKEY(SCREENST"FTAB",INPOS,FIELD,INPOS);
END
OFFSET = 0; # CLEAR FIELD OFFSET #
LASTFIELD = FIELD; # UPDATE LAST VALID FIELD #
XPOS = XMASKOF INPOS; # RESET INTERNAL POSITION #
YPOS = YMASKOF INPOS;
VDTCOR(YPOS,XPOS);
END
END
IF VALIDFIELD THEN
BEGIN # CHAR IN AN INPUT FIELD #
WRIVCH(FIELD,OFFSET,CHAR); # WRITE CHARACTER INTO VARDATA #
FLDENTERED[FIELD] = TRUE;
FLDVALID[FIELD] = FALSE; # INVALID UNTIL PROVEN VALID #
IF NOT FLDOUTPUTV[FIELD] THEN
BEGIN # IF INPUT ONLY FIELD #
IF NOT TERGUARDMD[0] THEN
BEGIN # IF NO GUARD MODE AVAILABLE #
FLDREWRITE[FIELD] = TRUE; # SET REWRITE BIT FOR FIELD #
TERREWFLDS[0] = TRUE;
END
END
IF TERTABAUTO[0] THEN
BEGIN # IF AUTOMATIC TABBING #
IF OFFSET EQ FLDLENGTH[FIELD] - 1 THEN
BEGIN # IF AUTO-TAB TO NEXT FIELD #
TABKEY(SCREENST"FTAB",INPOS,FIELD,INPOS);
IF INPOS EQ 0 THEN
BEGIN # IF TABBING PAST LAST FIELD #
IF TERPTDWFPG[0] THEN
BEGIN # IF NO WRAP AROUND SCREEN #
TABKEY(SCREENST"BTAB",INPOS,FIELD,INPOS);
OFFSET = FLDLENGTH[FIELD] - 1;
INPOS = INPOS + OFFSET;
END
ELSE
BEGIN # WRAPPING TO FIRST FIELD #
IF NOT TERTABHOME[0] THEN
BEGIN # IF TAB DOES NOT STOP AT HOME #
TABKEY(SCREENST"FTAB",INPOS,FIELD,INPOS);
END
OFFSET = 0;
END
END
OFFSET = 0; # CLEAR FIELD OFFSET #
LASTFIELD = FIELD; # UPDATE LAST VALID FIELD #
INPOS = INPOS - 1; # RESET INTERNAL POSITION #
YPOS = YMASKOF INPOS;
XPOS = XMASKOF INPOS;
VDTCOR(YPOS,XPOS);
END
END
END
ELSE
BEGIN # CHAR NOT IN AN INPUT FIELD #
IF NOT TERTABAUTO[0] THEN
BEGIN # IF NEED TO REFRESH SCREEN #
RESTFLD (INPOS);
TERMISSINP[0] = TRUE; # ERROR CONDITION #
END
RESTFLD (INPOS);
END
END
ELSE
BEGIN # IGNORE CHARACTER #
IF VALIDFIELD AND NOT TERREWSCRN[0] THEN
BEGIN # IF NEED TO SET REWRITE BIT #
FLDREWRITE[FIELD] = TRUE;
TERREWFLDS[0] = TRUE;
END
ELSE
BEGIN # BAD CHARACTER IS NOT IN FIELD #
IF CHAR NQ BLANK AND NOT TERREWSCRN[0] THEN
BEGIN # IF NEED TO CLEAR ON SCREEN #
VDTPOS(XPOS,YPOS); # ERASE CHARACTER #
VDTOUT(BLANK);
END
END
END
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
HOMEKEY: # HOME KEY WAS PRESSED #
IF TERTABAUTO[0] THEN
BEGIN # IF AUTOMATIC TABBING #
IF NOT TERNOINVRS[0] THEN
BEGIN # IF INPUT VARIABLES EXIST #
IF NOT TERTABHOME[0] THEN
BEGIN # CURSOR HAS MOVED TO FIELD #
TABKEY(SCREENST"FTAB",INPOS,FIELD,INPOS);
OFFSET = 0; # CLEAR FIELD OFFSET #
LASTFIELD = FIELD; # UPDATE LAST VALID FIELD #
YPOS = YMASKOF INPOS; # RESET INTERNAL POSITION #
XPOS = XMASKOF INPOS;
VDTCOR(YPOS,XPOS);
END
END
END
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
LEFTKEY: # CURSOR LEFT #
IF TERTABAUTO[0] AND NOT TERTABHOME[0] THEN
BEGIN # IF AUTOMATIC TABBING #
IF NOT TERNOINVRS[0] AND NOT VALIDFIELD THEN
BEGIN # IF AUTO-TAB TO PREVIOUS FIELD #
LASTPOS = INPOS; # SAVE CURRENT POSITION #
TABKEY(SCREENST"BTAB",INPOS,FIELD,INPOS);
IF INPOS EQ 0 AND TERPTDWBPG[0] THEN
BEGIN # IF NO BACKWARD WRAP FROM HOME #
INPOS = LASTPOS; # RESTORE PREVIOUS POSITION #
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
END
IF INPOS EQ 0 AND NOT TERTABHOME[0] THEN
BEGIN # IF TAB DOES NOT STOP AT HOME #
TABKEY(SCREENST"BTAB",INPOS,FIELD,INPOS);
END
OFFSET = FLDLENGTH[FIELD] - 1; # SET OFFSET TO END OF FIELD #
LASTFIELD = FIELD; # UPDATE LAST VALID FIELD #
INPOS = INPOS + OFFSET; # RESET INTERNAL POSITION #
YPOS = YMASKOF INPOS;
XPOS = XMASKOF INPOS;
VDTCOR(YPOS,XPOS);
END
END
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
RIGHTKEY: # CURSOR RIGHT #
IF TERTABAUTO[0] AND NOT TERTABHOME[0] THEN
BEGIN # IF AUTOMATIC TABBING #
IF NOT TERNOINVRS[0] AND NOT VALIDFIELD THEN
BEGIN # IF AUTO-TAB TO NEXT FIELD #
TABKEY(SCREENST"FTAB",INPOS,FIELD,INPOS);
IF INPOS EQ 0 AND NOT TERTABHOME[0] THEN
BEGIN # IF TAB DOES NOT STOP AT HOME #
TABKEY(SCREENST"FTAB",INPOS,FIELD,INPOS);
END
OFFSET = 0; # CLEAR FIELD OFFSET #
LASTFIELD = FIELD; # UPDATE LAST VALID FIELD #
YPOS = YMASKOF INPOS; # RESET INTERNAL POSITION #
XPOS = XMASKOF INPOS;
VDTCOR(YPOS,XPOS);
END
END
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
FORWARDTAB: # FORWARD TAB KEY PRESSED #
IF TERTABPROT[0] THEN
BEGIN # CAN TAB TO UNPROTECTED FIELD #
LASTPOS = INPOS; # SAVE POSITION #
TABKEY(ORD,INPOS,FIELD,INPOS);
IF INPOS EQ 0 THEN
BEGIN # IF LOGICALLY AT HOME #
IF NOT TERPTDWFPG[0] THEN
BEGIN # IF TAB CAN REALLY WRAP #
IF NOT TERTABHOME[0] THEN
BEGIN # IF TAB DOES NOT STOP AT HOME #
TABKEY(ORD,INPOS,FIELD,INPOS);
END
OFFSET = 0; # CLEAR FIELD OFFSET #
LASTFIELD = FIELD; # UPDATE LAST VALID FIELD #
END
ELSE
BEGIN # TAB DID NOT OCCUR ON SCREEN #
INPOS = LASTPOS;
END
END
YPOS = YMASKOF INPOS; # RESET INTERNAL POSITION #
XPOS = XMASKOF INPOS;
VDTCOR(YPOS,XPOS);
END
ELSE
BEGIN # SIMULATE WITH SOFT TAB #
IF TERSOFTTAB[0] EQ 0 THEN TERSOFTPOS[0] = INPOS;
TERSOFTTAB[0] = TERSOFTTAB[0] + 1;
END
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
BACKWRDTAB: # BACK TAB KEY PRESSED #
IF TERTABPROT[0] THEN
BEGIN # CAN TAB TO UNPROTECTED FIELD #
LASTPOS = INPOS; # SAVE POSITION #
TABKEY(ORD,INPOS,FIELD,INPOS);
IF INPOS EQ 0 THEN
BEGIN # IF LOGICALLY AT HOME #
IF NOT TERPTDWBPG[0] THEN
BEGIN # IF TAB CAN REALLY WRAP #
IF NOT TERTABHOME[0] THEN
BEGIN # IF TAB DOES NOT STOP AT HOME #
TABKEY(ORD,INPOS,FIELD,INPOS);
END
OFFSET = 0; # CLEAR FIELD OFFSET #
LASTFIELD = FIELD; # UPDATE LAST VALID FIELD #
END
ELSE
BEGIN # TAB DID NOT OCCUR ON SCREEN #
INPOS = LASTPOS;
END
END
YPOS = YMASKOF INPOS; # RESET INTERNAL POSITION #
XPOS = XMASKOF INPOS;
VDTCOR(YPOS,XPOS);
END
ELSE
BEGIN # SIMULATE WITH SOFT TAB #
IF TERSOFTTAB[0] EQ 0 THEN TERSOFTPOS[0] = INPOS;
TERSOFTTAB[0] = TERSOFTTAB[0] - 1;
END
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
CLEARPAGE: # CLEAR PAGE PRESSED #
TERREWSCRN[0] = TRUE; # COMPLETE REWRITE OF SCREEN #
TERREWFLDS[0] = TRUE;
SKIPINP = TRUE; # SKIP TO NEXT INPUT #
GOTO GETINP; # GET INPUT AGAIN #
CLEAREOL: # CLEAR TO END OF LINE PRESSED #
IF VALIDFIELD THEN
BEGIN # IF IN ACTIVE INPUT FIELD #
BFIELD(FIELD,OFFSET,DUMMY); # BLANK FIELD IN VARDATA #
FLDVALID[FIELD] = FALSE;
FLDENTERED[FIELD] = TRUE;
FLDREWRITE[FIELD] = TRUE;
TERREWFLDS[0] = TRUE;
END
REWRTLINE: # REWRITE REST OF FIELDS ON LINE #
STARTFIELD = FIELD + 1;
IF NOT TERTABPROT[0] OR TERCLEARSM[0] THEN
BEGIN # IF MORE THAN ONE CLEARED #
FOR I = STARTFIELD STEP 1 WHILE FLDENTRY[I] NQ 0
AND FLDYCORD[I] LQ YPOS DO
BEGIN # IF NOT PAST AFFECTED LINE #
IF FLDYCORD[I] EQ YPOS AND FLDACTIVE[I]
AND FLDXCORD[I]+FLDLENGTH[I] GQ XPOS THEN
BEGIN # IF ACTIVE FIELD ON SAME LINE #
IF FLDINPUTV[I] THEN
BEGIN # IF ACTIVE INPUT FIELD #
BFIELD(I,0,DUMMY); # BLANK FIELD IN VARDATA #
FLDVALID[I] = FALSE;
FLDENTERED[I] = TRUE;
END
FLDREWRITE[I] = TRUE;
TERREWFLDS[0] = TRUE;
END
END
END
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
ERASELINE: # SHIFT ERASE PRESSED #
IF NOT TERTABPROT[0] THEN
BEGIN # IF NO PROTECT #
XPOS = 0;
XMASKOF INPOS = XPOS;
VDTCOR(YPOS,XPOS); # REPOSITION TO START OF LINE #
STARTFIELD = -1;
GOTO REWRTLINE; # REWRITE ALL FIELDS ON LINE #
END
FFIELD(TERPREVPOS,FIELD,OFFSET,INSEARCH);
IF FIELD GQ 0 THEN
BEGIN # FOUND FIELD #
BFIELD(FIELD,0,DUMMY); # BLANK FIELD IN VARDATA #
TERREWFLDS[0] = TRUE;
FLDREWRITE[FIELD] = TRUE;
FLDENTERED[FIELD] = TRUE;
FLDVALID[FIELD] = FALSE;
VDTCOR(FLDYCORD[FIELD],FLDXCORD[FIELD]); # RESET INTERNAL POS #
END
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
ERASECHAR: # ERASE KEY PRESSED #
IF TERTABAUTO[0] THEN
BEGIN # IF AUTOMATIC TABBING #
IF NOT TERNOINVRS[0] AND NOT VALIDFIELD THEN
BEGIN # IF AUTO-TAB TO PREVIOUS FIELD #
TABKEY(SCREENST"BTAB",INPOS,FIELD,INPOS);
IF INPOS EQ 0 AND NOT TERTABHOME[0] THEN
BEGIN # IF TAB DOES NOT STOP AT HOME #
TABKEY(SCREENST"BTAB",INPOS,FIELD,INPOS);
END
OFFSET = FLDLENGTH[FIELD] - 1; # SET OFFSET TO END OF FIELD #
LASTFIELD = FIELD; # UPDATE LAST VALID FIELD #
INPOS = INPOS + OFFSET; # RESET INTERNAL POSITION #
YPOS = YMASKOF INPOS;
XPOS = XMASKOF INPOS;
VDTCOR(YPOS,XPOS);
END
END
IF VALIDFIELD THEN
BEGIN # IF VALID FIELD #
WRIVCH(FIELD,OFFSET,BLANK); # WRITE BLANK INTO VARDATA #
FLDENTERED[FIELD] = TRUE;
FLDVALID[FIELD] = FALSE; # INVALID UNTIL PROVEN VALID #
END
ELSE IF NOT TERTABAUTO[0] THEN
BEGIN
RESTFLD (INPOS);
END
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
APPLICFUN:
GENERICFUN: # FUNCTION KEY PRESSED #
IF TERLEAVESM[0] NQ 0 THEN
BEGIN # IF FUNCTION KEY LEFT MARK #
IF VALIDFIELD THEN
BEGIN # IF IN INPUT FIELD #
FLDREWRITE[FIELD] = TRUE; # SET REWRITE BIT FOR FIELD #
TERREWFLDS[0] = TRUE;
END
ELSE
BEGIN # IF NOT IN INPUT FIELD #
RESTFLD (INPOS);
END
END
IF NOT SKIPINP THEN
BEGIN # PROCESS FUNCTION KEY #
FUNKEY(INPOS,OFFSET,ORD,CHAR,FIELD);
IF TERSOFTTAB[0] EQ 0 THEN
BEGIN # IF FUNCTION KEY NOT SOFT TAB #
SKIPINP = TRUE; # SKIP INPUT #
END
END
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
INSERTLINE: # INSERT LINE PRESSED #
DELETELINE: # DELETE LINE PRESSED #
TERREWSCRN[0] = TRUE; # FORCE SCREEN REWRITE #
TERREWFLDS[0] = TRUE;
BADINPUT: # BAD INPUT RETURNED #
INPUTERROR = TRUE; # UNSUPPORTED KEY ENTERED #
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
INSERTCHAR: # INSERT CHARACTER PRESSED #
IF VALIDFIELD THEN
BEGIN # SHIFT CHARACTERS IN VARDATA #
FOR I = FLDLENGTH[FIELD] - 1 STEP - 1 UNTIL OFFSET + 1 DO
BEGIN
DUMMY = NEXTCHAR(FIELD,I-1);
WRIVCH(FIELD,I,DUMMY); # WRITE CHARACTER INTO VARDATA #
END
WRIVCH(FIELD,OFFSET,CHAR); # WRITE CHARACTER INTO VARDATA #
FLDENTERED[FIELD] = TRUE;
FLDVALID[FIELD] = FALSE;
FLDREWRITE[FIELD] = TRUE;
TERREWFLDS[0] = TRUE;
END
IF NOT TERTABPROT[0] THEN
BEGIN
VDTCLL(XPOS,YPOS); # CLEAR THE REST OF THE LINE #
VDTPOS(XPOS,YPOS);
GOTO REWRTLINE; # REWRITE THE REST OF THE LINE #
END
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
DELETECHAR: # DELETE CHARACTER PRESSED #
IF VALIDFIELD THEN
BEGIN # IF VALID FIELD #
FOR I = OFFSET STEP 1 UNTIL FLDLENGTH[FIELD] - 2 DO
BEGIN # SHIFT CHARACTERS IN VARDATA #
CHAR = NEXTCHAR(FIELD,I+1);
WRIVCH(FIELD,I,CHAR); # WRITE CHARACTER INTO VARDATA #
END
WRIVCH(FIELD,FLDLENGTH[FIELD]-1,BLANK); # BLANK LAST CHARACTER #
FLDENTERED[FIELD] = TRUE;
FLDVALID[FIELD] = FALSE;
FLDREWRITE[FIELD] = TRUE;
TERREWFLDS[0] = TRUE;
END
IF NOT TERTABPROT[0] THEN
BEGIN
VDTCLL(XPOS,YPOS); # CLEAR THE REST OF THE LINE #
VDTPOS(XPOS,YPOS);
GOTO REWRTLINE; # REWRITE THE REST OF THE LINE #
END
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
NEWFIELD: # START OF NEW FIELD #
IF VALIDFIELD THEN
BEGIN # IF VALID INPUT FIELD #
VDTINP(ORD,XPOS,YPOS,CHAR,DUMMY);
FOR OFFSET = 0 STEP 1 WHILE ORD EQ SCREENST"CHAR" DO
BEGIN # WHILE INPUT IS CHARACTERS #
WRIVCH(FIELD,OFFSET,CHAR); # WRITE CHARACTER INTO VARDATA #
VDTINP(ORD,XPOS,YPOS,CHAR,DUMMY);
END
BFIELD(FIELD,OFFSET,DUMMY); # BLANK FILL FIELD #
FLDENTERED[FIELD] = TRUE; # FIELD ENTERED #
FLDVALID[FIELD] = FALSE; # INVALID UNTIL PROVEN VALID #
GOTO SKIPREAD; # CONTINUE #
END
ELSE
BEGIN # INVALID FIELD #
GOTO GETINP; # CONTINUE WITH INPUT #
END
CONTINUE: # IGNORABLE INPUT ENTERED #
GOTO GETINP; # CONTINUE LOOKING AT INPUT #
ENDOFINPUT: # END OF INPUT BUFFER #
IF NOT (SKIPINP OR INPUTERROR OR TERHELPREQ[0]) THEN
BEGIN # NEXT KEY WAS PRESSED #
FUNKEY(INPOS,OFFSET,SCREENST"GKEY",GENERICST"GNEXT",FIELD);
END
IF TERSOFTTAB[0] NQ 0 THEN
BEGIN # PERFORM SOFT TABS #
STARTPOS = TERSOFTPOS[0];
WHYLE TERSOFTTAB[0] NQ 0 DO
BEGIN # UNTIL DONE WITH SOFT TABS #
TABKEY(SCREENST"FTAB",STARTPOS,FIELD,STARTPOS);
TERSOFTTAB[0] = TERSOFTTAB[0] - 1;
IF FIELD EQ -1 THEN
BEGIN
TABKEY(SCREENST"FTAB",STARTPOS,FIELD,STARTPOS);
END
END
OFFSET = 0; # CLEAR FIELD OFFSET #
LASTFIELD = FIELD; # UPDATE LAST VALID FIELD #
YPOS = YMASKOF STARTPOS;
XPOS = XMASKOF STARTPOS;
VDTCOR(YPOS,XPOS);
IF TERPENDHLP[0] THEN
BEGIN # IF HELP PENDING #
TERPENDHLP[0] = FALSE; # CLEAR HELP PENDING #
TERHELPFLD[0] = FIELD; # SET FIELD REQUESTING HELP #
TERHELPREQ[0] = TRUE; # SET HELP REQUESTED FLAG#
END
END
IF TERABNTERM[0] OR TERNRMTERM[0] THEN
BEGIN # TERMINATION REQUESTED #
IF (TERNRMTERM[0] AND NOT (INPUTERROR OR TERHELPREQ[0])) OR
(TERABNTERM[0]) THEN
BEGIN
FLDIND = LASTFIELD;
CPANEL;
RETURN;
END
END
IF NOT VALIDFIELD THEN FIELD = LASTFIELD;
GOTO DOREAD; # READ INPUT AGAIN #
END # READIN #
CONTROL EJECT;
PROC READSF(PANEL);
# TITLE READSF - READ SCREEN FORMATTED PANEL. #
BEGIN # READSF #
#
** READSF - READ SCREEN FORMATTED PANEL.
*
* READSF CHECKS THAT ALL INPUT TO THE PANEL IS VALID.
*
* PROC READSF(PANEL)
*
* ENTRY PANEL = NAME OF PANEL TO READ.
*
* EXIT VARDATA CONTAINS INPUT DATA.
*
* CALLS CPANEL, FFIRST, GFIELD, PSTRNG, READIN, SFSWRI$, VALIDF.
*
* USES TERABNTERM, TERCURSROW, TERCURSSET, TERCURSVAR,
* TERNRMTERM, TERREADFLG, TERREWFLDS,
*IF UNDEF,QTRM
* TERNOINVRS, TERREWSCRN.
*ELSE
* TERNOINVRS, TERREWSCRN, TERWAITINP.
*ENDIF
*
* NOTES IF PANEL IS NOT THE ACTIVE PANEL THEN SFSWRI$
* IS CALLED TO WRITE THE PANEL TO THE SCREEN.
#
ITEM PANEL C(7); # INPUT PANEL NAME #
ITEM CHARIND I; # CHARACTER OFFSET WITHIN FIELD #
ITEM CUROFF I; # INITIAL CURSOR OFFSET #
*IF DEF,QTRM
ITEM FATAL B = TRUE; # FATAL ERROR #
*ENDIF
ITEM FLDIND I; # POINTER INTO FIELD LIST #
ITEM INSP C(10); # DUMMY PARAMETER FOR SFSWRI$ #
ITEM LASTFIELD I; # LAST FIELD ENTERED #
ITEM LEN I = 7; # FIXED PANEL NAME LENGTH #
*IF DEF,QTRM
ITEM MSG C(43) = " PANEL MUST BE WRITTEN BEFORE READ IN QTRM.";
*ENDIF
ITEM OFF I = 0; # FIXED PANEL NAME OFFSET #
*IF DEF,QTRM
ITEM PNAME C(7) = "SFSREA "; # CALLING PROCEDURE #
*ENDIF
ITEM USEROW B = TRUE; # USE TERCURSROW #
ITEM VARIND I; # INDEX INTO VARLIST #
*IF,DEF,QTRM
IF TERWAITINP[0] THEN GOTO READFIELDS; # RESUME AFTER QTRM I/O #
*ENDIF
# INITIALIZE TERMINATION, REWRITE AND VARIABLE FLAGS #
TERABNTERM[0] = FALSE;
TERHELPREQ[0] = FALSE;
TERNOINVRS[0] = FALSE;
TERNRMTERM[0] = FALSE;
TERREWSCRN[0] = FALSE;
IF PANEL NQ TERACTPANL[0] THEN
BEGIN # IF NEW ACTIVE PANEL #
*IF UNDEF,QTRM
TERREADFLG[0] = TRUE; # WRITE PANEL BEFORE READ #
SFSWRI$(PANEL,LEN,OFF,INSP,LEN,OFF);
TERREADFLG[0] = FALSE;
*ELSE
ERRMSG(PANEL,PNAME,MSG,FATAL); # NO READ BEFORE WRITE IN QTRM #
*ENDIF
END
FLDIND = -1;
IF TERCURSSET[0] THEN
BEGIN # IF SFSETP$ HAS BEEN CALLED #
GFIELD(TERCURSVAR[0],USEROW,FLDIND);
END
IF (FLDIND NQ -1 AND FLDINPUTV[FLDIND]) AND FLDACTIVE[FLDIND] THEN
BEGIN # IF VALID FIELD #
IF TERCURSSET[0] AND TERCURSOFF[0] LQ FLDLENGTH[FLDIND] - 1 THEN
BEGIN # SFSETP$ SPECIFIED POSITION #
CUROFF = TERCURSOFF[0];
END
ELSE
BEGIN
CUROFF = 0; # CLEAR OFFSET #
END
END
ELSE
BEGIN # FIELD NOT FOUND #
FFIRST(FLDIND); # FIND FIRST INPUT FIELD #
IF FLDIND EQ -1 THEN
BEGIN # IF NO ACTIVE INPUT FIELDS #
TERNOINVRS[0] = TRUE; # NO INPUT VARIABLES #
END
CUROFF = 0;
END
TERCURSSET[0] = FALSE; # CLEAR SFSETP$ VARIABLES #
TERCURSVAR[0] = " ";
TERCURSROW[0] = 0;
READFIELDS: # READ INPUT FIELDS #
READIN(FLDIND,CUROFF); # READ INPUT FROM TERMINAL #
*IF DEF,QTRM
IF TERWAITINP[0] THEN RETURN; # IF WAITING FOR INPUT, RETURN #
*ENDIF
LASTFIELD = FLDIND;
CUROFF = 0;
FLDIND = 0; # CHECK ALL FIELDS #
IF TERABNTERM[0] THEN RETURN; # ABNORMAL TERMINATION #
IF TERNOINVRS[0] THEN GOTO CHEKMISSED; # NO FIELDS TO CHECK #
WHYLE FLDENTRY[FLDIND] NQ 0 DO
BEGIN # UNTIL FIELD LIST EXHAUSTED #
VARIND = FLDVARORD[FLDIND]; # CHECK FIELD VALIDATION #
IF FLDACTIVE[FLDIND] AND FLDINPUTV[FLDIND] THEN
BEGIN # IF ACTIVE INPUT FIELD #
IF TERBLCKMDE[0] THEN
BEGIN
FOR CHARIND = FLDLENGTH[FLDIND]-1 STEP -1 UNTIL 0 DO
BEGIN
IF NEXTCHAR(FLDIND,CHARIND) NQ O"137" THEN CHARIND = 0;
ELSE WRIVCH(FLDIND,CHARIND,O"40");
END
END
IF(FLDENTERED[FLDIND] OR VARMUSENTR[VARIND] OR
VARMUSCON[VARIND]) AND NOT FLDVALID[FLDIND] THEN
BEGIN # IF FIELD TO BE CHECKED #
VALIDF(FLDIND);
IF NOT FLDVALID[FLDIND] THEN
BEGIN # IF VALIDATION FAILED #
PSTRNG(FLDIND,MESSSTAT"HELP");
GOTO READFIELDS; # NOTIFY USER OF ERROR #
END
END
END
FLDIND = FLDIND + 1;
END
CHEKMISSED: # TERMINATE IF NO FIELD MISSED #
IF TERMISSINP[0] THEN
BEGIN # IF INPUT OUTSIDE OF FIELDS #
PSTRNG(LASTFIELD,MESSSTAT"CONFIRM");
FLDIND = LASTFIELD; # POSITION TO LAST FIELD ENTERED #
GOTO READFIELDS; # REQUEST CONFIRMATION OF INPUT #
END
TERREWFLDS[0] = FALSE;
END # READSF #
CONTROL EJECT;
PROC RESTFLD (INPOS);
# TITLE RESTFLD - RESTORE DESTROYED FIELD. #
BEGIN # RESTFLD #
#
** RESTFLD - RESTORE DESTROYED FIELD.
*
* RESTFLD MARKS AN ACTIVE FIELD AT *INPOS* FOR REWRITING,
* OR WRITES A BLANK IF *INPOS* IS NOT IN AN ACTIVE FIELD.
*
* PROC RESTFLD (INPOS)
*
* ENTRY INPOS = POSITION ON SCREEN.
*
* EXIT *FLDREWRITE* FLAG SET OR BLANK WRITTEN TO SCREEN.
#
ITEM INPOS U;
ITEM FIELD I;
ITEM I I;
FIELD = -1;
FOR I = 0 STEP 1 WHILE FLDENTRY[I] NQ 0 AND FLDPOS[I] LS INPOS DO
BEGIN # SEARCH FOR ACTIVE FIELD #
IF FLDACTIVE[I] THEN FIELD = I;
END
IF VALIDFIELD AND INPOS - FLDPOS[FIELD] LS FLDLENGTH[FIELD] THEN
BEGIN # IF WITHIN THIS FIELD #
FLDREWRITE[FIELD] = TRUE;
TERREWFLDS[0] = TRUE;
END
ELSE
BEGIN # IF NOT IN ANY ACTIVE FIELD #
VDTPOS(XMASKOF INPOS,YMASKOF INPOS);
VDTOUT(BLANK);
END
END # RESTFLD #
CONTROL EJECT;
PROC REWFLD;
# TITLE REWFLD - REWRITE FIELDS. #
BEGIN # REWFLD #
#
** REWFLD - REWRITE FIELDS.
*
* THIS PROCEDURE REWRITES FIELDS.
*
* PROC REWFLD
*
* ENTRY TERNOREWRT = FALSE, IF REWRITING ALL VARIABLES.
* = TRUE, IF HONORING FIELD LIST REWRITE FLAG.
*
* EXIT FIELDS REWRITTEN TO SCREEN.
*
* CALLS SETATR, VDTSAM, VDTSTR, WRIVAR.
#
ITEM FLDINDEX I; # INDEX INTO FIELD LIST #
ITEM VARINDEX I; # INDEX TO LAST VAR WRITTEN #
BASED ARRAY CONSTRING;; # PASSES ADDRESS TO VDTSTR #
VARINDEX = - 2; # NO VARIABLES WRITTEN YET #
TERCURVORD[0] = - 1; # NO CURRENT ATTRIBUTES YET #
TERPREVPOS[0] = - 1; # LAST ATTRIBUTE POSITION #
FOR FLDINDEX = 0 STEP 1 WHILE FLDENTRY[FLDINDEX] NQ 0 DO
BEGIN
IF FLDACTIVE[FLDINDEX] AND (FLDREWRITE[FLDINDEX] OR
((NOT TERNOREWRT[0]) AND FLDVARFLAG[FLDINDEX])) OR
(TERATTRCHR[0] AND VARINDEX EQ FLDINDEX - 1) THEN
BEGIN # IF ACTIVE FIELD TO REWRITE #
SETATR(FLDINDEX); # SET FIELD ATTRIBUTES #
IF FLDVARFLAG[FLDINDEX] THEN # IF VARIABLE FIELD #
BEGIN
WRIVAR(FLDINDEX); # WRITE VARIABLE FIELD #
VARINDEX = FLDINDEX;
END
ELSE
BEGIN # WRITE CONSTANT FIELD #
P<CONSTRING>=LOC(RECWORDC[FLDCONOS[FLDINDEX]]);
VDTSTR(CONSTRING);
FLDREWRITE[FLDINDEX] = FALSE; # CLEAR REWRITE FIELD FLAG #
END
IF TERTABPROT[0] THEN
BEGIN # IF PROTECTED TABBING #
IF TERATTRSET[0] THEN
BEGIN # RESET ATTRIBUTES BEFORE VDTPOS #
IF TERCURVORD[0] NQ 2 THEN
BEGIN # IF NOT PROTECTED OUTPUT #
TERCURVORD[0] = 2; # SET ORDINAL AND ISSUE IT #
VDTSAM(O"6001");
END
END
END
END
END
IF NOT TERBLCKMDE[0] THEN
BEGIN
VDTSAM(0);
END
ELSE
BEGIN
VDTSAM(O"6001");
END
END # REWFLD #
CONTROL EJECT;
PROC REALRANGE(FLDIND,IVALUE,EVALUE);
# TITLE RRANGE - RANGE VALIDATION FOR REAL VARIABLES. #
BEGIN # RRANGE #
#
** REALRANGE - RANGE VALIDATION FOR REAL VARIABLES.
*
* THIS PROCEDURE VALIDATES THAT INPUT TO THE VARIABLE POINTED TO
* BY FLDIND IS WITHIN THE RANGE SPECIFIED IN THE PANEL RECORD.
*
* PROC REALRANGE(FLDIND,IVALUE,EVALUE)
*
* ENTRY FLDIND = INDEX OF CURRENT FIELD IN FLDLIST.
* IVALUE = THE INTEGER VALUE OF THE INPUT.
* EVALUE = THE EXPONENT VALUE OF THE INPUT.
*
* EXIT FLDVALID[FLDIND] = FALSE, IF INPUT IS INVALID.
#
ITEM FLDIND I; # INDEX OF VARIABLE TO VALIDATE #
ITEM IVALUE I; # INTEGER VALUE OF INPUT #
ITEM EVALUE I; # EXPONENT VALUE OF INPUT #
ITEM FPSTAT I; # GFP OVERFLOW STATUS #
ITEM MAXVAL R; # MAXIMUM ALLOWED VALUE #
ITEM MINVAL R; # MINIMUM ALLOWED VALUE #
ITEM OFFSET I; # OFFSET OF VALIDATION IN RECORD #
ITEM RVALUE R; # REAL VALUE OF INPUT #
ITEM VARIND I; # INDEX INTO VARLIST #
VARIND = FLDVARORD[FLDIND];
OFFSET = VARVALOS[VARIND];
MINVAL = RECWORDR[OFFSET];
MAXVAL = RECWORDR[OFFSET + 1];
FPSTAT = GFP(IVALUE,EVALUE,RVALUE); # GENERATE REAL VALUE #
IF FPSTAT EQ 0 THEN
BEGIN # IF NO ERROR IN REAL VALUE #
IF (RVALUE LS MINVAL) OR (RVALUE GR MAXVAL) THEN
BEGIN # IF VALUE OUTSIDE OF RANGE #
FLDVALID[FLDIND] = FALSE;
END
END
ELSE
BEGIN # ERROR IN REAL VALUE #
FLDVALID[FLDIND] = FALSE;
END
END # REALRANGE #
CONTROL EJECT;
PROC SETATR(FLDINDEX);
# TITLE SETATR - SET FIELD ATTRIBUTES. #
BEGIN # SETATR #
#
** SETATR - SET FIELD ATTRIBUTES.
*
* THIS PROCEDURE SETS THE FIELD ATTRIBUTES FOR A GIVEN FIELD.
*
* PROC SETATR(FLDINDEX)
*
* ENTRY FLDINDEX = INDEX INTO FIELD TABLE
*
* CALLS VDTSAM, VDTSAP.
#
ITEM FLDINDEX I; # FIELD INDEX #
VDTSAP(TERPREVPOS[0],FLDXCORD[FLDINDEX],FLDYCORD[FLDINDEX]);
TERPREVPOS[0] = TERPREVPOS[0] + FLDLENGTH[FLDINDEX] + 1;
IF (FLDATTORD[FLDINDEX] NQ TERCURVORD[0])
OR TERBLCKMDE[0] OR TERATTRCHR[0] THEN
BEGIN # IF NEED TO SET ATTRIBUTES #
TERCURVORD[0] = FLDATTORD[FLDINDEX];
VDTSAM(ATTMASK[TERCURVORD[0]]);
END
END # SETATR #
*IF DEF,QTRM
CONTROL EJECT;
PROC SETFSF(PANELADDR);
# TITLE SETFSF - SET FIELD STATUS FLAGS FOR PANEL. #
BEGIN # SETFSF #
#
** SETFSF - SET FIELD STATUS FLAGS FOR PANEL.
*
* THIS PROCEDURE GOES THROUGH THE FIELD LIST ENTRIES IN THE PANEL
* (FLDLIST)SETTING THE ENTERED, VALID, REWRITE AND ACTIVE FLAGS
* TO THEIR DEFAULT VALUE. THIS ASSURES THAT PANELS USED BY MORE
* THAN ONE USER WILL PRODUCE COMPLETE OUTPUT THE FIRST TIME THEY
* ARE WRITTEN TO THE SCREEN. THE ENTRY AND VALIDATION FIELDS
* ARE SET FALSE AND THE REWRITE AND ACTIVE FIELDS ARE SET TO TRUE.
* AT THIS TIME VARDATA IS ALSO RESET (TO ALL BLANKS).
*
* PROC SETFSF
*
* ENTRY PANELADDR = ADDRESS OF PANEL.
*
* EXIT FIELD STATUS FLAGS RESET TO DEFAULT VALUES.
* VARDATA BLANKED OUT.
#
ITEM PANELADDR I; # PANEL ADDRESS #
ITEM I I; # COUNTER #
ITEM VDATALEN I; # VARDATA LENGTH #
POSARR(PANELADDR); # POSITION BASED ARRAYS #
FOR I = 0 STEP 1 WHILE FLDENTRY[I] NQ 0 DO
BEGIN # FOR ENTIRE FIELD LIST #
FLDENTERED[I] = FALSE;
FLDVALID[I] = FALSE;
FLDREWRITE[I] = TRUE;
FLDACTIVE[I] = TRUE;
END
IF PANSTRFLD[0] NQ 0 THEN
BEGIN # IF FIELDS EXIST #
VDATALEN = P<FLDLIST> - (PANELADDR + PANHEADLEN);
END
ELSE
BEGIN # NO FIELDS #
VDATALEN = P<VARLIST> - (PANELADDR + PANHEADLEN);
END
# RESET VARDATA #
FOR I = 0 STEP 1 UNTIL VDATALEN - 1 DO
BEGIN # CLEAR VARDATA TO BLANKS #
VDATAU[I] = O"0040 0040 0040 0040 0040";
END
END # SETFSF #
*ENDIF
CONTROL EJECT;
PROC SETSRN(COLUMNS,LINES);
# TITLE SETSRN - SET SCREEN. #
BEGIN # SETSRN #
#
** SETSRN - SET SCREEN.
*
* THIS PROCEDURE SETS THE TERMINAL INTO SCREEN MODE, USING LINES
* AND COLUMNS AS THE DESIRED SCREEN SIZE, AND UPDATES THE GLOBAL
* VARIABLES THAT HOLD THE ACTUAL NUMBER OF LINES AND COLUMNS AND
* THE TERMINAL ATTRIBUTE CHARACTERISTICS.
*
* PROC SETSRN(COLUMNS,LINES)
*
* ENTRY COLUMNS = THE NUMBER OF DESIRED COLUMNS.
* LINES = THE NUMBER OF DESIRED LINES.
*
* EXIT TERPROTECT = TRUE IF TERMINAL HAS PROTECT.
* TERGUARDMD = TRUE IF TERMINAL HAS GUARD MODE.
* TERTABHOME = TRUE IF HARD TAB GOES TO HOME.
* TERTABPROT = TRUE IF CAN TAB TO PROTECTED FIELDS.
* TERSIZECLR = TRUE IF RESET OF SIZE CLEARS SCREEN.
* TERTABAUTO = TRUE IF AUTOMATIC TABBING AVAILABLE.
* TERNUMCOLS = THE ACTUAL NUMBER OF COLUMNS.
* TERNUMLNES = THE ACTUAL NUMBER OF LINES.
* TERLEAVESM = FUNCTION KEY LEAVES MARK COUNT.
* TERSCREENM = TRUE.
*
*IF UNDEF,QTRM
* CALLS VDTGTD, VDTGTF, VDTOPN, VDTSTD, VDTSTM.
*ELSE
* CALLS VDTGTD, VDTGTF, VDTSTD, VDTSTM.
*ENDIF
*
* USES TERGUARDMD, TERLEAVESM, TERNUMCOLS, TERNUMLNES,
* TERPROTECT, TERSCREENM, TERSIZECLR, TERTABAUTO,
* TERTABHOME, TERTABPROT.
#
ITEM COLUMNS U; # DESIRED NUMBER OF COLUMNS #
ITEM LINES U; # DESIRED NUMBER OF LINES #
ITEM SCREEN I = 1; # INDICATES SCREEN MODE TO VDT #
ITEM ATTRWORD U; # TERMINAL ATTRIBUTES WORD #
*IF UNDEF,QTRM
VDTOPN; # OPEN TERMINAL #
*ENDIF
VDTSTM(SCREEN,DUMMY); # SET SCREEN MODE #
VDTSTD(COLUMNS,LINES); # SET SCREEN DIMENSIONS #
VDTGTD(COLUMNS,LINES); # GET ACTUAL VALUES #
TERNUMCOLS[0] = COLUMNS - 1; # SET INTERNAL VALUE #
TERNUMLNES[0] = LINES - 1; # SET INTERNAL VALUE #
FOR DUMMY = 2 STEP 1 UNTIL 4 DO
BEGIN
VDTGTF(ATTRWORD,DUMMY); # GET TERMINAL ATTRIBUTES #
TERMSTATWD[DUMMY] = ATTRWORD; # SAVE TERMINAL ATTRIBUTES #
END
TERSCREENM[0] = TRUE; # TERMINAL IS IN SCREEN MODE #
END # SETSRN #
CONTROL EJECT;
PROC SFLOAD(PANELNAME,PANELADDR,OPENSTAT);
# TITLE SFLOAD - LOAD PANEL. #
BEGIN # SFLOAD #
#
** SFLOAD - LOAD PANEL.
*
* THIS PROCEDURE CALLS THE FAST DYNAMIC LOADER TO LOAD THE
* SPECIFIED PANEL AND ISSUES AN INFORMATIVE MESSAGE IF THE
* LOAD WAS UNSUCCESSFUL DUE TO AN INTERNAL F.D.L. ERROR.
*
* PROC SFLOAD(PANELNAME,PANELADDR,OPENSTAT)
*
* ENTRY PANELNAME = NAME OF PANEL TO BE LOADED.
*
* EXIT PANEL LOADED IF POSSIBLE, OPENSTAT SET, INFORMATIVE
* DAYFILE MESSAGE ISSUED IF NECESSARY.
*
* CALLS ERRMSG, LCP.
*
* NOTES OPENSTAT IS SET BY SFLOAD (AND RETURNED TO SFOPEN)
* IN THOSE INSTANCES WHERE THE FAST DYNAMIC LOADER
* IS CALLED.
*
* OPENSTAT SIGNIFICANCE PROCEDURE
* .....................................................
* . 0 . NO ERROR . BOTH .
* . 1 . UNKNOWN PANEL NAME . SFLOAD .
* . 2 . INCORRECT CAPSULE FORMAT . SFLOAD .
* . 3 . PLT FULL (TOO MANY OPEN PANELS) . SFOPEN .
* . 4 . PANEL ALREADY OPEN . SFOPEN .
* . 5 . INTERNAL (FAST DYNAMIC LOADER) . SFLOAD .
* . 6 . NO SCREEN COMMAND ISSUED . SFOPEN .
* . 7 . UNSUPPORTED TERMINAL . SFOPEN .
* .....................................................
#
ITEM PANELNAME C(7); # NAME OF PANEL TO LOAD #
ITEM PANELADDR I; # MEMORY ADDRESS OF PANEL #
ITEM OPENSTAT I; # RETURNS STATUS TO APPLICATION #
ITEM FATAL B = FALSE; # OPEN ERRORS ARE NOT FATAL #
ITEM FDLSTAT I; # RETURNS STATUS FROM LOADER #
ITEM MSG C(25); # DAYFILE ERROR MESSAGE #
ITEM PNAME C(6) = "SFOPEN"; # PROCEDURE NAME #
SWITCH LOADCASE # F.D.L. STATUS RETURN SWITCH #
NOERROR, # SUCCESSFUL LOAD #
BADLIBRARY, # BAD LIBRARY LIST #
BADGROUP, # BAD GROUP NAME #
UNKNOWNCAP, # UNKNOWN CAPSULE NAME #
BADFORMAT, # BAD CAPSULE FORMAT #
BADENTRY, # BAD PASSLOC/ENTRY FORMAT #
DUPLOAD, # CAPSULE ALREADY IN MEMORY #
CAPOVCAP; # CAPSULE/OVCAP CONFUSION #
LCP(PANELNAME,PANELADDR,FDLSTAT); # CALL FAST DYNAMIC LOADER #
#
* SIMULATED CASE STATEMENT FOR PROCESSING LOADER RETURN STATUS.
#
GOTO LOADCASE[FDLSTAT]; # PROCESS STATUS FROM LOADER #
NOERROR: # NO ERROR #
OPENSTAT = OPENSTATUS"NOERROR"; # UPDATE PANEL LOAD TABLE #
PLTNUMENT[0] = PLTNUMENT[0]+1;
PLTENAME[PLTNUMENT[0]]=PANELNAME;
PLTSLFLAG[PLTNUMENT[0]]=FALSE;
PLTOPENFLG[PLTNUMENT[0]]=TRUE;
PLTADDR[PLTNUMENT[0]]=PANELADDR;
GOTO ENDCASE;
BADLIBRARY: # BAD LIBRARY LIST #
OPENSTAT = OPENSTATUS"INTERNAL"; # ISSUE INFORMATIVE MESSAGE #
MSG = " BAD LIBRARY LIST. ";
ERRMSG(PANELNAME,PNAME,MSG,FATAL);
GOTO ENDCASE;
BADGROUP: # UNKNOWN GROUP NAME #
OPENSTAT = OPENSTATUS"INTERNAL"; # ISSUE INFORMATIVE MESSAGE #
MSG = " BAD GROUP NAME. ";
ERRMSG(PANELNAME,PNAME,MSG,FATAL);
GOTO ENDCASE;
UNKNOWNCAP: # UNKNOWN CAPSULE NAME #
OPENSTAT = OPENSTATUS"UNPANEL"; # UNKNOWN CAPSULE NAME #
GOTO ENDCASE;
BADFORMAT: # BAD CAPSULE FORMAT #
OPENSTAT = OPENSTATUS"INCAPFOR"; # BAD CAPSULE FORMAT #
GOTO ENDCASE;
BADENTRY: # BAD PASSLOC/ENTRY FORMAT #
OPENSTAT = OPENSTATUS"INTERNAL"; # ISSUE INFORMATIVE MESSAGE #
MSG = " BAD ENTRY FORMAT. ";
ERRMSG(PANELNAME,PNAME,MSG,FATAL);
GOTO ENDCASE;
DUPLOAD: # CAPSULE ALREADY IN MEMORY #
OPENSTAT = OPENSTATUS"INTERNAL"; # ISSUE INFORMATIVE MESSAGE #
MSG = " DUPLICATE LOAD. ";
ERRMSG(PANELNAME,PNAME,MSG,FATAL);
GOTO ENDCASE;
CAPOVCAP: # CAPSULE/OVCAP CONFUSION #
OPENSTAT = OPENSTATUS"INTERNAL"; # ISSUE INFORMATIVE MESSAGE #
MSG = " OVCAP CONFUSION. ";
ERRMSG(PANELNAME,PNAME,MSG,FATAL);
ENDCASE:
#
* END OF CASE STATEMENT FOR PROCESSING LOADER RETURN STATUS.
#
END # SFLOAD #
CONTROL EJECT;
PROC SKPBLK(FLDIND,CHARPOS,CHAR);
# TITLE SKPBLK - SKIP BLANKS. #
BEGIN # SKPBLK #
#
** SKPBLK - SKIP BLANKS.
*
* THIS PROCEDURE SKIPS BLANKS IN A FIELD IN VARDATA AND RETURNS
* THE POSITION OF THE FIRST NON-BLANK CHARACTER.
*
* PROC SKPBLK(FLDIND,CHARPOS,CHAR)
*
* ENTRY FLDIND = INDEX OF FIELD IN FLDLIST.
* CHARPOS = STARTING CHARACTER POSITION IN FIELD.
*
* EXIT CHARPOS = POSTION OF FIRST NON-BLANK CHARACTER.
* CHAR = FIRST NON-BLANK CHARACTER.
#
ITEM FLDIND I; # INDEX OF FIELD IN FLDLIST #
ITEM CHARPOS I; # CHARACTER POSITION IN FIELD #
ITEM CHAR I; # INPUT CHARACTER #
ITEM BLANKCHAR B; # BLANK CHARACTER INPUT #
BLANKCHAR = TRUE;
WHYLE BLANKCHAR AND CHARPOS LQ FLDLENGTH[FLDIND] DO
BEGIN
CHAR = NEXTCHAR(FLDIND,CHARPOS);
IF CHAR NQ BLANK THEN
BEGIN # IF NOT BLANK CHARACTER #
BLANKCHAR = FALSE;
END
ELSE
BEGIN # BLANK CHARACTER #
CHARPOS = CHARPOS + 1;
END
END
END # SKPBLK #
CONTROL EJECT;
PROC TABKEY(ORDINAL,INPOS,NEWFIELD,OUTPOS);
# TITLE TABKEY - PROCESS TABKEY. #
BEGIN # TABKEY #
#
** TABKEY - PROCESS TAB KEY.
*
* THIS PROCEDURE IS CALLED TO PROCESS TABS. IN THE CASE OF
* OF A HARD TAB ON A TERMINAL WITH PROTECT MODE VIRTERM HAS
* AN INCORRECT INTERNAL CURSOR POSITION WHICH WILL HAVE TO BE
* RESET. TABKEY DETERMINES THE CURSOR POSITION AND NOTIFIES
* VIRTEM THROUGH VDTCOR. FOR SOFT TABS (INCLUDING TAB KEYS
* ON TERMINALS WITHOUT PROTECT MODE) THE CURSOR POSITION IS
* INCORRECT BUT WILL BE FIXED THE NEXT TIME THAT PROCEDURE
* READIN DOES A VDTPOS.
*
* PROC TABKEY(ORDINAL,INPOS,FIELD,OUTPOS)
*
* ENTRY ORDINAL = FTAB, FORWARD TAB KEY
* = BTAB, BACKWARD TAB KEY
* INPOS = LINE AND COLUMN WHERE TAB KEY WAS PRESSED
*
* EXIT OUTPOS = NEW X/Y POSITION
* NEWFIELD = NEW FIELD POSITION
*
* NOTES CURSOR IS POSITIONED TO HOME IF TABBED BEYOND FIRST OR
* LAST INPUT FIELD.
#
ITEM ORDINAL I; # ORDINAL OF TAB KEY #
ITEM INPOS I; # LINE AND COLUMN WHERE PRESSED #
ITEM NEWFIELD I; # ORDINAL OF FIELD TABBED TO #
ITEM OUTPOS I; # NEW LINE AND COLUMN #
ITEM FIELDFOUND B; # FOUND FIELD TABBED TO #
ITEM I I; # LOOP COUNTER #
ITEM P I; # POINTER TO PREVIOUS FIELD #
P = -1;
NEWFIELD = -1;
FIELDFOUND = FALSE;
IF ORDINAL EQ SCREENST"FTAB" THEN
BEGIN # FORWARD TAB KEY PRESSED #
FOR I = 0 STEP 1 WHILE FLDENTRY[I] NQ 0
AND NOT FIELDFOUND DO
BEGIN # LOOK FOR NEXT INPUT FIELD #
IF FLDINPUTV[I] AND FLDACTIVE[I] THEN
BEGIN
IF INPOS LS FLDPOS[I]
AND (TERPTDWFLN[0] OR NOT (P GQ 0
AND FLDYCORD[P] EQ FLDYCORD[I]-1 AND FLDXCORD[I] EQ 0
AND FLDXCORD[P]+FLDLENGTH[P] EQ TERNUMCOLS[0]+1)) THEN
BEGIN # IF NEXT NON-CONTIGUOUS FIELD #
FIELDFOUND = TRUE;
NEWFIELD = I;
END
ELSE P = I;
END
END
END
ELSE
BEGIN # BACKWARD TAB KEY PRESSED #
IF INPOS EQ 0 THEN
BEGIN
XMASKOF INPOS = TERNUMCOLS[0];
YMASKOF INPOS = TERNUMLNES[0];
END
P = -1;
FOR I = 0 STEP 1 WHILE FLDENTRY[I] NQ 0 AND FLDPOS[I] LS INPOS DO
BEGIN # LOOK FOR NEXT INPUT FIELD #
IF FLDINPUTV[I] AND FLDACTIVE[I] THEN
BEGIN
IF TERPTDWBLN[0] OR NOT (P GQ 0
AND FLDYCORD[P] EQ FLDYCORD[I]-1 AND FLDXCORD[I] EQ 0
AND FLDXCORD[P]+FLDLENGTH[P] EQ TERNUMCOLS[0]+1) THEN
NEWFIELD = I; # IF FIELDS NOT CONTIGUOUS #
P = I;
END
END
END
IF NEWFIELD GQ 0 THEN
BEGIN # IF FIELD FOUND #
OUTPOS = FLDPOS[NEWFIELD];
END
ELSE
BEGIN # FIELD NOT FOUND #
OUTPOS = 0;
END
END # TABKEY #
CONTROL EJECT;
PROC VALIDF(FLDIND);
# TITLE VALIDF - VALIDATE FIELD. #
BEGIN # VALIDF #
#
** VALIDF - VALIDATE FIELD.
*
* THIS PROCEDURE CALLS THE APPROPRIATE VALIDATION PROCEDURE
* AS WELL AS CONVERTING INTEGER AND REAL VARIABLE INPUT TO
* THE CORRECT NUMERIC VALUE.
*
* PROC VALIDF(FLDIND)
*
* ENTRY FLDIND = INDEX OF CURRENT FIELD IN FLDLIST.
*
* EXIT FLDVALID[FLDIND] = FALSE, IF NUMERIC INPUT IS INVALID.
*
* CALLS DATEVL, IRANGE, MATCHV, NCHECK, PICVAL, RRANGE.
#
ITEM FLDIND I; # INDEX OF FIELD #
ITEM ALLBLANK B; # ALL BLANKS IN FIELD #
ITEM DOLLARSIGN B; # $ IN INPUT #
ITEM EVAL I; # EXPONENT VALUE OF INPUT #
ITEM I I; # LOOP COUNTER #
ITEM INPTYPE I; # INPUT FORMAT TYPE #
ITEM IVAL I; # INTEGER VALUE OF INPUT #
ITEM NOTFULL B; # FIELD CONTAINS A BLANK #
ITEM STARRED B; # * ("DON-T KNOW") ENTERED #
ITEM VARIND I; # INDEX INTO VARLIST #
SWITCH VARITYPE # VARIABLE TYPE #
RESERV, # RESERVED #
CHARACVAR, # CHARACTER VARIABLE #
INTEGERVAR, # INTEGER VARIABLE #
REALVAR; # REAL VARIABLE #
VARIND = FLDVARORD[FLDIND];
FLDVALID[FLDIND] = TRUE; # TRUE UNTIL PROVEN FALSE #
IF VARMUSENTR[VARIND] AND NOT FLDENTERED[FLDIND] THEN
BEGIN # IF MUST ENTERED AND NOT #
FLDVALID[FLDIND] = FALSE; # PROVEN FALSE #
RETURN;
END
ALLBLANK = TRUE; # SET FLAGS AND CHECK CHARACTER #
STARRED = FALSE;
NOTFULL = FALSE;
IF NEXTCHAR(FLDIND,0) EQ ASTERISK AND NOT VARMUSKNOW[VARIND] THEN
BEGIN # IF ASTERISK AND NOT MUST KNOW #
STARRED = TRUE;
END
IF NEXTCHAR(FLDIND,0) NQ BLANK THEN
BEGIN # IF NOT A BLANK #
ALLBLANK = FALSE; # NOT ALL BLANKS #
END
ELSE
BEGIN # A BLANK #
NOTFULL = TRUE; # UNFULL #
END
FOR I = 1 STEP 1 WHILE I LQ FLDLENGTH[FLDIND] -1 DO
BEGIN # EXAMINE THE REST OF THE FIELD #
IF NEXTCHAR(FLDIND,I) NQ BLANK THEN
BEGIN # IF NOT A BLANK #
ALLBLANK = FALSE; # NOT ALL BLANKS #
STARRED = FALSE; # NOT STARRED #
END
ELSE
BEGIN # A BLANK #
NOTFULL = TRUE; # UNFULL #
END
END
IF STARRED THEN RETURN; # ASTERISK AND NOT *MUST KNOW* #
IF(VARMUSFILL[VARIND] AND FLDENTERED[FLDIND] AND
(NOTFULL AND NOT ALLBLANK)) OR (VARMUSCON[VARIND] AND ALLBLANK) THEN
BEGIN # IF MUST FILL AND NOT FULL OR #
FLDVALID[FLDIND] = FALSE; # MUST CONTAIN AND ALL BLANKS #
RETURN;
END
IF NOT VARMUSENTR[VARIND] AND ALLBLANK THEN RETURN;
GOTO VARITYPE[VARTYPE[VARIND]];
RESERV:
CHARACVAR: # VALIDATE CHARACTER VARIABLE #
IF VARVALM[VARIND] THEN MATCHV(FLDIND);
IF VARPICTYPE[VARIND] NQ 0 THEN PICVAL(FLDIND);
RETURN;
INTEGERVAR: # VALIDATE INTEGER VARIABLE #
IF VARPICTYPE[VARIND] GR FORMTYPE"E" THEN
BEGIN # DATE VALIDATION #
DATEVL(FLDIND,IVAL,EVAL);
END
ELSE
BEGIN
NCHECK(FLDIND,IVAL,EVAL,INPTYPE,DOLLARSIGN);
IF INPTYPE EQ FORMTYPE"BAD" OR INPTYPE GR VARPICTYPE[VARIND]
OR VARPICTYPE[VARIND] EQ FORMTYPE"E" AND DOLLARSIGN THEN
BEGIN
FLDVALID[FLDIND] = FALSE;
RETURN;
END
END
IF VARVALM[VARIND] THEN MATCHV(FLDIND);
IF VARVALR[VARIND] THEN IRANGE(FLDIND,IVAL,EVAL);
RETURN;
REALVAR: # VALIDATE REAL VARIABLE #
IF VARPICTYPE[VARIND] GR FORMTYPE"E" THEN
BEGIN
DATEVL(FLDIND,IVAL,EVAL);
END
ELSE
BEGIN
NCHECK(FLDIND,IVAL,EVAL,INPTYPE,DOLLARSIGN);
IF INPTYPE EQ FORMTYPE"BAD" OR INPTYPE GR VARPICTYPE[VARIND]
OR VARPICTYPE[VARIND] EQ FORMTYPE"E" AND DOLLARSIGN THEN
BEGIN
FLDVALID[FLDIND] = FALSE;
RETURN;
END
END
IF VARVALM[VARIND] THEN MATCHV(FLDIND);
IF VARVALR[VARIND] THEN REALRANGE(FLDIND,IVAL,EVAL);
END # VALIDF #
CONTROL EJECT;
PROC WRIALL;
# TITLE WRIALL - WRITE ALL PANELS. #
BEGIN # WRIALL #
#
** WRIALL - WRITE ALL PANELS.
*
* THIS PROCEDURE REWRITES ALL PANELS THAT ARE ON THE SCREEN IN
* THE ORDER THAT THEY WERE WRITTEN.
*
* PROC WRIALL
*
* ENTRY TERACTPANL = THE NAME OF THE ACTIVE PANEL.
* PLTNUMONSC = THE NUMBER OF PANELS ON THE SCREEN.
*
* EXIT COMPLETE SCREEN REWRITTEN.
*
* CALLS CLRLNS, POSARR, REWFLD, VDTCAA, VDTCLS, VDTPRO, VDTSAM,
* WRIBOX, WRITES.
*
* NOTES THIS PROCEDURE IS CALLED BY READ IN THE CASE OF
* A CLEAR PAGE AND BY WRIPAN IF AN OVERLAY WRITE
* HAS CAUSED A SHIFT FROM 80 TO 132 COLUMN MODE.
* IF THE ACTIVE PANEL IS NOT THE LAST PANEL TO BE
* REWRITTEN THEN ITS VARIABLES WILL BE REWRITTEN
* ONCE MORE TO INSURE THAT THEY ARE CORRECT.
#
ITEM PANELADDR I; # PANEL ADDRESS #
ITEM PANELNAME C(7); # PANEL NAME #
ITEM PLTINDEX I; # PANEL LOAD TABLE INDEX #
ITEM NUMWRITTEN I; # NUMBER OF PANELS WRITTEN #
VDTCLS; # CLEAR SCREEN #
NUMWRITTEN = 0; # NO PANELS WRITTEN YET #
WHYLE NUMWRITTEN NQ PLTNUMONSC[0] DO
BEGIN
NUMWRITTEN = NUMWRITTEN + 1;
PLTINDEX = 1; # FIND CORRECT PANEL #
WHYLE PLTENTRYNM[PLTINDEX] NQ NUMWRITTEN DO
BEGIN
PLTINDEX = PLTINDEX + 1;
END
PANELNAME = PLTENAME[PLTINDEX]; # WRITE PANEL #
PANELADDR = PLTADDR[PLTINDEX];
IF PLTNUMONSC[0] NQ 1 THEN POSARR(PANELADDR);
IF NOT PANPRIPAN[0] THEN CLRLNS;
IF PANSTRFLD[0] NQ 0 THEN WRITES;
IF PANSTRBOX[0] NQ 0 THEN WRIBOX;
END
IF PANELNAME NQ TERACTPANL[0] THEN
BEGIN # IF NEED TO REWRITE VARIABLES #
PANELADDR = PLTADDR[TERACTPLTI[0]];
POSARR(PANELADDR);
IF PANPRIPAN[0] THEN
BEGIN # IF PRIMARY PANEL #
IF NOT TERPROCLRS[0] THEN VDTPRO(OUT"PROTECTALL");
IF PANNUMBYTE[0] NQ 0 THEN REWFLD;
END
ELSE
BEGIN # IF OVERLAY PANEL #
CLRLNS;
IF PANSTRFLD[0] NQ 0 THEN WRITES;
IF PANSTRBOX[0] NQ 0 THEN WRIBOX;
END
END
IF NOT TERBLCKMDE[0] THEN VDTSAM(0); ELSE VDTCAA(0);
END # WRIALL #
CONTROL EJECT;
PROC WRIBOX;
# TITLE WRIBOX - WRITE BOX. #
BEGIN # WRIBOX #
#
** WRIBOX - WRITE BOX.
*
* THIS PROCEDURE WRITES THE BOXES DEFINED IN THE BOX LIST OF
* THE ACTIVE PANEL TO THE SCREEN.
*
* PROC WRIBOX
*
* CALLS VDTBOX, VDTDRW, VDTPOS, VDTPRO, VDTSAM.
*
* NOTES WRIBOX DOES CURSOR POSITIONING AND ATTRIBUTE SELECTION
* (WHICH INCLUDES SELECTION OF THE PROPER LINE WEIGHT
* FOR THE LINE DRAWING CHARACTER SET) AND DOES NOT DE-
* PEND ON THE CALLING PROCEDURE FOR THESE FUNCTIONS.
#
ITEM BOXINDEX I; # INDEX INTO THE BOX LIST #
ITEM CURWEIGHT I; # CURRENT LINE WEIGHT #
ITEM NUMCHARS I; # NUMBER OF CHARACTERS #
IF PANSTRFLD[0] EQ 0 AND NOT TERPROCLRS[0] THEN
BEGIN # IF NO FIELDS AND NO CLEAR #
VDTPRO(OUT"PROTECTALL"); # ISSUE GLOBAL PROTECT #
END
TERCURVORD[0] = -1; # NO CURRENT ATTRIBUTES YET #
CURWEIGHT = -1; # NO CURRENT LINE WEIGHT YET #
FOR BOXINDEX = 0 STEP 1 WHILE BOXWORD[BOXINDEX] NQ 0 DO
BEGIN # CHECK FOR ATTRIBUTE CHANGE #
IF BOXATTORD[BOXINDEX] NQ TERCURVORD[0] THEN
BEGIN # SET NEW ATTRIBUTES #
TERCURVORD[0] = BOXATTORD[BOXINDEX];
IF NOT TERATTRCHR[0] THEN VDTSAM(ATTMASK[TERCURVORD[0]]);
END
IF ATTLINEWT[TERCURVORD[0]] NQ CURWEIGHT THEN
BEGIN # SET NEW LINE WEIGHT #
CURWEIGHT = ATTLINEWT[TERCURVORD[0]];
VDTDRW(CURWEIGHT);
END
IF BOXREPEAT[BOXINDEX] GR 1 THEN
BEGIN # IF HORIZONTAL / VERTICAL LINE #
IF BOXCHAR[BOXINDEX] EQ 0 THEN
BEGIN # IF HORIZONTAL LINE #
IF BOXYCORD[BOXINDEX] LQ TERNUMLNES[0] THEN
BEGIN # IF LINE WITHIN LINE BOUNDARY #
VDTPOS(BOXXCORD[BOXINDEX],BOXYCORD[BOXINDEX]);
FOR NUMCHARS = 0 STEP 1 UNTIL BOXREPEAT[BOXINDEX]-1 DO
BEGIN # OUTPUT HORIZONTAL LINE #
IF BOXXCORD[BOXINDEX] + NUMCHARS LQ TERNUMCOLS[0] THEN
BEGIN # IF WITHIN COLUMN BOUNDARY #
VDTBOX(BOXCHAR[BOXINDEX]);
END
END
END
END
ELSE
BEGIN # IF VERTICAL LINE #
IF BOXXCORD[BOXINDEX] LQ TERNUMCOLS[0] THEN
BEGIN # IF LINE WITHIN COLUMN BOUNDARY #
FOR NUMCHARS = 0 STEP 1 UNTIL BOXREPEAT[BOXINDEX]-1 DO
BEGIN # OUTPUT VERTICAL LINE #
IF BOXYCORD[BOXINDEX] + NUMCHARS LQ TERNUMLNES[0]THEN
BEGIN # IF WITHIN LINE BOUNDARY #
VDTPOS(BOXXCORD[BOXINDEX],BOXYCORD[BOXINDEX]+NUMCHARS);
VDTBOX(BOXCHAR[BOXINDEX]);
END
END
END
END
END
ELSE
BEGIN # OUTPUT SINGLE BOX CHARACTER #
IF BOXYCORD[BOXINDEX] LQ TERNUMLNES[0]
AND BOXXCORD[BOXINDEX] LQ TERNUMCOLS[0] THEN
BEGIN # IF CHARACTER WITHIN BOUNDARIES #
VDTPOS(BOXXCORD[BOXINDEX],BOXYCORD[BOXINDEX]);
VDTBOX(BOXCHAR[BOXINDEX]);
END
END
END
VDTDRW(0); # TURN OFF LINE DRAWING #
END # WRIBOX #
CONTROL EJECT;
PROC WRIPAN;
# TITLE WRIPAN - WRITE PANEL. #
BEGIN # WRIPAN #
#
** WRIPAN - WRITE PANEL.
*
* THIS PROCEDURE DETERMINES IF THE PANEL TO BE WRITTEN IS
* A PRIMARY OR AN OVERLAY PANEL, ASSURES THAT THE TERMINAL
* IS IN SCREEN MODE AND CALLS THE PROPER ROUTINES TO WRITE
* THE PANEL TO THE SCREEN.
*
* PROC WRIPAN
*
* ENTRY TERACTPANL = THE NAME OF THE PANEL TO BE WRITTEN.
* TERACTPLTI = THE CORRESPONDING PLT INDEX.
*
* EXIT PANEL WRITTEN TO SCREEN.
*
* CALLS REWFLD, SETSRN, WRIALL, WRIBOX, WRITES, VDTCAA, VDTCLS,
* VDTGTD, VDTPRO, VDTSAM, VDTSTD.
*
* NOTES IF AN ATTEMPT IS MADE TO WRITE AN OVERLAY PANEL
* WITHOUT A PREVIOUS PRIMARY PANEL BEING WRITTEN
* (I.E. THE TERMINAL IS IN LINE MODE) THEN A DAY-
* FILE MESSAGE WILL BE ISSUED AND THE PROGRAM WILL
* BE ABORTED.
#
ITEM FATAL B = TRUE; # FATAL ERROR #
ITEM HOLDCOLS I; # NUMBER OF REQUESTED COLUMNS #
ITEM HOLDLINES I; # NUMBER OF REQUESTED LINES #
ITEM MSG C(25) = " NOT PRIMARY. "; # ERROR MSG. #
ITEM PANELADDR I; # ADDRESS OF PANEL RECORD #
ITEM PLTCOUNT I; # COUNTER TO CLEAR PLT #
ITEM PNAME C(6) = "SFSWRI"; # PROCEDURE NAME #
IF PLTENTRYNM[TERACTPLTI[0]] NQ 0 THEN
BEGIN # IF PANEL IS ON SCREEN #
IF PANPRIPAN[0] THEN
BEGIN # IF PRIMARY ON SCREEN #
IF PLTNUMONSC[0] GR 1 AND NOT TERPROCLRS[0] THEN
BEGIN # IF MORE THAN 1 AND NO CLEAR #
VDTPRO(OUT"PROTECTALL"); # ISSUE GLOBAL PROTECT #
END
IF PANNUMBYTE[0] NQ 0 THEN REWFLD;
END
ELSE
BEGIN # IF OVERLAY ON SCREEN #
CLRLNS; # CLEAR NECESSARY LINES #
IF PANSTRFLD[0] NQ 0 THEN WRITES;
IF PANSTRBOX[0] NQ 0 THEN WRIBOX;
IF NOT TERBLCKMDE[0] THEN VDTSAM(0); ELSE VDTCAA(0);
FOR PLTCOUNT = 1 STEP 1 UNTIL PLTNUMENT[0] DO
BEGIN # UPDATE SEQUENCE NUMBERS #
IF PLTENTRYNM[PLTCOUNT] GR PLTENTRYNM[TERACTPLTI[0]] THEN
BEGIN
PLTENTRYNM[PLTCOUNT] = PLTENTRYNM[PLTCOUNT]-1;
END
END
PLTENTRYNM[TERACTPLTI[0]] = PLTNUMENT[0];
END
END
ELSE
BEGIN # IF PANEL NOT ON SCREEN #
HOLDCOLS = PANNUMCOLS[0]; # GET REQUESTED COLUMNS #
HOLDLINES = PANNUMLNES[0]; # GET REQUESTED LINES #
IF PANPRIPAN[0] THEN
BEGIN # IF PRIMARY NOT ON SCREEN #
IF NOT TERSCREENM[0] THEN
BEGIN # IF NOT IN SCREEN MODE #
SETSRN(HOLDCOLS,HOLDLINES); # SET SCREEN MODE #
END
ELSE
BEGIN
VDTSTD(HOLDCOLS,HOLDLINES); # SET SCREEN SIZE #
VDTGTD(HOLDCOLS,HOLDLINES); # GET ACTUAL VALUES #
TERNUMCOLS[0] = HOLDCOLS - 1; # SET INTERNAL VALUE #
TERNUMLNES[0] = HOLDLINES - 1; # SET INTERNAL VALUE #
END
VDTCLS;
TERCNWRIOV[0] = TRUE; # ALLOW OVERLAY WRITE #
FOR PLTCOUNT = 1 STEP 1 UNTIL PLTNUMENT[0] DO
BEGIN # CLEAR SEQUENCE NUMBERS #
PLTENTRYNM[PLTCOUNT] = 0;
END
PLTNUMONSC[0] = 1; # ONE PANEL ON SCREEN #
PLTENTRYNM[TERACTPLTI[0]] = 1;
TERMESWRIT[0] = FALSE;
TERMESREAD[0] = FALSE;
IF TERPROCLRS[0] THEN VDTPRO(OUT"PROTECTALL");
IF PANSTRFLD[0] NQ 0 THEN WRITES;
IF PANSTRBOX[0] NQ 0 THEN WRIBOX;
IF NOT TERBLCKMDE[0] THEN VDTSAM(0); ELSE VDTCAA(0);
END
ELSE
BEGIN # IF OVERLAY NOT ON SCREEN #
IF NOT TERCNWRIOV[0] THEN ERRMSG(TERACTPANL[0],PNAME,MSG,FATAL);
PLTNUMONSC[0] = PLTNUMONSC[0] + 1;
PLTENTRYNM[TERACTPLTI[0]] = PLTNUMONSC[0];
IF HOLDCOLS GR TERNUMCOLS[0] OR HOLDLINES GR TERNUMLNES[0] THEN
BEGIN
VDTSTD(HOLDCOLS,HOLDLINES); # SET SCREEN SIZE #
VDTGTD(HOLDCOLS,HOLDLINES); # GET ACTUAL VALUES #
IF HOLDCOLS NQ TERNUMCOLS[0] + 1 OR
HOLDLINES NQ TERNUMLNES[0] + 1 THEN
BEGIN # IF SCREEN SIZE CHANGED, RESET #
TERNUMCOLS[0] = HOLDCOLS - 1;
TERNUMLNES[0] = HOLDLINES - 1;
WRIALL; # WRITE ALL PANELS #
END
ELSE
BEGIN # NO CHANGE TO SCREEN SIZE #
CLRLNS; # CLEAR NECESSARY LINES #
IF PANSTRFLD[0] NQ 0 THEN WRITES;
IF PANSTRBOX[0] NQ 0 THEN WRIBOX;
IF NOT TERBLCKMDE[0] THEN VDTSAM(0); ELSE VDTCAA(0);
END
END
ELSE
BEGIN
CLRLNS; # CLEAR NECESSARY LINES #
IF PANSTRFLD[0] NQ 0 THEN WRITES;
IF PANSTRBOX[0] NQ 0 THEN WRIBOX;
IF NOT TERBLCKMDE[0] THEN VDTSAM(0); ELSE VDTCAA(0);
END
END
END
END # WRIPAN #
CONTROL EJECT;
PROC WRITES;
# TITLE WRITES - WRITE SCREEN. #
BEGIN # WRITES #
#
** WRITES - WRITE SCREEN.
*
* THIS PROCEDURE WRITES THE PANEL TO THE SCREEN USING THE
* POSITIONING INFORMATION FOUND IN THE FIELD LIST AND THE
* DATA FOUND IN THE CONSTANT LIST AND VARIABLE DATA AREAS.
*
* PROC WRITES
*
* EXIT PANEL WRITTEN TO SCREEN.
*
* CALLS SETATR, VDTCAA, VDTPRO, VDTSAM, VDTSTR, WRIVAR.
#
ITEM FLDINDEX I; # INDEX INTO FIELD LIST #
BASED ARRAY CONSTRING;; # PASSES ADDRESS TO VDTSTR #
TERCURVORD[0] = -1; # NO CURRENT ATTRIBUTES YET #
TERPREVPOS[0] = -1; # LAST ATTRIBUTE POSITION #
IF NOT TERPROCLRS[0] THEN VDTPRO(OUT"PROTECTALL");
FOR FLDINDEX = 0 STEP 1 WHILE FLDENTRY[FLDINDEX] NQ 0 DO
BEGIN
IF FLDACTIVE[FLDINDEX] THEN
BEGIN
IF FLDXCORD[FLDINDEX] + FLDLENGTH[FLDINDEX] LQ TERNUMCOLS[0] + 1
AND FLDYCORD[FLDINDEX] LQ TERNUMLNES[0] THEN
BEGIN # IF FIELD ON SCREEN #
SETATR(FLDINDEX); # SET FIELD ATTRIBUTES #
IF FLDVARFLAG[FLDINDEX] THEN # IF VARIABLE FIELD #
BEGIN
WRIVAR(FLDINDEX); # WRITE VARIABLE FIELD #
END
ELSE
BEGIN # WRITE CONSTANT FIELD #
P<CONSTRING>=LOC(RECWORDC[FLDCONOS[FLDINDEX]]);
VDTSTR(CONSTRING);
FLDREWRITE[FLDINDEX] = FALSE; # CLEAR REWRITE FIELD FLAG #
END
IF TERTABPROT[0] THEN
BEGIN # IF PROTECTED TABBING #
IF TERATTRSET[0] THEN
BEGIN # RESET ATTRIBUTES BEFORE VDTPOS #
IF TERCURVORD[0] NQ 2 THEN
BEGIN # IF NOT PROTECTED OUTPUT #
TERCURVORD[0] = 2; # SET ORDINAL AND ISSUE IT #
VDTSAM(O"6001");
END
END
END
END
ELSE
BEGIN # IF FIELD NOT ON SCREEN #
FLDACTIVE[FLDINDEX] = FALSE; # CLEAR ACTIVE FIELD FLAG #
FLDREWRITE[FLDINDEX] = FALSE; # CLEAR REWRITE FIELD FLAG #
END
END
END
IF NOT TERBLCKMDE[0] THEN VDTSAM(0); ELSE VDTSAM(O"6001");
END # WRITES #
CONTROL EJECT;
PROC WRIVAR(FLDINDEX);
# TITLE WRIVAR - WRITE VARIABLE. #
BEGIN # WRIVAR #
#
** WRIVAR - WRITE VARIABLE.
*
* THIS PROCEDURE WRITES THE VARIABLE POINTED AT BY FLDINDEX
* TO THE SCREEN.
*
* PROC WRIVAR(FLDINDEX)
*
* ENTRY FLDINDEX = INDEX INTO THE FIELD LIST.
*
* EXIT VARIABLE WRITTEN TO SCREEN.
*
* NOTES CURSOR POSITIONING HAS BEEN DONE BY THE CALLING
* PROCEDURE AS WELL AS ATTRIBUTE SELECTION.
*
* CALLS VDTPSU.
#
ITEM FLDINDEX I; # INDEX INTO THE FIELD LIST #
ITEM CHARACTER I; # HOLDS ONE CHARACTER FOR VDTCHR #
ITEM CHARINDEX I; # CHARACTER OFFSET INTO VARDATA #
ITEM ENDCHAR I; # LOCATION OF LAST NON-BLANK #
ITEM NUMCHARS I; # NUMCHARS TO WRITE #
ITEM WORDINDEX I; # WORD OFFSET INTO VARDATA #
FLDREWRITE[FLDINDEX] = FALSE; # CLEAR REWRITE FIELD FLAG #
IF NOT TERDONTCLR[0] THEN
BEGIN # CLEAR READ FLAGS #
FLDENTERED[FLDINDEX] = FALSE;
FLDVALID[FLDINDEX] = FALSE;
END
ENDCHAR = 0;
IF FLDOUTPUTV[FLDINDEX] THEN
BEGIN # IF NOT INPUT ONLY VARIABLE #
CHARINDEX = FLDVDTCORD[FLDINDEX]+FLDLENGTH[FLDINDEX];
WORDINDEX = CHARINDEX / 5;
CHARINDEX = 2*(CHARINDEX - (WORDINDEX * 5));
FOR NUMCHARS = FLDLENGTH[FLDINDEX] STEP -1
WHILE NUMCHARS GR ENDCHAR DO
BEGIN # FIND LAST NON-BLANK CHARACTER #
IF CHARINDEX GR 0 THEN CHARINDEX = CHARINDEX - 2;
ELSE
BEGIN # IF AT END OF WORD #
CHARINDEX = 8;
WORDINDEX = WORDINDEX - 1; # UPDATE WORD INDEX #
END
CHARACTER = C<CHARINDEX,2>VDATAC[WORDINDEX];
IF CHARACTER GR O"40" AND CHARACTER LQ O"176" THEN
ENDCHAR = NUMCHARS; # IF DISPLAYABLE NON-BLANK #
END
WORDINDEX = FLDVDTCORD[FLDINDEX] / 5;
CHARINDEX = 2*(FLDVDTCORD[FLDINDEX] - (WORDINDEX * 5));
FOR NUMCHARS = 1 STEP 1 UNTIL ENDCHAR DO
BEGIN # OUTPUT VARIABLE #
IF CHARINDEX EQ 10 THEN
BEGIN # UPDATE WORD INDEX #
CHARINDEX = 0;
WORDINDEX = WORDINDEX + 1;
END
CHARACTER = C<CHARINDEX,2>VDATAC[WORDINDEX];
IF CHARACTER GR O"40"
AND CHARACTER LQ O"176" THEN
BEGIN # IF NON-BLANK AND DISPLAYABLE #
VDTCHR(CHARACTER); # OUTPUT CHARACTER #
END
ELSE
BEGIN # BLANK OR NONDISPLAYABLE #
VDTPSU; # PSEUDO UNDERLINE #
END
CHARINDEX = CHARINDEX + 2; # UPDATE CHARACTER INDEX #
END
END
FOR NUMCHARS = ENDCHAR+1 STEP 1 UNTIL FLDLENGTH[FLDINDEX] DO
BEGIN
IF TERBLCKMDE[0] AND FLDINPUTV[FLDINDEX] THEN
BEGIN
VDTCHR(O"137"); # SEND UNDERLINE TO SCREEN #
END
ELSE
BEGIN
VDTPSU;
END
END
END # WRIVAR #
CONTROL EJECT;
PROC WRIVCH(FIELD,OFFSET,CHAR);
# TITLE WRIVCH - WRITE CHARACTER INTO VARDATA. #
BEGIN # WRIVCH #
#
** WRIVCH - WRITE CHARACTER INTO VARDATA.
*
* PROC WRIVCH(FIELD,OFFSET,CHAR)
*
* ENTRY FIELD = FIELD INDEX.
* OFFSET = CHARACTER POSITION IN FIELD.
* CHAR = CHARACTER INPUT.
*
* EXIT CHAR WRITTEN INTO VARDATA.
#
ITEM FIELD I; # INDEX OF CURRENT FIELD #
ITEM OFFSET I; # CHARACTER OFFSET INTO FIELD #
ITEM CHAR I; # CHARACTER TO PUT INTO VARDATA #
ITEM CHARIND I; # CHARACTER INDEX INTO VARDATA #
ITEM CHARPOS I; # CHARACTER POSITION IN VARDATA #
ITEM WORDIND I; # WORD INDEX INTO VARDATA #
CHARPOS = FLDVDTCORD[FIELD] + OFFSET;
WORDIND = CHARPOS/5;
CHARIND = CHARPOS - 5*WORDIND;
B<CHARIND*12,12>VDATAU[WORDIND] = CHAR;
END # WRIVCH #
END # SFORM # TERM