       IDENTIFICATION   DIVISION.
       PROGRAM-ID.      EW031.
       AUTHOR.          DOE.
      *****************************************************************
      *            COST AS A PERCENTAGE OF REVENUE (CAPOR)            *
      *****************************************************************
      * DATE CREATED:   06/27/95                                      *
      *****************************************************************
      * CALL #  - MMDDYY - PURPOSE                                    *
      * 9508024 -        - THE PREP COST FIELDS WILL ALWAYS BE ZEROS. *
      * 9508074 -        - THE DRC FILE WAS ENLARGED.                 *
      * 9511053 - 112895 - FIXED SPACING AND COLUMN HEADINGS.         *
      * 9512028 - 120895 - IF PGM NOT DEFINE, SHOW SPACE AS VALID RNGE*
      * FIX9711 - 041397 - CORRECT HEADER AND DISTRIBUTION OF CRD AMTS*
      * FIX9903 - 040599 - CHG FEFP PGMS                              *
      * FIX0001 - 051100 - SKIP CHARTER SCHOOL RECORDS(FORM 7)        *
      * FIX???  - 101500 - SKIP DRC PGMS WITH 0 REVENUE               *
      * 2001001 - 033001 - DON'T ROLL PROGRAMS 251 -> 255 INTO PGM    *
      *                    250.                                       *
      * 2001002 - 040401 - TRUNCATE RWF AMT FIELDS TO ADJUST THE      *
      *                    ROUNDING TO MATCH THE STATE.               *
      * 2001003 - 040401 - MODIFIED TO NOT ADD FUNCTIONS FOR FOOD     *
      *                    SERVICE AND TRANSPORTATION TO INDIRECT     *
      *                    AND DIRECT COSTS.  THOSE FIGURES COME      *
      *                    VIA THE REQUEST CARD.                      *
      * 2001004 - 091201 - FIXED FIELD SIZE PROBLEM ON REVENUE.       *
      * 2002001 - 050102 - MODIFIED TO NOT ADD FOOD SERVICE AND TRANS-*
      *                    PORTATION COSTS TO ANY ADULT ED PGMS.      *
      * 2003001 - 041103 - FIXED REPORT SEQUENCE TOTALS SOMETIMES     *
      *                    PRINTING INFORMATION FROM THE PREVIOUS     *
      *                    DETAIL LINE.                               *
      * 2003002 - 042903 - EXPAND FIELD SIZES TO SHOW Z(10).          *
      * 2006001 - 041006 - SHOW XX,XXX IF COST PER FTE (LN1STDT)      *
      *                    EXCEEDS $99,999. XX,XXX INDICATES MAX SIZE *
      *                    OF FIELD HAS BEEN EXCEEDED.                *
      * 2006002 - 042006 - ADD FUNCTIONS 6500 & 8200.                 *
      *****************************************************************


       ENVIRONMENT DIVISION.

       INPUT-OUTPUT SECTION.
       FILE-CONTROL.

           SELECT    CRD-CARD          ASSIGN       DATABASE-EWCRDI.           1
                                                                               0
           SELECT    SRT-SORT          ASSIGN       WORKSTATION-SORT.

           SELECT    PR1-PRNT          ASSIGN       PRINTER-EWPRT01.

           SELECT    CRF-DISK          ASSIGN       DATABASE-EWCRFI
                                       ORGANIZATION INDEXED
                                       ACCESS       DYNAMIC
                                       RECORD KEY   CRFDK
                                       FILE STATUS  RETCRF.

           SELECT    RWF-DISK          ASSIGN       DATABASE-EWRWFI
                                       ORGANIZATION INDEXED
                                       ACCESS       SEQUENTIAL
                                       RECORD KEY   RWFDK
                                       FILE STATUS  RETRWF.

           SELECT    ABF-DISK          ASSIGN       DATABASE-EWABFI
                                       ORGANIZATION INDEXED
                                       ACCESS       DYNAMIC
                                       RECORD KEY   ABFDK
                                       FILE STATUS  RETABF.

           SELECT    DRC-DISK          ASSIGN       DATABASE-EWDRCI
                                       ORGANIZATION SEQUENTIAL
                                       ACCESS       SEQUENTIAL
                                       FILE STATUS  RETDRC.

           SELECT    DRC-TAPE          ASSIGN       TAPEFILE-EWTAP01
                                       ORGANIZATION SEQUENTIAL
                                       ACCESS       SEQUENTIAL
                                       FILE STATUS  RETDRCT.

       DATA DIVISION.
       FILE SECTION.

       FD  CRD-CARD
           RECORD    CONTAINS   80  CHARACTERS
           LABEL     RECORDS   ARE  OMITTED
           DATA      RECORDS   ARE  CRD  CRH.

       01            CRD.
001        05        CRDREQ            PIC  X(03).
004        05        FILLER            PIC  X(01).
005        05        CRDID             PIC  X(02).
007        05        FILLER            PIC  X(01).
008        05        CRDPRT            PIC  X(01).
009        05        FILLER            PIC  X(01).
010        05        CRDDIST           PIC  X(02).
012        05        FILLER            PIC  X(01).
013        05        CRDFY             PIC  X(02).
016        05        CRDFUND           PIC  X(01).
017        05        CRDSCHL           PIC  X(04).
021        05        CRDFSRV           PIC  9(09).
030        05        CRDTSCHL          PIC  9(09).
039        05        CRDTDIST          PIC  9(09).
048        05        CRDPREPD          PIC  9(09).
057        05        CRDPREPS          PIC  9(09).
066        05        CRDPREPT          PIC  9(09).
075        05        CRDSRC            PIC  X(01).
075        05        CRDRPT            PIC  X(01).
076        05        CRDPGM            PIC  X(05).

       01            CRH.
001        05        CRHREQ            PIC  X(03).
004        05        FILLER            PIC  X(01).
005        05        CRHID             PIC  X(02).
007        05        FILLER            PIC  X(01).
008        05        CRHUSER           PIC  X(08).
016        05        FILLER            PIC  X(01).
           05        CRHHEAD.
017          10      CRHB       OCCURS 050  TIMES  INDEXED BY CRH1
                                       PIC  X(01).
067        05        FILLER            PIC  X(14).

       FD  PR1-PRNT
           RECORD    CONTAINS  132  CHARACTERS
           LABEL     RECORDS   ARE  OMITTED
           DATA      RECORDS   ARE  LNM  LN1  LN2  LN3.

       01  LNM.
001        05        LNMMSG            PIC  X(20).
021        05        FILLER            PIC  X(02).
023        05        LNMVALUE1         PIC  X(02).
025        05        FILLER            PIC  X(01).
026        05        LNMVALUE2         PIC  X(80).
106        05        FILLER            PIC  X(27).

       01            LN1.
001        05        LN1PGM            PIC  X(03).
004        05        FILLER            PIC  X(01).
005        05        LN1MSG            PIC  X(15).
020        05        FILLER            PIC  X(01).
042903*    05        LN1FTE            PIC  ZZZ,ZZZ.ZZ.
042903     05        LN1FTE            PIC  ZZZZ,ZZZ.ZZ.
031        05        LN1ERR1           PIC  X(01).
042903*    05        FILLER            PIC  X(02).
042903     05        FILLER            PIC  X(01).
042903*    05        LN1DIR            PIC  ZZZ,ZZZ,ZZZ.
042903     05        LN1DIR            PIC  ZZZZ,ZZZ,ZZZ.
045        05        LN1ERR2           PIC  X(01).
042903*    05        FILLER            PIC  X(02).
042903     05        FILLER            PIC  X(01).
042903*    05        LN1SCOST          PIC  ZZZ,ZZZ,ZZZ.
042903     05        LN1SCOST          PIC  ZZZZ,ZZZ,ZZZ.
059        05        LN1ERR3           PIC  X(01).
042903*    05        FILLER            PIC  X(02).
042903     05        FILLER            PIC  X(01).
042903*    05        LN1TCOST          PIC  ZZZ,ZZZ,ZZZ.
042903     05        LN1TCOST          PIC  ZZZZ,ZZZ,ZZZ.
073        05        LN1ERR4           PIC  X(01).
042903*    05        FILLER            PIC  X(02).
042903     05        FILLER            PIC  X(01).
074        05        LN1DPCT           PIC  ZZZ.
077        05        FILLER            PIC  X(01).
078        05        LN1SPCT           PIC  ZZZ.
081        05        FILLER            PIC  X(01).
082        05        LN1TPCT           PIC  ZZZ.
042903*    05        FILLER            PIC  X(03).
042903     05        FILLER            PIC  X(02).
042903*    05        LN1REV            PIC  ZZZ,ZZZ,ZZZ.
042903     05        LN1REV            PIC  ZZZZ,ZZZ,ZZZ.
099        05        LN1ERR5           PIC  X(01).
100        05        LN1STDT           PIC  ZZ,ZZZ.
041006     05        LN1STDT9 REDEFINES LN1STDT.
041006       10      LN1STDT1          PIC  XXXXXX.
106        05        FILLER            PIC  X(01).
107        05        LN1STF            PIC  ZZZ.ZZ.
113        05        FILLER            PIC  X(01).
112895*    05        LN1ERROR          PIC  X(19).
112895     05        LN1ERROR          PIC  X(17).
           05        LN1ERR  REDEFINES LN1ERROR.
112895*      10      LN1CHAR1          PIC  X(03).
112895       10      LN1CHAR1          PIC  X(02).
             10      LN1FRM            PIC  ZZ,ZZZ.
             10      LN1CHAR2          PIC  X(03).
             10      LN1TO             PIC  ZZ,ZZZ.
112895*      10      FILLER            PIC  X(01).

       01            LN2.
001        05        FILLER            PIC  X(04).
005        05        LN2MSG            PIC  X(15).
020        05        FILLER            PIC  X(01).
021        05        LN2FTE            PIC  ZZZ,ZZZ.ZZ.
031        05        FILLER            PIC  X(01).
032        05        LN2DIR            PIC  Z,ZZZ,ZZZ,ZZZ.
045        05        FILLER            PIC  X(01).
046        05        LN2SCOST          PIC  Z,ZZZ,ZZZ,ZZZ.
059        05        FILLER            PIC  X(01).
060        05        LN2TCOST          PIC  Z,ZZZ,ZZZ,ZZZ.
073        05        FILLER            PIC  X(01).
112895     05        FILLER            PIC  X(02).
074        05        LN2DPCT           PIC  ZZZ.
077        05        FILLER            PIC  X(01).
078        05        LN2SPCT           PIC  ZZZ.
081        05        FILLER            PIC  X(01).
082        05        LN2TPCT           PIC  ZZZ.
085        05        FILLER            PIC  X(01).
086        05        LN2REV            PIC  Z,ZZZ,ZZZ,ZZZ.
099        05        FILLER            PIC  X(01).
100        05        LN2STDT           PIC  ZZ,ZZZ.
106        05        FILLER            PIC  X(01).
107        05        LN2STF            PIC  ZZZ.ZZ.
112895*    05        FILLER            PIC  X(20).
112895     05        FILLER            PIC  X(18).

       01            LN3.
001        05        FILLER            PIC  X(04).
005        05        LN3MSG            PIC  X(05).
010        05        LN3FLD            PIC  X(04).
014        05        FILLER            PIC  X(07).
021        05        LN3FTE            PIC  ZZZ,ZZZ.ZZ.
031        05        FILLER            PIC  X(01).
032        05        LN3DIR            PIC  Z,ZZZ,ZZZ,ZZZ.
045        05        FILLER            PIC  X(01).
046        05        LN3SCOST          PIC  Z,ZZZ,ZZZ,ZZZ.
059        05        FILLER            PIC  X(01).
060        05        LN3TCOST          PIC  Z,ZZZ,ZZZ,ZZZ.
073        05        FILLER            PIC  X(01).
112895     05        FILLER            PIC  X(02).
074        05        LN3DPCT           PIC  ZZZ.
077        05        FILLER            PIC  X(01).
078        05        LN3SPCT           PIC  ZZZ.
081        05        FILLER            PIC  X(01).
082        05        LN3TPCT           PIC  ZZZ.
085        05        FILLER            PIC  X(01).
086        05        LN3REV            PIC  Z,ZZZ,ZZZ,ZZZ.
099        05        FILLER            PIC  X(01).
100        05        LN3STDT           PIC  ZZ,ZZZ.
106        05        FILLER            PIC  X(01).
107        05        LN3STF            PIC  ZZZ.ZZ.
112895*    05        FILLER            PIC  X(20).
112895     05        FILLER            PIC  X(18).

           COPY                        EWCRFD             OF   CPYSRC.
           COPY                        EWRWFD             OF   CPYSRC.
           COPY                        EWABFD             OF   CPYSRC.
           COPY                        EWDRCD             OF   CPYSRC.
           COPY                        EWDRCT             OF   CPYSRC.

       SD  SRT-SORT.

       01            SRT.
           05        SRTKEY.
             10      SRTKDIST          PIC  X(02).
             10      SRTKREQ.
               15    SRTKREQ1          PIC  X(01).
               15    SRTKREQ2          PIC  X(01).
               15    SRTKREQ3          PIC  X(01).
             10      SRTKFY.
               15    SRTKFY1           PIC  X(01).
               15    SRTKFY2           PIC  X(01).
             10      SRTKRPT           PIC  X(01).
             10      SRTKSCHL          PIC  X(04).
             10      SRTKSEQ           PIC  X(01).
             10      SRTKPGM           PIC  X(03).
             10      SRTKTYPE          PIC  X(01).
           05        SRTDATA.
             10      SRTDIRECT         PIC  S9(11).
             10      SRTSIND           PIC  S9(11).
             10      SRTDIND           PIC  S9(11).
091201*      10      SRTREV            PIC  S9(07).
091201       10      SRTREV            PIC  S9(08).
             10      SRTFTE            PIC  S9(07)V9(02).
             10      SRTSTAFF          PIC  S9(04)V9(03).
             10      SRTFSRV           PIC  S9(09).
             10      SRTTSCHL          PIC  S9(09).
             10      SRTTDIST          PIC  S9(09).
             10      SRTPREPD          PIC  S9(09).
             10      SRTPREPS          PIC  S9(09).
             10      SRTPREPT          PIC  S9(09).
             10      SRTPRT            PIC  X(01).
             10      SRTSRC            PIC  X(01).

       WORKING-STORAGE SECTION.

       01            WSC.
           05        WSCLAST           PIC  X(01) VALUE 'N'.
           05        WSCRWF            PIC  X(01) VALUE 'N'.
           05        WSCABF            PIC  X(01) VALUE 'N'.
           05        WSCDRC            PIC  X(01) VALUE 'N'.
           05        WSCRC             PIC  X(01) VALUE ' '.
           05        WSCRCT            PIC  X(01) VALUE ' '.
           05        WSCFILE           PIC  X(01) VALUE ' '.
           05        WSCPGM.
             10      WSCP1             PIC  X(01).
             10      FILLER            PIC  X(02).
           05        WSCFRM            PIC S9(05) VALUE ZEROS.
           05        WSCTO             PIC S9(05) VALUE ZEROS.
           05        WSCQUOT           PIC S9(03)V9(09) VALUE ZEROS.
040401     05        WSCTRUNC          PIC S9(11) COMP-3.

       01            TMP.
           05        TEMPPGM           PIC  X(03).
           05        TEMPSEQ           PIC  X(01).

       01            RET.
           05        RETCRF            PIC  X(02) VALUE '00'.
           05        RETCRFOLD         PIC  X(02) VALUE '00'.
           05        RETRWF            PIC  X(02) VALUE '00'.
           05        RETABF            PIC  X(02) VALUE '00'.
           05        RETABFOLD         PIC  X(02) VALUE '00'.
           05        RETDRC            PIC  X(02) VALUE '00'.
           05        RETDRCT           PIC  X(02) VALUE '00'.

       01            SYS.
           05        SYSTIME.
             10      SYSHR             PIC  X(02).
             10      SYSMIN            PIC  X(02).
             10      SYSSEC            PIC  X(02).
           05        SYSDATE.
             10      SYSYY             PIC  9(02).
             10      SYSMM             PIC  X(02).
             10      SYSDD             PIC  X(02).

       01            CTLAREA.
           05        CTLCHAR           PIC  X(01) VALUE ' '.
           05        ERR.
             10      ERRREQ            PIC  X(03).
             10      FILLER            PIC  X(01).
             10      ERRID             PIC  X(02).
             10      FILLER            PIC  X(01).
             10      ERRPRT            PIC  X(01).
             10      FILLER            PIC  X(03).
             10      ERRDIST           PIC  X(02).
             10      FILLER            PIC  X(01).
             10      ERRFY             PIC  X(02).
             10      ERRFUND           PIC  X(01).
             10      ERRSCHL           PIC  X(04).
             10      ERRFSRV           PIC  X(09).
             10      ERRTSCHL          PIC  X(09).
             10      ERRTDIST          PIC  X(09).
             10      ERRPREPD          PIC  X(09).
             10      ERRPREPS          PIC  X(09).
             10      ERRPREPT          PIC  X(09).
             10      ERRSRC            PIC  X(01).
             10      ERRRPT            PIC  X(01).

       01            RQR.
           05        RQRREQ            PIC  X(03).
           05        RQRPRT            PIC  X(01).
           05        RQRDIST           PIC  X(02).
           05        RQRFY             PIC  X(02).
           05        RQRSEL.
             10      RQRSCHL           PIC  X(04).
           05        RQRSELR    REDEFINES   RQRSEL.
             10      RQRB       OCCURS 004  TIMES INDEXED BY RQR1
                                       PIC  X(01).
           05        RQRFSRV           PIC  9(09).
           05        RQRTSCHL          PIC  9(09).
           05        RQRTDIST          PIC  9(09).
           05        RQRPREPD          PIC  9(09).
           05        RQRPREPS          PIC  9(09).
           05        RQRPREPT          PIC  9(09).
           05        RQRSRC            PIC  X(01).
           05        RQRRPT            PIC  X(01).

       01            SEL.
           05        SELSCHL           PIC  X(04).
       01            SELR       REDEFINES   SEL.
           05        SELB       OCCURS 004  TIMES INDEXED BY SEL1
                                       PIC  X(01).

       01            RQH.
           05        RQHENTRY   OCCURS 100  TIMES INDEXED BY RQH1.
             10      RQHREQ            PIC  X(03).
             10      RQHID             PIC  X(02).
             10      RQHUSER           PIC  X(08).
             10      RQHHEAD.
               15    RQHB       OCCURS 050  TIMES INDEXED BY RQH2
                                       PIC  X(01).

       01            PGMTBL.
           05        PGMENTRY   OCCURS 1000 TIMES
                                       ASCENDING KEY IS PGMPGM
                                       INDEXED BY PGM1.
             10      PGMPGM            PIC  X(03).
             10      PGMSEQ            PIC  X(01).
             10      PGMFRM            PIC  S9(05).
             10      PGMTO             PIC  S9(05).

       01            ST1KEY.
           05        ST1DIST           PIC  X(02) VALUE HIGH-VALUES.
           05        ST1FY             PIC  X(02) VALUE HIGH-VALUES.
           05        ST1FUND           PIC  X(01) VALUE HIGH-VALUES.
           05        FILLER            PIC  X(12) VALUE HIGH-VALUES.

       01            EN1KEY.
           05        EN1DIST           PIC  X(02) VALUE LOW-VALUES.
           05        EN1FY             PIC  X(02) VALUE LOW-VALUES.
           05        EN1FUND           PIC  X(01) VALUE LOW-VALUES.
           05        FILLER            PIC  X(12) VALUE LOW-VALUES.

       01            ST2KEY.
           05        ST2DIST           PIC  X(02) VALUE HIGH-VALUES.
           05        ST2FY             PIC  X(02) VALUE HIGH-VALUES.
           05        ST2SCHL           PIC  X(04) VALUE HIGH-VALUES.
           05        FILLER            PIC  X(03) VALUE HIGH-VALUES.

       01            EN2KEY.
           05        EN2DIST           PIC  X(02) VALUE LOW-VALUES.
           05        EN2FY             PIC  X(02) VALUE LOW-VALUES.
           05        EN2SCHL           PIC  X(04) VALUE LOW-VALUES.
           05        FILLER            PIC  X(03) VALUE LOW-VALUES.

       01            CTR.
           05        CTRLN            PIC S9(03)       COMP-3 VALUE +0.
           05        CTRPG            PIC S9(03)       COMP-3 VALUE +0.
           05        CTRIDX           PIC S9(05)       COMP-3 VALUE +0.
           05        CTRCOMP          PIC S9(11)       COMP-3 VALUE +0.
           05        CTRFTETOT        PIC S9(07)V9(02) COMP-3 VALUE +0.
           05        CTRACCUM.
             10      CTRSIND          PIC S9(11)       COMP-3 VALUE +0.
             10      CTRDIND          PIC S9(11)       COMP-3 VALUE +0.
             10      CTRSTF1          PIC S9(04)V9(03) COMP-3 VALUE +0.
           05        CTRLVL1.
             10      CTRLNFTE         PIC S9(07)V9(02) COMP-3 VALUE +0.
             10      CTRLNDIR         PIC S9(09)       COMP-3 VALUE +0.
             10      CTRLNSCOST       PIC S9(09)       COMP-3 VALUE +0.
             10      CTRLNTCOST       PIC S9(09)       COMP-3 VALUE +0.
             10      CTRLNDPCT        PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRLNSPCT        PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRLNTPCT        PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRLNREV         PIC S9(09)       COMP-3 VALUE +0.
041006*      10      CTRLNSTDT        PIC S9(05)       COMP-3 VALUE +0.
041006       10      CTRLNSTDT        PIC S9(09)       COMP-3 VALUE +0.
             10      CTRLNSTF         PIC S9(03)V9(02) COMP-3 VALUE +0.
           05        CTRLVL2.
             10      CTRSQFTE         PIC S9(07)V9(02) COMP-3 VALUE +0.
             10      CTRSQDIR         PIC S9(11)       COMP-3 VALUE +0.
             10      CTRSQSCOST       PIC S9(11)       COMP-3 VALUE +0.
             10      CTRSQTCOST       PIC S9(11)       COMP-3 VALUE +0.
             10      CTRSQDPCT        PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRSQSPCT        PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRSQTPCT        PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRSQREV         PIC S9(11)       COMP-3 VALUE +0.
             10      CTRSQSTDT        PIC S9(05)       COMP-3 VALUE +0.
             10      CTRSQSTF         PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRSTF2          PIC S9(04)V9(03) COMP-3 VALUE +0.
           05        CTRLVL3.
             10      CTRSCFTE         PIC S9(07)V9(02) COMP-3 VALUE +0.
             10      CTRSCDIR         PIC S9(11)       COMP-3 VALUE +0.
             10      CTRSCSCOST       PIC S9(11)       COMP-3 VALUE +0.
             10      CTRSCTCOST       PIC S9(11)       COMP-3 VALUE +0.
             10      CTRSCDPCT        PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRSCSPCT        PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRSCTPCT        PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRSCREV         PIC S9(11)       COMP-3 VALUE +0.
             10      CTRSCSTDT        PIC S9(05)       COMP-3 VALUE +0.
             10      CTRSCSTF         PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRSTF3          PIC S9(04)V9(03) COMP-3 VALUE +0.
           05        CTRLVL4.
             10      CTRRQFTE         PIC S9(07)V9(02) COMP-3 VALUE +0.
             10      CTRRQDIR         PIC S9(11)       COMP-3 VALUE +0.
             10      CTRRQSCOST       PIC S9(11)       COMP-3 VALUE +0.
             10      CTRRQTCOST       PIC S9(11)       COMP-3 VALUE +0.
             10      CTRRQDPCT        PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRRQSPCT        PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRRQTPCT        PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRRQREV         PIC S9(11)       COMP-3 VALUE +0.
             10      CTRRQSTDT        PIC S9(05)       COMP-3 VALUE +0.
             10      CTRRQSTF         PIC S9(03)V9(02) COMP-3 VALUE +0.
             10      CTRSTF4          PIC S9(04)V9(03) COMP-3 VALUE +0.

       01            OLD.
           05        OLDKEY.
             10      OLDKDIST          PIC  X(02).
             10      OLDKREQ           PIC  X(03).
             10      OLDKFY            PIC  X(02).
             10      OLDKRPT           PIC  X(01).
             10      OLDKSCHL          PIC  X(04).
             10      OLDKSEQ           PIC  X(01).
             10      OLDKPGM           PIC  X(03).
             10      OLDKTYPE          PIC  X(01).
           05        OLDFSRV           PIC  S9(09).
           05        OLDTSCHL          PIC  S9(09).
           05        OLDTDIST          PIC  S9(09).
           05        OLDPREPD          PIC  S9(09).
           05        OLDPREPS          PIC  S9(09).
           05        OLDPREPT          PIC  S9(09).
           05        OLDPRT            PIC  X(01).
           05        OLDSRC            PIC  X(01).


           COPY                        EWSCL        OF          CPYSRC.
           COPY                        EWFPG        OF          CPYSRC.
           COPY                        EWFRS        OF          CPYSRC.
           COPY                        EWRWF        OF          CPYSRC.
           COPY                        EWABF        OF          CPYSRC.
           COPY                        EWDRC        OF          CPYSRC.

       01            OLDLN             PIC  X(133).

       01      HD1.
001        05  FILLER  PIC X(06) VALUE 'EW031 '.
           05  HD1ABBR.
007         10 HD1B    OCCURS 22 TIMES INDEXED BY HD11 PIC X(01).
029        05  FILLER  PIC X(11) VALUE SPACES.
040        05  HD1MODE PIC X(08) VALUE SPACES.
048        05  FILLER  PIC X(04) VALUE SPACES.
052        05  FILLER  PIC X(21) VALUE 'COST AS A PERCENTAGE '.
073        05  FILLER  PIC X(10) VALUE 'OF REVENUE'.
083        05  FILLER  PIC X(15) VALUE SPACES.
098        05  HD1USER PIC X(09) VALUE SPACES.
107        05  HD1MM   PIC X(02) VALUE SPACES.
109        05  FILLER  PIC X(01) VALUE '/'.
110        05  HD1DD   PIC X(02) VALUE SPACES.
112        05  FILLER  PIC X(01) VALUE '/'.
113        05  HD1YY   PIC X(02) VALUE SPACES.
115        05  FILLER  PIC X(02) VALUE SPACES.
117        05  HD1HR   PIC X(02) VALUE SPACES.
119        05  FILLER  PIC X(01) VALUE ':'.
120        05  HD1MN   PIC X(02) VALUE SPACES.
122        05  FILLER  PIC X(07) VALUE '  PAGE-'.
129        05  HD1PG   PIC ZZZ9.

041397 01      HD1A.
041397     05  FILLER  PIC X(45) VALUE SPACES.
041397     05  FILLER  PIC X(29) VALUE 'REVENUE FILE BASED ON SURVEY'.
041397     05  FILLER  PIC X(29) VALUE 'S 1, 2, 3, & 4E             '.

       01      HD2.
001        05  FILLER  PIC X(41) VALUE SPACES.
           05  HD2HEAD.
042         10 HD2B    OCCURS 50 TIMES INDEXED BY HD21 PIC X(01).
092        05  FILLER  PIC X(41) VALUE SPACES.

       01      HD3.
001        05  FILLER  PIC X(41) VALUE SPACES.
           05  HD3HEAD.
042         10 HD3B    OCCURS 50 TIMES INDEXED BY HD31 PIC X(01).
092        05  FILLER  PIC X(41) VALUE SPACES.

       01      HD4.
001        05  FILLER  PIC X(06) VALUE 'SCHL- '.
007        05  HD4SCHL PIC X(04) VALUE SPACES.
011        05  FILLER  PIC X(01) VALUE SPACES.
012        05  HD4DESC PIC X(30) VALUE SPACES.
042        05  FILLER  PIC X(91) VALUE SPACES.

       01      HD5.
           05  FILLER  PIC X(47) VALUE
                     'ADJUSTED DISTRICT AGGREGATE - ADDS TRANSPORTATI'.
041397*    05  FILLER  PIC X(47) VALUE
041397*              'ON FROM SPECIAL REVENUE AND FOOD SERVICE(STATE '.
041397     05  FILLER  PIC X(26) VALUE
041397               'ON AND FOOD SERVICE(STATE '.
           05  FILLER  PIC X(34) VALUE
                     'SUPPLEMENT AND TRANSFER ONLY).    '.

       01      HD6.
001        05  FILLER  PIC X(39) VALUE SPACES.
040        05  FILLER  PIC X(29) VALUE 'TOTAL         TOTAL         T'.
112895*    05  FILLER  PIC X(29) VALUE 'OTAL %OF REVENUE        FEFP '.
112895     05  FILLER  PIC X(29) VALUE 'OTAL   %OF REVENUE        FEF'.
112895*    05  FILLER  PIC X(21) VALUE '   TOTAL   FTE       '.
112895     05  FILLER  PIC X(21) VALUE 'P    TOTAL   FTE     '.
119        05  FILLER  PIC X(14) VALUE SPACES.

       01      HD7.
001        05  FILLER  PIC X(19) VALUE '----- PROGRAM -----'.
020        05  FILLER  PIC X(19) VALUE SPACES.
039        05  FILLER  PIC X(29) VALUE 'DIRECT        SCHOOL       PR'.
112895*    05  FILLER  PIC X(29) VALUE 'OGRAM DIR SCL TOT      ADJUST'.
112895     05  FILLER  PIC X(29) VALUE 'OGRAM   DIR SCL TOT      ADJU'.
112895*    05  FILLER  PIC X(21) VALUE 'ED  COSTS    TO      '.
112895     05  FILLER  PIC X(21) VALUE 'STED   PER     TO    '.
118        05  FILLER  PIC X(15) VALUE SPACES.

       01      HD8.
001        05  FILLER  PIC X(03) VALUE 'NBR'.
004        05  FILLER  PIC X(24) VALUE SPACES.
028        05  FILLER  PIC X(03) VALUE 'FTE'.
031        05  FILLER  PIC X(09) VALUE SPACES.
040        05  FILLER  PIC X(20) VALUE 'COSTS         COSTS '.
112895*    05  FILLER  PIC X(20) VALUE '        COSTS CST CS'.
112895     05  FILLER  PIC X(22) VALUE '        COSTS   CST CS'.
080        05  FILLER  PIC X(20) VALUE 'T CST       REVENUE '.
112895*    05  FILLER  PIC X(20) VALUE '  STDT  STAFF       '.
112895     05  FILLER  PIC X(20) VALUE '  FTE   STAFF       '.
112895*    05  FILLER  PIC X(13) VALUE SPACES.
112895     05  FILLER  PIC X(11) VALUE SPACES.

       LINKAGE       SECTION.

           COPY                       EWBJR                OF CPYSRC.

       PROCEDURE DIVISION USING BJR.
      ******************************************************************
       DECLARATIVES.
       000-ERROR     SECTION.
           USE AFTER STANDARD ERROR PROCEDURE ON CRD-CARD
                                                 RWF-DISK
                                                 ABF-DISK
                                                 DRC-DISK
                                                 DRC-TAPE
                                                 CRF-DISK.
       000-ENCOUNTERED.
           CONTINUE.
       END DECLARATIVES.

      ******************************************************************
           SORT    SRT-SORT            ASCENDING KEY       SRTKEY
                                       INPUT     PROCEDURE 000-INPUT
                                       OUTPUT    PROCEDURE 500-OUTPUT.
           GOBACK.

      ******************************************************************
       000-INPUT SECTION.
           PERFORM 490-HOUSEKEEPING    THRU 490-EXIT.

           IF      WSCRC               NOT  =  'Y'
             MOVE  '99'                TO   RETDRC.
           IF      WSCRCT              NOT  =  'Y'
             MOVE  '99'                TO   RETDRCT.

       005-LOOP.
           IF     (RETRWF              NOT  =  '00'          AND
                   RETABF              NOT  =  '00'          AND
                   RETDRC              NOT  =  '00'          AND
                   RETDRCT             NOT  =  '00')
             GO                        TO   499-EOJ.

           PERFORM 015-SELECT          THRU 015-EXIT
           PERFORM 010-READ            THRU 010-EXIT
           GO                          TO   005-LOOP.

      ******************************************************************
       010-READ.

           IF      RETRWF              =    '00'
             READ  RWF-DISK            NEXT
             IF    (RWFDK              >    EN1KEY)                OR
                   (RETRWF             NOT  =   '00')
               MOVE  '99'              TO   RETRWF
             ELSE
               MOVE  RWFD              TO   RWF
               MOVE  'R'               TO   WSCFILE
040599         PERFORM 012-CONV-PGM    THRU 012-EXIT
040401         IF  RWFPGM              >    SPACES
040401           PERFORM 014-TRUNC     THRU 014-EXIT
040401         END-IF
               GO                      TO   010-EXIT.

           IF      RETABF              =    '00'
             READ    ABF-DISK          NEXT
             IF     (ABFDK             >    EN2KEY)                OR
                    (RETABF            NOT  =   '00')
               MOVE  '99'              TO   RETABF
             ELSE
               MOVE  ABFD              TO   ABF
               MOVE  'A'               TO   WSCFILE
040599         PERFORM 012-CONV-PGM    THRU 012-EXIT
               GO                      TO   010-EXIT.

           IF      RETDRC              =    '00'
             READ  DRC-DISK            NEXT
             IF    RETDRC              NOT  =  '00'
               MOVE '99'               TO   RETDRC
             ELSE
               MOVE  DRCD              TO   DRC
               MOVE  'D'               TO   WSCFILE
040599         PERFORM 012-CONV-PGM    THRU 012-EXIT
               GO                      TO   010-EXIT.

           READ    DRC-TAPE
           IF      RETDRCT             NOT  =  '00'
             MOVE  '99'                TO   RETDRCT
             GO                        TO   010-EXIT
           ELSE
             MOVE  DRCT                TO   DRC
040599*      MOVE  'D'                 TO   WSCFILE.
040599       MOVE  'D'                 TO   WSCFILE
040599       PERFORM 012-CONV-PGM      THRU 012-EXIT.

       010-EXIT.
           EXIT.

040599******************************************************************
040599 012-CONV-PGM.
040599     IF      WSCFILE             =    'R'
040599       IF    RWFPGM              =    '121'
033001         MOVE  '120'             TO   RWFPGM.
033001*        MOVE  '120'             TO   RWFPGM
033001*      ELSE
033001*        IF  RWFPGM              >=   '251'                  AND
033001*            RWFPGM              <=   '255'
033001*          MOVE  '250'           TO   RWFPGM.
040599*
040599     IF      WSCFILE             =    'A'
040599       IF    ABFPGM              =    '121'
033001         MOVE  '120'             TO   ABFPGM.
033001*        MOVE  '120'             TO   ABFPGM
033001*      ELSE
033001*        IF  ABFPGM              >=   '251'                  AND
033001*            ABFPGM              <=   '255'
033001*          MOVE  '250'           TO   ABFPGM.
030599*
040599*
040599     IF      WSCFILE             NOT  =  'D'
040599       GO                        TO   012-EXIT.
040599
040599     SET     DRC1                TO   +1.
040599 012-LOOP.
040599     IF      DRCPGM  (DRC1)      =    '121'
033001       MOVE  '120'               TO   DRCPGM       (DRC1).
033001*      MOVE  '120'               TO   DRCPGM       (DRC1)
033001*    ELSE
033001*      IF    DRCPGM  (DRC1)      >=   '251'                  AND
033001*            DRCPGM  (DRC1)      <=   '255'
033001*        MOVE  '250'             TO   DRCPGM       (DRC1).
040599     IF      DRC1                <    +7
040599       SET   DRC1                UP   BY  +1
040599       GO                        TO   012-LOOP.
040599
040599 012-EXIT.
040599     EXIT.
040599
      ******************************************************************
040401 014-TRUNC.
040401
040401     MOVE    RWFDSAL             TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDSAL
040401
040401     MOVE    RWFDBEN             TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDBEN
040401
040401     MOVE    RWFDPRCH            TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDPRCH
040401
040401     MOVE    RWFDMATSUP          TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDMATSUP
040401
040401     MOVE    RWFDOTHER           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDOTHER
040401
040401     MOVE    RWFDCAP             TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDCAP
040401
040401
040401     MOVE    RWFSI6100           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFSI6100
040401
040401     MOVE    RWFSI6200           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFSI6200
040401
040401     MOVE    RWFSI6300           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFSI6300
040401
040401     MOVE    RWFSI6400           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFSI6400
040401
042006     MOVE    RWFSI6500           TO   WSCTRUNC
042006     MOVE    WSCTRUNC            TO   RWFSI6500
042006
040401     MOVE    RWFSI7300           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFSI7300
040401
040401     MOVE    RWFSI7400           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFSI7400
040401
040401     MOVE    RWFSI7600           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFSI7600
040401
040401     MOVE    RWFSI7700           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFSI7700
040401
040401     MOVE    RWFSI7800           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFSI7800
040401
040401     MOVE    RWFSI7900           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFSI7900
040401
040401     MOVE    RWFSI8100           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFSI8100
040401
042006     MOVE    RWFSI8200           TO   WSCTRUNC
042006     MOVE    WSCTRUNC            TO   RWFSI8200
040401
040401     MOVE    RWFDI6100           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDI6100
040401
040401     MOVE    RWFDI6200           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDI6200
040401
040401     MOVE    RWFDI6300           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDI6300
040401
040401     MOVE    RWFDI6400           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDI6400
040401
042006     MOVE    RWFDI6500           TO   WSCTRUNC
042006     MOVE    WSCTRUNC            TO   RWFDI6500
042006
040401     MOVE    RWFDI7100           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDI7100
040401
040401     MOVE    RWFDI7200           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDI7200
040401
040401     MOVE    RWFDI7400           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDI7400
040401
040401     MOVE    RWFDI7500           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDI7500
040401
040401     MOVE    RWFDI7600           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDI7600
040401
040401     MOVE    RWFDI7700           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDI7700
040401
040401     MOVE    RWFDI7800           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDI7800
040401
040401     MOVE    RWFDI7900           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDI7900
040401
040401     MOVE    RWFDI8100           TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFDI8100
040401
042006     MOVE    RWFDI8200           TO   WSCTRUNC
042006     MOVE    WSCTRUNC            TO   RWFDI8200
040401
040401     MOVE    RWFTOTAL            TO   WSCTRUNC
040401     MOVE    WSCTRUNC            TO   RWFTOTAL.
040401 014-EXIT.
040401     EXIT.

       015-SELECT.
           IF      WSCFILE             =    'A'
             GO                        TO   015-ABF.
           IF      WSCFILE             =    'D'
             GO                        TO   015-DRC.

           MOVE    RWFSCHL             TO   SELSCHL
           SET     RQR1  SEL1          TO   +1.
       015-MASK1.
           IF      RQRB    (RQR1)      =    SPACES
             MOVE  ' '                 TO   SELB         (SEL1).
           IF      RQR1                <    +04
             SET   RQR1  SEL1          UP   BY  +1
             GO                        TO   015-MASK1.

           IF     (RQRDIST             NOT  =  RWFDIST)      OR
                  (RQRFY               NOT  =  RWFFY)        OR
                  (RQRSEL              NOT  =  SEL)          OR
051100            (RWFTABLE            =    '99998')         OR
                  (RWFTABLE            =    '99999')
             GO                        TO   015-EXIT.

           INITIALIZE    SRT
           MOVE    RQRDIST             TO   SRTKDIST
           MOVE    RQRREQ              TO   SRTKREQ
           MOVE    RQRFY               TO   SRTKFY
           MOVE    '1'                 TO   SRTKRPT
           MOVE    RWFSCHL             TO   SRTKSCHL
           MOVE    RWFPGM              TO   SRTKPGM   TEMPPGM
           PERFORM 020-PGM             THRU 020-EXIT
           MOVE    TEMPSEQ             TO   SRTKSEQ
           MOVE    '1'                 TO   SRTKTYPE
           COMPUTE SRTDIRECT           =    RWFDSAL   + RWFDBEN
                                          + RWFDPRCH  + RWFDMATSUP
                                          + RWFDOTHER + RWFDCAP.
           COMPUTE SRTSIND             =    RWFSI6100 + RWFSI6200
                                          + RWFSI6300 + RWFSI6400
042006                                                + RWFSI6500
                                          + RWFSI7300 + RWFSI7400
040401*                                   + RWFSI7600 + RWFSI7700
040401*                                   + RWFSI7800 + RWFSI7900
040401                                                + RWFSI7700
040401                                                + RWFSI7900
042006*                                   + RWFSI8100.
042006                                                + RWFSI8100
042006                                                + RWFSI8200.
           COMPUTE SRTDIND             =    RWFDI6100 + RWFDI6200
                                          + RWFDI6300 + RWFDI6400
042006                                                + RWFDI6500
                                          + RWFDI7100 + RWFDI7200
                                          + RWFDI7400 + RWFDI7500
040401*                                   + RWFDI7600 + RWFDI7700
040401*                                   + RWFDI7800 + RWFDI7900
040401                                                + RWFDI7700
040401                                                + RWFDI7900
042006*                                   + RWFDI8100.
042006                                                + RWFDI8100
042006                                                + RWFDI8200.
           MOVE    ZEROS               TO   SRTREV SRTFTE SRTSTAFF
041397*    MOVE    RQRFSRV             TO   SRTFSRV
041397*    MOVE    RQRTSCHL            TO   SRTTSCHL
041397*    MOVE    RQRTDIST            TO   SRTTDIST
041397*    MOVE    RQRPREPD            TO   SRTPREPD
041397*    MOVE    RQRPREPS            TO   SRTPREPS
041397*    MOVE    RQRPREPT            TO   SRTPREPT
           MOVE    RQRPRT              TO   SRTPRT
           MOVE    RQRSRC              TO   SRTSRC

           RELEASE SRT
           MOVE    '0000'              TO   SRTKSCHL
           RELEASE SRT
           MOVE    '2'                 TO   SRTKRPT
041397     MOVE    RQRFSRV             TO   SRTFSRV
041397     MOVE    RQRTSCHL            TO   SRTTSCHL
041397     MOVE    RQRTDIST            TO   SRTTDIST
041397     MOVE    RQRPREPD            TO   SRTPREPD
041397     MOVE    RQRPREPS            TO   SRTPREPS
041397     MOVE    RQRPREPT            TO   SRTPREPT
           RELEASE SRT
           GO                          TO   015-EXIT.

       015-ABF.
           IF      WSCFILE             =    'D'
             GO                        TO   015-DRC.

           MOVE    ABFSCHL             TO   SELSCHL
           SET     RQR1  SEL1          TO   +1.
       015-MASK2.
           IF      RQRB    (RQR1)      =    SPACES
             MOVE  ' '                 TO   SELB         (SEL1).
           IF      RQR1                <    +04
             SET   RQR1  SEL1          UP   BY  +1
             GO                        TO   015-MASK2.

           IF     (RQRDIST             NOT  =  ABFDIST)      OR
                  (RQRFY               NOT  =  ABFFY)        OR
                  (RQRSEL              NOT  =  SEL)
             GO                        TO   015-EXIT.

           INITIALIZE    SRT
           MOVE    RQRDIST             TO   SRTKDIST
           MOVE    RQRREQ              TO   SRTKREQ
           MOVE    RQRFY               TO   SRTKFY
           MOVE    '1'                 TO   SRTKRPT
           MOVE    ABFSCHL             TO   SRTKSCHL
           MOVE    ABFPGM              TO   SRTKPGM    TEMPPGM
           PERFORM 020-PGM             THRU 020-EXIT
           MOVE    TEMPSEQ             TO   SRTKSEQ
           MOVE    '2'                 TO   SRTKTYPE
           MOVE    ZEROS               TO   SRTDIRECT     SRTSIND
                                            SRTDIND       SRTREV
           MOVE    ABFSTDT             TO   SRTFTE
           MOVE    ABFSTAFF            TO   SRTSTAFF
           MOVE    ABFPGM              TO   WSCPGM
050102*    IF      WSCPGM              NOT  =  '214'     AND
050102*            WSCP1               NOT  =  '4'
050102     IF      WSCPGM              NOT  =  '214'     AND
050102             WSCPGM                   <  '340'
             ADD   ABFSTDT             TO   CTRFTETOT.
041397*    MOVE    RQRFSRV             TO   SRTFSRV
041397*    MOVE    RQRTSCHL            TO   SRTTSCHL
041397*    MOVE    RQRTDIST            TO   SRTTDIST
041397*    MOVE    RQRPREPD            TO   SRTPREPD
041397*    MOVE    RQRPREPS            TO   SRTPREPS
041397*    MOVE    RQRPREPT            TO   SRTPREPT
           MOVE    RQRPRT              TO   SRTPRT
           MOVE    RQRSRC              TO   SRTSRC

           RELEASE SRT
           MOVE    '0000'              TO   SRTKSCHL
           RELEASE SRT
           MOVE    '2'                 TO   SRTKRPT
041397     MOVE    RQRFSRV             TO   SRTFSRV
041397     MOVE    RQRTSCHL            TO   SRTTSCHL
041397     MOVE    RQRTDIST            TO   SRTTDIST
041397     MOVE    RQRPREPD            TO   SRTPREPD
041397     MOVE    RQRPREPS            TO   SRTPREPS
041397     MOVE    RQRPREPT            TO   SRTPREPT
           RELEASE SRT
           GO                          TO   015-EXIT.

       015-DRC.
           IF      WSCFILE             NOT  =  'D'
             GO                        TO   015-EXIT.

           MOVE    DRCSCHL             TO   SELSCHL
           SET     RQR1  SEL1          TO   +1.
       015-MASK3.
           IF      RQRB    (RQR1)      =    SPACES
             MOVE  ' '                 TO   SELB         (SEL1).
           IF      RQR1                <    +04
             SET   RQR1  SEL1          UP   BY  +1
             GO                        TO   015-MASK3.

           IF     (RQRDIST             NOT  =  DRCDIST)      OR
                  (RQRSEL              NOT  =  SEL)
             GO                        TO   015-EXIT.

051100     MOVE    DRCDIST             TO   SCLKEY
051100     MOVE    RQRFY               TO   SCLFY
051100     MOVE    'SCL'               TO   SCLPREF
051100     MOVE    DRCSCHL             TO   SCLSCL
051100     MOVE    SCLKEY              TO   CRFDK
051100     READ    CRF-DISK
051100     IF      RETCRF              NOT  =  '00'
051100       MOVE  SPACES              TO   SCLCHRTR
051100     ELSE
051100       MOVE  CRFD                TO   SCL.
051100     IF      SCLCHRTR            =    'Y'
051100       GO                        TO   015-EXIT.

           IF      DRCCARD             >    '7'
             MOVE  'DRCCARD > 7'       TO   LNMMSG
             MOVE  DRC                 TO   LNMVALUE2
             PERFORM 520-PRINT         THRU 520-EXIT.

           INITIALIZE    SRT
           MOVE    RQRDIST             TO   SRTKDIST
           MOVE    RQRREQ              TO   SRTKREQ
           MOVE    RQRFY               TO   SRTKFY
           MOVE    '3'                 TO   SRTKTYPE
           MOVE    ZEROS               TO   SRTDIRECT SRTSIND SRTDIND
                                            SRTFTE    SRTSTAFF
041397*    MOVE    RQRFSRV             TO   SRTFSRV
041397*    MOVE    RQRTSCHL            TO   SRTTSCHL
041397*    MOVE    RQRTDIST            TO   SRTTDIST
041397*    MOVE    RQRPREPD            TO   SRTPREPD
041397*    MOVE    RQRPREPS            TO   SRTPREPS
041397*    MOVE    RQRPREPT            TO   SRTPREPT
           MOVE    RQRPRT              TO   SRTPRT
           MOVE    RQRSRC              TO   SRTSRC
           SET     DRC1                TO   +1.
       015-DRC-LOOP.
101500*    IF      DRCPGM  (DRC1)      NOT  =  SPACES
101500     IF      DRCREV  (DRC1)      NOT  =  ZEROS
041397       MOVE    ZEROS             TO   SRTFSRV
041397                                      SRTTSCHL
041397                                      SRTTDIST
041397                                      SRTPREPD
041397                                      SRTPREPS
041397                                      SRTPREPT
             MOVE  DRCSCHL             TO   SRTKSCHL
             MOVE  '1'                 TO   SRTKRPT
             MOVE  DRCPGM  (DRC1)      TO   SRTKPGM   TEMPPGM
             PERFORM 020-PGM           THRU 020-EXIT
             MOVE  TEMPSEQ             TO   SRTKSEQ
             MOVE  DRCREV  (DRC1)      TO   SRTREV
             RELEASE SRT
             MOVE    '0000'            TO   SRTKSCHL
             RELEASE SRT
             MOVE    '2'               TO   SRTKRPT
041397       MOVE    RQRFSRV           TO   SRTFSRV
041397       MOVE    RQRTSCHL          TO   SRTTSCHL
041397       MOVE    RQRTDIST          TO   SRTTDIST
041397       MOVE    RQRPREPD          TO   SRTPREPD
041397       MOVE    RQRPREPS          TO   SRTPREPS
041397       MOVE    RQRPREPT          TO   SRTPREPT
             RELEASE SRT.
           IF      DRC1                <    +7
             SET   DRC1                UP   BY  +1
             GO                        TO   015-DRC-LOOP.

       015-EXIT.
           EXIT.

       020-PGM.
           SEARCH  ALL  PGMENTRY
             AT  END
               MOVE  '***PGM NOT IN TBL***' TO  LNMMSG
               MOVE  TEMPPGM           TO   LNMVALUE2
               PERFORM 520-PRINT       THRU 520-EXIT
             WHEN    PGMPGM  (PGM1)    =    TEMPPGM
               MOVE  PGMSEQ  (PGM1)    TO   TEMPSEQ.
       020-EXIT.
           EXIT.

      ******************************************************************
       490-HOUSEKEEPING.
           OPEN    INPUT                    CRD-CARD      CRF-DISK
                                            RWF-DISK      ABF-DISK
                   OUTPUT                   PR1-PRNT
           MOVE    SPACES              TO   LN1
           MOVE    '1'                 TO   CTLCHAR
TEMP  *    MOVE    +1                  TO   CTRFTETOT.
TEMP  *490-DELAY-LOOP.
TEMP  *    IF      CTRFTETOT           NOT  =  ZERO
TEMP  *      GO                        TO   490-DELAY-LOOP.
           MOVE    ZEROS               TO   CTRFTETOT
           SET     RQH1                TO   +1
           MOVE    HIGH-VALUES         TO   RQR           RQH.
           IF      BJR                 >    SPACES
             PERFORM 495-LOAD          THRU 495-EXIT
             GO                        TO   490-TEST.
       490-LOAD.
           READ    CRD-CARD            AT   END
             GO                        TO   490-TEST.
           IF      CRDREQ              NOT  NUMERIC
             MOVE    CRD               TO   LNMVALUE2
             PERFORM 520-PRINT         THRU 520-EXIT
             GO                        TO   490-LOAD.
           MOVE    SPACES              TO   ERR
           IF      CRDID               =    'SL'
             GO                        TO   490-REQ
           ELSE
             IF     (CRDID             =    'H1')                    OR
                    (CRDID             =    'H2')
               GO                      TO   490-HEAD
             ELSE
               GO                      TO   490-LOAD.

       490-REQ.
           IF     (CRDPRT              NOT  =   'U')                 AND
                  (CRDPRT              NOT  =   'T')                 AND
                  (CRDPRT              NOT  =   'B')                 AND
                  (CRDPRT              NOT  =   'N')
             MOVE  ALL '-'             TO   ERRPRT.
           IF     (CRDDIST             =    SPACES)
             MOVE  ALL '-'             TO   ERRDIST.
           IF     (CRDFY               NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRFY.
           IF     (CRDFUND             NOT  =   '1')               AND
                  (CRDFUND             NOT  =   ' ')
             MOVE  ALL '-'             TO   ERRFUND.
           IF     (CRDFSRV             NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRFSRV.
           IF     (CRDTSCHL            NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRTSCHL.
           IF     (CRDTDIST            NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRTDIST.
           IF     (CRDPREPD            NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRPREPD.
           IF     (CRDPREPS            NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRPREPS.
           IF     (CRDPREPT            NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRPREPT.
           IF     (CRDRPT              NOT  =   'C')
             MOVE  ALL '-'             TO   ERRRPT.
           IF     (CRDSRC              NOT  =   'D')               AND
                  (CRDSRC              NOT  =   'T')
             MOVE  ALL '-'             TO   ERRSRC.
           IF      ERR                 NOT  =   SPACES
             MOVE    'ERROR. BYPASSED' TO   LNMMSG
             MOVE    CRD               TO   LNMVALUE2
             PERFORM 520-PRINT         THRU 520-EXIT
             MOVE    ERR               TO   LNMVALUE2
             PERFORM 520-PRINT         THRU 520-EXIT
             GO                        TO   490-LOAD
           ELSE
             MOVE    'REQUEST LOADED'  TO   LNMMSG
             MOVE    CRD               TO   LNMVALUE2
             PERFORM 520-PRINT         THRU 520-EXIT.
           MOVE    CRDREQ              TO   RQRREQ
           MOVE    CRDPRT              TO   RQRPRT
           MOVE    CRDDIST             TO   RQRDIST
           MOVE    CRDFY               TO   RQRFY
           MOVE    CRDSCHL             TO   RQRSCHL
           MOVE    CRDFSRV             TO   RQRFSRV
           MOVE    CRDTSCHL            TO   RQRTSCHL
           MOVE    CRDTDIST            TO   RQRTDIST
           MOVE    CRDPREPD            TO   RQRPREPD
           MOVE    CRDPREPS            TO   RQRPREPS
           MOVE    CRDPREPT            TO   RQRPREPT
           MOVE    CRDSRC              TO   RQRSRC

           MOVE    CRDDIST             TO   RWFKEY
           MOVE    CRDFY               TO   RWFFY
           MOVE    '1'                 TO   RWFFUND
           IF     (RWFKEY              <    ST1KEY)
             MOVE  RWFKEY              TO   ST1KEY.
           INSPECT RWFKEY       REPLACING   ALL  ' ' BY HIGH-VALUES
           IF     (RWFKEY              >    EN1KEY)
             MOVE  RWFKEY              TO   EN1KEY.

           MOVE    CRDDIST             TO   ABFKEY
           MOVE    CRDFY               TO   ABFFY
           MOVE    CRDSCHL             TO   ABFSCHL
           IF     (ABFKEY              <    ST2KEY)
             MOVE  ABFKEY              TO   ST2KEY.
           INSPECT ABFKEY       REPLACING   ALL  ' ' BY HIGH-VALUES
           IF     (ABFKEY              >    EN2KEY)
             MOVE  ABFKEY              TO   EN2KEY.

           GO                          TO   490-LOAD.
       490-HEAD.
           MOVE    CRD                 TO   LNMVALUE2
           PERFORM 520-PRINT           THRU 520-EXIT
           MOVE    CRHREQ              TO   RQHREQ       (RQH1)
           MOVE    CRHID               TO   RQHID        (RQH1)
           MOVE    CRHUSER             TO   RQHUSER      (RQH1)
           MOVE    SPACES              TO   RQHHEAD      (RQH1)
           MOVE    +50                 TO   CTRIDX
           SET     CRH1                TO   +50.
       490-HEAD1.
           IF      CRHB         (CRH1) =    SPACES
             IF      CRH1              >    +2
               ADD   -1                TO   CTRIDX
               SET   CRH1              DOWN BY  +1
               GO                      TO   490-HEAD1.
           SUBTRACT +1                 FROM CTRIDX
           COMPUTE CTRIDX      ROUNDED =    (50  - CTRIDX) / 2
           SET     RQH2                TO   CTRIDX
           SET     CRH1                TO   +1.
       490-HEAD2.
           MOVE    CRHB         (CRH1) TO   RQHB         (RQH1 RQH2)
           IF      RQH2                <    +50
             SET   RQH2  CRH1          UP   BY  +1
             GO                        TO   490-HEAD2.
           SET     RQH1             UP BY   +1
           GO                          TO   490-LOAD.

       490-TEST.
           IF      RQR                 =    HIGH-VALUES
             MOVE    'EW031 NO REQUESTS *'   TO   LNMMSG
             PERFORM 520-PRINT         THRU 520-EXIT.
           IF      RQRSRC              =    'D'
             OPEN  INPUT               DRC-DISK
             MOVE  '00'                TO  RETDRCT
             MOVE  'Y'                 TO  WSCRC
           ELSE
             OPEN  INPUT               DRC-TAPE
             MOVE  '00'                TO  RETDRC
             MOVE  'Y'                 TO  WSCRCT.
           IF      RETCRF              NOT  =   '00'
             MOVE    'CRF OPEN ERROR'  TO   LNMMSG
             MOVE    RETCRF            TO   LNMVALUE1
             PERFORM 520-PRINT         THRU 520-EXIT.
           IF      RETRWF              NOT  =   '00'
             MOVE    'RWF OPEN ERROR'  TO   LNMMSG
             MOVE    RETRWF            TO   LNMVALUE1
             PERFORM 520-PRINT         THRU 520-EXIT.
           IF      RETABF              NOT  =   '00'
             MOVE    'ABF OPEN ERROR'  TO   LNMMSG
             MOVE    RETABF            TO   LNMVALUE1
             PERFORM 520-PRINT         THRU 520-EXIT.
           IF      RETDRC              NOT  =   '00'
             MOVE    'DRC OPEN ERROR'  TO   LNMMSG
             MOVE    RETDRC            TO   LNMVALUE1
             PERFORM 520-PRINT         THRU 520-EXIT.
           IF      RETDRCT             NOT  =   '00'
             MOVE    'DRCT OPEN ERROR' TO   LNMMSG
             MOVE    RETDRCT           TO   LNMVALUE1
             PERFORM 520-PRINT         THRU 520-EXIT.
           IF     (RETCRF              NOT  =   '00')                OR
                  (RETRWF              NOT  =   '00')                OR
                  (RETABF              NOT  =   '00')                OR
                  (RETDRC              NOT  =   '00')                OR
                  (RETDRCT             NOT  =   '00')
             GO                        TO   499-EOJ.
           PERFORM 493-TBL-PGM         THRU 493-EXIT
           MOVE    ST1KEY              TO   RWFDK
           START   RWF-DISK        KEY >    RWFDK
           MOVE    ST2KEY              TO   ABFDK
           START   ABF-DISK        KEY >    ABFDK
           IF     (RETRWF              =    '00'                AND
                   RETABF              =    '00')
             PERFORM 010-READ          THRU 010-EXIT.
       490-EXIT.
           EXIT.

      ******************************************************************
       493-TBL-PGM.
           MOVE    RETCRF              TO   RETCRFOLD
           MOVE    HIGH-VALUES         TO   PGMTBL
           SET     PGM1                TO   +1
           MOVE    RQRDIST             TO   FPGKEY
           MOVE    RQRFY               TO   FPGFY
           MOVE    'FPG'               TO   FPGPREF
           MOVE    FPGKEY              TO   CRFDK
           START   CRF-DISK      KEY   >    CRFDK.
           IF      RETCRF              NOT  =  '00'
             MOVE  RETCRFOLD           TO   RETCRF
             GO                        TO   493-EXIT.
       493-LOOP.
           READ    CRF-DISK            NEXT
           IF      RETCRF              =    '00'
             MOVE  CRFD                TO   FPG
             IF    FPGDIST             =    RQRDIST             AND
                   FPGFY               =    RQRFY               AND
                   FPGPREF             =    'FPG'
               MOVE FPGFPG             TO   PGMPGM  (PGM1)
               MOVE FPGRPT             TO   PGMSEQ  (PGM1)
               MOVE FPGCOSTFR          TO   PGMFRM  (PGM1)
               MOVE FPGCOSTTO          TO   PGMTO   (PGM1)
               IF  PGM1                <    +1000
                 SET PGM1              UP   BY  +1
                 GO                    TO   493-LOOP.
           MOVE    RETCRFOLD           TO   RETCRF.
       493-EXIT.
           EXIT.
      ******************************************************************
       495-LOAD.
           MOVE    BJRCARD1            TO   CRD
           MOVE    SPACES              TO   ERR
           IF     (CRDPRT              NOT  =   'U')                 AND
                  (CRDPRT              NOT  =   'T')                 AND
                  (CRDPRT              NOT  =   'B')                 AND
                  (CRDPRT              NOT  =   'N')
             MOVE  ALL '-'             TO   ERRPRT.
           IF     (CRDDIST             =    SPACES)
             MOVE  ALL '-'             TO   ERRDIST.
           IF     (CRDFY               NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRFY.
           IF     (CRDFUND             NOT  =   '1')               AND
                  (CRDFUND             NOT  =   ' ')
             MOVE  ALL '-'             TO   ERRFUND.
           IF     (CRDFSRV             NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRFSRV.
           IF     (CRDTSCHL            NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRTSCHL.
           IF     (CRDTDIST            NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRTDIST.
           IF     (CRDPREPD            NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRPREPD.
           IF     (CRDPREPS            NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRPREPS.
           IF     (CRDPREPT            NOT  NUMERIC)
             MOVE  ALL '-'             TO   ERRPREPT.
           IF     (CRDRPT              NOT  =   'C')
             MOVE  ALL '-'             TO   ERRRPT.
           IF     (CRDSRC              NOT  =   'D')               AND
                  (CRDSRC              NOT  =   'T')
             MOVE  ALL '-'             TO   ERRSRC.
           IF      ERR                 NOT  =   SPACES
             MOVE    'ERROR. BYPASSED' TO   LNMMSG
             MOVE    CRD               TO   LNMVALUE2
             PERFORM 520-PRINT         THRU 520-EXIT
             MOVE    ERR               TO   LNMVALUE2
             PERFORM 520-PRINT         THRU 520-EXIT
             GO                        TO   495-EXIT.
           MOVE    CRDREQ              TO   RQRREQ
           MOVE    CRDPRT              TO   RQRPRT
           MOVE    CRDDIST             TO   RQRDIST
           MOVE    CRDFY               TO   RQRFY
           MOVE    CRDSCHL             TO   RQRSCHL
           MOVE    CRDFSRV             TO   RQRFSRV
           MOVE    CRDTSCHL            TO   RQRTSCHL
           MOVE    CRDTDIST            TO   RQRTDIST
           MOVE    CRDPREPD            TO   RQRPREPD
           MOVE    CRDPREPS            TO   RQRPREPS
           MOVE    CRDPREPT            TO   RQRPREPT
           MOVE    CRDSRC              TO   RQRSRC

           MOVE    CRDDIST             TO   RWFKEY
           MOVE    CRDFY               TO   RWFFY
           MOVE    '1'                 TO   RWFFUND
           IF     (RWFKEY              <    ST1KEY)
             MOVE  RWFKEY              TO   ST1KEY.
           INSPECT RWFKEY       REPLACING   ALL  ' ' BY HIGH-VALUES
           IF     (RWFKEY              >    EN1KEY)
             MOVE  RWFKEY              TO   EN1KEY.

           MOVE    CRDDIST             TO   ABFKEY
           MOVE    CRDFY               TO   ABFFY
           MOVE    CRDSCHL             TO   ABFSCHL
           IF     (ABFKEY              <    ST2KEY)
             MOVE  ABFKEY              TO   ST2KEY.
           INSPECT ABFKEY       REPLACING   ALL  ' ' BY HIGH-VALUES
           IF     (ABFKEY              >    EN2KEY)
             MOVE  ABFKEY              TO   EN2KEY.

           MOVE    BJRREQ1             TO   CRHREQ
           MOVE    BJRID1              TO   CRHID
           MOVE    BJRUSER1            TO   CRHUSER
           MOVE    BJRHEAD1            TO   CRHHEAD.
       495-HEAD.
           MOVE    CRHREQ              TO   RQHREQ       (RQH1)
           MOVE    CRHID               TO   RQHID        (RQH1)
           MOVE    CRHUSER             TO   RQHUSER      (RQH1)
           MOVE    SPACES              TO   RQHHEAD      (RQH1)
           MOVE    +50                 TO   CTRIDX
           SET     CRH1                TO   +50.
       495-HEAD1.
           IF      CRHB         (CRH1) =    SPACES
             IF      CRH1              >    +2
               ADD   -1                TO   CTRIDX
               SET   CRH1              DOWN BY  +1
               GO                      TO   495-HEAD1.
           SUBTRACT +1                 FROM CTRIDX
           COMPUTE CTRIDX      ROUNDED =    (50  - CTRIDX) / 2
           SET     RQH2                TO   CTRIDX
           SET     CRH1                TO   +1.
       495-HEAD2.
           MOVE    CRHB         (CRH1) TO   RQHB         (RQH1 RQH2)
           IF      RQH2                <    +50
             SET   RQH2  CRH1          UP   BY  +1
             GO                        TO   495-HEAD2.
           IF      BJRHEAD2            NOT  =   SPACES              AND
                   RQH1                =    +1
             SET   RQH1                UP   BY  +1
             MOVE  BJRREQ2             TO   CRHREQ
             MOVE  BJRID2              TO   CRHID
             MOVE  BJRUSER2            TO   CRHUSER
             MOVE  BJRHEAD2            TO   CRHHEAD
             GO                        TO   495-HEAD.
       495-EXIT.
           EXIT.
      ******************************************************************
       499-EOJ.
       499-EXIT.
           EXIT.

      ******************************************************************
       500-OUTPUT SECTION.
           PERFORM 990-HOUSEKEEPING    THRU 990-EXIT.
       505-LOOP.
             IF    (SRTKDIST           NOT  =   OLDKDIST)            OR
                   (SRTKREQ            NOT  =   OLDKREQ)             OR
                   (SRTKFY             NOT  =   OLDKFY)              OR
                   (SRTKSCHL           NOT  =   OLDKSCHL)            OR
                   (SRTKSEQ            NOT  =   OLDKSEQ)             OR
                   (SRTKPGM            NOT  =   OLDKPGM)
               PERFORM 615-1TOT        THRU 615-EXIT
               IF  (SRTKDIST           NOT  =   OLDKDIST)            OR
                   (SRTKREQ            NOT  =   OLDKREQ)             OR
                   (SRTKFY             NOT  =   OLDKFY)              OR
                   (SRTKSCHL           NOT  =   OLDKSCHL)            OR
                   (SRTKSEQ            NOT  =   OLDKSEQ)
                 PERFORM 625-2TOT      THRU 625-EXIT
                 IF  (SRTKDIST         NOT  =   OLDKDIST)            OR
                     (SRTKREQ          NOT  =   OLDKREQ)             OR
                     (SRTKFY           NOT  =   OLDKFY)              OR
                     (SRTKSCHL         NOT  =   OLDKSCHL)
                   PERFORM 635-3TOT    THRU 635-EXIT
                   IF  (SRTKDIST       NOT  =   OLDKDIST)            OR
                       (SRTKREQ        NOT  =   OLDKREQ)             OR
                       (SRTKFY         NOT  =   OLDKFY)
                     PERFORM 645-4TOT  THRU 645-EXIT
                     IF  (SRTKEY          =    HIGH-VALUES)
                       GO                 TO   999-EOJ
                     ELSE
                       PERFORM 640-4CHG     THRU 640-EXIT
                   ELSE
                     PERFORM 630-3CHG       THRU 630-EXIT
                 ELSE
                   PERFORM 620-2CHG         THRU 620-EXIT
               ELSE
                 PERFORM 610-1CHG           THRU 610-EXIT.

           PERFORM 515-PROCESS         THRU 515-EXIT
           PERFORM 510-READ            THRU 510-EXIT
           GO                          TO   505-LOOP.

      ******************************************************************
       510-READ.
           RETURN  SRT-SORT            AT   END
             MOVE  HIGH-VALUES         TO   SRTKEY.
       510-EXIT.
           EXIT.

      ******************************************************************
       515-PROCESS.
           IF       SRTKTYPE           =    '1'
             MOVE   'Y'                TO   WSCRWF.
           IF       SRTKTYPE           =    '2'
             MOVE   'Y'                TO   WSCABF.
           IF       SRTKTYPE           =    '3'
             MOVE   'Y'                TO   WSCDRC.
           ADD      SRTDIRECT          TO   CTRLNDIR
           ADD      SRTSIND            TO   CTRSIND
           ADD      SRTDIND            TO   CTRDIND
           ADD      SRTREV             TO   CTRLNREV
           ADD      SRTFTE             TO   CTRLNFTE
           ADD      SRTSTAFF           TO   CTRSTF1
           MOVE     SRTFSRV            TO   OLDFSRV
           MOVE     SRTTSCHL           TO   OLDTSCHL
           MOVE     SRTTDIST           TO   OLDTDIST
           MOVE     SRTPREPD           TO   OLDPREPD
           MOVE     SRTPREPS           TO   OLDPREPS
           MOVE     SRTPREPT           TO   OLDPREPT.
       515-EXIT.
           EXIT.

      ******************************************************************
       520-PRINT.
           IF      CTRLN               >    +60
             PERFORM 525-HEADS         THRU 525-EXIT.
           IF      CTLCHAR             =    '1'
             WRITE LN1             AFTER    ADVANCING PAGE
           ELSE
             IF      CTLCHAR           =    '0'
               WRITE LN1           AFTER    ADVANCING  2  LINES
               ADD   +2                TO   CTRLN
             ELSE
               IF      CTLCHAR         =    ' '
                 WRITE LN1         AFTER    ADVANCING  1  LINES
                 ADD   +1              TO   CTRLN
               ELSE
                 WRITE LN1         AFTER    ADVANCING  0  LINES
                 ADD   +0              TO   CTRLN.
           MOVE    SPACES              TO   LN1           CTLCHAR.
       520-EXIT.
           EXIT.

       525-HEADS.
           MOVE    LN1                 TO   OLDLN
           MOVE    +0                  TO   CTRLN
           ADD     +1                  TO   CTRPG
           MOVE    CTRPG               TO   HD1PG
           MOVE    HD1                 TO   LN1
           MOVE    '1'                 TO   CTLCHAR
           PERFORM 520-PRINT           THRU 520-EXIT
041397     MOVE    HD1A                TO   LN1
041397     PERFORM 520-PRINT           THRU 520-EXIT
           IF      HD2                 NOT  =   SPACES
             MOVE    HD2               TO   LN1
             PERFORM 520-PRINT         THRU 520-EXIT.
           IF      HD3                 NOT  =   SPACES
             MOVE    HD3               TO   LN1
             PERFORM 520-PRINT         THRU 520-EXIT.
           MOVE    '0'                 TO   CTLCHAR
           IF      WSCLAST             =   'N'
             MOVE    HD4               TO   LN1
             PERFORM 520-PRINT         THRU 520-EXIT
             IF    OLDKRPT             =   '2'
               MOVE    HD5             TO   LN1
               PERFORM 520-PRINT       THRU 520-EXIT.
           IF      WSCLAST             =   'N'
             MOVE    '0'             TO   CTLCHAR
             MOVE    HD6             TO   LN1
             PERFORM 520-PRINT       THRU 520-EXIT
             MOVE    HD7             TO   LN1
             PERFORM 520-PRINT       THRU 520-EXIT
             MOVE    HD8             TO   LN1
             PERFORM 520-PRINT       THRU 520-EXIT
           ELSE
             MOVE   'N'                TO   WSCLAST.
           MOVE    '0'                 TO   CTLCHAR
           MOVE    OLDLN               TO   LN1.
       525-EXIT.
           EXIT.

      ******************************************************************
       610-1CHG.
           MOVE    SRTKPGM             TO   OLDKPGM   LN1PGM
           MOVE    SRTKRPT             TO   OLDKRPT
           MOVE    SRTKDIST            TO   FPGKEY
           MOVE    SRTKFY              TO   FPGFY
           MOVE    'FPG'               TO   FPGPREF
           MOVE    SRTKPGM             TO   FPGFPG
           MOVE    FPGKEY              TO   CRFDK
           READ    CRF-DISK
           IF      RETCRF              NOT  =  '00'
             MOVE  SPACES              TO   FPGABBR
           ELSE
             MOVE  CRFD                TO   FPG.
           MOVE    FPGABBR             TO   LN1MSG
           MOVE    'N'                 TO   WSCRWF WSCABF WSCDRC
           INITIALIZE                  CTRLVL1  CTRACCUM.
       610-EXIT.
           EXIT.

       615-1TOT.
           IF      WSCABF              =    'N'
             MOVE  '*'                 TO   LN1ERR1.
           IF      WSCRWF              =    'N'
             MOVE  '*'                 TO   LN1ERR2  LN1ERR3  LN1ERR4.
           IF      WSCDRC              =    'N'
             MOVE  '*'                 TO   LN1ERR5.
           IF      WSCRWF              =    'N'                 AND
                   WSCABF              =    'N'                 AND
                   WSCDRC              =    'N'
             MOVE  '* NO RECORD *'     TO   LN1ERROR.

           IF      OLDKRPT             =    '2'
             GO                        TO   615-ADJST.

           MOVE    CTRLNFTE            TO   LN1FTE
           MOVE    CTRLNDIR            TO   LN1DIR
           COMPUTE CTRLNSCOST          =    CTRLNDIR + CTRSIND
           MOVE    CTRLNSCOST          TO   LN1SCOST
           COMPUTE CTRLNTCOST          =    CTRLNSCOST + CTRDIND
           MOVE    CTRLNTCOST          TO   LN1TCOST
           GO                          TO   615-CONT.

       615-ADJST.
           IF      CTRFTETOT           =    ZEROS
             MOVE  ZEROS               TO   WSCQUOT
           ELSE
             COMPUTE WSCQUOT           =    CTRLNFTE / CTRFTETOT.
           MOVE    CTRLNFTE            TO   LN1FTE
           IF      OLDKPGM             =    '101'
             COMPUTE CTRLNDIR  =  CTRLNDIR - (OLDPREPD * WSCQUOT)
             MOVE    CTRLNDIR          TO   LN1DIR
           ELSE
             MOVE    CTRLNDIR          TO   LN1DIR.

           MOVE    OLDKPGM             TO   WSCPGM
050102*    IF      WSCPGM              =    '214'          OR
050102*            WSCP1               =    '4'
050102     IF      WSCPGM              =  '214'            OR
050102             WSCPGM              >  '339'
             COMPUTE CTRLNSCOST        =    CTRLNDIR + CTRSIND
           ELSE
             COMPUTE CTRLNSCOST    =  ((OLDFSRV + OLDTSCHL) * WSCQUOT)
                                   +  CTRLNDIR + CTRSIND
             IF    WSCPGM              =    '101'
               COMPUTE CTRLNSCOST =  CTRLNSCOST - (OLDPREPS * WSCQUOT).
           MOVE    CTRLNSCOST          TO   LN1SCOST

050102*    IF      WSCPGM              =    '214'          OR
050102*            WSCP1               =    '4'
050102     IF      WSCPGM              =  '214'            OR
050102             WSCPGM              >  '339'
             COMPUTE CTRLNTCOST        =    CTRLNSCOST + CTRDIND
           ELSE
             COMPUTE CTRLNTCOST        =    ((OLDTDIST * WSCQUOT)
                                       +    CTRLNSCOST + CTRDIND)
             IF    WSCPGM              =    '101'
               COMPUTE CTRLNTCOST =  CTRLNTCOST - (OLDPREPT * WSCQUOT).
           MOVE    CTRLNTCOST          TO   LN1TCOST.

       615-CONT.
           IF      CTRLNREV            =    ZEROS
             MOVE  ZEROS               TO   CTRLNDPCT  LN1DPCT
                                            CTRLNSPCT  LN1SPCT
                                            CTRLNTPCT  LN1TPCT
           ELSE
             COMPUTE CTRLNDPCT ROUNDED =    CTRLNDIR   / CTRLNREV
             MULTIPLY  100             BY   CTRLNDPCT
             MOVE    CTRLNDPCT         TO   LN1DPCT
             COMPUTE CTRLNSPCT ROUNDED =    CTRLNSCOST / CTRLNREV
             MULTIPLY  100             BY   CTRLNSPCT
             MOVE    CTRLNSPCT         TO   LN1SPCT
             COMPUTE CTRLNTPCT ROUNDED =    CTRLNTCOST / CTRLNREV
             MULTIPLY  100             BY   CTRLNTPCT
             MOVE    CTRLNTPCT         TO   LN1TPCT.
           MOVE    CTRLNREV            TO   LN1REV
           IF      CTRLNFTE            =    ZEROS
             MOVE  ZEROS               TO   CTRLNSTDT
           ELSE
             COMPUTE CTRLNSTDT ROUNDED =    CTRLNTCOST / CTRLNFTE.
041006*    MOVE    CTRLNSTDT           TO   LN1STDT
041006     IF      CTRLNSTDT           >    99999
041006       MOVE  'XX,XXX'            TO   LN1STDT1
041006     ELSE
041006       MOVE  CTRLNSTDT           TO   LN1STDT.
           IF      CTRSTF1             =    ZEROS
             MOVE  ZEROS               TO   CTRLNSTF
           ELSE
             COMPUTE CTRLNSTF  ROUNDED =    CTRLNFTE / CTRSTF1.
           MOVE    CTRLNSTF            TO   LN1STF
120895     MOVE    ZEROS               TO   WSCFRM   WSCTO
           SEARCH  ALL  PGMENTRY
             WHEN  PGMPGM (PGM1)       =    OLDKPGM
               MOVE PGMFRM (PGM1)      TO   WSCFRM
               MOVE PGMTO  (PGM1)      TO   WSCTO.
           IF      WSCFRM              >    CTRLNSTDT             OR
                   WSCTO               <    CTRLNSTDT
             MOVE  WSCFRM              TO   LN1FRM
             MOVE  WSCTO               TO   LN1TO
112895*      MOVE  '** '               TO   LN1CHAR1
112895       MOVE  '**'                TO   LN1CHAR1
             MOVE  ' - '               TO   LN1CHAR2.
           PERFORM 520-PRINT           THRU 520-EXIT
           ADD     CTRLNFTE            TO   CTRSQFTE
           ADD     CTRLNDIR            TO   CTRSQDIR
           ADD     CTRLNSCOST          TO   CTRSQSCOST
           ADD     CTRLNTCOST          TO   CTRSQTCOST
           ADD     CTRLNREV            TO   CTRSQREV
           ADD     CTRSTF1             TO   CTRSTF2.
       615-EXIT.
           EXIT.

       620-2CHG.
           MOVE    SRTKSEQ             TO   OLDKSEQ
           INITIALIZE                  CTRLVL2
           PERFORM 610-1CHG            THRU 610-EXIT.
       620-EXIT.
           EXIT.

       625-2TOT.
           MOVE    OLDKDIST            TO   FRSKEY
           MOVE    OLDKFY              TO   FRSFY
           MOVE    'FRS'               TO   FRSPREF
           MOVE    OLDKSEQ             TO   FRSFRS
           MOVE    FRSKEY              TO   CRFDK
           READ    CRF-DISK
           IF      RETCRF              NOT  =  '00'
             MOVE  'UNKNOWN'           TO   FRSABBR
           ELSE
             MOVE  CRFD                TO   FRS.
           MOVE    '0'                 TO   CTLCHAR
041103     MOVE    SPACES              TO   LN2
           MOVE    FRSABBR             TO   LN2MSG
           MOVE    CTRSQFTE            TO   LN2FTE
           MOVE    CTRSQDIR            TO   LN2DIR
           MOVE    CTRSQSCOST          TO   LN2SCOST
           MOVE    CTRSQTCOST          TO   LN2TCOST
           IF      CTRSQREV            =    ZEROS
             MOVE  ZEROS               TO   CTRSQDPCT  LN2DPCT
                                            CTRSQSPCT  LN2SPCT
                                            CTRSQTPCT  LN2TPCT
           ELSE
             COMPUTE CTRSQDPCT ROUNDED =    CTRSQDIR   / CTRSQREV
             MULTIPLY  100             BY   CTRSQDPCT
             MOVE    CTRSQDPCT         TO   LN2DPCT
             COMPUTE CTRSQSPCT ROUNDED =    CTRSQSCOST / CTRSQREV
             MULTIPLY  100             BY   CTRSQSPCT
             MOVE    CTRSQSPCT         TO   LN2SPCT
             COMPUTE CTRSQTPCT ROUNDED =    CTRSQTCOST / CTRSQREV
             MULTIPLY  100             BY   CTRSQTPCT
             MOVE    CTRSQTPCT         TO   LN2TPCT.
           MOVE    CTRSQREV            TO   LN2REV
           IF      CTRSQFTE            =    ZEROS
             MOVE  ZEROS               TO   CTRSQSTDT
           ELSE
             COMPUTE CTRSQSTDT ROUNDED =    CTRSQTCOST / CTRSQFTE.
           MOVE    CTRSQSTDT           TO   LN2STDT
           IF      CTRSTF2             =    ZEROS
             MOVE  ZEROS               TO   CTRSQSTF
           ELSE
             COMPUTE CTRSQSTF  ROUNDED =    CTRSQFTE / CTRSTF2.
           MOVE    CTRSQSTF            TO   LN2STF
           PERFORM 520-PRINT           THRU 520-EXIT
           MOVE    '0'                 TO   CTLCHAR
           ADD     CTRSQFTE            TO   CTRSCFTE
           ADD     CTRSQDIR            TO   CTRSCDIR
           ADD     CTRSQSCOST          TO   CTRSCSCOST
           ADD     CTRSQTCOST          TO   CTRSCTCOST
           ADD     CTRSQREV            TO   CTRSCREV
           ADD     CTRSTF2             TO   CTRSTF3.
       625-EXIT.
           EXIT.

       630-3CHG.
           MOVE    SRTKSCHL            TO   OLDKSCHL  HD4SCHL
           MOVE    SRTKDIST            TO   SCLKEY
           MOVE    SRTKFY              TO   SCLFY
           MOVE    'SCL'               TO   SCLPREF
           MOVE    SRTKSCHL            TO   SCLSCL
           MOVE    SCLKEY              TO   CRFDK
           READ    CRF-DISK
           IF      RETCRF              NOT  =  '00'
             MOVE  'UNKNOWN'           TO   SCLDESC
           ELSE
             MOVE  CRFD                TO   SCL.
           MOVE    SCLDESC             TO   HD4DESC
           INITIALIZE                  CTRLVL3
           MOVE    +61                 TO   CTRLN
           PERFORM 620-2CHG            THRU 620-EXIT.
       630-EXIT.
           EXIT.

       635-3TOT.
           MOVE    '0'                 TO   CTLCHAR
041103     MOVE    SPACES              TO   LN3
           MOVE    'SCHL '             TO   LN3MSG
           MOVE    OLDKSCHL            TO   LN3FLD
           MOVE    CTRSCFTE            TO   LN3FTE
           MOVE    CTRSCDIR            TO   LN3DIR
           MOVE    CTRSCSCOST          TO   LN3SCOST
           MOVE    CTRSCTCOST          TO   LN3TCOST
           IF      CTRSCREV            =    ZEROS
             MOVE  ZEROS               TO   CTRSCDPCT  LN3DPCT
                                            CTRSCSPCT  LN3SPCT
                                            CTRSCTPCT  LN3TPCT
           ELSE
             COMPUTE CTRSCDPCT ROUNDED =    CTRSCDIR   / CTRSCREV
             MULTIPLY  100             BY   CTRSCDPCT
             MOVE    CTRSCDPCT         TO   LN3DPCT
             COMPUTE CTRSCSPCT ROUNDED =    CTRSCSCOST / CTRSCREV
             MULTIPLY  100             BY   CTRSCSPCT
             MOVE    CTRSCSPCT         TO   LN3SPCT
             COMPUTE CTRSCTPCT ROUNDED =    CTRSCTCOST / CTRSCREV
             MULTIPLY  100             BY   CTRSCTPCT
             MOVE    CTRSCTPCT         TO   LN3TPCT.
           MOVE    CTRSCREV            TO   LN3REV
           IF      CTRSCFTE            =    ZEROS
             MOVE  ZEROS               TO   CTRSCSTDT
           ELSE
             COMPUTE CTRSCSTDT ROUNDED =    CTRSCTCOST / CTRSCFTE.
           MOVE    CTRSCSTDT           TO   LN3STDT
           IF      CTRSTF3             =    ZEROS
             MOVE  ZEROS               TO   CTRSCSTF
           ELSE
             COMPUTE CTRSCSTF  ROUNDED =    CTRSCFTE / CTRSTF3.
           MOVE    CTRSCSTF            TO   LN3STF
           PERFORM 520-PRINT           THRU 520-EXIT
           ADD     CTRSCFTE            TO   CTRRQFTE
           ADD     CTRSCDIR            TO   CTRRQDIR
           ADD     CTRSCSCOST          TO   CTRRQSCOST
           ADD     CTRSCTCOST          TO   CTRRQTCOST
           ADD     CTRSCREV            TO   CTRRQREV
           ADD     CTRSTF3             TO   CTRSTF4.
       635-EXIT.
           EXIT.

       640-4CHG.
           MOVE     ZEROS              TO   CTRLN    CTRPG
           INITIALIZE  CTRLVL4
           MOVE     SRTKREQ            TO   OLDKREQ
           MOVE     SRTKDIST           TO   OLDKDIST
           MOVE     SRTKFY             TO   OLDKFY
           MOVE     SRTPRT             TO   OLDPRT
           MOVE     SRTSRC             TO   OLDSRC

           MOVE     '    SCL0000'      TO   SCLKEY
           MOVE     SRTKDIST           TO   SCLDIST
           MOVE     SRTKFY             TO   SCLFY
           MOVE     SCLKEY             TO   CRFDK
           READ     CRF-DISK
           IF       RETCRF             NOT  =   '00'
             MOVE   'UNKNOWN'          TO   HD1ABBR
           ELSE
             MOVE   CRFD               TO   SCL
             MOVE   SCLABBR            TO   HD1ABBR.
           SET     HD11                TO   +15.
       640-REQ.
           IF      HD1B         (HD11) =    SPACES
             SET   HD11                DOWN BY  +1
             GO                        TO   640-REQ.
           SET     HD11                UP   BY  +1
           MOVE    '-'                 TO   HD1B         (HD11)
           SET     HD11                UP   BY  +1
           MOVE    SRTKREQ1            TO   HD1B         (HD11)
           SET     HD11                UP   BY  +1
           MOVE    SRTKREQ2            TO   HD1B         (HD11)
           SET     HD11                UP   BY  +1
           MOVE    SRTKREQ3            TO   HD1B         (HD11)
           SET     HD11                UP   BY  +1
           MOVE    '-'                 TO   HD1B         (HD11)
           SET     HD11                UP   BY  +1
           MOVE    SRTKFY1             TO   HD1B         (HD11)
           SET     HD11                UP   BY  +1
           MOVE    SRTKFY2             TO   HD1B         (HD11).

           SET     RQH1                TO   +1.
       640-HEAD.
           IF      RQHREQ       (RQH1) NOT  =   HIGH-VALUES
             IF      RQHREQ     (RQH1) NOT  =   SRTKREQ
               SET   RQH1              UP   BY  +1
               GO                      TO   640-HEAD
             ELSE
               IF      RQHID    (RQH1) =    'H1'
                 MOVE  RQHHEAD  (RQH1) TO   HD2HEAD
                 MOVE  RQHUSER  (RQH1) TO   HD1USER
                 SET   RQH1            UP   BY  +1
                 GO                    TO   640-HEAD
               ELSE
                 IF      RQHID  (RQH1) =    'H2'
                   MOVE  RQHHEAD (RQH1) TO  HD3HEAD
                   SET   RQH1          UP   BY  +1
                   GO                  TO   640-HEAD.
           IF        OLDPRT            =    'N'
             MOVE    SPACES            TO   HD2HEAD       HD1USER
             MOVE    SPACES            TO   HD3HEAD
           ELSE
             IF      OLDPRT            =    'U'
               MOVE  SPACES            TO   HD2HEAD       HD3HEAD
             ELSE
               IF    OLDPRT            =    'T'
                 MOVE  SPACES          TO   HD1USER.

           PERFORM 630-3CHG            THRU 630-EXIT
           PERFORM 525-HEADS           THRU 525-EXIT.
       640-EXIT.
           EXIT.

       645-4TOT.
           MOVE    'Y'                 TO   WSCLAST
           MOVE    +61                 TO   CTRLN
           MOVE    '0'                 TO   CTLCHAR
041103     MOVE    SPACES              TO   LN3
           MOVE    'REQ  '             TO   LN3MSG
           MOVE    OLDKREQ             TO   LN3FLD
           MOVE    CTRRQFTE            TO   LN3FTE
           MOVE    CTRRQDIR            TO   LN3DIR
           MOVE    CTRRQSCOST          TO   LN3SCOST
           MOVE    CTRRQTCOST          TO   LN3TCOST
           IF      CTRRQREV            =    ZEROS
             MOVE  ZEROS               TO   CTRRQDPCT  LN3DPCT
                                            CTRRQSPCT  LN3SPCT
                                            CTRRQTPCT  LN3TPCT
           ELSE
             COMPUTE CTRRQDPCT ROUNDED =    CTRRQDIR   / CTRRQREV
             MULTIPLY  100             BY   CTRRQDPCT
             MOVE    CTRRQDPCT         TO   LN3DPCT
             COMPUTE CTRRQSPCT ROUNDED =    CTRRQSCOST / CTRRQREV
             MULTIPLY  100             BY   CTRRQSPCT
             MOVE    CTRRQSPCT         TO   LN3SPCT
             COMPUTE CTRRQTPCT ROUNDED =    CTRRQTCOST / CTRRQREV
             MULTIPLY  100             BY   CTRRQTPCT
             MOVE    CTRRQTPCT         TO   LN3TPCT.
           MOVE    CTRRQREV            TO   LN3REV
           IF      CTRRQFTE            =    ZEROS
             MOVE  ZEROS               TO   CTRRQSTDT
           ELSE
             COMPUTE CTRRQSTDT ROUNDED =    CTRRQTCOST / CTRRQFTE.
           MOVE    CTRRQSTDT           TO   LN3STDT
           IF      CTRSTF4             =    ZEROS
             MOVE  ZEROS               TO   CTRRQSTF
           ELSE
             COMPUTE CTRRQSTF  ROUNDED =    CTRRQFTE / CTRSTF4.
           MOVE    CTRRQSTF            TO   LN3STF
           PERFORM 520-PRINT           THRU 520-EXIT.
       645-EXIT.
           EXIT.

      ******************************************************************
       700-FPG-EDIT.
       700-EXIT.
           EXIT.

      ******************************************************************
       990-HOUSEKEEPING.
           PERFORM 510-READ            THRU 510-EXIT
           ACCEPT  SYSDATE             FROM DATE
           MOVE    SYSYY               TO   HD1YY
           MOVE    SYSMM               TO   HD1MM
           MOVE    SYSDD               TO   HD1DD
           ACCEPT  SYSTIME             FROM TIME
           MOVE    SYSHR               TO   HD1HR
           MOVE    SYSMIN              TO   HD1MN
           IF      SRTKEY              =    HIGH-VALUES
             MOVE  'EW031 NO DATA TO PROCESS'  TO  LNM
             PERFORM 520-PRINT         THRU 520-EXIT
             GO                        TO   999-EOJ.
           PERFORM 640-4CHG            THRU 640-EXIT.
       990-EXIT.
           EXIT.

      ******************************************************************
       999-EOJ.
           CLOSE                       CRD-CARD      CRF-DISK
                                       DRC-DISK      RWF-DISK
                                       ABF-DISK      PR1-PRNT.
           IF      OLDSRC              =   'T'
             CLOSE                     DRC-TAPE.
       999-EXIT.
           EXIT.
