Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0081/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.