Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-04 - 43,50343/dtape.cbl
There is 1 other file named dtape.cbl in the archive. Click here to see a list.
 IDENTIFICATION DIVISION.
 PROGRAM-ID.             DTAPE.
 AUTHOR.                 J E HENDRIX.
 INSTALLATION.           OLE MISS.
 DATE-WRITTEN.           APRIL 1973.
 DATE-COMPILED.
 REMARKS.                ON-LINE TAPE LIBRARY PROGRAM.
*
 ENVIRONMENT DIVISION.
 CONFIGURATION SECTION.
 SOURCE-COMPUTER.        PDP-10.
 OBJECT-COMPUTER.        PDP-10  SEGMENT-LIMIT IS 49.
 INPUT-OUTPUT SECTION.
 FILE-CONTROL.
     SELECT VOL ASSIGN TO DSK
                ACCESS MODE IS RANDOM
                FILE-LIMIT IS 10000
                ACTUAL KEY IS VOL-KEY
                RECORDING MODE IS SIXBIT.
*
     SELECT VID ASSIGN TO DSK
            ACCESS MODE IS INDEXED
            SYMBOLIC KEY IS VID-SYM-KEY
            RECORD KEY IS VID-REC-KEY
            RECORDING MODE IS SIXBIT.
*
     SELECT CMD ASSIGN TO DSK
            RECORDING MODE IS ASCII.
*
     SELECT RPT ASSIGN TO DSK
                RECORDING MODE IS ASCII.
*
 DATA DIVISION.
 FILE SECTION.
*
 FD  VOL BLOCK CONTAINS 42 RECORDS
         VALUE OF IDENTIFICATION IS "DTAPE VOL"
                USER-NUMBER *** PPN OF DTAPE FILES ***.
 01  VOL-REC.
     02  VOL-VID     PIC  X(6).
     02  VOL-GEN     PIC  9(4).
*
 FD  VID BLOCK CONTAINS 10 RECORDS
         VALUE OF IDENTIFICATION IS "DTAPE IDX"
                USER-NUMBER *** PPN OF DTAPE FILES ***.
 01  VID-REC.
     02  VID-REC-KEY.
         03  VID-VID         PIC  X(6).
         03  VID-GEN         PIC  9(4).
     02  VID-0000-REC.
         03  VID-RCD         PIC S9(6).
         03  VID-CUR-GEN     PIC  9(4).
         03  VID-CUR-CMD     PIC  X(3).
         03  VID-RPG         PIC  9(1).
         03  VID-MRS         PIC  X(6).
         03  VID-FIL         PIC  X(36).
     02  VID-NNNN-REC  REDEFINES VID-0000-REC.
         03  GEN-RDT         PIC  9(6).
         03  GEN-CNT         PIC  9(4).
         03  GEN-DATE        PIC  9(6).
         03  GEN-TIME        PIC  9(4).
         03  GEN-WHO         PIC  X(6).
         03  GEN-REELS.
             04  GEN-REEL    OCCURS 5 TIMES  INDEXED BY REEL-NDX.
                 05  GEN-SIZ PIC  9(2).
                 05  GEN-VOL PIC  9(4).
         03  GEN-REELS-RED REDEFINES GEN-REELS.
             04  RL-1    PIC  9(6).
             04  RL-2    PIC  9(6).
             04  RL-3    PIC  9(6).
             04  RL-4    PIC  9(6).
             04  RL-5    PIC  9(6).
*
 FD  CMD     VALUE OF IDENTIFICATION IS CMD-ID.
 01  CMD-REC.
     02  CMD-MTA     PIC  X(6).
     02  CMD-LDV     PIC  X(6).
     02  CMD-REELID  PIC  X(9).
     02  CMD-RID     PIC  X(5).
     02  CMD-VID     PIC  X(6).
     02  CMD-REELS.
         03  CMD-REEL  OCCURS 5 TIMES.
             04  CMD-VOL  PIC  9(4).
             04  CMD-FIL  PIC  X.
     02  CMD-SLSH    PIC  X.
     02  CMD-RW      PIC  X(6).
*
 FD  RPT  REPORTS ARE VOL-RPT  VID-RPT
          VALUE OF IDENTIFICATION IS "DTAPE LPT".
*
 WORKING-STORAGE SECTION.
*
 77  VOL-KEY         PIC  9(5) COMP.
 77  HOLD-VOL-KEY      PIC  9(4) COMP.
*
 77  CMD-BRANCH      PIC  9(2) COMP.
 77  OLD-GEN         PIC  9(4) COMP.
 77  NEW-GEN         PIC  9(4) COMP.
 77  OLD-CNT         PIC  9(4) COMP.
 77  NEW-CNT         PIC  9(4) COMP.
 77  I               PIC  9(4) COMP.
 77  J               PIC  9(4) COMP.
 77  K               PIC  9(4) COMP.
 77  VE-SUB          PIC  99  COMP.
 77  VE-HIT          PIC  99  COMP.
 77  VOL-10          PIC  999 COMP.
 77  SEC             PIC  99  COMP  VALUE  5.
 77  EXP-AST         PIC  X.
 77  HOLD-REC-KEY    PIC  X(10).
 77  HOLD-GEN        PIC  9(4).
 77  X-4             PIC  X(4).
 77  ANS             PIC  X(3).
 77  OLD-VID         PIC  X(6).
 77  NEW-VID         PIC  X(6).
 77  SCR-GEN         PIC  9(4).
 77  DELAYED-FATALITY  PIC  X(7)  VALUE SPACES.
 77  SORRY             PIC  X(7)  VALUE "? SORRY".
***************** PROGRAM LIMITS *************************
 77  MAX-REELS       PIC  9(2) COMP  VALUE 5.
 77  MAX-GEN         PIC  9(4) COMP  VALUE 9999.
*
 77  VOL-END         PIC  9(5) COMP  VALUE 10000.
 01  DISPLAY-FIELDS.
     02  D-CMD   PIC  X(4)  VALUE "CMD=".
     02  D-WHT   PIC  X(4)  VALUE "WHT=".
     02  D-VID   PIC  X(4)  VALUE "VID=".
     02  D-GEN   PIC  X(4)  VALUE "GEN=".
     02  D-VOL   PIC  X(4)  VALUE "VOL=".
     02  D-RCD   PIC  X(4)  VALUE "RCD=".
     02  D-RDT   PIC  X(4)  VALUE "RDT=".
     02  D-NEW   PIC  X(4)  VALUE "NEW=".
     02  D-LDV   PIC  X(4)  VALUE "LDV=".
     02  D-DIS   PIC  X(4)  VALUE "DIS=".
     02  D-USE   PIC  X(4)  VALUE "USE=".
     02  D-WHO   PIC  X(4)  VALUE "WHO=".
     02  D-SIZ   PIC  X(4)  VALUE "SIZ=".
     02  D-RPG   PIC  X(4)  VALUE "RPG=".
     02  D-MRS   PIC  X(4)  VALUE "MRS=".
     02  D-RCDX  PIC  ---,--,-9.
*
 01  ACCEPT-FIELDS.
     02  A-CMD   PIC  X(3).
     02  A-WHT   PIC  X(3).
         88  WHT-SCRATCH VALUE "SCR".
         88  WHT-VID     VALUE "VID".
         88  WHT-VOLUME  VALUE "VOL".
         88  WHT-RCD     VALUE "RCD".
         88  WHT-RDT     VALUE "RDT".
         88  WHT-VOL     VALUE "VOL".
         88  WHT-GEN     VALUE "GEN".
         88  WHT-EXPIRED VALUE "EXP".
         88  WHT-REEL    VALUE "REE".
         88  WHT-RPG     VALUE "RPG".
         88  WHT-MRS     VALUE "MRS".
     02  A-VID   PIC  X(6).
         88  VID-SCRATCH VALUE "0300FT" "0600FT"
                               "1200FT" "2400FT".
         88  VID-ALL     VALUE "ALL   ".
     02  A-VID-RED REDEFINES A-VID.
         03  A-VID-2 PIC 9(2).
         03  FILLER  PIC X(4).
     02  A-GEN   PIC S9(4).
         88  GEN-LEVEL   VALUE  -9999 THRU -1.
         88  GEN-SCRATCH VALUE    0.
         88  GEN-COUNT   VALUE    1 THRU 9999.
     02  A-VOL   PIC  9(4).
         88  VOL-VALID   VALUE    1 THRU 9999.
     02  A-RCD   PIC S9(6).
         88  RCD-GENS    VALUE  -9999 THRU -1.
     02  A-RCD-RED  REDEFINES A-RCD.
         03  A-RCD-YR    PIC  99.
             88  RCD-YR-ZERO     VALUE  00.
             88  RCD-YR-VALID    VALUE  73 THRU 99.
         03  A-RCD-MO    PIC  99.
             88  RCD-MO-ZERO     VALUE  00.
             88  RCD-MO-VALID    VALUE  01 THRU 12.
         03  A-RCD-DY    PIC  99.
             88  RCD-DY-ZERO     VALUE  00.
             88  RCD-DY-VALID    VALUE  01 THRU 31.
     02  A-RPG   PIC  9.
     02  A-LDV   PIC  X(6).
     02  A-DIS   PIC S9(4).
         88  DIS-VALID   VALUE -9999 THRU 0.
     02  A-USE   PIC  X(3).
         88  USE-INPUT   VALUE "INP".
         88  USE-OUTPUT  VALUE "OUT".
     02  A-WHO   PIC  X(6).
*
 01  VID-SYM-KEY.
     02  KEY-VID     PIC  X(6).
     02  KEY-GEN     PIC  9(4).
*
 01  BODY-HDR.
     02  FILLER PIC X(49) VALUE
         " GENERATION   ***CREATED******BY***      RDT     ".
*
 01  BODY.
     02  B-GEN      PIC  ----9.
     02  FILLER     PIC  X    VALUE "(".
     02  B-CNT      PIC  9(4).
     02  FILLER     PIC  X(4) VALUE ")".
     02  B-CRE-YY   PIC  99.
     02  FILLER     PIC  X    VALUE "/".
     02  B-CRE-MM   PIC  99.
     02  FILLER     PIC  X    VALUE "/".
     02  B-CRE-DD   PIC  99.
     02  B-CRE-HH   PIC ZZ9.
     02  FILLER     PIC  X    VALUE ":".
     02  B-CRE-MIN  PIC  99.
     02  FILLER     PIC  X    VALUE SPACES.
     02  B-WHO      PIC  X(9).
     02  B-RDT-YY   PIC  99.
     02  FILLER     PIC  X    VALUE "/".
     02  B-RDT-MM   PIC  99.
     02  FILLER     PIC  X    VALUE "/".
     02  B-RDT-DD   PIC  99.
     02  FILLER     PIC  X(3) VALUE SPACES.
*
 01  VOL-LINE.
     02  VOL-ENTRY  OCCURS 10 TIMES.
         03  VE-GEN    PIC  ----9.
         03  FILLER    PIC  X.
         03  VE-VID    PIC  X(6).
*
 01  SWITCHES.
     02  FIRST-REEL-SW PIC 9.
         88  FIRST-REEL-SCRATCHED  VALUE 1.
     02  INSERT-SW   PIC 9.
         88  INSERT-ERROR  VALUE 1.
         88  INSERT-OK     VALUE 0.
     02  EXTRACT-SW  PIC 9.
         88  EXTRACT-ERROR VALUE 1.
         88  EXTRACT-OK    VALUE 0.
     02  START-SW    PIC 9.
         88  START-ERROR   VALUE 1.
         88  START-OK      VALUE 0.
     02  END-SW      PIC 9.
         88  END-ERROR     VALUE 1.
         88  END-OK        VALUE 0.
     02  UPDT-VOL-SW PIC 9.
         88  UPDT-VOL-ERROR  VALUE 1.
         88  UPDT-VOL-OK     VALUE 0.
     02  FETCH-SW    PIC 9.
         88  FETCH-ERROR     VALUE 1.
         88  FETCH-OK        VALUE 0.
     02  TYPE-EXP-SW PIC 9   VALUE 0.
         88  SCRATCH-EXP-OK  VALUE 1.
     02  ASSIGN-SW   PIC 9.
         88  ASSIGN-ERROR    VALUE 1.
         88  NO-SCRATCHES    VALUE 2.
     02  FIRST-GEN-SW  PIC  9.
         88  FIRST-GEN     VALUE 1.
*
 01  COMMANDS.
     02  FILLER  PIC X(3) VALUE "ADD".
     02  FILLER  PIC X(3) VALUE "CHA".
     02  FILLER  PIC X(3) VALUE "DEL".
     02  FILLER  PIC X(3) VALUE "ASS".
     02  FILLER  PIC X(3) VALUE "SCR".
     02  FILLER  PIC X(3) VALUE "SWA".
     02  FILLER  PIC X(3) VALUE "TYP".
     02  FILLER  PIC X(3) VALUE "REP".
     02  FILLER  PIC X(3) VALUE "CAT".
     02  FILLER  PIC X(3) VALUE "MOU".
     02  FILLER  PIC X(3) VALUE "EXI".
 01  CMD-TBL REDEFINES COMMANDS.
     02  CMD-CD  PIC X(3) OCCURS 11 TIMES INDEXED BY CMD-NDX.
*
*
 01  MONTH-SIZES.
     02  JAN     PIC 9(2)  VALUE 31.
     02  FEB     PIC 9(2)  VALUE 28.
     02  MAR     PIC 9(2)  VALUE 31.
     02  APR     PIC 9(2)  VALUE 30.
     02  MAY     PIC 9(2)  VALUE 31.
     02  JUN     PIC 9(2)  VALUE 30.
     02  JUL     PIC 9(2)  VALUE 31.
     02  AUG     PIC 9(2)  VALUE 31.
     02  SEP     PIC 9(2)  VALUE 30.
     02  OCT     PIC 9(2)  VALUE 31.
     02  NOV     PIC 9(2)  VALUE 30.
     02  DEC     PIC 9(2)  VALUE 31.
 01  MONTH-TBL REDEFINES MONTH-SIZES.
     02  MO-SZ   PIC 9(2)  OCCURS 12 TIMES.
*
 01  TODAYS-DATE-TIME.
     02  TODAYS-DATE     PIC  9(6).
     02  TODAYS-TIME     PIC  9(4).
     02  TODAYS-SEC      PIC  9(2).
*
 01  SCR-VID.
     02  SCR-SIZ     PIC  99.
     02  FILLER      PIC  X(4)   VALUE "00FT".
*
 01  SWAP-FIELDS.
     02  VOL-1   PIC  X(6).
     02  VID-1   PIC  X(6).
     02  GEN-1   PIC S9(4).
     02  REEL-1       INDEX.
     02  VOL-2   PIC  X(6).
     02  VID-2   PIC  X(6).
     02  GEN-2   PIC S9(4).
     02  REEL-2       INDEX.
     02  VOL-X   PIC  X(6).
*
 01  CMD-ID.
     02  CMD-LDV-ID  PIC  X(6).
     02  FILLER      PIC  X(3)   VALUE "CMD".
*
 01  WS-VID-REC.
     02  WS-REC-KEY.
         03  WS-VID      PIC  X(6).
         03  WS-GEN      PIC  9(4).
     02  WS-00.
         03  WS-RCD      PIC S9(6).
         03  WS-CUR-GEN  PIC  9(4).
         03  WS-CUR-CMD  PIC  X(3).
         03  WS-RPG      PIC  9.
         03  WS-FIL      PIC  X(42).
     02  WS-NN  REDEFINES WS-00.
         03  WS-RDT      PIC  9(6).
         03  WS-RDT-RED REDEFINES WS-RDT.
             04  YY  PIC 99.
             04  MM  PIC 99.
             04  DD  PIC 99.
         03  WS-CNT      PIC  9(4).
         03  WS-DATE     PIC  9(6).
         03  WS-TIME     PIC  9(4).
         03  WS-TIME-RED REDEFINES WS-TIME.
             04  HH    PIC  99.
             04  MIN   PIC  99.
         03  WS-WHO      PIC  X(6).
         03  WS-REELS.
             04  WS-REEL PIC  9(6)   OCCURS 5 TIMES.
*
 REPORT SECTION.
*
 RD  VOL-RPT  PAGE LIMITS ARE 59 LINES
             HEADING 1  FIRST DETAIL 3  LAST DETAIL 58  FOOTING 59.
*
 01  VOL-HDG  TYPE IS PAGE HEADING
              NEXT GROUP PLUS 1.
     02  VOL-HDG-1  LINE 1.
         03  COLUMN  11  PIC  99,99,99  SOURCE TODAYS-DATE.
         03  COLUMN  51  PIC  X(23)     VALUE "DTAPE VOLUME STATUS".
         03  COLUMN 111  PIC  X(4)      VALUE "PAGE".
         03  COLUMN 115  PIC  ZZ9       SOURCE PAGE-COUNTER OF VOL-RPT.
     02  VOL-HDG-2  LINE PLUS 3.
         03  COLUMN   9  PIC  X(4)  VALUE "XXX0".
         03  COLUMN  21  PIC  X(4)  VALUE "XXX1".
         03  COLUMN  33  PIC  X(4)  VALUE "XXX2".
         03  COLUMN  45  PIC  X(4)  VALUE "XXX3".
         03  COLUMN  57  PIC  X(4)  VALUE "XXX4".
         03  COLUMN  69  PIC  X(4)  VALUE "XXX5".
         03  COLUMN  81  PIC  X(4)  VALUE "XXX6".
         03  COLUMN  93  PIC  X(4)  VALUE "XXX7".
         03  COLUMN 105  PIC  X(4)  VALUE "XXX8".
         03  COLUMN 117  PIC  X(4)  VALUE "XXX9".
*
 01  VOL-DET  TYPE IS DETAIL
              LINE PLUS 2.
     02  COLUMN   1  PIC  999    SOURCE VOL-10.
     02  COLUMN   4  PIC  X      VALUE "X".
     02  COLUMN   5  PIC  X(120) SOURCE VOL-LINE.
*
 01  VOL-RPT-FTG  TYPE IS REPORT FOOTING  LINE NEXT PAGE.
     02  COLUMN 1 PIC X VALUE " ".
*
 RD  VID-RPT  CONTROLS ARE VID-VID
              PAGE LIMITS ARE 59 LINES
              HEADING 1  FIRST DETAIL 3  LAST DETAIL 58
              FOOTING 59.
*
 01  VID-RPT-HDG  TYPE IS REPORT HEADING
                  LINE 1.
     02  COLUMN 1 PIC X VALUE " ".
*
 01  VID-HDG  TYPE IS PAGE HEADING
              NEXT GROUP PLUS 2.
     02  VID-HDG-1  LINE 1.
         03  COLUMN  11  PIC  99,99,99  SOURCE TODAYS-DATE.
         03  COLUMN  51  PIC  X(20)     VALUE "DTAPE VID STATUS".
         03  COLUMN 111  PIC  X(4)      VALUE "PAGE".
         03  COLUMN 115  PIC  ZZ9       SOURCE PAGE-COUNTER OF VID-RPT.
     02  VID-HDG-2  LINE PLUS 3.
         03  COLUMN   1  PIC  X(3)   VALUE "ERR".
         03  COLUMN   7  PIC  X(3)   VALUE "VID".
         03  COLUMN  18  PIC  X(3)   VALUE "RCD".
         03  COLUMN  27  PIC  X(10)  VALUE "GENERATION".
         03  COLUMN  39  PIC  X(3)   VALUE "EXP".
         03  COLUMN  49  PIC  X(3)   VALUE "RDT".
         03  COLUMN  63  PIC  X(7)   VALUE "CREATED".
         03  COLUMN  80  PIC  X(2)   VALUE "BY".
         03  COLUMN  88  PIC  X(6)   VALUE "REEL-1".
         03  COLUMN  97  PIC  X(6)   VALUE "REEL-2".
         03  COLUMN 106  PIC  X(6)   VALUE "REEL-3".
         03  COLUMN 115  PIC  X(6)   VALUE "REEL-4".
         03  COLUMN 124  PIC  X(6)   VALUE "REEL-5".
*
 01  VID-CON-HDG  TYPE IS CONTROL HEADING VID-VID.
     02  COLUMN 1 PIC X VALUE " "  LINE PLUS 1.
*
 01  VID-DET  TYPE IS DETAIL  LINE PLUS 1.

     02  COLUMN   1  PIC  X(3)     SOURCE A-CMD.
     02  COLUMN   6  PIC  X(6)     SOURCE A-VID GROUP INDICATE.
     02  COLUMN  14  PIC  ---,--,-- SOURCE A-RCD GROUP INDICATE.
     02  COLUMN  25  PIC  ----9    SOURCE A-GEN.
     02  COLUMN  30  PIC  X        VALUE "(".
     02  COLUMN  31  PIC  9999     SOURCE GEN-CNT.
     02  COLUMN  35  PIC  X        VALUE ")".
     02  COLUMN  40  PIC  X        SOURCE EXP-AST.
     02  COLUMN  46  PIC  99,99,99 SOURCE GEN-RDT.
     02  COLUMN  59  PIC  99,99,99 SOURCE GEN-DATE.
     02  COLUMN  69  PIC  99,99    SOURCE GEN-TIME.
     02  COLUMN  78  PIC  X(6)     SOURCE GEN-WHO.
     02  COLUMN  89  PIC  ZZZZ     SOURCE RL-1.
     02  COLUMN  98  PIC  ZZZZ     SOURCE RL-2.
     02  COLUMN 107  PIC  ZZZZ     SOURCE RL-3.
     02  COLUMN 116  PIC  ZZZZ     SOURCE RL-4.
     02  COLUMN 125  PIC  ZZZZ     SOURCE RL-5.
*
 PROCEDURE DIVISION.
 DECLARATIVES.
 0010-SLEEP SECTION.
     USE AFTER ERROR PROCEDURE ON VID OPEN.
 0020-SLEEP.
     ENTER MACRO DELAY USING SEC.
 0030-SLEEP-2 SECTION.
     USE AFTER ERROR PROCEDURE ON VOL OPEN.
 0032-SLEEP-2.
     ENTER MACRO DELAY USING SEC.
 END DECLARATIVES.
*
 0040-RESIDENT SECTION.
 0050-GET-CMD.
     MOVE TODAY TO TODAYS-DATE-TIME.
     DISPLAY " ".
     DISPLAY D-CMD WITH NO ADVANCING. ACCEPT A-CMD.
     MOVE 1 TO CMD-NDX.
     SEARCH CMD-CD WHEN A-CMD = CMD-CD (CMD-NDX) GO TO 0060-LONG-BRANCH.
     DISPLAY " TRY ADD, CHANGE, DELETE, ASSIGN, SCRATCH, SWAP, TYPE,".
     DISPLAY "?    REPORT, CATALOG, MOUNT, EXIT".
     GO TO 0050-GET-CMD.
*
 0060-LONG-BRANCH.
     MOVE CMD-NDX TO CMD-BRANCH.
     GO TO 0100-ADD
           0200-CHANGE
           0300-DELETE
           0400-ASSIGN
           0500-SCRATCH
           0600-SWAP
           0700-TYPE
           0800-REPORT
           0900-CATALOG
           1000-MOUNT
           1100-EXIT
     DEPENDING ON CMD-BRANCH.
     DISPLAY "? PROG ERR AT 0060".
     GO TO 0050-GET-CMD.
*
 0070-ABORT-A-VID-UPDT.
     CLOSE   VOL  VID.
     IF DELAYED-FATALITY NOT = SPACES
         DISPLAY DELAYED-FATALITY
         MOVE SPACES TO DELAYED-FATALITY.
     GO TO 0050-GET-CMD.
*
 0080-FINISH-A-VID-UPDT.
     PERFORM 7050-END-A-VID-UPDT.
     IF END-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     GO TO 0050-GET-CMD.
*
 0100-ADD SECTION 1.
 0110-ADD.
     DISPLAY D-WHT WITH NO ADVANCING.  ACCEPT A-WHT.
     IF WHT-SCRATCH   GO TO 0120-ADD-SCRATCH.
     IF WHT-VID       GO TO 0140-ADD-VID.
     DISPLAY "? MUST BE SCRATCH OR VID".
     GO TO 0050-GET-CMD.
 0120-ADD-SCRATCH.
     DISPLAY D-SIZ WITH NO ADVANCING. ACCEPT A-VID.
     IF NOT VID-SCRATCH
        DISPLAY "? INVALID SCRATCH VID"
        GO TO 0050-GET-CMD.
     DISPLAY D-DIS WITH NO ADVANCING. ACCEPT A-DIS.
     IF NOT DIS-VALID
        DISPLAY "? INVALID DISPOSITION "
        GO TO 0050-GET-CMD.
     MOVE 0 TO WS-DATE.
     MOVE 0 TO WS-TIME.
     MOVE SPACES TO WS-WHO.
 0130-NEXT-VOL.
     DISPLAY D-VOL WITH NO ADVANCING.  ACCEPT A-VOL.
     IF NOT VOL-VALID DISPLAY "? INVALID VOLUME"
                      GO TO 0130-NEXT-VOL.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     PERFORM 7400-FETCH-A-VOL.
     IF FETCH-ERROR GO TO 0080-FINISH-A-VID-UPDT.
     IF VOL-REC NOT = SPACES
              DISPLAY "? " A-VOL " ALREADY EXISTS"
              GO TO 0135-ADD-VOL-DONE.
     MOVE A-VID       TO  SCR-VID.
     PERFORM 7600-BUILD-SCRATCH-WS.
     PERFORM 5000-INSERT-GEN.
     IF INSERT-ERROR GO TO 0070-ABORT-A-VID-UPDT.
 0135-ADD-VOL-DONE.
     PERFORM 7050-END-A-VID-UPDT.
     IF END-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     GO TO 0130-NEXT-VOL.
*
 0140-ADD-VID.
     DISPLAY D-VID WITH NO ADVANCING.  ACCEPT A-VID.
     IF A-VID = "ALL   " DISPLAY "? ILLEGAL VID"
         GO TO 0050-GET-CMD.
     DISPLAY D-RCD WITH NO ADVANCING.  ACCEPT A-RCD.
     PERFORM 7200-CALC-RDT.
     IF WS-RDT = 0
         DISPLAY "? INVALID RETENTION CODE"
         GO TO 0050-GET-CMD.
     OPEN I-O  VID.
     MOVE A-VID  TO VID-VID KEY-VID.
     MOVE 0      TO VID-GEN KEY-GEN.
     MOVE A-RCD  TO VID-RCD.
     MOVE 0      TO VID-CUR-GEN.
     MOVE SPACES TO VID-CUR-CMD.
     MOVE SPACES TO VID-FIL.
     DISPLAY D-RPG WITH NO ADVANCING.  ACCEPT VID-RPG.
     IF VID-RPG     < 1 OR > MAX-REELS
        DISPLAY "? RPG MUST BE 1 THRU " MAX-REELS
        GO TO 0150-ADD-VID-EXIT.
     DISPLAY D-MRS WITH NO ADVANCING.  ACCEPT A-VID.
     IF NOT VID-SCRATCH
         DISPLAY "? MIN-REEL-SIZE MUST BE A SCRATCH VID"
         GO TO 0150-ADD-VID-EXIT.
     MOVE A-VID TO VID-MRS.
     WRITE VID-REC INVALID KEY
               DISPLAY "? " KEY-VID " ALREADY EXISTS".
 0150-ADD-VID-EXIT.
     CLOSE  VID.
     GO TO 0050-GET-CMD.
*
 0200-CHANGE SECTION 2.
 0210-CHANGE.
     DISPLAY D-WHT WITH NO ADVANCING.  ACCEPT A-WHT.
     IF WHT-VOL  GO TO 0220-CHANGE-VOL.
     IF WHT-VID  GO TO 0240-CHANGE-VID.
     IF WHT-RCD  GO TO 0260-CHANGE-RCD.
     IF WHT-RDT  GO TO 0280-CHANGE-RDT.
     IF WHT-RPG  GO TO 0290-CHANGE-RPG.
     IF WHT-MRS  GO TO 0295-CHANGE-MRS.
     DISPLAY "? MUST BE VOL, VID, RPG, MRS, RCD OR RDT".
     GO TO 0050-GET-CMD.
 0220-CHANGE-VOL.
     DISPLAY D-VOL WITH NO ADVANCING.  ACCEPT A-VOL.
     IF NOT VOL-VALID
        DISPLAY "? INVALID VOLUME NUMBER"
        GO TO 0050-GET-CMD.
     MOVE A-VOL TO VOL-KEY.
     DISPLAY D-NEW WITH NO ADVANCING.  ACCEPT A-VOL.
     IF NOT VOL-VALID
        DISPLAY "? INVALID VOLUME NUMBER"
        GO TO 0050-GET-CMD.
     OPEN INPUT VOL.
     READ VOL INVALID KEY
          DISPLAY "? PROG READ ERR AT 0220, VOL " VOL-KEY
          CLOSE VOL
          GO TO 0050-GET-CMD.
     MOVE VOL-GEN TO HOLD-GEN.
     CLOSE VOL.
     IF VOL-REC = SPACES
        DISPLAY "? VOL " VOL-KEY " NON-EXISTENT"
        GO TO 0050-GET-CMD.
     MOVE VOL-VID TO A-VID.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     MOVE HOLD-GEN TO KEY-GEN.
     READ VID INVALID KEY
              DISPLAY "? PROG READ ERR AT 0220, VID " VID-SYM-KEY
              GO TO 0070-ABORT-A-VID-UPDT.
     MOVE 1 TO REEL-NDX.
     SEARCH GEN-REEL
              AT END DISPLAY "? VOL " VOL-KEY " NOT FOUND IN "
                             VID-SYM-KEY
                     GO TO 0070-ABORT-A-VID-UPDT
              WHEN VOL-KEY = GEN-VOL  (REEL-NDX) NEXT SENTENCE.
     MOVE A-VOL TO VOL-KEY.
     READ VOL INVALID KEY
              DISPLAY "? PROG READ ERR AT 0220, VOL " VOL-KEY
              GO TO 0080-FINISH-A-VID-UPDT.
     IF VOL-REC NOT = SPACES
        DISPLAY "? VOL " VOL-KEY " ALREADY EXISTS"
        GO TO 0080-FINISH-A-VID-UPDT.
     MOVE VID-SYM-KEY TO VOL-REC.
     WRITE VOL-REC INVALID KEY
           DISPLAY "? PROG WRITE ERR AT 0220, VOL " VOL-KEY
           GO TO 0070-ABORT-A-VID-UPDT.
     MOVE GEN-VOL  (REEL-NDX) TO VOL-KEY.
     MOVE SPACES TO VOL-REC.
     WRITE VOL-REC INVALID KEY
           DISPLAY "? PROG WRT ERR AT 0220, VOL " VOL-KEY
           GO TO 0070-ABORT-A-VID-UPDT.
     MOVE A-VOL TO GEN-VOL  (REEL-NDX).
     REWRITE VID-REC INVALID KEY
             DISPLAY "? PROG REWRITE ERR AT 0220, VID " VID-SYM-KEY
             GO TO 0070-ABORT-A-VID-UPDT.
     GO TO 0080-FINISH-A-VID-UPDT.
*
 0240-CHANGE-VID.
     DISPLAY D-VID WITH NO ADVANCING.  ACCEPT A-VID.
     IF VID-SCRATCH
        DISPLAY "? INVALID VID"
        GO TO 0050-GET-CMD.
     MOVE A-VID TO OLD-VID.
     DISPLAY D-NEW WITH NO ADVANCING.  ACCEPT A-VID.
     IF VID-SCRATCH
        DISPLAY "? INVALID NEW VID"
        GO TO 0050-GET-CMD.
     MOVE A-VID TO NEW-VID.
     MOVE OLD-VID TO A-VID.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     MOVE NEW-VID TO VID-VID  KEY-VID.
     WRITE VID-REC INVALID KEY
           DISPLAY "? VID " NEW-VID " ALREADY EXISTS"
           GO TO 0080-FINISH-A-VID-UPDT.
 0245-CHANGE-VID-LOOP.
     MOVE OLD-VID TO WS-VID.
     MOVE 1 TO WS-GEN.
     PERFORM 6000-EXTRACT-GEN.
     IF EXTRACT-ERROR GO TO 0248-VERIFY-END.
     MOVE NEW-VID TO WS-VID.
     MOVE 9999 TO WS-GEN.
     PERFORM 5000-INSERT-GEN.
     IF INSERT-ERROR GO TO  0070-ABORT-A-VID-UPDT.
     GO TO 0245-CHANGE-VID-LOOP.
 0248-VERIFY-END.
     MOVE OLD-VID TO KEY-VID.
     MOVE 1 TO KEY-GEN.
     READ VID INVALID KEY GO TO 0250-CHANGE-DONE.
     DISPLAY "? CHANGE INCOMPLETE"
     GO TO 0070-ABORT-A-VID-UPDT.
 0250-CHANGE-DONE.
     MOVE 0 TO KEY-GEN.
     DELETE VID-REC INVALID KEY
            DISPLAY "? PROG DELETE ERR AT 0250, VID " VID-SYM-KEY
            GO TO 0070-ABORT-A-VID-UPDT.
     MOVE NEW-VID TO A-VID.
     GO TO 0080-FINISH-A-VID-UPDT.
*
 0260-CHANGE-RCD.
     DISPLAY D-VID WITH NO ADVANCING.  ACCEPT A-VID.
     DISPLAY D-NEW WITH NO ADVANCING.  ACCEPT A-RCD.
     PERFORM 7200-CALC-RDT.
     IF WS-RDT = 0
        DISPLAY "? INVALID RETENTION CODE"
        GO TO 0050-GET-CMD.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     MOVE A-RCD TO VID-RCD.
     REWRITE VID-REC INVALID KEY
             DISPLAY "? PROG REWRITE ERR AT 0260, VID=" VID-SYM-KEY
             GO TO 0070-ABORT-A-VID-UPDT.
     GO TO 0080-FINISH-A-VID-UPDT.
*
 0280-CHANGE-RDT.
     DISPLAY D-VID WITH NO ADVANCING.  ACCEPT A-VID.
     DISPLAY D-GEN WITH NO ADVANCING.  ACCEPT A-GEN.
     DISPLAY D-NEW WITH NO ADVANCING.  ACCEPT A-RCD.
     MOVE HIGH-VALUE TO WS-RDT.
     PERFORM 7200-CALC-RDT.
     IF A-RCD NOT = WS-RDT
        DISPLAY "? INVALID RETENTION DATE"
        GO TO 0050-GET-CMD.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     PERFORM 7300-FETCH-A-GEN.
     IF FETCH-ERROR GO TO 0080-FINISH-A-VID-UPDT.
     MOVE A-RCD TO GEN-RDT.
     REWRITE VID-REC INVALID KEY
             DISPLAY "? PROG REWRITE ERR AT 0280, VID " VID-SYM-KEY
             GO TO 0070-ABORT-A-VID-UPDT.
     GO TO 0080-FINISH-A-VID-UPDT.
*
 0290-CHANGE-RPG.
     DISPLAY D-VID WITH NO ADVANCING.  ACCEPT A-VID.
     DISPLAY D-NEW WITH NO ADVANCING.  ACCEPT A-RPG.
     IF A-RPG < 1 OR > MAX-REELS
        DISPLAY "? RPG MUST BE > 1 THRU "  MAX-REELS
        GO TO 0050-GET-CMD.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     MOVE A-RPG TO VID-RPG.
 0292-CHANGE-HDR.
     REWRITE VID-REC INVALID KEY
         DISPLAY "? PROG REWRITE ERR AT 0290, VID=" VID-SYM-KEY
         GO TO 0070-ABORT-A-VID-UPDT.
     GO TO 0080-FINISH-A-VID-UPDT.
*
 0295-CHANGE-MRS.
     DISPLAY D-VID WITH NO ADVANCING.  ACCEPT A-VID.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR  GO TO 0070-ABORT-A-VID-UPDT.
     DISPLAY D-NEW WITH NO ADVANCING.  ACCEPT A-VID.
     IF NOT VID-SCRATCH
         DISPLAY " MIN-REEL-SIZE MUST BE A SCRATCH VID"
         MOVE SORRY TO DELAYED-FATALITY
         MOVE KEY-VID TO A-VID
         GO TO 0080-FINISH-A-VID-UPDT.
     MOVE A-VID TO VID-MRS.  MOVE KEY-VID TO A-VID.
     GO TO 0292-CHANGE-HDR.
*
 0300-DELETE SECTION 3.
 0310-DELETE.
     DISPLAY D-WHT WITH NO ADVANCING.  ACCEPT A-WHT.
     IF WHT-SCRATCH  GO TO 0320-DELETE-SCR.
     IF WHT-VID      GO TO 0330-DELETE-VID.
     IF A-WHT = "#$%"
         DISPLAY " IF YOU'RE PLAYING AROUND, QUIT IT!"
         DISPLAY D-WHT WITH NO ADVANCING
         ACCEPT A-WHT
         IF A-WHT = "%$#" GO TO 0900-CATALOG.
     DISPLAY "? MUST BE SCRATCH OR VID".
     GO TO 0050-GET-CMD.
 0320-DELETE-SCR.
     DISPLAY D-VOL WITH NO ADVANCING.  ACCEPT A-VOL.
     IF NOT VOL-VALID DISPLAY "? INVALID VOLUME"
                      GO TO 0050-GET-CMD.
     PERFORM 7500-FETCH-OLD-VID.
     IF FETCH-ERROR GO TO 0050-GET-CMD.
     MOVE VOL-KEY TO HOLD-VOL-KEY.
     IF NOT VID-SCRATCH
           MOVE A-VOL TO X-4
           DISPLAY "? "  X-4 " NOT A SCRATCH, VID=" A-VID
            GO TO 0050-GET-CMD.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     MOVE A-VID TO WS-VID.
     MOVE A-GEN TO WS-GEN.
     PERFORM 6000-EXTRACT-GEN.
     IF EXTRACT-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     MOVE SPACES TO VOL-REC.
     MOVE HOLD-VOL-KEY TO VOL-KEY.
     WRITE VOL-REC INVALID KEY
           DISPLAY "? INVALID WRITE AT 0320, VOL " VOL-KEY
           GO TO 0070-ABORT-A-VID-UPDT.
     GO TO 0080-FINISH-A-VID-UPDT.
 0330-DELETE-VID.
     DISPLAY D-VID WITH NO ADVANCING.  ACCEPT A-VID.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     MOVE 1 TO KEY-GEN.
     READ VID INVALID KEY GO TO 0340-DELETE-VID-OK.
     DISPLAY "? " A-VID " NOT EMPTY".
     GO TO 0080-FINISH-A-VID-UPDT.
 0340-DELETE-VID-OK.
     MOVE 0 TO KEY-GEN.
     DELETE VID-REC INVALID KEY
            DISPLAY "? PROG DELETE ERR AT 0340, VID " VID-SYM-KEY
            GO TO 0070-ABORT-A-VID-UPDT.
     GO TO 0070-ABORT-A-VID-UPDT.
*
 0400-ASSIGN SECTION 4.
 0410-ASSIGN.
     DISPLAY D-WHT WITH NO ADVANCING.  ACCEPT A-WHT.
     IF WHT-VOLUME   GO TO 0420-ASSIGN-VOL.
     IF WHT-SCRATCH  GO TO 0430-ASSIGN-SCR.
     DISPLAY "? MUST BE VOLUME OR SCRATCH".
     GO TO 0050-GET-CMD.
 0420-ASSIGN-VOL.
     DISPLAY D-VOL WITH NO ADVANCING.  ACCEPT A-VOL.
     IF NOT VOL-VALID
        DISPLAY "? INVALID VOLUME"
        GO TO 0050-GET-CMD.
     PERFORM 7500-FETCH-OLD-VID.
     IF FETCH-ERROR GO TO 0050-GET-CMD.
     IF NOT VID-SCRATCH
        DISPLAY "? " A-VOL " NOT A SCRATCH"
        GO TO 0050-GET-CMD.
     MOVE A-VID TO SCR-VID.
     MOVE A-GEN TO SCR-GEN.
     GO TO 0440-ASSIGN-IT.
 0430-ASSIGN-SCR.
     DISPLAY D-SIZ WITH NO ADVANCING.  ACCEPT A-VID.
     IF NOT VID-SCRATCH
        DISPLAY "? INVALID SIZE"
        GO TO 0050-GET-CMD.
     MOVE A-VID TO SCR-VID.
     MOVE 1     TO SCR-GEN.
 0440-ASSIGN-IT.
     DISPLAY D-VID WITH NO ADVANCING.  ACCEPT A-VID.
     DISPLAY D-GEN WITH NO ADVANCING.  ACCEPT A-GEN.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     PERFORM 7800-ASSIGN-THIS-SCRATCH.
     IF ASSIGN-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     GO TO 0080-FINISH-A-VID-UPDT.
*
 0500-SCRATCH SECTION 5.
 0510-SCRATCH.
     MOVE 0 TO FIRST-REEL-SW.
         ALTER 0560-GEN-DELETED TO PROCEED TO 0080-FINISH-A-VID-UPDT.
     DISPLAY D-WHT WITH NO ADVANCING.  ACCEPT A-WHT.
     IF WHT-REEL
        ALTER 0540-SCRATCH-DONE TO PROCEED TO 0080-FINISH-A-VID-UPDT
        GO TO 0520-SCRATCH-PARMS.
     IF WHT-GEN
        ALTER 0540-SCRATCH-DONE TO PROCEED TO 0530-SCRATCH-REEL
        GO TO 0520-SCRATCH-PARMS.
     IF WHT-EXPIRED
         ALTER 0560-GEN-DELETED TO PROCEED TO 0580-NEXT-READ
         ALTER 0540-SCRATCH-DONE TO PROCEED TO 0530-SCRATCH-REEL
        GO TO 0570-SCRATCH-EXP.
     DISPLAY "? MUST BE REEL OR GENERATION OR EXPIRED".
     GO TO 0050-GET-CMD.
*
 0520-SCRATCH-PARMS.
     DISPLAY D-VID WITH NO ADVANCING.  ACCEPT A-VID.
     DISPLAY D-GEN WITH NO ADVANCING.  ACCEPT A-GEN.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
*
 0530-SCRATCH-REEL.
     PERFORM 7300-FETCH-A-GEN.
     IF FETCH-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     MOVE 1 TO REEL-NDX.
     SEARCH GEN-REEL
            AT END COMPUTE REEL-NDX = MAX-REELS + 1
            WHEN   GEN-VOL (REEL-NDX) < 1 NEXT SENTENCE.
     SUBTRACT 1 FROM REEL-NDX.
     IF REEL-NDX < 1 GO TO 0550-DELETE-GEN.
     IF REEL-NDX = 1 MOVE 1 TO FIRST-REEL-SW.
     MOVE GEN-SIZ (REEL-NDX) TO SCR-SIZ.
     MOVE GEN-VOL (REEL-NDX) TO   A-VOL.
     MOVE 0 TO GEN-SIZ (REEL-NDX).
     MOVE 0 TO GEN-VOL (REEL-NDX).
     MOVE GEN-DATE TO WS-DATE.
     MOVE GEN-TIME TO WS-TIME.
     MOVE GEN-WHO TO WS-WHO.
     REWRITE VID-REC INVALID KEY
             DISPLAY "? PROG REWRITE ERR AT 0530, VID=" VID-SYM-KEY
             GO TO 0080-FINISH-A-VID-UPDT.
     MOVE  9999 TO A-DIS.
     PERFORM 7600-BUILD-SCRATCH-WS.
     PERFORM 5000-INSERT-GEN.
     IF INSERT-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     IF FIRST-REEL-SCRATCHED GO TO 0530-SCRATCH-REEL.
 0540-SCRATCH-DONE.
     GO TO.
 0550-DELETE-GEN.
     MOVE VID-REC-KEY TO WS-REC-KEY.
     PERFORM 6000-EXTRACT-GEN.
     IF EXTRACT-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     IF NOT WHT-EXPIRED GO TO 0560-GEN-DELETED.
     MOVE HOLD-REC-KEY TO VID-SYM-KEY.
     READ VID INVALID KEY
          DISPLAY "? PROG READ ERR AT 0550, VID " VID-SYM-KEY
          GO TO 0080-FINISH-A-VID-UPDT.
 0560-GEN-DELETED.
     GO TO.

 0570-SCRATCH-EXP.
     IF NOT SCRATCH-EXP-OK
        DISPLAY "? MUST FIRST TYPE ALL EXPIRED GENERATIONS"
        GO TO 0050-GET-CMD.
     OPEN I-O  VID  VOL  .
 0580-NEXT-READ.
     MOVE LOW-VALUES TO VID-SYM-KEY.
     READ VID INVALID KEY GO TO 0070-ABORT-A-VID-UPDT.
     IF VID-GEN = 0
         MOVE VID-REC-KEY TO HOLD-REC-KEY
         MOVE VID-RCD TO A-RCD  
         GO TO 0580-NEXT-READ.
     IF (GEN-RDT < TODAYS-DATE)
     OR (A-RCD < 0 AND (VID-GEN + A-RCD) > 0)
        MOVE VID-VID TO A-VID
        COMPUTE A-GEN = 0 - VID-GEN
        GO TO 0530-SCRATCH-REEL.
     GO TO 0580-NEXT-READ.
*
 0600-SWAP SECTION 6.
 0610-SWAP.
     ALTER 0630-SWAP-SWITCH TO PROCEED TO 0640-SWAP-1.
 0620-SWAP-PARMS.
     DISPLAY D-VOL WITH NO ADVANCING.  ACCEPT A-VOL.
     IF NOT VOL-VALID
        DISPLAY "? INVALID VOLUME"
        GO TO 0050-GET-CMD.
     PERFORM 7500-FETCH-OLD-VID.
     IF FETCH-ERROR GO TO 0050-GET-CMD.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     PERFORM 7300-FETCH-A-GEN.
     IF FETCH-ERROR GO TO 0080-FINISH-A-VID-UPDT.
     MOVE 1 TO REEL-NDX.
     SEARCH GEN-REEL
            AT END DISPLAY "? VOL " A-VOL " NOT FOUND IN " VID-SYM-KEY
                   GO TO 0070-ABORT-A-VID-UPDT
            WHEN GEN-VOL (REEL-NDX) = A-VOL NEXT SENTENCE.
     DISPLAY "*** VID=" A-VID " GEN=" A-GEN " REEL=" REEL-NDX.
 0630-SWAP-SWITCH.
     GO TO.
 0640-SWAP-1.
     MOVE GEN-REEL (REEL-NDX) TO VOL-1.
     MOVE A-VID    TO VID-1.
     MOVE A-GEN    TO GEN-1.
     MOVE REEL-NDX TO REEL-1.
     PERFORM 7050-END-A-VID-UPDT.
     IF  END-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     ALTER 0630-SWAP-SWITCH TO PROCEED TO 0650-SWAP-2.
     GO TO 0620-SWAP-PARMS.
 0650-SWAP-2.
     MOVE GEN-REEL (REEL-NDX) TO VOL-2.
     MOVE A-VID    TO VID-2.
     MOVE A-GEN    TO GEN-2.
     MOVE REEL-NDX TO REEL-2.
     PERFORM 7050-END-A-VID-UPDT.
     IF END-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     DISPLAY "CONTINUE?=" WITH NO ADVANCING. ACCEPT ANS.
     IF ANS NOT = "YES" GO TO 0050-GET-CMD.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     IF VID-1 NOT = VID-2
         CLOSE VOL VID
         MOVE VID-1 TO A-VID
         PERFORM 7000-START-A-VID-UPDT
         IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
 0655-BEGIN-1.
     ALTER 0670-SWAP-DONE TO PROCEED TO 0675-BEGIN-2.
     MOVE VOL-2 TO VOL-X.
     MOVE VID-1 TO A-VID.
     MOVE GEN-1 TO A-GEN.
     MOVE REEL-1 TO REEL-NDX.
 0660-SWAP-IT.
     PERFORM 7300-FETCH-A-GEN.
     IF FETCH-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     MOVE VOL-X TO GEN-REEL (REEL-NDX).
     MOVE A-VID TO VOL-VID.
     MOVE A-GEN TO VOL-GEN.
     MOVE GEN-VOL (REEL-NDX) TO VOL-KEY.
     REWRITE VID-REC INVALID KEY
             DISPLAY "? PROG REWRITE ERR AT 0660, VID " VID-SYM-KEY
             GO TO 0070-ABORT-A-VID-UPDT.
     WRITE VOL-REC INVALID KEY
           DISPLAY "? PROG WRITE ERR AT 0660, VOL " VOL-KEY
           GO TO 0070-ABORT-A-VID-UPDT.
 0670-SWAP-DONE.
     GO TO.
 0675-BEGIN-2.
     ALTER 0670-SWAP-DONE TO PROCEED TO 0680-SWAPPING-COMPLETE.
     MOVE VOL-1 TO VOL-X.
     MOVE VID-2 TO A-VID.
     MOVE GEN-2 TO A-GEN.
     MOVE REEL-2 TO REEL-NDX.
     GO TO 0660-SWAP-IT.
 0680-SWAPPING-COMPLETE.
     PERFORM 7050-END-A-VID-UPDT.
     IF END-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     IF VID-1 NOT = VID-2
         MOVE VID-1 TO A-VID
         OPEN  I-O      VID  VOL  
         PERFORM 7050-END-A-VID-UPDT
         IF END-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     DISPLAY "*** SWAPPED ***".
     GO TO 0050-GET-CMD.
*
 0700-TYPE SECTION 7.
 0710-TYPE.
     DISPLAY D-WHT WITH NO ADVANCING.  ACCEPT A-WHT.
     IF WHT-VOLUME   GO TO 0720-TYPE-VOL.
     IF WHT-VID      GO TO 0730-TYPE-VID.
     IF WHT-SCRATCH  GO TO 0745-TYPE-SCR.
     IF WHT-EXPIRED  GO TO 0760-TYPE-EXP.
     DISPLAY "? MUST BE VOLUME OR VID OR SCRATCH OR EXPIRED".
     GO TO 0050-GET-CMD.
*
 0720-TYPE-VOL.
     DISPLAY D-VOL WITH NO ADVANCING.  ACCEPT A-VOL.
     IF NOT VOL-VALID
        DISPLAY "? INVALID VOLUME"
        GO TO 0050-GET-CMD.
     PERFORM 7500-FETCH-OLD-VID.
     IF FETCH-ERROR GO TO 0050-GET-CMD.
     IF A-VID = SPACES 
         MOVE A-VOL TO X-4
         DISPLAY "NO SUCH VOL=" X-4
         GO TO 0050-GET-CMD.
     OPEN INPUT  VID.
     PERFORM 7300-FETCH-A-GEN.
     CLOSE  VID.
     IF FETCH-ERROR GO TO 0050-GET-CMD.
     MOVE 1 TO REEL-NDX.
     SEARCH GEN-REEL
            AT END MOVE 0 TO REEL-NDX
            WHEN   A-VOL = GEN-VOL (REEL-NDX)  NEXT SENTENCE.
     DISPLAY " ".
     PERFORM 0780-LOAD-BODY.
     DISPLAY " VID  " BODY-HDR "REEL".
     DISPLAY VID-VID  BODY  REEL-NDX.
     IF REEL-NDX = 0
        DISPLAY "? PROG ERR AT 0720, VOL " A-VOL " NOT IN "
                VID-SYM-KEY.
     GO TO 0050-GET-CMD.
*
 0730-TYPE-VID.
     DISPLAY D-VID WITH NO ADVANCING.  ACCEPT A-VID.
     MOVE SPACES TO ANS  A-CMD.
     OPEN INPUT  VID  VOL.
     MOVE A-VID TO KEY-VID.
     MOVE 0     TO KEY-GEN.
     READ VID INVALID KEY
              DISPLAY "NO SUCH VID " A-VID GO TO 0740-TYPE-VID-DONE.
     MOVE VID-CUR-CMD TO A-CMD.
     DISPLAY " ".
     MOVE VID-RCD TO D-RCDX.
     DISPLAY "RCD:" D-RCDX.
     DISPLAY "RPG: " VID-RPG.
     DISPLAY "MRS: " VID-MRS.
     DISPLAY " VOL" BODY-HDR.
 0734-TYPE-VID-LOOP-1.
     ADD 1 TO KEY-GEN.
     READ VID INVALID KEY GO TO 0740-TYPE-VID-DONE.
     MOVE 1 TO REEL-NDX I.
     PERFORM 0780-LOAD-BODY.
     MOVE GEN-VOL(REEL-NDX) TO X-4.
     DISPLAY X-4 BODY.
 0736-TYPE-VID-LOOP-2.
     IF GEN-VOL(REEL-NDX) = 0 GO TO 0738-TYPE-VID-INC.
     MOVE GEN-VOL(REEL-NDX) TO VOL-KEY.
     READ VOL INVALID KEY
          MOVE "ERR" TO ANS
          DISPLAY " PROG READ ERR AT 0736, VOL=" VOL-KEY
          GO TO 0738-TYPE-VID-INC.
     IF VOL-REC NOT = VID-SYM-KEY
        MOVE "ERR" TO ANS
        DISPLAY " PROG ERR AT 0736, VOL-REC=" VOL-REC
                " VID-KEY=" VID-SYM-KEY.
 0738-TYPE-VID-INC.
     ADD 1 TO REEL-NDX.
     IF REEL-NDX > MAX-REELS  GO TO 0734-TYPE-VID-LOOP-1.
     IF GEN-VOL(REEL-NDX) = 0 GO TO 0736-TYPE-VID-LOOP-2.
     MOVE GEN-VOL(REEL-NDX) TO X-4.
     DISPLAY X-4.
     IF REEL-NDX NOT = (I + 1)
        DISPLAY "? PROG ERR AT 0738, GAP BETWEEN REELS " I
                " AND " REEL-NDX.
     MOVE REEL-NDX TO I.
     GO TO 0736-TYPE-VID-LOOP-2.
 0740-TYPE-VID-DONE.
     CLOSE  VOL  VID.
     IF (A-CMD = SPACES) AND (ANS = SPACES) GO TO 0050-GET-CMD.
     DISPLAY " LAST " A-CMD " COMMAND INCOMPLETE ON VID " A-VID.
     IF ANS NOT = SPACES
         DISPLAY " AND THE CATALOG IS MESSED UP"
         DISPLAY SORRY
         GO TO 0050-GET-CMD.
     DISPLAY " BUT THE CATALOG IS OK".
     MOVE 0 TO KEY-GEN.
     OPEN I-O VID VOL.
     READ VID INVALID KEY
              DISPLAY "? PROG READ ERR AT 0740, VID-KEY=" VID-SYM-KEY
              GO TO 0742-VID-CLEARED.
     MOVE SPACES TO VID-CUR-CMD.
     REWRITE VID-REC INVALID KEY
                     DISPLAY "? PROG WRITE ERR AT 0740, VID-KEY="
                             VID-SYM-KEY
                     GO TO 0742-VID-CLEARED.
     DISPLAY " YOU MAY NOW USE VID " A-VID.
 0742-VID-CLEARED.
     CLOSE VOL VID.
     GO TO 0050-GET-CMD.

*
 0745-TYPE-SCR.
     OPEN INPUT  VID.
     DISPLAY " VID   NUMBER".
     MOVE "0300FT" TO KEY-VID  PERFORM 0747-TYPE-SCR-COUNT.
     MOVE "0600FT" TO KEY-VID  PERFORM 0747-TYPE-SCR-COUNT.
     MOVE "1200FT" TO KEY-VID  PERFORM 0747-TYPE-SCR-COUNT.
     MOVE "2400FT" TO KEY-VID  PERFORM 0747-TYPE-SCR-COUNT.
     CLOSE VID.
     GO TO 0050-GET-CMD.
 0747-TYPE-SCR-COUNT.
     MOVE 1 TO I.
     PERFORM 0749-TYPE-SCR-RD
             VARYING KEY-GEN FROM 1 BY 1 UNTIL I = 0.
     SUBTRACT 2 FROM KEY-GEN.
     DISPLAY KEY-VID "  " KEY-GEN.
 0749-TYPE-SCR-RD.
     READ VID INVALID KEY MOVE 0 TO I.
*
 0760-TYPE-EXP.
     DISPLAY D-VID WITH NO ADVANCING.  ACCEPT A-VID.
     IF VID-ALL
          MOVE 1 TO TYPE-EXP-SW
          MOVE LOW-VALUE TO VID-SYM-KEY
     ELSE MOVE A-VID TO KEY-VID
          MOVE 0     TO KEY-GEN.
     OPEN INPUT  VID.
     DISPLAY " VOL" BODY-HDR "   VID      RCD".
 0765-TYPE-EXP-LOOP-1.
     READ VID INVALID KEY
              CLOSE  VID
              GO TO 0050-GET-CMD.
     IF NOT VID-ALL ADD 1 TO KEY-GEN.
     IF VID-GEN = 0
         MOVE 1 TO FIRST-GEN-SW
        MOVE VID-VID TO A-LDV
        MOVE VID-RCD TO A-RCD
        GO TO 0765-TYPE-EXP-LOOP-1.
     IF (GEN-RDT < TODAYS-DATE)
     OR (A-RCD < 0 AND (VID-GEN + A-RCD) > 0)  NEXT SENTENCE
     ELSE GO TO 0765-TYPE-EXP-LOOP-1.
     MOVE 1 TO REEL-NDX.
     PERFORM 0780-LOAD-BODY.
     MOVE GEN-VOL(REEL-NDX) TO X-4.
     DISPLAY X-4  BODY WITH NO ADVANCING.
     IF FIRST-GEN
         MOVE 0 TO FIRST-GEN-SW
         MOVE A-RCD TO D-RCDX
          DISPLAY "  " A-LDV " " D-RCDX
     ELSE DISPLAY " ".
 0770-TYPE-EXP-LOOP-2.
     ADD 1 TO REEL-NDX.
     IF REEL-NDX > MAX-REELS  GO TO 0765-TYPE-EXP-LOOP-1.
     IF GEN-VOL (REEL-NDX) = 0 GO TO 0770-TYPE-EXP-LOOP-2.
     MOVE GEN-VOL(REEL-NDX) TO X-4.
     DISPLAY X-4.
     GO TO 0770-TYPE-EXP-LOOP-2.
*
 0780-LOAD-BODY.
     COMPUTE B-GEN = 0 - VID-GEN.
     MOVE GEN-CNT TO B-CNT.
     MOVE GEN-WHO TO B-WHO.
     MOVE GEN-DATE TO WS-RDT.
     MOVE YY TO B-CRE-YY.
     MOVE MM TO B-CRE-MM.
     MOVE DD TO B-CRE-DD.
     MOVE GEN-TIME TO WS-TIME.
     MOVE HH TO B-CRE-HH.
     MOVE MIN TO B-CRE-MIN.
     MOVE GEN-RDT TO WS-RDT.
     MOVE YY TO B-RDT-YY.
     MOVE MM TO B-RDT-MM.
     MOVE DD TO B-RDT-DD.
*
 0800-REPORT SECTION 8.
 0810-REPORT.
     MOVE SPACES TO DELAYED-FATALITY.
     OPEN OUTPUT RPT.
     OPEN INPUT VID  VOL.
     INITIATE VOL-RPT.
     MOVE SPACES TO VOL-LINE.
     MOVE 1 TO VE-SUB.
     MOVE 0 TO VE-HIT  VOL-KEY.
     GO TO 0840-REPORT-VOL-RD.
 0830-REPORT-VOL-CLR.
     MOVE 0 TO VE-SUB  VE-HIT.
     MOVE SPACES TO VOL-LINE.
 0840-REPORT-VOL-RD.
     ADD 1 TO VOL-KEY  VE-SUB.
     READ VOL INVALID KEY GO TO 0850-REPORT-VID.
     IF VOL-REC NOT = SPACES
         PERFORM 7900-VERIFY-VOL-VID
         ADD 1 TO VE-HIT
         COMPUTE VE-GEN(VE-SUB) = 0 - VOL-GEN
         MOVE VOL-VID TO VE-VID(VE-SUB).
     IF VE-SUB < 10  GO TO 0840-REPORT-VOL-RD.
     IF VE-HIT < 1   GO TO 0830-REPORT-VOL-CLR.
     COMPUTE VOL-10 = VOL-KEY / 10.
     GENERATE VOL-DET.
     GO TO 0830-REPORT-VOL-CLR.
*
 0850-REPORT-VID.
     IF VE-HIT > 0  GENERATE VOL-DET.
     TERMINATE VOL-RPT.
     CLOSE VOL VID.
     OPEN INPUT VID VOL.
     INITIATE VID-RPT.
     MOVE LOW-VALUE TO VID-SYM-KEY OLD-VID.
 0860-REPORT-VID-RD.
     READ VID INVALID KEY  GO TO 0870-REPORT-DONE.
     IF VID-GEN = 0
         MOVE VID-VID TO A-VID
         MOVE VID-RCD TO A-RCD
         MOVE VID-CUR-CMD TO A-CMD
         IF VID-CUR-CMD NOT = SPACES
             DISPLAY " INCOMPLETE COMMAND " VID-CUR-CMD " ON VID "
                      VID-VID
             MOVE SORRY TO DELAYED-FATALITY
             GO TO 0860-REPORT-VID-RD
         ELSE GO TO 0860-REPORT-VID-RD.
     COMPUTE A-GEN = 0 - VID-GEN.
     IF (GEN-RDT < TODAYS-DATE)
     OR (A-RCD < 0 AND (VID-GEN + A-RCD) > 0)
          MOVE "*" TO EXP-AST
     ELSE MOVE " " TO EXP-AST.
     GENERATE VID-DET.
     GO TO 0860-REPORT-VID-RD.
 0870-REPORT-DONE.
     TERMINATE VID-RPT.
     CLOSE  VOL  VID.
     DISPLAY DELAYED-FATALITY.
     GO TO 0050-GET-CMD.
*
 0900-CATALOG SECTION 9.
 0910-CATALOG.
     DISPLAY D-VID WITH NO ADVANCING.  ACCEPT A-VID.
     DISPLAY D-GEN WITH NO ADVANCING.  ACCEPT A-GEN.
     IF A-CMD = "DEL" GO TO 0920-SKIP.
     DISPLAY D-DIS WITH NO ADVANCING.  ACCEPT A-DIS.
     IF NOT DIS-VALID
        DISPLAY "? INVALID DISPOSITION"
        GO TO 0050-GET-CMD.
 0920-SKIP.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     PERFORM 7300-FETCH-A-GEN.
     IF FETCH-ERROR GO TO 0080-FINISH-A-VID-UPDT.
     MOVE VID-REC-KEY TO WS-REC-KEY.
     PERFORM 6000-EXTRACT-GEN.
     IF EXTRACT-ERROR GO TO 0070-ABORT-A-VID-UPDT.

     IF A-CMD = "DEL" GO TO 0080-FINISH-A-VID-UPDT.
     IF A-DIS < 0 MOVE A-DIS TO WS-GEN.
     PERFORM 5000-INSERT-GEN.
     IF INSERT-ERROR  GO TO 0070-ABORT-A-VID-UPDT.
     GO TO 0080-FINISH-A-VID-UPDT.
*
 1000-MOUNT SECTION 10.
 1010-MOUNT.
     DISPLAY D-LDV WITH NO ADVANCING.  ACCEPT A-LDV.
     DISPLAY D-VID WITH NO ADVANCING.  ACCEPT A-VID.
     DISPLAY D-GEN WITH NO ADVANCING.  ACCEPT A-GEN.
     DISPLAY D-DIS WITH NO ADVANCING.  ACCEPT A-DIS.
     DISPLAY D-USE WITH NO ADVANCING.  ACCEPT A-USE.
     DISPLAY D-WHO WITH NO ADVANCING.  ACCEPT A-WHO.
     IF VID-SCRATCH
        DISPLAY "? INVALID VID"
        GO TO 0050-GET-CMD.
     IF NOT DIS-VALID
        DISPLAY "? INVALID DISPOSITION"
        GO TO 0050-GET-CMD.
     IF NOT USE-INPUT AND NOT USE-OUTPUT
        DISPLAY "? INVALID USE, MUST BE INPUT OR OUTPUT"
        GO TO 0050-GET-CMD.
     PERFORM 7000-START-A-VID-UPDT.
     IF START-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     MOVE VID-RCD TO A-RCD.
     MOVE VID-CUR-GEN TO OLD-CNT  NEW-CNT.
     MOVE VID-RPG TO A-RPG.
     IF A-GEN NOT = 0 GO TO 1015-MOUNT-IT.
     IF NOT USE-OUTPUT
        DISPLAY " CANNOT MOUNT SCRATCH FOR INPUT"
        MOVE SORRY TO DELAYED-FATALITY
        GO TO 0080-FINISH-A-VID-UPDT.
     MOVE A-RPG TO SCR-GEN.
     MOVE 9999  TO A-GEN.
     IF VID-MRS = SPACES MOVE "2400FT" TO SCR-VID
     ELSE                MOVE VID-MRS TO SCR-VID.
 1012-NN00FT.
     PERFORM 7800-ASSIGN-THIS-SCRATCH.
     IF ASSIGN-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     IF NO-SCRATCHES GO TO 1014-NEXT-FT.
     SUBTRACT 1 FROM SCR-GEN.
     IF SCR-GEN > 0 GO TO 1012-NN00FT.
     GO TO 1015-MOUNT-IT.
 1014-NEXT-FT.
     IF SCR-SIZ < 06  MOVE 06 TO SCR-SIZ ELSE
     IF SCR-SIZ < 12  MOVE 12 TO SCR-SIZ ELSE
     IF SCR-SIZ < 24  MOVE 24 TO SCR-SIZ ELSE
         MOVE SORRY TO DELAYED-FATALITY
         GO TO 0080-FINISH-A-VID-UPDT.
     GO TO 1012-NN00FT.
 1015-MOUNT-IT.
     PERFORM 7300-FETCH-A-GEN.
     IF FETCH-ERROR GO TO 0080-FINISH-A-VID-UPDT.
     MOVE A-LDV TO CMD-LDV-ID.   OPEN OUTPUT CMD.
     MOVE " MTA: " TO CMD-MTA.
     MOVE A-LDV    TO CMD-LDV.
     MOVE " /REELID:" TO CMD-REELID.
     MOVE " /VID:" TO CMD-VID.
     MOVE SPACES   TO CMD-REELS.
     MOVE "/"      TO CMD-SLSH.
     IF USE-INPUT  MOVE "WLOCK " TO CMD-RW.
     IF USE-OUTPUT MOVE "WENABL" TO CMD-RW.
     PERFORM 1030-GET-REELS
             VARYING I FROM 1 BY 1 UNTIL I > MAX-REELS.
     MOVE CMD-REELS TO CMD-RID.
     WRITE CMD-REC.
     CLOSE CMD.
     MOVE VID-REC-KEY TO WS-REC-KEY.
     PERFORM 6000-EXTRACT-GEN.
     IF EXTRACT-ERROR GO TO 0070-ABORT-A-VID-UPDT.
     IF A-DIS < 0 MOVE A-DIS TO WS-GEN.
     IF USE-INPUT GO TO 1020-MOUNT-SKIP.
     PERFORM 7200-CALC-RDT.
     IF OLD-CNT = 9999 MOVE 1 TO NEW-CNT
     ELSE      COMPUTE NEW-CNT = OLD-CNT + 1.
     MOVE NEW-CNT TO WS-CNT.
     MOVE TODAYS-DATE TO WS-DATE.
     MOVE TODAYS-TIME TO WS-TIME.
     MOVE A-WHO TO WS-WHO.
 1020-MOUNT-SKIP.
     PERFORM 5000-INSERT-GEN.
     IF INSERT-ERROR  GO TO 0070-ABORT-A-VID-UPDT.
     MOVE WS-CNT TO X-4.
     DISPLAY "CATALOGED -" HOLD-GEN "(" X-4 ") VOL=" CMD-REELS.
     GO TO 0080-FINISH-A-VID-UPDT.
*
 1030-GET-REELS.
     IF GEN-VOL(I) = 0 MOVE 99 TO I
     ELSE MOVE GEN-VOL(I) TO CMD-VOL(I)
          COMPUTE J = I - 1
          IF J > 0 MOVE "-" TO CMD-FIL(J).
*
 1100-EXIT SECTION.
 1110-EXIT.
     STOP RUN.
*
 5000-INSERT-GEN SECTION.
 5010-INSERT.
     MOVE 1 TO INSERT-SW.
     MOVE WS-VID TO KEY-VID.
     MOVE 0      TO KEY-GEN.
     READ VID INVALID KEY
              DISPLAY "? NO SUCH VID " KEY-VID
              GO TO 5060-INSERT-EXIT.
 5020-FIND-BOTTOM.
     ADD 1 TO KEY-GEN. MOVE KEY-GEN TO NEW-GEN.
     IF KEY-GEN > MAX-GEN GO TO 5060-INSERT-EXIT.
     READ VID INVALID KEY GO TO 5030-SHIFT-DOWN.
     GO TO 5020-FIND-BOTTOM.
 5030-SHIFT-DOWN.
     SUBTRACT 1 FROM KEY-GEN.
     IF WS-GEN > KEY-GEN  GO TO 5040-INSERT-IT.
     READ VID INVALID KEY
              DISPLAY "? PROG READ ERR AT 5030, VID " VID-SYM-KEY
              GO TO 5060-INSERT-EXIT.
     PERFORM 5050-WRITE-IT.
     SUBTRACT 1 FROM KEY-GEN.
     GO TO 5030-SHIFT-DOWN.
 5040-INSERT-IT.
     MOVE WS-VID-REC TO VID-REC.
 5050-WRITE-IT.
     ADD 1 TO KEY-GEN. MOVE KEY-GEN TO VID-GEN HOLD-GEN.
     PERFORM 7100-UPDT-VOL.
     IF UPDT-VOL-ERROR GO TO 5060-INSERT-EXIT.
     IF KEY-GEN < NEW-GEN
          REWRITE VID-REC INVALID KEY
             DISPLAY "? PROG REWRITE ERR AT 5050, VID " VID-SYM-KEY
             GO TO 5060-INSERT-EXIT
     ELSE WRITE   VID-REC INVALID KEY
             DISPLAY "? PROG WRITE ERR AT 5050, VID " VID-SYM-KEY
             GO TO 5060-INSERT-EXIT.
 5055-INSERT-DONE.
     MOVE 0 TO INSERT-SW.
 5060-INSERT-EXIT.
     EXIT.
*
*
 6000-EXTRACT-GEN SECTION.
 6010-EXTRACT.
     MOVE 1 TO EXTRACT-SW.
     MOVE WS-VID TO KEY-VID.
     MOVE WS-GEN TO KEY-GEN.
     READ VID INVALID KEY
              IF A-CMD = "CHA" AND WHT-VID
                  GO TO 6050-EXTRACT-EXIT
              ELSE
              DISPLAY "? NO SUCH GEN=-" KEY-GEN " VID=" KEY-VID
              GO TO 6050-EXTRACT-EXIT.
     MOVE VID-REC TO WS-VID-REC.
 6020-SHIFT-UP.
     ADD 1 TO KEY-GEN.
     READ VID INVALID KEY GO TO 6030-DELETE-BOTTOM.
     SUBTRACT 1 FROM KEY-GEN.  MOVE KEY-GEN TO VID-GEN.
     PERFORM 7100-UPDT-VOL.
     IF UPDT-VOL-ERROR GO TO 6050-EXTRACT-EXIT.
     REWRITE VID-REC INVALID KEY
             DISPLAY "? PROG REWRITE ERR AT 6020, VID=" VID-SYM-KEY
             GO TO 6050-EXTRACT-EXIT.
     ADD 1 TO KEY-GEN.
     GO TO 6020-SHIFT-UP.
 6030-DELETE-BOTTOM.
     SUBTRACT 1 FROM KEY-GEN.
     DELETE VID-REC INVALID KEY
            DISPLAY "? PROG DELETE ERR AT 6030, VID "VID-SYM-KEY
            GO TO 6050-EXTRACT-EXIT.
 6040-EXTRACT-DONE.
     MOVE 0 TO EXTRACT-SW.
 6050-EXTRACT-EXIT.
     EXIT.
*
 7000-START-A-VID-UPDT SECTION.
 7010-START-A-VID.
     OPEN I-O  VID  VOL.
     MOVE A-VID TO KEY-VID.
     MOVE 0     TO KEY-GEN.
     MOVE 1 TO START-SW.
     MOVE SPACES TO DELAYED-FATALITY.
     READ VID INVALID KEY
              DISPLAY "? NO SUCH VID=" KEY-VID
              GO TO 7030-START-EXIT.
     IF VID-CUR-CMD NOT = SPACES
        DISPLAY "? LAST " VID-CUR-CMD " COMMAND INCOMPLETE ON VID "
                  KEY-VID
        GO TO 7030-START-EXIT.
     MOVE A-CMD TO VID-CUR-CMD.
     REWRITE VID-REC INVALID KEY
             DISPLAY "? PROG REWRITE ERR AT 7010, VID "VID-SYM-KEY
             GO TO 7030-START-EXIT.
 7020-START-DONE.
     MOVE 0 TO START-SW.
 7030-START-EXIT.
     EXIT.
*
 7050-END-A-VID-UPDT SECTION.
 7060-END-A-VID.
     MOVE 1 TO END-SW.
     MOVE A-VID TO KEY-VID.
     MOVE 0     TO KEY-GEN.
     READ VID INVALID KEY
              DISPLAY "? NO SUCH VID=" KEY-VID
              GO TO 7080-END-EXIT.
     IF VID-CUR-CMD = "MOU" MOVE NEW-CNT TO VID-CUR-GEN.
     MOVE SPACES TO VID-CUR-CMD.
     REWRITE VID-REC INVALID KEY
             DISPLAY "? PROG REWRITE ERR AT 7060, VID "VID-SYM-KEY
             GO TO 7080-END-EXIT.
 7070-END-DONE.
     MOVE 0 TO END-SW.
 7080-END-EXIT.
     CLOSE  VOL  VID.
     IF DELAYED-FATALITY NOT = SPACES 
         DISPLAY DELAYED-FATALITY
         MOVE SPACE TO DELAYED-FATALITY.
*
*
 7100-UPDT-VOL SECTION.
 7110-UPDT-VOL.
     MOVE 1 TO UPDT-VOL-SW  REEL-NDX.
 7120-UPDT-VOL-LOOP.
     SEARCH GEN-REEL
            AT END GO TO 7130-UPDT-VOL-DONE
            WHEN GEN-VOL  (REEL-NDX) > 0  NEXT SENTENCE.
     MOVE GEN-VOL  (REEL-NDX) TO VOL-KEY.
     MOVE VID-REC-KEY TO VOL-REC.
     WRITE VOL-REC INVALID KEY
           DISPLAY "? PROG WRITE ERR AT 7120, VOL " VOL-KEY
           GO TO 7140-UPDT-VOL-EXIT.
     ADD 1 TO REEL-NDX.
     GO TO 7120-UPDT-VOL-LOOP.
 7130-UPDT-VOL-DONE.
     MOVE 0 TO UPDT-VOL-SW.
 7140-UPDT-VOL-EXIT.
     EXIT.
*
 7200-CALC-RDT SECTION.
 7210-CALC-RDT.
     IF RCD-GENS
        MOVE 999999 TO WS-RDT
        GO TO 7250-CALC-RDT-EXIT.
     IF RCD-YR-VALID AND RCD-MO-VALID AND RCD-DY-VALID
        MOVE A-RCD TO WS-RDT
        GO TO 7250-CALC-RDT-EXIT.
     MOVE TODAYS-DATE TO WS-RDT.
     DIVIDE 4 INTO YY GIVING I REMAINDER J.
     IF J = 0
        MOVE 29 TO FEB.
     COMPUTE I = YY + A-RCD-YR.
     COMPUTE J = MM + A-RCD-MO.
     COMPUTE K = DD + A-RCD-DY.
     IF RCD-YR-ZERO AND RCD-MO-ZERO  GO TO 7220-ADD-DY.
     IF RCD-YR-ZERO AND RCD-DY-ZERO  GO TO 7230-ADD-MO.
     IF RCD-MO-ZERO AND RCD-DY-ZERO  GO TO 7240-ADD-YR.
     MOVE 0 TO WS-RDT.
     GO TO 7250-CALC-RDT-EXIT.
 7220-ADD-DY.
     IF K > MO-SZ(MM)
        SUBTRACT MO-SZ(MM) FROM K
        ADD 1 TO J
        GO TO 7220-ADD-DY.
     MOVE K TO DD.
 7230-ADD-MO.
     IF J > 12
        SUBTRACT 12 FROM J
        ADD 1 TO I
        GO TO 7230-ADD-MO.
     IF J NOT = MM
        MOVE J TO MM
        GO TO 7220-ADD-DY.
 7240-ADD-YR.
     IF I > 99 MOVE 99 TO YY
     ELSE      MOVE I  TO YY.
 7250-CALC-RDT-EXIT.
     MOVE 28 TO FEB.
*
 7300-FETCH-A-GEN SECTION.
 7310-FETCH.
     MOVE 1 TO FETCH-SW  KEY-GEN.
     MOVE A-VID TO KEY-VID.
     IF GEN-LEVEL GO TO 7320-FETCH-LEVEL.
     IF GEN-COUNT GO TO 7330-FETCH-COUNT.
     DISPLAY " INVALID GENERATION".
     MOVE SORRY TO DELAYED-FATALITY.
     GO TO 7360-FETCH-EXIT.
 7320-FETCH-LEVEL.
     MOVE A-GEN TO KEY-GEN.
     READ VID INVALID KEY GO TO 7340-FETCH-FAIL.
     GO TO 7350-FETCH-DONE.
 7330-FETCH-COUNT.
     READ VID INVALID KEY GO TO 7340-FETCH-FAIL.
     IF A-GEN = GEN-CNT   GO TO 7350-FETCH-DONE.
     ADD 1 TO KEY-GEN.
     GO TO 7330-FETCH-COUNT.
 7340-FETCH-FAIL.
     DISPLAY " NO SUCH VID=" A-VID " GEN=" A-GEN.
     MOVE SORRY TO DELAYED-FATALITY.
     GO TO 7360-FETCH-EXIT.
 7350-FETCH-DONE.
     MOVE 0 TO FETCH-SW.
 7360-FETCH-EXIT.
     EXIT.
*
 7400-FETCH-A-VOL SECTION.
 7410-FETCH.
     MOVE 1 TO FETCH-SW.
     MOVE A-VOL TO VOL-KEY.
     READ VOL INVALID KEY
              DISPLAY "? PROG READ ERR AT 7410, VOL " VOL-KEY
              GO TO 7420-FETCH-VOL-EXIT.
     MOVE 0 TO FETCH-SW.
 7420-FETCH-VOL-EXIT.
     EXIT.
*
 7500-FETCH-OLD-VID SECTION.
 7510-FETCH.
     OPEN INPUT VOL.
     PERFORM 7400-FETCH-A-VOL.
     MOVE VOL-VID TO A-VID.
     COMPUTE A-GEN = 0 - VOL-GEN.
     CLOSE VOL.
*
 7600-BUILD-SCRATCH-WS SECTION.
 7610-BUILD-SCRATCH.
     MOVE SCR-VID     TO WS-VID.
     MOVE A-DIS       TO WS-GEN.
     MOVE 999999      TO WS-RDT.
     MOVE 0           TO WS-CNT.
     MOVE ALL ZEROES  TO WS-REELS.
     COMPUTE WS-REEL (1) = A-VOL + 10000 * SCR-SIZ.
*
 7700-CREATE-LOW-GEN SECTION.
 7710-CREATE-LOW-GEN.
     MOVE A-VID TO WS-VID.
     MOVE 9999  TO WS-GEN.
     MOVE 999999 TO WS-RDT.
     MOVE 0      TO WS-CNT.
     MOVE 0      TO WS-DATE.
     MOVE 0      TO WS-TIME.
     MOVE SPACES TO WS-WHO.
     MOVE ALL ZEROES TO WS-REELS.
     PERFORM 5000-INSERT-GEN.
     COMPUTE A-GEN = 0 - KEY-GEN.
*
 7800-ASSIGN-THIS-SCRATCH SECTION.
 7810-ASSIGN-THIS-SCRATCH.
     MOVE 1 TO ASSIGN-SW.
     IF VID-SCRATCH
        DISPLAY " INVALID VID"
        MOVE SORRY TO DELAYED-FATALITY
        GO TO 7830-ASSIGN-EXIT.
     MOVE SCR-VID TO KEY-VID.
     MOVE SCR-GEN TO KEY-GEN.
     READ VID INVALID KEY
              DISPLAY "NO " SCR-VID " SCRATCHES"
              MOVE 2 TO ASSIGN-SW
              GO TO 7830-ASSIGN-EXIT.
     MOVE A-VID   TO KEY-VID.
     MOVE A-GEN   TO KEY-GEN.
     READ VID INVALID KEY PERFORM 7700-CREATE-LOW-GEN.
     MOVE SCR-VID TO WS-VID.
     MOVE SCR-GEN TO WS-GEN.
     PERFORM 6000-EXTRACT-GEN.
     IF EXTRACT-ERROR GO TO 7830-ASSIGN-EXIT.
     MOVE WS-REEL(1) TO A-VOL.
     IF A-VOL = 0
        DISPLAY "? PROG ERR AT 7810, VOL=0 AT " VID-SYM-KEY
        GO TO 7830-ASSIGN-EXIT.
     MOVE A-VID   TO KEY-VID.
     MOVE A-GEN   TO KEY-GEN.
     READ VID INVALID KEY
              DISPLAY "? PROG RD ERR AT 7810, VID=" VID-SYM-KEY
              GO TO 7830-ASSIGN-EXIT.
     MOVE 1 TO REEL-NDX.
     SEARCH GEN-REEL
         AT END DISPLAY " MAX " MAX-REELS " PER GENERATION"
                MOVE SORRY TO DELAYED-FATALITY
                GO TO 7830-ASSIGN-EXIT
         WHEN GEN-VOL (REEL-NDX) = 0  NEXT SENTENCE.
     MOVE SCR-SIZ TO GEN-SIZ (REEL-NDX).
     MOVE   A-VOL TO GEN-VOL (REEL-NDX).
     IF REEL-NDX = 1
         MOVE WS-DATE TO GEN-DATE
         MOVE WS-TIME TO GEN-TIME
         MOVE WS-WHO  TO GEN-WHO.
     REWRITE VID-REC INVALID KEY
         DISPLAY "? PROG REWRITE ERR AT 7810, VID=" VID-SYM-KEY
         GO TO 7830-ASSIGN-EXIT.
     MOVE KEY-VID TO VOL-VID.
     MOVE KEY-GEN TO VOL-GEN.
     MOVE A-VOL TO VOL-KEY.
     WRITE VOL-REC INVALID KEY
         DISPLAY "? PROG WRITE ERR AT 7810, VOL=" VOL-KEY
         GO TO 7830-ASSIGN-EXIT.
 7820-ASSIGN-DONE.
     MOVE 0 TO ASSIGN-SW.
     MOVE A-VOL TO X-4.
     DISPLAY SCR-VID " VOL=" X-4 " ASSIGNED TO " KEY-VID.
 7830-ASSIGN-EXIT.
     EXIT.

 7900-VERIFY-VOL-VID SECTION.
 7910-VERIFY-VOL-VID.
     MOVE VOL-REC TO VID-SYM-KEY
     READ VID INVALID KEY GO TO 7930-NO-MATCHING-VID-REC.
     IF KEY-GEN = 0   GO TO 7940-VID-HDR-REC.
     SET REEL-NDX TO 1.
     SEARCH GEN-REEL AT END GO TO 7920-VOL-NOT-IN-GEN
                     WHEN GEN-VOL (REEL-NDX) = VOL-KEY GO TO 7960-EXIT.
 7920-VOL-NOT-IN-GEN.
     DISPLAY " VOL " VOL-KEY " NOT IN " VID-SYM-KEY.
     GO TO 7950-ERROR-EXIT.
 7930-NO-MATCHING-VID-REC.
     DISPLAY " NO MATCHING VID RECORD " VID-SYM-KEY " FOR VOL " VOL-KEY.
     GO TO 7950-ERROR-EXIT.
 7940-VID-HDR-REC.
     DISPLAY " VOL RECORD " VOL-KEY " POINTING TO VID HEADER "
             VID-SYM-KEY.
 7950-ERROR-EXIT.
     MOVE SORRY TO DELAYED-FATALITY.
 7960-EXIT.    EXIT.