000100 Identification Division.
000200 Program-Id. ED05PGM.
000300*-----------------------------------------------------
000400* This is a sample solution to Exercise 5
000500* the Presentation Program
000600*-----------------------------------------------------
000700 Data Division.
000800 Working-Storage Section.
000900     Copy DFHAID.
001000     Copy EDMAP2.
001100     02 MyMessage  Redefines MSGO Pic X(50).
001200        88 Msg-InvalidPFK   Value 'Invalid PF-key pressed'.
001300        88 Msg-ReadEdempErr Value 'Employee not found'.
001400        88 Msg-EmpnoMissing Value 'Employee no missing'.
001500        88 Msg-EmpnoNotNum  Value 'Employee no not numeric'.
001600        88 Msg-EmpRecNotfnd Value 'Employee record not found'.
001700        88 Msg-DBReadError  Value 'DBRead returned error'.
001800        88 Msg-DBReadOK     Value 'This is requested record'.
001900
002000 01 Ws-Commarea    Pic X(01).
002100
002200 01 MyDBCommarea.
002300     05 MyDBRequest  Pic 9(01) Value 0.
002400        88 DBRead              Value 1.
002500
002600     05 MyDBResponse Pic 9(02) Value 0.
002700        88 DBReadOK            Value 11.
002800        88 DBReadNotfnd        Value 12.
002900        88 DBReadError         Value 19.
003000        88 DBRequestError      Value 99.
003100
003200     05 MyDBRecord.
003300        10 Empno      Pic X(05).
003400        10 Ssno       Pic X(10).
003500        10 Fname      Pic X(20).
003600        10 Lname      Pic X(20).
003700        10 Dpt        Pic X(05).
003800        10            Pic X(20).
003900
004000 77 MyEmpno        Pic X(05).
004100 77 MyResp         Pic S9(08) Binary.
004200 77 MyTransid      Pic X(04) Value 'ED05'.
004300 77 MyMenuPgm      Pic X(08) Value 'ED03PGM'.
004400 77 MyDBPgm        Pic X(08) Value 'ED0DB1A'.
004500 77 Switches       Pic 9(01) Value 0.
004600    88 Indata-ERR  Value 0.
004700    88 Indata-OK   Value 1.
004800
004900 Procedure Division.
005000     Perform InitVars
005100     Evaluate True
005200        When EIBCALEN = 0
005300            Perform Send-Maponly
005400            Perform Return-Transid-Commarea
005500        When EIBAID = DFHPF3
005600        When EIBAID = DFHCLEAR
005700             Perform XCTL-Program
005800        When EIBAID = DFHPF1
005900             Perform Send-MapEraseAup
006000        When EIBAID = DFHENTER
006100             Perform Receive-Map
006200             Perform Validate-Indata
006300             If Indata-OK
006400                Perform ReadEdemp
006500             End-If
006600        When Other
006700             Set Msg-InvalidPFK to True
006800     End-Evaluate
006900     Perform Send-Mapdataonly
007000     Perform Return-Transid-Commarea
007100     .
007200*--------------------------------------------
007300 InitVars.
007400*--------------------------------------------
007500     Move Low-Value to EDMAP2O
007600     .
007700*--------------------------------------------
007800 XCTL-Program.
007900*--------------------------------------------
008000     Exec CICS
008100          XCTL
008200          Program(MyMenuPgm)
008300     End-Exec
008400     .
008500*--------------------------------------------
008600 Return-Transid-Commarea.
008700*--------------------------------------------
008800     Exec CICS
008900          Return
009000          Transid(MyTransid)
009100          Commarea(Ws-Commarea)
009200     End-Exec
009300     .
009400*--------------------------------------------
009500 Send-MapEraseAup.
009600*--------------------------------------------
009700     Exec CICS
009800          Send Control
009900          EraseAup
010000          Freekb
010100     End-Exec
010200     Move Low-Value to EDMAP2O
010300     Move Space to MSGO
010400     .
010500*--------------------------------------------
010600 Send-Maponly.
010700*--------------------------------------------
010800     Exec CICS
010900          Send
011000          Map('EDMAP2')
011100          Maponly
011200          Erase
011300          Freekb
011400     End-Exec
011500     .
011600*--------------------------------------------
011700 Send-Mapdataonly.
011800*--------------------------------------------
011900     Exec CICS
012000          Send
012100          Map('EDMAP2')
012200          Dataonly
012300          Freekb
012400          EraseAup
012500     End-Exec
012600     .
012700*--------------------------------------------
012800 Receive-Map.
012900*--------------------------------------------
013000     Exec CICS
013100          Receive
013200          Map('EDMAP2')
013300          Resp(MyResp)
013400     End-Exec
013500     .
013600*--------------------------------------------
013700 ReadEdemp.
013800*--------------------------------------------
013900     Initialize MyDBCommarea
014000     Move MyEmpno to Empno in MyDBCommarea
014100     Set DBRead to True
014200     Exec CICS
014300          Link
014400          Program(MyDBPgm)
014500          Commarea(MyDBCommarea)
014600     End-Exec
014700     Move Low-Value to EDMAP2O
014800     Evaluate True
014900        When DBReadOK
015000           Move MyEmpno    to EmpnoO
015100           Move Ssno       to SsnoO
015200           Move Fname      to FnameO
015300           Move Lname      to LnameO
015400           Move Dpt        to DptO
015500           Set MSG-DBReadOK to True
015600        When DBReadNotfnd
015700           Move MyEMpno   to EmpnoO
015800           Set Msg-EmprecNotfnd to True
015900        When Other
016000           Set Msg-DBReadError to True
016100     End-Evaluate
016200     .
016300*--------------------------------------------
016400 Validate-Indata.
016500*--------------------------------------------
016600      Evaluate True
016700         When EmpnoL = 0
016800              Set Msg-EmpnoMissing to True
016900         When EmpnoI  Not Numeric
017000              Set Msg-EmpnoNotNum to True
017100         When Other
017200              Move EmpnoI to MyEmpno
017300              Set Indata-OK to True
017400      End-Evaluate
017500     .