       IDENTIFICATION   DIVISION.                                               
       PROGRAM-ID.      EW031.                                                  
       AUTHOR.          DOE.                                                    
      *****************************************************************         
      *            COST AS A PERCENTAGE OF REVENUE (CAPOR)            *         
      *****************************************************************         
      * DATE CREATED:   06/29/95                                      *         
      *****************************************************************         
      * CALL #  - MMDDYY - PURPOSE                                    *         
      * 9508024 -        - THE PREP COST FIELDS WILL ALWAYS BE ZEROS. *         
      * 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*         
      * JA      - 050597 - MODS TO CORRECT ROUNDING ERRORS            *         
      * JA      - 091097 - MODS TO NOT PRINT IF NO FTE,TOTAL DIRECT   *         
      *                    COST, SCHOOL COST ECT.                     *         
      * JA      - 091098 - MODS TO CONSOLODATE PGMS 120-121 INTO 120  *         
      *                    AND 251-255 INTO 250.                      *         
      * FIX9903-040599   - CHG FEFP PGMS                              * EW000180
      * FIC0001-051100   - SKIP CHARTER SCHOOL RECORDS                * EW000260
      * 2001001- 033001  - DON'T ROLL PROGRAMS 251 -> 255 INTO PGM 250* EW000190
      * 2001002- 040401  - TRUNCATE RWF AMT FIELDS TO ADJUST THE      * EW000200
      *                    ROUNDING TO MATCH THE STATE                * EW000210
      * 2001003- 040401  - MODIFIED TO NOT ADD FUNCTIONS FOR FOOD     * EW000220
      *                    SERVICE AND TRANSPORTATION TO INDIRECT     * EW000230
      *                    AND DIRECT COSTS.  THOSE FIGURES COME      * EW000240
      *                    VIA THE REQUEST CARDS.                     * EW000250
      * 2001004- 091201  - FIXED FIELD SIZE PROBLEM ON REVENUE        * EW000260
      * 2002001 - 050102 - MODIFIED TO NOT ADD FOOD SERVICE AND TRANS-* 00019944
      *                    PORTATION COSTS TO ANY ADULT ED PGMS       * 00019972
      * 2003001 - 041103 - FIXED REPORT SEQUENCE TOTALS SOMETIMES     * 00019944
      *                    PRINTING INFORMATION FROM THE PREVIOUS     * 00019972
      *                    DETAIL LINE                                * 00019972
      * 2003002 - 042903 - EXPAND FIELD SIZES TO SHOW Z(10)           * 00019944
      * 2006001 - 041006 - SHOW XX,XXX IF COST PER FTE (LN1STDT)      * 00019944
      *                    EXCEEDS $99,999. XX,XXX INDICATES MAX SIZE * 00019944
      *                    OF FIELD HAS BEEN EXCEEDED.                * 00019944
      * 2006002 - 042006 - ADD FUNCTIONS 6500 & 8200.                 * 00019944
      *****************************************************************         
                                                                                
                                                                                
       ENVIRONMENT DIVISION.                                                    
                                                                                
       INPUT-OUTPUT SECTION.                                                    
       FILE-CONTROL.                                                            
                                                                                
MVS        SELECT    CRD-CARD          ASSIGN    UT-S-CARDIN.               0021
                                                                               0
MVS        SELECT    SRT-SORT          ASSIGN    DA-SORTWK.                     
                                                                                
MVS        SELECT    PR1-PRNT          ASSIGN    UT-S-PRTOT1.                   
                                                                                
MVS        SELECT    CRF-DISK          ASSIGN       DA-EWCRF                    
                                       ORGANIZATION INDEXED                     
                                       ACCESS       DYNAMIC                     
                                       RECORD KEY   CRFDK                       
                                       FILE STATUS  RETCRF.                     
                                                                                
MVS        SELECT    RWF-DISK          ASSIGN       DA-EWRWF                    
                                       ORGANIZATION INDEXED                     
                                       ACCESS       SEQUENTIAL                  
                                       RECORD KEY   RWFDK                       
                                       FILE STATUS  RETRWF.                     
                                                                                
MVS        SELECT    ABF-DISK          ASSIGN       DA-EWABF                    
                                       ORGANIZATION INDEXED                     
                                       ACCESS       DYNAMIC                     
                                       RECORD KEY   ABFDK                       
                                       FILE STATUS  RETABF.                     
                                                                                
MVS        SELECT    DRC-DISK          ASSIGN       DA-EWDRC                    
                                       ORGANIZATION SEQUENTIAL                  
                                       ACCESS       SEQUENTIAL                  
                                       FILE STATUS  RETDRC.                     
                                                                                
MVS        SELECT    DRC-TAPE          ASSIGN       UT-S-TAPE01.                
                                                                                
                                                                                
       DATA DIVISION.                                                           
       FILE SECTION.                                                            
                                                                                
       FD  CRD-CARD                                                             
           RECORDING MODE       IS  F                                       0033
           RECORD    CONTAINS   80  CHARACTERS                                  
MVS        BLOCK     CONTAINS    0  RECORDS                                 0034
           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                                                             
           RECORDING MODE       IS  F                                       0044
VSE        RECORD    CONTAINS  133  CHARACTERS                                  
MVS        BLOCK     CONTAINS    0  RECORDS                                     
           LABEL     RECORDS   ARE  OMITTED                                     
           DATA      RECORDS   ARE  LNM  LN1  LN2  LN3.                         
                                                                                
       01  LNM.                                                                 
VSE        05        FILLER            PIC  X(01).                              
002        05        LNMMSG            PIC  X(20).                              
023        05        FILLER            PIC  X(02).                              
024        05        LNMVALUE1         PIC  X(02).                              
026        05        FILLER            PIC  X(01).                              
027        05        LNMVALUE2         PIC  X(80).                              
107        05        FILLER            PIC  X(27).                              
                                                                                
       01            LN1.                                                       
VSE        05        FILLER            PIC  X(01).                              
002        05        LN1PGM            PIC  X(03).                              
005        05        FILLER            PIC  X(01).                              
006        05        LN1MSG            PIC  X(15).                              
042903*    05        FILLER            PIC  X(01).                              
042903*    05        LN1FTE            PIC  ZZZ,ZZZ.ZZ.                         
042903     05        LN1FTE            PIC  ZZZZ,ZZZ.ZZ.                        
032        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.                       
060        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.                       
074        05        LN1ERR4           PIC  X(01).                              
075        05        FILLER            PIC  X(02).                              
075        05        LN1DPCT           PIC  ZZZ.                                
078        05        FILLER            PIC  X(01).                              
079        05        LN1SPCT           PIC  ZZZ.                                
082        05        FILLER            PIC  X(01).                              
083        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.                       
100        05        LN1ERR5           PIC  X(01).                              
101        05        LN1STDT           PIC  ZZ,ZZZ.                             
041006     05        LN1STDT9 REDEFINES LN1STDT.                                
041006       10      LN1STDT1          PIC  XXXXXX.                             
107        05        FILLER            PIC  X(01).                              
108        05        LN1STF            PIC  ZZZ.ZZ.                             
114        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.                                                       
VSE        05        FILLER            PIC  X(01).                              
002        05        FILLER            PIC  X(04).                              
006        05        LN2MSG            PIC  X(15).                              
021        05        FILLER            PIC  X(01).                              
022        05        LN2FTE            PIC  ZZZ,ZZZ.ZZ.                         
032        05        FILLER            PIC  X(01).                              
033        05        LN2DIR            PIC  Z,ZZZ,ZZZ,ZZZ.                      
046        05        FILLER            PIC  X(01).                              
047        05        LN2SCOST          PIC  Z,ZZZ,ZZZ,ZZZ.                      
060        05        FILLER            PIC  X(01).                              
061        05        LN2TCOST          PIC  Z,ZZZ,ZZZ,ZZZ.                      
074        05        FILLER            PIC  X(01).                              
112895     05        FILLER            PIC  X(02).                              
075        05        LN2DPCT           PIC  ZZZ.                                
078        05        FILLER            PIC  X(01).                              
079        05        LN2SPCT           PIC  ZZZ.                                
082        05        FILLER            PIC  X(01).                              
083        05        LN2TPCT           PIC  ZZZ.                                
086        05        FILLER            PIC  X(01).                              
087        05        LN2REV            PIC  Z,ZZZ,ZZZ,ZZZ.                      
100        05        FILLER            PIC  X(01).                              
101        05        LN2STDT           PIC  ZZ,ZZZ.                             
107        05        FILLER            PIC  X(01).                              
108        05        LN2STF            PIC  ZZZ.ZZ.                             
112895*    05        FILLER            PIC  X(20).                              
112895     05        FILLER            PIC  X(18).                              
                                                                                
       01            LN3.                                                       
VSE        05        FILLER            PIC  X(01).                              
002        05        FILLER            PIC  X(04).                              
006        05        LN3MSG            PIC  X(05).                              
011        05        LN3FLD            PIC  X(04).                              
015        05        FILLER            PIC  X(07).                              
022        05        LN3FTE            PIC  ZZZ,ZZZ.ZZ.                         
032        05        FILLER            PIC  X(01).                              
033        05        LN3DIR            PIC  Z,ZZZ,ZZZ,ZZZ.                      
046        05        FILLER            PIC  X(01).                              
047        05        LN3SCOST          PIC  Z,ZZZ,ZZZ,ZZZ.                      
060        05        FILLER            PIC  X(01).                              
061        05        LN3TCOST          PIC  Z,ZZZ,ZZZ,ZZZ.                      
074        05        FILLER            PIC  X(01).                              
112895     05        FILLER            PIC  X(02).                              
075        05        LN3DPCT           PIC  ZZZ.                                
078        05        FILLER            PIC  X(01).                              
079        05        LN3SPCT           PIC  ZZZ.                                
082        05        FILLER            PIC  X(01).                              
083        05        LN3TPCT           PIC  ZZZ.                                
086        05        FILLER            PIC  X(01).                              
087        05        LN3REV            PIC  Z,ZZZ,ZZZ,ZZZ.                      
100        05        FILLER            PIC  X(01).                              
101        05        LN3STDT           PIC  ZZ,ZZZ.                             
107        05        FILLER            PIC  X(01).                              
108        05        LN3STF            PIC  ZZZ.ZZ.                             
112895*    05        FILLER            PIC  X(20).                              
112895     05        FILLER            PIC  X(18).                              
                                                                                
           COPY                        EWCRFD.                                  
           COPY                        EWRWFD.                                  
           COPY                        EWABFD.                                  
           COPY                        EWDRCD.                                  
           COPY                        EWDRCT.                                  
                                                                                
       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.                                                   
JA0997*      10      SRTDIRECT         PIC  S9(11).                             
JA0997*      10      SRTSIND           PIC  S9(11).                             
JA0997*      10      SRTDIND           PIC  S9(11).                             
JA0997       10      SRTDIRECT         PIC  S9(11)V9(7).                        
JA0997       10      SRTSIND           PIC  S9(11)V9(7).                        
JA0997       10      SRTDIND           PIC  S9(11)V9(7).                        
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.                                                 
JA0998 77  I1                          PIC S9(03) COMP SYNC    VALUE +0.    0065
                                                                                
       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.               EW002910
                                                                                
       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.                                                  
JA0997*      10      CTRSIND          PIC S9(11)       VALUE +0.                
JA0997*      10      CTRDIND          PIC S9(11)       VALUE +0.                
JA0997       10      CTRSIND          PIC S9(11)V9(7)  VALUE +0.                
JA0997       10      CTRDIND          PIC S9(11)V9(7)  VALUE +0.                
             10      CTRSTF1          PIC S9(04)V9(03) VALUE +0.                
           05        CTRLVL1.                                                   
             10      CTRLNFTE         PIC S9(07)V9(02) VALUE +0.                
JA0997*      10      CTRLNDIR         PIC S9(09)       VALUE +0.                
JA0997*      10      CTRLNSCOST       PIC S9(09)       VALUE +0.                
JA0997*      10      CTRLNTCOST       PIC S9(09)       VALUE +0.                
JA0997       10      CTRLNDIR         PIC S9(09)V9(7)  VALUE +0.                
JA0997       10      CTRLNSCOST       PIC S9(09)V9(7)  VALUE +0.                
JA0997       10      CTRLNTCOST       PIC S9(09)V9(7)  VALUE +0.                
             10      CTRLNDPCT        PIC S9(03)V9(02) VALUE +0.                
             10      CTRLNSPCT        PIC S9(03)V9(02) VALUE +0.                
             10      CTRLNTPCT        PIC S9(03)V9(02) VALUE +0.                
             10      CTRLNREV         PIC S9(09)       VALUE +0.                
JA0997*      10      CTRLNSTDT        PIC S9(05)       VALUE +0.                
JA0997*04100610      CTRLNSTDT        PIC S9(05)V9(7)  VALUE +0.                
041006       10      CTRLNSTDT        PIC S9(09)       VALUE +0.                
             10      CTRLNSTF         PIC S9(03)V9(02) VALUE +0.                
           05        CTRLVL2.                                                   
             10      CTRSQFTE         PIC S9(07)V9(02)        VALUE +0.         
JA0997*      10      CTRSQDIR         PIC S9(11)              VALUE +0.         
JA0997*      10      CTRSQSCOST       PIC S9(11)              VALUE +0.         
JA0997*      10      CTRSQTCOST       PIC S9(11)              VALUE +0.         
JA0997       10      CTRSQDIR         PIC S9(11)V9(7)         VALUE +0.         
JA0997       10      CTRSQSCOST       PIC S9(11)V9(7)         VALUE +0.         
JA0997       10      CTRSQTCOST       PIC S9(11)V9(7)         VALUE +0.         
             10      CTRSQDPCT        PIC S9(03)V9(02)        VALUE +0.         
             10      CTRSQSPCT        PIC S9(03)V9(02)        VALUE +0.         
             10      CTRSQTPCT        PIC S9(03)V9(02)        VALUE +0.         
             10      CTRSQREV         PIC S9(11)              VALUE +0.         
JA0997*      10      CTRSQSTDT        PIC S9(05)              VALUE +0.         
JA0997       10      CTRSQSTDT        PIC S9(05)V9(7)         VALUE +0.         
             10      CTRSQSTF         PIC S9(03)V9(02)        VALUE +0.         
             10      CTRSTF2          PIC S9(04)V9(03)        VALUE +0.         
           05        CTRLVL3.                                                   
             10      CTRSCFTE         PIC S9(07)V9(02)        VALUE +0.         
JA0997*      10      CTRSCDIR         PIC S9(11)              VALUE +0.         
JA0997*      10      CTRSCSCOST       PIC S9(11)              VALUE +0.         
JA0997*      10      CTRSCTCOST       PIC S9(11)              VALUE +0.         
JA0997       10      CTRSCDIR         PIC S9(11)V9(7)         VALUE +0.         
JA0997       10      CTRSCSCOST       PIC S9(11)V9(7)         VALUE +0.         
JA0997       10      CTRSCTCOST       PIC S9(11)V9(7)         VALUE +0.         
             10      CTRSCDPCT        PIC S9(03)V9(02)        VALUE +0.         
             10      CTRSCSPCT        PIC S9(03)V9(02)        VALUE +0.         
             10      CTRSCTPCT        PIC S9(03)V9(02)        VALUE +0.         
             10      CTRSCREV         PIC S9(11)              VALUE +0.         
JA0997*      10      CTRSCSTDT        PIC S9(05)              VALUE +0.         
JA0997       10      CTRSCSTDT        PIC S9(05)V9(7)         VALUE +0.         
             10      CTRSCSTF         PIC S9(03)V9(02)        VALUE +0.         
             10      CTRSTF3          PIC S9(04)V9(03)        VALUE +0.         
           05        CTRLVL4.                                                   
             10      CTRRQFTE         PIC S9(07)V9(02)        VALUE +0.         
JA0997*      10      CTRRQDIR         PIC S9(11)              VALUE +0.         
JA0997*      10      CTRRQSCOST       PIC S9(11)              VALUE +0.         
JA0997*      10      CTRRQTCOST       PIC S9(11)              VALUE +0.         
JA0997       10      CTRRQDIR         PIC S9(11)V9(7)         VALUE +0.         
JA0997       10      CTRRQSCOST       PIC S9(11)V9(7)         VALUE +0.         
JA0997       10      CTRRQTCOST       PIC S9(11)V9(7)         VALUE +0.         
             10      CTRRQDPCT        PIC S9(03)V9(02)        VALUE +0.         
             10      CTRRQSPCT        PIC S9(03)V9(02)        VALUE +0.         
             10      CTRRQTPCT        PIC S9(03)V9(02)        VALUE +0.         
             10      CTRRQREV         PIC S9(11)              VALUE +0.         
JA0997*      10      CTRRQSTDT        PIC S9(05)              VALUE +0.         
JA0997       10      CTRRQSTDT        PIC S9(05)V9(7)         VALUE +0.         
             10      CTRRQSTF         PIC S9(03)V9(02)        VALUE +0.         
             10      CTRSTF4          PIC S9(04)V9(03)        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.                                   
           COPY                        EWFPG.                                   
           COPY                        EWFRS.                                   
           COPY                        EWRWF.                                   
           COPY                        EWABF.                                   
           COPY                        EWDRC.                                   
                                                                                
       01            OLDLN             PIC  X(134).                             
                                                                                
       01      HD1.                                                             
VSE        05  FILLER  PIC X(01) VALUE ' '.                                     
002        05  FILLER  PIC X(06) VALUE 'EW031 '.                                
           05  HD1ABBR.                                                         
008         10 HD1B    OCCURS 22 TIMES INDEXED BY HD11 PIC X(01).               
030        05  FILLER  PIC X(11) VALUE SPACES.                                  
041        05  HD1MODE PIC X(08) VALUE SPACES.                                  
049        05  FILLER  PIC X(04) VALUE SPACES.                                  
053        05  FILLER  PIC X(21) VALUE 'COST AS A PERCENTAGE '.                 
074        05  FILLER  PIC X(10) VALUE 'OF REVENUE'.                            
084        05  FILLER  PIC X(15) VALUE SPACES.                                  
099        05  HD1USER PIC X(09) VALUE SPACES.                                  
108        05  HD1MM   PIC X(02) VALUE SPACES.                                  
110        05  FILLER  PIC X(01) VALUE '/'.                                     
111        05  HD1DD   PIC X(02) VALUE SPACES.                                  
113        05  FILLER  PIC X(01) VALUE '/'.                                     
114        05  HD1YY   PIC X(02) VALUE SPACES.                                  
116        05  FILLER  PIC X(02) VALUE SPACES.                                  
118        05  HD1HR   PIC X(02) VALUE SPACES.                                  
120        05  FILLER  PIC X(01) VALUE ':'.                                     
121        05  HD1MN   PIC X(02) VALUE SPACES.                                  
123        05  FILLER  PIC X(07) VALUE '  PAGE-'.                               
130        05  HD1PG   PIC ZZZ9.                                                
                                                                                
041397 01      HD1A.                                                            
VSE   *    05  FILLER  PIC X(01) VALUE ' '.                                     
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.                                                             
VSE        05  FILLER  PIC X(01) VALUE ' '.                                     
002        05  FILLER  PIC X(41) VALUE SPACES.                                  
           05  HD2HEAD.                                                         
043         10 HD2B    OCCURS 50 TIMES INDEXED BY HD21 PIC X(01).               
093        05  FILLER  PIC X(41) VALUE SPACES.                                  
                                                                                
       01      HD3.                                                             
VSE        05  FILLER  PIC X(01) VALUE ' '.                                     
002        05  FILLER  PIC X(41) VALUE SPACES.                                  
           05  HD3HEAD.                                                         
043         10 HD3B    OCCURS 50 TIMES INDEXED BY HD31 PIC X(01).               
093        05  FILLER  PIC X(41) VALUE SPACES.                                  
                                                                                
       01      HD4.                                                             
VSE        05  FILLER  PIC X(01) VALUE ' '.                                     
002        05  FILLER  PIC X(06) VALUE 'SCHL- '.                                
008        05  HD4SCHL PIC X(04) VALUE SPACES.                                  
012        05  FILLER  PIC X(01) VALUE SPACES.                                  
013        05  HD4DESC PIC X(30) VALUE SPACES.                                  
043        05  FILLER  PIC X(91) VALUE SPACES.                                  
                                                                                
       01      HD5.                                                             
VSE        05  FILLER  PIC X(01) VALUE ' '.                                     
006        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 '.                              
100        05  FILLER  PIC X(34) VALUE                                          
                     'SUPPLEMENT AND TRANSFER ONLY).    '.                      
                                                                                
       01      HD6.                                                             
VSE        05  FILLER  PIC X(01) VALUE ' '.                                     
002        05  FILLER  PIC X(39) VALUE SPACES.                                  
041        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     '.                 
120        05  FILLER  PIC X(14) VALUE SPACES.                                  
                                                                                
       01      HD7.                                                             
VSE        05  FILLER  PIC X(01) VALUE ' '.                                     
002        05  FILLER  PIC X(19) VALUE '----- PROGRAM -----'.                   
021        05  FILLER  PIC X(19) VALUE SPACES.                                  
040        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    '.                 
119        05  FILLER  PIC X(15) VALUE SPACES.                                  
                                                                                
       01      HD8.                                                             
VSE        05  FILLER  PIC X(01) VALUE ' '.                                     
002        05  FILLER  PIC X(03) VALUE 'NBR'.                                   
005        05  FILLER  PIC X(24) VALUE SPACES.                                  
029        05  FILLER  PIC X(03) VALUE 'FTE'.                                   
032        05  FILLER  PIC X(09) VALUE SPACES.                                  
041        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'.                
081        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.                                  
                                                                                
       PROCEDURE DIVISION.                                                      
      ******************************************************************        
           SORT    SRT-SORT            ASCENDING KEY       SRTKEY               
                                       INPUT     PROCEDURE 000-INPUT            
                                       OUTPUT    PROCEDURE 500-OUTPUT.          
           STOP                        RUN.                                     
                                                                                
      ******************************************************************        
       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                    EW006480
040401         IF  RWFPGM              >    SPACES                      EW006490
040401           PERFORM 014-TRUNC     THRU 014-EXIT                    EW006500
040401           GO                    TO   010-EXIT                    EW006510
040401         ELSE                                                     EW006520
               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                    EW006630
               GO                      TO   010-EXIT.                           
                                                                                
           IF      RETDRC              =    '00'                                
             READ    DRC-DISK          NEXT                                     
             IF     (RETDRC            NOT  =   '00')                           
               MOVE  '99'              TO   RETDRC                              
             ELSE                                                               
               MOVE  DRCD              TO   DRC                                 
JA0998         MOVE  ZERO              TO   I1                                  
JA0998         PERFORM 010-LOOP        THRU 010-LOOP-EXIT                       
               MOVE  'D'               TO   WSCFILE                             
040599         PERFORM 012-CONV-PGM    THRU 012-EXIT                    EW006730
               GO                      TO   010-EXIT.                           
                                                                                
           IF      RETDRCT             =    '00'                                
             READ  DRC-TAPE            AT   END                                 
               CLOSE                   DRC-TAPE                                 
               MOVE '99'               TO   RETDRCT.                            
                                                                                
           IF    RETDRCT               =  '00'                                  
             MOVE  DRCT                TO   DRC                                 
JA0998       MOVE  ZERO                TO   I1                                  
JA0998       PERFORM 010-LOOP          THRU 010-LOOP-EXIT                       
             MOVE  'D'                 TO   WSCFILE                             
040599       PERFORM 012-CONV-PGM      THRU 012-EXIT                    EW006730
             GO                        TO   010-EXIT.                           
                                                                                
       010-EXIT.                                                                
           EXIT.                                                                
JA0998 010-LOOP.                                                                
JA0998     ADD   +1                    TO   I1                                  
JA0998     IF    I1                    >    7                                   
JA0998           GO                    TO   010-LOOP-EXIT.                      
JA0998     IF    DRCPGM (I1)           =    '121'                               
JA0998           MOVE '120'            TO   DRCPGM (I1)                         
JA0998     ELSE                                                                 
JA0998     IF  ((DRCPGM (I1)           >    '250') AND                          
JA0998          (DRCPGM (I1)           <    '256'))                             
JA0998           MOVE '250'            TO   DRCPGM (I1).                        
JA0998     GO                          TO   010-LOOP.                           
JA0998 010-LOOP-EXIT.                                                           
           EXIT.                                                                
040599******************************************************************EW006890
040599 012-CONV-PGM.                                                    EW006900
040599     IF      WSCFILE             =     'R'                        EW006910
040599        IF   RWFPGM              =     '121'                      EW006920
033001         MOVE  '120'             TO    RWFPGM.                    EW006930
033001*        MOVE  '120'             TO    RWFPGM                     EW006940
033001*      ELSE                                                       EW006950
033001*        IF   RWFPGM             >   '250'                    AND EW006960
033001*             RWFPGM             <   '256'                        EW006970
033001*           MOVE  '250'          TO  RWFPGM.                      EW006980
040599*                                                                 EW006990
040599     IF       WSCFILE            =   'A'                          EW007000
040599        IF    ABFPGM             =   '121'                        EW007010
033001           MOVE '120'            TO  ABFPGM.                      EW007020
033001*          MOVE '120'            TO  ABFPGM                       EW007030
033001*       ELSE                                                      EW007040
033001*          IF  ABFPGM            >   '250'                    AND EW007050
033001*              ABFPGM            <   '256'                        EW007060
033001*            MOVE  '250'         TO  ABFPGM.                      EW007070
040599*                                                                 EW007080
040599     IF        WSCFILE           NOT =  'D'                       EW007090
040599      GO                         TO  012-EXIT.                    EW007100
040599                                                                  EW007110
040599     SET       DRC1              TO  +1.                          EW007120
040599 012-LOOP.                                                        EW007130
040599     IF        DRCPGM   (DRC1)   =   '121'                        EW007140
033001       MOVE    '120'             TO  DRCPGM    (DRC1).            EW007150
033001*      MOVE    '120'             TO  DRCPGM    (DRC1)             EW007160
033001*    ELSE                                                         EW007170
033001*      IF    DRCPGM   (DRC1)     >   '250'              AND       EW007180
033001*            DRCPGM   (DRC1)     <   '256'                        EW007190
033001*        MOVE  '250'             TO  DRCPGM    (DRC1).            EW007200
040599     IF      DRC1                <   +7                           EW007210
040599        SET  DRC1                UP  BY  +1                       EW007220
040599        GO                       TO  012-LOOP.                    EW007230
040599                                                                  EW007240
040599 012-EXIT.                                                        EW007250
040599     EXIT.                                                        EW007260
040599                                                                  EW007270
040401 014-TRUNC.                                                       EW007290
040401                                                                  EW007300
040401     MOVE    RWFDSAL             TO   WSCTRUNC                    EW007310
040401     MOVE    WSCTRUNC            TO   RWFDSAL                     EW007320
040401                                                                  EW007330
040401     MOVE    RWFDBEN             TO   WSCTRUNC                    EW007340
040401     MOVE    WSCTRUNC            TO   RWFDBEN                     EW007350
040401                                                                  EW007360
040401     MOVE    RWFDPRCH            TO   WSCTRUNC                    EW007370
040401     MOVE    WSCTRUNC            TO   RWFDPRCH                    EW007380
040401                                                                  EW007390
040401     MOVE    RWFDMATSUP          TO   WSCTRUNC                    EW007400
040401     MOVE    WSCTRUNC            TO   RWFDMATSUP                  EW007410
040401                                                                  EW007420
040401     MOVE    RWFDOTHER           TO   WSCTRUNC                    EW007430
040401     MOVE    WSCTRUNC            TO   RWFDOTHER                   EW007440
040401                                                                  EW007450
040401     MOVE    RWFDCAP             TO   WSCTRUNC                    EW007460
040401     MOVE    WSCTRUNC            TO   RWFDCAP                     EW007470
040401                                                                  EW007480
040401                                                                  EW007490
040401     MOVE    RWFSI6100           TO   WSCTRUNC                    EW007500
040401     MOVE    WSCTRUNC            TO   RWFSI6100                   EW007510
040401                                                                  EW007520
040401     MOVE    RWFSI6200           TO   WSCTRUNC                    EW007530
040401     MOVE    WSCTRUNC            TO   RWFSI6200                   EW007540
040401                                                                  EW007550
040401     MOVE    RWFSI6300           TO   WSCTRUNC                    EW007560
040401     MOVE    WSCTRUNC            TO   RWFSI6300                   EW007570
040401                                                                  EW007580
040401     MOVE    RWFSI6400           TO   WSCTRUNC                    EW007590
040401     MOVE    WSCTRUNC            TO   RWFSI6400                   EW007600
040401                                                                  EW007610
042006     MOVE    RWFSI6500           TO   WSCTRUNC                            
042006     MOVE    WSCTRUNC            TO   RWFSI6500                           
042006                                                                          
040401     MOVE    RWFSI7300           TO   WSCTRUNC                    EW007620
040401     MOVE    WSCTRUNC            TO   RWFSI7300                   EW007630
040401                                                                  EW007640
040401     MOVE    RWFSI7400           TO   WSCTRUNC                    EW007650
040401     MOVE    WSCTRUNC            TO   RWFSI7400                   EW007660
040401                                                                  EW007670
040401     MOVE    RWFSI7600           TO   WSCTRUNC                    EW007680
040401     MOVE    WSCTRUNC            TO   RWFSI7600                   EW007690
040401                                                                  EW007700
040401     MOVE    RWFSI7700           TO   WSCTRUNC                    EW007710
040401     MOVE    WSCTRUNC            TO   RWFSI7700                   EW007720
040401                                                                  EW007730
040401     MOVE    RWFSI7800           TO   WSCTRUNC                    EW007740
040401     MOVE    WSCTRUNC            TO   RWFSI7800                   EW007750
040401                                                                  EW007760
040401     MOVE    RWFSI7900           TO   WSCTRUNC                    EW007770
040401     MOVE    WSCTRUNC            TO   RWFSI7900                   EW007780
040401                                                                  EW007790
040401     MOVE    RWFSI8100           TO   WSCTRUNC                    EW007800
040401     MOVE    WSCTRUNC            TO   RWFSI8100                   EW007810
040401                                                                  EW007820
042006     MOVE    RWFSI8200           TO   WSCTRUNC                            
042006     MOVE    WSCTRUNC            TO   RWFSI8200                           
040401                                                                  EW007830
040401     MOVE    RWFDI6100           TO   WSCTRUNC                    EW007840
040401     MOVE    WSCTRUNC            TO   RWFDI6100                   EW007850
040401                                                                  EW007860
040401     MOVE    RWFDI6200           TO   WSCTRUNC                    EW007870
040401     MOVE    WSCTRUNC            TO   RWFDI6200                   EW007880
040401                                                                  EW007890
040401     MOVE    RWFDI6300           TO   WSCTRUNC                    EW007900
040401     MOVE    WSCTRUNC            TO   RWFDI6300                   EW007910
040401                                                                  EW007920
040401     MOVE    RWFDI6400           TO   WSCTRUNC                    EW007930
040401     MOVE    WSCTRUNC            TO   RWFDI6400                   EW007940
040401                                                                  EW007950
042006     MOVE    RWFDI6500           TO   WSCTRUNC                            
042006     MOVE    WSCTRUNC            TO   RWFDI6500                           
042006                                                                          
040401     MOVE    RWFDI7100           TO   WSCTRUNC                    EW007960
040401     MOVE    WSCTRUNC            TO   RWFDI7100                   EW007970
040401                                                                  EW007980
040401     MOVE    RWFDI7200           TO   WSCTRUNC                    EW007990
040401     MOVE    WSCTRUNC            TO   RWFDI7200                   EW008000
040401                                                                  EW008010
040401     MOVE    RWFDI7400           TO   WSCTRUNC                    EW008020
040401     MOVE    WSCTRUNC            TO   RWFDI7400                   EW008030
040401                                                                  EW008040
040401     MOVE    RWFDI7500           TO   WSCTRUNC                    EW008050
040401     MOVE    WSCTRUNC            TO   RWFDI7500                   EW008060
040401                                                                  EW008070
040401     MOVE    RWFDI7600           TO   WSCTRUNC                    EW008080
040401     MOVE    WSCTRUNC            TO   RWFDI7600                   EW008090
040401                                                                  EW008100
040401     MOVE    RWFDI7700           TO   WSCTRUNC                    EW008110
040401     MOVE    WSCTRUNC            TO   RWFDI7700                   EW008120
040401                                                                  EW008130
040401     MOVE    RWFDI7800           TO   WSCTRUNC                    EW008140
040401     MOVE    WSCTRUNC            TO   RWFDI7800                   EW008150
040401                                                                  EW008160
040401     MOVE    RWFDI7900           TO   WSCTRUNC                    EW008170
040401     MOVE    WSCTRUNC            TO   RWFDI7900                   EW008180
040401                                                                  EW008190
040401     MOVE    RWFDI8100           TO   WSCTRUNC                    EW008200
040401     MOVE    WSCTRUNC            TO   RWFDI8100                   EW008210
040401                                                                  EW008220
042006     MOVE    RWFDI8200           TO   WSCTRUNC                            
042006     MOVE    WSCTRUNC            TO   RWFDI8200                           
042006                                                                          
040401     MOVE    RWFTOTAL            TO   WSCTRUNC                    EW008230
040401     MOVE    WSCTRUNC            TO   RWFTOTAL.                   EW008240
040401                                                                  EW008250
040401 014-EXIT.                                                        EW008260
040401     EXIT.                                                        EW008270
040401                                                                  EW008280
                                                                                
      ******************************************************************        
       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                 
041301            (RWFTABLE            =    '99998')         OR         EW008480
                  (RWFTABLE            =    '99999')                            
             GO                        TO   015-EXIT.                           
                                                                                
           MOVE    SPACES              TO   SRTKEY                              
           MOVE    ZEROS               TO   SRTDATA                             
           MOVE    SPACES              TO   SRTPRT  SRTSRC                      
           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       EW008720
040401                                                + RWFSI7900       EW008730
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       EW008720
040401                                                + RWFDI7900       EW008730
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.                           
                                                                                
           MOVE    SPACES              TO   SRTKEY                              
           MOVE    ZEROS               TO   SRTDATA                             
           MOVE    SPACES              TO   SRTPRT  SRTSRC                      
           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            00822600
050102*            WSCP1               NOT  =  '4'                      00823200
050102     IF      WSCPGM              NOT  =  '214'     AND            00823800
050102             WSCPGM              <    '340'                       00824400
             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.                           
                                                                                
           IF      DRCCARD             >    '7'                                 
             MOVE  'DRCCARD > 7'       TO   LNMMSG                              
             MOVE  DRC                 TO   LNMVALUE2                           
             PERFORM 520-PRINT         THRU 520-EXIT.                           
                                                                                
           MOVE    SPACES              TO   SRTKEY                              
           MOVE    ZEROS               TO   SRTDATA                             
           MOVE    SPACES              TO   SRTPRT  SRTSRC                      
           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     DRC2                TO   +1.                                 
       015-DRC-LOOP.                                                            
           IF      DRCPGM  (DRC2)      NOT  =  SPACES                           
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  (DRC2)      TO   SRTKPGM   TEMPPGM                   
             PERFORM 020-PGM           THRU 020-EXIT                            
             MOVE  TEMPSEQ             TO   SRTKSEQ                             
             MOVE  DRCREV  (DRC2)      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      DRC2                <    +7                                  
             SET   DRC2                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                             
           MOVE    ZEROS               TO   CTRFTETOT                           
           MOVE    HIGH-VALUES         TO   RQR           RQH.                  
           SET     RQH1                TO   +1.                                 
       490-LOAD.                                                                
           READ    CRD-CARD            AT   END                                 
             GO                        TO   490-TEST.                           
           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.                             
           SET     RWF1                TO   +1.                                 
       490-SET1.                                                                
           IF      RWFB     (RWF1)     =    SPACES                              
             MOVE  HIGH-VALUES         TO   RWFB (RWF1).                        
           IF      RWF1                <    +17                                 
             SET   RWF1                UP   BY  +1                              
             GO                        TO   490-SET1.                           
           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.                             
           SET     ABF1                TO   +1.                                 
       490-SET2.                                                                
           IF      ABFB     (ABF1)     =    SPACES                              
             MOVE  HIGH-VALUES         TO   ABFB (ABF1).                        
           IF      ABF1                <    +11                                 
             SET   ABF1                UP   BY  +1                              
             GO                        TO   490-SET2.                           
           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.                                                                
      ******************************************************************        
       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                
           MOVE    ZEROS               TO   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           01335600
050102*            WSCP1               =    '4'                         01336200
050102     IF      WSCPGM              =    '214'          OR           01336800
050102             WSCPGM              >    '339'                       01337400
             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           01345600
050102*            WSCP1               =    '4'                         01346200
050102     IF      WSCPGM              =    '214'          OR           01346800
050102             WSCPGM              >    '339'                       01347400
             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.                           
JA0910     IF    ((LN1ERR1             =    '*') AND                            
JA0910            (LN1ERR2             =    '*') AND                            
JA0910            (LN1ERR3             =    '*') AND                            
JA0910            (LN1ERR4             =    '*'))                               
JA0910            MOVE SPACES          TO   LN1                                 
JA0910     ELSE                                                                 
           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                             
           MOVE    ZEROS               TO   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                             
           MOVE    ZEROS               TO   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                      
           MOVE     ZEROS              TO   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.                                                                
                                                                                
      ******************************************************************        
       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.                  
       999-EXIT.                                                                
           EXIT.                                                                
