000100 Identification Division. 000200 Program-Id. ED0APGM2. 000300*----------------------------------------------------- 000400* This is a sample solution to Exercise 10 (A) 000500* the Presentation Program 000600* Asyncronous DB-program (ED0DB1X) 000700*----------------------------------------------------- 000800 Data Division. 000900 Working-Storage Section. 001000 Copy DFHAID. 001010 Copy DFHBMSCA. 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 '*** ERROR 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 'ED0A'. 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 77 MyCursorPos1 Pic 9(04) Value 800 Binary. 004000 77 MyCursorPos2 Pic 9(04) Value 960 Binary. 004100 77 MyAbendCode Pic X(04) Value 'ERRA'. 004200 77 MyTDQueue Pic X(04) Value 'ERRA'. 004300 77 Msg-Press-Enter Pic X(25) Value '- Press ENTER to continue'. 004400 004500 77 Switches Pic 9(01) Value 0. 004600 88 Indata-ERR Value 0. 004700 88 Indata-OK Value 1. 004800 004900 Linkage Section. 005000 005100 01 DFHCOMMAREA. 005200 005300 05 MyDBRequest Pic 9(01). 005400 88 DBRead Value 1. 005500 88 DBUpdate Value 2. 005600 88 DBDelete Value 3. 005700 88 DBAdd Value 4. 005800 88 DBPageRequest Value 5. 005900 006000 05 MyDBResponse Pic 9(02). 006100 88 DBReadOK Value 10. 006200 88 DBReadNotfnd Value 11. 006300 88 DBReadError Value 19. 006400 006500 88 DBUpdateOK Value 20. 006600 88 DBUpdateNotfnd Value 21. 006700 88 DBUpdateDBRecordError Value 22. 006800 88 DBUpdateError Value 29. 006900 007000 88 DBDeleteOK Value 30. 007100 88 DBDeleteNotfnd Value 31. 007200 88 DBDeleteError Value 39. 007300 007400 88 DBAddOK Value 40. 007500 88 DBAddDuprec Value 41. 007600 88 DBAddError Value 49. 007700 007800 88 DBRequestError Value 99. 007900 88 DBAsyncError Value 91. 008000 88 DBRequestNormal Value 00. 008100 008200 05 MyTSQueue Pic X(08). 008300 05 MyDelayReqid Pic X(08). 008400 008500 05 MyDBRecord. 008600 10 Empno Pic X(05). 008700 10 Ssno Pic X(10). 008800 10 Fname Pic X(20). 008900 10 Lname Pic X(20). 009000 10 Dpt Pic X(05). 009100 10 Pic X(20). 009200 009300 Procedure Division. 009400 Evaluate True 009500 When EIBCALEN = 0 009600 Perform InitVars 009700 Perform Send-Maponly 009800 Perform Return-Transid-Commarea 009900 When DBPageRequest 010000 Perform Send-Maponly 010100 Perform ReadEdemp 010200 When EIBAID = DFHPF3 010300 When EIBAID = DFHCLEAR 010400 Perform XCTL-Program 010500 When EIBAID = DFHPF1 010600 Perform Send-MapEraseAup 010700 When EIBAID = DFHENTER 010800 Perform Receive-Map 010900 Perform Validate-Indata 011000 If Indata-OK 011100 Perform ReadEdemp 011200 End-If 011300 When EIBAID = DFHPF5 and DBReadOK 011400 Perform Receive-Map 011500 Perform Validate-Indata 011600 If Indata-OK 011700 Perform UpdateEdemp 011800 End-If 011900 When EIBAID = DFHPF6 012000 Perform Receive-Map 012100 Perform AddEdemp 012200 When EIBAID = DFHPF7 and DBReadOK 012300 Perform DeleteEdemp 012400 When Other 012500 Set Msg-InvalidPFK to True 012600 End-Evaluate 012700 Perform Send-Mapdataonly 012800 Perform Return-Transid-Commarea 012900 . 013000*-------------------------------------------- 013100 InitVars. 013200*-------------------------------------------- 013300 Exec CICS Getmain 013400 Length(Length of DFHCOMMAREA) 013500 Set(Address of DFHCOMMAREA) 013600 End-Exec 013700 Move Low-Value to EDMAP2O 013800 Initialize DFHCOMMAREA 013900 . 014000*-------------------------------------------- 014100 XCTL-Program. 014200*-------------------------------------------- 014300 Exec CICS 014400 XCTL 014500 Program(MyMenuPgm) 014600 End-Exec 014700 . 014800*-------------------------------------------- 014900 Return-Transid-Commarea. 015000*-------------------------------------------- 015100 Exec CICS 015200 Return 015300 Transid(MyTransid) 015400 Commarea(DFHCOMMAREA) 015500 End-Exec 015600 . 015700*-------------------------------------------- 015800 Send-MapEraseAup. 015900*-------------------------------------------- 016000 Exec CICS 016100 Send Control 016200 EraseAup 016300 Freekb 016400 End-Exec 016500 Move Low-Value to EDMAP2O 016600 Move Space to MSGO 016700 Move Low-Value to DFHCOMMAREA 016800 . 016900*-------------------------------------------- 017000 Send-Maponly. 017100*-------------------------------------------- 017200 Exec CICS 017300 Send 017400 Map('EDMAP2') 017500 Maponly 017600 Erase 017700 Freekb 017800 End-Exec 017900 . 018000*-------------------------------------------- 018100 Send-Mapdataonly. 018200*-------------------------------------------- 018300 Exec CICS 018400 Send 018500 Map('EDMAP2') 018600 Dataonly 018700 Freekb 018800 EraseAup 018900 End-Exec 019000 . 019100*-------------------------------------------- 019200 Receive-Map. 019300*-------------------------------------------- 019400 Exec CICS 019500 Receive 019600 Map('EDMAP2') 019700 Resp(MyResp) 019800 End-Exec 019900 . 020000*-------------------------------------------- 020100 ReadEdemp. 020200*-------------------------------------------- 020300 If Not DBPageRequest 020400 Initialize DFHCOMMAREA 020500 Move EmpnoI to Empno in MyDBRecord 020600 Else 020700 Move Empno in MyDBRecord to MyEmpno 020800 End-If 020900 Set DBRead to True 021000 021100 Perform StartDBProgram 021200 021300 Evaluate True 021400 When DBReadOK 021410 Move DFHBMFSE to EmpnoA 021500 Move MyEmpno to EmpnoO 021600 Move Ssno to SsnoO 021700 Move Fname to FnameO 021800 Move Lname to LnameO 021900 Move Dpt to DptO 022000 Set MSG-DBReadOK to True 022100 When DBReadNotfnd 022200 Move MyEMpno to EmpnoO 022300 Set Msg-EmprecNotfnd to True 022400 When Other 022500 Continue 022600* Set Msg-DBReadError to True 022700 End-Evaluate 022800 . 022900*-------------------------------------------- 023000 AddEdemp. 023100*-------------------------------------------- 023200 If EmpnoL = 0 or 023300 SsnoL = 0 or 023400 FnameL = 0 or 023500 LnameL = 0 or 023600 DptL = 0 023700 Set MSG-DBAddInputError to True 023800 Else 023900 Move EmpnoI to Empno in MyDBRecord 024000 Move SsnoI to SSno in MyDBRecord 024100 Move FnameI to Fname in MyDBRecord 024200 Move LnameI to Lname in MyDBRecord 024300 Move DptI to Dpt in MyDBRecord 024400 Set DBAdd to True 024500 024600 Perform StartDBProgram 024700 024800 Evaluate True 024900 When DBAddOK 025000 Set MSG-DBAddOK to True 025100 When DBAddDuprec 025200 Set MSG-DBAddDuprec to True 025300 When Other 025400 Set DBAsyncError to True 025500 End-Evaluate 025600 End-If 025700 . 025800*-------------------------------------------- 025900 UpdateEdemp. 026000*-------------------------------------------- 026100 If SsnoL Not = 0 026200 Move SsnoI to SSno in MyDBRecord 026300 End-If 026400 If FnameL Not = 0 026500 Move FnameI to Fname in MyDBRecord 026600 End-If 026700 If LnameL Not = 0 026800 Move LnameI to Lname in MyDBRecord 026900 End-If 027000 If DptL Not = 0 027100 Move DptI to Dpt in MyDBRecord 027200 End-If 027300 Move MyEmpno to Empno in MyDBRecord 027400 Set DBUpdate to True 027500 027600 Perform StartDBProgram 027700 027800 Evaluate True 027900 When DBUpdateOK 028000 Move MyEmpno to EmpnoO 028100 Move Ssno to SsnoO 028200 Move Fname to FnameO 028300 Move Lname to LnameO 028400 Move Dpt to DptO 028500 Set MSG-DBUpdateOK to True 028600 When DBupdateDBrecordError 028700 Set Msg-DBupdateDBrecordError to True 028800 When Other 028900 Set DBAsyncError to True 029000 End-Evaluate 029100 . 029200*-------------------------------------------- 029300 DeleteEdemp. 029400*-------------------------------------------- 029500 Initialize DFHCOMMAREA 029600 Move MyEmpno to Empno in MyDBRecord 029700 Set DBDelete to True 029800 029900 Perform StartDBprogram 030000 030100 Evaluate True 030200 When DBDeleteOK 030300 Set MSG-DBDeleteOK to True 030400 When DBDeleteNotFnd 030500 Move MyEMpno to EmpnoO 030600 Set Msg-EmprecNotfnd to True 030700 When Other 030800 Set DBAsyncError to True 030900 End-Evaluate 031000 . 031100*-------------------------------------------- 031200 StartDBprogram. 031300*-------------------------------------------- 031400 Move Low-Value to EDMAP2O 031500 String MyTRansid 031600 EIBTRMID Delimited by Size 031700 Into MyTSQueue in DFHCOMMAREA 031800 End-String 031900 032000 Move MyTSQueue to MyDelayReqid in DFHCOMMAREA 032100 Exec CICS 032200 Deleteq TS 032300 Queue(MyTSQueue) 032400 Resp(Myresp) 032500 End-Exec 032600 Exec CICS 032700 Start 032800 Transid(MyDBTrans) 032900 From(DFHCOMMAREA) 033000 Resp(Myresp) 033100 End-Exec 033200 Exec CICS 033300 Delay 033400 Interval(25) 033500 Reqid(MyDelayReqid) 033600 Resp(Myresp) 033700 End-Exec 033800*------------------------------------------- 033900* Continue here when interval has expired 034000* or has been cancelled. 034100*------------------------------------------- 034200 Exec CICS 034300 ReadQ TS 034400 Queue(MyTSQueue) 034500 Into(DFHCOMMAREA) 034600 Resp(MyResp) 034700 End-Exec 034800*------------------------------------------- 034900* If no TS-record/Queue is avaiable this indicates 035000* that the DB-program didnt terminate normally 035100*------------------------------------------- 035200 If MyResp = DFHRESP(QIDERR) 035300 Perform AbendMyProgram 035400 End-If 035500 . 035600*-------------------------------------------- 035700 AbendMyProgram. 035800*-------------------------------------------- 035900 Set DBAsyncError to True 036000 Set MSG-DBasyncError to True 036100 036200 Exec CICS Send Control 036300 Erase 036400 Cursor(MyCursorPos1) 036500 End-Exec 036600 036700 Exec CICS Send 036800 From(MyMessage) 036900 End-Exec 037000 037100 Exec CICS Send Control 037200 Cursor(MyCursorPos2) 037300 End-Exec 037400 037500 Exec CICS Send 037600 From(Msg-Press-Enter) 037700 End-Exec 037800 037900 Exec CICS Receive 038000 Into(MyMessage) 038100 Resp(MyResp) 038200 End-Exec 038300 038400 Exec CICS Writeq TD 038500 Queue(MyTDQueue) 038600 From(MyMessage) 038700 End-Exec 038800 038900 Exec CICS Abend 039000 Abcode(MyAbendCode) 039100 End-Exec 039200 . 039300*-------------------------------------------- 039400 Validate-Indata. 039500*-------------------------------------------- 039600 Evaluate True 039700 When EmpnoL = 0 039800 Set Msg-EmpnoMissing to True 039900 When EmpnoI Not Numeric 040000 Set Msg-EmpnoNotNum to True 040100 When Other 040200 Move EmpnoI to MyEmpno 040300 Set Indata-OK to True 040400 End-Evaluate 040500 . 040600*-------------------------------------------- 040700 End Program ED0APGM2. 040800*--------------------------------------------