       IDENTIFICATION DIVISION.

       PROGRAM-ID.      EW48.
       AUTHOR.          DOE.
      ******************************************************************
      *                       COST BY TABLE                            *
      * COMPILE WITH SUBCOB CICS                                       *
      ******************************************************************
      * DATE CREATED:  06/25/95                                        *    0011
      ******************************************************************
      * CALL #  - MMDDYY - PURPOSE                                     *
      * 2009001 - 050409 - ALLOW FUNDS 5,6,7 FOR AARA MONEY            *
      * 2011001 - 020411 - ADD ARRA FUNDS 8 & 9                        *
      ******************************************************************

       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       DATA DIVISION.

       WORKING-STORAGE SECTION.

       01            WSC.
           05        WSCMAPLEN         PIC S9(04) COMP SYNC VALUE +0214.
           05        WSCDATE.
             10      WSCMM             PIC  X(02).
             10      WSCDD             PIC  X(02).
             10      WSCYY             PIC  X(02).
           05        WXR.
001          10      WXRREQ            PIC  X(03).
004          10      FILLER            PIC  X(01).
005          10      WXRID             PIC  X(02).
007          10      FILLER            PIC  X(01).
008          10      WXRPRT            PIC  X(01).
009          10      FILLER            PIC  X(03).
012          10      WXRDIST           PIC  X(02).
014          10      FILLER            PIC  X(02).
016          10      WXRFY             PIC  X(02).
018          10      FILLER            PIC  X(01).
019          10      WXRFUND           PIC  X(01).
020          10      FILLER            PIC  X(01).
021          10      WXRTBLE           PIC  X(05).
026          10      FILLER            PIC  X(01).
027          10      WXRSCHL           PIC  X(04).
031          10      FILLER            PIC  X(01).
032          10      WXRSUM            PIC  X(01).
033          10      FILLER            PIC  X(01).
034          10      WXRRPT            PIC  X(01).
035          10      WXRPGM            PIC  X(05).
           05        WXRR       REDEFINES   WXR.
              10     WXRB       OCCURS 039  TIMES  INDEXED BY WXR1
                                       PIC  X(01).

           COPY                        EWWXF.

       01            WSK.
           05        NEWKEY.
             10      NEWREQ.
               15    NEWREQ9           PIC  9(03).
           05        NEWPANEL.
             10      NEWPANEL1         PIC  X(01).
             10      NEWPANEL2         PIC  X(02).
           05        OLDKEY            PIC  X(03).
       01            WSKR       REDEFINES   WSK.
           05        WSKB       OCCURS 006  TIMES  INDEXED BY WSK1
                                       PIC  X(01).

       01            RET.
           05        RETQWR            PIC  X(02).
           05        RETBJR            PIC  X(02).
           05        RETERR            PIC S9(01).

       01            MSG.
           05        MSG01             PIC  X(35) VALUE
                     'District is not authorized.  EXIT.'.
           05        MSG03             PIC  X(37) VALUE
                     'Highlighted elements in error. Retry.'.
           05        MSG12             PIC  X(25) VALUE
                     'Record displayed.  Next ?'.
           05        MSG13             PIC  X(28) VALUE
                     'No previous records.  Next ?'.
           05        MSG14             PIC  X(30) VALUE
                     'No additional records.  Next ?'.
           05        MSG15             PIC  X(25) VALUE
                     'Record unchanged.  Next ?'.
           05        MSG16             PIC  X(21) VALUE
                     'Record added.  Next ?'.
           05        MSG17             PIC  X(23) VALUE
                     'Record updated.  Next ?'.
           05        MSG18             PIC  X(40) VALUE
                     'Please type key element(s).  Then ENTER.'.
           05        MSG20             PIC  X(39) VALUE
                     'Record deleted.  Press ENTER to re-add.'.
           05        MSG21             PIC  X(35) VALUE
                     'Not on file. Not update authorized.'.
           05        MSG22             PIC  X(37) VALUE
                     'Record displayed for inquiry.  Next ?'.
           05        MSG23             PIC  X(40) VALUE
                     'Not on file.  Type data to add or retry.'.
           05        MSG29             PIC  X(28) VALUE
                     'No record to delete.  Next ?'.
           05        MSG90             PIC  X(35) VALUE
                     'Not authorized for panel requested.'.
           05        MSG91             PIC  X(32) VALUE
                     'Not authorized at this terminal.'.
           05        MSG92             PIC  X(35) VALUE
                     'Panel unknown/not installed. Retry.'.
           05        MSG93             PIC  X(39) VALUE
                     'Panel temporarily disabled.  Try later.'.
           05        MSG94             PIC  X(41) VALUE
                     'Unknown system error. Request assistance.'.
           05        MSG95             PIC  X(35) VALUE
                     'Database full.  Request assistance.'.
           05        MSG96             PIC  X(42) VALUE
                     'Program error(INVREQ). Request assistance.'.
           05        MSG97             PIC  X(30) VALUE
                     'Database closed.  Try later.'.

           COPY                             EWBJRC.
           COPY                             EWQWRC.

           COPY                             EWBJR.

       01            OJR.
           05        OJRKEY                 PIC  X(017).
           05        OJRDATA                PIC  X(880).

           COPY                             EWQWR.
           COPY                             EWQWRI.
           COPY                             EWWCM.
           COPY                             DFHAID.
           COPY                             EWWAB.
           COPY                             EWNUMBW.

           COPY                             MPEW48.
       01            MPEW48R     REDEFINES  MPEW48I.
           05        MAPBYTE        OCCURS  0214  TIMES INDEXED BY MAP1.
             10      FILLER            PIC  X(01).

       LINKAGE SECTION.

       01  DFHCOMMAREA                 PIC  X(220).

       PROCEDURE DIVISION.
      ******************************************************************

       000-CONTROL.
           MOVE    SPACES              TO   WSK           WCM
           MOVE    LOW-VALUES          TO   MPEW48O
           MOVE    '99'                TO   RETQWR
           EXEC    CICS HANDLE CONDITION    MAPFAIL  (100-DISPLAY)
                   ERROR   (901-ERROR)      NOSPACE  (902-NOSPACE)
                   INVREQ  (903-INVREQ)     NOTOPEN  (904-NOTOPEN)
                   DSIDERR (905-DSIDERR)    END-EXEC

           MOVE    EIBTRMID            TO   QWRTRMID
           MOVE    'EW48'              TO   QWRPGM
           EXEC    CICS HANDLE CONDITION    NOTFND  (005-NEW)  END-EXEC
           EXEC    CICS READ                DATASET (QWRFIL)
                                            INTO    (QWR)
                                            RIDFLD  (QWRKEY)
                                            LENGTH  (QWRLENR)  END-EXEC
           MOVE    '00'                TO   RETQWR.
       005-NEW.
           IF      RETQWR              NOT  =   '00'
             MOVE  QWRKEY              TO   QWRIKEY
             MOVE  QWRI                TO   QWR
             MOVE  DFHCOMMAREA         TO   WCM
             MOVE  ZEROS               TO   WCMXFCRS9     WCMXFPOS9
             MOVE  HIGH-VALUES         TO   OLDKEY
           ELSE
             MOVE  QWRWCM              TO   WCM
             MOVE  QWROLD              TO   OLDKEY.

           MOVE    WCMSODISTA          TO   BJRFILDS

           IF      EIBCALEN            >    ZEROS
             GO                        TO   850-CALLED.
           IF      EIBAID              NOT  =   DFHENTER
             GO                        TO   800-XCTL.

           MOVE    QWROLD              TO   OLDKEY
           PERFORM 010-RECEIVE         THRU 010-EXIT
           IF      NEWPANEL            NOT  =   SPACES
             MOVE  NEWPANEL            TO   WCMXFTPNL
             GO                        TO   805-XCTL.
           IF      NEWKEY              NOT  =   OLDKEY
             GO                        TO   100-DISPLAY
           ELSE
             GO                        TO   300-UPDATE.

      ******************************************************************
       010-RECEIVE.
           EXEC    CICS RECEIVE             MAP    ('MPEW48')  END-EXEC
           MOVE    EIBCPOSN            TO   WCMXFCRS9
           SET     MAP1  QWR1          TO   +1.
       010-LOOP1.
           IF     (MAPBYTE      (MAP1) NOT  =   LOW-VALUES)          AND
                  (MAPBYTE      (MAP1) NOT  =   HIGH-VALUES)
             MOVE  MAPBYTE      (MAP1) TO   QWRBYTE      (QWR1).
           IF      MAP1                <    WSCMAPLEN
             SET   MAP1  QWR1          UP   BY  +1
             GO                        TO   010-LOOP1.
           MOVE    QWRMAP              TO   MPEW48I

           IF      MPANELA             =    WABEOF
             MOVE  WABUM               TO   MPANELA
             MOVE  ALL '_'             TO   MPANELO       NEWPANEL
           ELSE
             IF      MPANELL           >    ZEROS
               MOVE  MPANELI           TO   NEWPANEL
               MOVE  WABUM             TO   MPANELA
             ELSE
               IF      MPANELI         >    LOW-VALUES
                 MOVE  MPANELI         TO   NEWPANEL.
           IF      MREQA               =    WABEOF
             MOVE  WABUM               TO   MREQA
             MOVE  ALL '_'             TO   MREQO      NEWREQ
           ELSE
             MOVE    MREQI             TO   WNUIN
             PERFORM 700-CONVERT       THRU 700-EXIT
             MOVE    WABUNM            TO   MREQA
             IF      WNU30             >    ZERO
               MOVE  WNU30             TO   NEWREQ9    MREQO.

           SET     WSK1                TO   +1.
       010-LOOP2.
           IF      WSKB         (WSK1) =    '_'
             MOVE  ' '                 TO   WSKB         (WSK1).
           IF      WSK1                <    +6
             SET   WSK1                UP   BY  +1
             GO                        TO   010-LOOP2.
       010-EXIT.
           EXIT.

      ******************************************************************
       015-SEND.
           MOVE    EIBTRMID            TO   QWRTRMID
           MOVE    'EW48'              TO   QWRPGM
           MOVE    OLDKEY              TO   QWROLD
           MOVE    WCM                 TO   QWRWCM
           MOVE    MPEW48O             TO   QWRMAP
           EXEC    CICS HANDLE CONDITION    DUPREC  (015-ERR)  END-EXEC
           IF      RETQWR              NOT  =   '00'
             EXEC  CICS WRITE               DATASET (QWRFIL)
                                            FROM    (QWR)
                                            RIDFLD  (QWRKEY)
                                            LENGTH  (QWRLENR)  END-EXEC
           ELSE
             EXEC  CICS READ UPDATE         DATASET (QWRFIL)
                                            INTO    (QWRI)
                                            RIDFLD  (QWRKEY)
                                            LENGTH  (QWRLENR)  END-EXEC
             EXEC  CICS REWRITE             DATASET (QWRFIL)
                                            FROM    (QWR)
                                            LENGTH  (QWRLENR)  END-EXEC.
       015-ERR.
           IF      EIBCALEN            =    ZEROS
             EXEC  CICS SEND                MAP     ('MPEW48') DATAONLY
                                            CURSOR             END-EXEC
           ELSE
             IF      EIBCALEN          NOT  =   1234
               EXEC  CICS SEND              MAP     ('MPEW48') ERASE
                                            CURSOR             END-EXEC
             ELSE
               EXEC  CICS SEND              MAP     ('MPEW48') ERASE
                                            CURSOR  (EIBCPOSN) END-EXEC.
           EXEC    CICS RETURN              TRANSID ('EW48')   END-EXEC.

      ******************************************************************
       100-DISPLAY.
           MOVE    HIGH-VALUES         TO   OLDKEY
           MOVE    LOW-VALUES          TO   MPEW48O       QWRMAP
           MOVE    +10                 TO   EIBCALEN
           MOVE    ZEROS               TO   RETERR
           SET     WSK1                TO   +1.
       100-LOOP1.
           IF      WSKB         (WSK1) =    ' '
             MOVE  '_'                 TO   WSKB         (WSK1).
           IF      WSK1                <    +6
             SET   WSK1                UP   BY  +1
             GO                        TO   100-LOOP1.
           MOVE    NEWPANEL            TO   MPANELO
           MOVE    NEWREQ              TO   MREQO
           SET     WSK1                TO   +1.
       100-LOOP2.
           IF      WSKB         (WSK1) =    '_'
             MOVE  ' '                 TO   WSKB         (WSK1).
           IF      WSK1                <    +6
             SET   WSK1                UP   BY  +1
             GO                        TO   100-LOOP2.

           IF     (NEWREQ9             NOT  NUMERIC)               OR
                  (NEWREQ9             NOT  >  ZEROS)
             MOVE  -1                  TO   MREQL
             MOVE  MSG18               TO   MMSGO
             GO                        TO   015-SEND.

           MOVE    NEWKEY              TO   OLDKEY
           MOVE    SPACES              TO   BJR
           MOVE    WCMSODIST           TO   BJRDIST
           MOVE    'C'                 TO   BJRSER
           MOVE    WCMSOUSER           TO   BJRUSER
           MOVE    'B09'               TO   BJRPANEL
           MOVE    NEWREQ              TO   BJRREQ
           EXEC    CICS HANDLE CONDITION    NOTFND  (110-NEW)  END-EXEC
           EXEC    CICS READ                DATASET (BJRFIL)
                                            INTO    (BJR)
                                            RIDFLD  (BJRKEY)
                                            LENGTH  (BJRLENR)  END-EXEC

           IF      BJRHEAD1            NOT  =   SPACES
             MOVE  BJRHEAD1            TO   MHD1O.
           IF      BJRHEAD2            NOT  =   SPACES
             MOVE  BJRHEAD2            TO   MHD2O.
           MOVE    BJRCARD1            TO   WXR
           IF      WXRFUND             NOT  =   SPACES
             MOVE  WXRFUND             TO   MFUNDO.
           IF      WXRTBLE             NOT  =   SPACES
             MOVE  WXRTBLE             TO   MTBLEO.
           IF      WXRSCHL             NOT  =   SPACES
             MOVE  WXRSCHL             TO   MSCHLO.
           IF      WXRSUM              NOT  =   SPACES
             MOVE  WXRSUM              TO   MSUMO.
           IF      WXRRPT              NOT  =   SPACES
             MOVE  WXRRPT              TO   MRPTO.
           IF      WXRPRT              NOT  =   SPACES
             MOVE  WXRPRT              TO   MPRTO.

           MOVE    -1                  TO   MREQL
           IF      WCMSOCURR           =    'U'
             MOVE  MSG12               TO   MMSGO
           ELSE
             MOVE  MSG22               TO   MMSGO
             MOVE  HIGH-VALUES         TO   OLDKEY.
           GO                          TO   015-SEND.

       110-NEW.
           IF      WCMSOCURR           =    'U'
             MOVE  -1                  TO   MHD1L
             MOVE  MSG23               TO   MMSGO
           ELSE
             MOVE  -1                  TO   MREQL
             MOVE  MSG21               TO   MMSGO
             MOVE  HIGH-VALUES         TO   OLDKEY.
           GO                          TO   015-SEND.

      ******************************************************************
       300-UPDATE.
           IF      WCMSOCURR           NOT  =  'U'
             GO                        TO   100-DISPLAY.
           MOVE    ZEROS               TO   MREQL
           MOVE    SPACES              TO   BJR
           MOVE    WCMSODIST           TO   BJRDIST
           MOVE    'C'                 TO   BJRSER
           MOVE    WCMSOUSER           TO   BJRUSER
           MOVE    'B09'               TO   BJRPANEL
           MOVE    NEWREQ              TO   BJRREQ
           MOVE    '99'                TO   RETBJR
           EXEC    CICS HANDLE CONDITION    NOTFND  (305-NEW)  END-EXEC
           EXEC    CICS READ                DATASET (BJRFIL)
                                            INTO    (BJR)
                                            RIDFLD  (BJRKEY)
                                            LENGTH  (BJRLENR)  END-EXEC
           IF      EIBAID              =    DFHPF10
             EXEC  CICS READ   UPDATE       DATASET (BJRFIL)
                                            INTO    (BJR)
                                            RIDFLD  (BJRKEY)
                                            LENGTH  (BJRLENR)  END-EXEC
             EXEC  CICS DELETE              DATASET (BJRFIL)   END-EXEC
             MOVE  -1                  TO   MREQL
             MOVE  MSG20               TO   MMSGO
             GO                        TO   015-SEND.
           MOVE    '00'                TO   RETBJR.
       305-NEW.
           IF     (EIBAID              =    DFHPF10)                 AND
                  (RETBJR              NOT  =   '00')
             MOVE  -1                  TO   MREQL
             MOVE  MSG29               TO   MMSGO
             GO                        TO   015-SEND.

           MOVE    BJR                 TO   OJR
           MOVE    BJRCARD1            TO   WXR
           MOVE    NEWREQ              TO   WXRREQ

           IF      MHD1A               =    WABEOF
             MOVE  ALL '_'             TO   MHD1O
             MOVE  WABUM               TO   MHD1A
             MOVE  SPACES              TO   BJRHEAD1
           ELSE
             IF      MHD1L             >    ZEROS
               MOVE  ZEROS             TO   MHD1L
               MOVE  MHD1I             TO   BJRHEAD1
               MOVE  WABU              TO   MHD1A
             ELSE
               IF      MHD1I           >    LOW-VALUES
                 MOVE  WABU            TO   MHD1A
                 MOVE  MHD1I           TO   BJRHEAD1.
           IF      MHD2A               =    WABEOF
             MOVE  ALL '_'             TO   MHD2O
             MOVE  WABUM               TO   MHD2A
             MOVE  SPACES              TO   BJRHEAD2
           ELSE
             IF      MHD2L             >    ZEROS
               MOVE  ZEROS             TO   MHD2L
               MOVE  MHD2I             TO   BJRHEAD2
               MOVE  WABU              TO   MHD2A
             ELSE
               IF      MHD2I           >    LOW-VALUES
                 MOVE  WABU            TO   MHD2A
                 MOVE  MHD2I           TO   BJRHEAD2.
           IF      MFUNDA              =    WABEOF
             MOVE  ALL '_'             TO   MFUNDO
             MOVE  WABUM               TO   MFUNDA
             MOVE  SPACES              TO   WXRFUND
           ELSE
             IF      MFUNDL            >    ZEROS
               MOVE  ZEROS             TO   MFUNDL
               MOVE  MFUNDI            TO   WXRFUND
               MOVE  WABU              TO   MFUNDA
             ELSE
               IF      MFUNDI          >    LOW-VALUES
                 MOVE  WABU            TO   MFUNDA
                 MOVE  MFUNDI          TO   WXRFUND.
           IF      MTBLEA              =    WABEOF
             MOVE  ALL '_'             TO   MTBLEO
             MOVE  WABUM               TO   MTBLEA
             MOVE  SPACES              TO   WXRTBLE
           ELSE
             IF      MTBLEL            >    ZEROS
               MOVE  ZEROS             TO   MTBLEL
               MOVE  MTBLEI            TO   WXRTBLE
               MOVE  WABU              TO   MTBLEA
             ELSE
               IF      MTBLEI          >    LOW-VALUES
                 MOVE  WABU            TO   MTBLEA
                 MOVE  MTBLEI          TO   WXRTBLE.
           IF      MSCHLA              =    WABEOF
             MOVE  ALL '_'             TO   MSCHLO
             MOVE  WABUM               TO   MSCHLA
             MOVE  SPACES              TO   WXRSCHL
           ELSE
             IF      MSCHLL            >    ZEROS
               MOVE  ZEROS             TO   MSCHLL
               MOVE  MSCHLI            TO   WXRSCHL
               MOVE  WABU              TO   MSCHLA
             ELSE
               IF      MSCHLI          >    LOW-VALUES
                 MOVE  WABU            TO   MSCHLA
                 MOVE  MSCHLI          TO   WXRSCHL.
           IF      MSUMA               =    WABEOF
             MOVE  ALL '_'             TO   MSUMO
             MOVE  WABUM               TO   MSUMA
             MOVE  SPACES              TO   WXRSUM
           ELSE
             IF      MSUML             >    ZEROS
               MOVE  ZEROS             TO   MSUML
               MOVE  MSUMI             TO   WXRSUM
               MOVE  WABU              TO   MSUMA
             ELSE
               IF      MSUMI           >    LOW-VALUES
                 MOVE  WABU            TO   MSUMA
                 MOVE  MSUMI           TO   WXRSUM.
           IF      MRPTA               =    WABEOF
             MOVE  ALL '_'             TO   MRPTO
             MOVE  WABUM               TO   MRPTA
             MOVE  SPACES              TO   WXRRPT
           ELSE
             IF      MRPTL             >    ZEROS
               MOVE  ZEROS             TO   MRPTL
               MOVE  MRPTI             TO   WXRRPT
               MOVE  WABU              TO   MRPTA
             ELSE
               IF      MRPTI           >    LOW-VALUES
                 MOVE  WABU            TO   MRPTA
                 MOVE  MRPTI           TO   WXRRPT.
           IF      MPRTA               =    WABEOF
             MOVE  ALL '_'             TO   MPRTO
             MOVE  WABUM               TO   MPRTA
             MOVE  SPACES              TO   WXRPRT
           ELSE
             IF      MPRTL             >    ZEROS
               MOVE  ZEROS             TO   MPRTL
               MOVE  MPRTI             TO   WXRPRT
               MOVE  WABU              TO   MPRTA
             ELSE
               IF      MPRTI           >    LOW-VALUES
                 MOVE  WABU            TO   MPRTA
                 MOVE  MPRTI           TO   WXRPRT.

           MOVE    ZEROS               TO   RETERR

           SET     BJR1  WXR1          TO   +1.
       310-LOOP.
           IF      BJRB         (BJR1) =    '_'
             MOVE  ' '                 TO   BJRB         (BJR1).
           IF      BJR1                <    +897
             SET   BJR1                UP   BY  +1
             GO                        TO   310-LOOP.
       315-LOOP.
           IF      WXRB         (WXR1) =    '_'
             MOVE  ' '                 TO   WXRB         (WXR1).
           IF      WXR1                <    +39
             SET   WXR1                UP   BY  +1
             GO                        TO   315-LOOP.

           IF      WXRPRT              =    SPACES
             MOVE  'N'                 TO   WXRPRT        MPRTO.
           IF      BJRHD1              =    SPACES
             MOVE  ALL '_'             TO   MHD1O.
           IF      BJRHD2              =    SPACES
             MOVE  ALL '_'             TO   MHD2O.
           IF      WXRFUND             =    SPACES
             MOVE  ALL '_'             TO   MFUNDO.
           IF      WXRTBLE             =    SPACES
             MOVE  ALL '_'             TO   MTBLEO.
           IF      WXRSCHL             =    SPACES
             MOVE  ALL '_'             TO   MSCHLO.
           IF      WXRSUM              =    SPACES
             MOVE  ALL '_'             TO   MSUMO.
           IF      WXRRPT              =    SPACES
             MOVE  ALL '_'             TO   MRPTO.
           IF      WXRPRT              =    SPACES
             MOVE  ALL '_'             TO   MPRTO.

           MOVE    'SL'                TO   WXRID
           MOVE    WCMSODIST           TO   WXRDIST
           MOVE    WCMSOFY             TO   WXRFY
           IF     (WXRRPT              =    'A')                  OR
                  (WXRRPT              =    'B')
             MOVE  'EW028'             TO   WXRPGM
           ELSE
             IF   (WXRRPT              =    'C')
               MOVE 'EW029'            TO   WXRPGM
             ELSE
               MOVE  WABUMB            TO   MRPTA
               MOVE  -1                TO   MRPTL  RETERR.
           MOVE    WXR                 TO   BJRCARD1

           IF      BJRHEAD1            =    SPACES
             MOVE  WABUMB              TO   MHD1A
             MOVE  -1                  TO   MHD1L         RETERR.
           IF     (WXRRPT              NOT  =   'A')                 AND
                  (WXRRPT              NOT  =   'B')                 AND
                  (WXRRPT              NOT  =   'C')
             MOVE  WABUMB              TO   MRPTA
             MOVE  -1                  TO   MRPTL          RETERR.
           IF     (WXRSUM              NOT  =   'Y')                 AND
                  (WXRSUM              NOT  =   ' ')
             MOVE  WABUMB              TO   MSUMA
             MOVE  -1                  TO   MSUML          RETERR.
           IF     (WXRRPT              NOT  =   'C')                 AND
                  (WXRSUM              NOT  =   ' ')
             MOVE  WABUMB              TO   MSUMA
             MOVE  -1                  TO   MSUML          RETERR.
           IF     (WXRFUND             NOT  =   '1')                 AND
                  (WXRFUND             NOT  =   '4')                 AND
050409            (WXRFUND             NOT  =   '5')                 AND
050409            (WXRFUND             NOT  =   '6')                 AND
050409            (WXRFUND             NOT  =   '7')                 AND
020411            (WXRFUND             NOT  =   '8')                 AND
020411            (WXRFUND             NOT  =   '9')                 AND
                  (WXRFUND             NOT  =   ' ')
             MOVE  WABUMB              TO   MFUNDA
             MOVE  -1                  TO   MFUNDL         RETERR.
           IF     (WXRPRT              NOT  =   'U')                 AND
                  (WXRPRT              NOT  =   'T')                 AND
                  (WXRPRT              NOT  =   'B')                 AND
                  (WXRPRT              NOT  =   'N')
             MOVE  WABUMB              TO   MPRTA
             MOVE  -1                  TO   MPRTL         RETERR.

           IF      RETERR              NOT  =   ZEROS
             MOVE  MSG03               TO   MMSGO
             GO                        TO   015-SEND.
           MOVE    -1                  TO   MREQL
           IF      BJR                 =    OJR
             MOVE  MSG15               TO   MMSGO
             GO                        TO   015-SEND.
           MOVE    NEWREQ              TO   BJRREQ1       BJRREQ2
           MOVE    'H1'                TO   BJRID1
           MOVE    'H2'                TO   BJRID2
           MOVE    WCMSOUSER           TO   BJRUSER1      BJRUSER2
           IF      RETBJR              =    '00'
             MOVE  MSG17               TO   MMSGO
             EXEC  CICS READ UPDATE         DATASET (BJRFIL)
                                            INTO    (OJR)
                                            RIDFLD  (BJRKEY)
                                            LENGTH  (BJRLENR)  END-EXEC
             EXEC  CICS REWRITE             DATASET (BJRFIL)
                                            FROM    (BJR)
                                            LENGTH  (BJRLENR)  END-EXEC
           ELSE
             MOVE  MSG16               TO   MMSGO
             EXEC  CICS WRITE               DATASET (BJRFIL)
                                            FROM    (BJR)
                                            RIDFLD  (BJRKEY)
                                            LENGTH  (BJRLENR)  END-EXEC.
           GO                          TO   015-SEND.

      ******************************************************************

           COPY                             EWNUMBP.

      ******************************************************************
       800-XCTL.
           IF     (EIBAID              =    DFHCLEAR)                OR
                  (EIBAID              =    DFHPA1)                  OR
                  (EIBAID              =    DFHPA2)
             MOVE  QWRMAP              TO   MPEW48O
             MOVE  -1                  TO   MPANELL
             MOVE  +10                 TO   EIBCALEN
             GO                        TO   015-SEND.
           MOVE    QWRWCM              TO   WCM
           PERFORM 010-RECEIVE         THRU 010-EXIT

           IF      EIBAID              =    DFHPF1
             MOVE  WCMXFFR             TO   WCMXFHLD
             MOVE  EIBCPOSN            TO   WCMXFCRS9     WCMXFPOS9
             MOVE  'CZ02'              TO   WCMXFTO
             GO                        TO   805-XCTL.
           IF      EIBAID              =    DFHPF4
             MOVE  WCMXFFR             TO   WCMXFHLD
             MOVE  'B09'               TO   WCMXFPROM
             MOVE  EIBCPOSN            TO   WCMXFCRS9     WCMXFPOS9
             MOVE  'CZ03'              TO   WCMXFTO
             GO                        TO   805-XCTL.
           IF     (EIBAID              =    DFHPF7)                  OR
                  (EIBAID              =    DFHPF8)
             GO                        TO   820-PAGE.
           IF      EIBAID              =    DFHPF10
             GO                        TO   300-UPDATE.
           IF      EIBAID              =    DFHPF12
             MOVE  SPACES              TO   WCMXFHLD
             MOVE  'C   '              TO   WCMXFTO
           ELSE
             IF      EIBAID            =    DFHPF3
               MOVE  SPACES            TO   WCMXFHLD
               MOVE  'CB  '            TO   WCMXFTO
             ELSE
               IF      EIBAID          =    DFHPF11
                 GO                    TO   815-SUBM
               ELSE
                 MOVE  QWRMAP          TO   MPEW48O
                 MOVE  +10             TO   EIBCALEN
                 MOVE  -1              TO   MREQL
                 GO                    TO   015-SEND.
       805-XCTL.
           MOVE    'C'                 TO   WCMXFTS
           MOVE    WCM                 TO   QWRWCM
           EXEC    CICS HANDLE CONDITION    DUPREC  (810-END)  END-EXEC
           IF      RETQWR              NOT  =   '00'
             EXEC  CICS WRITE               DATASET (QWRFIL)
                                            FROM    (QWR)
                                            RIDFLD  (QWRKEY)
                                            LENGTH  (QWRLENR)  END-EXEC
           ELSE
             EXEC  CICS READ UPDATE         DATASET (QWRFIL)
                                            INTO    (QWRI)
                                            RIDFLD  (QWRKEY)
                                            LENGTH  (QWRLENR)  END-EXEC
             EXEC  CICS REWRITE             DATASET (QWRFIL)
                                            FROM    (QWR)
                                            LENGTH  (QWRLENR)  END-EXEC.
       810-END.
           MOVE    'CB09'              TO   WCMXFFR
           EXEC    CICS XCTL                PROGRAM ('EW02')
                                            COMMAREA(WCM)
                                            LENGTH  (220)      END-EXEC.

      ******************************************************************
       815-SUBM.
           MOVE    WCMSODISTA          TO   WXF
           MOVE    WCMSODIST           TO   WXFDIST
           MOVE    'C'                 TO   WXFSER
           MOVE    WCMSOUSER           TO   WXFUSER
           MOVE    'B09'               TO   WXFPANEL
           MOVE    NEWREQ              TO   WXFREQ
           IF     (MRPTI               =    'A')                    OR
                  (MRPTI               =    'B')
             MOVE  'EW028'             TO   WXFPGM
           ELSE
             IF   (MRPTI               =    'C')
               MOVE 'EW029'            TO   WXFPGM.
           EXEC    CICS LINK                PROGRAM ('EW83')
                                            COMMAREA(WXF)
                                            LENGTH  (27)       END-EXEC
           IF      WXFRET              =    'C'
             MOVE  'User class restricted.  Retry ?'           TO MMSGO
           ELSE
             IF      WXFRET            NOT  =   '0'
               MOVE  'Submission Error.  Request assistance.'  TO MMSGO
             ELSE
               MOVE  'Request submitted. Next ?'               TO MMSGO.
           MOVE  -1              TO   MREQL
           GO                    TO   015-SEND.

      ******************************************************************
       820-PAGE.
           MOVE    SPACES              TO   BJR
           MOVE    WCMSODIST           TO   BJRDIST
           MOVE    'C'                 TO   BJRSER
           MOVE    WCMSOUSER           TO   BJRUSER
           MOVE    'B09'               TO   BJRPANEL
           MOVE    NEWREQ              TO   BJRREQ
           MOVE    BJRKEY              TO   OJRKEY.
       825-RETRY.
           EXEC    CICS HANDLE CONDITION    NOTFND  (840-NONE)
                                            INVREQ  (840-NONE)
                                            ENDFILE (840-NONE) END-EXEC
           EXEC    CICS STARTBR             DATASET (BJRFIL)
                                            RIDFLD  (BJRKEY)   GTEQ
                                            KEYLENGTH(BJRLENK) END-EXEC.
           IF      EIBAID              =    DFHPF7
             EXEC  CICS HANDLE CONDITION    NOTFND  (845-NONE) END-EXEC
             EXEC  CICS READPREV            DATASET (BJRFIL)
                                            INTO    (BJR)
                                            RIDFLD  (BJRKEY)
                                            LENGTH  (BJRLENR)  END-EXEC
           ELSE
             EXEC  CICS READNEXT            DATASET (BJRFIL)
                                            INTO    (BJR)
                                            RIDFLD  (BJRKEY)
                                            LENGTH  (BJRLENR)  END-EXEC.
           EXEC    CICS HANDLE CONDITION    ENDFILE (840-NONE) END-EXEC
           IF      BJRKEY              =    OJRKEY
             IF      EIBAID            =    DFHPF7
               EXEC  CICS READPREV          DATASET (BJRFIL)
                                            INTO    (BJR)
                                            RIDFLD  (BJRKEY)
                                            LENGTH  (BJRLENR)  END-EXEC
             ELSE
               EXEC  CICS READNEXT          DATASET (BJRFIL)
                                            INTO    (BJR)
                                            RIDFLD  (BJRKEY)
                                            LENGTH  (BJRLENR)  END-EXEC.
       830-PF7M.
           EXEC    CICS ENDBR               DATASET (BJRFIL)   END-EXEC
           IF     (BJRDIST             NOT  =   WCMSODIST)           OR
                  (BJRSER              NOT  =   'C')                 OR
                  (BJRPANEL            NOT  =   'B09')               OR
                  (BJRUSER             NOT  =   WCMSOUSER)
             GO                        TO   840-NONE.
           MOVE    BJRREQ              TO   NEWREQ
           GO                          TO   100-DISPLAY.
       840-NONE.
           MOVE    -1                  TO   MREQL
           IF      EIBAID              =    DFHPF7
             MOVE  MSG13               TO   MMSGO
           ELSE
             MOVE  MSG14               TO   MMSGO.
           GO                          TO   015-SEND.
       845-NONE.
           EXEC    CICS READNEXT            DATASET (BJRFIL)
                                            INTO    (BJR)
                                            RIDFLD  (BJRKEY)
                                            LENGTH  (BJRLENR)  END-EXEC
           EXEC    CICS READPREV            DATASET (BJRFIL)
                                            INTO    (BJR)
                                            RIDFLD  (BJRKEY)
                                            LENGTH  (BJRLENR)  END-EXEC
           EXEC    CICS READPREV            DATASET (BJRFIL)
                                            INTO    (BJR)
                                            RIDFLD  (BJRKEY)
                                            LENGTH  (BJRLENR)  END-EXEC
           GO                          TO   830-PF7M.

      ******************************************************************
       850-CALLED.
           MOVE    DFHCOMMAREA         TO   WCM
           IF      WCMXFFR             =    'CZ02'
             MOVE  WCMXFHLD            TO   WCMXFFR
             MOVE  WCMXFCRS9           TO   EIBCPOSN
             MOVE  1234                TO   EIBCALEN
             MOVE  QWRMAP              TO   MPEW48O
             GO                        TO   015-SEND.
           IF      WCMXFFR             =    'CZ04'                    OR
                   WCMXFFR             =    'CZ03'
             MOVE  WCMXFHLD            TO   WCMXFFR
             MOVE  WCMXFCRS9           TO   EIBCPOSN
             MOVE  1234                TO   EIBCALEN
             MOVE  QWRMAP              TO   MPEW48O
             IF      WCMXFPROM         NOT  =   SPACES
               IF    WCMXFPNL5         =    'TBLE'
                 MOVE  WCMXFPROM       TO   MTBLEO
                 GO                    TO   015-SEND
               ELSE
               IF    WCMXFPNL5         =    'SCHL'
                 MOVE  WCMXFPROM       TO   MSCHLO
                 GO                    TO   015-SEND
               ELSE
                 GO                    TO   015-SEND
             ELSE
               GO                      TO   015-SEND.
           IF      WCMXFFR             =    'CZ05'
             MOVE  WCMXFHLD            TO   WCMXFFR
             MOVE  WCMXFCRS9           TO   EIBCPOSN
             MOVE  1234                TO   EIBCALEN
             MOVE  QWRMAP              TO   MPEW48O
             IF      WCMXFPROM         NOT  =   SPACES
               MOVE  WCMXFPROM         TO   MREQO
               GO                      TO   015-SEND
             ELSE
               GO                      TO   015-SEND.
           IF      WCMRETCD            NOT  =   'G'
             GO                        TO   900-SECURITY.
           MOVE    SPACES              TO   NEWKEY
           GO                          TO   100-DISPLAY.

      ******************************************************************
       900-SECURITY.
           MOVE    ZEROS               TO   EIBCALEN
           MOVE    WCMXFHLD            TO   WCMXFFR
           MOVE    1234                TO   EIBCALEN
           MOVE    +14                 TO   EIBCPOSN
           MOVE    QWRMAP              TO   MPEW48O
           MOVE    WCMXFTPNL           TO   MPANELO
           MOVE    WABUMB              TO   MPANELA
           IF      WCMRETCD            =    'S'
             MOVE  MSG90               TO   MMSGO
           ELSE
             IF      WCMRETCD          =    'T'
               MOVE  MSG91             TO   MMSGO
             ELSE
               IF     (WCMRETCD        =    'U')                     OR
                      (WCMRETCD        =    'N')
                 MOVE  MSG92           TO   MMSGO
               ELSE
                 IF      WCMRETCD      =    'D'
                   MOVE  MSG93         TO   MMSGO.
           GO                          TO   015-SEND.
       901-ERROR.
           MOVE    -1                  TO   MPANELL
           MOVE    MSG94               TO   MMSGO
           GO                          TO   015-SEND.
       902-NOSPACE.
           MOVE    MSG95               TO   MMSGO
           MOVE    -1                  TO   MPANELL
           GO                          TO   015-SEND.
       903-INVREQ.
           MOVE    MSG96               TO   MMSGO
           MOVE    -1                  TO   MPANELL
           GO                          TO   015-SEND.
       904-NOTOPEN.
           MOVE    MSG97               TO   MMSGO
           MOVE    -1                  TO   MPANELL
           GO                          TO   015-SEND.
       905-DSIDERR.
           MOVE    MSG97               TO   MMSGO
           MOVE    -1                  TO   MPANELL
           GO                          TO   015-SEND.
           GOBACK.
