000100 Identification Division.
000200 Program-Id. ED03PGM.
000300 Data Division.
000400 Working-Storage Section.
000500     Copy DFHAID.
000600     Copy DFHBMSCA.
000700     Copy EDMAP1.
000800    02 MyMessage Redefines MESSAGEO Pic X(50).
000900       88 Msg-SelectErr  Value 'Invalid choice'.
001000       88 Msg-OtherErr   Value 'Other error!'.
001100       88 Msg-NoEmpPgm   Value 'Program ED03PGM missing'.
001200       88 Msg-NoPagPgm   Value 'Program ED08PGM missing'.
001300 77 Ws-Commarea    Pic X.
001400 77 MyResp         Pic S9(08) Binary.
001500 77                Pic 9 Value 0.
001600     88 ExitPgm          Value 1.
001700     88 Msg-Exist        Value 2.
001800     88 SelectErr        Value 3.
001900     88 Employees        Value 4.
002000     88 Paging           Value 5.
002100
002200 01 Date-Accept Pic X(08).
002300 01 Date-Map    Pic X(10).
002400
002500 Procedure Division.
002600     Evaluate True
002700        When EIBCALEN = 0
002800             Perform Date-Create
002900             Perform Send-Map
003000        When EIBAID = DFHCLEAR
003100        When EIBAID = DFHPF3
003200             Perform Return-CICS
003300        When EIBAID = DFHENTER
003400             Perform Receive-Map
003500             Perform Validate-Indata
003600             If ExitPgm
003700                Perform Return-CICS
003800             Else
003900                Perform XCTL-Program
004000             End-If
004100        When Other
004200             Set Msg-OtherErr to True
004300             Set Msg-Exist    to True
004400     End-Evaluate
004500     If MSG-Exist
004600        Perform Send-MapDataonly
004700     End-If
004800     Perform Return-Transid
004900     .
005000*--------------------------------------------
005100 Date-Create.
005200*--------------------------------------------
005300     Accept Date-Accept from Date YYYYMMDD
005400     String
005500        Date-Accept(7:2)
005600        '/'
005700        Date-Accept(5:2)
005800        ','
005900        Date-Accept(1:4) Delimited by Size
006000        Into Date-Map
006100     End-String
006200     .
006300*--------------------------------------------
006400 XCTL-Program.
006500*--------------------------------------------
006600      Evaluate True
006700         When Employees
006800            Exec CICS
006900                 XCTL
007000                 Program('ED04PGM')
007100                 Resp(MyResp)
007200            End-Exec
007300            If Myresp = DFHRESP(PGMIDERR)
007400               Set Msg-NoEmpPgm to True
007500               Set Msg-Exist to True
007600            End-If
007700         When Paging
007800            Exec CICS
007900                 XCTL
008000                 Program('ED08PGM')
008100                 Resp(MyResp)
008200            End-Exec
008300            If Myresp = DFHRESP(PGMIDERR)
008400               Set Msg-NoPagPgm to True
008500               Set Msg-Exist to True
008600            End-If
008700         When Other
008800            Exec CICS
008900                 XCTL
009000                 Program('ERRPGM')
009100            End-Exec
009200      End-Evaluate
009300      .
009400*--------------------------------------------
009500 Return-CICS.
009600*--------------------------------------------
009700      Exec CICS
009800           Send Control
009900           Erase
010000           Freekb
010100      End-Exec
010200      Exec CICS
010300           Return
010400      End-Exec
010500      .
010600*--------------------------------------------
010700 Return-Transid.
010800*--------------------------------------------
010900      Exec CICS
011000           Return
011100           Transid('ED03')
011200           Commarea(Ws-Commarea)
011300      End-Exec
011400      .
011500*--------------------------------------------
011600 Send-Map.
011700*--------------------------------------------
011800      Move Low-Value to EDMAP1O
011900      Move Date-Map to DateO
012000      Exec CICS
012100           Send
012200           Map('EDMAP1')
012300           Erase Freekb
012400      End-Exec
012500      .
012600*--------------------------------------------
012700 Send-Maponly.
012800*--------------------------------------------
012900      Exec CICS
013000           Send
013100           Map('EDMAP1')
013200           Maponly
013300      End-Exec
013400      .
013500*--------------------------------------------
013600 Send-Mapdataonly.
013700*--------------------------------------------
013800      Exec CICS
013900           Send
014000           Map('EDMAP1')
014100           Dataonly Freekb EraseAup
014200      End-Exec
014300      .
014400*--------------------------------------------
014500 Receive-Map.
014600*--------------------------------------------
014700      Exec CICS
014800           Receive
014900           Map('EDMAP1')
015000           Resp(MyResp)
015100      End-Exec
015200      Evaluate True
015300         When ExitF = DFHBMCUR
015400              or ExitL = 1
015500              Set ExitPgm to True
015600         When EmpfileF = DFHBMCUR
015700              or EmpfileL = 1
015800              Set Employees to True
015900         When PagingF  = DFHBMCUR
016000              or PagingL = 1
016100              Set Paging to True
016200         When Other
016300              Set SelectErr to True
016400      End-Evaluate
016500      Move Low-Value to EDMAP1O
016600      .
016700*--------------------------------------------
016800 Validate-Indata.
016900*--------------------------------------------
017000     Evaluate True
017100        When ExitPgm
017200            Perform Return-CICS
017300        When SelectErr
017400            Set Msg-SelectErr to True
017500            Perform Send-Mapdataonly
017600            Perform Return-Transid
017700        When Employees
017800        When Paging
017900            Continue
018000        When Other
018100            Set Msg-OtherErr to True
018200            Perform Send-Mapdataonly
018300            Perform Return-Transid
018400     End-Evaluate
018500     .