Google
 

Trailing-Edge - PDP-10 Archives - iqlv30 - iqd.cbl
There are 2 other files named iqd.cbl in the archive. Click here to see a list.
000100 IDENTIFICATION DIVISION.
000120
000140 PROGRAM-ID.    IQD.
000160
000180 DATE-WRITTEN.  1976.
000200 DATE-COMPILED. 1976.
000220
000240 SECURITY.      COPYRIGHT 1976 AZREX INC. ALL RIGHTS RESERVED.
000260 REMARKS.       THIS IS VERSION 3.0 OF THE DICTIONARY GENERATOR
000280                FOR THE IQL3 SYSTEM.
000360
000380 ENVIRONMENT DIVISION.
000400 CONFIGURATION SECTION.
000420 SOURCE-COMPUTER. DECSYSTEM-10.
000440 OBJECT-COMPUTER. DECSYSTEM-10.
000460 SPECIAL-NAMES.   CHANNEL (1) IS TOP-OF-PAGE
000480                  CONSOLE IS TTY.
000500
000520 INPUT-OUTPUT SECTION.
000540 FILE-CONTROL.
000560     SELECT QPDICT ASSIGN TO DSK.
000580     SELECT QTDICT ASSIGN TO DSK.
000600     SELECT QCDICT ASSIGN TO DSK.
000620     SELECT QLDICT ASSIGN TO DSK.
000640
000660 DATA DIVISION.
000680
000700 FILE SECTION.
000720
000740 FD  QPDICT
000760     VALUE OF IDENTIFICATION IS QPDICTSEQ
000780     LABEL RECORDS ARE STANDARD
000800     BLOCK CONTAINS 0 RECORDS
000820     RECORD CONTAINS 150 CHARACTERS
000840     DATA RECORD IS DICT-REC.
000860 01  DICT-REC                PIC X(150) USAGE IS DISPLAY-7.
000880
000900 FD  QLDICT
000920     VALUE OF IDENTIFICATION IS QL001DLPT
000940     LABEL RECORDS ARE STANDARD
000960     BLOCK CONTAINS 0 RECORDS
000980     RECORD CONTAINS 132 CHARACTERS
001000     DATA RECORD IS PRINT-LINE.
001020 01  PRINT-LINE USAGE IS DISPLAY-7.
001040     02 PRINT-LN             PIC X(132).
001060
001080 FD  QCDICT
001100     VALUE OF IDENTIFICATION IS QC001DTMP
001120     LABEL RECORDS ARE STANDARD
001140     BLOCK CONTAINS 0 RECORDS
001160     DATA RECORD IS TRANSACTION-REC.
001180 01  TRANSACTION-REC         PIC X(120) USAGE IS DISPLAY-7.
001200
001220 FD  QTDICT
001240     VALUE OF IDENTIFICATION IS QT001DTMP
001260     LABEL RECORDS ARE STANDARD
001280     BLOCK CONTAINS 0 RECORDS
001300     RECORD CONTAINS 150 CHARACTERS
001320     DATA RECORD IS WORK-REC.
001340 01  WORK-REC                PIC X(150) USAGE IS DISPLAY-7.
001360
001380 WORKING-STORAGE SECTION.
001390 01  UNIVERSAL-PASSWORD      PIC X(12) VALUE 'DRAGON      '.
001400 01  COPY-LEVEL              PIC 99 VALUE 0.
001420 01  CURRENT-CF-NAME         PIC X(30).
001440 01  CURRENT-DF-NAME         PIC X(30).
001460 01  DASH                    PIC X VALUE '-'.
001480 01  PAGE-CTR                PIC 9(3)  VALUE 0.
001500 01  PW-REF-SUM              PIC 9(3) VALUE 0.
001520 01  PW-TEXT-HOLDER          PIC X(12).
001540 01  LINE-CTR                PIC 99  VALUE 0.
001560 01  LINE-MAX                PIC 99 VALUE 54.
001580 01  ELEM-CHAR               PIC X VALUE SPACE DISPLAY-7.
001600 01  FOUND-FD-TRAN           PIC S9(10) COMP VALUE 0.
001620 01  FOUND-ENTRY             PIC S9(10) COMP VALUE 0.
001640 01  FOUND-FD                PIC S9(10) COMP VALUE 0.
001660 01  FOUND-DICT              PIC S9(10) COMP VALUE 0.
001680 01  FOUND-NON-FD-FLAG       PIC S9(10) COMP VALUE 0.
001700 01  1ST-NTRY-FLAG           PIC S9(10) COMP VALUE 0.
001720 01  FURNISHED-UNLOCKER      PIC X(6).
001740 01  HOLD-TRAN-FLAG          PIC S9(10) COMP VALUE 0.
001760 01  DICT-EOF                PIC S9(10) COMP VALUE 0.
001780 01  DICT-LOCK               PIC S9(10) COMP VALUE 0.
001800 01  I                       PIC S9(4) COMP VALUE 0.
001820 01  IGNORE-RECORD-FLAG      PIC S9(10) COMP VALUE 0.
001840 01  J                       PIC S9(10) COMP VALUE 0.
001860 01  JOB-NO                  PIC S9(3) COMP VALUE 1.
001880 01  K                       PIC S9(10) COMP VALUE 0.
001900 01  L                       PIC S9(10) COMP VALUE 0.
001904 01  M                       PIC S9(10) COMP VALUE 0.
001920 01  LOOK-CYCLE              PIC 9 VALUE 0.
001940 01  TRAN-ERR-FLG            PIC 9 VALUE 0.
001960*77  MAX-RECLEN              PIC 9(4) VALUE 2600.
001980*77  MIN-RECLEN              PIC 9(4) VALUE 15.
002000*77  MAX-BLKFACT             PIC 9(4) VALUE 7200.
002020 01  MAX-EDIT                PIC 99 VALUE 20.
002040 01  EDIT-ERROR-FLAG         PIC S9(10) COMP VALUE 0.
002060 01  TEMPFTX                 PIC X.
002080 01  TEMPNUMFT REDEFINES TEMPFTX
002100                             PIC 9.
002120 01  MAX-KEYLEN              PIC 9(3) VALUE 30.
002140 01  MAX-ITEMLEN             PIC 9(4) VALUE 50.
002160 01  CURRENT-FILENAME        PIC X(30).
002180 01  TRAN-FILE-FLAG          PIC S9(10) COMP VALUE 0.
002200 01  DICT-FILE-FLAG          PIC S9(10) COMP VALUE 0.
002220 01  WORK-FILE-FLAG          PIC S9(10) COMP VALUE 0.
002240 01  PRINT-FILE-FLAG         PIC S9(10) COMP VALUE 0.
002244 01  PROTECTED-LEVEL         PIC 99 VALUE 0.
002260 01  RETURN-FLAG             PIC S9(10) COMP.
002310 01  UNLOCKED-LEVEL          PIC 99 VALUE 0.
002315 01  UNLOCKED-WORK           PIC 99 VALUE 0.
002340 01  WORK-1                  PIC 9(4) VALUE 0.
002360 01  WORK-2                  PIC 9(8) VALUE 0.
002380
002400**FILE NAME CONSTRUCTORS FOLLOW**
002420
002440 01  QC001DTMP.
002460     02  FILLER              PIC X(2) VALUE 'QC'.
002480     02  QC001DNO            PIC 9(3) VALUE 1.
002500     02  FILLER              PIC X(4) VALUE 'DTMP'.
002520 01  QT001DTMP.
002540     02  FILLER              PIC X(2) VALUE 'QT'.
002560     02  QT001DNO            PIC 9(3) VALUE 1.
002580     02  FILLER              PIC X(4) VALUE 'DTMP'.
002600 01  QL001DLPT.
002620     02  FILLER              PIC X(2) VALUE 'QL'.
002640     02  QL001DNO            PIC 9(3) VALUE 1.
002660     02  FILLER              PIC X(4) VALUE 'DLPT'.
002680 01  QPDICTSEQ               PIC X(9) VALUE 'QPDICTSEQ'.
002700 01  DEVICER                 PIC X(6) VALUE SPACE.
002720 01  PROJ                    PIC S9(8) COMP VALUE 0.
002740 01  USER                    PIC S9(8) COMP VALUE 0.
002760 01  CALLED-NAME             PIC X(6) USAGE IS DISPLAY-6.
002780 01  TOP-TITLE DISPLAY-7.
002800     02  TOP-TITLE-CHAR      PIC X OCCURS 10 TIMES
002820                             INDEXED BY TTX.
002840 01  BOTTOM-TITLE DISPLAY-7.
002860     02  BOTTOM-TITLE-CHAR   PIC X OCCURS 10 TIMES
002880                             INDEXED BY BTX.
002900 01  PICT-REDEF.
002920     02  PICTCHAR            PIC X OCCURS 19 TIMES
002940                             INDEXED BY PIX.
002960 01  SCANTABLE.
002980     02  N-SCANITEMS         PIC 9(3) VALUE 0.
003000     02  SCANTABLEINFO OCCURS 100 TIMES.
003020       03  GROUP-NAME-TAB    PIC X.
003040       03  GROUP-LEN-TAB     PIC 9(3).
003060 01  DATE-CONV.
003080     02  YR-IN               PIC 99.
003100     02  MO-IN               PIC 99.
003120     02  DA-IN               PIC 99.
003140     02  FILLER              PIC X(38).
003160 01  DATE-MASK.
003180     02  MON                 PIC 99.
003200     02  SLSH1               PIC X VALUE '/'.
003220     02  DAYY                PIC 99.
003240     02  SLSH2               PIC X VALUE '/'.
003260     02  YEAR                PIC 99.
003280 01  DATE-WORK.
003300     02  WMON                PIC XX.
003320     02  WDAY                PIC XX.
003340     02  WYEAR               PIC XX.
003360 01  PACKED-DATE.
003380     02  PMON                PIC XX.
003400     02  PDAY                PIC XX.
003420     02  PYEAR               PIC XX.
003440 01  SLASHED-DATE.
003460     02  SMON                PIC XX.
003480     02  FILLER              PIC X VALUE '/'.
003500     02  SDAY                PIC XX.
003520     02  FILLER              PIC X VALUE '/'.
003540     02  SYEAR               PIC XX.
003560 01  NUMEDX4                 PIC 9(4).
003580 01  NUMEDXANGRP REDEFINES NUMEDX4.
003600     02  FILLER              PIC XX.
003620     02  NUMEDXAN            PIC 99.
003640 01  NUMEDXGRP REDEFINES NUMEDX4.
003660     02  FILLER              PIC XX.
003680     02  NUMEDX              PIC 99.
003700 01  TRAN-MESSAGE USAGE IS DISPLAY-7.
003720     02  FILLER              PIC X(8) VALUE ' TRANS- '.
003740     02  TRAN-LINE           PIC X(120).
003760     02  FILLER              PIC X(4) VALUE SPACE.
003780
003800 01  PICTURE-TABLE.
003820     02  PICT1               PIC X(15) VALUE '999-99-9999'.
003840     02  PICT2               PIC X(15) VALUE 'SZZZ9.99'.
003860     02  PICT3               PIC X(15) VALUE '999-9999'.
003880     02  PICT4               PIC X(15) VALUE '9999 9999'.
003900     02  PICT5               PIC X(15) VALUE 'SZ9.99'.
003920     02  PICT6               PIC X(15) VALUE 'SZZ9.99'.
003940     02  PICT7               PIC X(15) VALUE '99-99-99'.
003960     02  PICT8               PIC X(15) VALUE 'SZZZZ9'.
003980     02  PICT9               PIC X(15) VALUE 'SZZZZ9.99'.
004000     02  PICT10              PIC X(15) VALUE 'SZZZZZ9.99999'.
004020     02  PICT11              PIC X(15)
004040                             VALUE 'ZZZZZZZZZZZZZZZ'.
004060     02  PICT12              PIC X(15) VALUE 'SZZZZZ9.99'.
004080     02  PICT13              PIC X(15) VALUE 'SZZZZZZ9.99'.
004100     02  PICT14              PIC X(15) VALUE 'SZZZ9.999'.
004120     02  PICT15              PIC X(15) VALUE 'ZZZZZ9.99'.
004140     02  PICT16              PIC X(15) VALUE 'S9.99'.
004160     02  PICT17              PIC X(15) VALUE 'SZZZZZZZ'.
004180     02  PICT18              PIC X(15) VALUE 'SZ9.999'.
004200     02  PICT19              PIC X(15) VALUE 'SZZZZZ9'.
004220     02  PICT20              PIC X(15) VALUE 'SZZZZZZ9.99'.
004240     02  PICT21              PIC X(15) VALUE 'XX-XXXX-X'.
004260     02  PICT22              PIC X(15) VALUE 'X-XXX-XX'.
004280     02  PICT23              PIC X(15) VALUE 'ZZZ.999'.
004300     02  PICT24              PIC X(15) VALUE 'S9.999'.
004320     02  PICT25              PIC X(15) VALUE 'SZZZZZZZZ'.
004340     02  PICT26              PIC X(15) VALUE 'SZZZZZZZZZ'.
004360     02  PICT27              PIC X(15) VALUE 'SZZZZZZZZZZ'.
004380     02  PICT28              PIC X(15) VALUE 'SZZZZZZZ9.99'.
004400     02  PICT29              PIC X(15) VALUE '.999999'.
004420     02  PICT30              PIC X(15) VALUE 'SZZZZZZZZ9.99'.
004440 01  PICT-TAB REDEFINES      PICTURE-TABLE.
004460     02 IQ-PICTURE PIC X(15) OCCURS 30 TIMES.
004480
004500 01  HOLD-WS                 PIC X(150).
004520
004540**INPUT FORMATS FOR DICTIONARY TRANSACTIONS FOLLOWS**
004560
004580 01  TRAN-WS DISPLAY-7.
004600     02  TRAN-FD.
004620         04  CF-IDNT         PIC XX.
004640         04  CF-ACT          PIC X.
004660         04  CF-NAME         PIC X(30).
004680         04  CF-INLABEL      PIC X(9).
004700         04  FILLER          PIC X(8).
004720         04  CF-DIRECT       PIC X(19).
004740         04  CF-FILETYPE-X   PIC X.
004760         04  CF-FILETYPE REDEFINES CF-FILETYPE-X
004780                             PIC 9.
004800         04  CF-RECLEN-X    PIC X(4).
004820         04  CF-RECLEN  REDEFINES CF-RECLEN-X
004840                             PIC 9(4).
004860         04  CF-BLKFACT-X    PIC X(4).
004880         04  CF-BLKFACT REDEFINES CF-BLKFACT-X
004900                             PIC S9(4).
004920         04  CF-KEYPOS-X     PIC X(4).
004940         04  CF-KEYPOS REDEFINES CF-KEYPOS-X
004960                             PIC 9(4).
004980         04  CF-KEYLEN-X     PIC XXX.
005000         04  CF-KEYLEN REDEFINES CF-KEYLEN-X
005020                             PIC 9(3).
005040         04  CF-KEYTYPE-X    PIC X.
005060         04  CF-KEYTYPE REDEFINES CF-KEYTYPE-X
005080                             PIC 9.
005100         04  CF-KEYSIGN      PIC X.
005120         04  CF-PROT-READ    PIC XX.
005140         04  CF-PROT-COPY    PIC XX.
005160         04  CF-PROT-REWR    PIC XX.
005180         04  FILLER          PIC X(21).
005200         04  CF-PASSWORD     PIC X(6).
005220
005240     02  TRAN-PD REDEFINES TRAN-FD.
005260         04  CP-IDNT         PIC XX.
005280         04  CP-ACT          PIC X.
005300         04  CP-PROT-NO      PIC 99.
005320         04  CP-PROT-NO-X REDEFINES CP-PROT-NO
005340                             PIC XX.
005360         04  CP-DATE-FLAG    PIC X.
005380         04  CP-LINE         PIC 9.
005400         04  CP-LINE-X REDEFINES CP-LINE
005420                             PIC X.
005440         04  CP-TEXT.
005460             06  CP-PASSWORD.
005480                 08  CP-CHAR PIC X OCCURS 6 TIMES.
005500                 08  FILLER  PIC X(6).
005520         04  FILLER          PIC X(101).
005540
005560     02  TRAN-DD REDEFINES TRAN-FD.
005580         04  CD-IDNT         PIC XX.
005600         04  CD-ACT          PIC X.
005620         04  CD-NAME.
005640             06  CD-NME2.
005660                 08  CD-NME1 PIC X.
005680                 08  FILLER  PIC X.
005700             06  FILLER      PIC X(28).
005720         04  CD-TITLE1       PIC X(10).
005740         04  CD-TITLE2       PIC X(10).
005760         04  CD-FCHAR-X      PIC X(4).
005780         04  CD-FCHAR REDEFINES CD-FCHAR-X
005800                             PIC 9(4).
005820         04  CD-NCHARS-X     PIC X(4).
005840         04  CD-NCHARS REDEFINES CD-NCHARS-X
005860                             PIC 9(4).
005880         04  CD-TYPE         PIC 9.
005900         04  CD-TYPE-X REDEFINES CD-TYPE
005920                             PIC X.
005940         04  CD-SCALE        PIC 9.
005960         04  CD-SCALE-X REDEFINES CD-SCALE
005980                             PIC X.
006000         04  CD-OFFSET       PIC 9.
006020         04  CD-OFFSET-X REDEFINES CD-OFFSET
006040                             PIC X.
006060         04  CD-EDIT-X       PIC XX.
006080         04  CD-EDIT REDEFINES CD-EDIT-X
006100                             PIC 99.
006120         04  CD-PICT         PIC X(19).
006140         04  FILLER REDEFINES CD-PICT.
006160             06  CD-PICTCHAR PIC X OCCURS 19 TIMES.
006180         04  CD-SCANINFO.
006200             06 CD-GRPNME    PIC X.
006220             06 CD-NREPEATS  PIC 99.
006240             06 CD-NREPEATS-X REDEFINES CD-NREPEATS
006260                             PIC XX.
006280             06 CD-STOPPER   PIC X.
006300         04  CD-PROTINFO.
006320             06  CD-PROT-NO  PIC 99.
006340             06  CD-PROT-NO-X REDEFINES CD-PROT-NO
006360                             PIC XX.
006380             06  CD-EXCLFLAG PIC X.
006400         04  CD-NOUPD        PIC X.
006420         04  FILLER          PIC X(27).
006440     02  TRAN-CD REDEFINES TRAN-FD.
006460         04  CC-IDNT         PIC XX.
006480         04  CC-ACT          PIC X.
006500         04  CC-NO           PIC XX.
006520         04  CC-TEXT         PIC X(115).
006540     02  TRAN-RD REDEFINES TRAN-FD.
006560         04  RD-IDNT         PIC XX.
006580         04  RD-ACT          PIC X.
006600         04  RD-NAME         PIC X(30).
006620         04  RD-ORIGIN       PIC 9(4).
006640         04  RD-ORIGIN-X REDEFINES RD-ORIGIN
006660                             PIC X(4).
006680         04  RD-LENGTH       PIC 9(4).
006700         04  RD-LENGTH-X REDEFINES RD-LENGTH
006720                             PIC X(4).
006740         04  RD-TYPE         PIC XXX.
006760         04  RD-TEXT         PIC X(76).
006780     02  TRAN-AD REDEFINES TRAN-FD.
006800         04  AD-IDNT         PIC XX.
006820         04  AD-ACT          PIC X.
006840         04  AD-NAME         PIC X(30).
006860         04  AD-ORIGIN       PIC 9(4).
006880         04  AD-ORIGIN-X REDEFINES AD-ORIGIN
006900                             PIC X(4).
006920         04  AD-LENGTH       PIC 9(4).
006940         04  AD-LENGTH-X REDEFINES AD-LENGTH
006960                             PIC X(4).
006980         04  AD-TYPE         PIC XXX.
007000         04  AD-TEXT         PIC X(76).
007020     02  TRAN-SD REDEFINES TRAN-FD.
007040         04  SD-IDNT         PIC XX.
007060         04  SD-ACT          PIC X.
007080         04  SD-NAME         PIC X(30).
007100         04  FILLER          PIC X(8).
007120         04  SD-TYPE         PIC XXX.
007140         04  SD-TEXT         PIC X(76).
007160 01  HOLD-TRAN-FD            PIC X(120) VALUE SPACES
007170                                        DISPLAY-7.
007180 01  LAST-DD-NAME.
007200     02  LAST-DD-CHAR        PIC X OCCURS 30 TIMES.
007220 01  PW-WORKER USAGE IS DISPLAY-6.
007240     02  PW-CHAR             PIC X OCCURS 12 TIMES.
007260 01  PW-WORK REDEFINES PW-WORKER.
007280     02  PW-WORK1            PIC S9(10) COMP.
007300     02  PW-WORK2            PIC S9(10) COMP.
007320 01  PW-MASK1                PIC S9(10) COMP VALUE 14729163.
007340 01  PW-MASK2                PIC S9(10) COMP VALUE -24815212.
007360
007380 01  HOLD-TRAN               PIC X(120) DISPLAY-7.
007400
007420**FORMATS FOR PERMANENT DICTIONARY ENTRIES FOLLOW**
007440
007460 01  DICT-WS DISPLAY-7.
007480     02  DICT-FD.
007500         04  DF-IDNT         PIC XX.
007520         04  DF-NAME         PIC X(30).
007540         04  DF-NDICTS       PIC 9(3).
007560         04  DF-INLABEL      PIC X(17).
007580         04  DF-DIRECT       PIC X(19).
007600         04  DF-FILETYPE     PIC X.
007620         04  DF-RECLEN       PIC 9(4).
007640         04  DF-BLKFACT      PIC S9(4).
007660         04  DF-KEYPOS       PIC 9(4).
007680         04  DF-KEYLEN       PIC 9(3).
007700         04  DF-KEYTYPE      PIC 9.
007720         04  DF-KEYSIGN      PIC 9.
007740         04  DF-PROT         PIC X.
007760         04  DF-PROT-READ    PIC XX.
007780         04  DF-PROT-COPY    PIC XX.
007800         04  DF-PROT-REWR    PIC XX.
007820         04  FILLER          PIC X(48).
007840         04  DF-LAST-UPDATE  PIC X(6).
007860
007880     02  DICT-DD REDEFINES DICT-FD.
007900         04  DD-IDNT         PIC XX.
007920         04  DD-NAME         PIC X(30).
007940         04  DD-TITLE1       PIC X(10).
007960         04  DD-TITLE2       PIC X(10).
007980         04  DD-NTCHARS      PIC 99.
008000         04  DD-NECHARS      PIC 9(4).
008020         04  DD-FCHAR        PIC 9(4).
008040         04  DD-NCHARS       PIC 9(4).
008060         04  DD-TYPE         PIC X.
008080         04  DD-SCALE        PIC 9.
008100         04  DD-OFFSET       PIC 9.
008120         04  DD-EDIT         PIC 99.
008140         04  DD-PICT         PIC X(19).
008160         04  DD-SCANINFO.
008180             06  DD-GRPLEN   PIC 9(3).
008200             06  DD-GRPNME   PIC X.
008220             06  DD-NREPEATS PIC XX.
008240             06  DD-STOPPER  PIC X.
008260         04  DD-PROTINFO.
008280             06  DD-PROT-NO  PIC 99.
008300             06  DD-PROT-NO-X REDEFINES DD-PROT-NO
008320                             PIC XX.
008340             06  DD-EXCLFLAG PIC X.
008360         04  DD-RECTYPE      PIC XXX.
008380         04  DD-NOUPD        PIC X.
008400         04  FILLER          PIC X(40).
008420         04  DD-LAST-UPDATE  PIC X(6).
008440
008460     02  DICT-PD REDEFINES DICT-FD.
008480         04  DP-IDNT         PIC XX.
008500         04  DP-PROT-NO      PIC 99.
008520         04  DP-DATE-FLAG    PIC X.
008540         04  DP-LINE         PIC 9.
008560         04  DP-TEXT.
008580             06  DP-CHAR     PIC X OCCURS 12 TIMES.
008600         04  FILLER          PIC X(126).
008620         04  DP-LAST-UPDATE  PIC X(6).
008640
008660     02  DICT-CD REDEFINES DICT-FD.
008680         04  DC-IDNT         PIC XX.
008700         04  DC-NO           PIC XX.
008720         04  DC-TEXT         PIC X(115).
008740         04  FILLER          PIC X(25).
008760         04  DC-LAST-UPDATE  PIC X(6).
008780
008800     02  DICT-RD REDEFINES DICT-FD.
008820         04  DR-IDNT         PIC XX.
008840         04  DR-NAME         PIC X(30).
008860         04  DR-ORIGIN       PIC 9(4).
008880         04  DR-LENGTH       PIC 9(4).
008900         04  DR-TYPE         PIC XXX.
008920         04  DR-TEXT         PIC X(76).
008940         04  FILLER          PIC X(25).
008960         04  DR-LAST-UPDATE  PIC X(6).
008980
009000     02  DICT-AD REDEFINES DICT-FD.
009020         04  DA-IDNT         PIC XX.
009040         04  DA-NAME         PIC X(30).
009060         04  DA-ORIGIN       PIC 9(4).
009080         04  DA-LENGTH       PIC 9(4).
009100         04  DA-TYPE         PIC XXX.
009120         04  DA-TEXT         PIC X(76).
009140         04  FILLER          PIC X(25).
009160         04  DA-LAST-UPDATE  PIC X(6).
009180
009200     02  DICT-SD REDEFINES DICT-FD.
009220         04  DS-IDNT         PIC XX.
009240         04  DS-NAME         PIC X(30).
009260         04  FILLER          PIC X(8).
009280         04  DS-TYPE         PIC XXX.
009300         04  DS-TEXT         PIC X(76).
009320         04  FILLER          PIC X(25).
009340         04  DS-LAST-UPDATE  PIC X(6).
009360
009380 01  FILE-TYPE-LIST DISPLAY-7.
009400     02  FILLER PIC X(16) VALUE 'Labeled Tape    '.
009420     02  FILLER PIC X(16) VALUE 'Unlabeled Tape  '.
009440     02  FILLER PIC X(16) VALUE 'Rptd Lbld Tape  '.
009460     02  FILLER PIC X(16) VALUE 'Rptd Unlbld Tape'.
009480     02  FILLER PIC X(16) VALUE 'Tran File       '.
009500     02  FILLER PIC X(16) VALUE 'Sixbit Disk- Seq'.
009520     02  FILLER PIC X(16) VALUE 'ASCII Disk-  Seq'.
009540     02  FILLER PIC X(16) VALUE 'DBMS Schema     '.
009560     02  FILLER PIC X(16) VALUE 'Sorted Disk     '.
009580     02  FILLER PIC X(16) VALUE '?Illegal type'.
009600     02  FIllER PIC X(16) VALUE '?Illegal type'.
009620     02  FILLER PIC X(16) VALUE '?Illegal type'.
009640 01  FILE-TYPE REDEFINES FILE-TYPE-LIST DISPLAY-7.
009660     02 TYPE-LIST            PIC X(16) OCCURS 12 TIMES.
009680
009700 01  FD-ERROR-MESSAGES DISPLAY-7.
009720     02  FD-MSG-0            PIC X(57) VALUE
009740     ' %Resulting FD entry may need correction'.
009760*    02  FD-MSG-1            PIC X(57) VALUE
009780*    ' %Record len was too large- changed to system maximum'.
009800*    02  FD-MSG-2            PIC X(57) VALUE
009820*    ' %Record len was too small- changed to system minimum'.
009840*    02  FD-MSG-3            PIC X(53) VALUE
009860*    ' %Block fact for ISAM files must be > 0; set to 1'.
009880*    02  FD-MSG-4            PIC X(53) VALUE
009900*    ' %Block fact was too small- changed to 1'.
009920     02  FD-MSG-5            PIC X(53) VALUE
009940     ' %File type was illegal- changed to 7 (ASCII disk)'.
009960     02  FD-MSG-6            PIC X(48) VALUE
009980     ' %No key position for ISAM file- changed to 1'.
010000     02  FD-MSG-7            PIC X(54) VALUE
010020     ' %Key position outside of ISAM record- changed to 1'.
010040     02  FD-MSG-8            PIC X(41) VALUE
010060     ' %No length for ISAM key- changed to 1'.
010080     02  FD-MSG-9            PIC X(53) VALUE
010100     ' %Length for ISAM key exceeded max- changed to max'.
010120*    02  FD-MSG-10           PIC X(57) VALUE
010140*    ' %Block fact not multiple of rec len - set to 1'.
010160     02  FD-MSG-11.
010180         03  FILLER          PIC XXX VALUE ' %'.
010200         03  FD-NO-NUM       PIC X(12) VALUE SPACE.
010220         03  FILLER          PIC X(31) VALUE
010240         'was not numeric- set to 0'.
010260         02  FD-MSG-12       PIC X(51) VALUE
010280     ' %Key data furnished for non-ISAM file - ignored'.
010300     02  FD-MSG-13           PIC X(54) VALUE
010320     ' %Illegal key type for ISAM file- set to alphabetic'.
010340     02  FD-MSG-14           PIC X(54) VALUE
010360     ' %Illegal key sign for ISAM file- set to unsigned'.
010380     02  FD-MSG-15           PIC X(43) VALUE
010400     ' %Dict name was blank- set to "BAD-NAME"'.
010420     02  FD-MSG-16           PIC X(56) VALUE
010440     ' %0 blocksize only valid for sequential disk files'.
010460
010480 01  DD-ERROR-MSGS DISPLAY-7.
010500     02  DD-MSG-0            PIC X(32) VALUE
010520     ' %DD transaction rejected'.
010540     02  DD-MSG-1            PIC X(28) VALUE
010560     ' %Action code was illegal'.
010580     02  DD-MSG-2            PIC X(35) VALUE
010600     ' %Item name started with X or ZZ'.
010620     02  DD-MSG-3            PIC X(27) VALUE
010640     ' %No first char location'.
010660*    02  DD-MSG-4            PIC X(41) VALUE
010680*    ' %Item partly or all outside of record'.
010700     02  DD-MSG-5            PIC X(19) VALUE
010720     ' %No item length'.
010740*    02  DD-MSG-6            PIC X(37) VALUE
010760*    ' %Item length too long - max is 354'.
010780     02  DD-MSG-7            PIC X(26) VALUE
010800     ' %Item type was illegal'.
010820     02  DD-MSG-8            PIC X(38) VALUE
010840     ' %Scale was larger than item length'.
010860     02  DD-MSG-9            PIC X(26) VALUE
010880     ' %Edit code was illegal'.
010900     02  DD-MSG-10           PIC X(35) VALUE
010920     ' %Had both edit code and picture'.
010940     02  DD-MSG-11           PIC X(45) VALUE
010960     ' %Warning- picture positions/item mismatch'.
010980     02  DD-MSG-12           PIC X(40) VALUE
011000     ' %Picture decimal did not match scale'.
011020     02  DD-MSG-13           PIC X(23) VALUE
011040     ' %No scan group name'.
011060     02  DD-MSG-14           PIC X(39) VALUE
011080     ' %Scan repeats ran outside of record'.
011100     02  DD-MSG-15           PIC X(20) VALUE
011120     ' %No scan repeats'.
011140     02  DD-MSG-16           PIC X(35) VALUE
011160     ' %No PD for referenced protection'.
011180     02  DD-MSG-17           PIC X(37) VALUE
011200     ' %Illegal value for prot excl flag'.
011220     02  DD-MSG-18.
011240         04  FILLER          PIC XXX VALUE  ' %'.
011260         04  DD-NO-NUM       PIC X(30) VALUE SPACE.
011280         04  FILLER          PIC X(17) VALUE
011300         'was not numeric'.
011320     02  DD-MSG-19           PIC X(24) VALUE
011340     ' %Name was all blanks'.
011360     02  DD-MSG-20 PIC X(42) VALUE
011380     ' %Length of member exceeds group length'.
011400     02  PD-MSG-0            PIC X(33) VALUE
011420         ' %PD transaction rejected'.
011440     02  PD-MSG-1            PIC X(35) VALUE
011460         ' %Protection no. was not numeric'.
011480     02  PD-MSG-2            PIC X(38) VALUE
011500        ' %Dict not unlocked for PW changes'.
011520
011540 01  HEAD-1 DISPLAY-7.
011560     02  FILLER              PIC X(61)  VALUE SPACE.
011580     02  H1                  PIC X(13) VALUE SPACE.
011600 01  HEAD-2 DISPLAY-7.
011620     02  H2                  PIC X(7) VALUE ' Date: '.
011640     02  DATEX               PIC X(8).
011660     02  FILLER              PIC X(41) VALUE SPACE.
011680     02  H3                  PIC X(22) VALUE
011700         'IQL Dictionary Listing'.
011720     02  FILLER              PIC X(43) VALUE SPACE.
011740     02  H4                  PIC X(6) VALUE 'Page: '.
011760     02  PAGE-OUT            PIC ZZ9.
011780 01  HEAD-3 DISPLAY-7.
011800     02  FILLER              PIC X(56) VALUE SPACE.
011820     02  H5                  PIC X(22) VALUE
011840         '--- ---------- -------'.
011860 01  HEAD-4 DISPLAY-7.
011880     02  H6                  PIC X(18) VALUE
011900         'File Definition- '.
011920 01  HEAD-5 DISPLAY-7.
011940     02  J5                  PIC X(24) VALUE
011960         'Data Item Definitions -'.
011980 01  FD-HEAD-1 DISPLAY-7.
012000     02  FILLER              PIC X(44) VALUE
012020         '                                            '.
012040     02  FILLER              PIC X(44) VALUE
012060         '                                          Re'.
012080     02  FILLER              PIC X(44) VALUE
012100         'c  Blk  Key  Key K K RD CP WR      Last     '.
012120 01  FD-HEAD-2 DISPLAY-7.
012140     02  FILLER              PIC X(44) VALUE
012160         'Dictionary Name                File in Name '.
012180     02  FILLER              PIC X(44) VALUE
012200         '     PPN                 File type        Lt'.
012220     02  FILLER              PIC X(44) VALUE
012240         'h  Fac  Loc  Lth T S PT PT PT      Updated  '.
012260 01  FD-HYPHS DISPLAY-7.
012280     02  FILLER              PIC X(44) VALUE
012300         '--------------                 ------------ '.
012320     02  FILLER              PIC X(44) VALUE
012340         '     ---------           ---------        --'.
012360     02  FILLER              PIC X(44) VALUE
012380         '-- ---- ---- --- - - -- -- --      -------  '.
012400 01  DD-HEAD1 DISPLAY-7.
012420     02  FILLER              PIC X(47) VALUE
012440         '                                  Top        Bo'.
012460     02  FILLER              PIC X(44) VALUE
012480         'ttom                      S NT Edit Ed Print'.
012500     02  FILLER              PIC X(41) VALUE
012520         'ing            Grp Scan         Last   '.
012540 01  DD-HEAD-2 DISPLAY-7.
012560     02  FILLER              PIC X(47) VALUE
012580         'ID Item name                      Title      Ti'.
012600     02  FILLER              PIC X(44) VALUE
012620         'tle      Type   Loc  Lth  C Ch Lth  Cd Pictu'.
012640     02  FILLER              PIC X(41) VALUE
012660         're             Len G-NN-S Prot  Updated'.
012680 01  DD-HYPHS DISPLAY-7.
012700     02  FILLER              PIC X(47) VALUE
012720         '-- ---------                      -----      --'.
012740     02  FILLER              PIC X(44) VALUE
012760         '---      ----   ---- ---- - -- ---- -- -----'.
012780     02  FILLER              PIC X(41) VALUE
012800         '---            --- - -- - ----  -------  '.
012820
012840**DISPLAY(PRINT) LAYOUTS FOR VARIOUS ENTRIES FOLLOW**.
012860
012880 01  FD-DATA DISPLAY-7.
012900     02  FIL-NM-PRT          PIC X(30).
012920     02  FILLER              PIC X.
012940     02  IN-LAB-PRT          PIC X(17).
012960     02  FILLER              PIC X.
012980     02  DIRECT-PRT          PIC X(19).
013000     02  FILLER              PIC X.
013020     02  FIL-TYP-PRT.
013040         04  FILLER          PIC X(12).
013060         04  FIL-ORG-PRT     PIC X(4).
013080     02  FILLER              PIC X.
013100     02  RECZ-PRT            PIC ZZZ9.
013120     02  FILLER              PIC X.
013140     02  BLKF-PRT            PIC ZZZ9.
013160     02  FILLER              PIC X.
013180     02  KEY-POS-PRT         PIC ZZZ9.
013200     02  FILLER              PIC X.
013220     02  KEY-LEN-PRT         PIC ZZ9.
013240     02  FILLER              PIC X.
013260     02  KEY-TYP-PRT         PIC X.
013280     02  FILLER              PIC X.
013300     02  KEY-SIGN-PRT        PIC X.
013320     02  FILLER              PIC X.
013340     02  FD-PD-READ          PIC XX.
013360     02  FILLER              PIC X.
013380     02  FD-PD-COPY          PIC XX.
013400     02  FILLER              PIC X.
013420     02  FD-PD-REWR          PIC XX.
013440     02  FILLER              PIC X(6).
013460     02  FD-UPDATE-PRT       PIC X(8).
013480
013500 01  DD-DATA REDEFINES FD-DATA DISPLAY-7.
013520     02  DD-DATA-IDNT        PIC XXX.
013540     02  DD-NAME-PRT         PIC X(30).
013560     02  FILLER              PIC X.
013580     02  DD-TITLE1-PRT       PIC X(10).
013600     02  FILLER              PIC X.
013620     02  DD-TITLE2-PRT       PIC X(10).
013640     02  FILLER              PIC X.
013660     02  DD-TYPE-PRT         PIC X(6).
013680     02  FILLER              PIC X.
013700     02  DD-FCHAR-PRT        PIC ZZZZ.
013720     02  DD-FCHAR-PRT-DBS REDEFINES DD-FCHAR-PRT PIC XXXX.
013740     02  FILLER              PIC X.
013760     02  NCHAR-PRT           PIC ZZZZ.
013780     02  FILLER              PIC X.
013800     02  SCL-PRT             PIC Z.
013820     02  FILLER              PIC X.
013840     02  NTCHAR-PRT          PIC ZZ.
013860     02  NOUPD-PRT           PIC X.
013880     02  NECHAR-PRT          PIC ZZZZ.
013900     02  FILLER              PIC X.
013920     02  DD-EDIT-PRT         PIC ZZ.
013940     02  FILLER              PIC X.
013960     02  PICT-PRT            PIC X(19).
013980     02  FILLER              PIC X.
014000     02  GRPLEN-PRT          PIC ZZZ.
014020     02  FILLER              PIC X.
014040     02  SCAN-PRT.
014060         03  GRPNME-PRT      PIC X.
014080         03  DD-SCAN-DASH1   PIC X.
014100         03  NREPEATS-PRT    PIC XX.
014120         03  DD-SCAN-DASH2   PIC X.
014140         03  STOPPER-PRT     PIC X.
014160     02  FILLER              PIC X.
014180     02  PROT-PRT.
014200         03  DP-PRT          PIC XX.
014220         03  DP-PROT-DASH    PIC X.
014240         03  DD-EXCLFLAG-PRT PIC X.
014260     02  FILLER              PIC X(2).
014280     02  DD-UPDATE-PRT       PIC X(8).
014300
014320 01  CD-DATA REDEFINES FD-DATA DISPLAY-7.
014340     02  CD-DATA-IDNT        PIC XXX.
014360     02  FILLER              PIC X.
014380     02  DC-NO-PRT           PIC XX.
014400     02  FILLER              PIC X.
014420     02  DC-TEXT-PRT         PIC X(75).
014440     02  FILLER              PIC X(41).
014460     02  DC-UPDATE-PRT       PIC X(8).
014480
014500 01  RD-DATA REDEFINES FD-DATA DISPLAY-7.
014520     02  RD-DATA-IDNT        PIC XXX.
014540     02  RD-DATA-NAME        PIC X(31).
014560     02  RD-DATA-TEXT        PIC X(28).
014580     02  FILLER              PIC X.
014600     02  RD-DATA-ORIGIN      PIC ZZZ9.
014620     02  FILLER              PIC X.
014640     02  RD-DATA-LENGTH      PIC ZZZ9.
014660     02  FILLER              PIC XX.
014680     02  RD-DATA-TYPE        PIC XXX.
014700     02  FILLER              PIC X(46).
014720     02  RD-DATA-UPDATE      PIC X(8).
014740
014760 01  PD-DATA REDEFINES FD-DATA DISPLAY-7.
014780     02  PD-DATA-IDNT        PIC XXX.
014800     02  DP-TEXT-PRINT       PIC X(12).
014820     02  FILLER              PIC X(19).
014840     02  DP-PROT-NO-PRINT    PIC XX.
014860     02  FILLER              PIC X(87).
014880     02  DP-UPDATE-PRINT     PIC X(8).
014900
014904 01  SIXBIT-SPACES DISPLAY-6 PIC X(90) VALUE SPACES.
014908 01  ASCII-NULLS REDEFINES SIXBIT-SPACES DISPLAY-7.
014912     02  ASCII-NULL          PIC X.
014916     02  FILLER              PIC X(74).
014920
014924 01  CONSOLE-LINE DISPLAY-7.
014924     02  CONSOLE-CHAR        PIC X OCCURS 72.
014930
014940 PROCEDURE DIVISION.
014960
014980*******************************************************
015000* BEGIN PROCESSING
015020*******************************************************
015040 STARTDG.
015060     ENTER MACRO CLRTTY.
015080     ENTER MACRO IQGJOB USING JOB-NO.
015100     MOVE JOB-NO TO QC001DNO QT001DNO QL001DNO.
015120     PERFORM OPEN-PRINT-FILE.
015140     OPEN OUTPUT QTDICT.
015160     CLOSE QTDICT.
015180     MOVE SPACES TO DEVICER.
015200     MOVE 0 TO USER PROJ I.
015220*   *BE SURE THERE ARE TRANSACTIONS TO PROCESS*
015240     ENTER MACRO IQLOOK USING DEVICER QC001DTMP
015260         PROJ USER I.
015280     IF I NOT = -1
015300         MOVE ' %No dictionary transaction input found'
015320         TO PRINT-LINE
015340         PERFORM DISPLAYER THRU DISPLAYER-EXIT
015360         PERFORM PRINT2
015380         PERFORM CLOSE-ALL-FILES
015400         GO TO STOPPER1.
015420*   *IF THERE IS NO QPDICT IN PPN, MAKE ONE*
015440     ENTER MACRO IQLOOK USING DEVICER QPDICTSEQ
015460         PROJ USER I.
015480     IF I NOT = -1
015500         OPEN OUTPUT QPDICT
015520         MOVE 'CD00BEGINNING ENTRY' TO DICT-REC
015540         WRITE DICT-REC
015560         CLOSE QPDICT.
015580     MOVE 0 TO DICT-EOF.
015600     PERFORM OPEN-TRAN-FILE.
015620     MOVE TODAY     TO DATE-CONV.
015640     MOVE YR-IN     TO YEAR.
015660     MOVE MO-IN     TO MON.
015680     MOVE DA-IN     TO DAYY.
015700     MOVE DATE-MASK TO DATEX.
015720     MOVE MON       TO PMON.
015740     MOVE DAYY      TO PDAY.
015760     MOVE YEAR      TO PYEAR.
015780     MOVE 0      TO RETURN-FLAG.
015800 START-TRANS-IN.
015820     READ QCDICT INTO TRAN-WS AT END
015840         PERFORM NEW-PAGE
015860         MOVE ' %Dictionary transaction input was empty'
015880         TO PRINT-LINE
015900         PERFORM DISPLAYER THRU DISPLAYER-EXIT
015920         PERFORM PRINT2
015940         GO TO DICT-RUN-DONE.
015960     MOVE TRAN-WS TO HOLD-TRAN.
015980     IF CF-IDNT = 'FD' MOVE 1 TO FOUND-FD-TRAN
016000         GO TO CENTRAL-DICT-CONTROL.
016020     PERFORM NEW-PAGE.
016040     PERFORM PRINT-TRAN.
016060     MOVE ' %First transaction above was not FD - ignored'
016080         TO PRINT-LINE.
016100     PERFORM PRINT1B.
016120     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
016140     ADD 1 TO LINE-CTR.
016160     GO TO START-TRANS-IN.
016180
016200*****************************
016220* THIS IS CENTRAL LOGIC OF ENTIRE PROGRAM.
016240* CONTROL GOES HERE WHENEVER JUST READ FD TRAN.
016260*****************************
016280 CENTRAL-DICT-CONTROL.
016300     IF FOUND-FD-TRAN NOT = 1 GO TO DICT-RUN-DONE.
016320     MOVE TRAN-FD TO HOLD-TRAN-FD.
016340     MOVE 0 TO N-SCANITEMS.
016360     MOVE CF-NAME TO CURRENT-CF-NAME LAST-DD-NAME.
016380     MOVE 0 TO FOUND-FD-TRAN DICT-LOCK 
016384               UNLOCKED-LEVEL PROTECTED-LEVEL
016386               COPY-LEVEL.
016400     PERFORM NEW-PAGE.
016420     IF CF-ACT = 'P' PERFORM DICT-PRINTER
016440         THROUGH DICT-PRINTER-EXIT
016460         GO TO CENTRAL-DICT-CONTROL.
016480     MOVE CF-NAME TO CURRENT-FILENAME.
016500     IF CF-ACT = 'S' PERFORM DICT-STARTER
016520         THROUGH DICT-STARTER-EXIT
016540         GO TO CENTRAL-DICT-CONTROL.
016560     IF CF-ACT = 'A' PERFORM DICT-ADDER
016580         THROUGH DICT-ADDER-EXIT
016600         GO TO CENTRAL-DICT-CONTROL.
016620     IF CF-ACT = 'D' PERFORM DICT-DELETER
016640         THROUGH DICT-DELETER-EXIT
016660         GO TO CENTRAL-DICT-CONTROL.
016680     IF CF-ACT = 'R' PERFORM DICT-REPLACER
016700         THROUGH DICT-REPLACER-EXIT
016720         GO TO CENTRAL-DICT-CONTROL.
016740     IF CF-ACT = 'C' PERFORM DICT-CHANGER
016760         THROUGH DICT-CHANGER-EXIT
016780         GO TO CENTRAL-DICT-CONTROL.
016800     IF CF-ACT = 'N' PERFORM DICT-NAMES THROUGH DICT-NAMES-EXIT
016820         GO TO CENTRAL-DICT-CONTROL1.
016840     PERFORM PRINT-TRAN.
016860     MOVE ' %Action code in above FD tran is in error -'
016880     TO PRINT-LINE.  PERFORM PRINT1D.
016900     MOVE '    following DD  CD or PD trans ignored'
016920     TO PRINT-LINE. PERFORM DISPLAYER THRU DISPLAYER-EXIT.
016940     PERFORM PRINT1B.
016960 CENTRAL-DICT-CONTROL1.
016980     PERFORM FIND-FD-TRAN THROUGH FIND-FD-TRAN-EXIT.
017000     IF FOUND-FD-TRAN = 1 GO TO CENTRAL-DICT-CONTROL.
017020 DICT-RUN-DONE.
017040     MOVE ' ' TO PRINT-LINE.
017060     PERFORM PRINT1.
017080     MOVE ' (End of dictionary run)' TO PRINT-LINE.
017100     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
017120     PERFORM PRINT0.
017140     MOVE ' ' TO PRINT-LINE.
017160     PERFORM PRINT1B.
017180     PERFORM CLOSE-ALL-FILES.
017200 STOPPER.
017220     OPEN INPUT QTDICT.
017240     CLOSE QTDICT WITH DELETE.
017260 STOPPER1.
017280     MOVE 'IQL   ' TO CALLED-NAME.
017300     ENTER MACRO IQNEXT USING CALLED-NAME.
017320
017340*****************************
017360* SUBROUTINES WHICH FOLLOW CONTROL MASTER EXECUTION OF ACTIONS
017380* IN FD TRANS INPUT FROM TRAN IMAGE FILE.  THEY DRAW IN TURN
017400* UPON THE SUBROUTINES IN THE SUBSEQUENT SECTION.
017420*****************************
017440
017460*****************************
017480* SUBROUTINE TO PRINT OUT ALL OR SELECTED DICTS ON 'P' OPTION
017500* IF THE FD TRAN CONTAINS A NAME  ONLY THIS DICTIONARY WILL BE PRI
017520* IF THE TRAN NAME IS SPACE  ALL DICTIONARIES WILL BE PRINTED.
017540*****************************
017560 DICT-PRINTER.
017580     PERFORM DICT-FINDER THROUGH DICT-FINDER-EXIT.
017600     IF FOUND-DICT NOT = 1 GO TO DICT-PRINTER-ERROR.
017620 DICT-PRINTER-FD.
017640     IF CF-PASSWORD = UNIVERSAL-PASSWORD
017650         MOVE 99 TO UNLOCKED-LEVEL  ELSE
017654         PERFORM DICT-UNLOCKER THRU DICT-UNLOCKER-EXIT
017658         PERFORM DICT-FINDER THRU DICT-FINDER-EXIT.
017700     PERFORM PRINT-FD-HEAD.
017720     PERFORM PRINT-FD-FIELDS THRU PRINT-FD-FIELDS-EXIT.
017740     MOVE 0 TO FOUND-NON-FD-FLAG.
017760 DICT-PRINTER-READ.
017780     READ QPDICT INTO DICT-WS AT END
017800         GO TO DICT-PRINTER-DONE.
017820     IF DF-IDNT NOT = 'FD'
017840         AND FOUND-NON-FD-FLAG NOT = 1
017860         MOVE 1 TO FOUND-NON-FD-FLAG
017880         PERFORM PRINT-DD-HEAD.
017900     IF DF-IDNT = 'DD' OR 'KD' PERFORM PRINT-DD-FIELDS
017920         GO TO DICT-PRINTER-READ.
017940     IF DF-IDNT NOT = 'PD' GO TO DICT-PRINTER-READ1.
017960     MOVE DP-TEXT TO PW-TEXT-HOLDER.
017980     PERFORM UNSCRAMBLE-PW THRU UNSCRAMBLE-PW-EXIT.
018060     MOVE PW-TEXT-HOLDER TO DP-TEXT.
018080     PERFORM PRINT-PD-FIELDS.
018100     GO TO DICT-PRINTER-READ.
018120 DICT-PRINTER-READ1.
018140     IF DF-IDNT = 'RD' OR 'AD' OR 'SD'
018160         PERFORM PRINT-RD-FIELDS THRU PRINT-RD-FIELDS-EXIT
018180         GO TO DICT-PRINTER-READ.
018200     IF DF-IDNT = 'CD' PERFORM PRINT-CD-FIELDS
018220         GO TO DICT-PRINTER-READ.
018240     IF DF-IDNT NOT = 'FD' MOVE DICT-WS TO PRINT-LINE
018260         PERFORM PRINT1  GO TO DICT-PRINTER-READ.
018280     MOVE DF-NAME TO CURRENT-DF-NAME.
018300     IF FOUND-NON-FD-FLAG NOT = 1
018320         PERFORM PRINT-FD-FIELDS THRU PRINT-FD-FIELDS-EXIT
018340         GO TO DICT-PRINTER-READ.
018360     IF CF-NAME = SPACE
018380         PERFORM NEW-PAGE
018400         GO TO DICT-PRINTER-FD.
018420     GO TO DICT-PRINTER-DONE.
018440 DICT-PRINTER-ERROR.
018460     PERFORM PRINT-TRAN.
018480     MOVE ' %Cannot find dictionary for name specified above'
018500     TO PRINT-LINE.  PERFORM DISPLAYER THRU DISPLAYER-EXIT.
018520     PERFORM PRINT1.
018540 DICT-PRINTER-DONE.
018560     PERFORM CLOSE-DICT-WORK.
018580     PERFORM FIND-FD-TRAN THROUGH FIND-FD-TRAN-EXIT.
018600     MOVE 0 TO DICT-LOCK.
018620 DICT-PRINTER-EXIT.
018640     EXIT.
018660
018680********************
018700* SUBROUTINE TO PRINT OUT DICTIONARY NAMES ON N ACTION CODE.
018720********************
018740 DICT-NAMES.
018760     PERFORM OPEN-IN-DICT-OUT-WORK.
018780 DICT-NAMES-1.
018800     PERFORM NEW-PAGE.
018820     PERFORM PRINT-FD-HEAD.
018840 DICT-NAMES-2.
018860     READ QPDICT INTO DICT-WS AT END
018880         PERFORM CLOSE-DICT-WORK GO TO DICT-NAMES-EXIT.
018900     IF DF-IDNT = 'FD' PERFORM PRINT-FD-FIELDS
018920         THRU PRINT-FD-FIELDS-EXIT
018940         ADD 1 TO LINE-CTR.
018960     IF LINE-CTR LESS THAN LINE-MAX GO TO DICT-NAMES-2.
018980     GO TO DICT-NAMES-1.
019000 DICT-NAMES-EXIT.
019020     EXIT.
019040
019060*****************************
019080* SUBROUTINE TO START A NEW DICTIONARY FILE. IT DOES THIS BY
019100* PLANTING AN END OF FILE AT THE BEGINNING OF THE DICTIONARY FILE
019120* AND THEN ADDING THE NEW DICTIONARY AS USUAL.
019140*****************************
019160 DICT-STARTER.
019180     PERFORM CLOSE-DICT-WORK.
019200     PERFORM OPEN-OUT-DICT.
019220     PERFORM CLOSE-DICT-WORK.
019240     PERFORM DICT-ADDER THROUGH DICT-ADDER-EXIT.
019260 DICT-STARTER-EXIT.
019280     EXIT.
019300
019320*****************************
019340* SUBROUTINE TO ADD A NEW DICTIONARY TO THE FILE.  IT CALLS
019360* SUBROUTINE NEW-DICT TO DO MOST OF ITS WORK. DICT-ADDER IS
019380* CALLED BY DICT-STARTER.
019400*****************************
019420 DICT-ADDER.
019440     PERFORM DICT-FINDER THROUGH DICT-FINDER-EXIT.
019460     IF FOUND-DICT = 1 GO TO DICT-ADDER-ERROR.
019480     PERFORM NEW-DICT THROUGH NEW-DICT-EXIT.
019500     PERFORM WORK-COPY THROUGH WORK-COPY-EXIT.
019520     GO TO DICT-ADDER-EXIT.
019540 DICT-ADDER-ERROR.
019560     PERFORM CLOSE-DICT-WORK.
019580     PERFORM PRINT-TRAN.
019600     MOVE ' %A dictionary already exists for the name '
019620     TO PRINT-LINE.
019640     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
019660     PERFORM PRINT1.
019680     MOVE '  above. Change name in tran or action to D or R'
019700     TO PRINT-LINE. PERFORM DISPLAYER THRU DISPLAYER-EXIT.
019720     PERFORM PRINT1B.
019740     PERFORM FIND-FD-TRAN THROUGH FIND-FD-TRAN-EXIT.
019760 DICT-ADDER-EXIT.
019780     EXIT.
019800
019820*****************************
019840* SUBROUTINE TO DELETE A DICTIONARY FROM FILE
019860*****************************
019880 DICT-DELETER.
019900     PERFORM DICT-FINDER THROUGH DICT-FINDER-EXIT.
019920     PERFORM PRINT-FD-HEAD.
019940     IF FOUND-DICT NOT = 1 GO TO DICT-DELETER-ERROR.
019960     IF DF-PROT-READ = '  ' OR '00' GO TO DICT-DELETER2.
019980     IF CF-PASSWORD = UNIVERSAL-PASSWORD
019984         MOVE 99 TO UNLOCKED-LEVEL 
020000         GO TO DICT-DELETER2.
020004     PERFORM DICT-UNLOCKER THRU DICT-UNLOCKER-EXIT.
020008*    *TO DELETE A DICT MUST UNLOCK AT HIGHEST PD LEVEL*
020012     IF DICT-LOCK = 0
020016         PERFORM DICT-FINDER THRU DICT-FINDER-EXIT
020018         GO TO DICT-DELETER2.
020020     PERFORM PRINT-TRAN.
020040     MOVE ' %Dictionary not unlocked to be deleted'
020060         TO PRINT-LINE.
020080     GO TO DICT-DELETER-ERROR1.
020100 DICT-DELETER2.
020120     PERFORM PRINT-FD-FIELDS THRU PRINT-FD-FIELDS-EXIT.
020140     PERFORM DICT-PASS THROUGH DICT-PASS-EXIT.
020160     PERFORM DICT-COPY THRU DICT-COPY-EXIT.
020180     PERFORM WORK-COPY THROUGH WORK-COPY-EXIT.
020200     MOVE ' (Dictionary correctly deleted)' TO PRINT-LINE.
020220     GO TO DICT-DELETER-DONE.
020240 DICT-DELETER-ERROR.
020260     PERFORM PRINT-TRAN.
020280     MOVE ' %No dictionary found under above name'
020300         TO PRINT-LINE.
020320 DICT-DELETER-ERROR1.
020340     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
020360     PERFORM CLOSE-DICT-WORK.
020380 DICT-DELETER-DONE.
020400     PERFORM PRINT1B.
020420     PERFORM FIND-FD-TRAN THROUGH FIND-FD-TRAN-EXIT.
020440 DICT-DELETER-EXIT.
020460     EXIT.
020480
020500*****************************
020520* SUBROUTINE TO REPLACE A DICTIONARY IN DICTIONARY FILE.
020540*****************************
020560 DICT-REPLACER.
020580     PERFORM DICT-FINDER THROUGH DICT-FINDER-EXIT.
020600     IF FOUND-DICT NOT = 1 GO TO DICT-REPLACER-ERROR.
020620     IF DF-PROT-READ = '  ' OR '00' GO TO DICT-REPLACER1.
020640     IF CF-PASSWORD = UNIVERSAL-PASSWORD
020650         MOVE 99 TO UNLOCKED-LEVEL
020660         GO TO DICT-REPLACER1.
020664     PERFORM DICT-UNLOCKER THRU DICT-UNLOCKER-EXIT.
020666*    *TO REPLACE A DICT MUST UNLOCK AT HIGHEST PD LEVEL*
020668     IF DICT-LOCK = 0
020670         PERFORM DICT-FINDER THRU DICT-FINDER-EXIT
020672         GO TO DICT-REPLACER1.
020680     PERFORM PRINT-TRAN.
020700     MOVE ' %Dictionary not unlocked to be replaced'
020720         TO PRINT-LINE.
020740     GO TO DICT-REPLACER-ERROR1.
020760*   * COPY OUT ANY ALTERNATE FD ENTRIES *   *
020780 DICT-REPLACER1.
020800     READ QPDICT INTO DICT-WS AT END
020820         MOVE 1 TO DICT-EOF
020840         GO TO DICT-REPLACER2.
020860     IF DF-IDNT NOT = 'FD' GO TO DICT-REPLACER2.
020880     WRITE WORK-REC FROM DICT-WS.
020900     GO TO DICT-REPLACER1.
020920 DICT-REPLACER2.
020940     MOVE 0 TO IGNORE-RECORD-FLAG.
020960     PERFORM NEW-DICT THROUGH NEW-DICT-EXIT.
020980     PERFORM DICT-PASS THROUGH DICT-PASS-EXIT.
021000     PERFORM DICT-COPY THROUGH DICT-COPY-EXIT.
021020     PERFORM WORK-COPY THROUGH WORK-COPY-EXIT.
021040     GO TO DICT-REPLACER-EXIT.
021060 DICT-REPLACER-ERROR.
021080     PERFORM PRINT-TRAN.
021100     MOVE ' %No dictionary found to replace under above name'
021120         TO PRINT-LINE.
021140 DICT-REPLACER-ERROR1.
021160     PERFORM CLOSE-DICT-WORK.
021180     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
021200     PERFORM PRINT1B.
021220     PERFORM FIND-FD-TRAN THROUGH FIND-FD-TRAN-EXIT.
021240 DICT-REPLACER-EXIT.
021260     EXIT.
021280
021300****************************************************
021320* SUBROUTINE TO PROCESS CHANGES TO AN EXISTING DICTIONARY
021340* INCLUDING FD PD RD AD SD CD AND DD CHANGES.  IN EACH
021360* NON-BLANK FIELDS IN THE INPUT TRANS
021380* REPLACE THOSE FIELDS IN THE DICTIONARY; ALL OTHER FIELDS
021400* REMAIN AS ORIGINALLY CONTAINED. ALPHA FIELDS CONTAINING
021420* ALL '*' IN THE INPUT ARE SET TO BLANKS IN THE
021440* DICTIONARY.  THE COMPOSITE TRAN IMAGE IS PROCESSED THROUGH
021460* ALL NORMAL EDITS AND CHECKS INTO THE DICTIONARY.
021480******************************************************
021500 DICT-CHANGER.
021520     PERFORM DICT-FINDER THROUGH DICT-FINDER-EXIT.
021540     IF FOUND-DICT = 1 GO TO DICT-CHANGER-FD.
021560     PERFORM CLOSE-DICT-WORK.
021580     PERFORM PRINT-TRAN.
021600     MOVE ' %No dictionary found to change under above name'
021620     TO PRINT-LINE. PERFORM DISPLAYER THRU DISPLAYER-EXIT.
021640     PERFORM PRINT1B.
021660     PERFORM FIND-FD-TRAN THRU FIND-FD-TRAN-EXIT.
021680     GO TO DICT-CHANGER-EXIT.
021700
021720*    *PROCESS FD CHANGES*    *
021740 DICT-CHANGER-FD.
021740     IF CF-PASSWORD = UNIVERSAL-PASSWORD
021760         MOVE 99 TO UNLOCKED-LEVEL
021780         GO TO DICT-CHANGER-FD1A.
021800     PERFORM DICT-UNLOCKER THRU DICT-UNLOCKER-EXIT.
021802*    *TO CHANGE DICT MUST UNLOCK AT HIGHEST LEVEL
021820     IF DICT-LOCK = 1 GO TO DICT-CHANGER-FD-LOCK.
021840     PERFORM DICT-FINDER THRU DICT-FINDER-EXIT.
021860     GO TO DICT-CHANGER-FD1A.
021960 DICT-CHANGER-FD-LOCK.
021980     PERFORM PRINT-TRAN.
022000     MOVE ' %Dictionary not unlocked for update'
022020         TO PRINT-LINE.
022040     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
022060     PERFORM PRINT1B.
022080     PERFORM FIND-FD-TRAN THRU FIND-FD-TRAN-EXIT.
022100     PERFORM CLOSE-DICT-WORK.
022120     GO TO DICT-CHANGER-EXIT.
022140 DICT-CHANGER-FD1A.
022160     IF CF-INLABEL = SPACE MOVE DF-INLABEL TO CF-INLABEL.
022180     IF CF-INLABEL = ALL '*'
022200         MOVE SPACE TO CF-INLABEL.
022220     IF CF-DIRECT = SPACE MOVE DF-DIRECT TO CF-DIRECT.
022240     IF CF-DIRECT = ALL '*'
022260          MOVE SPACE TO CF-DIRECT.
022280     IF CF-FILETYPE-X = SPACE   MOVE DF-FILETYPE  TO CF-FILETYPE.
022300     IF CF-RECLEN-X  = SPACE   MOVE DF-RECLEN     TO CF-RECLEN.
022320     IF CF-BLKFACT-X  = SPACE   MOVE DF-BLKFACT   TO CF-BLKFACT.
022340     IF CF-BLKFACT-X  = ALL '*' MOVE SPACES       TO CF-BLKFACT.
022360     IF CF-KEYPOS-X   = SPACE   MOVE DF-KEYPOS    TO CF-KEYPOS.
022380     IF CF-KEYPOS-X   = ALL '*' MOVE SPACES       TO CF-KEYPOS-X.
022400     IF CF-KEYLEN-X   = SPACE   MOVE DF-KEYLEN    TO CF-KEYLEN.
022420     IF CF-KEYLEN-X   = ALL '*' MOVE SPACES       TO CF-KEYLEN-X.
022440     IF CF-KEYTYPE-X  = SPACE   MOVE DF-KEYTYPE   TO CF-KEYTYPE.
022460     IF CF-KEYTYPE-X  = ALL '*' MOVE SPACES       TO CF-KEYTYPE-X.
022480     IF CF-KEYSIGN    = SPACE   MOVE DF-KEYSIGN   TO CF-KEYSIGN.
022500     IF CF-KEYSIGN    = ALL '*' MOVE SPACES       TO CF-KEYSIGN.
022520     IF CF-PROT-READ  = SPACE   MOVE DF-PROT-READ TO CF-PROT-READ.
022540     IF CF-PROT-COPY  = SPACE   MOVE DF-PROT-COPY TO CF-PROT-COPY.
022560     IF CF-PROT-REWR  = SPACE   MOVE DF-PROT-REWR TO CF-PROT-REWR.
022580     IF CF-PROT-READ  = '**'    MOVE SPACE        TO CF-PROT-READ.
022600     IF CF-PROT-COPY  = '**'    MOVE SPACE        TO CF-PROT-COPY.
022620     IF CF-PROT-REWR  = '**'    MOVE SPACE        TO CF-PROT-REWR.
022640     PERFORM PRINT-FD-HEAD.
022660     PERFORM EDIT-FD-FIELDS.
022680     PERFORM CHECK-FD-FIELDS THRU CHECK-FD-FIELDS-EXIT.
022700     PERFORM MOVE-FD-FIELDS.
022720     PERFORM PRINT-FD-FIELDS THRU PRINT-FD-FIELDS-EXIT.
022740     MOVE 0 TO IGNORE-RECORD-FLAG.
022760     PERFORM PRINT-DD-HEAD.
022780*   * KEEP CHANGED FD ENTRY AND COPY ALT FD'S *   *
022800 DICT-CHANGER-FD1.
022820     WRITE WORK-REC FROM DICT-WS.
022840     IF HOLD-TRAN-FLAG = 1 MOVE HOLD-TRAN TO TRAN-WS
022860                           MOVE 1 TO IGNORE-RECORD-FLAG
022880                           MOVE 0 TO HOLD-TRAN-FLAG
022900                           GO TO DICT-CHANGER-DETAIL1.
022920     READ QPDICT INTO DICT-WS AT END
022940         PERFORM CLOSE-DICT-WORK
022960         GO TO DICT-CHANGER-FD2.
022980     IF DF-IDNT = 'FD' GO TO DICT-CHANGER-FD1.
023000 DICT-CHANGER-FD2.
023020     MOVE 1 TO 1ST-NTRY-FLAG.
023040 DICT-CHANGER-DETAIL.
023060     READ QCDICT INTO TRAN-WS AT END
023080         MOVE 0 TO FOUND-FD-TRAN GO TO DICT-CHANGER-DONE.
023100     MOVE TRAN-WS TO HOLD-TRAN.
023120 DICT-CHANGER-DETAIL1.
023140     IF CF-IDNT = 'FD' MOVE 1 TO FOUND-FD-TRAN
023160         MOVE CF-NAME TO CURRENT-CF-NAME
023180         GO TO DICT-CHANGER-DONE.
023200     IF CD-IDNT = 'DD' OR 'KD' GO TO DICT-CHANGER-DD.
023220     IF CD-IDNT = 'CD' GO TO DICT-CHANGER-CD.
023240     IF CD-IDNT = 'PD' GO TO DICT-CHANGER-PD.
023260     IF CD-IDNT = 'RD' OR 'AD' OR 'SD' GO TO DICT-CHANGER-RD.
023280     GO TO DICT-CHANGER-ERROR.
023300
023320*    *COMPLAIN ABOUT ANY ERRORS*    *
023340 DICT-CHANGER-ERROR.
023360     PERFORM PRINT-TRAN.
023380     MOVE ' %Tran type or action code above illegal- ignored'
023400         TO PRINT-LINE.
023420     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
023440     PERFORM PRINT1B.
023460     GO TO DICT-CHANGER-DETAIL.
023480
023500*    *PROCESS RD, AD, OR SD ENTRY*    *
023520*    *(WHICH ARE ALL SAME FORMAT)*    *
023540 DICT-CHANGER-RD.
023560     IF RD-ACT = 'A' OR ' ' GO TO DICT-CHANGER-RD-ADD.
023580     IF RD-ACT = 'D' GO TO DICT-CHANGER-RD-DEL.
023600     IF RD-ACT = 'C' GO TO DICT-CHANGER-RD-CHG.
023620     GO TO DICT-CHANGER-ERROR.
023640 DICT-CHANGER-RD-DEL.
023660     PERFORM FIND-ENTRY THRU FIND-ENTRY-EXIT.
023680     IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
023700     PERFORM PRINT-RD-FIELDS THRU  PRINT-RD-FIELDS-EXIT.
023720     GO TO DICT-CHANGER-DEL-CMN.
023740 DICT-CHANGER-RD-ADD.
023760     PERFORM DICT-CHG-WRITE1.
023780     GO TO DICT-CHANGER-RD-CHG1.
023800 DICT-CHANGER-RD-CHG.
023820     PERFORM FIND-ENTRY THRU FIND-ENTRY-EXIT.
023840     IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
023860     IF RD-ORIGIN-X = SPACE   MOVE DR-ORIGIN   TO RD-ORIGIN.
023880     IF RD-ORIGIN-X = ALL '*' MOVE SPACE       TO RD-ORIGIN.
023900     IF RD-LENGTH-X = SPACE   MOVE DR-LENGTH   TO RD-LENGTH.
023920     IF RD-LENGTH-X = ALL '*' MOVE SPACE       TO RD-LENGTH-X.
023940     IF RD-TYPE     = SPACE   MOVE DR-TYPE     TO RD-TYPE.
023960     IF RD-TYPE     = ALL '*' MOVE SPACE       TO RD-TYPE.
023980     IF RD-TEXT     = SPACE   MOVE DR-TEXT     TO RD-TEXT.
024000     IF RD-TEXT     = ALL '*' MOVE SPACE       TO RD-TEXT.
024020 DICT-CHANGER-RD-CHG1.
024040     PERFORM EDIT-RD-FIELDS THRU EDIT-RD-FIELDS-EXIT.
024060     PERFORM CHECK-RD-FIELDS THRU CHECK-RD-FIELDS-EXIT.
024080     IF TRAN-ERR-FLG NOT = 1 GO TO DICT-CHANGER-RD-CHG2.
024100     IF RD-ACT = 'A' MOVE 1 TO IGNORE-RECORD-FLAG.
024120     GO TO DICT-CHANGER-DETAIL.
024140 DICT-CHANGER-RD-CHG2.
024160     PERFORM MOVE-RD-FIELDS THRU MOVE-RD-FIELDS-EXIT.
024180     PERFORM PRINT-RD-FIELDS THRU PRINT-RD-FIELDS-EXIT.
024200     GO TO DICT-CHANGER-AC-CMN.
024220
024240*    *PROCESS PD CHANGES*    *
024260 DICT-CHANGER-PD.
024280     IF CP-ACT = 'A' OR ' ' GO TO DICT-CHANGER-PD-ADD.
024300     IF CP-ACT = 'D' GO TO DICT-CHANGER-PD-DEL.
024320     IF CP-ACT = 'C' GO TO DICT-CHANGER-PD-CHG.
024340     GO TO DICT-CHANGER-ERROR.
024360 DICT-CHANGER-PD-DEL.
024380     PERFORM FIND-ENTRY THROUGH FIND-ENTRY-EXIT.
024400     IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
024420     PERFORM PRINT-PD-FIELDS.
024440     GO TO DICT-CHANGER-DEL-CMN.
024460 DICT-CHANGER-PD-ADD.
024480     PERFORM DICT-CHG-WRITE1.
024500     GO TO DICT-CHANGER-PD-CHG1.
024520 DICT-CHANGER-PD-CHG.
024540     PERFORM FIND-ENTRY THROUGH FIND-ENTRY-EXIT.
024560     IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
024580     IF CP-PROT-NO-X = SPACE MOVE DP-PROT-NO   TO CP-PROT-NO.
024600     IF CP-DATE-FLAG = SPACE MOVE DP-DATE-FLAG TO CP-DATE-FLAG.
024620     IF CP-LINE-X    = SPACE MOVE DP-LINE      TO CP-LINE.
024640     IF CP-PASSWORD  = SPACE MOVE DP-TEXT      TO CP-PASSWORD.
024660 DICT-CHANGER-PD-CHG1.
024680     PERFORM EDIT-PD-FIELDS.
024700     PERFORM CHECK-PD-FIELDS.
024720     IF TRAN-ERR-FLG NOT = 1 GO TO DICT-CHANGER-PD-CHG2.
024740     IF CP-ACT = 'A' MOVE 1 TO IGNORE-RECORD-FLAG.
024760     GO TO DICT-CHANGER-DETAIL.
024780 DICT-CHANGER-PD-CHG2.
024800     PERFORM MOVE-PD-FIELDS.
024820     PERFORM PRINT-PD-FIELDS.
024840     GO TO DICT-CHANGER-AC-CMN.
024860
024880*    *PROCESS DD CHANGES*    *
024900 DICT-CHANGER-DD.
024920     IF CD-ACT = 'A' OR ' ' GO TO DICT-CHANGER-DD-ADD.
024940     IF CD-ACT = 'D' GO TO DICT-CHANGER-DD-DEL.
024960     IF CD-ACT = 'C' GO TO DICT-CHANGER-DD-CHG.
024980     GO TO DICT-CHANGER-ERROR.
025000 DICT-CHANGER-DD-DEL.
025020     PERFORM FIND-ENTRY THROUGH FIND-ENTRY-EXIT.
025040     IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
025060     PERFORM PRINT-DD-FIELDS.
025080     GO TO DICT-CHANGER-DEL-CMN.
025100 DICT-CHANGER-DD-ADD.
025120     PERFORM DICT-CHG-WRITE1.
025140     GO TO DICT-CHANGER-DD-CHG1.
025160 DICT-CHANGER-DD-CHG.
025180     PERFORM FIND-ENTRY THROUGH FIND-ENTRY-EXIT.
025200     IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
025220     IF CD-TITLE1     = SPACE   MOVE DD-TITLE1   TO CD-TITLE1.
025240     IF CD-TITLE1     = ALL '*' MOVE SPACE       TO CD-TITLE1.
025260     IF CD-TITLE2     = SPACE   MOVE DD-TITLE2   TO CD-TITLE2.
025280     IF CD-TITLE2     = ALL '*' MOVE SPACE       TO CD-TITLE2.
025300     IF CD-FCHAR-X    = SPACE   MOVE DD-FCHAR    TO CD-FCHAR.
025320     IF CD-FCHAR-X    = ALL '*' MOVE SPACE       TO CD-FCHAR-X.
025340     IF CD-NCHARS-X   = SPACE   MOVE DD-NCHARS   TO CD-NCHARS.
025360     IF CD-NCHARS-X   = ALL '*' MOVE SPACE       TO CD-NCHARS-X.
025380     IF CD-NOUPD      = SPACES  MOVE DD-NOUPD    TO CD-NOUPD.
025400     IF CD-NOUPD      = '*'     MOVE SPACE       TO CD-NOUPD.
025420     IF CD-TYPE-X     = SPACE   MOVE DD-TYPE     TO CD-TYPE.
025440     IF CD-TYPE-X     = ALL '*' MOVE SPACE       TO CD-TYPE-X.
025460     IF CD-SCALE-X    = SPACE   MOVE DD-SCALE    TO CD-SCALE.
025480     IF CD-SCALE-X    = ALL '*' MOVE SPACE       TO CD-SCALE-X.
025500     IF CD-OFFSET-X   = SPACE   MOVE DD-OFFSET   TO CD-OFFSET.
025520     IF CD-OFFSET-X   = ALL '*' MOVE SPACE       TO CD-OFFSET-X.
025540     IF CD-EDIT-X     = SPACE   MOVE DD-EDIT     TO CD-EDIT.
025560     IF CD-EDIT-X     = ALL '*' MOVE SPACE       TO CD-EDIT-X.
025580     IF CD-PICT       = SPACE   MOVE DD-PICT     TO CD-PICT.
025600     IF CD-PICT       = ALL '*' MOVE SPACE       TO CD-PICT.
025620     IF CD-GRPNME     = SPACE   MOVE DD-GRPNME   TO CD-GRPNME.
025640     IF CD-GRPNME     = '*'     MOVE SPACE       TO CD-GRPNME.
025660     IF CD-NREPEATS-X = SPACE   MOVE DD-NREPEATS TO CD-NREPEATS.
025680     IF CD-NREPEATS-X = ALL '*' MOVE SPACE       TO CD-NREPEATS-X.
025700     IF CD-STOPPER    = SPACE   MOVE DD-STOPPER  TO CD-STOPPER.
025720     IF CD-STOPPER    = '*'     MOVE SPACE       TO CD-STOPPER.
025740     IF CD-PROT-NO-X  = SPACE   MOVE DD-PROT-NO  TO CD-PROT-NO.
025760     IF CD-PROT-NO-X  = ALL '*' MOVE SPACE       TO   CD-PROT-NO-X
025780     IF CD-EXCLFLAG   = SPACE   MOVE DD-EXCLFLAG TO CD-EXCLFLAG.
025800     IF CD-EXCLFLAG   = '*'     MOVE SPACE       TO CD-EXCLFLAG.
025820 DICT-CHANGER-DD-CHG1.
025840     PERFORM EDIT-DD-FIELDS.
025860     PERFORM CHECK-DD-FIELDS.
025880     IF TRAN-ERR-FLG NOT = 1 GO TO DICT-CHANGER-DD-CHG2.
025900     IF CD-ACT = 'A' MOVE 1 TO IGNORE-RECORD-FLAG.
025920     GO TO DICT-CHANGER-DETAIL.
025940 DICT-CHANGER-DD-CHG2.
025960     PERFORM MOVE-DD-FIELDS.
025980     PERFORM PRINT-DD-FIELDS.
026000     GO TO DICT-CHANGER-AC-CMN.
026020
026040*    *PROCESS CD (COMMENT) CHANGES*    *
026060 DICT-CHANGER-CD.
026080     IF CC-ACT = 'A' OR ' ' GO TO DICT-CHANGER-CD-ADD.
026100     IF CC-ACT = 'C' GO TO DICT-CHANGER-CD-CHG.
026120     IF CC-ACT = 'D' GO TO DICT-CHANGER-CD-DEL.
026140     GO TO DICT-CHANGER-ERROR.
026160 DICT-CHANGER-CD-ADD.
026180     PERFORM DICT-CHG-WRITE1.
026200     GO TO DICT-CHANGER-CD-CHG1.
026220 DICT-CHANGER-CD-CHG.
026240     PERFORM FIND-ENTRY THROUGH FIND-ENTRY-EXIT.
026260     IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
026280 DICT-CHANGER-CD-CHG1.
026300     IF CC-TEXT = SPACE MOVE DC-TEXT TO CC-TEXT.
026320     IF CC-TEXT = ALL '*' MOVE SPACE TO CC-TEXT.
026340     PERFORM MOVE-CD-FIELDS.
026360     PERFORM PRINT-CD-FIELDS.
026380     GO TO DICT-CHANGER-AC-CMN.
026400 DICT-CHANGER-CD-DEL.
026420     PERFORM FIND-ENTRY THROUGH FIND-ENTRY-EXIT.
026440     IF FOUND-ENTRY NOT = 1 GO TO DICT-CHANGER-MISSED-CMN.
026460     PERFORM PRINT-CD-FIELDS.
026480     GO TO DICT-CHANGER-DEL-CMN.
026500
026520*    *COMMON LOGIC FOLLOWS TO SERVICE ABOVE SEQUENCES*    *
026540 DICT-CHANGER-MISSED-CMN.
026560     PERFORM PRINT-TRAN.
026580     MOVE ' %Found no entry matching above- tran rejected'
026600         TO PRINT-LINE.
026620     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
026640     IF DICT-EOF = 1
026660         PERFORM WORK-COPY THRU WORK-COPY-EXIT
026680         PERFORM DICT-FINDER THRU DICT-FINDER-EXIT.
026700     GO TO DICT-CHANGER-CMN.
026720 DICT-CHANGER-AC-CMN.
026740     MOVE 0 TO IGNORE-RECORD-FLAG.
026760     IF CF-ACT = 'C' GO TO DICT-CHANGER-CHG-CMN.
026780     IF 1ST-NTRY-FLAG = 1 WRITE WORK-REC FROM DICT-WS
026800         MOVE HOLD-WS TO DICT-WS.
026820     MOVE ' *Above entry added' TO PRINT-LINE.
026840     GO TO DICT-CHANGER-CMN.
026860 DICT-CHANGER-CHG-CMN.
026880     MOVE ' *Above entry after changes made' TO PRINT-LINE.
026900     GO TO DICT-CHANGER-CMN.
026920 DICT-CHANGER-DEL-CMN.
026940     MOVE 1 TO IGNORE-RECORD-FLAG.
026960     MOVE ' *Above entry deleted' TO PRINT-LINE.
026980 DICT-CHANGER-CMN.
027000     PERFORM PRINT1B.
027020     GO TO DICT-CHANGER-DETAIL.
027040 DICT-CHANGER-DONE.
027060     PERFORM DICT-COPY THRU DICT-COPY-EXIT.
027080     PERFORM WORK-COPY THRU WORK-COPY-EXIT.
027100
027120 DICT-CHANGER-EXIT.
027140     EXIT.
027160
027180 DICT-CHG-WRITE1.
027200     IF 1ST-NTRY-FLAG = 1 MOVE DICT-WS TO HOLD-WS
027220         MOVE 1 TO IGNORE-RECORD-FLAG.
027240     IF IGNORE-RECORD-FLAG = 0
027260         WRITE WORK-REC FROM DICT-WS.
027280     MOVE 0 TO IGNORE-RECORD-FLAG.
027300
027320********************
027340* THE SUBROUTINE BELOW SEARCHES THE CURRENT DICTIONARY FOR
027360* THE ENTRY CORRESPONDING TO THE CURRENT TRAN. IF IT DOES NOT
027380* HIT THE FIRST TIME  IT RETRIES FROM THE BEGINNING OF THE
027400* DICTIONARY BEFORE SETTING AN ERROR (NOT FOUND) FLAG AND
027420* EXITING.
027440* ON HIT, EXITS WITH:  FOUND-ENTRY = 1
027460*                      FILES OPEN AND MARKED OPEN
027480*                      DICT-EOF = 0
027500* ON MISS, EXITS WITH: FOUND-ENTRY = 0
027520*                      FILES CLOSED AND MARKED CLOSED
027540*                      DICT-EOF = 0
027560********************
027580 FIND-ENTRY.
027600     MOVE 0 TO FOUND-ENTRY  1ST-NTRY-FLAG.
027620     MOVE 1 TO LOOK-CYCLE.
027640 FIND-ENTRY-READ.
027660     IF DICT-FILE-FLAG = 0 GO TO FIND-ENTRY-RETRY.
027680     IF IGNORE-RECORD-FLAG = 1 GO TO FIND-ENTRY2.
027700     IF DF-IDNT NOT = CF-IDNT GO TO FIND-ENTRY1.
027720     IF ( DF-IDNT = 'DD' OR 'KD' OR 'RD' OR 'AD' OR 'SD' )
027740         AND DF-NAME = CF-NAME GO TO FIND-ENTRY-DONE.
027760     IF DF-IDNT = 'CD' AND DC-NO = CC-NO
027780         GO TO FIND-ENTRY-DONE.
027800     IF DF-IDNT NOT = 'PD' GO TO FIND-ENTRY1.
027820     MOVE DP-TEXT TO PW-TEXT-HOLDER.
027840     PERFORM UNSCRAMBLE-PW THRU UNSCRAMBLE-PW-EXIT.
027860     IF DP-PROT-NO = CP-PROT-NO AND
027880          ( CP-TEXT = DP-TEXT OR
027900            CP-TEXT = UNIVERSAL-PASSWORD )
027920         MOVE PW-TEXT-HOLDER TO DP-TEXT
027940         GO TO FIND-ENTRY-DONE.
027960     MOVE PW-TEXT-HOLDER TO DP-TEXT.
027980     GO TO FIND-ENTRY2.
028000 FIND-ENTRY1.
028020     IF DF-IDNT = 'DD' OR 'KD'
028040         PERFORM GETGRPLEN THRU GETGRPLENX
028060         GO TO FIND-ENTRY2.
028080     IF DF-IDNT = 'FD' AND DF-NAME NOT = CURRENT-CF-NAME
028100         MOVE 1 TO FOUND-FD
028120         MOVE DF-NAME TO CURRENT-DF-NAME
028140         GO TO FIND-ENTRY-RETRY.
028160 FIND-ENTRY2.
028180     IF IGNORE-RECORD-FLAG = 0
028200         WRITE WORK-REC FROM DICT-WS.
028220     MOVE 0 TO IGNORE-RECORD-FLAG  1ST-NTRY-FLAG.
028240     IF DICT-FILE-FLAG = 0 GO TO FIND-ENTRY-RETRY.
028260     READ QPDICT INTO DICT-WS AT END PERFORM CLOSE-DICT-WORK
028280         GO TO FIND-ENTRY-RETRY.
028300     GO TO FIND-ENTRY-READ.
028320 FIND-ENTRY-RETRY.
028340     IF LOOK-CYCLE = 2
028360         PERFORM CLOSE-DICT-WORK GO TO FIND-ENTRY-EXIT.
028380     MOVE 2 TO LOOK-CYCLE.
028400     PERFORM DICT-COPY THROUGH DICT-COPY-EXIT.
028420     PERFORM WORK-COPY THROUGH WORK-COPY-EXIT.
028440     PERFORM DICT-FINDER THROUGH DICT-FINDER-EXIT.
028460     MOVE 0 TO N-SCANITEMS.
028480     GO TO FIND-ENTRY2.
028500 FIND-ENTRY-DONE.
028520     MOVE 1 TO FOUND-ENTRY.
028540 FIND-ENTRY-EXIT.
028560     EXIT.
028580
028600*****************************
028620* SUBROUTINE TO PROCESS A NEW DICTIONARY FROM TRANS TO WORK FILE.
028640* IT READS TRANS  EDITS THEM  CHECKS AND CORRECTS ERRORS  MOVES
028660* TO WORK FILE  PRINTS THEM OUT.  ASSUMES DICT AND TRAN FILES
028680* ARE OPEN AND POSITIONED AT PLACE TO BE READ OR WRITTEN TO.
028700*****************************
028720 NEW-DICT.
028724     MOVE 99 TO UNLOCKED-LEVEL. 
028726     MOVE 0 TO DICT-LOCK.
028740     PERFORM PRINT-FD-HEAD.
028760     PERFORM EDIT-FD-FIELDS.
028780     PERFORM CHECK-FD-FIELDS THRU CHECK-FD-FIELDS-EXIT.
028800     PERFORM MOVE-FD-FIELDS.
028820     PERFORM PRINT-FD-FIELDS THRU PRINT-FD-FIELDS-EXIT.
028840     PERFORM PRINT-DD-HEAD.
028860     IF IGNORE-RECORD-FLAG EQUAL TO 0
028880         WRITE WORK-REC FROM DICT-WS.
028900     MOVE 0 TO IGNORE-RECORD-FLAG FOUND-FD-TRAN.
028920 NEW-DICT-READ.
028940     READ QCDICT INTO TRAN-WS AT END GO TO NEW-DICT-EXIT.
028960     MOVE TRAN-WS TO HOLD-TRAN.
028980     IF CF-ACT = 'D' OR CF-ACT = 'C'
029000         MOVE HOLD-TRAN-FD TO TRAN-FD
029020         MOVE 1 TO HOLD-TRAN-FLAG
029040         MOVE 'C' TO CF-ACT
029060         GO TO NEW-DICT-FD.
029080     IF CF-IDNT = 'FD' GO TO NEW-DICT-FD.
029100     IF CC-IDNT = 'CD' GO TO NEW-DICT-CD.
029120     IF CD-IDNT = 'PD' GO TO NEW-DICT-PD.
029140     IF CD-IDNT = 'DD' OR 'KD' GO TO NEW-DICT-DD.
029160     IF CD-IDNT = 'RD' OR 'AD' OR 'SD' GO TO NEW-DICT-RD.
029180     GO TO NEW-DICT-ERROR.
029200**SAME LOGIC BELOW APPLIES FOR RD, AD, AND SD TRANSACTIONS***
029220 NEW-DICT-RD.
029240     PERFORM EDIT-RD-FIELDS THRU EDIT-RD-FIELDS-EXIT.
029260     PERFORM CHECK-RD-FIELDS THRU CHECK-RD-FIELDS-EXIT.
029280     IF TRAN-ERR-FLG = 1 GO TO NEW-DICT-READ.
029300     PERFORM MOVE-RD-FIELDS THRU MOVE-RD-FIELDS-EXIT.
029320     PERFORM PRINT-RD-FIELDS THRU PRINT-RD-FIELDS-EXIT.
029340     WRITE WORK-REC FROM DICT-WS.
029360     GO TO NEW-DICT-READ.
029380 NEW-DICT-DD.
029400     PERFORM EDIT-DD-FIELDS.
029420     PERFORM CHECK-DD-FIELDS.
029440     IF TRAN-ERR-FLG = 1 GO TO NEW-DICT-READ.
029460     PERFORM MOVE-DD-FIELDS.
029480     PERFORM PRINT-DD-FIELDS.
029500     WRITE WORK-REC FROM DICT-WS.
029520     GO TO NEW-DICT-READ.
029540 NEW-DICT-CD.
029560     PERFORM MOVE-CD-FIELDS.
029580     PERFORM PRINT-CD-FIELDS.
029600     WRITE WORK-REC FROM DICT-WS.
029620     GO TO NEW-DICT-READ.
029640 NEW-DICT-PD.
029660     IF CP-IDNT NOT = 'PD' GO TO NEW-DICT-FD.
029680     PERFORM EDIT-PD-FIELDS.
029700     PERFORM CHECK-PD-FIELDS.
029720     IF TRAN-ERR-FLG = 1 GO TO NEW-DICT-READ.
029740     PERFORM MOVE-PD-FIELDS.
029760     PERFORM PRINT-PD-FIELDS.
029780     WRITE WORK-REC FROM DICT-WS.
029800     GO TO NEW-DICT-READ.
029820 NEW-DICT-FD.
029840     IF CF-IDNT = 'FD' MOVE 1 TO FOUND-FD-TRAN
029860     MOVE CF-NAME TO CURRENT-CF-NAME
029880         GO TO NEW-DICT-EXIT.
029900     PERFORM PRINT-TRAN.
029920 NEW-DICT-ERROR.
029940     MOVE ' %Unrecognizeable tran type above- ignored'
029960     TO PRINT-LINE. PERFORM DISPLAYER THRU DISPLAYER-EXIT.
029980     PERFORM PRINT1B.
030000     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
030020     GO TO NEW-DICT-READ.
030040 NEW-DICT-EXIT.
030060     EXIT.
030080
030100*****************************
030120* SUBROUTINE TO POSITION DICTIONARY FILE AT THE BEGINNING OF THE
030140* DICTIONARY NAMED IN THE FD TRAN IN TRAN-WS. AN ALL SPACE
030160* NAME WILL GIVE HIT ON FIRST DICTIONARY IN FILE. FILES ARE
030180* LEFT OPEN. FD ENTRY OF FIRST DICTIONARY FOUND IS LEFT IN
030200* DICT-WS.
030220* EXIT CONDITIONS ARE:
030240*   IF DID NOT FIND DICT, HIT EOF ON QPDICT:
030260*       FILES OPEN AND MARKED OPEN
030280*       DICT-EOF = 1
030300*       FOUND-DICT = 0
030320*
030340*   IF SUCCESSFULLY FOUND DICT:
030360*       FILES ARE LEFT OPEN
030380*       DICT-EOF = 0
030400*       FOUND-DICT = 1
030420*****************************
030440 DICT-FINDER.
030460     MOVE 0 TO FOUND-DICT.
030480     PERFORM OPEN-IN-DICT-OUT-WORK.
030500 DICT-FINDER-READ.
030520     READ QPDICT INTO DICT-WS AT END MOVE 1 TO DICT-EOF
030540         GO TO DICT-FINDER-EXIT.
030560      IF DF-IDNT EQUAL TO 'FD' GO TO DICT-FINDER-FD.
030580     WRITE WORK-REC FROM DICT-WS.
030600     GO TO DICT-FINDER-READ.
030620 DICT-FINDER-FD.
030640*    *BLK FAC CONVERSION NOTED OUT FOR NOW*    *
030660*    *IF HAVE OLD BLK LEN, CONVERT IT TO - BLKFACT*.
030680*    IF DF-BLKFACT GREATER THAN 0
030700*         DIVIDE DF-RECLEN INTO DF-BLKFACT GIVING WORK-1
030720*         SUBTRACT WORK-1 FROM 0 GIVING DF-BLKFACT.
030740     IF CURRENT-CF-NAME = SPACE MOVE 1 TO FOUND-DICT
030760     MOVE DF-NAME TO CURRENT-DF-NAME
030780         GO TO DICT-FINDER-EXIT.
030800     IF DF-NAME = CURRENT-CF-NAME
030820        MOVE 1 TO FOUND-DICT  GO TO DICT-FINDER-EXIT.
030840     WRITE WORK-REC FROM DICT-WS.
030860     GO TO DICT-FINDER-READ.
030880 DICT-FINDER-EXIT.
030900     EXIT.
030920
030940*****************************
030960* SUBROUTINE TO PASS OVER A DICTIONARY IN DICTIONARY FILE.
030980* IT LEAVES THE NEXT FD RECORD (IF ANY) IN DICT-WS. IF IT
031000* DOES NOT FIND A NEXT FD RECORD  FLAG DICT-EOF IS SET
031020* TO 1 ELSE IT IS SET TO 0.
031040*****************************
031060 DICT-PASS.
031080     IF DICT-EOF = 1 PERFORM CLOSE-DICT-WORK
031100         GO TO DICT-PASS-EXIT.
031120     IF DICT-FILE-FLAG = 0 GO TO DICT-PASS-EXIT.
031140 DICT-PASS1.
031160     READ QPDICT INTO DICT-WS AT END
031180         PERFORM CLOSE-DICT-WORK  GO TO DICT-PASS-EXIT.
031200     IF DF-IDNT NOT = 'FD' GO TO DICT-PASS1.
031220*    *BLK FAC CONVERSION NOTED OUT FOR NOW*    *
031240*    *CONVERT OLD BLK LEN TO BLK FACT (< 0)*.
031260*    IF DF-BLKFACT GREATER THAN 0
031280*        DIVIDE DF-RECLEN INTO DF-BLKFACT GIVING WORK-1
031300*        SUBTRACT WORK-1 FROM 0 GIVING DF-BLKFACT.
031320 DICT-PASS-EXIT.
031340     EXIT.
031360
031380*****************************
031400* SUBROUTINE TO COPY REST OF DICTIONARY FILE INTO WORK FILE.
031420* STARTING FROM RECORD NOW IN DICT-WS.
031440*****************************
031460 DICT-COPY.
031480     IF DICT-EOF = 1 PERFORM CLOSE-DICT-WORK
031500         GO TO DICT-COPY-EXIT.
031520     IF DICT-FILE-FLAG = 0 GO TO DICT-COPY-EXIT.
031540 DICT-COPY-1.
031560     IF IGNORE-RECORD-FLAG EQUAL TO 0
031580     WRITE WORK-REC FROM DICT-WS.
031600     MOVE 0 TO IGNORE-RECORD-FLAG.
031620     READ QPDICT INTO DICT-WS AT END
031640         PERFORM CLOSE-DICT-WORK
031660         GO TO DICT-COPY-EXIT.
031680     GO TO DICT-COPY-1.
031700 DICT-COPY-EXIT.
031720     EXIT.
031740
031760*****************************
031780* SUBROUTINE TO COPY WORK FILE BACK INTO ORIGINAL DICTIONARY FILE
031800*****************************
031820 WORK-COPY.
031840     PERFORM OPEN-OUT-DICT-IN-WORK.
031860 WORK-COPY-1.
031880     READ QTDICT AT END
031900         PERFORM CLOSE-DICT-WORK
031920         GO TO WORK-COPY-EXIT.
031940     WRITE DICT-REC FROM WORK-REC.
031960     GO TO WORK-COPY-1.
031980 WORK-COPY-EXIT.
032000     EXIT.
032020
032040*****************************
032060* SUBROUTINE TO READ OVER TRANS FROM CURRENT POSITION UNTIL
032080* HIT AN FD TRAN OR END OF TRAN IMAGE FILE.
032100* IF FINDS FD TRAN  IT IS LEFT IN TRAN-WS.
032120*****************************
032140 FIND-FD-TRAN.
032160     MOVE 0 TO FOUND-FD-TRAN.
032180 FIND-FD-TRAN-1.
032200     READ QCDICT INTO TRAN-WS AT END GO TO FIND-FD-TRAN-EXIT.
032220     MOVE TRAN-WS TO HOLD-TRAN.
032240     IF CF-IDNT NOT = 'FD' GO TO FIND-FD-TRAN-1.
032260     MOVE 1 TO FOUND-FD-TRAN.
032280     MOVE CF-NAME TO CURRENT-CF-NAME.
032300 FIND-FD-TRAN-EXIT.
032320     EXIT.
032340
032360**************************
032380* PRINT SUBROUTINES FOLLOW.
032400* THIS IS THE ONLY PLACE PRINTS ARE PHYSICALLY DONE.
032420**************************
032440 PRINT0.
032460     WRITE PRINT-LINE AFTER ADVANCING TOP-OF-PAGE.
032480     MOVE 0 TO LINE-CTR.
032500 PRINT0-EXIT.
032520     EXIT.
032540
032560 PRINT1.
032580     WRITE PRINT-LINE AFTER ADVANCING 1 LINES.
032600     ADD 1 TO LINE-CTR.
032620     IF LINE-CTR GREATER THAN LINE-MAX PERFORM NEW-PAGE
032640         PERFORM PRINT-DD-HEAD.
032660 PRINT1-EXIT.
032680     EXIT.
032700
032720 PRINT1B.
032740     WRITE PRINT-LINE AFTER ADVANCING 1 LINES.
032760     ADD 1 TO LINE-CTR.
032780     IF LINE-CTR GREATER THAN LINE-MAX PERFORM NEW-PAGE
032800         PERFORM PRINT-DD-HEAD
032820         ELSE
032840         MOVE ' ' TO PRINT-LINE PERFORM PRINT1.
032860 PRINT1B-EXIT.
032880     EXIT.
032900
032920 PRINT1D.
032940     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
032960     PERFORM PRINT1.
032980 PRINT1D-EXIT.
033000     EXIT.
033020
033040 PRINT2.
033060     WRITE PRINT-LINE AFTER ADVANCING 2 LINES.
033080     ADD 2 TO LINE-CTR.
033100     IF LINE-CTR GREATER THAN LINE-MAX PERFORM NEW-PAGE
033120          PERFORM PRINT-DD-HEAD.
033140 PRINT2-EXIT.
033160     EXIT.
033180
033200******************************************************
033220* SUBROUTINE TO SPACE 1 LINE ON PRINTER.
033240******************************************************
033260 SPACER.
033280     MOVE SPACE TO PRINT-LINE.
033300     WRITE PRINT-LINE AFTER ADVANCING 1 LINES.
033320     ADD 1 TO LINE-CTR.
033340
033360*****************************
033380* SUBROUTINE TO PRINT OUT TRAN IMAGE VERBATIM.
033400*****************************
033420 PRINT-TRAN.
033440     MOVE HOLD-TRAN TO TRAN-LINE.
033460     MOVE TRAN-MESSAGE TO PRINT-LINE.
033480     PERFORM DISPLAYER THRU DISPLAYER-EXIT.
033500     PERFORM PRINT2.
033520 PRINT-TRAN-EXIT.
033540     EXIT.
033560
033580***************************
033600* SUBROUTINE TO DISPLAY PRINT LINE UPON TERMINAL.
033620***************************
033640 DISPLAYER.
033644     MOVE PRINT-LINE TO CONSOLE-LINE.
033648     MOVE 72 TO M.
033652 DISPLAYER1.
033656     IF CONSOLE-CHAR (M) = SPACE
033660         MOVE ASCII-NULL TO CONSOLE-CHAR (M)
033664         IF M NOT < 2 SUBTRACT 1 FROM M
033668             GO TO DISPLAYER1.
033672     DISPLAY CONSOLE-LINE UPON CONSOLE.
033680 DISPLAYER-EXIT.
033700     EXIT.
033720
033740********************
033760* DATE SLASHING ROUTINE
033780********************
033800 DATE-SLASHER.
033820     MOVE WMON TO SMON.
033840     MOVE WDAY TO SDAY.
033860     MOVE WYEAR TO SYEAR.
033880 DATE-SLASHER-EXIT.
033900     EXIT.
033920
033940***********************************************************
033960* SUBROUTINES WHICH FOLLOW OPEN AND CLOSE FILES.
033980***********************************************************
034000
034020*****************************
034040* SUBROUTINE TO OPEN TRAN FILE.
034060*****************************
034080 OPEN-TRAN-FILE.
034100     IF TRAN-FILE-FLAG = 1 CLOSE QCDICT.
034120     OPEN INPUT QCDICT.
034140     MOVE 1 TO TRAN-FILE-FLAG.
034160 OPEN-TRAN-FILE-EXIT.
034180     EXIT.
034200
034220*****************************
034240* SUBROUTINE TO OPEN PRINT FILE.
034260*****************************
034280 OPEN-PRINT-FILE.
034300     IF PRINT-FILE-FLAG = 1 CLOSE QLDICT.
034320     OPEN OUTPUT QLDICT.
034340     MOVE 1 TO PRINT-FILE-FLAG.
034360 OPEN-PRINT-FILE-EXIT.
034380     EXIT.
034400
034420*****************************
034440* SUBROUTINE TO OPEN OUTPUT DICTIONARY FILE ONLY.
034460*****************************
034480 OPEN-OUT-DICT.
034500     IF DICT-FILE-FLAG = 1 CLOSE QPDICT.
034520     MOVE 0 TO DICT-EOF.
034540     OPEN OUTPUT QPDICT.
034560     MOVE 1 TO DICT-FILE-FLAG.
034580 OPEN-OUT-DICT-EXIT.
034600     EXIT.
034620
034640*****************************
034660* SUBROUTINE TO OPEN INPUT DICT FILE AND OUTPUT WORK FILE
034680*****************************
034700 OPEN-IN-DICT-OUT-WORK.
034720     MOVE 0 TO DICT-EOF.
034740     IF DICT-FILE-FLAG = 1 CLOSE QPDICT.
034760     IF WORK-FILE-FLAG = 1 CLOSE QTDICT
034770        MOVE 0 TO WORK-FILE-FLAG.
034780     OPEN INPUT QPDICT. MOVE 1 TO DICT-FILE-FLAG.
034800     OPEN OUTPUT QTDICT. MOVE 1 TO WORK-FILE-FLAG.
034820 OPEN-IN-DICT-OUT-WORK-EXIT.
034840     EXIT.
034860
034880*****************************
034900* SUBROUTINE TO OPEN INPUT WORK FILE AND OUTPUT DICT FILE.
034920*****************************
034940 OPEN-OUT-DICT-IN-WORK.
034960     MOVE 0 TO DICT-EOF.
034980     IF DICT-FILE-FLAG = 1 CLOSE QPDICT.
035000     IF WORK-FILE-FLAG = 1 CLOSE QTDICT
035010        MOVE 0 TO WORK-FILE-FLAG.
035020     OPEN INPUT QTDICT. MOVE 1 TO WORK-FILE-FLAG.
035040     OPEN OUTPUT QPDICT. MOVE 1 TO DICT-FILE-FLAG.
035060
035080*****************************
035100* SUBROUTINE TO CLOSE DICT AND WORK FILES.
035120*****************************
035140 CLOSE-DICT-WORK.
035160     MOVE 0 TO DICT-EOF.
035180     IF DICT-FILE-FLAG = 1 CLOSE QPDICT.
035200     IF WORK-FILE-FLAG = 1 CLOSE QTDICT
035210        MOVE 0 TO WORK-FILE-FLAG.
035220     MOVE 0 TO DICT-FILE-FLAG  WORK-FILE-FLAG.
035240
035260*****************************
035280* SUBROUTINE TO CLOSE ALL FILES.
035300*****************************
035320 CLOSE-ALL-FILES.
035340     IF DICT-FILE-FLAG = 1 CLOSE QPDICT.
035360     IF WORK-FILE-FLAG = 1 CLOSE QTDICT
035370        MOVE 0 TO WORK-FILE-FLAG.
035380     IF TRAN-FILE-FLAG = 1 CLOSE QCDICT.
035400     IF PRINT-FILE-FLAG = 1 CLOSE QLDICT.
035420     MOVE 0 TO DICT-FILE-FLAG WORK-FILE-FLAG
035440         TRAN-FILE-FLAG PRINT-FILE-FLAG DICT-EOF.
035460
035480***********************************************************
035500* SUBROUTINES BELOW ALL DEAL WITH CHECKING TRANSACTION
035520* AND MOVING IT INTO PERMANENT DICTIONARY ENTRY AND/OR
035540* PRINTING ENTRY FIELDS.
035560***********************************************************
035580
035600*****************************
035620* SUBROUTINE TO EDIT FD FIELDS IN INPUT TRAN
035640*****************************
035660 EDIT-FD-FIELDS.
035680     EXAMINE CF-RECLEN-X    REPLACING ALL SPACE BY 0.
035700     EXAMINE CF-BLKFACT-X    REPLACING ALL SPACE BY 0.
035720     EXAMINE CF-KEYPOS-X     REPLACING ALL SPACE BY 0.
035740     EXAMINE CF-KEYLEN-X     REPLACING ALL SPACE BY 0.
035760     EXAMINE CF-KEYTYPE-X    REPLACING ALL SPACE BY 0.
035780     EXAMINE CF-KEYSIGN      REPLACING ALL SPACE BY 0.
035800     EXAMINE CF-PROT-READ    REPLACING ALL SPACE BY 0.
035820     EXAMINE CF-PROT-COPY    REPLACING ALL SPACE BY 0.
035840     EXAMINE CF-PROT-REWR    REPLACING ALL SPACE BY 0.
035860
035880****************************
035900* SUBROUTINE TO CHECK FD FIELDS FOR ERRORS  PRINTOUT PROPER
035920* MESSAGES  AND CHANGE FIELDS CONTENTS AS INDICATED.
035940*****************************
035960 CHECK-FD-FIELDS.
035980     MOVE 0 TO TRAN-ERR-FLG.
036000     IF CF-NAME = SPACE PERFORM FD-ERROR
036020         MOVE 'BAD-NAME' TO CF-NAME
036040         MOVE FD-MSG-15 TO PRINT-LINE
036060         PERFORM PRINT1D.
036080     IF CF-FILETYPE = '6' OR '7' NEXT SENTENCE
036100         ELSE GO TO CHECK-FD-FIELDS2.
036120     IF CF-KEYTYPE-X = 'N' AND CF-KEYLEN GREATER THAN 10
036140         MOVE 2 TO CF-KEYTYPE  GO TO CHECK-FD-FIELDS1.
036160     IF CF-KEYTYPE-X = 'N'
036180         MOVE 1 TO CF-KEYTYPE GO TO CHECK-FD-FIELDS1.
036200     IF CF-KEYTYPE-X EQUAL TO 'A'
036220         MOVE 0 TO CF-KEYTYPE  GO TO CHECK-FD-FIELDS1.
036240     IF CF-KEYTYPE-X NOT = '0'
036260         AND CF-KEYTYPE-X NOT = '1'
036280         AND CF-KEYTYPE-X NOT = '2'
036300         MOVE 0 TO CF-KEYTYPE
036320         PERFORM FD-ERROR
036340         MOVE FD-MSG-13 TO PRINT-LINE PERFORM PRINT1D.
036360 CHECK-FD-FIELDS1.
036380     IF CF-KEYSIGN = 'S'
036400         MOVE '0' TO CF-KEYSIGN GO TO CHECK-FD-FIELDS2.
036420     IF CF-KEYSIGN = 'U' MOVE '1' TO CF-KEYSIGN
036440         GO TO CHECK-FD-FIELDS2.
036460     IF CF-KEYSIGN NOT = '0'
036480         AND CF-KEYSIGN NOT = '1'
036500         MOVE 1 TO CF-KEYSIGN
036520         PERFORM FD-ERROR
036540         MOVE FD-MSG-14 TO PRINT-LINE PERFORM PRINT1D.
036560 CHECK-FD-FIELDS2.
036580     IF CF-RECLEN-X IS NOT NUMERIC  PERFORM FD-ERROR
036600         MOVE 0 TO CF-RECLEN     MOVE 'REC LENGTH' TO FD-NO-NUM
036620         MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
036640     IF CF-BLKFACT IS NOT NUMERIC  PERFORM FD-ERROR
036660         MOVE 0 TO CF-BLKFACT-X   MOVE 'BLK FACT' TO FD-NO-NUM
036680         MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
036700     IF CF-KEYPOS-X IS NOT NUMERIC
036720         PERFORM FD-ERROR  MOVE 0 TO CF-KEYPOS
036740         MOVE 'KEY POSITION' TO FD-NO-NUM
036760         MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
036780     IF CF-KEYLEN-X IS NOT NUMERIC
036800         PERFORM FD-ERROR  MOVE 0 TO CF-KEYLEN
036820         MOVE 'KEY LENGTH' TO FD-NO-NUM
036840         MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
036860     IF CF-PROT-READ IS NOT NUMERIC PERFORM FD-ERROR
036880         MOVE 0 TO CF-PROT-READ
036900         MOVE 'READ PROTECT' TO FD-NO-NUM
036920         MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
036940     IF CF-PROT-COPY IS NOT NUMERIC
036960         MOVE 0 TO CF-PROT-COPY
036980         MOVE 'COPY PROTECT' TO FD-NO-NUM
037000         MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
037020     IF CF-PROT-REWR IS NOT NUMERIC
037040         MOVE 0 TO CF-PROT-REWR
037060         MOVE 'REWR PROTECT' TO FD-NO-NUM
037080         MOVE FD-MSG-11 TO PRINT-LINE PERFORM PRINT1D.
037100*    *BLK FAC CONVERSION NOTED OUT FOR NOW*    *
037120*    *IF HAVE OLD BLK LEN, CONVERT TO BLKFACT (< 0)*.
037140*    IF CF-BLKFACT GREATER THAN 0
037160*        DIVIDE CF-RECLEN INTO CF-BLKFACT GIVING WORK-1
037180*        SUBTRACT WORK-1 FROM 0 GIVING CF-BLKFACT.
037200*    IF CF-RECLEN  GREATER THAN MAX-RECLEN
037220*        MOVE MAX-RECLEN  TO CF-RECLEN   PERFORM FD-ERROR
037240*        MOVE FD-MSG-1  TO PRINT-LINE PERFORM PRINT1D.
037260*    IF CF-RECLEN  LESS THAN MIN-RECLEN
037280*        MOVE MIN-RECLEN  TO CF-RECLEN   PERFORM FD-ERROR
037300*        MOVE FD-MSG-2  TO PRINT-LINE PERFORM PRINT1D.
037320*    IF CF-BLKFACT GREATER THAN MAX-BLKFACT
037340*        MOVE CF-RECLEN  TO CF-BLKFACT  PERFORM FD-ERROR
037360*        MOVE FD-MSG-3  TO PRINT-LINE PERFORM PRINT1D.
037380     IF CF-FILETYPE = '8' GO TO CHECK-FD-NOBLOCK.
037400     IF ( CF-FILETYPE = '6' OR '7' ) AND
037420         CF-KEYPOS = 0 AND
037440         CF-KEYLEN = 0 AND
037460         CF-BLKFACT = 0 GO TO CHECK-FD-NOBLOCK.
037480     IF CF-BLKFACT = 0
037500        PERFORM FD-ERROR
037520        MOVE FD-MSG-16 TO PRINT-LINE PERFORM PRINT1D.
037540 CHECK-FD-NOBLOCK.
037560     IF CF-FILETYPE-X EQUAL TO SPACE
037580         MOVE '6' TO CF-FILETYPE-X  PERFORM FD-ERROR
037600         MOVE FD-MSG-5  TO PRINT-LINE PERFORM PRINT1D.
037620     MOVE CF-KEYPOS TO WORK-1. ADD CF-KEYLEN TO WORK-1.
037640     SUBTRACT 1 FROM WORK-1.
037660     IF WORK-1 IS GREATER THAN CF-RECLEN  PERFORM FD-ERROR
037680         MOVE 1 TO CF-KEYPOS
037700         MOVE FD-MSG-7  TO PRINT-LINE PERFORM PRINT1D.
037720     IF CF-KEYLEN GREATER THAN MAX-KEYLEN
037740         PERFORM FD-ERROR  MOVE MAX-KEYLEN TO CF-KEYLEN
037760         MOVE FD-MSG-9  TO PRINT-LINE PERFORM PRINT1.
037780     MOVE CF-KEYLEN TO WORK-1.
037800     ADD CF-KEYPOS TO WORK-1.
037820     ADD CF-KEYTYPE TO WORK-1.
037840     IF WORK-1 NOT = 0
037860         AND CF-FILETYPE NOT = '6'
037880         AND CF-FILETYPE NOT = '7'
037900         PERFORM FD-ERROR
037920         MOVE FD-MSG-12 TO PRINT-LINE PERFORM PRINT1D.
037940     IF TRAN-ERR-FLG NOT = 0
037960         MOVE FD-MSG-0  TO PRINT-LINE
037980         PERFORM DISPLAYER THRU DISPLAYER-EXIT
038000         DISPLAY ' ' UPON CONSOLE
038020         PERFORM PRINT1B.
038040 CHECK-FD-FIELDS-EXIT.  EXIT.
038060
038080*************************************
038100* SUB SUBROUTINE TO PRINT OFFENDING TRAN ON FIRST
038120* FD ERROR.
038140*************************************
038160 FD-ERROR.
038180     IF TRAN-ERR-FLG = 0 PERFORM PRINT-TRAN
038200         MOVE 1 TO TRAN-ERR-FLG.
038220 FD-ERROR-EXIT.
038240     EXIT.
038260
038280
038300*****************************
038320* SUBROUTINE TO MOVE FD FIELDS FROM TRAN-WS TO DICT-WS.
038340*****************************
038360 MOVE-FD-FIELDS.
038380     MOVE SPACE         TO DICT-FD.
038400     MOVE CF-IDNT       TO DF-IDNT.
038420     MOVE CF-NAME       TO DF-NAME.
038440     MOVE 0          TO DF-NDICTS.
038460     MOVE CF-INLABEL    TO DF-INLABEL.
038480     MOVE CF-DIRECT     TO DF-DIRECT.
038500     MOVE CF-FILETYPE-X TO DF-FILETYPE.
038520     MOVE CF-RECLEN     TO DF-RECLEN.
038540     MOVE CF-BLKFACT    TO DF-BLKFACT.
038560     MOVE CF-KEYPOS     TO DF-KEYPOS.
038580     MOVE CF-KEYLEN     TO DF-KEYLEN.
038600     MOVE CF-KEYTYPE    TO DF-KEYTYPE.
038620     MOVE CF-KEYSIGN    TO DF-KEYSIGN.
038640     MOVE CF-PROT-READ  TO DF-PROT-READ.
038660     MOVE CF-PROT-COPY  TO DF-PROT-COPY.
038680     MOVE CF-PROT-REWR  TO DF-PROT-REWR.
038700     MOVE PACKED-DATE   TO DF-LAST-UPDATE.
038720 MOVE-FD-FIELDS-EXIT.
038740     EXIT.
038760
038780*****************************
038800* SUBROUTINE TO PRINT FD HEADING ON PAGE.
038820*****************************
038840 PRINT-FD-HEAD.
038860     MOVE HEAD-4        TO PRINT-LN.
038880     PERFORM PRINT1.
038900     MOVE FD-HEAD-1     TO PRINT-LN.
038920     PERFORM PRINT1.
038940     MOVE FD-HEAD-2     TO PRINT-LN.
038960     PERFORM PRINT1.
038980     MOVE FD-HYPHS      TO PRINT-LN.
039000     PERFORM PRINT1.
039020
039040*****************************
039060* SUBROUTINE TO PRINT FD FIELDS FROM DICT-WS
039080*****************************
039100 PRINT-FD-FIELDS.
039110     MOVE DF-PROT-COPY TO COPY-LEVEL.
039120     MOVE SPACE      TO FD-DATA.
039140     MOVE DF-NAME    TO FIL-NM-PRT.
039142     MOVE DF-PROT-READ TO FD-PD-READ.
039144     MOVE DF-PROT-READ TO UNLOCKED-WORK.
039146     IF UNLOCKED-WORK > UNLOCKED-LEVEL
039148         MOVE '**' TO FD-PD-READ FD-PD-COPY FD-PD-REWR
039150         GO TO PRINT-FD-FIELDS1.
039152     MOVE DF-PROT-COPY TO FD-PD-COPY.
039154     MOVE DF-PROT-COPY TO UNLOCKED-WORK.
039156     IF UNLOCKED-WORK > UNLOCKED-LEVEL
039158         MOVE '**' TO FD-PD-COPY FD-PD-REWR
039160         GO TO PRINT-FD-FIELDS1.
039162     MOVE DF-PROT-REWR TO FD-PD-REWR.
039164     MOVE DF-PROT-REWR TO UNLOCKED-WORK.
039166     IF UNLOCKED-WORK > UNLOCKED-LEVEL
039168         MOVE '**' TO FD-PD-REWR
039170         ELSE GO TO PRINT-FD-FIELDS2.
039172 PRINT-FD-FIELDS1.
039174     MOVE '(Locked)' TO IN-LAB-PRT.
039176     GO TO PRINT-FD-FIELDS3.
039178 PRINT-FD-FIELDS2.
039340     MOVE DF-INLABEL TO IN-LAB-PRT.
039360     MOVE DF-DIRECT  TO DIRECT-PRT.
039380     MOVE DF-FILETYPE TO TEMPFTX.
039400     IF TEMPFTX EQUAL TO 'V'
039420         MOVE 10 TO I ELSE IF TEMPFTX EQUAL TO 'S'
039440         MOVE 11 TO I ELSE IF TEMPFTX IS NOT NUMERIC
039460         MOVE 12 TO I.
039480     IF TEMPFTX IS NUMERIC MOVE TEMPNUMFT TO I.
039500     MOVE TYPE-LIST (I) TO FIL-TYP-PRT.
039520     IF DF-KEYPOS NOT = 0 MOVE 'ISAM' TO FIL-ORG-PRT.
039540     MOVE DF-RECLEN  TO RECZ-PRT.
039560*    *IF OLD BLK LEN (> 0), CONVERT TO BLK FAC.
039580     IF DF-BLKFACT GREATER THAN 0
039600         DIVIDE DF-RECLEN INTO DF-BLKFACT GIVING WORK-1
039620         ELSE SUBTRACT DF-BLKFACT FROM 0 GIVING WORK-1.
039640     MOVE WORK-1 TO BLKF-PRT.
039660     MOVE DF-KEYPOS  TO KEY-POS-PRT.
039680     MOVE DF-KEYLEN  TO KEY-LEN-PRT.
039700     MOVE SPACE      TO KEY-TYP-PRT KEY-SIGN-PRT.
039720     IF DF-KEYPOS = 0 GO TO PRINT-FD-FIELDS3.
039740     MOVE DF-KEYTYPE TO KEY-TYP-PRT.
039760     IF DF-KEYTYPE = 0 MOVE 'A' TO KEY-TYP-PRT.
039780     IF DF-KEYTYPE = 1 MOVE 'N' TO KEY-TYP-PRT.
039800     IF DF-KEYTYPE = 2 MOVE 'N' TO KEY-TYP-PRT.
039820     MOVE DF-KEYSIGN TO KEY-SIGN-PRT.
039840     IF DF-KEYSIGN = 0 MOVE 'S' TO KEY-SIGN-PRT.
039860     IF DF-KEYSIGN = 1 MOVE 'U' TO KEY-SIGN-PRT.
039880 PRINT-FD-FIELDS3.
040120     MOVE DF-LAST-UPDATE TO DATE-WORK.
040140     IF DATE-WORK = SPACE MOVE SPACE TO FD-UPDATE-PRT ELSE
040160         PERFORM DATE-SLASHER
040180         MOVE SLASHED-DATE TO FD-UPDATE-PRT.
040200     PERFORM SPACER.
040220     IF TRAN-ERR-FLG = 1 MOVE SPACE TO PRINT-LINE
040240         PERFORM PRINT1.
040260     MOVE FD-DATA TO PRINT-LN.
040280     PERFORM PRINT1.
040300     PERFORM SPACER.
040320 PRINT-FD-FIELDS-EXIT.
040340     EXIT.
040360
040380*****************************
040400* SUBROUTINE TO EDIT FIELDS IN DD TRAN INPUT
040420*****************************
040440 EDIT-DD-FIELDS.
040460     EXAMINE CD-NCHARS-X     REPLACING ALL SPACE BY 0.
040480     EXAMINE CD-FCHAR-X      REPLACING ALL SPACE BY 0.
040500     EXAMINE CD-EDIT-X       REPLACING ALL SPACE BY 0.
040520     EXAMINE CD-OFFSET-X     REPLACING ALL SPACE BY 0.
040540     EXAMINE CD-SCALE-X      REPLACING ALL SPACE BY 0.
040560     EXAMINE CD-NREPEATS-X   REPLACING ALL SPACE BY 0.
040580     EXAMINE CD-PROT-NO-X    REPLACING ALL SPACE BY 0.
040600 EDIT-DD-FIELDS-EXIT.
040620     EXIT.
040640
040660******************************
040680* SUBROUTINE TO CHECK DD FIELDS AND MODIFY IF NECESSARY
040700******************************
040720 CHECK-DD-FIELDS.
040740     MOVE 0 TO TRAN-ERR-FLG EDIT-ERROR-FLAG.
040760     IF CD-NAME = SPACE PERFORM DD-ERROR
040780         MOVE DD-MSG-19 TO PRINT-LINE
040800         PERFORM PRINT1D.
040820     IF CD-NCHARS-X IS NOT NUMERIC  MOVE 'ITEM LENGTH'
040840         TO DD-NO-NUM  MOVE 0 TO CD-NCHARS
040860         PERFORM DD-ERROR
040880         MOVE DD-MSG-18 TO PRINT-LINE  PERFORM PRINT1D.
040900     IF CD-FCHAR-X = 'DBMS' MOVE '0000' TO CD-FCHAR-X.
040920     IF CD-FCHAR-X IS NOT NUMERIC
040940         MOVE 'FIRST CHAR LOC'
040960         TO  DD-NO-NUM  MOVE 0 TO CD-FCHAR
040980         PERFORM DD-ERROR
041000         MOVE DD-MSG-18 TO PRINT-LINE  PERFORM PRINT1D.
041020     IF CD-SCALE-X IS NOT NUMERIC  MOVE 'SCALE'
041040         TO DD-NO-NUM  MOVE 0 TO CD-SCALE
041060         PERFORM DD-ERROR
041080         MOVE DD-MSG-18 TO PRINT-LINE  PERFORM PRINT1D.
041100     MOVE 0 TO CD-OFFSET.
041120     IF CD-EDIT-X IS NOT NUMERIC  MOVE 'EDIT CODE' TO
041140         DD-NO-NUM  MOVE 0 TO CD-EDIT
041160         PERFORM DD-ERROR
041180         MOVE DD-MSG-18 TO PRINT-LINE  PERFORM PRINT1D.
041200     IF CD-NREPEATS-X IS NOT NUMERIC  MOVE 'SCAN REPEATS'
041220         TO DD-NO-NUM  MOVE 0 TO CD-NREPEATS
041240         PERFORM DD-ERROR
041260         MOVE DD-MSG-18 TO PRINT-LINE  PERFORM PRINT1D.
041280     IF CD-PROT-NO-X IS NOT NUMERIC  MOVE 'PROT REF'
041300         TO DD-NO-NUM  MOVE 0 TO CD-PROT-NO
041320         PERFORM DD-ERROR
041340         MOVE DD-MSG-18 TO PRINT-LINE  PERFORM PRINT1D.
041360     IF CD-ACT NOT = ' ' AND CD-ACT NOT = 'A' AND
041380        CD-ACT NOT = 'C' AND CD-ACT NOT = 'D'
041400         PERFORM DD-ERROR
041420         MOVE DD-MSG-1  TO PRINT-LINE  PERFORM PRINT1D.
041440     IF CD-NME1 = 'X' OR CD-NME2 = 'ZZ'
041460         PERFORM DD-ERROR
041480         MOVE DD-MSG-2  TO PRINT-LINE  PERFORM PRINT1D.
041500*    *CHECK FOR FCHAR = 0 DISABLED TO PERMIT DBMS DYNAMIC*.
041520*    IF CD-FCHAR = 0
041540*        PERFORM DD-ERROR
041560*        MOVE DD-MSG-3  TO PRINT-LINE  PERFORM PRINT1D.
041580*    *NOTE: RECORD LENGTH CHECK DISABLED THIS VERSION*.
041600*    IF CD-FCHAR GREATER THAN MAX-RECLEN
041620*        PERFORM DD-ERROR
041640*        MOVE DD-MSG-4  TO PRINT-LINE  PERFORM PRINT1D.
041660     IF CD-NCHARS = 0
041680         PERFORM DD-ERROR
041700         MOVE DD-MSG-5  TO PRINT-LINE  PERFORM PRINT1D.
041720*    *NOTE: ITEM LENGTH CHECK DISABLED THIS VERSION*.
041740*    IF CD-NCHARS GREATER THAN MAX-ITEMLEN
041760*        PERFORM DD-ERROR
041780*        MOVE DD-MSG-6  TO PRINT-LINE  PERFORM PRINT1D.
041800     IF CD-TYPE-X = 'A' MOVE '1' TO CD-TYPE.
041820     IF CD-TYPE-X = 'N' MOVE '2' TO CD-TYPE.
041840     IF CD-TYPE-X = 'B' MOVE '6' TO CD-TYPE.
041860     IF CD-TYPE-X NOT = '1' AND CD-TYPE-X NOT = '2' AND
041880         CD-TYPE-X NOT = '6'
041900         PERFORM DD-ERROR
041920         MOVE DD-MSG-7  TO PRINT-LINE  PERFORM PRINT1D.
041940     IF CD-SCALE GREATER THAN CD-NCHARS
041960         PERFORM DD-ERROR
041980         MOVE DD-MSG-8  TO PRINT-LINE  PERFORM PRINT1D.
042000     IF CD-EDIT-X = '31' MOVE '00' TO CD-EDIT-X.
042020     IF CD-EDIT GREATER THAN MAX-EDIT
042040         PERFORM DD-ERROR
042060         MOVE DD-MSG-9  TO PRINT-LINE  PERFORM PRINT1D.
042080     IF CD-PICT NOT = SPACE
042100         PERFORM CHECK-PICT THROUGH CHECK-PICT-EXIT.
042120     IF EDIT-ERROR-FLAG NOT = 0 
042122         ADD 1 TO LINE-CTR PERFORM PRINT-TRAN
042126         MOVE DD-MSG-11 TO PRINT-LINE PERFORM PRINT1D
042128         MOVE 0 TO EDIT-ERROR-FLAG.
042160     IF CD-GRPNME = SPACE AND CD-NREPEATS NOT = 0
042180         PERFORM DD-ERROR
042200         MOVE DD-MSG-13 TO PRINT-LINE  PERFORM PRINT1D.
042220*    MULTIPLY CD-NREPEATS BY CD-NCHARS GIVING WORK-2.
042240*    ADD CD-FCHAR TO WORK-2.
042260*    IF WORK-2 IS GREATER THAN MAX-RECLEN
042280*        PERFORM DD-ERROR
042300*        MOVE DD-MSG-14 TO PRINT-LINE  PERFORM PRINT1D.
042320     IF CD-GRPNME NOT = SPACE AND CD-NREPEATS = 0
042340         PERFORM DD-ERROR
042360         MOVE DD-MSG-15 TO PRINT-LINE  PERFORM PRINT1D.
042380     IF CD-EXCLFLAG = ' ' MOVE '0' TO CD-EXCLFLAG.
042400     IF CD-EXCLFLAG = 'Y' MOVE '1' TO CD-EXCLFLAG.
042420     IF CD-EXCLFLAG = 'N' MOVE '0' TO CD-EXCLFLAG.
042440     IF CD-EXCLFLAG NOT = '0' AND CD-EXCLFLAG NOT = '1'
042460         PERFORM DD-ERROR
042480         MOVE DD-MSG-17 TO PRINT-LINE  PERFORM PRINT1D.
042500     IF TRAN-ERR-FLG NOT = 0
042520         MOVE DD-MSG-0  TO PRINT-LINE
042540         PERFORM DISPLAYER THRU DISPLAYER-EXIT
042560         DISPLAY ' ' UPON CONSOLE
042580         PERFORM PRINT1B.
042600 CHECK-DD-FIELDS-EXIT.
042620     EXIT.
042640
042660*****************************************
042680* SUB SUBROUTINE TO PRINT OFFENDING DD TRAN
042700* ON FIRST ERROR ENCOUNTERED.
042720******************************************
042740 DD-ERROR.
042760     ADD 1 TO LINE-CTR.
042780     IF TRAN-ERR-FLG = 0 PERFORM PRINT-TRAN
042800         MOVE 1 TO TRAN-ERR-FLG.
042820 DD-ERROR-EXIT.
042840     EXIT.
042860
042880*****************************
042900* SUBROUTINE TO MOVE DD FIELDS FROM TRAN-WS TO DICT-WS.
042920*****************************
042940 MOVE-DD-FIELDS.
042960     MOVE SPACE        TO DICT-DD.
042980     MOVE CD-IDNT      TO DD-IDNT.
043000     MOVE CD-NAME      TO DD-NAME  LAST-DD-NAME.
043020     MOVE CD-TITLE1    TO DD-TITLE1.
043040     MOVE CD-TITLE2    TO DD-TITLE2.
043060     MOVE CD-FCHAR     TO DD-FCHAR.
043080     MOVE CD-NCHARS    TO DD-NCHARS.
043100     MOVE CD-EDIT      TO DD-EDIT.
043120     MOVE CD-TYPE      TO DD-TYPE.
043140     MOVE CD-SCALE     TO DD-SCALE.
043160     MOVE CD-OFFSET    TO DD-OFFSET.
043180     MOVE CD-PICT      TO DD-PICT.
043200     MOVE CD-GRPNME    TO DD-GRPNME.
043220     MOVE CD-NREPEATS  TO DD-NREPEATS.
043240     MOVE CD-STOPPER   TO DD-STOPPER.
043260     MOVE CD-PROT-NO   TO DD-PROT-NO.
043280     MOVE CD-EXCLFLAG  TO DD-EXCLFLAG.
043300     IF CD-NOUPD = 'N' MOVE 'N' TO DD-NOUPD
043310         ELSE MOVE ' ' TO DD-NOUPD.
043320     PERFORM DD-TITLE-LENGTH THROUGH DD-TITLE-LENGTH-EXIT.
043340     IF CD-TYPE NOT EQUAL TO '1' AND CD-EDIT = 0
043360         AND CD-PICT = SPACE AND CD-NCHARS NOT > 18
043380         PERFORM MAKE-OWN-PICT THROUGH MAKE-OWN-PICT-EXIT.
043400     PERFORM MODIFYPICTED THROUGH MODIFY-EXIT.
043420     PERFORM EDIT-LENGTH THROUGH EDIT-LENGTH-EXIT.
043440     PERFORM GETGRPLEN THRU GETGRPLENX.
043460     MOVE PACKED-DATE TO DD-LAST-UPDATE.
043480 MOVE-DD-FIELDS-EXIT.
043500     EXIT.
043520
043540*****************************
043560* SUBROUTINE TO PRINT DD COLUMN HEADINGS.
043580*****************************
043600 PRINT-DD-HEAD.
043620     MOVE HEAD-5       TO PRINT-LN.
043640     PERFORM PRINT1.
043660     MOVE DD-HEAD1     TO PRINT-LN.
043680     PERFORM PRINT1.
043700     MOVE DD-HEAD-2    TO PRINT-LN.
043720     PERFORM PRINT1.
043740     MOVE DD-HYPHS     TO PRINT-LN.
043760     PERFORM PRINT1B.
043780
043800*****************************
043820* SUBROUTINE TO PRINT DD FIELDS FROM DICT-WS.
043840*****************************
043860 PRINT-DD-FIELDS.
043880     MOVE SPACE       TO DD-DATA.
043900     MOVE DD-IDNT     TO DD-DATA-IDNT.
043920     MOVE DD-NAME     TO DD-NAME-PRT.
043940     MOVE DD-TITLE1   TO DD-TITLE1-PRT.
043960     MOVE DD-TITLE2   TO DD-TITLE2-PRT.
043980     MOVE DD-NTCHARS  TO NTCHAR-PRT.
043990     MOVE DD-NCHARS    TO NCHAR-PRT.
044000     MOVE DD-NECHARS  TO NECHAR-PRT.
044002     MOVE DD-FCHAR    TO DD-FCHAR-PRT.
044004     IF DD-PROT-NO > UNLOCKED-LEVEL 
044006         OR COPY-LEVEL > UNLOCKED-LEVEL
044010         MOVE SPACES TO DD-FCHAR-PRT.
044012     MOVE DD-PROT-NO-X TO DP-PRT.
044014     IF DD-EXCLFLAG = 1 MOVE 'E' TO DD-EXCLFLAG-PRT
044016         MOVE DASH TO DP-PROT-DASH.
044018     IF DD-PROT-NO-X = '  ' OR '00'
044020         MOVE SPACE TO PROT-PRT
044022          ELSE IF DD-PROT-NO > UNLOCKED-LEVEL
044024             MOVE '**  ' TO PROT-PRT.
044100     IF DD-FCHAR = 0 MOVE 'DBMS' TO DD-FCHAR-PRT-DBS.
044140     MOVE DD-EDIT     TO DD-EDIT-PRT.
044160     IF DD-TYPE = '1' MOVE 'ALPHA'  TO DD-TYPE-PRT.
044180     IF DD-TYPE = '2' MOVE 'NUM  '  TO DD-TYPE-PRT.
044200     IF DD-TYPE = '6' MOVE 'BINARY' TO DD-TYPE-PRT.
044220     MOVE DD-SCALE  TO SCL-PRT.
044240     MOVE DD-PICT   TO PICT-PRT.
044260     MOVE DD-GRPLEN TO GRPLEN-PRT.
044280     IF DD-NREPEATS = '00' OR '  ' MOVE SPACE TO SCAN-PRT
044300         ELSE MOVE DASH TO DD-SCAN-DASH1  DD-SCAN-DASH2
044320             MOVE DD-GRPNME TO GRPNME-PRT
044340             MOVE DD-NREPEATS TO NREPEATS-PRT
044360             MOVE DD-STOPPER TO STOPPER-PRT.
044500     MOVE DD-LAST-UPDATE TO DATE-WORK.
044520     PERFORM DATE-SLASHER.
044540     IF DATE-WORK = SPACE MOVE SPACE TO DD-UPDATE-PRT ELSE
044560     MOVE SLASHED-DATE TO DD-UPDATE-PRT.
044580     MOVE DD-DATA TO PRINT-LN.
044600     PERFORM PRINT1.
044620     IF TRAN-ERR-FLG = 1 MOVE SPACE TO PRINT-LINE
044640     PERFORM PRINT1.
044660
044680*****************************
044700* SUBROUTINE TO EDIT FIELDS IN PD TRAN INPUT
044720*****************************
044740 EDIT-PD-FIELDS.
044760     EXAMINE CP-PROT-NO-X REPLACING ALL SPACE BY 0.
044780     EXAMINE CP-LINE-X    REPLACING ALL SPACE BY 0.
044800 EDIT-PD-FIELDS-EXIT.
044820     EXIT.
044840
044860******************************
044880* SUBROUTINE TO CHECK FIELDS IN PD TRAN INPUT
044900******************************
044920 CHECK-PD-FIELDS.
044940     MOVE 0 TO TRAN-ERR-FLG.
044960     IF CP-PROT-NO-X NOT NUMERIC
044980         MOVE 1 TO TRAN-ERR-FLG  PERFORM PRINT-TRAN
045000         MOVE PD-MSG-1 TO PRINT-LINE
045020         PERFORM PRINT1D
045040         MOVE PD-MSG-0 TO PRINT-LINE
045060         PERFORM DISPLAYER THRU DISPLAYER-EXIT
045080         DISPLAY ' ' UPON CONSOLE
045100         PERFORM PRINT1B.
045120     MOVE 1 TO CP-LINE.
045140     MOVE 0 TO CP-DATE-FLAG.
045160 CHECK-PD-FIELDS-EXIT.
045180     EXIT.
045200
045220*****************************
045240* SUBROUTINE TO MOVE PD FIELDS FROM TRAN-WS TO DICT-WS.
045260*****************************
045280 MOVE-PD-FIELDS.
045300     MOVE SPACE        TO DICT-PD.
045320     MOVE '1'          TO DF-PROT.
045340     MOVE CP-IDNT      TO DP-IDNT.
045360     MOVE CP-PROT-NO   TO DP-PROT-NO.
045380     MOVE CP-DATE-FLAG TO DP-DATE-FLAG.
045400     MOVE CP-LINE      TO DP-LINE.
045420     MOVE PACKED-DATE  TO DP-LAST-UPDATE.
045440     MOVE CP-PASSWORD  TO DP-TEXT.
045460     PERFORM SCRAMBLE-PW THRU SCRAMBLE-PW-EXIT.
045480 MOVE-PD-FIELDS-EXIT.
045500     EXIT.
045520
045540*****************************
045560* SUBROUTINE TO PRINT PD FIELDS FROM DICT-WS
045580*****************************
045600 PRINT-PD-FIELDS.
045620     MOVE SPACE      TO PD-DATA.
045640     MOVE 'PD'       TO PD-DATA-IDNT.
045660     MOVE DP-PROT-NO TO DP-PROT-NO-PRINT.
045680     MOVE DP-TEXT    TO PW-TEXT-HOLDER.
045700     PERFORM UNSCRAMBLE-PW THRU UNSCRAMBLE-PW-EXIT.
045710     IF UNLOCKED-LEVEL < DP-PROT-NO
045720         MOVE '(Locked)' TO DP-TEXT-PRINT
045740         ELSE MOVE DP-TEXT TO DP-TEXT-PRINT.
045760     MOVE PW-TEXT-HOLDER TO DP-TEXT.
045780     MOVE DP-LAST-UPDATE TO DATE-WORK.
045800     PERFORM DATE-SLASHER.
045820     IF DATE-WORK = SPACE MOVE SPACE TO DP-UPDATE-PRINT ELSE
045840     MOVE SLASHED-DATE TO DP-UPDATE-PRINT.
045860     MOVE PD-DATA      TO PRINT-LN.
045880     PERFORM PRINT1.
045900 PRINT-PD-FIELDS-EXIT.
045920     EXIT.
045940
045960********************
045980* SUBROUTINE TO MOVE COMMENT (CD) FIELDS TO DICT-WS.
046000********************
046020 MOVE-CD-FIELDS.
046040     MOVE SPACE        TO DICT-CD.
046060     MOVE 'CD'         TO DC-IDNT.
046080     MOVE CC-NO        TO DC-NO.
046100     MOVE CC-TEXT      TO DC-TEXT.
046120     MOVE PACKED-DATE  TO DC-LAST-UPDATE.
046140 MOVE-CD-FIELDS-EXIT.
046160     EXIT.
046180
046200********************
046220* SUBROUTINE TO PRINT COMMENT (CD) FIELDS FROM DICT-WS.
046240********************
046260 PRINT-CD-FIELDS.
046280     MOVE SPACE          TO CD-DATA.
046300     MOVE 'CD'           TO CD-DATA-IDNT.
046320     MOVE DC-NO          TO DC-NO-PRT.
046340     MOVE DC-TEXT        TO DC-TEXT-PRT.
046360     MOVE DC-LAST-UPDATE TO DATE-WORK.
046380     PERFORM DATE-SLASHER.
046400     IF DATE-WORK = SPACE MOVE SPACE TO DC-UPDATE-PRT ELSE
046420     MOVE SLASHED-DATE   TO DC-UPDATE-PRT.
046440     MOVE CD-DATA       TO PRINT-LN.
046460     PERFORM PRINT1.
046480 PRINT-CD-FIELDS-EXIT.
046500     EXIT.
046520
046540*************************************
046560* EDIT RD, AD, AND SD FIELDS.
046580***********************************
046600 EDIT-RD-FIELDS.
046620     EXAMINE RD-ORIGIN-X REPLACING ALL SPACE BY 0.
046640     EXAMINE RD-LENGTH-X REPLACING ALL SPACE BY 0.
046660 EDIT-RD-FIELDS-EXIT.
046680     EXIT.
046700
046720*************************************
046740* CHECK RD, AD, AND SD FIELDS.
046760*************************************
046780 CHECK-RD-FIELDS.
046800     MOVE 0 TO TRAN-ERR-FLG.
046820     IF RD-NAME = SPACE
046840         PERFORM DD-ERROR
046860         MOVE DD-MSG-19 TO PRINT-LINE
046880         PERFORM PRINT1D.
046900     IF RD-ORIGIN-X IS NOT NUMERIC
046920         MOVE 'ORIGIN' TO DD-NO-NUM
046940         MOVE 0 TO RD-ORIGIN
046960         PERFORM DD-ERROR
046980         MOVE DD-MSG-18 TO PRINT-LINE
047000         PERFORM PRINT1D.
047020     IF RD-LENGTH-X IS NOT NUMERIC
047040         MOVE 'LENGTH' TO DD-NO-NUM
047060         MOVE 0 TO RD-LENGTH
047080         PERFORM DD-ERROR
047100         MOVE DD-MSG-18 TO PRINT-LINE
047120         PERFORM PRINT1D.
047140 CHECK-RD-FIELDS-EXIT.
047160     EXIT.
047180
047200*********************************
047220* MOVE RD, AD, AND SD FIELDS FROM TRAN TO DICT-WS.
047240*********************************
047260 MOVE-RD-FIELDS.
047280     MOVE RD-IDNT   TO DR-IDNT.
047300     MOVE RD-NAME   TO DR-NAME.
047320     MOVE RD-ORIGIN TO DR-ORIGIN.
047340     MOVE RD-LENGTH TO DR-LENGTH.
047360     MOVE RD-TYPE   TO DR-TYPE.
047380     MOVE RD-TEXT   TO DR-TEXT.
047400 MOVE-RD-FIELDS-EXIT.
047420     EXIT.
047440
047460********************************
047480* SUBROUTINE TO PRINT RD, AD, OR SD FIELDS FROM DICT WS.
047500********************************
047520 PRINT-RD-FIELDS.
047540     MOVE SPACE          TO RD-DATA.
047560     MOVE DR-IDNT        TO RD-DATA-IDNT.
047580     MOVE DR-NAME        TO RD-DATA-NAME.
047584     IF UNLOCKED-LEVEL NOT < PROTECTED-LEVEL
047600         MOVE DR-ORIGIN      TO RD-DATA-ORIGIN
047620         MOVE DR-LENGTH      TO RD-DATA-LENGTH.
047640     MOVE DR-TYPE        TO RD-DATA-TYPE.
047660     MOVE DR-TEXT        TO RD-DATA-TEXT.
047680     MOVE DR-LAST-UPDATE TO DATE-WORK.
047700     PERFORM DATE-SLASHER.
047720     IF DATE-WORK = SPACE MOVE SPACE TO RD-DATA-UPDATE
047740          ELSE MOVE SLASHED-DATE TO RD-DATA-UPDATE.
047760     MOVE RD-DATA TO PRINT-LINE.
047780     PERFORM PRINT2.
047800 PRINT-RD-FIELDS-EXIT.
047820      EXIT.
047840
047860*****************************
047880* SUBROUTINE TO GO TO A NEW PAGE AND PRINT GENERAL HEADING.
047900*****************************
047920 NEW-PAGE.
047940     MOVE HEAD-1 TO PRINT-LN.
047960     WRITE PRINT-LINE AFTER ADVANCING TOP-OF-PAGE.
047980     ADD 1 TO PAGE-CTR.
048000     MOVE PAGE-CTR TO PAGE-OUT.
048020     MOVE HEAD-2 TO PRINT-LN.
048040     WRITE PRINT-LINE AFTER ADVANCING 1 LINES.
048060     MOVE HEAD-3 TO PRINT-LN.
048080     WRITE PRINT-LINE AFTER ADVANCING 1 LINES.
048100     MOVE ' ' TO PRINT-LINE.
048120     WRITE PRINT-LINE AFTER ADVANCING 1 LINES.
048140     MOVE 3 TO LINE-CTR.
048160
048180*********************************
048200* THIS SUBROUTINE SCRAMBLES PASSWORDS.
048220*********************************
048240 SCRAMBLE-PW.
048260     MOVE DP-CHAR (1) TO PW-CHAR (10).
048280     MOVE DP-CHAR (2) TO PW-CHAR (9).
048300     MOVE DP-CHAR (3) TO PW-CHAR (6).
048320     MOVE DP-CHAR (4) TO PW-CHAR (12).
048340     MOVE DP-CHAR (5) TO PW-CHAR (3).
048360     MOVE DP-CHAR (6) TO PW-CHAR (2).
048380     MOVE LAST-DD-CHAR (1) TO PW-CHAR (1).
048400     MOVE LAST-DD-CHAR (2) TO PW-CHAR (7).
048420     MOVE LAST-DD-CHAR (3) TO PW-CHAR (4).
048440     MOVE LAST-DD-CHAR (4) TO PW-CHAR (11).
048460     MOVE LAST-DD-CHAR (5) TO PW-CHAR (8).
048480     MOVE LAST-DD-CHAR (6) TO PW-CHAR (5).
048500     ADD PW-MASK1 TO PW-WORK1.
048520     ADD PW-MASK2 TO PW-WORK2.
048540     MOVE PW-CHAR (1)  TO DP-CHAR (1).
048560     MOVE PW-CHAR (2)  TO DP-CHAR (2).
048580     MOVE PW-CHAR (3)  TO DP-CHAR (3).
048600     MOVE PW-CHAR (4)  TO DP-CHAR (4).
048620     MOVE PW-CHAR (5)  TO DP-CHAR (5).
048640     MOVE PW-CHAR (6)  TO DP-CHAR (6).
048660     MOVE PW-CHAR (7)  TO DP-CHAR (7).
048680     MOVE PW-CHAR (8)  TO DP-CHAR (8).
048700     MOVE PW-CHAR (9)  TO DP-CHAR (9).
048720     MOVE PW-CHAR (10) TO DP-CHAR (10).
048740     MOVE PW-CHAR (11) TO DP-CHAR (11).
048760     MOVE PW-CHAR (12) TO DP-CHAR (12).
048780 SCRAMBLE-PW-EXIT.
048800     EXIT.
048820
048840*******************************
048860* THIS SUBROUTINE UNSCRAMBLES PASSWORDS.
048880*******************************
048900 UNSCRAMBLE-PW.
048920     MOVE DP-CHAR (1)  TO PW-CHAR (1).
048940     MOVE DP-CHAR (2)  TO PW-CHAR (2).
048960     MOVE DP-CHAR (3)  TO PW-CHAR (3).
048980     MOVE DP-CHAR (4)  TO PW-CHAR (4).
049000     MOVE DP-CHAR (5)  TO PW-CHAR (5).
049020     MOVE DP-CHAR (6)  TO PW-CHAR (6).
049040     MOVE DP-CHAR (7)  TO PW-CHAR (7).
049060     MOVE DP-CHAR (8)  TO PW-CHAR (8).
049080     MOVE DP-CHAR (9)  TO PW-CHAR (9).
049100     MOVE DP-CHAR (10) TO PW-CHAR (10).
049120     MOVE DP-CHAR (11) TO PW-CHAR (11).
049140     MOVE DP-CHAR (12) TO PW-CHAR (12).
049160     SUBTRACT PW-MASK1 FROM PW-WORK1.
049180     SUBTRACT PW-MASK2 FROM PW-WORK2.
049200     MOVE SPACE TO DP-TEXT.
049220     MOVE PW-CHAR (10) TO DP-CHAR (1).
049240     MOVE PW-CHAR (9)  TO DP-CHAR (2).
049260     MOVE PW-CHAR (6)  TO DP-CHAR (3).
049280     MOVE PW-CHAR (12) TO DP-CHAR (4).
049300     MOVE PW-CHAR (3)  TO DP-CHAR (5).
049320     MOVE PW-CHAR (2)  TO DP-CHAR (6).
049340 UNSCRAMBLE-PW-EXIT.
049360     EXIT.
049380
049400*****************************
049420* THIS SUBROUTINE FINDS THE LENGTH OF THE EDIT
049440*      PIC IF THERE IS ONE AND MOVES IT
049460*      INTO FIELD DD-NECHARS.  IF THERE IS NO EDIT PICTURE
049480*      THE NUMBER OF CHARACTERS IN THE ITEM (FIELD DD-NCHARS)
049500*      IS MOVED INTO DD-NECHARS.
049520*****************************
049540 EDIT-LENGTH.
049560     SET PIX TO 19.
049580     MOVE DD-PICT  TO PICT-REDEF.
049600 EDIT-LENGTH-LOOP.
049620     IF PICTCHAR (PIX) IS NOT EQUAL TO SPACE
049640         GO TO EDIT-LENGTH-DONE.
049660     SET PIX DOWN BY 1.
049680     IF PIX IS NOT EQUAL TO 0 GO TO EDIT-LENGTH-LOOP.
049700     SET PIX TO DD-NCHARS.
049720 EDIT-LENGTH-DONE.
049740     SET DD-NECHARS TO PIX.
049760 EDIT-LENGTH-EXIT.
049780     EXIT.
049800
049820*****************************
049840*    THIS SUBROUTINE FINDS THE LONGEST
049860*    LENGTH OF THE TOP OR BOTTOM COLUMN DD-TITLWS
049880*    AND STORES IT IN FIELD DD-NTCHARS.
049900*****************************
049920 DD-TITLE-LENGTH.
049940     SET TTX TO 10.  SET BTX TO 10.
049960     MOVE DD-TITLE1  TO TOP-TITLE.
049980     MOVE DD-TITLE2  TO BOTTOM-TITLE.
050000 DD-TITLE-LENGTH-LOOP.
050020     IF TOP-TITLE-CHAR (TTX) IS NOT EQUAL TO
050040         SPACE GO TO DD-TITLE-LENGTH-DONE.
050060     IF BOTTOM-TITLE-CHAR (BTX) IS NOT EQUAL TO
050080         SPACE GO TO DD-TITLE-LENGTH-DONE.
050100     SET TTX DOWN BY 1.  SET BTX DOWN BY 1.
050120     IF TTX IS NOT EQUAL TO 1 GO TO DD-TITLE-LENGTH-LOOP.
050140 DD-TITLE-LENGTH-DONE.
050160     SET DD-NTCHARS TO TTX.
050180 DD-TITLE-LENGTH-EXIT.
050200     EXIT.
050220
050240*****************************
050260* SUBROUTINE TO TRANSLATE OLD/NEW EDIT CODES.
050280*****************************
050300 MODIFYPICTED.
050320     IF CD-EDIT EQUAL TO 0 GO TO MOD4.
050340     IF CD-EDIT GREATER THAN 30 GO TO MODIFY-EXIT.
050360*    *EDIT CODE ABOVE 31 INDICATES USER PLANS TO
050380*          EDIT THIS ITEM VIA USER EXIT 9*.
050400     IF CD-PICT EQUAL TO SPACE GO TO MOD3.
050420*    *HAVE BOTH EDIT CODE AND PICTURE--COMPARE INPUT
050440*          PIC WITH STANDARD PIC AND IF DIFFERENT
050460*          MAKE IT A NON-STANDARD CODE 31*.
050480     MOVE CD-EDIT TO NUMEDXAN.
050500     IF IQ-PICTURE (NUMEDX) EQUAL TO CD-PICT
050520        MOVE CD-EDIT TO DD-EDIT GO TO MOD2.
050540 MOD1.
050560     MOVE 31 TO CD-EDIT.  MOVE 31 TO DD-EDIT.
050580 MOD2.
050600     MOVE CD-PICT TO DD-PICT.
050620     GO TO MODIFY-EXIT.
050640*    *HERE FOR EDIT CODE SPECIFIED WITH NO PICTURE
050660*           GIVEN--THIS MUST BE A STANDARD PICTURE*.
050680 MOD3.
050700     MOVE  CD-EDIT TO NUMEDXAN.
050720     MOVE IQ-PICTURE (NUMEDX) TO CD-PICT.
050740     MOVE CD-PICT TO DD-PICT.
050760     GO TO MODIFY-EXIT.
050780 MOD4.
050800     IF CD-PICT EQUAL TO SPACE
050820        MOVE 00 TO DD-EDIT GO TO MODIFY-EXIT.
050840     GO TO MOD1.
050860 MODIFY-EXIT.   EXIT.
050880
050900***************************************************
050920* SUBROUTINE TO CREATE OWN PIC FOR NUMERICS WITH
050940* NO SPECIFIED PICTURES.
050960***************************************************
050980 MAKE-OWN-PICT.
051000     MOVE SPACE TO PICT-REDEF.
051020     MOVE 'S' TO PICTCHAR (1).
051040     SET PIX TO CD-NCHARS. SET PIX UP BY 2.
051060     IF CD-SCALE = 0 GO TO MAKE-OWN-PICT-INTEGER.
051080     MOVE CD-SCALE TO J.
051084     IF PIX > 19 SET PIX TO 19.
051100 MAKE-OWN-PICT-FRACT.
051120     MOVE 9 TO PICTCHAR (PIX).
051140     SET PIX DOWN BY 1.
051160     SUBTRACT 1 FROM J.
051180     IF J = 0 MOVE '.' TO PICTCHAR (PIX)
051200         ELSE GO TO MAKE-OWN-PICT-FRACT.
051220 MAKE-OWN-PICT-INTEGER.
051222     IF PIX > 20 SET PIX TO 20.
051240     SET PIX DOWN BY 1.
051260     IF PIX = 1 GO TO MAKE-OWN-PICT-DONE.
051280     MOVE 9 TO PICTCHAR (PIX).
051300 MAKE-OWN-PICT-INTEGER-1.
051320     SET PIX DOWN BY 1.
051340     IF PIX = 1 GO TO MAKE-OWN-PICT-DONE.
051360     MOVE 'Z' TO PICTCHAR (PIX).
051380     GO TO MAKE-OWN-PICT-INTEGER-1.
051400 MAKE-OWN-PICT-DONE.
051420     MOVE PICT-REDEF TO CD-PICT DD-PICT.
051440     MOVE 31 TO DD-EDIT.
051460 MAKE-OWN-PICT-EXIT.
051480     EXIT.
051500
051520*********************************************
051540* SUB SUBROUTINE TO CHECK SPECIAL PICTURES VERSUS
051560* ITEM TYPE  SCALE  AND INSERTION CHARACTERS. IF DISCREPANCY
051580* IT SETS EDIT-ERROR-FLAG TO 1 AND GENERATES A NEW PICTURE.
051600***********************************************
051620 CHECK-PICT.
051640     MOVE 0 TO J.
051660     MOVE 0 TO EDIT-ERROR-FLAG.
051680     IF CD-PICT = SPACE GO TO CHECK-PICT-EXIT.
051700     MOVE CD-PICT TO PICT-REDEF.
051720     IF CD-TYPE-X = '1' OR 'A'
051740         GO TO CHECK-PICT-ALPHA.
051760 CHECK-PICT-NUM.
051780*   *CHECK INSERTION CHARS 9 Z $ FOR NUMERIC ITEM*.
051800     MOVE 0 TO K L.
051820     SET PIX TO 1.
051840 CHECK-PICT-DEC.
051860     IF PIX GREATER THAN 19 GO TO CHECK-PICT-DEC2.
051880     MOVE PICTCHAR (PIX) TO ELEM-CHAR.
051900     IF ELEM-CHAR = ' ' GO TO CHECK-PICT-DEC2.
051920     IF ELEM-CHAR = '9' OR 'Z' OR 'R' ADD 1 TO L.
051940     IF ELEM-CHAR = '$' ADD 1 TO L MOVE 1 TO J.
051960     IF ELEM-CHAR NOT = '.' SET PIX UP BY 1
051980         GO TO CHECK-PICT-DEC.
052000 CHECK-PICT-DEC1.
052020     IF ELEM-CHAR = '9' OR 'Z' OR 'R' OR '$'
052040         ADD 1 TO K  ADD 1 TO L.
052060     SET PIX UP BY 1.
052080     IF PIX GREATER THAN 19 GO TO CHECK-PICT-DEC2.
052100     MOVE PICTCHAR (PIX) TO ELEM-CHAR.
052120     IF ELEM-CHAR NOT = ' ' GO TO CHECK-PICT-DEC1.
052140 CHECK-PICT-DEC2.
052160     SUBTRACT J FROM L.
052180*   * ABOVE TAKES ACCOUNT OF LEADING $*.
052200     IF L NOT = CD-NCHARS GO TO CHECK-PICT-ERROR.
052220     IF K NOT = CD-SCALE GO TO CHECK-PICT-ERROR.
052240     GO TO CHECK-PICT-EXIT.
052260 CHECK-PICT-ALPHA.
052280     EXAMINE CD-PICT TALLYING ALL 'X'.
052300     IF TALLY NOT = CD-NCHARS GO TO CHECK-PICT-ERROR.
052320     GO TO CHECK-PICT-EXIT.
052340 CHECK-PICT-ERROR.
052360     MOVE 1 TO EDIT-ERROR-FLAG.
052380 CHECK-PICT-EXIT.
052400     EXIT.
052420
052440*************************
052460* CALCULATE GROUP LENGTH.
052480**************************
052500 GETGRPLEN.
052520     IF DD-NREPEATS = '00' OR '  '
052540         MOVE 0 TO DD-GRPLEN
052560         GO TO GETGRPLENX.
052580     IF N-SCANITEMS = 0 GO TO GETGRPLEN3.
052600     MOVE 1 TO I.
052620 GETGRPLEN1.
052640     IF I GREATER THAN N-SCANITEMS GO TO GETGRPLEN3.
052660     IF DD-GRPNME = GROUP-NAME-TAB (I)
052680        GO TO GETGRPLEN4.
052700**THIS ROUTINE EXPECTS THAT THE FIRST APPEARANCE OF A
052720*          FAMILY GROUP NAME IS ALSO THE FATHER OF ALL WITHIN
052740*          THAT SAME FAMILY AND AS SUCH THE FIRST APPEARANCE OF A
052760*          SPECIFIC FAMILY NAME DEFINES THE GRPLEN FOR THAT
052780*          FAMILY--
052800*          ALSO  THIS VERSION OF IQD WILL NOT PROPERLY
052820*          HANDLE UPDATES TO SCAN GROUP LTH-- ALL SCAN INFO
052840*          MUST BE REENTERED*.
052860     ADD 1 TO I.
052880     GO TO GETGRPLEN1.
052900 GETGRPLEN3.
052920     ADD 1 TO N-SCANITEMS. MOVE N-SCANITEMS TO I.
052940     MOVE DD-GRPNME TO GROUP-NAME-TAB (I).
052960     MOVE DD-NCHARS TO GROUP-LEN-TAB (I).
052980 GETGRPLEN4.
053000     MOVE GROUP-LEN-TAB (I) TO DD-GRPLEN.
053020     IF DD-GRPLEN IS LESS THAN DD-NCHARS
053040         PERFORM PRINT-DD-FIELDS
053060         MOVE DD-MSG-20 TO PRINT-LINE
053080         PERFORM PRINT1D.
053100 GETGRPLENX.
053120     EXIT.
053140
053160**************************************************************
053180* SUBROUTINE TO PASS A DICTIONARY TO SEE IF IT CAN
053200* BE UPDATED. IT CHECKS THE UPDATING PASSWORD IN THE FD TRAN
053220* VERSUS THE PD'S IN THE DICTIONARY. THE LEVEL OF THE HIGHEST
053240* PD IS LEFT IN PROTECTED-LEVEL AND THE LEVEL OF THE UPDATING 
053260* PASSWORD IS LEFT IN UNLOCKED-LEVEL.
053280* THIS SUBROUTINE DEPENDS ON THE DICTIONARY'S BEING
053300* POSITIONED AT THE FD AND ON THE FD'S BEING IN 
053320* DICT-FD AND THE TRANSACTION'S BEING IN TRAN-FD.
053340*****************************************************************
053360
053380 DICT-UNLOCKER.
053400     MOVE 0 TO DICT-LOCK UNLOCKED-LEVEL PROTECTED-LEVEL.
053420     IF CF-PASSWORD = UNIVERSAL-PASSWORD
053440         MOVE 99 TO UNLOCKED-LEVEL
053460         GO TO DICT-UNLOCKER-EXIT.
053470
053480 DICT-UNLOCKER-LOOP.
053500     READ QPDICT INTO DICT-WS AT END 
053520         GO TO DICT-UNLOCKER-DONE.
053540     IF DF-IDNT = 'FD' GO TO DICT-UNLOCKER-DONE.
053560     IF DF-IDNT NOT = 'PD' GO TO DICT-UNLOCKER-LOOP.
053580     IF DP-PROT-NO > PROTECTED-LEVEL
053600         MOVE DP-PROT-NO TO PROTECTED-LEVEL.
053620     MOVE DP-TEXT TO PW-TEXT-HOLDER.
053640     PERFORM UNSCRAMBLE-PW THRU UNSCRAMBLE-PW-EXIT.
053660     IF CF-PASSWORD = DP-TEXT
053680         MOVE DP-PROT-NO TO UNLOCKED-LEVEL.
053700     GO TO DICT-UNLOCKER-LOOP.
053720
053740 DICT-UNLOCKER-DONE.
053760     IF PROTECTED-LEVEL > UNLOCKED-LEVEL
053780         MOVE 1 TO DICT-LOCK.
053800
053820 DICT-UNLOCKER-EXIT.
053840     EXIT.
053860