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 = CNAME; 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 = CNAME; # LEFT JUSTIFY PANEL NAME # *IF UNDEF,QTRM P = LOC(PLT); # REFERENCE PANEL LOAD TABLE # *ELSE P = 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 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 = 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 = CCSET; 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 = CHAIN; IF QLEN LS 1 THEN QLEN = 7; # CRACK PARAMETER # QUEUENAME = CQNAME; WHYLE P 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 = P + 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$WD0[B$CURWORD] = BQ$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; # ADDRESS FOR CMM # I = Q$BACK; # BACK POINTER # J = Q$FORWARD; # FORWARD POINTER # P = 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 = 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$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 = CVARNAME; 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 = 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 # CSTRING = " "; ELSE IF CRETVAL EQ 0 THEN # IF BEYOND ACTUAL MODEL NAME # CSTRING = " "; ELSE CSTRING = CRETVAL; OFFIND = OFFIND + 1; IF (OFFIND GR 9) THEN BEGIN # IF END OF CURRENT WORD # OFFIND = 0; P = P + 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 # CVARNAME = " "; ROWNUM = 0; # FIND FIELD # FFIELD(TERFUNCPOS[0],FIELD,OFFSET,OUTSEARCH); IF VALIDFIELD THEN BEGIN # IF FIELD FOUND # OFFSET = OFFSET + 1; VARIND = FLDVARORD[FIELD]; CVARNAME = 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 = CVARNAME; 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 = CMODEL; 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 = 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 = 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 = LOC(PLT); # INITIALIZE THE NIT PLT AREA # I = PLTNUMENT[0]; P = 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 = CQNAME; P = LOC(BUFFER); B$CURBIT = 0; # START AT BEGINNING OF BUFFER # B$CURWORD = 0; ENTCT = ENTCT + 1; SFNQUE1: I = 0; P = CHAIN; WHYLE P 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 = P + 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; BQ$WORD[WORD] = BB$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; # QUEUE DOESN-T EXIST, CREATE IT # P = Q$FORWARD; # ADD BLOCK TO END OF CHAIN # END IF CHAIN EQ 0 THEN BEGIN # IF NO CHAIN HEADER # P = LOC(CHAIN); END ELSE BEGIN # CHAIN HEADER EXISTS # P = I; END CMMALF (Q$BLKSIZE,0,0,RCC); Q$FORWARD = RCC; I = P; P = 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=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 = CNAME; *IF DEF,QTRM # CHECK FOR PANEL IN THIS USERS PLT AREA # P = 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 = 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 = 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 = 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 = 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 = CTABLENAME; 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 = LOC(NITADDR); # SAVE NIT ADDRESS # IF CURRNT$ACN EQ 0 THEN BEGIN # IF FIRST CALL TO SFQTRM$ # CURRNT$ACN = NIT$CON[0]; P = 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 = NIT$PCT[CURRNT$ACN]; # SAVE PREVIOUS TERMINAL-S STATE # TERFLDADDR = P; # SAVE FIELD LIST ADDRESS # P = P + SFORMOFFSET; FOR I = 0 STEP 1 UNTIL SFORMSIZE -1 DO BEGIN # MOVE SFORM DATA # QTRM$WD0[I] = TERMSTATWD[I]; END P = P + VTERMOFFSET; FOR I = 0 STEP 1 UNTIL VTERMSIZE - 1 DO BEGIN # MOVE VIRTERM DATA # QTRM$WD0[I] = COMVDT$WD0[I]; END P = P + 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; BQTRM$WD0[WORDIND] = FLDSTFLAGS[I]; END END P = P + VDTAOFFSET; PANELADDR = P - PANHEADLEN; IF PANSTRFLD[0] NQ 0 THEN BEGIN # IF FIELDS EXISTS # VDATALEN = P - (PANELADDR + PANHEADLEN); END ELSE BEGIN # NO FIELDS # VDATALEN = P - (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 = NIT$PCT[CURRNT$ACN]; P = NIT$PCT[CURRNT$ACN] + PLTOFFSET; P = P + SFORMOFFSET; FOR I = 0 STEP 1 UNTIL SFORMSIZE - 1 DO BEGIN # MOVE SFORM DATA # TERMSTATWD[I] = QTRM$WD0[I]; END P = TERFLDADDR; # FLDLIST ADDRESS # P = P + 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 = P + 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] = BQTRM$WD0[WORDIND]; END END PANELNAME = TERACTPANL[0]; # GET PANEL NAME # GETADD(PANELNAME,PANELADDR,PLTINDEX); POSARR(PANELADDR); P = P + VDTAOFFSET; PANELADDR = P - PANHEADLEN; IF PANSTRFLD[0] NQ 0 THEN BEGIN VDATALEN = P - (PANELADDR + PANHEADLEN); END ELSE BEGIN VDATALEN = P - (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 = 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] = CVARNAME; 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 = CPANELP; 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 = CNAME; # 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 BVDATAU[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 CPANELNAME NQ SPACE AND CPANELNAME 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 = 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 = CMATCH[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 CMATCH[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 = CMATCH[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 = CVNAME; 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 CCSET 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 = LOC(VDATAU[WORDIND]); P = 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 = LOC(STRG); FROMCHAROS = SOS; # CHARACTER OFFSET / FROM STRING # P = 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 = STRINGADDR; # POSITION FROM AND TO STRING # P = 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 = LOC(VDATAU[0]); # POSITION FROM AND TO STRING # P = 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 # CTOSTRIU[TOINDEX] = CFROMSTRIU[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; CTOSTRIU[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; CTOSTRIU[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 = PANELADDR; # POSITION BASED ARRAYS # P = PANELADDR; P = PANELADDR + PANHEADLEN; IF PANSTRFLD[0] NQ 0 THEN BEGIN # IF PANEL HAS FIELD LIST # P = PANELADDR + PANSTRFLD[0]; END ELSE BEGIN # NO FIELD LIST, ONLY BOXES # P = LOC(ZEROWORD); END P = PANELADDR + PANSTRVAR[0]; P = PANELADDR + PANSTRFUN[0]; P = PANELADDR + PANSTRATT[0]; P = PANELADDR + PANSTRARR[0]; P = 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 = PANELADDR; IF PAN2STRFLD[0] NQ 0 THEN BEGIN # IF PANEL HAS FIELD LIST # P = PANELADDR + PAN2STRFLD[0]; END ELSE BEGIN # NO FIELD LIST, ONLY BOXES # P = LOC(ZEROWORD); END P = PANELADDR + PAN2STRVAR[0]; P = PANELADDR + PAN2STRATT[0]; P = 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 = 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 = LOC(DEFMESSAGE[0]); # *PLEASE ENTER* # END ELSE BEGIN # DATA ENTERED IN FIELD # P = LOC(CORMESSAGE[0]); # *PLEASE CORRECT* # END END END ELSE BEGIN # NO INPUT FIELD # MSGFIT = TRUE; # SMF MESSAGE WILL FIT # P = LOC(FUNMESSAGE[0]); # *PLEASE PRESS FUNCTION KEY* # END TERHELPREQ[0] = FALSE; # HELP REQUEST HONORED # GOTO PRINTMSG; JUMPRENT: MSGFIT = TRUE; # SMF MESSAGE WILL FIT # P = 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 = LOC(CONMESSAGE[0]); # *PLEASE CONFIRM* # END ELSE BEGIN # NO INPUT FIELD # P = 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 = CMESSWORD[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 = CMESSWORD[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=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 - (PANELADDR + PANHEADLEN); END ELSE BEGIN # NO FIELDS # VDATALEN = P - (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=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 = CVDATAC[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 = CVDATAC[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; BVDATAU[WORDIND] = CHAR; END # WRIVCH # END # SFORM # TERM