; INP.DBL V-A-X PROCEDURE DIVISION FOR THE FDS.DBL DATA DIVISION FOR TT INPUT ; PROGRAMMER RON TENNY 1/7/83 ; ; COMMENTS The main program used with this procedure division must have three common return labels, ; COM1, COM2 & COM3 to handle common functions as follows: ; ; COM1 applies OPTIONAL values to the record before being created or updated ; COM2 checks that the ID code of header/trailer type records is proper for the record ; COM3 bumps up the ID code of mailing and customer records to be unique in 'CUSTSC' & 'MAILSC' ;*************************************** ; FORMAT THE SCREEN FROM PARAMETER FILE ;*************************************** READ, ONERROR RSCR K = 0 ;COUNTER OF ELEMENTS READ FROM SCREEN PARAMETER FILE Y = 1 ;POINTER INTO NEXT SCREEN START ELEMENT ARRAY Z = 1 ;CURRENT SCREEN #1 S(1) = 0 ;LOAD NEXT SCREEN START ELEMENT RSCR, READS (6,SCR,EOS) ;SCAN THRU SCREEN PARAMETERS IF (SC.EQ.';') GOTO RSCR ;BYPASS COMMENT LINES IF (SC.EQ.'!') GOTO NEXT ;REACHED A BREAK IN THE PARAMETERS FOR NEXT SCREEN IF (TRC.EQ.'S') INCR STFLG ;FLAGS THAT WE HAVE THE STATE FILE OPEN IF (TRC.EQ.'S'.AND.STFLG.EQ.1) XCALL XOPEN (5,'SI','STATE.ISM');OPEN THE STATE CODE/ZIP CROSS-REFERENCE FILE NEXT, INCR K ;BUMP UP THE TOTAL ELEMENTS COUNTER RTRC(K) = SCR ;LOAD THE PARAMETER LINE INTO ARRAY TRC = STRC ;TRANSFER DISPLAY INFO IF (SC.EQ.'!') GOTO NEWSCR ;NEXT SCREEN BREAK LINE, UPDATE COUNTERS IF (CLR.LE.MAX) GOTO BADSCR ;TRAPS FOR A BAD CLEAR LENGTH IN PARAMETER FILE IF (STXT.EQ.' ') GOTO BADSCR ;NO TEXT IN THE PARAMETER TEXT FIELD IF (Y.GE.2) GOTO RSCR ;PARAMETERS FOR NEXT SCREEN, DON'T DISPLAY THEM L = CLM - SLEN ;BACK UP TO THE LEFT THE LENGTH OF THE TEXT LINE DISPLAY (TT,DIS,ROW+31,L+31,STXT(1,SLEN)) ;DISPLAY THE TEXT ON THE SCREEN GOTO RSCR ;READ IN THE NEXT SCREEN PARAMETER NEWSCR, INCR Y ;BUMP THE POINTER INTO THE NEXT SCREEN ARRAY S(Y) = K ;SAVE THE VALUE (ONE LOW) FOR THE NEXT SCREEN START ELEMENT GOTO RSCR ;READ IN THE NEXT SCREEN PARAMETER EOS, CLOSE 6 ;CLOSE THE PARAMETER FILE OFFERROR OPT = 3 ;DEFAULT START UP IS 'CHANGE' MODE MSG = 'CHANGES' ;DEFAULT MESSAGE DISPLAY (TT,DIS,32,38,'C') ;DISPLAY THE CHANGE MODE CHARACTER GOTO DKEY ;SKIP TYPE SELECTION ON FIRST PASS ;**************************************** ; ACCEPT TYPE OF MAINTENANCE DESIRED ;**************************************** TYPE, XCALL FLAGS ('11000000') ;DISABLE ALL FLAGS EXCEPT CONTROL C TRAP OPT = 0 SCR = ;CLEAR OUT PARAMETERS TRC = 'A0107010102' XCALL XINP IF (TCHAR.EQ.3) GOTO SELECT ;UP ARROW TO CHECK ALT KEY DISPLAY (TT,DIS,32,38,INPUT(1,1),DIS,55,32,BLANK) TYP, INCR OPT MSG = 'INQUIRY' IF (INPUT.EQ.'I') GOTO DKEY INCR OPT MSG = 'ADDITIONS' IF (NOADD.NE.1.AND.INPUT.EQ.'A') GOTO DKEY INCR OPT MSG = 'CHANGES' IF (INPUT.EQ.'C') GOTO DKEY INCR OPT MSG = 'DELETIONS' IF (NOADD.NE.1.AND.INPUT.EQ.'D') GOTO DKEY MSG = 'ENTER -I-, -A-, -C-, -D-' CALL INVRTN GOTO TYPE ;INVALID TYPE , RETURN DKEY, DISPLAY (TT,DIS,32,92,MSG(1,15),BLANK) IF ((X.NE.1).AND.(OPT.EQ.2.OR.OPT.EQ.4)) GOTO SELECT ;CANT ADD OR DELETE ON ALTERNATE KEY GOTO KEY ;************************************* ; SEARCH FOR THE KEY IN THE KEY FILE ;************************************* ICD, XCALL FLAGS ('11000010') ;ENABLE LOWER CASE FLAG DISPLAY (TT,DIS,33,32,BLANK) IF (OPT.EQ.2) GOTO ADD PASS, ONERROR ERRORI RC(KEYL,KEYH)=DBKEY READ (CHAN,RC,RC(KEYL,KEYH)) DBKEY = RC(KEYL,KEYH) DIS, CALL COM2 ;CHECK TO SEE IF ID IS OK IF (IDCHK.EQ.1) GOTO SCAN ;NOT THE RIGHT ID OFFERROR DISP, DISPLAY (TT,DIS,32,47,RC(KEY1L,KEY1H)) ;DISPLAY PRIMARY KEY AGAIN FROM ACTUAL RECORD IF (OPT.EQ.1) UNLOCK CHAN K = S(Z) ;LOAD THE STARTING POINT OF THE NEXT SCREEN ;****************************************************** ; DISPLAY INFORMATION FIELDS ON THE SCREEN ;****************************************************** I1, INCR K SCR = RTRC(K) TRC = STRC ;TRANSFER DISPLAY INFO IF (TRC(1,1).EQ.' ') GOTO I2 IF (TYP.EQ.'A'.OR.TYP.EQ.'Y') GOTO AOK ;PLAIN ALPHA FIELD OR Y/N FIELD INPUT = RCA(FROM,TO) IF (TYP.EQ.'S') GOTO AOK ;STATE ALPHA FIELD GOTO IN ;ITS A NUMERIC FIELD AOK, IF (TYP.EQ.'S') CALL STREAD ;ITS A STATE FIELD, READ THE FILE DISPLAY (TT,DIS,ROW+31,CLM+31,RCA(FROM,TO),' ') GOTO I1 IN, EA(1,CLR-1) = RCD(FROM,TO), EDT(1,CLR-1) ;PLACE EDIT MASK ON FIELD DISPLAY (TT,DIS,ROW+31,CLM+31,EA(1,CLR-1),' ') GOTO I1 I2, GOTO (CHANGE,CHANGE,DELETE), OPT-1 ;INQUIRY (OPT = 1) FALLS THRU CALL FC IF (TCHAR.NE.0) GOTO KEY ;SOME ARROW HIT STOP ;BAD INPUT ;------------------------------------------------------------------------------------------------------------- SCAN, RC(KEYL,KEYH) = DBKEY IF (OPT.NE.3) GOTO SCN ;IT IS NOT IN CHANGE MODE WRITE (CHAN,RC,RC(KEYL,KEYH)) ;WRITE OUT LAST CHANGE BEFORE CONTINUING WITH SCAN DISPLAY (TT,7,DIS,32,101,'-PROCESSED-') SCN, ONERROR CKEOF READS (CHAN,RC,KEY) ;SEQUENTIALLY SCAN DBKEY = RC(KEYL,KEYH) CALL COM2 ;CHECK RECORD ID IF (IDCHK.EQ.1) GOTO SCN ;NOT THE RIGHT ID OFFERROR GOTO DISP CKEOF, XCALL ERROR (ERNO,ERLN) CALL ERROR ;PROCESS THE ERROR OFFERROR GOTO KEY ;************************** ; CHANGE ROUTINE ;************************** CHANGE, CALL FC IF (OPT.EQ.2) GOTO (ADD3,ADD5,CHGOUT,NOPRO) ,TCHAR GOTO (SCAN,CHGOUT,CHGOUT,NOPRO) ,TCHAR K = S(Z) ;LOAD THE STARTING POINT OF THE NEXT SCREEN CHGK, INCR K SCR = RTRC(K) TRC = STRC ;TRANSFER DISPLAY INFO IF (TRC(1,1).EQ.' ') GOTO CHANGE ;A NON-EXISTANT FIELD IF (K.NE.NUM) GOTO CHGK ;SCAN THRU THE ARRAY TILL THE PROPER FIELD REACHED IF (SNUM.EQ.0) GOTO CHANGE ;A 'DISPLAY-ONLY' FIELD AGAIN, XCALL XINP ; IF (TCHAR.GT.0) GOTO AGAIN ;THEY HIT AN ESCAPE BY ACCIDENT RCA(FROM,TO) = IF (TYP.EQ.'A'.OR.TYP.EQ.'Y') GOTO AOK1 ;PLAIN ALPHA FIELD OR Y/N FIELD IF (TYP.EQ.'S') GOTO AOK1 GOTO CHGN ;ITS A NUMERIC FIELD AOK1, IF (TYP.EQ.'S') CALL STREAD ;ITS A STATE, READ FILE RCA(FROM,TO) = INPUT GOTO CHANGE CHGN, RCD(FROM,TO) = DECMA IF (NAME.EQ.'PART') CALL COM1 ;TEST FOR AUTO PRICE UPDATE FEATURE GOTO CHANGE CHGOUT, RC(KEYL,KEYH)=DBKEY CALL COM1 ;CHECK THE MAIN ROUTINE FOR EDITING OF DATA BEFORE WRITE IF (OPT.EQ.2) GOTO STORE WRITE (CHAN,RC,RC(KEYL,KEYH)) ;WRITE OUT THE UPDATED RECORD PRO, DISPLAY (TT,7,DIS,32,101,'-PROCESSED-',DIS,54,32,BLANK) GOTO KEY NOPRO, DISPLAY (TT,DIS,32,101,'-NO PROCESS') GOTO KEY ;*********************** ; ADDITIONS ROUTINE ;*********************** ADD, K = S(Z) ;LOAD THE STARTING POINT OF THE NEXT SCREEN DISPLAY (TT,DIS,33,32,BLANK) ADD1, INCR K SCR = RTRC(K) TRC = STRC ;TRANSFER DISPLAY INFO IF (TRC(1,1).EQ.' ') GOTO ADD2 DISPLAY (TT,DIS,ROW+31,CLM+31,PER(1,MAX),BLNK(1,CLR-MAX)) GOTO ADD1 ADD2, K = S(Z) ;LOAD THE STARTING POINT OF THE NEXT SCREEN RC = ADD3, INCR K SCR = RTRC(K) TRC = STRC ;TRANSFER DISPLAY INFO IF (TRC(1,1).EQ.' ') GOTO CHANGE XCALL XINP GOTO (ADD3,ADD5,CHANGE,CHANGE),TCHAR IF (TYP.EQ.'A'.OR.TYP.EQ.'Y') GOTO AOK2 ;PLAIN ALPHA FIELD OR Y/N FIELD IF (TYP.EQ.'S') GOTO AOK2 ;IT IS A STATE ALPHA FIELD GOTO ADDN ;IT IS A NUMERIC FIELD AOK2, IF (TYP.EQ.'S') CALL STREAD ;READ THE STATE CODE FILE RCA(FROM,TO) = INPUT GOTO ADD3 ADDN, RCD(FROM,TO) = DECMA GOTO ADD3 ADD5, K = K-2 IF (K.LT.0) K = 0 GOTO ADD3 STORE, ONERROR ERRORA STORE (CHAN,RC,RC(KEYL,KEYH)) OFFERROR DISPLAY (TT,DIS,33,47,RC(KEYL,KEYH)) GOTO PRO ;--------------------------------------------------------------------------------------------------- ;************************************ ; MISC ROUTINES ;************************************ STREAD, ONERROR BADST ;READ THE STATE CODE FILE BYPASS IF BAD STACD = INPUT ;SAVE THE STATE CODE STCOD = STACD ;TRANSFER THE STATE CODE TO THE FILE KEY READ (5,STATE,STCOD) ;READ THE STATE CODE FILE USING THE KEY BADST, OFFERROR RETURN INVRTN, DISPLAY (TT,DIS,54,32,CLEAR,MSG,DIS,54,82,'Please C/R, then reenter ',7) READS (TT,OK) DISPLAY (TT,DIS,55,32,BLANK) MSG = OFFERROR RETURN FC, NUM = DISPLAY (TT,DIS,32,102,BLANK,DIS,54,32,CLEAR,10,'FIELD #') SCR = ;CLEAR OUT PARAMETERS TRC = 'N2409000203' XCALL XINP IF (TCHAR.GT.0) RETURN IF (DECMA.EQ.0) GOTO NXTSCR ;THE OPERATOR WANTS TO SEE THE NEXT SCREEN ;;;;;; IF (NAME.EQ.'PART'.AND.DECMA.EQ.0) GOTO COM1 NUM = DECMA + (Z - 1) ;BUMP UP NUMBER IF ON MULTIPLE SCREENS RETURN NXTSCR, CNT = Z ;SAVE THE CURRENT SCREEN NUMBER INCR Z ;BUMP UP SCREEN COUNTER K = S(Z) ;LOAD STARTING POINT (ONE LOW) OF NEXT SCREEN IF (K.EQ.0) Z = 1 ;WE HAVE REACHED THE LAST SCREEN, GO TO THE FIRST ONE IF (Z.EQ.CNT) GOTO FC ;WE ARE ON THE FIRST AND ONLY SCREEN ALREADY DISPLAY (TT,DIS,33,32,CLEAR) NXTLP, INCR K SCR = RTRC(K) ;GET THE PARAMETERS OUT OF THE ARRAY TRC = STRC ;TRANSFER DISPLAY INFO IF (TRC.EQ.' ') GOTO DIS ;REACHED THE NEXT SCREEN OR THE END, SO DISPLAY THIS ONE L = CLM - SLEN ;BACK UP THE DISPLAY POINT THE LENGTH OF THE TEXT DISPLAY (TT,DIS,ROW+31,L+31,STXT(1,SLEN)) ;DISPLAY THE TEXT GOTO NXTLP ;LOOP BACK FOR THE NEXT ELEMENT ON THIS SCREEN DELETE, DISPLAY (TT,DIS,54,32,'Record to be deleted? (N) ',CLEAR,7) XCALL FLAGS ('01000000') READS (TT,OK) IF (OK.NE.'Y') GOTO NOPRO XCALL FLAGS ('11000010') RC(KEYL,KEYH) = DBKEY DELETE (CHAN,RC(KEYL,KEYH)) DISPLAY (TT,DIS,54,32,BLANK) GOTO PRO ;--------------------------------------------------------------------------------------- SELECT, DISPLAY (TT,DIS,54,32,CLEAR,'SELECT: -1-',KEY1) IF (KEY2L.NE.0) DISPLAY (TT,' -2-',KEY2) IF (KEY3L.NE.0) DISPLAY (TT,' -3-',KEY3) SCR = ;CLEAR OUT PARAMETERS TRC = 'N2309010102' XCALL XINP IF (TCHAR.EQ.3) GOTO DISPL ;UP ARROW HIT TO QUIT IF (TCHAR.NE.0) GOTO SELECT ;BAD ENTRY OF ARROWS OR ESCAPES IF (DECMA.LE.0) GOTO SELECT ;BAD ENTRY X = DECMA IF (X.GT.1.AND.Z.GT.1) GOTO SELECT ;CAN'T SELECT AN ALTERNATE KEY IF ON THE SECOND SCREEN KEY = KEYS(X) ;GET THE PROPER KEY FROM THE ARRAY IF (KEYL.EQ.0) GOTO SELECT ;THEY SELECTED A BAD KEY DISPLAY (TT,DIS,54,32,BLANK) IF (X.EQ.1) GOTO TYPE ;SELECTED PRIMARY KEY DISPLAY (TT,DIS,32,38,'C') INPUT = 'C' ;FORCE CHANGE OPTION WHEN USING ALT KEY GOTO TYP ;---------------------------------------------------------------------------------------------------- ALTKEY, SCR = RTRC(KEYN) ;GET KEYS DISPLAY LOCATION FROM ARRAY TRC = STRC ;TRANSFER DISPLAY INFO SCR = ;CLEAR OUT BAD PARAMETERS IF (ROW.LE.0) GOTO BADREF ;VALUE NOT SET RIGHT IN MAIN PROG XCALL XINP IF (TCHAR.EQ.3) GOTO TYPE DBKEY = INPUT GOTO ICD ;---------------------------------------------------------------------------------------------------- ERRORI, XCALL ERROR (ERNO,ERLN) CALL ERROR IF (ERNO.EQ.40) GOTO KEY DBKEY = RC(KEYL,KEYH) IF (ERNO.EQ.53) GOTO DIS IF (ERNO.EQ.64) GOTO UNFOUN A4 = ERNO B4 = ERLN DISPLAY (TT,DIS,55,32,'ERROR: ',A4,' AT LINE: ',B4) SLEEP 2 IF (ERNO.NE.40) GOTO KEY GOTO ICD ERRORA, XCALL ERROR (ERNO,ERLN) IF ((NAME.EQ.'MAIL'.OR.NAME.EQ.'CUST'.OR. & NAME.EQ.'VEPRSC'.OR.NAME.EQ.'CUMESC').AND. & (ERNO.EQ.54)) GOTO BUMP ;BUMP UP KEY TO AVOID A DUPLICATE CALL ERROR IF (ERNO.EQ.54) GOTO DUPLIC A4 = ERNO B4 = ERLN DISPLAY (TT,DIS,55,32,'ERROR: ',A4,' AT LINE: ',B4) SLEEP 2 IF (ERNO.NE.40) GOTO KEY GOTO STORE BUMP, CALL COM3 ;BUMP UP THE RECORD ID VALUE TO AVOID DUP KEYS GOTO STORE ERROR, MSG = IF (ERNO.EQ.01) MSG = 'End of file reached' IF (ERNO.EQ.22) MSG = ' I/O error ' IF (ERNO.EQ.40) MSG = 'Record locked by another user ' IF (ERNO.EQ.53) MSG = 'Approximate key located' CALL INVRTN RETURN BADV, MSG = 'Bad vendor number --- try again' CALL INVRTN RETURN BADSCR, MSG = 'Bad screen parameter ' MSG(22,40) = STXT CALL INVRTN STOP BADREF, MSG = 'Bad alternate key "KEY?N" value in ' MSG(36,41) = NAME CALL INVRTN STOP BADKEY, MSG = 'I will not allow a key of zero' CALL INVRTN GOTO KEY DUPLIC, MSG = 'You can''t add duplicate keys' CALL INVRTN GOTO KEY UNFOUN, MSG = 'No records on file with this key' CALL INVRTN GOTO KEY