Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-11 - 43,50534/csscng.cbl
There is 1 other file named csscng.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
PROGRAM-ID. CSSCNG, VERSION-5, EDIT-2.
AUTHOR. BOB CONLON.
DATE-WRITTEN. 19-NOV-75, MODIFIED 22-NOV-78.
DATE-COMPILED.
REMARKS. THIS PROGRAM WRITES A COBOL SOURCE WHICH WILL
	 REARRANGE AN EXISTING DATA BASE.

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-RECORD.
    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 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 FILLER			PIC X(3).
    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.

FD  SOURCE-FILE; VALUE OF IDENTIFICATION IS SOURCE-NAME.

01  SOURCE-RECORD; DISPLAY-7		PIC X(80).

WORKING-STORAGE SECTION.
77  Z-1			PIC S9(3); COMP.
77  USER-PASSWORD			PIC X(6).
77  PROMPT-IND				PIC S9(3); COMP.
77  IN-OP-NO			PIC S9(3); COMP.
77  OUT-OP-NO			PIC S9(3); COMP.
77  OUT-LA-NO			PIC S9(3); COMP.
77  EXTRA-IND			PIC S9(3); COMP.
77  OB-IND				PIC S9(3); COMP.
77  SAVE-01				PIC X(3).
77  DIS					PIC ZZZ.
77  A PIC X(24); VALUE "IDENTIFICATION DIVISION.".
77  C PIC X(19); VALUE "AUTHOR. BOB CONLON.".
77  E PIC X(15); VALUE "DATE-COMPILED.".
77  G PIC X(21); VALUE "ENVIRONMENT DIVISION.".
77  H PIC X(22); VALUE "CONFIGURATION SECTION.".
77  I PIC X(30); VALUE "SOURCE-COMPUTER. DECSYSTEM-10.".
77  J PIC X(30); VALUE "OBJECT-COMPUTER. DECSYSTEM-10.".
77  K PIC X(21); VALUE "INPUT-OUTPUT SECTION.".
77  L PIC X(13); VALUE "FILE-CONTROL.".
77  O PIC X(14); VALUE "DATA DIVISION.".
77  P PIC X(13); VALUE "FILE SECTION.".
77  R PIC X(11); VALUE "01  REC-IN.".
77  S-1 PIC X(60); VALUE "FD  FILE-OUT; VALUE OF IDENTIFICATION IS OUT-NAME.".
77  S-2 PIC X(23); VALUE "01  REC-OUT; DISPLAY-7.".
77  S PIC X(39); VALUE "FD  FORMAT-FILE             COPY FDFMT.".
77  T PIC X(24); VALUE "WORKING-STORAGE SECTION.".
77  W-1 PIC X(60); VALUE "01  OUT-NAME          COPY WSOUTNAM.".
77  W PIC X(17); VALUE "01  FILE-IN-NAME.".
77  Z PIC X(40); VALUE "01  PROMPT-INFO             COPY WSFMT1.".
77  A1 PIC X(19); VALUE "PROCEDURE DIVISION.".
77  A2 PIC X(16); VALUE "OPENING SECTION.".
77  A3 PIC X(32); VALUE "CHECK-IT.          COPY PRCHKPW.".
77  A4 PIC X(33); VALUE "PRIV-CHK.          COPY PRCHKPV3.".
77  A5 PIC X(60); VALUE "    PERFORM MOVE-PAGE VARYING I FROM 1 BY 1".
77  A7 PIC X(36); VALUE "77  I               PIC S9(3); COMP.".
77  A10 PIC X(21); VALUE "    PERFORM CLEAN-UP.".
77  NED-HLP				PIC A.
77  REC-TYPE			PIC S9(3); COMP.

01  PRG-NAM.
    02 FILLER PIC X(20); VALUE "77  PRG-NAM".
    02 FILLER PIC X(16); VALUE "PIC X(6); VALUE ".
    02 FILLER PIC X; VALUE QUOTE.
    02 PRG-NAME PIC X(6).
    02 FILLER PIC X; VALUE QUOTE.
    02 FILLER PIC X; VALUE ".".

01  A6.
    02 FILLER PIC X(16); VALUE "      UNTIL I > ".
    02 A6-NUM PIC Z(3).
    02 FILLER PIC X; VALUE ".".
01  A8.
    02 FILLER PIC X(22); VALUE "    02 PAGEI-2 OCCURS ".
    02 A8-NUM PIC Z(3).
    02 FILLER PIC X(7); VALUE " TIMES.".

01  A9.
    02 FILLER PIC X(22); VALUE "    02 PAGEO-2 OCCURS ".
    02 A9-NUM PIC Z(3).
    02 FILLER PIC X(7); VALUE " TIMES.".

01  DISPLAY-LINE.
    02 FILLER PIC X(12); VALUE "    DISPLAY ".
    02 FILLER PIC X; VALUE QUOTE.
    02 FILLER PIC X(20); VALUE "RECORDS CONVERTED:  ".
    02 FILLER PIC X; VALUE QUOTE.
    02 FILLER PIC X(10); VALUE " IN-COUNT.".

01  MOVE-LINE1.
    02 FILLER PIC X(9); VALUE "    MOVE ".
    02 FILLER PIC X; VALUE QUOTE.
    02 ML1-NAME PIC X(3).
    02 FILLER PIC X; VALUE QUOTE.
    02 FILLER PIC X(12); VALUE " TO OUTNAM2.".

01  B.
    02 FILLER PIC X(13); VALUE "PROGRAM-ID.".
    02 B-NAME			PIC X(6).
    02 FILLER			PIC X; VALUE ".".

01  D.
    02 FILLER PIC X(14); VALUE "DATE-WRITTEN.".
    02 D-DD		PIC Z9.
    02 FILLER		PIC X; VALUE "-".
    02 D-MON		PIC X(3).
    02 FILLER		PIC X; VALUE "-".
    02 D-YY		PIC 99.
    02 FILLER		PIC X; VALUE ".".

01  F.
    02 FILLER PIC X(21); VALUE "REMARKS.  THIS PROGRA".
    02 FILLER PIC X(21); VALUE "M WRITTEN BY CSSCNG.".

01  M.
    02 FILLER PIC X(18); VALUE "    SELECT FILE-IN".
    02 FILLER PIC X(19); VALUE SPACES.
    02 FILLER PIC X(13); VALUE "ASSIGN TO DSK".

01  M1.
    02 FILLER PIC X(37); VALUE SPACES.
    02 FILLER PIC X(22); VALUE "ACCESS MODE IS INDEXED".

01  M2.
    02 FILLER PIC X(37); VALUE SPACES.
    02 FILLER PIC X(23); VALUE "SYMBOLIC KEY IS SYM-KEY".

01  M3.
    02 FILLER PIC X(37); VALUE SPACES.
    02 FILLER PIC X(22); VALUE "RECORD KEY IS REC-KEY.".

01  N-1.
    02 FILLER PIC X(22); VALUE "    SELECT FILE-OUT".
    02 FILLER PIC X(15); VALUE SPACES.
    02 FILLER PIC X(14); VALUE "ASSIGN TO DSK.".

01  N.
    02 FILLER PIC X(22); VALUE "    SELECT FORMAT-FILE".
    02 FILLER PIC X(15); VALUE SPACES.
    02 FILLER PIC X(14); VALUE "ASSIGN TO DSK.".

01  Q.
    02 FILLER PIC X(29); VALUE "FD  FILE-IN; RECORD CONTAINS".
    02 Q-NUM			PIC Z(4).
    02 FILLER PIC X(11); VALUE " CHARACTERS".

01  Q1.
    02 FILLER PIC X(28); VALUE "             BLOCK CONTAINS".
    02 Q1-NUM			PIC Z(3).
    02 FILLER PIC X(8); VALUE " RECORDS".

01  Q2.
    02 FILLER PIC X(13); VALUE SPACES.
    02 FILLER PIC X(40); VALUE "VALUE OF IDENTIFICATION IS FILE-IN-NAME.".

01  U.
    02 FILLER PIC X(13); VALUE "77  VERS-NUM".
    02 FILLER PIC X(15); VALUE SPACES.
    02 FILLER PIC X(16); VALUE "PIC 9(3); VALUE ".
    02 U-NUM			PIC Z(3).
    02 FILLER PIC X; VALUE ".".

01  V.
    02 FILLER PIC X(27); VALUE "77  SYM-KEY".
    02 FILLER PIC X(4); VALUE "PIC ".
    02 SK-PIC				PIC XX.
    02 FILLER			PIC X; VALUE "(".
    02 V-NUM			PIC 9(3).
    02 FILLER PIC XX; VALUE ").".


01  X.
    02 FILLER PIC X(27); VALUE "    02 FIN".
    02 FILLER PIC X(16); VALUE "PIC X(6); VALUE ".
    02 FILLER PIC X; VALUE QUOTE.
    02 X-FNAME			PIC X(6).
    02 FILLER PIC X; VALUE QUOTE.
    02 FILLER PIC X; VALUE ".".

01  Y.
    02 FILLER PIC X(27); VALUE "    02 FILLER".
    02 FILLER PIC X(16); VALUE "PIC X(3); VALUE".
    02 FILLER PIC X; VALUE QUOTE.
    02 FILLER PIC X(3); VALUE "IDX".
    02 FILLER PIC X; VALUE QUOTE.
    02 FILLER PIC X; VALUE ".".

01  P-TODAY.
    02 TOD.
       03 P-YY		PIC 99.
       03 P-MM		PIC 99.
       03 P-DD		PIC 99.
    02 FILLER		PIC X(6).

01  MONTH-REGISTER.
    02 FILLER PIC X(36); VALUE "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC".

01  MONTH-ARRAY REDEFINES MONTH-REGISTER.
    02 M-BUFF OCCURS 12 TIMES PIC X(3).

01  IN-SYM.
    02 FILLER PIC X(7); VALUE "    02 ".
    02 IS-NUM1			PIC ZZ9.
    02 IS1A PIC X(3); VALUE "INN".
    02 IS-REDEF			PIC X(20).
    02 FILLER PIC X(4); VALUE "PIC".
    02 IS-PIC			PIC XX.
    02 FILLER			PIC X; VALUE "(".
    02 IS-NUM2			PIC 9(3).
    02 FILLER PIC XX; VALUE ").".

01  REC-K.
    02 FILLER PIC X(33); VALUE "    02 REC-KEY".
    02 FILLER PIC X(4); VALUE "PIC ".
    02 RK-PIC			PIC XX.
    02 FILLER PIC X; VALUE "(".
    02 RK-NUM			PIC 9(3).
    02 FILLER PIC XX; VALUE ").".

01  03-LINE.
    02 FILLER PIC X(10); VALUE "       03 ".
    02 03NUM1			PIC Z(3).
    02 03SYM PIC X(20); VALUE "INN".
    02 FILLER PIC X(6); VALUE "PIC X(".
    02 03NUM2			PIC 9(3).
    02 FILLER PIC XX; VALUE ").".

01  MOVE-LINE.
    02 FILLER PIC X(9); VALUE "    MOVE ".
    02 ML-NUM1		PIC ZZ9.
    02 FILLER PIC X(3); VALUE "INN".
    02 ML-IND1 PIC X(3); VALUE SPACES.
    02 FILLER PIC X(4); VALUE " TO ".
    02 ML-NUM2		PIC ZZ9.
    02 FILLER PIC X(3); VALUE "OUT".
    02 ML-IND2 PIC X(3); VALUE SPACES.
    02 FILLER PIC X; VALUE ".".


01  FORMAT-NAME.
    02 F-NAME.
       03 FNAME			PIC X(3).
       03 FNAME1		PIC X(3).
    02 FILLER			PIC X(3); VALUE "FMT".

01  SOURCE-NAME.
    02 SNAME.
       03 SNAME1			PIC X(3); VALUE "CNG".
       03 SNAME2			PIC X(3).
    02 SEXT				PIC X(3); VALUE "CBL".

01  OUTPUT-ARRAY.
    02 OUTPUT-BUFFER OCCURS 150 TIMES.
       03 INPUT-FIELD			PIC 9(3).
       03 OR-SIZE			PIC 9(3).

01  INPUT-RESP.
    02 IR			PIC X.
    02 FILLER			PIC XX.

01  Q-LINE.
    02 FILLER PIC X(3); VALUE SPACES.
    02 FILLER PIC X; VALUE QUOTE.
    02 FILLER PIC X; VALUE "N".
    02 FILLER PIC X; VALUE QUOTE.
    02 FILLER PIC X(4); VALUE "...".
    02 FILLER PIC X(41); VALUE "IN RESPONSE TO THE ASTERISK, N REPRESENTS".

PROCEDURE DIVISION.
OPENING SECTION.
CHECK-IT.
    ENTER MACRO NAMDAT.
    DISPLAY "TYPE NAME OF INPUT FORMAT FILE:  "; WITH NO ADVANCING.
    ACCEPT F-NAME.
    IF FNAME NOT = "DBM" DISPLAY "ILLEGAL FILE NAME", GO TO CHECK-IT.
    OPEN INPUT FORMAT-FILE.
    READ FORMAT-FILE; AT END STOP RUN.
    IF SPC = "(" MOVE 0 TO REC-TYPE, ENTER MACRO UNSSCR USING REC-TYPE, FORMAT-RECORD.
    ENTER MACRO NOECHO USING PROMPT-IND, BREAK-1, PRI, USER-PASSWORD.
    SET PROMPT-IND TO ZERO.

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.
    IF PRIV(PROMPT-IND) < 3 DISPLAY "NO PRIVILEGES TO RUN THIS PROGRAM"
    ,STOP RUN.
    DISPLAY " ".
    DISPLAY "CSS DATA BASE CONVERTER CSSCNG(V05-2)".
    DISPLAY " ".
    DISPLAY "DO YOU NEED TO SEE THE HELP DIALOG:  "; WITH NO ADVANCING.
    ACCEPT NED-HLP.
    IF NED-HLP = "Y" PERFORM HELP-DIALOG.
    DISPLAY " ".
    DISPLAY "ANSWER THE FOLLOWING ABOUT YOUR NEW OUTPUT RECORD".
    MOVE ZEROES TO OUTPUT-ARRAY, OB-IND, PROMPT-IND.
LOOP-01.
    SET OB-IND UP BY 1.
    MOVE OB-IND TO DIS.
    DISPLAY " ".
    DISPLAY "OUTPUT FIELD NUMBER" DIS.
    DISPLAY "*"; WITH NO ADVANCING.
    ACCEPT INPUT-RESP.
    IF IR = "H" PERFORM HLP-FIL, SET OB-IND DOWN BY 1, GO TO LOOP-01.
    IF IR = "S" GO TO NEW-PROGRAM.
    IF IR = "O" GO TO OVERLAY-SETUP.
    IF IR = "B" PERFORM NEW-FIELD, GO TO GET-SIZE.
    IF IR = "F" PERFORM FINISH-UP, GO TO NEW-PROGRAM.
    MOVE INPUT-RESP TO SAVE-01.
    EXAMINE SAVE-01 REPLACING ALL SPACES BY ZEROES.
    IF SAVE-01 NOT NUMERIC DISPLAY "NOT AN INPUT FIELD NUMBER"
    ,SET OB-IND DOWN BY 1, GO TO LOOP-01.
    MOVE INPUT-RESP TO INPUT-FIELD(OB-IND).
    IF INPUT-FIELD(OB-IND) NOT = ZERO MOVE INPUT-FIELD(OB-IND) TO PROMPT-IND
    ,GO TO SHOW-IN-REC.
    SET PROMPT-IND UP BY 1.
    IF LENGTH-OF-FIELD(PROMPT-IND) > ZERO GO TO GOOD-FIELD.
    DISPLAY "NO REMAINING INPUT FIELDS".
    SUBTRACT 1 FROM OB-IND, PROMPT-IND.
    GO TO LOOP-01.

GOOD-FIELD.
    MOVE PROMPT-IND TO INPUT-FIELD(OB-IND).

SHOW-IN-REC.
    MOVE PROMPT-IND TO DIS.
    DISPLAY DIS "..." PROMPT-TABLE(PROMPT-IND) "  :" LENGTH-OF-FIELD(PROMPT-IND).

GET-SIZE.
    DISPLAY " ".
    DISPLAY "SIZE:  "; WITH NO ADVANCING.
    ACCEPT OR-SIZE(OB-IND).
    IF OR-SIZE(OB-IND) NOT = ZERO GO TO LOOP-01.
    IF INPUT-FIELD(OB-IND) = ZERO DISPLAY "ZERO FIELD SIZE", GO TO GET-SIZE.
    MOVE LENGTH-OF-FIELD(PROMPT-IND) TO OR-SIZE(OB-IND).
    GO TO LOOP-01.

OVERLAY-SETUP.
    MOVE OVER-LAY-PAGE TO IN-OP-NO.
    DISPLAY " ".
    DISPLAY "TYPE FIRST LINE NUMBER OF FIRST OVERLAY PAGE IN".
    DISPLAY "YOUR OUTPUT RECORD:  "; WITH NO ADVANCING.
    ACCEPT OUT-OP-NO.
    DISPLAY " ".
    DISPLAY "TYPE LAST LINE NUMBER OF THE FIRST OVERLAY PAGE IN".
    DISPLAY "YOUR OUTPUT RECORD:  "; WITH NO ADVANCING.
    ACCEPT OUT-LA-NO.
    GO TO NEW-PROGRAM.


MOVE-PR-TAB.
    SET OB-IND UP BY 1.
    MOVE PROMPT-IND TO INPUT-FIELD(OB-IND).
    MOVE LENGTH-OF-FIELD(PROMPT-IND) TO OR-SIZE(OB-IND).

NEW-FIELD.
    DISPLAY "NEW FIELD".
    MOVE ZERO TO INPUT-FIELD(OB-IND).

FINISH-UP.
    SET PROMPT-IND UP BY 1.
    SET OB-IND DOWN BY 1.
    PERFORM MOVE-PR-TAB VARYING PROMPT-IND FROM PROMPT-IND BY 1
    ,UNTIL LENGTH-OF-FIELD(PROMPT-IND) = ZERO.
NEW-PROGRAM SECTION.
NP-OPENERS.
    MOVE FNAME1 TO SNAME2.
    DISPLAY "    CREATING " SNAME "." SEXT "  ...   "; WITH NO ADVANCING.
    OPEN OUTPUT SOURCE-FILE.
    WRITE SOURCE-RECORD FROM A.
    MOVE SNAME TO B-NAME.
    WRITE SOURCE-RECORD FROM B.
    WRITE SOURCE-RECORD FROM C.
    MOVE TODAY TO P-TODAY.
    MOVE P-DD TO D-DD.
    MOVE M-BUFF(P-MM) TO D-MON.
    MOVE P-YY TO D-YY.
    WRITE SOURCE-RECORD FROM D.
    WRITE SOURCE-RECORD FROM E.
    WRITE SOURCE-RECORD FROM F BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM G.
    WRITE SOURCE-RECORD FROM H.
    WRITE SOURCE-RECORD FROM I.
    WRITE SOURCE-RECORD FROM J BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM K.
    WRITE SOURCE-RECORD FROM L BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM M.
    WRITE SOURCE-RECORD FROM M1.
    WRITE SOURCE-RECORD FROM M2.
    WRITE SOURCE-RECORD FROM M3 BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM N-1 BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM N BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM O.
    WRITE SOURCE-RECORD FROM P BEFORE ADVANCING 3 LINES.
    MOVE NUM-CHARS TO Q-NUM.
    WRITE SOURCE-RECORD FROM Q.
    MOVE BLOCKING-FACTOR TO Q1-NUM.
    WRITE SOURCE-RECORD FROM Q1.
    WRITE SOURCE-RECORD FROM Q2 BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM R.
    MOVE " X" TO IS-PIC, RK-PIC, SK-PIC.
    IF IN-OP-NO = ZERO GO TO NO-OVERLAY-1.
    COMPUTE EXTRA-IND = (NUM-PAGES - IN-OP-NO) + 1.
    MOVE EXTRA-IND TO A8-NUM, A9-NUM, A6-NUM.
    PERFORM GET-FD VARYING PROMPT-IND FROM 1 BY 1
      ,UNTIL PROMPT-IND = TOP-LINE(IN-OP-NO).
    MOVE SPACES TO IS-REDEF.
    WRITE SOURCE-RECORD FROM A8.
    COMPUTE EXTRA-IND = IN-OP-NO + 1.
    PERFORM GET-03 VARYING PROMPT-IND FROM PROMPT-IND BY 1
      ,UNTIL PROMPT-IND = TOP-LINE(EXTRA-IND).
    GO TO NO-OVR-DONE.

NO-OVERLAY-1.
    PERFORM GET-FD VARYING PROMPT-IND FROM 1 BY 1
    ,UNTIL LENGTH-OF-FIELD(PROMPT-IND) = ZERO.
    MOVE SPACES TO IS-REDEF.

NO-OVR-DONE.
    MOVE SPACES TO SOURCE-RECORD.
    WRITE SOURCE-RECORD BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM S-1 BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM S-2 BEFORE ADVANCING 3 LINES.
    MOVE "OUT" TO IS1A, 03SYM.
    IF IN-OP-NO = ZERO GO TO NO-OVERLAY-2.
    PERFORM GET-OUT-FD VARYING OB-IND FROM 1 BY 1
      ,UNTIL OB-IND = OUT-OP-NO.
    WRITE SOURCE-RECORD FROM A9.
    PERFORM GET-03-1 VARYING OB-IND FROM OB-IND BY 1
      ,UNTIL OB-IND > OUT-LA-NO.
    GO TO NO-OVR-DONE2.

NO-OVERLAY-2.
    PERFORM GET-OUT-FD VARYING OB-IND FROM 1 BY 1
    ,UNTIL OR-SIZE(OB-IND) = ZERO.

NO-OVR-DONE2.
    WRITE SOURCE-RECORD FROM S BEFORE ADVANCING 3 LINES.
    WRITE SOURCE-RECORD FROM T.
    MOVE VERSION-NUMBER TO U-NUM.
    WRITE SOURCE-RECORD FROM U.
    MOVE SNAME TO PRG-NAME.
    WRITE SOURCE-RECORD FROM PRG-NAM.
    MOVE "77 IN-COUNT          INDEX." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    WRITE SOURCE-RECORD FROM A7.
    MOVE LENGTH-OF-FIELD(POS-KEY) TO V-NUM.
    WRITE SOURCE-RECORD FROM V.
    MOVE "77  LINE-COUNT      PIC S9(3); COMP." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD BEFORE ADVANCING 3 LINES.
    WRITE SOURCE-RECORD FROM W-1 BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM W.
    MOVE F-NAME TO X-FNAME.
    WRITE SOURCE-RECORD FROM X.
    WRITE SOURCE-RECORD FROM Y BEFORE ADVANCING 2 LINES.
    WRITE SOURCE-RECORD FROM Z BEFORE ADVANCING 3 LINES.
    WRITE SOURCE-RECORD FROM A1.
    WRITE SOURCE-RECORD FROM A2.
    WRITE SOURCE-RECORD FROM A3.
    WRITE SOURCE-RECORD FROM A4 BEFORE ADVANCING 2 LINES.
    MOVE "    MOVE F-NAME TO OUTNAM1." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    MOVE "    OPEN INPUT FILE-IN, OUTPUT FILE-OUT." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    MOVE "    MOVE LOW-VALUES TO SYM-KEY." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    MOVE "    MOVE ZERO TO IN-COUNT." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD BEFORE ADVANCING 3 LINES.
    MOVE "LOOP." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    MOVE "    READ FILE-IN; INVALID KEY GO TO ALL-DONE." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    MOVE "    MOVE SPACES TO REC-OUT." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    IF IN-OP-NO = ZERO GO TO NO-OVERLAY-3.
    MOVE SPACES TO ML-IND1, ML-IND2.
    COMPUTE Z-1 = TOP-LINE(IN-OP-NO) - 1.
    PERFORM ML-SETUP THRU ML-EXIT VARYING OB-IND FROM 1 BY 1
      ,UNTIL INPUT-FIELD(OB-IND) > Z-1.
    WRITE SOURCE-RECORD FROM A5.
    WRITE SOURCE-RECORD FROM A6.
    GO TO NO-OVR-DONE3.

NO-OVERLAY-3.
    PERFORM ML-SETUP THRU ML-EXIT VARYING OB-IND FROM 1 BY 1
    ,UNTIL OR-SIZE(OB-IND) = ZERO.

NO-OVR-DONE3.
    MOVE "    WRITE REC-OUT." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    MOVE "    SET IN-COUNT UP BY 1." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    MOVE "    GO TO LOOP." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD BEFORE ADVANCING 3 LINES.
    MOVE "ALL-DONE." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    WRITE SOURCE-RECORD FROM DISPLAY-LINE.
    MOVE "    MOVE PRG-NAM TO OUTNAM1." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    MOVE "    CLOSE FILE-OUT." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    MOVE "CBL" TO ML1-NAME.
    WRITE SOURCE-RECORD FROM MOVE-LINE1.
    WRITE SOURCE-RECORD FROM A10.
    MOVE "REL" TO ML1-NAME.
    WRITE SOURCE-RECORD FROM MOVE-LINE1.
    WRITE SOURCE-RECORD FROM A10.
    MOVE "    STOP RUN." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD BEFORE ADVANCING 3 LINES.
    MOVE "CLEAN-UP.               COPY PRCLNUP." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD BEFORE ADVANCING 3 LINES.
    IF IN-OP-NO = ZERO GO TO ALL-DONE.
    MOVE "MOVE-PAGE." TO SOURCE-RECORD.
    WRITE SOURCE-RECORD.
    MOVE "(I)" TO ML-IND1, ML-IND2.
    PERFORM ML-SETUP THRU ML-EXIT VARYING OB-IND FROM OB-IND BY 1
      ,UNTIL OB-IND > OUT-LA-NO.

ALL-DONE.
    STOP RUN.

GET-FD.
    MOVE SPACES TO IS-REDEF.
    IF PROMPT-IND = POS-KEY PERFORM GET-REC-KEY.
    MOVE PROMPT-IND TO IS-NUM1.
    MOVE LENGTH-OF-FIELD(PROMPT-IND) TO IS-NUM2.
    WRITE SOURCE-RECORD FROM IN-SYM.

GET-REC-KEY.
    MOVE LENGTH-OF-FIELD(POS-KEY) TO RK-NUM.
    WRITE SOURCE-RECORD FROM REC-K.
    MOVE " REDEFINES REC-KEY" TO IS-REDEF.

GET-OUT-FD.
    MOVE OB-IND TO IS-NUM1.
    MOVE OR-SIZE(OB-IND) TO IS-NUM2.
    WRITE SOURCE-RECORD FROM IN-SYM.

GET-03.
    MOVE PROMPT-IND TO 03NUM1.
    MOVE LENGTH-OF-FIELD(PROMPT-IND) TO 03NUM2.
    WRITE SOURCE-RECORD FROM 03-LINE.

GET-03-1.
    MOVE OB-IND TO 03NUM1.
    MOVE OR-SIZE(OB-IND) TO 03NUM2.
    WRITE SOURCE-RECORD FROM 03-LINE.

ML-SETUP.
    IF INPUT-FIELD(OB-IND) = ZERO GO TO ML-EXIT.
    MOVE INPUT-FIELD(OB-IND) TO ML-NUM1.
    MOVE OB-IND TO ML-NUM2.
    WRITE SOURCE-RECORD FROM MOVE-LINE.
ML-EXIT.  EXIT.

HELP-DIALOG.
    DISPLAY " ".
    DISPLAY "IN THE FOLLWING DIALOG, YOU WILL BE CREATING A NEW".
    DISPLAY "DATA FILE, WHICH CAN CONTAIN NEW FIELDS OF DATA AS".
    DISPLAY "WELL AS AN OLD DATA FIELD.  THIS CAN BE A COMPLETE".
    DISPLAY "REARRANGEMENT OF YOUR OLD FILE IF DESIRED.".
    PERFORM HLP-FIL.

HLP-FIL.
    DISPLAY " ".
    DISPLAY "COMMANDS ARE AS FOLLOWS:  ".
    DISPLAY "    H.... FOR THIS LIST OF COMMANDS.".
    DISPLAY "    B.... TO PLACE A BLANK FIELD INTO YOUR OUTPUT RECORD.".
    DISPLAY "    O.... TO OVERLAY AFTER YOU HAVE COMPLETELY DEFINED".
    DISPLAY "          THE FIRST OVERLAY PAGE OF YOU NEW OUTPUT RECORD.".
    DISPLAY "    F.... IF REMAINING FIELDS IN OUTPUT RECORD ARE THE SAME".
    DISPLAY "          AS THE REMAINING FIELDS IN INPUT RECORD.".
    DISPLAY "    S.... IF YOUR NEW RECORD TERMINATES AFTER THE LAST".
    DISPLAY "          FIELD YOU HAVE DEFINED."
    DISPLAY "    <CR>  IF NEXT NEW FIELD CORRESPONDS TO THE NEXT".
    DISPLAY "          SUCCESSIVE FIELD IN YOUR OLD RECORD.".
    DISPLAY Q-LINE.
    DISPLAY "          ANY INPUT FIELD NUMBER".