Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-11 - 43,50534/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.