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