000100 Identification Division. 000200 Program-Id. ED09PGM. 000300*----------------------------------------------------- 000400* This is a sample solution to Exercise 9 000500* the Presentation Program 000600* Asyncronous DB-program (ED0DB1X) 000700*----------------------------------------------------- 000800 Data Division. 000900 Working-Storage Section. 001000 Copy DFHAID. 001100 Copy EDMAP2. 001200 02 MyMessage Redefines MSGO Pic X(60). 001300 88 Msg-InvalidPFK Value 'Invalid PF-key pressed'. 001400 88 Msg-ReadEdempErr Value 'Employee not found'. 001500 88 Msg-EmpnoMissing Value 'Employee no missing'. 001600 88 Msg-EmpnoNotNum Value 'Employee no not numeric'. 001700 88 Msg-EmpRecNotfnd Value 'Employee record not found'. 001800 88 Msg-DBReadError Value 'DBRead returned error'. 001900 88 Msg-DBReadOK Value 'This is requested record'. 002000 88 Msg-DBUpdateDBRecordError 002100 Value 'DBUpdate Edemp record invalid'. 002200 88 Msg-DBUpdateError Value 'DBUpdate returned error'. 002300 88 Msg-DBUpdateOK Value 'Update normal'. 002400 88 Msg-DBDeleteError Value 'DBDelete returned error'. 002500 88 Msg-DBDeleteOK Value 'Delete normal'. 002600 88 Msg-DBAddError Value 'DBAdd returned error'. 002700 88 Msg-DBAddOK Value 'Add normal'. 002800 88 Msg-DBAddDuprec Value 'Add duplicate empno'. 002900 88 Msg-DBAddInputError Value 'Invalid field value(s)'. 003000 88 Msg-DBAsyncError 003100 Value 'Async DB-program has not responded'. 003200 003300 77 MyEmpno Pic X(05). 003400 77 MyResp Pic S9(08) Binary. 003500 77 MyTransid Pic X(04) Value 'ED09'. 003600 77 MyMenuPgm Pic X(08) Value 'ED03PGM'. 003700 77 MyDBPgm Pic X(08) Value 'ED0DB1X'. 003800 77 MyDBTrans Pic X(04) Value 'ED0X'. 003900 004000 77 Switches Pic 9(01) Value 0. 004100 88 Indata-ERR Value 0. 004200 88 Indata-OK Value 1. 004300 004400 Linkage Section. 004500 004600 01 DFHCOMMAREA. 004700 05 MyDBRequest Pic 9(01). 004800 88 DBRead Value 1. 004900 88 DBUpdate Value 2. 005000 88 DBDelete Value 3. 005100 88 DBAdd Value 4. 005200 005300 05 MyDBResponse Pic 9(02). 005400 88 DBReadOK Value 10. 005500 88 DBReadNotfnd Value 11. 005600 88 DBReadError Value 19. 005700 005800 88 DBUpdateOK Value 20. 005900 88 DBUpdateNotfnd Value 21. 006000 88 DBUpdateDBRecordError Value 22. 006100 88 DBUpdateError Value 29. 006200 006300 88 DBDeleteOK Value 30. 006400 88 DBDeleteNotfnd Value 31. 006500 88 DBDeleteError Value 39. 006600 006700 88 DBAddOK Value 40. 006800 88 DBAddDuprec Value 41. 006900 88 DBAddError Value 49. 007000 007100 88 DBRequestError Value 99. 007200 88 DBAsyncError Value 91. 007300 88 DBRequestNormal Value 00. 007400 007500 05 MyTSQueue Pic X(08). 007600 05 MyDelayReqid Pic X(08). 007700 007800 05 MyDBRecord. 007900 10 Empno Pic X(05). 008000 10 Ssno Pic X(10). 008100 10 Fname Pic X(20). 008200 10 Lname Pic X(20). 008300 10 Dpt Pic X(05). 008400 10 Pic X(20). 008500 008600 Procedure Division. 008700 Evaluate True 008800 When EIBCALEN = 0 008900 Perform InitVars 009000 Perform Send-Maponly 009100 Perform Return-Transid-Commarea 009200 When EIBAID = DFHPF3 009300 When EIBAID = DFHCLEAR 009400 Perform XCTL-Program 009500 When EIBAID = DFHPF1 009600 Perform Send-MapEraseAup 009700 When EIBAID = DFHENTER 009800 Perform Receive-Map 009900 Perform Validate-Indata 010000 If Indata-OK 010100 Perform ReadEdemp 010200 End-If 010300 When EIBAID = DFHPF5 and DBReadOK 010400 Perform Receive-Map 010500 Perform Validate-Indata 010600 If Indata-OK 010700 Perform UpdateEdemp 010800 End-If 010900 When EIBAID = DFHPF6 011000 Perform Receive-Map 011100 Perform AddEdemp 011200 When EIBAID = DFHPF7 and DBReadOK 011300 Perform DeleteEdemp 011400 When Other 011500 Set Msg-InvalidPFK to True 011600 End-Evaluate 011700 Perform Send-Mapdataonly 011800 Perform Return-Transid-Commarea 011900 . 012000*-------------------------------------------- 012100 InitVars. 012200*-------------------------------------------- 012300 Exec CICS Getmain 012400 Length(Length of DFHCOMMAREA) 012500 Set(Address of DFHCOMMAREA) 012600 End-Exec 012700 Move Low-Value to EDMAP2O 012800 Initialize DFHCOMMAREA 012900 . 013000*-------------------------------------------- 013100 XCTL-Program. 013200*-------------------------------------------- 013300 Exec CICS 013400 XCTL 013500 Program(MyMenuPgm) 013600 End-Exec 013700 . 013800*-------------------------------------------- 013900 Return-Transid-Commarea. 014000*-------------------------------------------- 014100 Exec CICS 014200 Return 014300 Transid(MyTransid) 014400 Commarea(DFHCOMMAREA) 014500 End-Exec 014600 . 014700*-------------------------------------------- 014800 Send-MapEraseAup. 014900*-------------------------------------------- 015000 Exec CICS 015100 Send Control 015200 EraseAup 015300 Freekb 015400 End-Exec 015500 Move Low-Value to EDMAP2O 015600 Move Space to MSGO 015700 Move Low-Value to DFHCOMMAREA 015800 . 015900*-------------------------------------------- 016000 Send-Maponly. 016100*-------------------------------------------- 016200 Exec CICS 016300 Send 016400 Map('EDMAP2') 016500 Maponly 016600 Erase 016700 Freekb 016800 End-Exec 016900 . 017000*-------------------------------------------- 017100 Send-Mapdataonly. 017200*-------------------------------------------- 017300 Exec CICS 017400 Send 017500 Map('EDMAP2') 017600 Dataonly 017700 Freekb 017800 EraseAup 017900 End-Exec 018000 . 018100*-------------------------------------------- 018200 Receive-Map. 018300*-------------------------------------------- 018400 Exec CICS 018500 Receive 018600 Map('EDMAP2') 018700 Resp(MyResp) 018800 End-Exec 018900 . 019000*-------------------------------------------- 019100 ReadEdemp. 019200*-------------------------------------------- 019300 Initialize DFHCOMMAREA 019400 Move EmpnoI to Empno in MyDBRecord 019500 019600 Set DBRead to True 019700 019800 Perform StartDBProgram 019900 020000 Evaluate True 020100 When DBReadOK 020200 Move MyEmpno to EmpnoO 020300 Move Ssno to SsnoO 020400 Move Fname to FnameO 020500 Move Lname to LnameO 020600 Move Dpt to DptO 020700 Set MSG-DBReadOK to True 020800 When DBReadNotfnd 020900 Move MyEMpno to EmpnoO 021000 Set Msg-EmprecNotfnd to True 021100 When Other 021200 Set Msg-DBReadError to True 021300 End-Evaluate 021400 . 021500*-------------------------------------------- 021600 AddEdemp. 021700*-------------------------------------------- 021800 If EmpnoL = 0 or 021900 SsnoL = 0 or 022000 FnameL = 0 or 022100 LnameL = 0 or 022200 DptL = 0 022300 Set MSG-DBAddInputError to True 022400 Else 022500 Move EmpnoI to Empno in MyDBRecord 022600 Move SsnoI to SSno in MyDBRecord 022700 Move FnameI to Fname in MyDBRecord 022800 Move LnameI to Lname in MyDBRecord 022900 Move DptI to Dpt in MyDBRecord 023000 Set DBAdd to True 023100 023200 Perform StartDBProgram 023300 023400 Evaluate True 023500 When DBAddOK 023600 Set MSG-DBAddOK to True 023700 When DBAddDuprec 023800 Set MSG-DBAddDuprec to True 023900 When Other 024000 Set Msg-DBAddError to True 024100 End-Evaluate 024200 End-If 024300 . 024400*-------------------------------------------- 024500 UpdateEdemp. 024600*-------------------------------------------- 024700 If SsnoL Not = 0 024800 Move SsnoI to SSno in MyDBRecord 024900 End-If 025000 If FnameL Not = 0 025100 Move FnameI to Fname in MyDBRecord 025200 End-If 025300 If LnameL Not = 0 025400 Move LnameI to Lname in MyDBRecord 025500 End-If 025600 If DptL Not = 0 025700 Move DptI to Dpt in MyDBRecord 025800 End-If 025900 Move MyEmpno to Empno in MyDBRecord 026000 Set DBUpdate to True 026100 026200 Perform StartDBProgram 026300 026400 Evaluate True 026500 When DBUpdateOK 026600 Move MyEmpno to EmpnoO 026700 Move Ssno to SsnoO 026800 Move Fname to FnameO 026900 Move Lname to LnameO 027000 Move Dpt to DptO 027100 Set MSG-DBUpdateOK to True 027200 When DBupdateDBrecordError 027300 Set Msg-DBupdateDBrecordError to True 027400 When Other 027500 Set Msg-DBUpdateError to True 027600 End-Evaluate 027700 . 027800*-------------------------------------------- 027900 DeleteEdemp. 028000*-------------------------------------------- 028100 Initialize DFHCOMMAREA 028200 Move MyEmpno to Empno in MyDBRecord 028300 Set DBDelete to True 028400 028500 Perform StartDBprogram 028600 028700 Evaluate True 028800 When DBDeleteOK 028900 Set MSG-DBDeleteOK to True 029000 When DBDeleteNotFnd 029100 Move MyEMpno to EmpnoO 029200 Set Msg-EmprecNotfnd to True 029300 When Other 029400 Set Msg-DBDeleteError to True 029500 End-Evaluate 029600 . 029700*-------------------------------------------- 029800 StartDBprogram. 029900*-------------------------------------------- 030000 Move Low-Value to EDMAP2O 030100 String EIBTRNID 030200 EIBTRMID Delimited by Size 030300 Into MyTSQueue in DFHCOMMAREA 030400 End-String 030500 030600 Move MyTSQueue to MyDelayReqid in DFHCOMMAREA 030700 Exec CICS 030800 Deleteq TS 030900 Queue(MyTSQueue) 031000 Resp(Myresp) 031100 End-Exec 031200 Exec CICS 031300 Start 031400 Transid(MyDBTrans) 031500 From(DFHCOMMAREA) 031600 Resp(Myresp) 031700 End-Exec 031800 Exec CICS 031900 Delay 032000 Interval(25) 032100 Reqid(MyDelayReqid) 032200 Resp(Myresp) 032300 End-Exec 032400*------------------------------------------- 032500* Continue here when interval has expired 032600* or has been cancelled. 032700*------------------------------------------- 032800 Exec CICS 032900 ReadQ TS 033000 Queue(MyTSQueue) 033100 Into(DFHCOMMAREA) 033200 Resp(MyResp) 033300 End-Exec 033400 . 033500*-------------------------------------------- 033600 Validate-Indata. 033700*-------------------------------------------- 033800 Evaluate True 033900 When EmpnoL = 0 034000 Set Msg-EmpnoMissing to True 034100 When EmpnoI Not Numeric 034200 Set Msg-EmpnoNotNum to True 034300 When Other 034400 Move EmpnoI to MyEmpno 034500 Set Indata-OK to True 034600 End-Evaluate 034700 . 034800*-------------------------------------------- 034900 End Program ED09PGM. 035000*--------------------------------------------