000100 Identification Division.
000200 Program-Id. ED0DB1X.
000300*-----------------------------------------------------
000400* This is a sample solution to Exercise 7
000500* the Database Program using VSAM, Read and Update
000600* Saving read record to TSQ
000700* Asyncrounus transaction.
000800*-----------------------------------------------------
000900 Data Division.
001000 Working-Storage Section.
001100
001200 77 MyResp          Pic S9(08) Binary.
001300 77 MyEdempFile     Pic X(08) Value 'EDEMP0'.
001400 77 MyTSQnameDBRead Pic X(16) Value Space.
001500
001600 01 MyDBRecordDBUpdate  Pic X(80).
001700 01 MyTSQDBRecord  Pic X(80).
001800
001900 Linkage Section.
002000
002100 01 DFHCOMMAREA.
002200    05 MyDBRequest Pic 9(01).
002300       88 DBRead   Value 1.
002400       88 DBUpdate Value 2.
002500       88 DBDelete Value 3.
002600       88 DBAdd    Value 4.
002700
002800    05 MyDBResponse Pic 9(02).
002900       88 DBReadOK       Value 10.
003000       88 DBReadNotfnd   Value 11.
003100       88 DBReadError    Value 19.
003200
003300       88 DBUpdateOK             Value 20.
003400       88 DBUpdateNotfnd         Value 21.
003500       88 DBUpdateDBRecordError  Value 22.
003600       88 DBUpdateError          Value 29.
003700
003800       88 DBDeleteOK     Value 30.
003900       88 DBDeleteNotfnd Value 31.
004000       88 DBDeleteError  Value 39.
004100
004200       88 DBAddOK        Value 40.
004300       88 DBAddDuprec    Value 41.
004400       88 DBAddError     Value 49.
004500
004600       88 DBRequestError Value 99.
004700       88 DBAsyncError1  Value 91.
004800
004900    05 MyTSQueue     Pic X(08).
005000    05 MyDelayReqid  Pic X(08).
005100
005200    05 MyDBRecord.
005300       10 Empno   Pic X(05).
005400       10 Ssno    Pic X(10).
005500       10 Fname   Pic X(20).
005600       10 Lname   Pic X(20).
005700       10 Dpt     Pic X(05).
005800       10         Pic X(20).
005900
006000 Procedure Division.
006100     Perform RetrieveCommarea
006200     Perform MyTSQnameDBReadGen
006300     Perform Until MyResp = DFHRESP(ENDDATA)
006400        Evaluate True
006500           When DBRead
006600              Perform MyDBRead
006700           When DBUpdate
006800              Perform MyDBUpdate
006900           When DBDelete
007000              Perform MyDBDelete
007100           When DBAdd
007200              Perform MyDBAdd
007300           When Other
007400              Set DBRequestError to True
007500        End-Evaluate
007600        Perform RetrieveCommarea
007700     End-Perform
007800
007900     Exec CICS Deleteq TS
008000          Queue(MyTSQueue)
008100          Resp(MyResp)
008200     End-EXec
008300     Exec CICS WriteQ TS
008400          Queue(MyTSQueue)
008500          From(DFHCOMMAREA)
008600     End-EXec
008700     Exec CICS
008800          Cancel
008900          Reqid(MyDelayReqid)
009000     End-Exec
009100
009200     Exec CICS
009300          Return
009400     End-Exec
009500     .
009600*--------------------------------------------
009700 RetrieveCommarea.
009800*--------------------------------------------
009900     Exec CICS
010000          Retrieve
010100          Set(Address of DFHCOMMAREA)
010200          Length(Length of DFHCOMMAREA)
010300          Resp(MyResp)
010400     End-Exec
010500     .
010600*--------------------------------------------
010700 MyDBRead.
010800*--------------------------------------------
010900     Exec CICS
011000          Read
011100          File(MyEdempFile)
011200          Into(MyDBRecord)
011300          Ridfld(Empno)
011400          Resp(MyResp)
011500     End-Exec
011600     Evaluate True
011700        When Myresp = DFHRESP(NORMAL)
011800           Set DBReadOK to True
011900           Perform MyTSQWrite
012000        When Myresp = DFHRESP(NOTFND)
012100           Set DBReadNotFnd to True
012200        When Other
012300           Set DBReadError to True
012400     End-Evaluate
012500     .
012600*--------------------------------------------
012700 MyTSQnameDBReadGen.
012800*--------------------------------------------
012900     String MyTSQueue
013000            'FILEREAD' Delimited by Size
013100            Into MyTSQnameDBRead
013200     End-String
013300     .
013400*--------------------------------------------
013500 MyTSQWrite.
013600*--------------------------------------------
013700
013800     Exec CICS
013900          Deleteq TS
014000          Qname(MYTSQNameDBRead)
014100          Resp(MyResp)
014200     End-Exec
014300     Exec CICS
014400          Writeq TS
014500          Qname(MYTSQNameDBRead)
014600          From (MyDBRecord)
014700          Resp(MyResp)
014800     End-Exec
014900     .
015000*--------------------------------------------
015100 MyDBUpdate.
015200*--------------------------------------------
015300     Exec CICS
015400          Read
015500          File(MyEdempFile)
015600          Into(MyDBRecordDBUpdate)
015700          Ridfld(Empno)
015800          Update
015900          Resp(MyResp)
016000     End-Exec
016100     Evaluate True
016200        When Myresp = DFHRESP(NORMAL)
016300           Perform MyDBRewrite
016400        When Myresp = DFHRESP(NOTFND)
016500           Set DBUpdateNotfnd to True
016600        When Other
016700           Set DBUpdateError to True
016800     End-Evaluate
016900     .
017000*--------------------------------------------
017100 MyTSQCheck.
017200*--------------------------------------------
017300     Exec CICS
017400          Readq TS
017500          Qname(MYTSQNameDBRead)
017600          Into(MyTSQDBRecord)
017700          Resp(MyResp)
017800     End-Exec
017900     .
018000*--------------------------------------------
018100 MyDBRewrite.
018200*--------------------------------------------
018300     Perform MyTSQCheck
018400     If MyTSQDBRecord = MyDBRecordDBUpdate
018500        Exec CICS
018600             Rewrite
018700             File(MyEdempFile)
018800             From(MyDBRecord)
018900             Resp(MyResp)
019000        End-Exec
019100        Evaluate True
019200           When Myresp = DFHRESP(NORMAL)
019300              Set DBUpdateOK to True
019400           When Other
019500              Set DBUpdateError to True
019600        End-Evaluate
019700     Else
019800        Set DBUpdateDBRecordError to True
019900     End-If
020000     .
020100*--------------------------------------------
020200 MyDBDelete.
020300*--------------------------------------------
020400     Exec CICS
020500          Delete
020600          File(MyEdempFile)
020700          Ridfld(Empno)
020800          Resp(MyResp)
020900     End-Exec
021000     Evaluate True
021100        When Myresp = DFHRESP(NORMAL)
021200           Set DBDeleteOK to True
021300        When Myresp = DFHRESP(NOTFND)
021400           Set DBDeleteNotfnd to True
021500        When Other
021600           Set DBDeleteError to True
021700     End-Evaluate
021800     .
021900*--------------------------------------------
022000 MyDBAdd.
022100*--------------------------------------------
022200     Exec CICS
022300          Write
022400          File(MyEdempFile)
022500          Ridfld(Empno)
022600          From(MyDBRecord)
022700          Resp(MyResp)
022800     End-Exec
022900     Evaluate True
023000        When Myresp = DFHRESP(NORMAL)
023100           Set DBAddOK  to True
023200        When Myresp = DFHRESP(DUPREC)
023300           Set DBAddDuprec to True
023400        When Other
023500           Set DBAddError to True
023600     End-Evaluate
023700     .
023800*--------------------------------------------
023900 End Program ED0DB1X.
024000*--------------------------------------------