Trailing-Edge
-
PDP-10 Archives
-
decuslib20-07
-
decus/20-0168/cssprg.cbl
There is 1 other file named cssprg.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
PROGRAM-ID. CSSPRG, VERSION-5, EDIT-13.
AUTHOR. BOB CONLON.
DATE-WRITTEN. 05-JAN-79, MODIFIED 05-FEB-81.
DATE-COMPILED.
REMARKS. THIS PROGRAM ALLOWS THE USER TO RELIEVE HIS/HER DATA BASE
BASED ON SPECIFIED CRITERIA. IT WRITES INTO AN ISAM FILE
OF THE EXACT IMAGE OF THE DATA BASE. THIS ILLIMINATES THE
NEED FOR STAND ALONE SORTING. IT ALSO ALLOWS THE USER TO
RUN ANY REPORTS ON THE PURGED DATA THAT WERE NORMALLY RUN
ON THE ACTIVE DATA.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. DECSYSTEM-10.
OBJECT-COMPUTER. DECSYSTEM-10.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT FORMAT-FILE ASSIGN TO DSK.
SELECT SOURCE-FILE ASSIGN TO DSK.
DATA DIVISION.
FILE SECTION.
FD FORMAT-FILE; VALUE OF IDENTIFICATION IS FORMAT-NAME.
01 FORMAT-REC PIC X(4035).
FD SOURCE-FILE; VALUE OF IDENTIFICATION IS SOURCE-NAME.
01 SOURCE-RECORD; DISPLAY-7 PIC X(92).
WORKING-STORAGE SECTION.
77 PRIV-1-HOLD PIC 9(3).
77 USER-PASSWORD PIC X(6).
77 PROMPT-IND PIC S9(3); COMP.
77 LINE-COUNT PIC S9(3); COMP.
77 REC-TYPE PIC S9(3); COMP.
77 SYM-IDX INDEX.
77 BD-IDX INDEX.
77 LT-IDX INDEX.
77 ANS1 PIC X.
77 SPA-CNT INDEX.
77 WB1-IDX INDEX.
77 WB2-IDX INDEX.
77 BD-SUM INDEX.
77 CHAR-COUNT PIC S9(4); COMP.
77 COND PIC X(3); VALUE "AND".
77 ANS2 PIC X(64).
77 A1 PIC X(24); VALUE "IDENTIFICATION DIVISION.".
77 A5 PIC X(14); VALUE "DATE-COMPILED.".
77 A6 PIC X(21); VALUE "ENVIRONMENT DIVISION.".
77 A7 PIC X(21); VALUE "INPUT-OUTPUT SECTION.".
77 A8 PIC X(13); VALUE "FILE-CONTROL.".
77 A9 PIC X(46); VALUE " SELECT FORMAT-FILE ASSIGN TO DSK.".
77 A10 PIC X(45); VALUE " SELECT FILE-IN ASSIGN TO DSK".
77 A11 PIC X(54); VALUE " ACCESS MODE IS INDEXED".
77 A12 PIC X(53); VALUE " SYMBOLIC KEY IS ISKEY".
77 A13 PIC X(50); VALUE " RECORD KEY IS IRK.".
77 A14 PIC X(45); VALUE " SELECT FILE-OUT ASSIGN TO DSK".
77 A15 PIC X(53); VALUE " SYMBOLIC KEY IS OSKEY".
77 A16 PIC X(50); VALUE " RECORD KEY IS ORK.".
77 A18 PIC X(14); VALUE "DATA DIVISION.".
77 A19 PIC X(13); VALUE "FILE SECTION.".
77 A20 PIC X(56); VALUE "FD FORMAT-FILE; VALUE OF IDENTIFICATION IS FORMAT-NAME.".
77 A21 PIC X(36); VALUE "01 FORMAT-REC PIC X(4035).".
77 A25 PIC X(11); VALUE "01 REC-IN.".
01 PRG-TABLE.
02 SYM-TAB OCCURS 10 TIMES.
03 ST-1 PIC 9(3).
03 ST-2 PIC 9.
03 ST-SIGN PIC X(3).
03 ST-BD OCCURS 5 TIMES PIC S9(2); COMP.
01 LITERAL-TABLE.
02 LIT-TAB OCCURS 10 TIMES.
03 LT OCCURS 10 TIMES PIC X(64).
01 WORK-BUFFER1.
02 WB1 OCCURS 7 TIMES PIC X.
01 WORK-BUFFER2.
02 WB2 OCCURS 3 TIMES PIC 9.
01 IN-NAME.
02 I-N PIC X(3).
02 FILLER PIC X(3).
01 OUT-NAME.
02 O-N PIC X(3).
02 FILLER PIC X(3).
01 FORMAT-HOLD.
02 PROMPT-TABLE OCCURS 150 TIMES PIC X(20).
02 LENGTH-OF-FIELD OCCURS 150 TIMES PIC 9(3).
02 NUMBER-FIELDS PIC 9(3).
02 NA.
03 NAMES OCCURS 28 TIMES PIC X(6).
02 VAL-ID PIC X.
02 AC-DAT PIC X.
02 SPC PIC X.
02 FILLER PIC X(3).
02 IND-BLOCK-FACT PIC 9(3).
02 OVER-LAY-PAGE PIC 9(3).
02 BLOCKING-FACTOR PIC 9(3).
02 PRI.
03 PRIV OCCURS 28 TIMES PIC 9(3).
02 PRG-FLG PIC X.
02 FILLER PIC X(2).
02 VERSION-NUMBER PIC 9(3).
02 NUM-CHARS PIC 9(4).
02 POS-KEY PIC 99.
02 NUM-PAGES PIC 9(3).
02 TOP-LINE OCCURS 50 TIMES PIC 9(3).
02 DECIMAL-POSIT OCCURS 150 TIMES PIC 9.
01 MONTHS PIC X(36); VALUE "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC".
01 MONTH-ARRAY REDEFINES MONTHS.
02 M-BUFF OCCURS 12 TIMES PIC X(3).
01 P-TODAY.
02 TOD.
03 YR PIC 99.
03 MO PIC 99.
03 DA PIC 99.
02 FILLER PIC X(6).
01 SOURCE-NAME.
02 S-NAME.
03 SN2 PIC X(3); VALUE "PRG".
03 SN1 PIC X(3).
02 FILLER PIC X(3); VALUE "CBL".
01 FORMAT-NAME.
02 FN1.
03 FN1A PIC X(3).
03 FN1B PIC X(3).
02 FN2 PIC X(3); VALUE "FMT".
01 A2.
02 FILLER PIC X(15); VALUE "PROGRAM-ID. PRG".
02 A2-ANS1 PIC X(3).
02 FILLER PIC X(21); VALUE ", VERSION-5B, EDIT-1.".
01 A3.
02 FILLER PIC X(8); VALUE "AUTHOR. ".
02 A3-ANS1 PIC X(25).
02 FILLER PIC X; VALUE ".".
01 A4.
02 FILLER PIC X(14); VALUE "DATE-WRITTEN.".
02 A4-ANS1 PIC 99.
02 FILLER PIC X; VALUE "-".
02 A4-ANS2 PIC X(3).
02 FILLER PIC X; VALUE "-".
02 A4-ANS3 PIC 99.
02 FILLER PIC X; VALUE ".".
01 A22.
02 FILLER PIC X(4); VALUE "FD ".
02 A22-ANS1 PIC X(8).
02 FILLER PIC X(18); VALUE "; RECORD CONTAINS ".
02 A22-ANS2 PIC 9(4).
02 FILLER PIC X(11); VALUE " CHARACTERS".
01 A23.
02 FILLER PIC X(24); VALUE " BLOCK CONTAINS".
02 A23-ANS1 PIC 9(4).
02 FILLER PIC X(9);VALUE " RECORDS".
01 A24.
02 FILLER PIC X(36); VALUE " VALUE OF IDENTIFICATION IS ".
02 FILLER PIC X; VALUE QUOTE.
02 A24-ANS1 PIC X(6).
02 FILLER PIC X(3); VALUE "IDX".
02 FILLER PIC X; VALUE QUOTE.
02 FILLER PIC X; VALUE ".".
01 02-DOT.
02 FILLER PIC X(7); VALUE " 02 ".
02 2DOT-SYM.
03 2D-PRE PIC Z(3).
03 2D-SYM PIC X(3).
03 2D-SUF PIC Z.
02 2D-RED PIC X(16); VALUE ".".
01 02-PIC.
02 FILLER PIC X(7); VALUE " 02 ".
02 2PIC-SYM.
03 2P-PRE PIC Z(3).
03 2P-SYM PIC X(3).
03 2P-SUF PIC Z.
02 2P-RED PIC X(15); VALUE SPACES.
02 FILLER PIC X(4); VALUE "PIC ".
02 2P-XN PIC X.
02 FILLER PIC X; VALUE "(".
02 2P-FSIZE PIC 9(2).
02 FILLER PIC X(2); VALUE ").".
01 03-PIC.
02 FILLER PIC X(10); VALUE " 03 ".
02 3PIC-SYM.
03 3P-PRE PIC Z(3).
03 3P-SYM PIC X(3).
03 3P-SUF PIC Z.
02 FILLER PIC X(12); VALUE SPACES.
02 FILLER PIC X(4); VALUE "PIC ".
02 3P-XN PIC X.
02 FILLER PIC X; VALUE "(".
02 3P-FSIZE PIC 9(2).
02 FILLER PIC X(2); VALUE ").".
01 FILL-REC.
02 FILLER PIC X(29); VALUE " 02 FILLER".
02 FILLER PIC X(6); VALUE "PIC X(".
02 FR-FSIZE PIC 9(4).
02 FILLER PIC X(2); VALUE ").".
01 SKEY-LINE.
02 FILLER PIC X(4); VALUE "77 ".
02 SK-1 PIC X(5).
02 FILLER PIC X(20); VALUE SPACES.
02 FILLER PIC X(6); VALUE "PIC X(".
02 SK-2 PIC 9(2).
02 FILLER PIC X(2); VALUE ").".
01 FIN-LINE.
02 FILLER PIC X(29); VALUE "77 FIN".
02 FILLER PIC X(16); VALUE "PIC X(6); VALUE ".
02 FILLER PIC X; VALUE QUOTE.
02 FL-NAME PIC X(6).
02 FILLER PIC X; VALUE QUOTE.
02 FILLER PIC X; VALUE ".".
01 VN.
02 FILLER PIC X(29); VALUE "77 VERS-NUM".
02 FILLER PIC X(16); VALUE "PIC 9(3); VALUE ".
02 VN-1 PIC 9(3).
02 FILLER PIC X; VALUE ".".
01 IF-REC1.
02 FILLER PIC X(3); VALUE "IF ".
02 IR1-1 PIC Z(3).
02 FILLER PIC X(3); VALUE "INN".
02 IR1-2 PIC Z.
02 FILLER PIC X; VALUE SPACE.
02 IR1-3 PIC X(3).
02 FILLER PIC X; VALUE SPACE.
02 IR1-4 PIC X(34).
02 FILLER PIC X(7); VALUE " GO TO ".
02 IR1-5 PIC X(11).
02 FILLER PIC X; VALUE ".".
01 TAG-NAME.
02 FILLER PIC X(9); VALUE "NEXT-TEST".
02 IN-1 PIC Z.
01 WORK-BUFFER3.
02 WB3 OCCURS 92 TIMES PIC X.
01 WORK-BUFFER4.
02 WB4 OCCURS 92 TIMES PIC X.
01 WORK-BUFFER5.
02 WB5 OCCURS 34 TIMES PIC X.
01 NEXT-TEST.
02 NEXT-TEST1.
03 FILLER PIC X(9); VALUE "NEXT-TEST".
03 NT-NUM PIC 99; VALUE 0.
02 FILLER PIC X; VALUE ".".
01 VAR-SYM.
02 VAR-SYM-PRE PIC ZZ.
02 FILLER PIC X(3); VALUE "VAR".
02 VAR-SYM-SUF PIC Z.
01 77-VAR.
02 FILLER PIC X(4); VALUE "77 ".
02 77-V1 PIC X(6).
02 FILLER PIC X(19); VALUE SPACES.
02 FILLER PIC X(4); VALUE "PIC ".
02 77-V2 PIC X.
02 FILLER PIC X; VALUE "(".
02 77-V3 PIC 9(3).
02 FILLER PIC X(2); VALUE ").".
01 DISP-LINE.
02 FILLER PIC X(8); VALUE "DISPLAY ".
02 DIS-L-1 PIC X(64).
02 FILLER PIC X(20); VALUE "; WITH NO ADVANCING.".
01 ACCEPT-LINE.
02 FILLER PIC X(11); VALUE " ACCEPT ".
02 ACC-L-1 PIC X(6).
02 FILLER PIC X; VALUE ".".
01 ASTER.
02 FILLER PIC X; VALUE QUOTE.
02 FILLER PIC X; VALUE "*".
02 FILLER PIC X; VALUE QUOTE.
01 DIS-LIN.
02 FILLER PIC X(8); VALUE "DISPLAY " .
02 FILLER PIC X; VALUE QUOTE.
02 DL-1 PIC X(70).
02 FILLER PIC X; VALUE QUOTE.
02 FILLER PIC X; VALUE ".".
01 DIS-LIN-A.
02 FILLER PIC X(12); VALUE " DISPLAY ".
02 FILLER PIC X; VALUE QUOTE.
02 FILLER PIC X; VALUE SPACE.
02 FILLER PIC X; VALUE QUOTE.
02 FILLER PIC X; VALUE ".".
01 FILE-DESC.
02 FD1 PIC X(6).
02 FILLER PIC X(4); VALUE " TO ".
02 FD2 PIC X(6).
02 FILLER PIC X(25); VALUE ". CRITERIA IS AS FOLLOWS:".
01 DIS-LIN-B.
02 FILLER PIC X(12); VALUE " DISPLAY ".
02 FILLER PIC X; VALUE QUOTE.
02 DLB-1.
03 DLB-1A PIC X(3).
03 DLB-1B PIC X(21).
03 DLB-1C PIC X(4).
02 DLB-2 PIC X(32).
02 FILLER PIC X; VALUE QUOTE.
02 FILLER PIC X; VALUE ".".
01 DIS-LIN-C.
02 FILLER PIC X(12); VALUE " DISPLAY ".
02 FILLER PIC X; VALUE QUOTE.
02 FILLER PIC X(33); VALUE SPACES.
02 DLC-1 PIC X(3).
02 FILLER PIC X; VALUE QUOTE.
02 FILLER PIC X; VALUE ".".
01 DIS-LIN-D.
02 FILLER PIC X(12); VALUE " DISPLAY ".
02 FILLER PIC X; VALUE QUOTE.
02 DLD-1.
03 DLD-1A PIC X(3).
03 DLD-1B PIC X(21).
03 DLD-1C PIC X(4).
02 FILLER PIC X; VALUE QUOTE.
02 FILLER PIC X; VALUE SPACE.
02 DLD-2 PIC X(7).
02 FILLER PIC X; VALUE ".".
01 DIS-DASH.
02 FILLER PIC X(12); VALUE " DISPLAY ".
02 FILLER PIC X; VALUE QUOTE.
02 FILLER PIC X(12); VALUE SPACES.
02 FILLER PIC X(36); VALUE "------------------------------------".
02 FILLER PIC X; VALUE QUOTE.
02 FILLER PIC X; VALUE ".".
PROCEDURE DIVISION.
OPENING SECTION.
OPENERS.
ENTER MACRO NAMDAT.
DISPLAY "TYPE NAME OF FORMAT FILE: "; WITH NO ADVANCING.
ACCEPT FN1.
IF FN1A NOT = "DBM" DISPLAY "INVALID FORMAT NAME", GO TO OPENERS.
OPEN INPUT FORMAT-FILE.
READ FORMAT-FILE; AT END STOP RUN.
MOVE FORMAT-REC TO FORMAT-HOLD.
IF SPC = "(" MOVE 0 TO REC-TYPE, ENTER MACRO UNSSCR USING REC-TYPE, FORMAT-HOLD.
CLOSE FORMAT-FILE.
MOVE PRIV(1) TO PRIV-1-HOLD.
ENTER MACRO NOECHO USING PROMPT-IND, BREAK-1, PRI, USER-PASSWORD.
MOVE ZERO TO PROMPT-IND.
LOOP1.
SET PROMPT-IND UP BY 1.
IF PROMPT-IND > 28 GO TO BREAK-1.
IF USER-PASSWORD = NAMES(PROMPT-IND) GO TO BREAK-1.
GO TO LOOP1.
BREAK-1.
IF PROMPT-IND > 28 DISPLAY "CANNOT ACCESS THIS DATA", STOP RUN.
DISPLAY " ".
IF PRIV(PROMPT-IND) < 3 DISPLAY "NO PRIVILEGES TO CREATE PURGE", STOP RUN.
DISPLAY "CSS PURGE PROGRAM GENERATOR(V05-13)".
DISPLAY " ".
MOVE FN1B TO SN1.
OPEN OUTPUT SOURCE-FILE.
FN-LOOP.
DISPLAY "PURGE INPUT FILE NAME: "; WITH NO ADVANCING.
ACCEPT IN-NAME.
IF I-N = SPACES MOVE FN1 TO IN-NAME, OUT-NAME
,MOVE "PRG" TO O-N, GO TO CONT-1.
IF I-N = "DBM" MOVE IN-NAME TO OUT-NAME
,MOVE "PRG" TO O-N, GO TO CONT-1.
IF I-N = "PRG" MOVE IN-NAME TO OUT-NAME
,MOVE "DBM" TO O-N, GO TO CONT-1.
DISPLAY "INVALID FILE NAME".
GO TO FN-LOOP.
CONT-1.
MOVE ZERO TO SYM-IDX, BD-IDX, LT-IDX.
LOOP-2.
DISPLAY "ENTER PURGE FIELD SYMBOL: "; WITH NO ADVANCING.
ACCEPT WORK-BUFFER1.
IF WORK-BUFFER1 = SPACES GO TO GEN-CODE.
IF SYM-IDX NOT = 1 GO TO LOOP-2-CONT.
IF WORK-BUFFER1 NOT = "OR" GO TO LOOP-2-CONT.
MOVE "OR" TO COND.
GO TO LOOP-2.
LOOP-2-CONT.
EXAMINE WORK-BUFFER1 TALLYING UNTIL FIRST "I".
IF TALLY = 7 PERFORM BAD-SYM, GO TO LOOP-2.
MOVE ZEROES TO WORK-BUFFER2.
MOVE 3 TO WB2-IDX.
LOOP-3.
IF TALLY < 1 GO TO BREAK-3.
IF WB1(TALLY) NOT NUMERIC GO TO BREAK-3.
MOVE WB1(TALLY) TO WB2(WB2-IDX).
SUBTRACT 1 FROM TALLY, WB2-IDX.
IF WB2-IDX < 1 GO TO BREAK-3.
GO TO LOOP-3.
BREAK-3.
MOVE WORK-BUFFER2 TO PROMPT-IND.
IF PROMPT-IND < 1 PERFORM BAD-SYM, GO TO LOOP-2.
IF PROMPT-IND > NUMBER-FIELDS PERFORM BAD-SYM, GO TO LOOP-2.
EXAMINE WORK-BUFFER1 TALLYING ALL "N".
IF TALLY NOT = 2 PERFORM BAD-SYM, GO TO LOOP-2.
SET SYM-IDX UP BY 1.
IF SYM-IDX > 10 GO TO GEN-CODE.
MOVE PROMPT-IND TO ST-1(SYM-IDX).
DISPLAY PROMPT-TABLE(PROMPT-IND) " : " LENGTH-OF-FIELD(PROMPT-IND).
EXAMINE WORK-BUFFER1 TALLYING UNTIL FIRST "N".
SET TALLY UP BY 3.
IF TALLY > 7 PERFORM BAD-SYM, MOVE 0 TO ST-1(SYM-IDX)
,SET SYM-IDX DOWN BY 1, GO TO LOOP-2.
IF WB1(TALLY) NOT NUMERIC GO TO GET-LITERALS.
IF WB1(TALLY) < 6 GO TO BREAK-4A.
IF WB1(TALLY) > 0 GO TO BREAK-4A.
PERFORM CLR-RESET.
GO TO LOOP-2.
BREAK-4A.
MOVE WB1(TALLY) TO ST-2(SYM-IDX).
MOVE ZERO TO BD-IDX, BD-SUM, LT-IDX.
DISPLAY " ".
LOOP-4.
DISPLAY "SUB FIELD SIZE EXTRA <CR> WHEN THROUGH: "; WITH NO ADVANCING.
ACCEPT LT-IDX.
IF LT-IDX NOT = 0 GO TO LOOP-4A.
MOVE ST-2(SYM-IDX) TO TALLY.
IF ST-BD(SYM-IDX,TALLY) > 0 GO TO GET-LITERALS.
DISPLAY "INCORRECT FIELD BREAKDOWN FOR SPECIFIED SYMBOL".
PERFORM CLR-RESET.
GO TO LOOP-2.
LOOP-4A.
IF LT-IDX > LENGTH-OF-FIELD(PROMPT-IND) PERFORM BD-ERR, GO TO LOOP-4.
COMPUTE BD-SUM = BD-SUM + LT-IDX.
IF BD-SUM > LENGTH-OF-FIELD(PROMPT-IND) PERFORM BD-ERR, GO TO LOOP-4.
SET BD-IDX UP BY 1.
IF BD-IDX > 5 DISPLAY "ONLY 5 SUB FIELDS ALLOWED", PERFORM BD-ERR, GO TO LOOP-4.
MOVE LT-IDX TO ST-BD(SYM-IDX, BD-IDX).
GO TO LOOP-4.
GET-LITERALS.
DISPLAY "PURGE IF ITS (=, NOT, >, <): "; WITH NO ADVANCING.
ACCEPT ST-SIGN(SYM-IDX).
IF ST-SIGN(SYM-IDX) = "=" OR "NOT" OR ">" OR "<" GO TO BREAK-5.
MOVE SPACES TO ST-SIGN(SYM-IDX).
DISPLAY "INVALID SIGN".
GO TO GET-LITERALS.
BREAK-5.
MOVE ZERO TO LT-IDX.
LOOP-5.
DISPLAY "LITERALS: "; WITH NO ADVANCING.
ACCEPT ANS2.
IF ANS2 = SPACES GO TO LOOP-2.
IF ANS2 = "RESET" PERFORM CLR-RESET, GO TO LOOP-2.
SET LT-IDX UP BY 1.
IF LT-IDX > 10 DISPLAY "ONLY 10 LITERALS ALLOWED", GO TO LOOP-2.
MOVE ANS2 TO LT(SYM-IDX, LT-IDX).
GO TO LOOP-5.
GEN-CODE.
WRITE SOURCE-RECORD FROM A1.
MOVE SN1 TO A2-ANS1.
WRITE SOURCE-RECORD FROM A2.
LOOP-6.
DISPLAY "TYPE IN YOUR NAME: "; WITH NO ADVANCING.
ACCEPT A3-ANS1.
IF A3-ANS1 = SPACES GO TO LOOP-6.
DISPLAY " CREATING " S-NAME ".CBL ... "; WITH NO ADVANCING.
WRITE SOURCE-RECORD FROM A3.
MOVE TODAY TO P-TODAY.
MOVE DA TO A4-ANS1.
MOVE M-BUFF(MO) TO A4-ANS2.
MOVE YR TO A4-ANS3.
WRITE SOURCE-RECORD FROM A4.
WRITE SOURCE-RECORD FROM A5 BEFORE ADVANCING 2 LINES.
WRITE SOURCE-RECORD FROM A6.
WRITE SOURCE-RECORD FROM A7.
WRITE SOURCE-RECORD FROM A8 BEFORE ADVANCING 2 LINES.
WRITE SOURCE-RECORD FROM A9 BEFORE ADVANCING 2 LINES.
WRITE SOURCE-RECORD FROM A10.
WRITE SOURCE-RECORD FROM A11.
WRITE SOURCE-RECORD FROM A12.
WRITE SOURCE-RECORD FROM A13 BEFORE ADVANCING 2 LINES.
WRITE SOURCE-RECORD FROM A14.
WRITE SOURCE-RECORD FROM A11.
WRITE SOURCE-RECORD FROM A15.
WRITE SOURCE-RECORD FROM A16 BEFORE ADVANCING 3 LINES.
WRITE SOURCE-RECORD FROM A18.
WRITE SOURCE-RECORD FROM A19 BEFORE ADVANCING 2 LINES.
WRITE SOURCE-RECORD FROM A20 BEFORE ADVANCING 2 LINES.
WRITE SOURCE-RECORD FROM A21 BEFORE ADVANCING 3 LINES.
MOVE "FILE-IN" TO A22-ANS1.
MOVE NUM-CHARS TO A22-ANS2.
WRITE SOURCE-RECORD FROM A22.
MOVE BLOCKING-FACTOR TO A23-ANS1.
WRITE SOURCE-RECORD FROM A23.
MOVE IN-NAME TO A24-ANS1.
WRITE SOURCE-RECORD FROM A24 BEFORE ADVANCING 2 LINES.
WRITE SOURCE-RECORD FROM A25.
MOVE ZERO TO LINE-COUNT, PROMPT-IND, BD-SUM, CHAR-COUNT.
LOOP-7.
SET PROMPT-IND UP BY 1.
IF PROMPT-IND > 150 GO TO BREAK-6.
IF LENGTH-OF-FIELD(PROMPT-IND) = 0 GO TO BREAK-6.
IF PROMPT-IND NOT = POS-KEY GO TO NOT-KEY-1.
PERFORM FILL-OUT.
MOVE "IRK" TO 2DOT-SYM, 2PIC-SYM.
MOVE LENGTH-OF-FIELD(PROMPT-IND) TO 2P-FSIZE.
MOVE "X" TO 2P-XN, 3P-XN.
WRITE SOURCE-RECORD FROM 02-PIC.
PERFORM CHECK-TAB THRU CT-DONE.
IF SYM-IDX = 0, GO TO CLR-RED.
PERFORM CLR-REC.
MOVE PROMPT-IND TO 2D-PRE, 2P-PRE, 3P-PRE.
MOVE " REDEFINES IRK." TO 2D-RED.
MOVE " REDEFINES IRK" TO 2P-RED.
IF ST-2(SYM-IDX) = 0 WRITE SOURCE-RECORD FROM 02-PIC, GO TO CLR-RED.
WRITE SOURCE-RECORD FROM 02-DOT.
IF ST-SIGN(SYM-IDX) = ">" OR "<" MOVE "9" TO 2P-XN, 3P-XN.
PERFORM 03-MOVE VARYING BD-IDX FROM 1 BY 1 UNTIL BD-IDX > 5.
CLR-RED.
MOVE SPACES TO 2P-RED.
MOVE "." TO 2D-RED.
PERFORM CLR-REC.
GO TO LOOP-7.
NOT-KEY-1.
PERFORM CHECK-TAB THRU CT-DONE.
IF SYM-IDX NOT = 0 GO TO FD-SYM.
COMPUTE CHAR-COUNT = CHAR-COUNT + LENGTH-OF-FIELD(PROMPT-IND).
GO TO LOOP-7.
FD-SYM.
PERFORM FILL-OUT.
PERFORM CLR-REC.
MOVE PROMPT-IND TO 2D-PRE, 2P-PRE, 3P-PRE.
IF ST-SIGN(SYM-IDX) = ">" OR "<" MOVE "9" TO 2P-XN, 3P-XN.
IF ST-2(SYM-IDX) NOT = 0 GO TO FD-03.
MOVE LENGTH-OF-FIELD(PROMPT-IND) TO 2P-FSIZE.
WRITE SOURCE-RECORD FROM 02-PIC.
GO TO LOOP-7.
FD-03.
WRITE SOURCE-RECORD FROM 02-DOT.
MOVE PROMPT-IND TO 3P-PRE.
PERFORM 03-MOVE VARYING BD-IDX FROM 1 BY 1 UNTIL BD-IDX > 5.
GO TO LOOP-7.
BREAK-6.
PERFORM FILL-OUT.
PERFORM SPACE-IT.
MOVE "FILE-OUT" TO A22-ANS1.
WRITE SOURCE-RECORD FROM A22.
WRITE SOURCE-RECORD FROM A23.
MOVE OUT-NAME TO A24-ANS1.
WRITE SOURCE-RECORD FROM A24.
PERFORM SPACE-IT.
MOVE "01 REC-OUT." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
PERFORM TOTAL-UP VARYING PROMPT-IND FROM 1 BY 1 UNTIL PROMPT-IND = POS-KEY.
PERFORM CLR-REC.
IF CHAR-COUNT NOT = ZERO PERFORM FILL-OUT.
MOVE "ORK" TO 2PIC-SYM.
MOVE LENGTH-OF-FIELD(POS-KEY) TO 2P-FSIZE.
WRITE SOURCE-RECORD FROM 02-PIC.
COMPUTE PROMPT-IND = POS-KEY + 1.
PERFORM TOTAL-UP VARYING PROMPT-IND FROM PROMPT-IND BY 1 UNTIL PROMPT-IND > 150.
PERFORM FILL-OUT.
PERFORM SPACE-IT 2 TIMES.
MOVE "WORKING-STORAGE SECTION." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
MOVE "ISKEY" TO SK-1.
MOVE LENGTH-OF-FIELD(POS-KEY) TO SK-2.
WRITE SOURCE-RECORD FROM SKEY-LINE.
MOVE "OSKEY" TO SK-1.
WRITE SOURCE-RECORD FROM SKEY-LINE.
MOVE FN1 TO FL-NAME.
WRITE SOURCE-RECORD FROM FIN-LINE.
MOVE VERSION-NUMBER TO VN-1.
WRITE SOURCE-RECORD FROM VN.
MOVE "77 IN-CNT INDEX." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
MOVE "77 ELG-CNT INDEX." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
MOVE "77 PRG-CNT INDEX." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
MOVE "77 LINE-COUNT PIC S9(3); COMP." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
MOVE ZERO TO SYM-IDX.
LOOP-7A.
SET SYM-IDX UP BY 1.
IF SYM-IDX > 10 GO TO CONT-7A.
IF ST-1(SYM-IDX) = 0 GO TO CONT-7A.
MOVE SYM-IDX TO VAR-SYM-PRE.
MOVE "X" TO 77-V2
IF ST-SIGN(SYM-IDX) = "<" OR ">" MOVE "9" TO 77-V2.
MOVE ZERO TO LT-IDX.
LOOP-7A-1.
SET LT-IDX UP BY 1.
IF LT-IDX > 10 GO TO LOOP-7A.
IF LT(SYM-IDX, LT-IDX) = SPACES GO TO LOOP-7A.
EXAMINE LT(SYM-IDX,LT-IDX) TALLYING ALL "/".
IF TALLY NOT = 2 GO TO LOOP-7A-1.
MOVE LT-IDX TO VAR-SYM-SUF.
MOVE VAR-SYM TO 77-V1.
MOVE ST-1(SYM-IDX) TO PROMPT-IND.
MOVE LENGTH-OF-FIELD(PROMPT-IND) TO 77-V3.
IF ST-2(SYM-IDX) NOT = 0 MOVE ST-2(SYM-IDX) TO BD-IDX
,MOVE ST-BD(SYM-IDX,BD-IDX) TO 77-V3.
WRITE SOURCE-RECORD FROM 77-VAR.
GO TO LOOP-7A-1.
CONT-7A.
PERFORM SPACE-IT.
MOVE "01 PROMPT-INFO COPY WSFMT1." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
PERFORM SPACE-IT.
MOVE "PROCEDURE DIVISION." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
MOVE "OPENING SECTION." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
MOVE "OPENERS. COPY PRCHKPW." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
MOVE "PRIV-CHK. COPY PRCHKPV3." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
MOVE ZERO TO SYM-IDX.
LOOP-7B.
SET SYM-IDX UP BY 1.
IF SYM-IDX > 10 GO TO CONT-7B.
IF ST-1(SYM-IDX) = 0 GO TO CONT-7B.
MOVE ZERO TO LT-IDX.
MOVE SYM-IDX TO VAR-SYM-PRE.
LOOP-7B-1.
SET LT-IDX UP BY 1.
IF LT-IDX > 10 GO TO LOOP-7B.
EXAMINE LT(SYM-IDX, LT-IDX) TALLYING ALL "/".
IF TALLY NOT = 2 GO TO LOOP-7B-1.
MOVE LT(SYM-IDX,LT-IDX) TO DIS-L-1.
IF DIS-L-1 = "//" MOVE ASTER TO DIS-L-1.
EXAMINE DIS-L-1 REPLACING ALL "/" BY QUOTE.
MOVE DISP-LINE TO WORK-BUFFER3.
PERFORM CLEAN-LINE THRU CL-EXIT.
WRITE SOURCE-RECORD FROM WORK-BUFFER4.
MOVE LT-IDX TO VAR-SYM-SUF.
MOVE VAR-SYM TO ACC-L-1.
WRITE SOURCE-RECORD FROM ACCEPT-LINE.
GO TO LOOP-7B-1.
CONT-7B.
WRITE SOURCE-RECORD FROM DIS-LIN-A.
MOVE "UPON COMPLETION OF THIS PROGRAM, ALL RECORDS WHICH" TO DL-1.
MOVE DIS-LIN TO WORK-BUFFER3.
PERFORM CLEAN-LINE THRU CL-EXIT.
WRITE SOURCE-RECORD FROM WORK-BUFFER4.
MOVE "SATISFY THE PURGE CONDITIONS WILL BE MOVED FROM" TO DL-1.
MOVE DIS-LIN TO WORK-BUFFER3.
PERFORM CLEAN-LINE THRU CL-EXIT.
WRITE SOURCE-RECORD FROM WORK-BUFFER4.
MOVE IN-NAME TO FD1.
MOVE OUT-NAME TO FD2.
MOVE FILE-DESC TO DL-1.
MOVE DIS-LIN TO WORK-BUFFER3.
PERFORM CLEAN-LINE THRU CL-EXIT.
WRITE SOURCE-RECORD FROM WORK-BUFFER4.
WRITE SOURCE-RECORD FROM DIS-LIN-A.
WRITE SOURCE-RECORD FROM DIS-DASH.
WRITE SOURCE-RECORD FROM DIS-LIN-A.
MOVE ZERO TO SYM-IDX.
LOOP-7C.
SET SYM-IDX UP BY 1.
IF SYM-IDX > 10 GO TO CONT-7C.
IF ST-1(SYM-IDX) = ZERO GO TO CONT-7C.
MOVE "IF" TO DLB-1A, DLD-1A.
MOVE ST-1(SYM-IDX) TO PROMPT-IND.
MOVE PROMPT-TABLE(PROMPT-IND) TO DLB-1B, DLD-1B.
MOVE ST-SIGN(SYM-IDX) TO DLB-1C, DLD-1C.
MOVE COND TO DLC-1.
MOVE ZERO TO LT-IDX.
LOOP-7D.
SET LT-IDX UP BY 1.
IF LT-IDX > 10 GO TO BREAK-7D.
IF LT(SYM-IDX,LT-IDX) = SPACES GO TO BREAK-7D.
EXAMINE LT(SYM-IDX,LT-IDX) TALLYING ALL "/".
IF TALLY = 2 GO TO BREAK-7D-1.
MOVE LT(SYM-IDX,LT-IDX) TO DLB-2.
WRITE SOURCE-RECORD FROM DIS-LIN-B.
GO TO BREAK-7D-2.
BREAK-7D-1.
MOVE SYM-IDX TO VAR-SYM-PRE.
MOVE LT-IDX TO VAR-SYM-SUF.
MOVE VAR-SYM TO DLD-2.
WRITE SOURCE-RECORD FROM DIS-LIN-D.
BREAK-7D-2.
MOVE SPACES TO DLB-1, DLD-1.
GO TO LOOP-7D.
BREAK-7D.
PERFORM CHECK-LAST THRU CLA-EXIT.
IF WB1-IDX NOT = 0 WRITE SOURCE-RECORD FROM DIS-LIN-C.
GO TO LOOP-7C.
CONT-7C.
WRITE SOURCE-RECORD FROM DIS-LIN-A.
WRITE SOURCE-RECORD FROM DIS-DASH.
WRITE SOURCE-RECORD FROM DIS-LIN-A.
MOVE " COPY PRDISGO." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
PERFORM SPACE-IT.
MOVE "LOOP-2." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
MOVE " READ FILE-IN; INVALID KEY GO TO ALL-DONE." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
MOVE " SET IN-CNT UP BY 1." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
MOVE ZERO TO SYM-IDX, LT-IDX.
LOOP-8.
SET SYM-IDX UP BY 1.
IF SYM-IDX > 10 GO TO OUT-CONT-1.
IF ST-1(SYM-IDX) = 0 GO TO OUT-CONT-1.
MOVE ST-1(SYM-IDX) TO IR1-1.
MOVE ST-2(SYM-IDX) TO IR1-2.
MOVE ST-SIGN(SYM-IDX) TO IR1-3.
IF ST-SIGN(SYM-IDX) NOT = "NOT" GO TO NOT-NOT-1.
MOVE "=" TO IR1-3.
IF COND = "AND" MOVE "LOOP-2" TO IR1-5, PERFORM DMP-LITS THRU DL-EXIT
,GO TO LOOP-8.
ADD 1 TO NT-NUM.
MOVE NEXT-TEST1 TO IR1-5.
PERFORM CHECK-LAST THRU CLA-EXIT.
IF WB1-IDX = 0, MOVE "LOOP-2" TO IR1-5, PERFORM DMP-LITS THRU DL-EXIT
,GO TO LOOP-8.
PERFORM DMP-LITS THRU DL-EXIT.
MOVE " GO TO CONT-1." TO SOURCE-RECORD.
WRITE SOURCE-RECORD BEFORE ADVANCING 2 LINES.
WRITE SOURCE-RECORD FROM NEXT-TEST.
GO TO LOOP-8.
NOT-NOT-1.
IF COND = "AND" GO TO ITS-AND.
MOVE "CONT-1" TO IR1-5.
PERFORM DMP-LITS THRU DL-EXIT.
PERFORM CHECK-LAST THRU CLA-EXIT.
IF WB1-IDX = 0 MOVE " GO TO LOOP-2." TO SOURCE-RECORD
,WRITE SOURCE-RECORD.
GO TO LOOP-8.
ITS-AND.
ADD 1 TO NT-NUM.
MOVE NEXT-TEST1 TO IR1-5.
PERFORM CHECK-LAST THRU CLA-EXIT.
IF WB1-IDX = 0 MOVE "CONT-1" TO IR1-5.
PERFORM DMP-LITS THRU DL-EXIT.
MOVE " GO TO LOOP-2." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
PERFORM CHECK-LAST THRU CLA-EXIT.
IF WB1-IDX NOT = 0 WRITE SOURCE-RECORD FROM NEXT-TEST.
GO TO LOOP-8.
OUT-CONT-1.
PERFORM SPACE-IT.
MOVE "CONT-1. COPY PRPRG." TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
IF PRG-FLG = "Y" GO TO ALL-DONE.
MOVE PRIV-1-HOLD TO PRIV(1).
MOVE "Y" TO PRG-FLG.
OPEN OUTPUT FORMAT-FILE.
MOVE FORMAT-HOLD TO FORMAT-REC.
WRITE FORMAT-REC.
CLOSE FORMAT-FILE.
ALL-DONE.
STOP RUN.
BAD-SYM.
DISPLAY "INVALID SYMBOL " WORK-BUFFER1.
BD-ERR.
DISPLAY "SUB FIELD SIZE ERROR, RE-INPUT BREAKDOWN".
MOVE ZERO TO BD-IDX, BD-SUM.
CHECK-TAB.
* THIS ROUTINE PROVIDES OFFSETS INTO THE SYMBOL TABLES USED TO ESTABLISH
* PURGE CRITERIA. TO USE CODE THE FOLLOWING: PERFORM CHECK-TAB THRU CT-DONE.
* IF SYM-IDX CONTAINS A NON ZERO VALUE UPON COMPLETION OF THIS ROUTINE, IT
* WILL BE THE SYMBOL TABLE POINTER.
*
MOVE ZERO TO SYM-IDX.
CT-LOOP-1.
SET SYM-IDX UP BY 1.
IF SYM-IDX > 10 GO TO CT-BREAK-1.
IF ST-1(SYM-IDX) = PROMPT-IND GO TO CT-DONE.
GO TO CT-LOOP-1.
CT-BREAK-1.
MOVE ZERO TO SYM-IDX.
CT-DONE.
EXIT.
FILL-OUT.
MOVE CHAR-COUNT TO FR-FSIZE.
IF CHAR-COUNT NOT = 0, WRITE SOURCE-RECORD FROM FILL-REC.
MOVE ZERO TO CHAR-COUNT.
CLR-REC.
MOVE SPACES TO 2DOT-SYM, 2PIC-SYM, 3PIC-SYM.
MOVE "INN" TO 2D-SYM, 2P-SYM, 3P-SYM.
MOVE "X" TO 2P-XN, 3P-XN.
SPACE-IT.
MOVE SPACES TO SOURCE-RECORD.
WRITE SOURCE-RECORD.
TOTAL-UP.
COMPUTE CHAR-COUNT = CHAR-COUNT + LENGTH-OF-FIELD(PROMPT-IND).
03-MOVE.
IF ST-BD(SYM-IDX,BD-IDX) NOT = 0 MOVE BD-IDX TO 3P-SUF
,MOVE ST-BD(SYM-IDX,BD-IDX) TO 3P-FSIZE
,WRITE SOURCE-RECORD FROM 03-PIC.
CLR-RESET.
MOVE SPACES TO SYM-TAB(SYM-IDX), LIT-TAB(SYM-IDX).
SET SYM-IDX DOWN BY 1.
* THIS ROUTINE WILL TAKE ANY 92 CHAR OR LESS ITEM PLACED INTO WORK-BUFFER3
* AND ELIMINATE ALL REDUNDANT SPACES. THE CLEAN LINE WILL BE FOUND IN
* WORK-BUFFER4 UPON EXIT. IT WILL ALWAYS INDENT CLEAN LINE 4 SPACES.
* TO EXECUTE "MOVE LINE INTO WORK-BUFFER3, PERFORM CLEAN-LINE THRU CL-EXIT.
*
CLEAN-LINE.
MOVE 0 TO WB1-IDX, SPA-CNT.
MOVE 4 TO WB2-IDX.
MOVE SPACES TO WORK-BUFFER4.
CL-LOOP-1.
SET WB1-IDX UP BY 1.
IF WB1-IDX > 92 GO TO CL-EXIT.
IF WB3(WB1-IDX) NOT = SPACE MOVE 0 TO SPA-CNT, GO TO NOT-SPA.
SET SPA-CNT UP BY 1.
IF SPA-CNT < 2 GO TO NOT-SPA.
GO TO CL-LOOP-1.
NOT-SPA.
SET WB2-IDX UP BY 1.
IF WB2-IDX > 92 GO TO CL-EXIT.
MOVE WB3(WB1-IDX) TO WB4(WB2-IDX).
GO TO CL-LOOP-1.
CL-EXIT. EXIT.
* THIS ROUTINE CLEANS + WRITES CONDITIONAL STATEMENTS FOUND
* IN IF-REC1 INTO THE SOURCE-FILE. IT TAKES LITERALS AS THE
* REMAINING PIECE TO CONDITIONAL FROM LT(SYM-IDX, LIT-IDX).
* TO EXECUTE "PERFORM DMP-LITS THRU DL-EXIT.".
DMP-LITS.
MOVE 0 TO LT-IDX.
DL-LOOP-1.
SET LT-IDX UP BY 1.
IF LT-IDX > 10 GO TO DL-EXIT.
IF LT(SYM-IDX,LT-IDX) = SPACES GO TO DL-EXIT.
IF LT(SYM-IDX,LT-IDX) = "BLANK" OR "BLANKS" MOVE "SPACES" TO IR1-4
,GO TO DL-CONT.
MOVE LT(SYM-IDX,LT-IDX) TO WORK-BUFFER4.
EXAMINE WORK-BUFFER4 TALLYING ALL "/".
IF TALLY NOT = 2 GO TO DL-NOT-VAR.
MOVE SYM-IDX TO VAR-SYM-PRE.
MOVE LT-IDX TO VAR-SYM-SUF.
MOVE VAR-SYM TO IR1-4.
GO TO DL-CONT.
DL-NOT-VAR.
IF ST-SIGN(SYM-IDX) = "<" OR ">" MOVE LT(SYM-IDX,LT-IDX) TO IR1-4
,GO TO DL-CONT.
MOVE SPACES TO WORK-BUFFER5.
IF ST-2(SYM-IDX) = 0 MOVE ST-1(SYM-IDX) TO PROMPT-IND
,MOVE LENGTH-OF-FIELD(PROMPT-IND) TO WB2-IDX, GO TO DLN-CONT-1.
MOVE ST-2(SYM-IDX) TO BD-IDX.
MOVE ST-BD(SYM-IDX,BD-IDX) TO WB2-IDX.
DLN-CONT-1.
SET WB2-IDX UP BY 1.
MOVE QUOTE TO WB4(WB2-IDX).
MOVE 0 TO WB1-IDX.
MOVE 1 TO WB2-IDX.
MOVE QUOTE TO WB5(1).
DLN-LOOP-1.
SET WB1-IDX UP BY 1.
SET WB2-IDX UP BY 1.
MOVE WB4(WB1-IDX) TO WB5(WB2-IDX).
IF WB4(WB1-IDX) NOT = QUOTE GO TO DLN-LOOP-1.
MOVE WORK-BUFFER5 TO IR1-4.
DL-CONT.
MOVE IF-REC1 TO WORK-BUFFER3.
PERFORM CLEAN-LINE THRU CL-EXIT.
WRITE SOURCE-RECORD FROM WORK-BUFFER4.
GO TO DL-LOOP-1.
DL-EXIT. EXIT.
* THIS ROUTINE DETERMINES IF NEXT ENTRY IS LAST ENTRY IN
* SYMBOL TABLE OR END OF TABLE. TO EXECUTE, "PERFORM CHECK-LAST
* THRU CLA-EXIT." IF WB1-IDX CONTAINS A ZERO, YOU ARE NOW ON THE LAST
* ENTRY IN THE TABLE.
CHECK-LAST.
MOVE 0 TO WB1-IDX.
COMPUTE WB2-IDX = SYM-IDX + 1.
IF WB2-IDX > 10 GO TO CL-EXIT.
MOVE ST-1(WB2-IDX) TO WB1-IDX.
CLA-EXIT. EXIT.