000100 IDENTIFICATION DIVISION. 
000200 PROGRAM-ID.    PO010 IS INITIAL.
000300 AUTHOR.        MJD.
000400 ENVIRONMENT DIVISION.
000500 CONFIGURATION SECTION. 
           COPY "EXCEL.CS".
000600 SOURCE-COMPUTER. IBM-PC-XT.
000700 OBJECT-COMPUTER. IBM-PC-XT.
000800*REMARKS. 
000900***************************************************************** 
001000* 
001100* PO010 - Purchase Orders Edit List 
001200* VERSION 4.00
060889* UPDATE 06/02/89  SLR  - Added pause option & printer redirect * 
010191* UPD KWS - ADDED DECIMAL BILLING OPTIONS                       *
081092* FIX KWS - NOT RECOGNIZING SPC-ITEM IN APPAREL MODE            *
052093* FIX BOB - IF APPAREL MODE, PRINT X8 OF ITEM#                  *
062393* UPD BOB - ADD SINGLE/DOUBLE SPACING OPTION                    *
110393* UPD KWS - ADDED SERIAL NUBMERS TO LISTING                     *
081694* UPD KWS - ADJUSTED LAST-OPTION TO USE NEW 2.2 MENU            *
012696* UPD KWS V2.4 - RETURN TO MENU AFTER PRINT, NOT PO000          *
012696* UPD KWS V2.4 - ONE DECIMAL, COMMAS NOT CORRECT IN QTY NUMBERS *
022796* UPD BOB V2.4 - APPAREL INFO                                   *
090996* FIX KWS V2.5B- REDUCE PAGE SIZE FOR PRINTING ON LASER PRINTER *
070397* FIX KWS V2.6D- INVOICE TYPE S/B PAYMENT TYPE                  *
041498* UPD BOB V2.7A- ADD BATCH-NO LOGIC                  (INDMETAL) *
111198* UPD BOB V2.7A- MINOR, CLEAN SCREEN IN PRINT BATCH LOGIC       *
112098* MOD KWS V2.7B- INDMETALS - ALLOW REPRINT OF BATCH             *
112398* FIX MOD V2.7B- INDMETALS - WAS NOT ASKING BATCH ON SELECTIVE  *
031199* UPD KWS V2.8 - Y2K DATE CHANGES                                *
082699* MOD KWS V2.8B- ATHENS- ADDED INDMODS FOR ATHENS (438)          *
110899* FIX KWS V2.8B- INDMETALS- IF INV DO NOT INCLUDE FRT LINES      *
012600* MOD BOB V2.8C- INDMETALS- SPACE OUT POHD-REQ-NO (IS REDEFINED) *
012600* FIX KWS V2.8C- INDMETALS- FIX TYPO                             *
030901* UPD KWS V2.9 - DO NOT ALLOW BATCH ZERO, USE NEW PO111 BATCHES  *
032101* MOD KWS V2.9 - INDMETALS - DEFAULT TO WORK ON BATCHES          *
120101* UPD KWS V2.9A- ADDED LOGIC FOR CREIDT MEMO PO                  *
090606* MOD KWS V4.1 - MEI - USE FOR RECEIVING REPORT                  *
010807* UDP KWS V4.2 - USER-BATCH IS NOW 2 DIGITS                      *
010909* FIX KWS V4.4.1 - ADD CLOSE-LO                                  *
032709* FIX SKI V4.4.2 SEEMS FORM-STOCK-FLAG NOT USED                  *
071409* UPD SKI V4.5  - MOVE APPAREL TO LONGOPTION                     *
092809* UPD SKI V4.5  - NEW APPAREL FIELDS DISPLAY ORDER               *
032911* FIX KWS V4.5.3 - PREVENT ERROR FROM PAGE OVERFLOW              *
001400****************************************************************** 
001500 INPUT-OUTPUT SECTION.
001600 FILE-CONTROL.
001700
001800     COPY "POHDF.SL". 
001900     COPY "POLNF.SL". 
060889     COPY "LPFPRNTR.SL".
002900     COPY "CNTLF.SL". 
003000     COPY "EXCNF.SL". 
003100     COPY "USERF.SL". 
110393     COPY "SRECF.SL".
071409*    COPY "MUCTF.SL".
071409     COPY "SCATF.SL".
022796     COPY "STYLF.SL".
022796     COPY "COLRF.SL".
030901     COPY "INVBF.SL".
           COPY "STEST.SL".
003200
003300 DATA DIVISION. 
       BASED-STORAGE SECTION.
            COPY "STEST.BS".
003400 FILE SECTION.
003500
003600*    PRNTR.FD   PRINT FILE DESCRIPTION. 
003700
070907     COPY "LPFPRNTR.FD".
070907*FD  LO 
070907*    LABEL RECORDS ARE OMITTED. 
004000
070907*01  PRINT-REC           PIC X(132).
004200
004300     COPY "POHDF.FD". 
004400     COPY "POLNF.FD". 
004500     COPY "CNTLF.FD". 
004600     COPY "EXCNF.FD". 
004700     COPY "USERF.FD". 
110393     COPY "SRECF.FD".
071409*    COPY "MUCTF.FD".
071409     COPY "SCATF.FD".
022796     COPY "STYLF.FD".
022796     COPY "COLRF.FD".
030901     COPY "INVBF.FD".
           COPY "STEST.FD".
004800
004900 WORKING-STORAGE SECTION. 
CVT    01  PROG-NAME    PIC X(6) VALUE    "PO010".                      
005000
005100 01  BATCH-LIST-FLAG PIC X  VALUE "N".
005200     88  BATCH-LIST  VALUE "Y". 
041498     88  OPEN-LIST   VALUE "O". 
005300 01  POHDF-NAME          PIC X(5) VALUE "POHDF".
005400 01  POLNF-NAME          PIC X(5) VALUE "POLNF".
005500 01  EXT-HDR-FILE        PIC X(14). 
005600 01  EXT-LIN-FILE        PIC X(14). 
030901 01  INVBF-STATUS        PIC XX VALUE SPACES.
CLNUP1     88 C-RECORD-OK VALUES "00", "02".
CLNUP1     88 C-FOUND VALUES "00", "02".
CLNUP1     88 C-AT-END VALUES "10", "14".
CLNUP1     88 C-END-OF-FILE VALUES "10", "14".
005700 01  POHDF-STATUS        PIC XX.
CLNUP1     88 C-RECORD-OK VALUES "00", "02".
CLNUP1     88 C-FOUND VALUES "00", "02".
CLNUP1     88 C-AT-END VALUES "10", "14".
CLNUP1     88 C-END-OF-FILE VALUES "10", "14".
005800 01  POLNF-STATUS        PIC XX.
CLNUP1     88 C-RECORD-OK VALUES "00", "02".
CLNUP1     88 C-FOUND VALUES "00", "02".
CLNUP1     88 C-AT-END VALUES "10", "14".
CLNUP1     88 C-END-OF-FILE VALUES "10", "14".
110393 01  SRECF-STATUS        PIC XX.
CLNUP1     88 C-RECORD-OK VALUES "00", "02".
CLNUP1     88 C-FOUND VALUES "00", "02".
CLNUP1     88 C-AT-END VALUES "10", "14".
CLNUP1     88 C-END-OF-FILE VALUES "10", "14".
071409*01  MUCTF-STATUS        PIC XX.
022796 01  STYLF-STATUS        PIC XX.
CLNUP1     88 C-RECORD-OK VALUES "00", "02".
CLNUP1     88 C-FOUND VALUES "00", "02".
CLNUP1     88 C-AT-END VALUES "10", "14".
CLNUP1     88 C-END-OF-FILE VALUES "10", "14".
022796 01  COLRF-STATUS        PIC XX.
CLNUP1     88 C-RECORD-OK VALUES "00", "02".
CLNUP1     88 C-FOUND VALUES "00", "02".
CLNUP1     88 C-AT-END VALUES "10", "14".
CLNUP1     88 C-END-OF-FILE VALUES "10", "14".
071409*01  MUCTF-KEY            PIC 9(5)  VALUE 1.
071409*01  MUCT-FILENAME.
071409*    05  MUCT-DRIVE      PIC X VALUE SPACES.
071409*    05  FILLER          PIC X(10) VALUE ":\PROFITS\".
071409*    05  MUCT-DIRECTORY  PIC X(08) VALUE SPACES.
071409*    05  FILLER          PIC X(11) VALUE "\MUCNTL.FIL".
071409*01  MUCTF--NAME REDEFINES MUCT-FILENAME PIC X(30) .
071409*01  MUCTF-FULLPATH REDEFINES MUCT-FILENAME PIC X(30) .
071409     COPY "SCATF.DTA".
072889 01  STYLE-FILENAME.
082589     05  STYL-DRIVE      PIC X VALUE SPACES.
TP2PF      05  FILLER          PIC X(10) VALUE ":\PROFITS\".
082589     05  STYL-DIRECTORY  PIC X(08) VALUE SPACES.
022796     05  FILLER          PIC X(13) VALUE "\STYLEHDR.FIL".
CLNUP1 01  STYLF--NAME REDEFINES STYLE-FILENAME PIC X(32) .
CLNUP1 01  STYLF-FULLPATH REDEFINES STYLE-FILENAME PIC X(32) .
005900 01  LINE-NO             PIC 9(2) VALUE 99. 
006000 01  PAGE-NO             PIC 9(4).
090996 01  PAGE-SIZE           PIC 99     VALUE 58. 
006200 01  SKIP                PIC 99 VALUE 1.
006300 01  LO-STATUS           PIC XX.
006400 01  CNTLF-STATUS        PIC XX.
006500 01  EXCNF-STATUS        PIC XX.
006600 01  USERF-STATUS        PIC XX.
006700 01  INDEX-OCCURS        PIC 9(1).
006800 01  INDEX-PERFORM       PIC 9(1) VALUE 1.
006900 01  ESC-FLAG            PIC 9    VALUE ZERO. 
007000 01  LOW-KEY             PIC X(6) VALUE LOW-VALUES. 
007100 01  HIGH-KEY            PIC X(6) VALUE HIGH-VALUES.
000191 77  NUMBER-DECIMALS  PIC 9 VALUE 0.
007200
007300 01  DISPLAY-MESSAGES.
007400     05 PRINTING-REPORT  PIC X(18) VALUE "Printing Report.".
007500
007600     COPY "CONSTANT.DTA". 
007700     COPY "SCREEN.DTA". 
007800     COPY "STATUS.DTA". 
007900     COPY "ERROR.DTA".
008000     COPY "ERRORP.DTA". 
008100     COPY "DATE.DTA". 
008200     COPY "APTYPE.OPT". 
008300     COPY "POTYPE.OPT". 
008400*    COPY "RANGE.DTA".
060889     COPY "PFPRINT.DTA".
070907     COPY "PAUSE.DTA".
008500 01  RANGE-DATA.
008600     05  RANGE-MSG      PIC X(21) VALUE "Do you want to print?".
008700     05  RANGE-CODES. 
008800         10  FILLER     PIC X(17) VALUE "All Orders". 
008900         10  FILLER     PIC X(17) VALUE "A range of Orders".
009000         10  FILLER     PIC X(17) VALUE "Selective Orders". 
009100         10  FILLER     PIC X(17) VALUE "Totals Only".
009200         10  FILLER     PIC X(17) VALUE "'Open' Orders".
009300         10  FILLER     PIC X(17) VALUE "Non 'Open' Orders".
112098         10  FILLER     PIC X(17) VALUE "RE-PRINT A BATCH ".
030901         10  FILLER     PIC X(17) VALUE "Work on Batches  ".
009400     05  RANGE-SPECS-1. 
009500         10  FILLER     PIC X(5)  VALUE "1143O".
009600         10  NUM-OPTIONS PIC 99   VALUE 4.
009700         10  FILLER     PIC 99    VALUE 17. 
009800         10  OPTION     PIC 9     VALUE 1.
009900         10  FILLER     PIC X(4)  VALUE "E   ". 
010000     05  RANGE-HELP-1   PIC X(54) VALUE " Select to print the orde
010100-    "rs you want, or only totals.$". 
010200     05  RANGE-LOW-MSG  PIC X(16) VALUE "First to print -". 
010300     05  RANGE-HIGH-MSG PIC X(16) VALUE "Last  to print -". 
010400     05  RANGE-SPECS-2. 
010500         10  FILLER     PIC X(14) VALUE "1343D06060    ". 
010600         10  FILLER     PIC X(14) VALUE "1443D06060    ". 
010700     05  RANGE-HELP-2   PIC X(116) VALUE " Enter the number of the
010800-    " first one to print.   To print a single one, make the   fir
010900-    "st and the last one the same.$ $".
011000     05  SELECT-QUES    PIC X(25) 
011100         VALUE "Purchase Order to print: ". 
011200     05  RANGE-SPECS-3. 
011300         10  FILLER     PIC X(14) VALUE "1352D06060E   ". 
011400     05  RANGE-HELP-3   PIC X(111) VALUE " Enter the number of the
011500-    " order to print.  Continue to enter order numbers until all 
011600-    "orders have been selected.$". 
011700     05  RANGE-ERR-1    PIC X(47) VALUE 
011800         " That is an invalid range, please try another. ". 
011900     05  RANGE-ERR-2    PIC X(51) VALUE 
012000         " There are none in this range, please try another. ". 
012100     05  RANGE-ERR-3    PIC X(48) VALUE 
012200         " This order does not exist, please try another. ".
030901 01  WS-PASSED-DATA.
030901     05 WS-BATCH-NO     PIC 99 VALUE ZERO.
030901     05 FILLER          PIC X(10) VALUE SPACES.
012300 01  RPT-TYPE-FLAG          PIC X VALUE "D".
012400     88  DET-RPT            VALUE "D".
012500 01  RES-SELECTIVE-FLAG         PIC 9 VALUE 0.
112098     88  ALL-ORDERS         VALUE 1.
112098     88  RES-RANGE              VALUE 2.
112398     88  SELECTIVE-ONLY     VALUE 3.
012600     88  RES-SELECTIVE          VALUES 5, 6.
012700     88  OPEN-ONLY          VALUE 5.
012800     88  NONOPEN-ONLY       VALUE 6.
112098     88  REPRINT-ONLY       VALUE 7.
030901     88  WORK-ON-BATCHES     VALUE 8.
012900
013000 01  ORDER-NUMBER           PIC 9(6) VALUE 0. 
013100
013200 01  SYSTEM-TIME. 
013300     03 SYSTEM-HOUR          PIC 99.
013400     03 SYSTEM-MINUTE        PIC 99.
013500     03 SYSTEM-SECONDS       PIC 99.
013600     03 FILLER               PIC 99.
013700
013800 01  PR-HEADER1.
070907*    03 PR-CNDSE         PIC X(9).
014000     03 FILLER           PIC X(7)   VALUE "DATE - ".
031199     03 PR-DATE-11       PIC X(11).
014200     03 FILLER           PIC X(10)  VALUE "   TIME - ". 
014300     03 PR-HOUR          PIC 99.
014400     03 FILLER           PIC X      VALUE ":".
014500     03 PR-MINUTE        PIC 99.
014600     03 FILLER           PIC X      VALUE ":".
014700     03 PR-SECONDS       PIC 99.
014800     03 FILLER           PIC X(10)  VALUE SPACES. 
014900     03 PR-CONAME        PIC X(40)  VALUE SPACES. 
031199     03 FILLER           PIC X(27)  VALUE SPACES. 
015100     03 FILLER           PIC X(5)   VALUE "PAGE ".
015200     03 PR-PAGE-NO       PIC ZZZ9.
015300 01  PR-HEADER1A. 
015400     03 FILLER           PIC X(41) VALUE SPACES.
015500     03 PR-TITLE         PIC X(50). 
015600     03 FILLER           PIC X(41) VALUE SPACES.
015700
016000 01  REPORT-TITLE PIC X(50) 
016100     VALUE "            PURCHASE ORDERS EDIT LIST". 
016200 01  OPEN-TITLE-1 PIC X(50) 
016300     VALUE "             PURCHASE ORDERS LISTING".
090606 01  OPEN-TITLE-2 PIC X(50) 
090606     VALUE "               PO RECEIVING LISTING".
016400
016500 01  PR-HEADER2.
016600     03 FILLER            PIC X(11) VALUE "P/O NO.   V".
016700     03 FILLER            PIC X(11) VALUE "ENDOR    AD".
016800     03 FILLER            PIC X(11) VALUE "DRESS      ".
016900     03 FILLER            PIC X(11) VALUE "           ".
017000     03 FILLER            PIC X(11) VALUE "          S".
017100     03 FILLER            PIC X(11) VALUE "HIP TO     ".
017200     03 FILLER            PIC X(11) VALUE "           ".
017300     03 FILLER            PIC X(10) VALUE "          ". 
041498 01  PR-HEADER2A.
041498     03 FILLER            PIC X(11) VALUE "           ".
041498     03 FILLER            PIC X(11) VALUE "           ".
041498     03 FILLER            PIC X(11) VALUE "           ".
041498     03 FILLER            PIC X(11) VALUE "           ".
041498     03 FILLER            PIC X(11) VALUE "           ".
041498     03 FILLER            PIC X(11) VALUE "           ".
041498     03 FILLER            PIC X(11) VALUE "           ".
041498     03 FILLER            PIC X(10) VALUE "          ".
041498     03 PR-BATCH-NO-MSG   PIC X(10) VALUE "BATCH NO. ".
041498     03 PR-BATCH-NO       PIC 9 VALUE 0. 
041498     03 FILLER            PIC X(11) VALUE "           ".
017400 01  PR-HEADER3.
017500     03 FILLER            PIC X(11) VALUE "ITEM NUMBER".
017600     03 FILLER            PIC X(11) VALUE "  DESCRIPTI".
017700     03 FILLER            PIC X(11) VALUE "ON         ".
010191     03 FILLER            PIC X(09) VALUE "         ".
010191     03 FILLER            PIC X(11) VALUE "   ORDER ". 
010191     03 PRMT-REC          PIC X(11)  VALUE " CUR RCPT ".
010191     03 PRMT-INV          PIC X(11)  VALUE " CUR INV".
018200     03 FILLER            PIC X(7)  VALUE " UNIT P".
018300     03 FILLER            PIC X(11) VALUE "RICE   EXTE".
018400     03 FILLER            PIC X(11) VALUE "NSION  VEND".
018500     03 FILLER            PIC X(11) VALUE "OR'S ITEM #".
018600     03 FILLER            PIC X(11) VALUE "  EXT QTY  ".
010191     03 FILLER            PIC X(08) VALUE "  CONV  ".
018800
090606 01  PR-HEADER3-MEI.
017500     03 FILLER            PIC X(11) VALUE "ITEM NUMBER".
017600     03 FILLER            PIC X(11) VALUE "  DESCRIPTI".
017700     03 FILLER            PIC X(11) VALUE "ON         ".
010191     03 FILLER            PIC X(09) VALUE "         ".
010191     03 FILLER            PIC X(11) VALUE "   ORDER ". 
010191     03 FILLER            PIC X(11)  VALUE " CUR RCPT ".
010191     03 FILLER            PIC X(11)  VALUE "BIN     ".
018200     03 FILLER            PIC X(7)  VALUE "       ".
018300     03 FILLER            PIC X(11) VALUE "           ".
018400     03 FILLER            PIC X(11) VALUE "       VEND".
018500     03 FILLER            PIC X(11) VALUE "OR'S ITEM #".
018600     03 FILLER            PIC X(11) VALUE "  EXT QTY  ".
010191     03 FILLER            PIC X(08) VALUE "  CONV  ".
018800
022796 01  PR-DETAILA.
032395     03 PART1-A.
092809*       05 PR-CATEGORY     PIC X(6)  VALUE SPACES.
092809*       05 FILLER          PIC X     VALUE SPACES.
              05 PR-COLOR        PIC X(2)  VALUE SPACES.
              05 PR-HYPHEN       PIC X     VALUE SPACES.
071409*       05 PR-COLR-NAME    PIC X(13) VALUE SPACES.
071409        05 PR-COLR-NAME    PIC X(12) VALUE SPACES.
              05 FILLER          PIC X     VALUE SPACES.
071409*       05 PR-SIZE         PIC X(4)  VALUE SPACES.
071409        05 PR-SIZE         PIC X(5)  VALUE SPACES.
092809        05 FILLER          PIC X     VALUE SPACES.
092809        05 PR-CATEGORY     PIC X(6)  VALUE SPACES.

018900 01  PR-DETAIL1.
019000     03 PR-POHD-PO-NO     PIC 9(6). 
019100     03 FILLER            PIC X(4)            VALUE SPACES. 
019200     03 PR-POHD-VEND-NO   PIC X(8). 
019300     03 FILLER            PIC XX              VALUE SPACES. 
019400     03 PR-POHD-VEND-NAME PIC X(30).
019500     03 FILLER            PIC X(4)            VALUE SPACES. 
019600     03 PR-POHD-CO-NAME   PIC X(30).
019700     03 FILLER            PIC X(19) VALUE "   ORDER DATE".
031199     03 PR-PO-DATE-11     PIC X(11).
031199     03 FILLER            PIC X(15) VALUE "  DISC DAYS".
020000     03 PR-POHD-DISC-DAYS PIC ZZ9.
020100 01  PR-DETAIL2.
101201*    03 FILLER            PIC X(20)           VALUE SPACES. 
101201     03 PR-CREDIT-MEMO    PIC X(11)           VALUE SPACES. 
101201     03 FILLER            PIC X(09)           VALUE SPACES. 
020300     03 PR-POHD-VEND-ADDR1 PIC X(30).
020400     03 FILLER            PIC X(4)            VALUE SPACES. 
020500     03 PR-POHD-CO-ADDR1  PIC X(30).
020600     03 FILLER            PIC X(19) VALUE "   DELIVERY DATE". 
031199     03 PR-POHD-DELIV-DATE-11 PIC X(11).
031199     03 FILLER            PIC X(12) VALUE "  DISC PCT". 
020900     03 PR-POHD-DISC-PCT  PIC ZZ.999. 
021000 01  PR-DETAIL3.
021100     03 FILLER            PIC X(20)           VALUE SPACES. 
021200     03 PR-POHD-VEND-ADDR2 PIC X(30).
021300     03 FILLER            PIC X(4)            VALUE SPACES. 
021400     03 PR-POHD-CO-ADDR2  PIC X(30).
031199     03 FILLER            PIC X(19) VALUE "   REQUISITION". 
021600     03 PR-POHD-REQ-NO    PIC X(10).
031199     03 FILLER            PIC X(17) VALUE "   DUE DAYS". 
021800     03 PR-POHD-DUE-DAYS  PIC ZZ9.
021900 01  PR-DETAIL4.
022000     03 FILLER            PIC X(20)           VALUE SPACES. 
022100     03 PR-POHD-VEND-CITY PIC X(18).
022200     03 FILLER            PIC X               VALUE SPACES. 
022300     03 PR-POHD-VEND-STATE PIC XX. 
022400     03 FILLER            PIC X               VALUE SPACES. 
022500     03 PR-POHD-VEND-ZIP  PIC X(10).
022600     03 FILLER            PIC XX              VALUE SPACES. 
022700     03 PR-POHD-CO-CITY   PIC X(18).
022800     03 FILLER            PIC X               VALUE SPACES. 
022900     03 PR-POHD-CO-STATE  PIC XX. 
023000     03 FILLER            PIC X               VALUE SPACES. 
023100     03 PR-POHD-CO-ZIP    PIC X(10).
023200     03 FILLER       PIC X(23) VALUE " RETAIN BACKORDERS".
023300     03 PR-BO-CD          PIC X(3). 
023400     03 FILLER            PIC X(8)  VALUE "  FOB".
023500     03 PR-POHD-FOB-PT    PIC X(12).
023600 01  PR-DETAIL5.
023700     03 FILLER   PIC X(22)  VALUE "INVOICE STATUS". 
023800     03 FILLER   PIC X(26)  VALUE "CONTACT".
023900     03 FILLER   PIC X(31)  VALUE "SHIPPING INSTRUCTIONS".
024000     03 FILLER   PIC X(26)  VALUE "BUYER".
024100     03 FILLER   PIC X(5)   VALUE "TERMS".
024200 01  PR-DETAIL6.
024300     03 PR-POHD-STATUS-CD                     PIC X(22).
024400     03 PR-POHD-VEND-CONTACT                  PIC X(26).
024500     03 PR-POHD-SHIP-INST                     PIC X(31).
024600     03 PR-POHD-BUYER                         PIC X(26).
024700     03 PR-POHD-TERMS-DESC                    PIC X(22).
024800 01  PR-DETAIL5A. 
024900     03 FILLER   PIC X(6)   VALUE SPACES. 
025000     03 FILLER   PIC X(16)  VALUE "INVOICE NUMBER". 
025100     03 FILLER   PIC X(22)  VALUE "INVOICE DESCRIPTION".
025200     03 FILLER   PIC X(15)  VALUE "INVOICE DATE". 
025300     03 FILLER   PIC X(11)  VALUE "DUE DATE". 
025400     03 FILLER   PIC X(17)  VALUE "HALT STATUS".
070397*    03 FILLER   PIC X(17)  VALUE "INVOICE TYPE". 
070397     03 FILLER   PIC X(17)  VALUE "PAYMENT TYPE". 
025600     03 FILLER   PIC X(12)  VALUE "CHECK NUMBER". 
025700 01  PR-DETAIL6A. 
025800     03 FILLER   PIC X(8)   VALUE SPACES. 
025900     03 PR-POHD-INV-NO                        PIC X(10).
026000     03 FILLER   PIC X(4)   VALUE SPACES. 
026100     03 PR-POHD-INV-DESC                      PIC X(20).
026200     03 FILLER   PIC X(3)   VALUE SPACES. 
031199     03 PR-POHD-INV-DATE-11                   PIC X(11).
031199     03 FILLER   PIC X(2)   VALUE SPACES. 
031199     03 PR-POHD-DUE-DATE-11                   PIC X(11).
026600     03 FILLER   PIC X(3)   VALUE SPACES. 
026700     03 PR-POHD-HALT-CD                       PIC X(15).
026800     03 FILLER   PIC X(2)   VALUE SPACES. 
026900     03 PR-POHD-TYPE-CD                       PIC X(15).
027000     03 FILLER   PIC X(2)   VALUE SPACES. 
027100     03 PR-POHD-CHK-NO                        PIC 9(6). 
027200 01  PR-DETAIL7.
027300     03 PR-POLN-ITEM-NO                       PIC X(12).
052093     03 PR-ITEM-RED REDEFINES PR-POLN-ITEM-NO.
052093        05 PR-ITEM-STYLE     PIC X(8).
052093        05 PR-APPAREL-PART   PIC X(4).
027400     03 FILLER            PIC X               VALUE SPACES. 
027500     03 PR-POLN-ITEM-DESC                     PIC X(28).
010191*    03 FILLER            PIC X               VALUE SPACES. 
010191*    03 PR-POLN-VEND-UOM                      PIC XXX.
010191*    03 FILLER            PIC X               VALUE SPACES. 
010191     03 PR-POLN-ORDER-QTY                 PIC ZZ,ZZZ,ZZ9-. 
010191     03 PR-POLN-ORDER-QTY-1 REDEFINES PR-POLN-ORDER-QTY
012696           PIC ZZZZ,ZZZ.9-. 
010191     03 PR-POLN-ORDER-QTY-2 REDEFINES PR-POLN-ORDER-QTY
                 PIC ZZZ,ZZZ.99-. 
010191     03 PR-POLN-ORDER-QTY-3 REDEFINES PR-POLN-ORDER-QTY
                 PIC ZZ,ZZZ.999-. 
010191     03 PR-POLN-ORDER-QTY-4 REDEFINES PR-POLN-ORDER-QTY
                 PIC ZZZZZ.9999-. 
010191     03 PR-POLN-ORDER-QTY-5 REDEFINES PR-POLN-ORDER-QTY
                 PIC ZZZZ.99999-. 
010191     03 PR-POLN-REC-QTY                   PIC ZZ,ZZZ,ZZ9-. 
010191     03 PR-POLN-REC-QTY-1 REDEFINES PR-POLN-REC-QTY
012696           PIC ZZZZ,ZZZ.9-. 
010191     03 PR-POLN-REC-QTY-2 REDEFINES PR-POLN-REC-QTY
                 PIC ZZZ,ZZZ.99-. 
010191     03 PR-POLN-REC-QTY-3 REDEFINES PR-POLN-REC-QTY
                 PIC ZZ,ZZZ.999-. 
010191     03 PR-POLN-REC-QTY-4 REDEFINES PR-POLN-REC-QTY
                 PIC ZZZZZ.9999-. 
010191     03 PR-POLN-REC-QTY-5 REDEFINES PR-POLN-REC-QTY
                 PIC ZZZZ.99999-. 
090606     03 PR-REC-UNDERLINE REDEFINES PR-POLN-REC-QTY
                 PIC X(11).
010191     03 PR-POLN-INV-QTY                   PIC ZZ,ZZZ,ZZ9-
090606                                          BLANK ZERO.
010191     03 PR-POLN-INV-QTY-1 REDEFINES PR-POLN-INV-QTY
012696           PIC ZZZZ,ZZZ.9-. 
010191     03 PR-POLN-INV-QTY-2 REDEFINES PR-POLN-INV-QTY
                 PIC ZZZ,ZZZ.99-. 
010191     03 PR-POLN-INV-QTY-3 REDEFINES PR-POLN-INV-QTY
                 PIC ZZ,ZZZ.999-. 
010191     03 PR-POLN-INV-QTY-4 REDEFINES PR-POLN-INV-QTY
                 PIC ZZZZZ.9999-. 
010191     03 PR-POLN-INV-QTY-5 REDEFINES PR-POLN-INV-QTY
                 PIC ZZZZ.99999-. 
090606     03 PR-BIN-LOC REDEFINES PR-POLN-INV-QTY
090606           PIC X(11).
010191     03 PR-POLN-ITEM-PRICE      PIC ZZ,ZZZ.999- BLANK ZERO. 
028300     03 PR-POLN-EXT-AMT         PIC ZZZZ,ZZZ.99- BLANK ZERO. 
028400     03 FILLER            PIC X               VALUE SPACES. 
028500     03 PR-POLN-VITEM-NO                      PIC X(14).
010191     03 FILLER            PIC X               VALUE SPACES. 
010191     03 PR-EXT-QTY                         PIC ZZ,ZZZ,ZZ9-.
010191     03 PR-EXT-QTY-1 REDEFINES PR-EXT-QTY
012696           PIC ZZZZ,ZZZ.9-. 
010191     03 PR-EXT-QTY-2 REDEFINES PR-EXT-QTY
                 PIC ZZZ,ZZZ.99-. 
010191     03 PR-EXT-QTY-3 REDEFINES PR-EXT-QTY
                 PIC ZZ,ZZZ.999-. 
010191     03 PR-EXT-QTY-4 REDEFINES PR-EXT-QTY
                 PIC ZZZZZ.9999-. 
010191     03 PR-EXT-QTY-5 REDEFINES PR-EXT-QTY
                 PIC ZZZZ.99999-. 
028800     03 FILLER            PIC X               VALUE SPACES. 
010191*    03 PR-POLN-ITEM-UOM                      PIC X(3). 
010191*    03 FILLER            PIC X               VALUE SPACES. 
029100     03 PR-POLN-CONV-FACTOR                   PIC ZZZ9. 

110393 01  PR-DETAIL8.
110393     03 FILLER               PIC X(09) VALUE SPACES.
110393     03 FILLER               PIC X(10) VALUE "      S/N ".
110393     03 PR-SERIAL-NO-A       PIC X(20) VALUE SPACES.
110393     03 FILLER               PIC X(10) VALUE "      S/N ".
110393     03 PR-SERIAL-NO-B       PIC X(20) VALUE SPACES.
110393
029300 01  PR-TOTALS. 
010191     03 FILLER            PIC X(31)           VALUE SPACES. 
029500     03 FILLER            PIC X(10)           VALUE "TOTALS". 
010191     03 TS-ORDER-QTY      PIC ZZ,ZZZ,ZZ9-. 
010191     03 TS-ORDER-QTY-1 REDEFINES TS-ORDER-QTY
012696           PIC ZZZZ,ZZZ.9-. 
010191     03 TS-ORDER-QTY-2 REDEFINES TS-ORDER-QTY
                 PIC ZZZ,ZZZ.99-. 
010191     03 TS-ORDER-QTY-3 REDEFINES TS-ORDER-QTY
                 PIC ZZ,ZZZ.999-. 
010191     03 TS-ORDER-QTY-4 REDEFINES TS-ORDER-QTY
                 PIC ZZZZZ.9999-. 
010191     03 TS-ORDER-QTY-5 REDEFINES TS-ORDER-QTY
                 PIC ZZZZ.99999-. 
010191     03 TS-REC-QTY        PIC ZZ,ZZZ,ZZ9- BLANK ZERO.
010191     03 TS-REC-QTY-1 REDEFINES TS-REC-QTY
012696           PIC ZZZZ,ZZZ.9-. 
010191     03 TS-REC-QTY-2 REDEFINES TS-REC-QTY
                 PIC ZZZ,ZZZ.99-. 
010191     03 TS-REC-QTY-3 REDEFINES TS-REC-QTY
                 PIC ZZ,ZZZ.999-. 
010191     03 TS-REC-QTY-4 REDEFINES TS-REC-QTY
                 PIC ZZZZZ.9999-. 
010191     03 TS-REC-QTY-5 REDEFINES TS-REC-QTY
                 PIC ZZZZ.99999-. 
010191     03 TS-INV-QTY        PIC ZZ,ZZZ,ZZ9- BLANK ZERO.
010191     03 TS-INV-QTY-1 REDEFINES TS-INV-QTY
012696           PIC ZZZZ,ZZZ.9-. 
010191     03 TS-INV-QTY-2 REDEFINES TS-INV-QTY
                 PIC ZZZ,ZZZ.99-. 
010191     03 TS-INV-QTY-3 REDEFINES TS-INV-QTY
                 PIC ZZ,ZZZ.999-. 
010191     03 TS-INV-QTY-4 REDEFINES TS-INV-QTY
                 PIC ZZZZZ.9999-. 
010191     03 TS-INV-QTY-5 REDEFINES TS-INV-QTY
                 PIC ZZZZ.99999-. 
010191     03 FILLER            PIC X(10) VALUE SPACES. 
030000     03 TS-EXT-AMT        PIC Z,ZZZ,ZZZ.99- BLANK ZERO.
030100
030200
030300 01  TOTALS VALUE ZERO. 
010191     05  TOT-ORDER-QTY        PIC S9(7)V9(5).
010191     05  TOT-REC-QTY          PIC S9(7)V9(5).
010191     05  TOT-INV-QTY          PIC S9(7)V9(5).
030700     05  TOT-EXT-AMT          PIC S9(7)V99. 
030800
030900 01  FINAL-TOTALS VALUE ZERO. 
031000     05  FT-ORDERS           PIC S9(7). 
101201     05  FT-CREDITS          PIC S9(7). 
031100     05  FT-ITEMS            PIC S9(7). 
010191     05  FT-ORDER-QTY        PIC S9(7)V9(5). 
010191     05  FT-REC-QTY          PIC S9(7)V9(5). 
010191     05  FT-INV-QTY          PIC S9(7)V9(5). 
031500     05  FT-EXT-AMT          PIC S9(9)V99.
031600
031700 01  TOTAL-LINE.
031800     05  TOTAL-DESC          PIC X(22). 
031900     05  TOTAL-NUM           PIC ZZ,ZZZ,ZZ9-. 
010191     05 TOTAL-NUM-1 REDEFINES TOTAL-NUM
                 PIC Z,ZZ,ZZZ.9-. 
010191     05 TOTAL-NUM-2 REDEFINES TOTAL-NUM
                 PIC ZZZ,ZZZ.99-. 
010191     05 TOTAL-NUM-3 REDEFINES TOTAL-NUM
                 PIC ZZ,ZZZ.999-. 
010191     05 TOTAL-NUM-4 REDEFINES TOTAL-NUM
                 PIC ZZZZZ.9999-. 
010191     05 TOTAL-NUM-5 REDEFINES TOTAL-NUM
                 PIC ZZZZ.99999-. 
032000     05  TOTAL-DESC2         PIC X(99). 
032100 01  DESCS. 
032200     05  ORDER-DESC    PIC X(20) VALUE "NUMBER OF ORDERS".
101201     05  CREDIT-DESC   PIC X(20) VALUE "NUMBER OF CREDITS".
032300     05  ITEM-DESC     PIC X(20) VALUE "NUMBER OF ITEMS". 
032400     05  OQTY-DESC     PIC X(20) VALUE "QUANTITY ORDERED".
032500     05  RQTY-DESC     PIC X(20) VALUE "CURRENT RECEIPT QTY". 
032600     05  PQTY-DESC     PIC X(20) VALUE "CURRENT INVOICE QTY". 
032700 01  FINAL-TOTAL-DESC.
032800     05  FILLER  PIC X(16) VALUE "    GROSS AMOUNT".
032900 01  FINAL-TOTAL-LINE.
033000     05  FILLER            PIC XXX VALUE SPACES.
033100     05  PR-FT-EXT-AMT     PIC ZZ,ZZZ,ZZZ.99-.
033200 01  WORKING-TOTALS.
101201     05  EXT-QTY             PIC S9(7)V9(5).
033400     05  WEIGHT              PIC S9(6)V999. 
033500
033600 01  SPC-ITEM-NO             PIC X(12). 
033700     88  SPC-ITEM     VALUES   "F           ", "f           ",
033800                               "S           ", "s           ",
033900                               "C           ", "c           ",
034000                               "T           ", "t           ".
110899     88  FREIGHT      VALUES   "F           ", "f           ".
034100
062393 01  INPUT-SPECS-2.
062393     05  FILLER      PIC X(9)   VALUE "0835O0206".
032190     05  OPTION      PIC 9      VALUE 1.
032190     05  FILLER      PIC X(4)   VALUE "E   ".
062393 01  FORM-QUES       PIC X(24) VALUE "Listing Spacing  ".
032190 01  FORM-TYPES.
062393     05  FILLER      PIC X(06) VALUE "Single".
032190     05  FILLER      PIC X(06) VALUE "Double".
032190 01  FORM-HELP.
062393     05  FILLER PIC X(120)   VALUE " This report detail may be sin
062393-    "gle spaced or double spaced.                                
062393-    "         $".
041498 01  WS-CUSTOMIZED-FLAG     PIC 9(5) VALUE ZERO.
082699     88 MEI                 VALUE 00152.
082699     88 ATHENS              VALUE 00438.
041498 01  BATCH-SPECS.
041498         10  FILLER     PIC X(5)  VALUE "1645D".
010807*        10  FILLER     PIC 99    VALUE 01.
010807*        10  FILLER     PIC 99    VALUE 01.
010807         10  FILLER     PIC 99    VALUE 02.
010807         10  FILLER     PIC 99    VALUE 02.
041498         10  FILLER     PIC 9     VALUE 0.
041498         10  FILLER     PIC X(4)  VALUE "E   ".
041498 01  BATCH-HELP.
041498     05 FILLER          PIC X(40) VALUE
041498        " Enter the batch number that should be a".
041498     05 FILLER          PIC X(40) VALUE
041498        "ssigned to these orders.  It must be    ".
041498     05 FILLER          PIC X(40) VALUE
041498        " from 1 to 9.                          $".
CLNUP1 77  CNTLF--NAME PIC X(15) VALUE "CONTROL.FIL" .
CLNUP1 77  CNTLF-FULLPATH PIC X(35) VALUE SPACES .
CLNUP1 77  TEMP-MASTER-DIR PIC X(14) VALUE SPACES .
CLNUP1 77  TEMP-SUB-DIR PIC X(14) VALUE SPACES .
CLNUP1 77  EXCNF--NAME PIC X(15) VALUE "CONTROL2.FIL" .
CLNUP1 77  EXCNF-FULLPATH PIC X(35) VALUE SPACES .
CLNUP1 77  USERF--NAME PIC X(15) VALUE "USER.FIL" .
CLNUP1 77  USERF-FULLPATH PIC X(35) VALUE SPACES .
CLNUP1 01  IO-WAIT-CD  PIC X VALUE "1"                                  
CLNUP1     88 IO-WAIT-ON VALUE IS "1".
CLNUP1     88 IO-WAIT-OFF VALUE IS "0".
            COPY "STEST.DTA".
CLNUP1 77  COLRF--NAME PIC X(15) VALUE "COLOR.FIL" .
CLNUP1 77  COLRF-FULLPATH PIC X(35) VALUE SPACES .
CLNUP1 77  POHDF--NAME PIC X(15) VALUE "POHDR.FIL" .
CLNUP1 77  POHDF-FULLPATH PIC X(35) VALUE SPACES .
CLNUP1 77  POLNF--NAME PIC X(15) VALUE "POLINE.FIL" .
CLNUP1 77  POLNF-FULLPATH PIC X(35) VALUE SPACES .
CLNUP1 77  SRECF--NAME PIC X(15) VALUE "SERLRECV.FIL" .
CLNUP1 77  SRECF-FULLPATH PIC X(35) VALUE SPACES .
CLNUP1 01  CHAIN-PARAM-LEN PIC S9(4) COMP-5.
CLNUP1 01  CHAIN-NAME-LEN PIC S9(4) COMP-5.
CLNUP1 77  INVBF--NAME PIC X(15) VALUE "INVBATCH.FIL" .
CLNUP1 77  INVBF-FULLPATH PIC X(35) VALUE SPACES .
CLNUP1 01  DSPL--CONTROL PIC X(100) IS EXTERNAL.
       SCREEN SECTION.
CLNUP1     COPY "CONSTANT.SCR".
CLNUP1     COPY "SCRNINIT.SCR".
CLNUP1     COPY "ERRORFIL.SCR".
CLNUP1     COPY "PRINT.SCR".   
CLNUP1                         
CLNUP1*01 SCR-errorfil-sr-14-20 PIC IS X(51) FROM BOX-TOP CONTROL 
CLNUP1*     DSPL--CONTROL LINE 08 COLUMN 14 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-15-20 PIC IS X(51) FROM BOX-MIDDLE CONTROL 
CLNUP1*     DSPL--CONTROL LINE 09 COLUMN 14 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-16-20 PIC IS X(51) FROM BOX-MIDDLE CONTROL 
CLNUP1*     DSPL--CONTROL LINE 10 COLUMN 14 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-17-20 PIC IS X(51) FROM BOX-MIDDLE CONTROL 
CLNUP1*     DSPL--CONTROL LINE 11 COLUMN 14 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-18-20 PIC IS X(51) FROM BOX-MIDDLE CONTROL 
CLNUP1*     DSPL--CONTROL LINE 12 COLUMN 14 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-19-20 PIC IS X(51) FROM BOX-MIDDLE CONTROL 
CLNUP1*     DSPL--CONTROL LINE 13 COLUMN 14 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-20-20 PIC IS X(51) FROM BOX-MIDDLE CONTROL 
CLNUP1*     DSPL--CONTROL LINE 14 COLUMN 14 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-21-20 PIC IS X(51) FROM BOX-BOTTOM CONTROL 
CLNUP1*     DSPL--CONTROL LINE 15 COLUMN 14 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-35-20 PIC IS X(40) FROM ERROR-MSG CONTROL 
CLNUP1*     DSPL--CONTROL LINE 10 COLUMN 17 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-36-20 PIC IS X(35) FROM ERROR-LINE-1 CONTROL 
CLNUP1*     DSPL--CONTROL LINE 11 COLUMN 17 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-37-20 PIC IS X(41) FROM ERROR-LINE-2 CONTROL 
CLNUP1*     DSPL--CONTROL LINE 12 COLUMN 17 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-38-20 PIC IS X(40) FROM ERROR-CONTACT CONTROL 
CLNUP1*     DSPL--CONTROL LINE 13 COLUMN 17 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-39-20 PIC IS X(40) FROM ERROR-RESUME CONTROL 
CLNUP1*     DSPL--CONTROL LINE 14 COLUMN 17 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-40-20 VALUE IS "Program Name = " CONTROL 
CLNUP1*     DSPL--CONTROL LINE 09 COLUMN 17 REVERSE-VIDEO.
CLNUP1*01 SCR-errorfil-sr-41-20 PIC IS X(6) FROM PROG-NAME CONTROL 
CLNUP1*     DSPL--CONTROL LINE 09 COLUMN 32 REVERSE-VIDEO.
CLNUP1*01 SCR-scrninit-sr-13-20 PIC IS X(80) FROM SCRN-TITLE-1 CONTROL 
CLNUP1*     DSPL--CONTROL LINE 01 COLUMN 01.
CLNUP1*01 SCR-scrninit-sr-14-20 PIC IS X(80) FROM SCRN-TITLE-2 CONTROL 
CLNUP1*     DSPL--CONTROL LINE 02 COLUMN 01.
CLNUP1*01 SCR-scrninit-sr-15-20 VALUE IS " PGM=" CONTROL DSPL--CONTROL 
CLNUP1*     LINE 02 COLUMN 04.
CLNUP1*01 SCR-scrninit-sr-16-20 PIC IS X(6) FROM PROG-NAME CONTROL 
CLNUP1*     DSPL--CONTROL LINE 02 COLUMN 09.
CLNUP1*01 SCR-scrninit-sr-17-20 VALUE IS " Station " CONTROL 
CLNUP1*     DSPL--CONTROL LINE 02 COLUMN 19.
CLNUP1*01 SCR-scrninit-sr-18-20 PIC IS X(2) FROM USER-TERMID CONTROL 
CLNUP1*     DSPL--CONTROL LINE 02 COLUMN 28.
CLNUP1*01 SCR-scrninit-sr-21-20 VALUE IS " " CONTROL DSPL--CONTROL LINE 
CLNUP1*     TIMER-CNT COLUMN 1 SIZE IS 80.
CLNUP1*01 SCR-print-sr-100-20 PIC IS X(6) FROM PROG-NAME CONTROL 
CLNUP1*     DSPL--CONTROL LINE 2 COLUMN 9.
CLNUP1*01 SCR-print-sr-114-20 PIC IS X(78) FROM CLEAR-19 CONTROL 
CLNUP1*     DSPL--CONTROL LINE CNT COLUMN 2.
CLNUP1*01 SCR-print-sr-145-20 PIC IS X(80) FROM PAUSE-SCRN-2 CONTROL 
CLNUP1*     DSPL--CONTROL LINE 19 COLUMN 1.
       01 SCR-po010-cbl-655-20 PIC IS X(18) FROM PRINTING-REPORT CONTROL
             DSPL--CONTROL LINE 13 COLUMN 30.
       01 SCR-po010-cbl-721-20 PIC IS X(24) FROM FORM-QUES CONTROL 
            DSPL--CONTROL LINE 8 COLUMN 18.
       01 SCR-po010-cbl-747-20 VALUE IS "               Enter Batch Numb
      -     "er              " CONTROL DSPL--CONTROL LINE 16 COLUMN 10.
       01 SCR-po010-cbl-754-23 VALUE IS " Batch Number must be greater t
      -     "han zero! " CONTROL DSPL--CONTROL LINE 21 COLUMN 1 
            REVERSE-VIDEO.
       01 SCR-po010-cbl-779-20 PIC IS X(21) FROM RANGE-MSG CONTROL 
            DSPL--CONTROL LINE 11 COLUMN 20.
       01 SCR-po010-cbl-802-20 PIC IS X(16) FROM RANGE-LOW-MSG CONTROL 
            DSPL--CONTROL LINE 13 COLUMN 20.
       01 SCR-po010-cbl-803-20 PIC IS X(16) FROM RANGE-HIGH-MSG CONTROL 
            DSPL--CONTROL LINE 14 COLUMN 20.
       01 SCR-po010-cbl-813-24 PIC IS X(47) FROM RANGE-ERR-1 CONTROL 
            DSPL--CONTROL LINE 21 COLUMN 1 REVERSE-VIDEO.
       01 SCR-po010-cbl-817-24 PIC IS X(51) FROM RANGE-ERR-2 CONTROL 
            DSPL--CONTROL LINE 21 COLUMN 1 REVERSE-VIDEO.
       01 SCR-po010-cbl-839-20 PIC IS X(25) FROM SELECT-QUES CONTROL 
            DSPL--CONTROL LINE 13 COLUMN 25.
       01 SCR-po010-cbl-851-24 PIC IS X(48) FROM RANGE-ERR-3 CONTROL 
            DSPL--CONTROL LINE 21 COLUMN 1 REVERSE-VIDEO.
       01 SCR-po010-cbl-901-20 PIC IS X(6) FROM INVB-PO-NO CONTROL 
            DSPL--CONTROL LINE 14 COLUMN 35.
       01 SCR-po010-cbl-1359-20 PIC IS X(6) FROM POHDF-KEY CONTROL 
            DSPL--CONTROL LINE 14 COLUMN 35.
041498
034200 PROCEDURE DIVISION.
034300 DECLARATIVES.
034400
034500
034600*    PRNTR.DS   PRINTER DECLARATIVES PROCEDURE. 
034700
034800 Z-PRNTR SECTION. 
034900     USE AFTER ERROR PROCEDURE ON LO. 
035000 Z-PRNTR-D. 
035100     COPY "ERRORPRT.SR".
035200     GO TO STATUS-EXIT. 
035300     COPY "POLNF.DS". 
035400
035500     COPY "POHDF.DS". 
035600
035700     COPY "CNTLF.DS". 
035800     COPY "EXCNF.DS". 
035900     COPY "USERF.DS". 
110393     COPY "SRECF.DS". 
071409*    COPY "MUCTF.DS". 
071409     COPY "SCATF.DS".
022796     COPY "STYLF.DS".
022796     COPY "COLRF.DS".
030901     COPY "INVBF.DS".
036000     GO TO STATUS-EXIT. 
036100
036200     COPY "ERRORFIL.SR".
036300
036400 STATUS-EXIT. EXIT. 
036500
036600 END DECLARATIVES.
036700
036800 MAIN-PROG SECTION. 
036900 OPEN-FILES.
071409     MOVE "SIZECAT.FIL"      TO  SCATF--NAME.
            PERFORM USERF-FILL-FULLPATH.
037000     PERFORM PGM-INIT.
082699     IF USER-SN = 00152 OR 00438
041498        MOVE USER-SN TO WS-CUSTOMIZED-FLAG.
041498     IF WS-CUSTOMIZED-FLAG > ZERO
041498        MOVE "PO010M" TO PROG-NAME.
041498     IF NOT ATHENS   
041498        MOVE SPACES TO PR-HEADER2A.
112098     IF NOT BATCH-LIST
030901*          MOVE 7 TO NUM-OPTIONS. 
030901           MOVE 8 TO NUM-OPTIONS. 
032101     IF ATHENS   
              MOVE 8 TO OPTION OF RANGE-SPECS-1.
090606     IF LAST-OPTION = 060604
032709*       MOVE "N" TO FORM-STOCK-FLAG
090606        MOVE "PICKTICK" TO QUEUE-DEFAULT-NAME.
010191     IF NO-DECIMALS   MOVE 0 TO NUMBER-DECIMALS.
010191     IF ONE-DECIMAL   MOVE 1 TO NUMBER-DECIMALS.
010191     IF TWO-DECIMALS  MOVE 2 TO NUMBER-DECIMALS.
010191     IF THREE-DECIMALS  MOVE 3 TO NUMBER-DECIMALS.
010191     IF FOUR-DECIMALS   MOVE 4 TO NUMBER-DECIMALS.
010191     IF FIVE-DECIMALS   MOVE 5 TO NUMBER-DECIMALS.
030901     PERFORM OPEN-ALL-FILES.
062393     PERFORM SCREEN-INIT. 
062393     MOVE 1 TO FLAG.
062393     PERFORM FORM-SELECTION.
037400 BEGIN-REPORT.
037500     PERFORM RANGE-SELECT.
037600     IF FLAG = 3
062393         MOVE 0 TO FLAG
062393         PERFORM FORM-SELECTION
062393         IF FLAG = 4
062393             GO TO EXIT-RUN
062393         ELSE GO TO BEGIN-REPORT.
*********            GO TO EXIT-RUN.

030901     IF WORK-ON-BATCHES
071409*       CLOSE POLNF, POHDF, SRECF, MUCTF, STYLF, COLRF
071409        CLOSE POLNF, POHDF, SRECF, STYLF, COLRF
071409        IF PROFITS-APPAREL-YES
071409            CLOSE SCATF
071409        END-IF
030901        PERFORM CALL-PO011 THRU CALL-PO011-EXIT
030901        MOVE "\PROFITS" TO MASTER-DIR
030901        PERFORM OPEN-ALL-FILES
030901        IF WS-BATCH-NO = ZERO
030901           GO TO EXIT-RUN
030901        ELSE
030901           PERFORM SCREEN-INIT
030901           MOVE WS-BATCH-NO TO USER-BATCH-NO
030901           REWRITE USERF-REC.

112098     IF ATHENS   
112098        IF OPEN-LIST AND 
031601*          (RANGE OR SELECTIVE-ONLY OR REPRINT-ONLY OR 
031601*           WORK-ON-BATCHES) 
031601           (REPRINT-ONLY OR WORK-ON-BATCHES) 
112098           PERFORM GET-BATCH-NO
112098           IF FLAG = 3
112098              GO TO BEGIN-REPORT
112098           ELSE NEXT SENTENCE
112098        ELSE
112098           MOVE ZERO TO USER-BATCH-NO
112098     ELSE
112098        MOVE ZERO TO USER-BATCH-NO.

           MOVE "1010000000" TO FKEYS.
060889     PERFORM PRINT-SELECT.
060889     IF FLAG = 3 GO TO BEGIN-REPORT.

041498*    IF  POST-BY-BATCH-BOTH OR
      *       (POST-BY-BATCH-NEW AND INPUT-BATCH) OR
      *       (POST-BY-BATCH-OPEN AND OPEN-ORDERS)
      *       IF NOT RESETTING-BATCH-NO
112098*    IF INDMETALS
112098*       IF OPEN-LIST
112098*          PERFORM GET-BATCH-NO
112098*          IF FLAG = 3
112098*             GO TO BEGIN-REPORT
112098*          ELSE NEXT SENTENCE
112098*       ELSE
112098*          MOVE ZERO TO USER-BATCH-NO
112098*    ELSE
112098*       MOVE ZERO TO USER-BATCH-NO.
041498
060889     PERFORM PF-OPEN-LO.
037700     PERFORM SCREEN-INIT. 
037800     MOVE 0 TO PAGE-NO. 
037900     DISPLAY SCR-po010-cbl-655-20  . 
038000     IF ESC-FLAG = 1 MOVE "0010000000" TO FKEYS 
038100                ELSE MOVE "0000000000" TO FKEYS.
038200     MOVE 1 TO FLAG.
038300     CALL "KBDCHK" USING FLAG, FKEYS. 
038400     MOVE 0 TO FLAG.
071489     IF OPTION OF RANGE-SPECS-1 = 3
071489       PERFORM SELECTIVE-ORDER UNTIL FLAG = 3
071489       CLOSE LO
071489       GO TO BEGIN-REPORT.
031601*    IF REPRINT-ONLY    
031601     IF REPRINT-ONLY OR WORK-ON-BATCHES
030901        PERFORM PROCESS-REPORT-BATCH THRU
                      PROCESS-REPORT-BATCH-EXIT
           ELSE
038500        PERFORM PROCESS-REPORT.
038600 END-REPORT.
038700     PERFORM PRINT-FINAL-TOTALS.
038800     MOVE SPACES TO PRINT-REC.
070907     PERFORM PF-REC-CHECK.
038900     WRITE PFRPT BEFORE ADVANCING PAGE. 
010909     PERFORM CLOSE-LO.
039000
039100 EXIT-RUN.
110393     IF LAST-OPTION = 040702
110393        MOVE "PO025" TO NEXT-PROG.
039300     PERFORM CLOSE-FILES. 
039400     COPY "FINISH.SR".
039500
039600     COPY "CONTROL.SR". 
039700     COPY "DATECVT.SR". 
039800
039900 SUBROUTINE SECTION.
040000 PGM-INIT.
040100     PERFORM CONTROL-INIT.
081694     IF LAST-OPTION = 060401
040300         MOVE "Y" TO BATCH-LIST-FLAG. 
041498     IF LAST-OPTION = 060601 OR 060602 OR 060603
030901         MOVE "O" TO INVB-LOC
041498         MOVE "O" TO BATCH-LIST-FLAG. 
040400     IF BATCH-LIST
030901         MOVE "B" TO INVB-LOC
040500         MOVE "POBATHDR.FIL" TO EXT-HDR-FILE
040600         MOVE "POBATLIN.FIL" TO EXT-LIN-FILE
040700         MOVE EXT-LIN-FILE TO POLNF--NAME
            PERFORM POLNF-FILL-FULLPATH
040800         MOVE EXT-HDR-FILE TO POHDF--NAME
            PERFORM POHDF-FILL-FULLPATH
040900         MOVE SPACES TO PRMT-REC, PRMT-INV
041000     ELSE MOVE OPEN-TITLE-1 TO REPORT-TITLE 
               MOVE 6 TO NUM-OPTIONS. 
090606     IF LAST-OPTION = 060604
090606        MOVE OPEN-TITLE-2 TO REPORT-TITLE. 
031199     MOVE PGM-DATE-11 TO PR-DATE-11.
041300     ACCEPT SYSTEM-TIME FROM TIME.
041400     MOVE SYSTEM-HOUR TO PR-HOUR. 
041500     MOVE SYSTEM-MINUTE TO PR-MINUTE. 
041600     MOVE SYSTEM-SECONDS TO PR-SECONDS. 
041700     MOVE CNTL-CONAME TO PR-CONAME. 
041800     MOVE REPORT-TITLE TO PR-TITLE. 
041900*    MOVE CNTL-PR-CNDSE TO PR-CNDSE.
042000*    0 = NO ESCAPE, 1 = ESCAPABLE 
042100     MOVE 1 TO ESC-FLAG.
042200     MOVE SPACES TO PR-DETAIL7, PR-TOTALS.
042300     OPEN INPUT EXCNF.
042400     READ EXCNF.
042500
PROFIT     COPY "SCRNINIT.SR".
043000
062393 FORM-SELECTION.
090606     IF LAST-OPTION = 060604
090606        MOVE 2 TO OPTION OF INPUT-SPECS-2.
032190     DISPLAY SCR-po010-cbl-721-20  .
032190     MOVE "1001000000" TO FKEYS.
           PERFORM STEST-po010-cbl-723
032190     CALL "SCRN01" USING FLAG, FKEYS, STEST-SCRN-SPECS, FORM-HELP,
032190         FORM-TYPES
           PERFORM STEST-AFTER-CALL.
062393     IF OPTION OF INPUT-SPECS-2 = 2
062393         MOVE 2 TO SKIP
062393     ELSE MOVE 1 TO SKIP.
062393
022796 SET-APPAREL-INFO.
022796*    MOVE POLN-STYLE TO PR-STYLE.
022796     MOVE SPACES TO PART1-A.

022796     MOVE POLN-COLOR TO PR-COLOR, COLRF-KEY.
           MOVE POLN-STYLE TO STYLF-KEY.
           PERFORM READ-STYLF.
CLNUP1     IF C-RECORD-OK OF STYLF-STATUS
071409        MOVE STYLE-GROUP-NAME TO SCAT-GROUP-NBR
071409        MOVE POLN-CATEGORY TO SCAT-CAT-NUM
071409        PERFORM READ-SCAT-GC
071409*       MOVE MUCT-CATEGORIES(STYLE-GROUP-NAME, POLN-CATEGORY) TO
071409        MOVE SCAT-CAT TO
                  PR-CATEGORY
071409        MOVE STYLE-GROUP-NAME TO SCAT-GROUP-NBR
071409        MOVE POLN-SIZE TO SCAT-SIZE-NUM
071409        PERFORM READ-SCAT-GS
071409*       MOVE MUCT-SIZES(STYLE-GROUP-NAME, POLN-SIZE) TO
071409        MOVE SCAT-SIZE TO
                  PR-SIZE.
           PERFORM READ-COLRF.
CLNUP1     IF C-RECORD-OK OF COLRF-STATUS
022796        MOVE "-" TO PR-HYPHEN
              MOVE COLR-NAME-KEY TO PR-COLR-NAME.

041498 GET-BATCH-NO.
111198     DISPLAY SCR-po010-cbl-747-20
111198         .
041498     MOVE "1010000000" TO FKEYS.
041498     MOVE 0 TO FLAG.
           PERFORM STEST-po010-cbl-751
041498     CALL "SCRN01" USING FLAG, FKEYS, STEST-SCRN-SPECS, 
            BATCH-HELP,
041498          USER-BATCH-NO
           PERFORM STEST-AFTER-CALL.
030901     IF USER-BATCH-NO = ZERO AND FLAG NOT = 3
030901        DISPLAY SCR-po010-cbl-754-23
030901              
030901        GO TO GET-BATCH-NO.
041498     REWRITE USERF-REC.

110899 PRINT-IMS-FRT-LINE.
110899     MOVE "Freight"             TO PR-POLN-ITEM-DESC.
110899     MOVE POHD-IMS-FRT          TO PR-POLN-EXT-AMT.
110899     IF DET-RPT
110899        PERFORM PRINT-DETAIL.
110899     ADD POHD-IMS-FRT           TO TOT-EXT-AMT, FT-EXT-AMT.

030901 OPEN-ALL-FILES.
037100     PERFORM  OPEN-POLNF. 
037200     PERFORM  OPEN-POHDF. 
110393     PERFORM  OPEN-SRECF.
071409*    PERFORM  OPEN-MUCTF.
071409*    PERFORM  READ-MUCTF.
071409     IF PROFITS-APPAREL-YES
              PERFORM OPEN-SCATF
071409     END-IF.
022796     PERFORM  OPEN-STYLF.
022796     PERFORM  OPEN-COLRF.

043100 SUBROUTINE-EXIT. EXIT. 
043200
043400 RANGE-SELECT SECTION.
043500 GET-RANGE. 
043700     DISPLAY SCR-po010-cbl-779-20  . 
043800     MOVE "1010000000" TO FKEYS.
090606     IF LAST-OPTION = 060604
090606        MOVE 1 TO FLAG
090606        MOVE 3 TO OPTION OF RANGE-SPECS-1
090606     ELSE
043900        MOVE 0 TO FLAG.
090606*    PERFORM STEST-po010-cbl-782
044000     CALL "SCRN01" USING FLAG, FKEYS, RANGE-SPECS-1,
044100       RANGE-HELP-1, RANGE-CODES
090606*    PERFORM STEST-AFTER-CALL. 
044200     IF FLAG = 3 GO TO RANGE-SELECT-EXIT. 
112098     MOVE OPTION OF RANGE-SPECS-1 TO RES-SELECTIVE-FLAG.
030901     IF WORK-ON-BATCHES
030901        GO TO RANGE-SELECT-EXIT.
044300     IF OPTION OF RANGE-SPECS-1 = 1 
044400          MOVE LOW-VALUES TO LOW-KEY
044500          MOVE HIGH-VALUES TO HIGH-KEY
044600          GO TO RANGE-SELECT-EXIT.
044700     IF OPTION OF RANGE-SPECS-1 = 3 
071489          GO TO RANGE-SELECT-EXIT.
071489*         GO TO SELECTIVE-ORDERS. 
044900     IF OPTION OF RANGE-SPECS-1 = 4 
045000          MOVE "S" TO RPT-TYPE-FLAG 
045100          GO TO RANGE-SELECT-EXIT.
045200     IF OPTION OF RANGE-SPECS-1 = 5 OR OPTION OF RANGE-SPECS-1 = 6
112098        OR OPTION OF RANGE-SPECS-1 = 7
112398*         MOVE OPTION OF RANGE-SPECS-1 TO SELECTIVE-FLAG
045400          GO TO RANGE-SELECT-EXIT.
045500     DISPLAY SCR-po010-cbl-802-20  . 
045600     DISPLAY SCR-po010-cbl-803-20  .
045700     MOVE LOW-VALUES TO LOW-KEY.
045800     MOVE HIGH-VALUES TO HIGH-KEY.
045900 GET-LOW-HIGH.
046000     MOVE "1010000000" TO FKEYS.
046100     MOVE 0 TO FLAG.
           PERFORM STEST-po010-cbl-809
046200     CALL "SCRN02" USING FLAG, FKEYS, STEST-SCRN-SPECS,
046300       RANGE-HELP-2, LOW-KEY, HIGH-KEY
           PERFORM STEST-AFTER-CALL. 
046400     IF FLAG = 3 GO TO GET-RANGE. 
046500     IF LOW-KEY > HIGH-KEY
046600         DISPLAY SCR-po010-cbl-813-24    
046700         GO TO GET-LOW-HIGH.
046800     PERFORM START-POHDF. 
046900     IF C-AT-END OF POHDF-STATUS 
047000         DISPLAY SCR-po010-cbl-817-24    
047100         GO TO GET-LOW-HIGH.
047200     GO TO RANGE-SELECT-EXIT. 
047300
071489 RANGE-SELECT-EXIT. EXIT. 
071489
030901 CALL-PO011 SECTION.
030901 CALL-PO011-BEGIN.
030901     MOVE "PO011" TO NEXT-PROG.
022701     CALL "CHGDIR" USING MASTER-DIR, RETURN-CD.
030901     PERFORM CALL-CHAINR THRU CALL-CHAINR-EXIT.
030901     MOVE OUTPUT-FILE TO WS-PASSED-DATA.
030901     CALL "CHGDIR" USING SUB-DIR, RETURN-CD.
030901 CALL-PO011-EXIT. EXIT.
      
030901 CALL-CHAINR SECTION.
030901 CALL-CHAINR-SECTION.
030901     PERFORM CHNR--PARM-BLOCK-DOS-RET-CODE.
030901 CALL-CHAINR-EXIT. EXIT.

071489 SELECTIVE-ORDER SECTION.
047400 SELECTIVE-ORDERS.
047500     DISPLAY SCR-po010-cbl-839-20  . 
047600     MOVE "1010000010" TO FKEYS.
047700     MOVE 0 TO FLAG.
           PERFORM STEST-po010-cbl-842
047800     CALL "SCRN01" USING FLAG, FKEYS, STEST-SCRN-SPECS,
047900       RANGE-HELP-3, ORDER-NUMBER
           PERFORM STEST-AFTER-CALL.
071489     IF FLAG = 3 GO TO SELECTIVE-ORDER-EXIT.
071489*    IF FLAG = 3 GO TO GET-RANGE. 
048100     IF FLAG = 9 GO TO END-REPORT.
048200     IF ORDER-NUMBER = 0 GO TO SELECTIVE-ORDERS.
048300     MOVE ORDER-NUMBER TO POHD-PO-NO. 
048400     PERFORM READ-POHDF.
048500     IF POHDF-STATUS = NOT-FOUND
048600         DISPLAY SCR-po010-cbl-851-24    
048700     ELSE PERFORM PRINT-PUR-ORDER.
071489*    GO TO SELECTIVE-ORDERS.
048900
071489 SELECTIVE-ORDER-EXIT. EXIT. 
049100
049200 PROCESS-REPORT SECTION.
049300 PROCESS-REPORT-BEGIN.
049400     PERFORM START-POHDF. 
049500     IF NOT C-AT-END OF POHDF-STATUS 
049600         PERFORM  READ-POHDF-NEXT.
049700
049800 PROCESS-REPORT-NEXT. 
049900     IF C-AT-END OF POHDF-STATUS 
050000         GO TO PROCESS-REPORT-EXIT. 
050100     IF POHDF-KEY > HIGH-KEY
050200         GO TO PROCESS-REPORT-EXIT. 

031601*    IF REPRINT-ONLY
031601*       IF USER-BATCH-NO NOT = POHD-BATCH-NO
031601*          GO TO PROCESS-REPORT-READ.

050300     PERFORM PRINT-PUR-ORDER. 
050400 PROCESS-REPORT-READ. 
050500     IF ESC-FLAG = 1
050600         CALL "KBDCHK" USING FLAG, FKEYS
060889         IF FLAG = 3 
060889            PERFORM ACCEPT-PAUSE 
060889            IF OPTION OF PAUSE-SPEC(1) = 1 
060889               MOVE 3 TO FLAG 
060889               GO TO PROCESS-REPORT-EXIT.
050800     PERFORM  READ-POHDF-NEXT.
050900     GO TO PROCESS-REPORT-NEXT. 
051000
051100 PROCESS-REPORT-EXIT. EXIT. 

030901******************************************************************
030901 PROCESS-REPORT-BATCH SECTION.
030901******************************************************************
030901 PROCESS-REPORT-BATCH-BEGIN.
           PERFORM OPEN-INVBF.
           MOVE USER-BATCH-NO TO INVB-BATCH-NO
           MOVE 1             TO INVB-SEQ-NO.
056000     PERFORM START-INVBF.
056100     IF C-AT-END OF INVBF-STATUS
               MOVE AT-END TO POHDF-STATUS
056200         GO TO PROCESS-REPORT-BATCH-EXIT.
           PERFORM PROCESS-REPORT-BATCH-READ.
056300
056400 PROCESS-REPORT-BATCH-NEXT.
022701     DISPLAY SCR-po010-cbl-901-20  .
056500     IF C-AT-END OF INVBF-STATUS
056600         GO TO PROCESS-REPORT-BATCH-EXIT.
081495     IF INVB-BATCH-NO NOT = USER-BATCH-NO
056800         GO TO PROCESS-REPORT-BATCH-EXIT.

           MOVE INVB-PO-NO TO POHDF-KEY.
           PERFORM READ-POHDF.
056900     PERFORM PRINT-PUR-ORDER.

057000 PROCESS-REPORT-BATCH-READ.
057200     CALL "KBDCHK" USING FLAG, FKEYS.
060589     IF FLAG = 3
060589        PERFORM ACCEPT-PAUSE
060589        IF OPTION OF PAUSE-SPEC(1) = 1
060589           MOVE 3 TO FLAG
060589           GO TO PROCESS-REPORT-BATCH-EXIT.
057400     PERFORM  READ-INVBF-NEXT.
057500     GO TO PROCESS-REPORT-BATCH-NEXT.

022701 PROCESS-REPORT-BATCH-EXIT. EXIT.
051200
051300 PRINT-REPORT SECTION.
051400 PRINT-PUR-ORDER.
112398*    IF SELECTIVE OR RANGE
031601*    IF SELECTIVE-ONLY OR RANGE
031601*       MOVE USER-BATCH-NO TO POHD-BATCH-NO.
032911*    IF LINE-NO > 50
032911     IF LINE-NO > 48
051600         MOVE 99 TO LINE-NO 
051700         PERFORM PAGE-CHECK.
051800     IF DET-RPT 
051900         PERFORM MOVE-PUR-ORDER-HEADER
052000         PERFORM PRINT-REPORT-HEADERS.
052100     MOVE POHD-PO-NO TO POLN-PO-NO. 
052200     MOVE 0 TO POLN-SEQ-NO. 
052300     PERFORM START-POLNF-GREATER. 
052400     IF NOT C-AT-END OF POLNF-STATUS 
052500         PERFORM READ-POLNF-NEXT. 
052600     PERFORM MOVE-DETAIL
052700         UNTIL C-AT-END OF POLNF-STATUS. 
012600*    IF INDMETALS AND POHD-INV-STATUS
012600     IF ATHENS    AND PO-INV-STATUS
110899        PERFORM PRINT-IMS-FRT-LINE.
052800     PERFORM MOVE-TOTALS. 
101201     IF POHD-CREDIT-MEMO
101201        ADD 1 TO FT-CREDITS
101201     ELSE
052900        ADD 1 TO FT-ORDERS.
041498     IF (ATHENS    AND OPEN-LIST)
041498        PERFORM REWRITE-POHDF.
053000
053100 PRINT-DETAIL.
053200     PERFORM PAGE-CHECK.
053300     PERFORM PRINT-REPORT-DETAIL. 
053400
053500 PRINT-TOTALS.
053600     PERFORM PAGE-CHECK.
053700     ADD 2 TO LINE-NO.
090606     IF LAST-OPTION = 060604
090606        MOVE ZERO TO TS-REC-QTY, TS-INV-QTY, TS-EXT-AMT.
053800     MOVE PR-TOTALS TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 2 LINES.
053900     PERFORM PAGE-CHECK.
054000     IF LINE-NO > 4 
054100         ADD 4 TO LINE-NO 
054200         MOVE ALL "=" TO PRINT-REC
070907               PERFORM PF-REC-CHECK
054300         WRITE PFRPT AFTER ADVANCING 2 LINES
054400         MOVE SPACES TO PRINT-REC 
070907               PERFORM PF-REC-CHECK
054500         WRITE PFRPT AFTER ADVANCING 2 LINES. 
054600
054700 PRINT-FINAL-TOTALS.
054800     ADD 5 TO LINE-NO.
054900     PERFORM PAGE-CHECK.
055000     MOVE ORDER-DESC TO TOTAL-DESC. 
055100     MOVE FT-ORDERS TO TOTAL-NUM. 
055200     MOVE FINAL-TOTAL-DESC TO TOTAL-DESC2.
055300     MOVE TOTAL-LINE TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 3 LINES. 
101201     MOVE CREDIT-DESC TO TOTAL-DESC.
101201     MOVE FT-CREDITS  TO TOTAL-NUM.
101201     MOVE SPACES TO TOTAL-DESC2.
101201     MOVE TOTAL-LINE TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINES. 
055400     MOVE ITEM-DESC TO TOTAL-DESC.
055500     MOVE FT-ITEMS TO TOTAL-NUM.
055600     MOVE SPACES TO TOTAL-DESC2.
055700     MOVE TOTAL-LINE TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINES. 
055800     MOVE OQTY-DESC TO TOTAL-DESC.
010191     IF NO-DECIMALS  MOVE FT-ORDER-QTY TO TOTAL-NUM.
010191     IF ONE-DECIMAL  MOVE FT-ORDER-QTY TO TOTAL-NUM-1.
010191     IF TWO-DECIMALS MOVE FT-ORDER-QTY TO TOTAL-NUM-2.
010191     IF THREE-DECIMALS MOVE FT-ORDER-QTY TO TOTAL-NUM-3.
010191     IF FOUR-DECIMALS MOVE FT-ORDER-QTY TO TOTAL-NUM-4.
010191     IF FIVE-DECIMALS MOVE FT-ORDER-QTY TO TOTAL-NUM-5.
056000     MOVE FT-EXT-AMT TO PR-FT-EXT-AMT.
056100     MOVE FINAL-TOTAL-LINE TO TOTAL-DESC2.
056200     MOVE TOTAL-LINE TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINES. 
056300     IF NOT BATCH-LIST
056400         MOVE RQTY-DESC TO TOTAL-DESC 
010191         PERFORM MOVE-FT-REC-QTY
010191*        MOVE FT-REC-QTY TO TOTAL-NUM 
056600         MOVE SPACES TO TOTAL-DESC2 
056700         MOVE TOTAL-LINE TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINES
056800         MOVE PQTY-DESC TO TOTAL-DESC 
010191         PERFORM MOVE-FT-INV-QTY
010191*        MOVE FT-INV-QTY TO TOTAL-NUM 
057000         MOVE SPACES TO TOTAL-DESC2 
057100         MOVE TOTAL-LINE TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINES. 

010191 MOVE-FT-REC-QTY.
010191     IF NO-DECIMALS  MOVE FT-REC-QTY TO TOTAL-NUM.
010191     IF ONE-DECIMAL  MOVE FT-REC-QTY TO TOTAL-NUM-1.
010191     IF TWO-DECIMALS  MOVE FT-REC-QTY TO TOTAL-NUM-2.
010191     IF THREE-DECIMALS MOVE FT-REC-QTY TO TOTAL-NUM-3.
010191     IF FOUR-DECIMALS MOVE FT-REC-QTY TO TOTAL-NUM-4.
010191     IF FIVE-DECIMALS MOVE FT-REC-QTY TO TOTAL-NUM-5.

010191 MOVE-FT-INV-QTY.
010191     IF NO-DECIMALS  MOVE FT-INV-QTY TO TOTAL-NUM.
010191     IF ONE-DECIMAL  MOVE FT-INV-QTY TO TOTAL-NUM-1.
010191     IF TWO-DECIMALS MOVE FT-INV-QTY TO TOTAL-NUM-2.
010191     IF THREE-DECIMALS MOVE FT-INV-QTY TO TOTAL-NUM-3.
010191     IF FOUR-DECIMALS MOVE FT-INV-QTY TO TOTAL-NUM-4.
010191     IF FIVE-DECIMALS MOVE FT-INV-QTY TO TOTAL-NUM-5.
057200
057300 PAGE-CHECK.
057400     IF LINE-NO > PAGE-SIZE AND PAGE-NO IS NOT = 0
057500         MOVE SPACES TO PRINT-REC 
070907               PERFORM PF-REC-CHECK
057600         WRITE PFRPT AFTER ADVANCING PAGE.
057700     IF LINE-NO > PAGE-SIZE 
057800         MOVE 0 TO LINE-NO
057900         ADD 1 TO PAGE-NO 
058000         MOVE PAGE-NO TO PR-PAGE-NO 
058100         MOVE PR-HEADER1 TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT
058200         MOVE PR-HEADER1A TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT 
058300         ADD 2 TO LINE-NO 
058400         MOVE SPACES TO PRINT-REC 
070907               PERFORM PF-REC-CHECK
058500         WRITE PFRPT
058600         ADD 2 TO LINE-NO.
058700
058800 PRINT-REPORT-EXIT. EXIT. 
058900
059000
059100*    PO010.RP 
059200
059300 PO010-REPORT SECTION.
059400
059500 AT-END-CHECK.
059600*    IF POHDF-STATUS = AT-END 
059700*        PERFORM FINAL-TOTALS.
059800
059900 MOVE-PUR-ORDER-HEADER. 
060000     MOVE POHD-PO-NO
060100         TO PR-POHD-PO-NO.
060200     MOVE POHD-VEND-NO
060300         TO PR-POHD-VEND-NO.
060400     MOVE POHD-VEND-NAME
060500         TO PR-POHD-VEND-NAME.
060600     MOVE POHD-CO-NAME
060700         TO PR-POHD-CO-NAME.
060800     MOVE POHD-PO-DATE TO DATE-IN.
031199     PERFORM DATE-CONVERT THRU DATE-CONVERT-EXIT.
031199     MOVE DATE-OUT-11 TO PR-PO-DATE-11. 
061100     MOVE POHD-DISC-DAYS TO PR-POHD-DISC-DAYS.
101201     IF POHD-CREDIT-MEMO
101201        MOVE "CREDIT MEMO" TO PR-CREDIT-MEMO
101201     ELSE
101201        MOVE "           " TO PR-CREDIT-MEMO.
061200     MOVE POHD-VEND-ADDR1 
061300         TO PR-POHD-VEND-ADDR1. 
061400     MOVE POHD-CO-ADDR1 
061500         TO PR-POHD-CO-ADDR1. 
061600     MOVE POHD-DELIV-DATE TO DATE-IN. 
031199     PERFORM DATE-CONVERT THRU DATE-CONVERT-EXIT.
031199     MOVE DATE-OUT-11 TO PR-POHD-DELIV-DATE-11. 
061900     MOVE POHD-DISC-PCT TO PR-POHD-DISC-PCT.
062000     MOVE POHD-VEND-ADDR2 
062100         TO PR-POHD-VEND-ADDR2. 
062200     MOVE POHD-CO-ADDR2 
062300         TO PR-POHD-CO-ADDR2. 
062400     MOVE POHD-REQ-NO TO PR-POHD-REQ-NO.
012600     IF ATHENS   
012600        MOVE SPACES TO PR-POHD-REQ-NO.
062500     MOVE POHD-DUE-DAYS TO PR-POHD-DUE-DAYS.
062600     MOVE POHD-VEND-CITY
062700         TO PR-POHD-VEND-CITY.
062800     MOVE POHD-VEND-STATE 
062900         TO PR-POHD-VEND-STATE. 
063000     MOVE POHD-VEND-ZIP 
063100         TO PR-POHD-VEND-ZIP. 
063200     MOVE POHD-CO-CITY
063300         TO PR-POHD-CO-CITY.
063400     MOVE POHD-CO-STATE 
063500         TO PR-POHD-CO-STATE. 
063600     MOVE POHD-CO-ZIP 
063700         TO PR-POHD-CO-ZIP. 
063800     MOVE YN-OPTS(POHD-BO-CD) TO PR-BO-CD.
063900     MOVE PO-STATUS-OPTS(POHD-STATUS-CD) TO PR-POHD-STATUS-CD.
064000     MOVE POHD-FOB-PT 
064100         TO PR-POHD-FOB-PT. 
064200     MOVE POHD-VEND-CONTACT 
064300         TO PR-POHD-VEND-CONTACT. 
064400     MOVE POHD-BUYER
064500         TO PR-POHD-BUYER.
064600     MOVE POHD-SHIP-INST
064700         TO PR-POHD-SHIP-INST.
064800     MOVE POHD-TERMS-DESC 
064900         TO PR-POHD-TERMS-DESC. 
065000     IF POHD-STATUS-CD = 2 OR POHD-STATUS-CD = 4
065100         MOVE POHD-INV-NO TO PR-POHD-INV-NO 
065200         MOVE POHD-INV-DESC TO PR-POHD-INV-DESC 
065300         MOVE POHD-INV-DATE TO DATE-IN
031199         PERFORM DATE-CONVERT THRU DATE-CONVERT-EXIT 
031199         MOVE DATE-OUT-11 TO PR-POHD-INV-DATE-11
065600         MOVE POHD-DUE-DATE TO DATE-IN
031199         PERFORM DATE-CONVERT THRU DATE-CONVERT-EXIT
031199         MOVE DATE-OUT-11 TO PR-POHD-DUE-DATE-11
065900         MOVE EXCN-HALT(POHD-HALT-CD) TO PR-POHD-HALT-CD
070397*        MOVE AP-TYPE(POHD-TYPE-CD) TO PR-POHD-TYPE-CD
070397         MOVE AP-PMT(POHD-TYPE-CD) TO PR-POHD-TYPE-CD
066100         MOVE POHD-CHK-NO TO PR-POHD-CHK-NO.
041498     IF ATHENS   
041498        IF OPEN-LIST
041498           MOVE POHD-BATCH-NO TO PR-BATCH-NO.
066200     PERFORM PRINT-PUR-ORDER-HEADER.
066300
066400 MOVE-DETAIL. 
066500     COMPUTE EXT-QTY = POLN-ORDER-QTY * POLN-CONV-FACTOR. 
066600     MOVE POLN-ITEM-DESC TO PR-POLN-ITEM-DESC.
022796     IF PROFITS-APPAREL-YES
052093         MOVE SPACES TO PR-APPAREL-PART
022796         PERFORM SET-APPAREL-INFO
CLNUP1         IF C-RECORD-OK OF STYLF-STATUS
022796            MOVE PART1-A TO PR-POLN-ITEM-DESC.
066800     MOVE POLN-ITEM-NO TO SPC-ITEM-NO.
110899     IF ATHENS  AND FREIGHT AND PO-INV-STATUS
110899        MOVE SPACES TO PR-POLN-ITEM-DESC
110899     ELSE
066700        MOVE POLN-EXT-AMT TO PR-POLN-EXT-AMT.
066900     IF NOT SPC-ITEM
067000         MOVE POLN-ITEM-NO TO PR-POLN-ITEM-NO 
067100         MOVE POLN-ITEM-PRICE TO PR-POLN-ITEM-PRICE 
010191         PERFORM MOVE-POLN-ORDER-QTY
067300         MOVE POLN-CONV-FACTOR TO PR-POLN-CONV-FACTOR 
010191*        MOVE POLN-VEND-UOM TO PR-POLN-VEND-UOM 
010191         MOVE POLN-VITEM-NO TO PR-POLN-VITEM-NO 
010191*        MOVE POLN-ITEM-UOM TO PR-POLN-ITEM-UOM
010191         IF NO-DECIMALS MOVE EXT-QTY TO PR-EXT-QTY 
010191         ELSE IF ONE-DECIMAL MOVE EXT-QTY TO PR-EXT-QTY-1
010191         ELSE IF TWO-DECIMALS MOVE EXT-QTY TO PR-EXT-QTY-2
010191         ELSE IF THREE-DECIMALS MOVE EXT-QTY TO PR-EXT-QTY-3
010191         ELSE IF FOUR-DECIMALS MOVE EXT-QTY TO PR-EXT-QTY-4
010191         ELSE IF FIVE-DECIMALS MOVE EXT-QTY TO PR-EXT-QTY-5.
052093     IF PROFITS-APPAREL-YES
052093         MOVE SPACES TO PR-APPAREL-PART.
067800     IF NOT SPC-ITEM
067900       IF POHD-STATUS-CD = 2 OR POHD-STATUS-CD = 3
010191          IF NO-DECIMALS MOVE POLN-REC-QTY TO PR-POLN-REC-QTY
010191          ELSE
010191          IF ONE-DECIMAL MOVE POLN-REC-QTY TO PR-POLN-REC-QTY-1
010191          ELSE
010191          IF TWO-DECIMALS MOVE POLN-REC-QTY TO PR-POLN-REC-QTY-2
010191          ELSE
010191          IF THREE-DECIMALS MOVE POLN-REC-QTY TO PR-POLN-REC-QTY-3
010191          ELSE
010191          IF FOUR-DECIMALS MOVE POLN-REC-QTY TO PR-POLN-REC-QTY-4
010191          ELSE
010191          IF FIVE-DECIMALS MOVE POLN-REC-QTY TO PR-POLN-REC-QTY-5.
068100     IF NOT SPC-ITEM
068200         IF POHD-STATUS-CD = 2 OR POHD-STATUS-CD = 4
010191          IF NO-DECIMALS MOVE POLN-INV-QTY TO PR-POLN-INV-QTY
010191          ELSE
010191          IF ONE-DECIMAL MOVE POLN-INV-QTY TO PR-POLN-INV-QTY-1
010191          ELSE
010191          IF TWO-DECIMALS MOVE POLN-INV-QTY TO PR-POLN-INV-QTY-2
010191          ELSE
010191          IF THREE-DECIMALS MOVE POLN-INV-QTY TO PR-POLN-INV-QTY-3
010191          ELSE
010191          IF FOUR-DECIMALS MOVE POLN-INV-QTY TO PR-POLN-INV-QTY-4
010191          ELSE
010191          IF FIVE-DECIMALS MOVE POLN-INV-QTY TO PR-POLN-INV-QTY-5.
090606     IF DET-RPT AND LAST-OPTION = 060604
090606        MOVE "  _______  " TO PR-REC-UNDERLINE 
090606        MOVE ZERO          TO PR-POLN-ITEM-PRICE, PR-POLN-EXT-AMT
090606        MOVE POLN-ITEM-BIN TO PR-BIN-LOC.
068400     IF DET-RPT 
068500         PERFORM PRINT-DETAIL.
068600     PERFORM ADD-TOTALS.
068700     PERFORM READ-POLNF-NEXT. 
068800
052093 MOVE-POLN-ORDER-QTY.
010191     IF NO-DECIMALS MOVE POLN-ORDER-QTY TO PR-POLN-ORDER-QTY .
010191     IF ONE-DECIMAL MOVE POLN-ORDER-QTY TO PR-POLN-ORDER-QTY-1.
010191     IF TWO-DECIMALS MOVE POLN-ORDER-QTY TO PR-POLN-ORDER-QTY-2.
010191     IF THREE-DECIMALS MOVE POLN-ORDER-QTY TO PR-POLN-ORDER-QTY-3.
010191     IF FOUR-DECIMALS MOVE POLN-ORDER-QTY TO PR-POLN-ORDER-QTY-4.
010191     IF FIVE-DECIMALS MOVE POLN-ORDER-QTY TO PR-POLN-ORDER-QTY-5.
068900 ADD-TOTALS.
069000     ADD POLN-ORDER-QTY TO TOT-ORDER-QTY, FT-ORDER-QTY. 
069100     ADD POLN-REC-QTY TO TOT-REC-QTY, FT-REC-QTY. 
069200     ADD POLN-INV-QTY TO TOT-INV-QTY, FT-INV-QTY. 
069300     ADD POLN-EXT-AMT TO TOT-EXT-AMT. 
069400     ADD POLN-EXT-AMT TO FT-EXT-AMT.
110899     IF ATHENS    AND FREIGHT AND PO-INV-STATUS
110899        SUBTRACT POLN-EXT-AMT FROM TOT-EXT-AMT, FT-EXT-AMT.
069500     IF NOT SPC-ITEM
069600         ADD 1 TO FT-ITEMS. 
069700
069800 MOVE-TOTALS. 
010191     IF NO-DECIMALS MOVE TOT-ORDER-QTY TO TS-ORDER-QTY
010191     ELSE IF ONE-DECIMAL MOVE TOT-ORDER-QTY TO TS-ORDER-QTY-1
010191     ELSE IF TWO-DECIMALS MOVE TOT-ORDER-QTY TO TS-ORDER-QTY-2
010191     ELSE IF THREE-DECIMALS MOVE TOT-ORDER-QTY TO TS-ORDER-QTY-3
010191     ELSE IF FOUR-DECIMALS MOVE TOT-ORDER-QTY TO TS-ORDER-QTY-4
010191     ELSE IF FIVE-DECIMALS MOVE TOT-ORDER-QTY TO TS-ORDER-QTY-5.
070000     IF NOT BATCH-LIST
010191         PERFORM MOVE-TS-REC-QTY
010191         PERFORM MOVE-TS-INV-QTY.
070300     MOVE TOT-EXT-AMT TO TS-EXT-AMT.
070400     MOVE 0 TO TOT-ORDER-QTY, TOT-REC-QTY, TOT-INV-QTY, 
070500       TOT-EXT-AMT. 
070600     IF DET-RPT 
070700         PERFORM PRINT-TOTALS.

010191 MOVE-TS-REC-QTY.
010191     IF NO-DECIMALS MOVE TOT-REC-QTY TO TS-REC-QTY
010191     ELSE IF ONE-DECIMAL MOVE TOT-REC-QTY TO TS-REC-QTY-1
010191     ELSE IF TWO-DECIMALS MOVE TOT-REC-QTY TO TS-REC-QTY-2
010191     ELSE IF THREE-DECIMALS MOVE TOT-REC-QTY TO TS-REC-QTY-3
010191     ELSE IF FOUR-DECIMALS MOVE TOT-REC-QTY TO TS-REC-QTY-4
010191     ELSE IF FIVE-DECIMALS MOVE TOT-REC-QTY TO TS-REC-QTY-5.

010191 MOVE-TS-INV-QTY.
010191     IF NO-DECIMALS MOVE TOT-INV-QTY TO TS-INV-QTY
010191     ELSE IF ONE-DECIMAL MOVE TOT-INV-QTY TO TS-INV-QTY-1
010191     ELSE IF TWO-DECIMALS MOVE TOT-INV-QTY TO TS-INV-QTY-2
010191     ELSE IF THREE-DECIMALS MOVE TOT-INV-QTY TO TS-INV-QTY-3
010191     ELSE IF FOUR-DECIMALS MOVE TOT-INV-QTY TO TS-INV-QTY-4
010191     ELSE IF FIVE-DECIMALS MOVE TOT-INV-QTY TO TS-INV-QTY-5.
070800
070900 PRINT-REPORT-HEADERS.
071000     ADD 2 TO LINE-NO.
090606     IF LAST-OPTION = 060604
090606        MOVE PR-HEADER3-MEI TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT
                  AFTER ADVANCING 1 LINE
090606     ELSE
071100        MOVE PR-HEADER3 TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINE.
071200     MOVE SPACES TO PRINT-REC.
070907               PERFORM PF-REC-CHECK
071300     WRITE PFRPT AFTER ADVANCING 1 LINE.
071400
071500 PRINT-PUR-ORDER-HEADER.
071600     MOVE PR-HEADER2 TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINE.
041498     MOVE PR-HEADER2A TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINE.
071700     MOVE PR-DETAIL1 TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINES. 
071800     MOVE PR-DETAIL2 TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINE.
071900     MOVE PR-DETAIL3 TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINE.
072000     MOVE PR-DETAIL4 TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINE.
072100     MOVE PR-DETAIL5 TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 2 LINES. 
072200     MOVE PR-DETAIL6 TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINE.
072300     IF POHD-STATUS-CD = 2 OR POHD-STATUS-CD = 4
072400         MOVE PR-DETAIL5A TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 2 LINES 
072500         MOVE PR-DETAIL6A TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINE
072600         ADD 3 TO LINE-NO.
072700     MOVE SPACES TO PRINT-REC.
070907               PERFORM PF-REC-CHECK
072800     WRITE PFRPT AFTER ADVANCING 2 LINES. 
072900     ADD 11 TO LINE-NO. 
073000
073100 PRINT-REPORT-DETAIL. 
073200     ADD SKIP TO LINE-NO. 
073300     MOVE PR-DETAIL7 TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING SKIP LINES.
073400     MOVE SPACES TO PR-DETAIL7. 
110393     PERFORM PROCESS-SERIAL-NUMBERS THRU
                   PROCESS-SERIAL-NUMBERS-EXIT.
073500
073600 PO010-REPORT-EXIT. EXIT. 

110393 PROCESS-SERIAL-NUMBERS SECTION.
110393 PROCESS-SERIAL-NUMBERS-START.

110393     MOVE POLNF-KEY TO SREC-PO-KEY.
110393     MOVE SPACES    TO SREC-SERIAL-NO.
110393     PERFORM START-SRECF-GREATER.
CLNUP1     IF C-RECORD-OK OF SRECF-STATUS
110393        PERFORM READ-SRECF-NEXT.
110393     MOVE 1 TO CNT.
110393     MOVE SPACES TO PR-SERIAL-NO-A, PR-SERIAL-NO-B.

       SERIAL-NUMBER-LOOP.
110393        IF C-AT-END OF SRECF-STATUS
110393           PERFORM PRINT-DETAIL8
110393           GO TO PROCESS-SERIAL-NUMBERS-EXIT.

110393        IF CNT = 1
110393           MOVE SREC-NUMBER TO PR-SERIAL-NO-A
110393           ADD 1 TO CNT
110393        ELSE
110393           MOVE SREC-NUMBER TO PR-SERIAL-NO-B
110393           MOVE 1 TO CNT
110393           PERFORM PRINT-DETAIL8.

110393     PERFORM READ-SRECF-NEXT.
110393     GO TO SERIAL-NUMBER-LOOP.

       PRINT-DETAIL8.
110393     IF PR-SERIAL-NO-A NOT = SPACES
110393        PERFORM PAGE-CHECK
110393        ADD 1 TO LINE-NO 
110393        MOVE PR-DETAIL8 TO PRINT-REC
070907               PERFORM PF-REC-CHECK
              WRITE PFRPT AFTER ADVANCING 1 LINES
110393        MOVE 1 TO CNT
110393        MOVE SPACES TO PR-SERIAL-NO-A, PR-SERIAL-NO-B.
           
110393       
110393 PROCESS-SERIAL-NUMBERS-EXIT. EXIT.

073700
060889     COPY "PFPRINT.SR".
073800
073900 IN-OUT SECTION.
074000 OPEN-POHDF.
041498     IF (ATHENS    AND OPEN-LIST)
041498        OPEN I-O POHDF
041498     ELSE
074100        OPEN INPUT  POHDF. 
074200 OPEN-POLNF.
074300     OPEN INPUT  POLNF. 
110393 OPEN-SRECF.
110393     OPEN INPUT  SRECF. 
071409*OPEN-MUCTF.
040496*    MOVE CNTL-TP-DIRECTORY TO MUCT-DIRECTORY.
040496*    MOVE CNTL-TP-DRIVE TO MUCT-DRIVE.
071409*    MOVE SPACES TO MUCT-FILENAME.
071409*    STRING CNTL-TP-DRIVE      DELIMITED BY SIZE,
071409*           ":"                DELIMITED BY SIZE,
071409*           MASTER-DIR         DELIMITED BY SPACE
071409*           "\"                DELIMITED BY SIZE
071409*           CNTL-TP-DIRECTORY  DELIMITED BY SPACE
071409*           "\"                DELIMITED BY SIZE
071409*           "MUCNTL.FIL"       DELIMITED BY SIZE
071409*           INTO MUCT-FILENAME.
071409*    OPEN INPUT MUCTF.
022796 OPEN-STYLF.
040496*    MOVE CNTL-TP-DIRECTORY TO STYL-DIRECTORY.
040496*    MOVE CNTL-TP-DRIVE TO STYL-DRIVE.
040496     MOVE SPACES TO STYLE-FILENAME.
040496     STRING CNTL-TP-DRIVE      DELIMITED BY SIZE,
040496            ":"                DELIMITED BY SIZE,
040496            MASTER-DIR         DELIMITED BY SPACE
040496            "\"                DELIMITED BY SIZE
040496            CNTL-TP-DIRECTORY  DELIMITED BY SPACE
040496            "\"                DELIMITED BY SIZE
040496            "STYLEHDR.FIL"     DELIMITED BY SIZE
040496            INTO STYLE-FILENAME.
022796     OPEN INPUT  STYLF.
022796 OPEN-COLRF.
022796     OPEN INPUT  COLRF.
030901 OPEN-INVBF.
030901     OPEN INPUT  INVBF.
074400
074700 START-POHDF. 
074800     MOVE LOW-KEY TO POHDF-KEY. 
074900     START POHDF KEY NOT < POHDF-KEY
075000         INVALID KEY MOVE AT-END TO POHDF-STATUS. 
075100 START-POLNF-GREATER. 
075200     START POLNF KEY > POLNF-KEY
075300         INVALID KEY MOVE AT-END TO POLNF-STATUS. 
110393 START-SRECF-GREATER. 
110393     START SRECF KEY > SREC-PO-KEY
110393         INVALID KEY MOVE AT-END TO SRECF-STATUS. 
075400 READ-POHDF-NEXT. 
075500     PERFORM WITH TEST AFTER UNTIL RECORD-LOCK NOT EQUAL 
CLNUP1      POHDF-STATUS OR IO-WAIT-OFF 
           READ POHDF NEXT
075600         AT END MOVE AT-END TO POHDF-STATUS
           END-READ END-PERFORM.
031601     DISPLAY SCR-po010-cbl-1359-20  .
075700     IF RES-SELECTIVE AND NOT C-AT-END OF POHDF-STATUS 
075800         IF OPEN-ONLY 
075900             IF POHD-STATUS-CD NOT = 1
076000                 GO TO READ-POHDF-NEXT
076100             ELSE NEXT SENTENCE 
076200         ELSE IF POHD-STATUS-CD = 1 
076300                 GO TO READ-POHDF-NEXT. 
076400 READ-POLNF-NEXT. 
076500     PERFORM WITH TEST AFTER UNTIL RECORD-LOCK NOT EQUAL 
CLNUP1      POLNF-STATUS OR IO-WAIT-OFF 
           READ POLNF NEXT
076600         AT END MOVE AT-END TO POLNF-STATUS
           END-READ END-PERFORM.
076700     IF NOT C-AT-END OF POLNF-STATUS 
076800         IF POLN-PO-NO NOT = POHD-PO-NO 
076900             MOVE AT-END TO POLNF-STATUS. 
101201     IF NOT C-AT-END OF POLNF-STATUS
101201        IF POHD-CREDIT-MEMO
101201           COMPUTE POLN-ORDER-QTY = POLN-ORDER-QTY * -1
101201           COMPUTE POLN-REC-QTY   = POLN-REC-QTY * -1
101201           COMPUTE POLN-INV-QTY   = POLN-INV-QTY * -1
101201           COMPUTE POLN-EXT-AMT   = POLN-EXT-AMT * -1 .


110393 READ-SRECF-NEXT. 
076500     PERFORM WITH TEST AFTER UNTIL RECORD-LOCK NOT EQUAL 
CLNUP1      SRECF-STATUS OR IO-WAIT-OFF 
           READ SRECF NEXT
076600         AT END MOVE AT-END TO SRECF-STATUS
           END-READ END-PERFORM.
076700     IF NOT C-AT-END OF SRECF-STATUS 
076800         IF SREC-PO-NO-GRP NOT = POLNF-KEY 
076900             MOVE AT-END TO SRECF-STATUS. 
077000 READ-POHDF.
077100     PERFORM WITH TEST AFTER UNTIL RECORD-LOCK NOT EQUAL 
CLNUP1      POHDF-STATUS OR IO-WAIT-OFF 
           READ POHDF INVALID KEY 
077200         MOVE SPACES TO POHDF-REC
           END-READ END-PERFORM.
022701 READ-INVBF-NEXT.
093200     PERFORM WITH TEST AFTER UNTIL RECORD-LOCK NOT EQUAL 
CLNUP1      INVBF-STATUS OR IO-WAIT-OFF 
           READ INVBF NEXT
093300         AT END MOVE AT-END TO INVBF-STATUS
           END-READ END-PERFORM.
022701 START-INVBF.
022701     START INVBF KEY NOT < INVBF-KEY
022701         INVALID KEY MOVE AT-END TO INVBF-STATUS.
022796 READ-STYLF.
022796     PERFORM WITH TEST AFTER UNTIL RECORD-LOCK NOT EQUAL 
CLNUP1      STYLF-STATUS OR IO-WAIT-OFF 
           READ STYLF INVALID KEY
022796         MOVE NOT-FOUND TO STYLF-STATUS
           END-READ END-PERFORM.
071409*READ-MUCTF.
071409*    PERFORM WITH TEST AFTER UNTIL RECORD-LOCK NOT EQUAL 
071409*     MUCTF-STATUS OR IO-WAIT-OFF 
071409*    READ MUCTF INVALID KEY
071409*        MOVE NOT-FOUND TO MUCTF-STATUS
071409*    END-READ END-PERFORM.
022796 READ-COLRF.
022796     PERFORM WITH TEST AFTER UNTIL RECORD-LOCK NOT EQUAL 
CLNUP1      COLRF-STATUS OR IO-WAIT-OFF 
           READ COLRF INVALID KEY
022796         MOVE NOT-FOUND TO COLRF-STATUS
           END-READ END-PERFORM.
041498 REWRITE-POHDF.
041498     REWRITE POHDF-REC.
077300 CLOSE-FILES. 
077400     CLOSE POHDF. 
077500     CLOSE POLNF. 
022796     CLOSE STYLF.
071409*    CLOSE MUCTF.
071409     IF PROFITS-APPAREL-YES
              CLOSE SCATF
071409     END-IF.
022796     CLOSE COLRF.
077700 IN-OUT-EXIT. EXIT. 
071409     COPY "APPARELD.SR".
       FILENAMES SECTION.
       FILL-PATHS.
            MOVE SPACES TO TEMP-SUB-DIR.
            STRING SUB-DIR DELIMITED BY LOW-VALUES INTO TEMP-SUB-DIR.
            PERFORM CNTLF-FILL-FULLPATH.
            PERFORM EXCNF-FILL-FULLPATH.
            PERFORM COLRF-FILL-FULLPATH.
            PERFORM POHDF-FILL-FULLPATH.
            PERFORM POLNF-FILL-FULLPATH.
            PERFORM SRECF-FILL-FULLPATH.
            PERFORM INVBF-FILL-FULLPATH.
071409      PERFORM SCATF-FILL-FULLPATH.
071409 SCATF-FILL-FULLPATH.
            MOVE SPACES TO TEMP-MASTER-DIR.
            STRING MASTER-DIR DELIMITED BY LOW-VALUES INTO 
            TEMP-MASTER-DIR.
            MOVE SPACES TO SCATF-FULLPATH.
            STRING TEMP-MASTER-DIR "\" TEMP-SUB-DIR "\" SCATF--NAME 
            DELIMITED BY SPACES INTO SCATF-FULLPATH.
       CNTLF-FILL-FULLPATH.
            MOVE SPACES TO TEMP-MASTER-DIR.
            STRING MASTER-DIR DELIMITED BY LOW-VALUES INTO 
            TEMP-MASTER-DIR.
            MOVE SPACES TO CNTLF-FULLPATH.
            STRING TEMP-MASTER-DIR "\" TEMP-SUB-DIR "\" CNTLF--NAME 
            DELIMITED BY SPACES INTO CNTLF-FULLPATH.
       EXCNF-FILL-FULLPATH.
            MOVE SPACES TO TEMP-MASTER-DIR.
            STRING MASTER-DIR DELIMITED BY LOW-VALUES INTO 
            TEMP-MASTER-DIR.
            MOVE SPACES TO EXCNF-FULLPATH.
            STRING TEMP-MASTER-DIR "\" TEMP-SUB-DIR "\" EXCNF--NAME 
            DELIMITED BY SPACES INTO EXCNF-FULLPATH.
       USERF-FILL-FULLPATH.
            MOVE SPACES TO TEMP-MASTER-DIR.
            STRING MASTER-DIR DELIMITED BY LOW-VALUES INTO 
            TEMP-MASTER-DIR.
            MOVE SPACES TO USERF-FULLPATH.
            STRING TEMP-MASTER-DIR "\" USERF--NAME DELIMITED BY SPACES 
            INTO USERF-FULLPATH.
       COLRF-FILL-FULLPATH.
            MOVE SPACES TO TEMP-MASTER-DIR.
            STRING MASTER-DIR DELIMITED BY LOW-VALUES INTO 
            TEMP-MASTER-DIR.
            MOVE SPACES TO COLRF-FULLPATH.
            STRING TEMP-MASTER-DIR "\" TEMP-SUB-DIR "\" COLRF--NAME 
            DELIMITED BY SPACES INTO COLRF-FULLPATH.
       POHDF-FILL-FULLPATH.
            MOVE SPACES TO TEMP-MASTER-DIR.
            STRING MASTER-DIR DELIMITED BY LOW-VALUES INTO 
            TEMP-MASTER-DIR.
            MOVE SPACES TO POHDF-FULLPATH.
            STRING TEMP-MASTER-DIR "\" TEMP-SUB-DIR "\" POHDF--NAME 
            DELIMITED BY SPACES INTO POHDF-FULLPATH.
       POLNF-FILL-FULLPATH.
            MOVE SPACES TO TEMP-MASTER-DIR.
            STRING MASTER-DIR DELIMITED BY LOW-VALUES INTO 
            TEMP-MASTER-DIR.
            MOVE SPACES TO POLNF-FULLPATH.
            STRING TEMP-MASTER-DIR "\" TEMP-SUB-DIR "\" POLNF--NAME 
            DELIMITED BY SPACES INTO POLNF-FULLPATH.
       SRECF-FILL-FULLPATH.
            MOVE SPACES TO TEMP-MASTER-DIR.
            STRING MASTER-DIR DELIMITED BY LOW-VALUES INTO 
            TEMP-MASTER-DIR.
            MOVE SPACES TO SRECF-FULLPATH.
            STRING TEMP-MASTER-DIR "\" TEMP-SUB-DIR "\" SRECF--NAME 
            DELIMITED BY SPACES INTO SRECF-FULLPATH.
       INVBF-FILL-FULLPATH.
            MOVE SPACES TO TEMP-MASTER-DIR.
            STRING MASTER-DIR DELIMITED BY LOW-VALUES INTO 
            TEMP-MASTER-DIR.
            MOVE SPACES TO INVBF-FULLPATH.
            STRING TEMP-MASTER-DIR "\" TEMP-SUB-DIR "\" INVBF--NAME 
            DELIMITED BY SPACES INTO INVBF-FULLPATH.
       CHAINCALLS SECTION.
       CHN--PARM-BLOCK.
            COPY "CHAIN.CBL" REPLACING ==PARAM-BLOCK== BY ==PARM-BLOCK==
            .

       CHN--PARM-BLK.
            COPY "CHAIN.CBL" REPLACING ==PARAM-BLOCK== BY ==PARM-BLK==.

       CHNR--WS-PASSED.
            COPY "CHAINR.CBL" REPLACING ==PARAM-BLOCK== BY ==WS-PASSED==
            .

       CHNR--PARM-BLOCK-DOS-RET-CODE.
            COPY "CHAINR.CBL" REPLACING ==PARAM-BLOCK== BY 
            ==PARM-BLOCK== ==RETURN-CD== BY ==DOS-RET-CODE==.

       SCRN-TEST SECTION.
            COPY "STEST.SR".
CLNUP1*STEST-errorfil-sr-46.
CLNUP1*     MOVE "   po010.cbl  errorfil.sr   46" TO STEST-KEY.
CLNUP1*     MOVE ERROR-FIELD TO STEST-SCRN-SPECS.
CLNUP1*     MOVE FUNCTION ADDR(ERROR-FIELD) TO STEST-PTR.
CLNUP1*     PERFORM STEST-BEGIN.
CLNUP1*     COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
CLNUP1*     = FUNCTION LENG (FLAG).
CLNUP1*     MOVE 4 TO STEST-PARAM-W-SIZE OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     MOVE "FLAG" TO STEST-PARAM-NAME OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     PERFORM STEST-PARAM-CHECK.
CLNUP1*     COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
CLNUP1*     = FUNCTION LENG (FKEYS).
CLNUP1*     MOVE 10 TO STEST-PARAM-W-SIZE OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     MOVE "FKEYS" TO STEST-PARAM-NAME OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     PERFORM STEST-PARAM-CHECK.
CLNUP1*     COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
CLNUP1*     = FUNCTION LENG (ERROR-FIELD).
CLNUP1*     MOVE 14 TO STEST-PARAM-W-SIZE OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     MOVE "ERROR-FIELD" TO STEST-PARAM-NAME OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     PERFORM STEST-PARAM-CHECK.
CLNUP1*     PERFORM STEST-SKIP.
CLNUP1*     COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
CLNUP1*     = FUNCTION LENG (ERROR-ANSWER).
CLNUP1*     MOVE FLEN OF STEST-SPECS (1) TO STEST-PARAM-W-SIZE OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     MOVE "ERROR-ANSWER" TO STEST-PARAM-NAME OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     PERFORM STEST-PARAM-CHECK.
CLNUP1*     PERFORM STEST-FINAL.
CLNUP1*STEST-print-sr-148.
CLNUP1*     MOVE "   po010.cbl     print.sr  148" TO STEST-KEY.
CLNUP1*     MOVE PAUSE-SPECS TO STEST-SCRN-SPECS.
CLNUP1*     MOVE FUNCTION ADDR(PAUSE-SPECS) TO STEST-PTR.
CLNUP1*     PERFORM STEST-BEGIN.
CLNUP1*     COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
CLNUP1*     = FUNCTION LENG (FLAG).
CLNUP1*     MOVE 4 TO STEST-PARAM-W-SIZE OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     MOVE "FLAG" TO STEST-PARAM-NAME OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     PERFORM STEST-PARAM-CHECK.
CLNUP1*     COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
CLNUP1*     = FUNCTION LENG (FKEYS).
CLNUP1*     MOVE 10 TO STEST-PARAM-W-SIZE OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     MOVE "FKEYS" TO STEST-PARAM-NAME OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     PERFORM STEST-PARAM-CHECK.
CLNUP1*     COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
CLNUP1*     = FUNCTION LENG (PAUSE-SPECS).
CLNUP1*     MOVE 14 TO STEST-PARAM-W-SIZE OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     MOVE "PAUSE-SPECS" TO STEST-PARAM-NAME OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     PERFORM STEST-PARAM-CHECK.
CLNUP1*     PERFORM STEST-SKIP.
CLNUP1*     COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
CLNUP1*     = FUNCTION LENG (ABORT-CONTINUE).
CLNUP1*     MOVE FLEN OF STEST-SPECS (1) TO STEST-PARAM-W-SIZE OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     MOVE "ABORT-CONTINUE" TO STEST-PARAM-NAME OF 
CLNUP1*     STEST-PARAMS (STEST-PARAM-NUM).
CLNUP1*     PERFORM STEST-PARAM-CHECK.
CLNUP1*     PERFORM STEST-FINAL.
       STEST-po010-cbl-723.
            MOVE "   po010.cbl               723" TO STEST-KEY.
            MOVE INPUT-SPECS-2 TO STEST-SCRN-SPECS.
            MOVE FUNCTION ADDR(INPUT-SPECS-2) TO STEST-PTR.
            PERFORM STEST-BEGIN.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (FLAG).
            MOVE 4 TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "FLAG" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (FKEYS).
            MOVE 10 TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "FKEYS" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (INPUT-SPECS-2).
            MOVE 14 TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "INPUT-SPECS-2" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            PERFORM STEST-SKIP.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (FORM-TYPES).
            MOVE FLEN OF STEST-SPECS (1) TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "FORM-TYPES" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            PERFORM STEST-FINAL.
       STEST-po010-cbl-751.
            MOVE "   po010.cbl               751" TO STEST-KEY.
            MOVE BATCH-SPECS TO STEST-SCRN-SPECS.
            MOVE FUNCTION ADDR(BATCH-SPECS) TO STEST-PTR.
            PERFORM STEST-BEGIN.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (FLAG).
            MOVE 4 TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "FLAG" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (FKEYS).
            MOVE 10 TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "FKEYS" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (BATCH-SPECS).
            MOVE 14 TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "BATCH-SPECS" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            PERFORM STEST-SKIP.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (USER-BATCH-NO).
            MOVE FLEN OF STEST-SPECS (1) TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "USER-BATCH-NO" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            PERFORM STEST-FINAL.
      * STEST-po010-cbl-782.
      *      MOVE "   po010.cbl               782" TO STEST-KEY.
      *      MOVE RANGE-SPECS-1 TO STEST-SCRN-SPECS.
      *      MOVE FUNCTION ADDR(RANGE-SPECS-1) TO STEST-PTR.
      *      PERFORM STEST-BEGIN.
      *      COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
      *      = FUNCTION LENG (FLAG).
      *      MOVE 4 TO STEST-PARAM-W-SIZE OF 
      *      STEST-PARAMS (STEST-PARAM-NUM).
      *      MOVE "FLAG" TO STEST-PARAM-NAME OF 
      *      STEST-PARAMS (STEST-PARAM-NUM).
      *      PERFORM STEST-PARAM-CHECK.
      *      COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
      *      = FUNCTION LENG (FKEYS).
      *      MOVE 10 TO STEST-PARAM-W-SIZE OF 
      *      STEST-PARAMS (STEST-PARAM-NUM).
      *      MOVE "FKEYS" TO STEST-PARAM-NAME OF 
      *      STEST-PARAMS (STEST-PARAM-NUM).
      *      PERFORM STEST-PARAM-CHECK.
      *      COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
      *      = FUNCTION LENG (RANGE-SPECS-1).
      *      MOVE 14 TO STEST-PARAM-W-SIZE OF 
      *      STEST-PARAMS (STEST-PARAM-NUM).
      *      MOVE "RANGE-SPECS-1" TO STEST-PARAM-NAME OF 
      *      STEST-PARAMS (STEST-PARAM-NUM).
      *      PERFORM STEST-PARAM-CHECK.
      *      PERFORM STEST-SKIP.
      *      COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
      *      = FUNCTION LENG (RANGE-CODES).
      *      MOVE FLEN OF STEST-SPECS (1) TO STEST-PARAM-W-SIZE OF 
      *      STEST-PARAMS (STEST-PARAM-NUM).
      *      MOVE "RANGE-CODES" TO STEST-PARAM-NAME OF 
      *      STEST-PARAMS (STEST-PARAM-NUM).
      *      PERFORM STEST-PARAM-CHECK.
      *      PERFORM STEST-FINAL.
       STEST-po010-cbl-809.
            MOVE "   po010.cbl               809" TO STEST-KEY.
            MOVE RANGE-SPECS-2 TO STEST-SCRN-SPECS.
            MOVE FUNCTION ADDR(RANGE-SPECS-2) TO STEST-PTR.
            PERFORM STEST-BEGIN.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (FLAG).
            MOVE 4 TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "FLAG" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (FKEYS).
            MOVE 10 TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "FKEYS" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (RANGE-SPECS-2).
            MOVE 28 TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "RANGE-SPECS-2" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            PERFORM STEST-SKIP.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (LOW-KEY).
            MOVE FLEN OF STEST-SPECS (1) TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "LOW-KEY" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (HIGH-KEY).
            MOVE FLEN OF STEST-SPECS (2) TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "HIGH-KEY" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            PERFORM STEST-FINAL.
       STEST-po010-cbl-842.
            MOVE "   po010.cbl               842" TO STEST-KEY.
            MOVE RANGE-SPECS-3 TO STEST-SCRN-SPECS.
            MOVE FUNCTION ADDR(RANGE-SPECS-3) TO STEST-PTR.
            PERFORM STEST-BEGIN.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (FLAG).
            MOVE 4 TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "FLAG" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (FKEYS).
            MOVE 10 TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "FKEYS" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (RANGE-SPECS-3).
            MOVE 14 TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "RANGE-SPECS-3" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            PERFORM STEST-SKIP.
            COMPUTE STEST-PARAM-SIZE OF STEST-PARAMS (STEST-PARAM-NUM)
            = FUNCTION LENG (ORDER-NUMBER).
            MOVE FLEN OF STEST-SPECS (1) TO STEST-PARAM-W-SIZE OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            MOVE "ORDER-NUMBER" TO STEST-PARAM-NAME OF 
            STEST-PARAMS (STEST-PARAM-NUM).
            PERFORM STEST-PARAM-CHECK.
            PERFORM STEST-FINAL.
