000100 Identification Division.
000200 Program-Id. ED0DB1C.
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*-----------------------------------------------------
000800 Data Division.
000900 Working-Storage Section.
001000
001100 77 MyResp         Pic S9(08) Binary.
001200 77 MyEdempFile    Pic X(08) Value 'EDEMP0'.
001300 77 MyTSQName      Pic X(08).
001400
001500 01 MyDBRecordDBUpdate  Pic X(80).
001600 01 MyTSQDBRecord  Pic X(80).
001700
001800 Linkage Section.
001900
002000 01 DFHCOMMAREA.
002100     05 MyDBRequest Pic 9(01).
002200        88 DBRead   Value 1.
002300        88 DBUpdate Value 2.
002400        88 DBDelete Value 3.
002500        88 DBAdd    Value 4.
002600
002700     05 MyDBResponse Pic 9(02).
002800        88 DBReadOK       Value 10.
002900        88 DBReadNotfnd   Value 11.
003000        88 DBReadError    Value 19.
003100
003200        88 DBUpdateOK             Value 20.
003300        88 DBUpdateNotfnd         Value 21.
003400        88 DBUpdateDBRecordError  Value 22.
003500        88 DBUpdateError          Value 29.
003600
003700        88 DBDeleteOK     Value 30.
003800        88 DBDeleteNotfnd Value 31.
003900        88 DBDeleteError  Value 39.
004000
004100        88 DBAddOK        Value 40.
004200        88 DBAddDuprec    Value 41.
004300        88 DBAddError     Value 49.
004400
004500        88 DBRequestError Value 99.
004600
004700     05 MyDBRecord.
004800        10 Empno   Pic X(05).
004900        10 Ssno    Pic X(10).
005000        10 Fname   Pic X(20).
005100        10 Lname   Pic X(20).
005200        10 Dpt     Pic X(05).
005300        10         Pic X(20).
005400     05            Pic X(20).
005500
005600 Procedure Division.
005700     Evaluate True
005800        When DBRead
005900           Perform MyDBRead
006000        When DBUpdate
006100           Perform MyDBUpdate
006200        When DBDelete
006300           Perform MyDBDelete
006400        When DBAdd
006500           Perform MyDBAdd
006600        When Other
006700           Set DBRequestError to True
006800     End-Evaluate
006900     Exec CICS
007000          Return
007100     End-Exec
007200     .
007300*--------------------------------------------
007400 MyDBRead.
007500*--------------------------------------------
007600     String
007700        EIBTRMID
007800        EIBTRNID Delimited By Size
007900        Into MYTSQName
008000     End-String
008100
008200     Exec CICS
008300          Read
008400          File(MyEdempFile)
008500          Into(MyDBRecord)
008600          Ridfld(Empno)
008700          Resp(MyResp)
008800     End-Exec
008900     Evaluate True
009000        When Myresp = DFHRESP(NORMAL)
009100           Set DBReadOK to True
009200           Perform MyTSQWrite
009300        When Myresp = DFHRESP(NOTFND)
009400           Set DBReadNotFnd to True
009500        When Other
009600           Set DBReadError to True
009700     End-Evaluate
009800     .
009900*--------------------------------------------
010000 MyTSQWrite.
010100*--------------------------------------------
010200     Exec CICS
010300          Deleteq TS
010400          Queue(MYTSQName)
010500          Resp(MyResp)
010600     End-Exec
010700     Exec CICS
010800          Writeq TS
010900          Queue(MYTSQName)
011000          From (MyDBRecord)
011100          Resp(MyResp)
011200     End-Exec
011300     .
011400*--------------------------------------------
011500 MyDBUpdate.
011600*--------------------------------------------
011700     Exec CICS
011800          Read
011900          File(MyEdempFile)
012000          Into(MyDBRecordDBUpdate)
012100          Ridfld(Empno)
012200          Update
012300          Resp(MyResp)
012400     End-Exec
012500     Evaluate True
012600        When Myresp = DFHRESP(NORMAL)
012700           Perform MyDBRewrite
012800        When Myresp = DFHRESP(NOTFND)
012900           Set DBUpdateNotfnd to True
013000        When Other
013100           Set DBUpdateError to True
013200     End-Evaluate
013300     .
013400*--------------------------------------------
013500 MyTSQCheck.
013600*--------------------------------------------
013700     Exec CICS
013800          Readq TS
013900          Queue(MYTSQName)
014000          Into(MyTSQDBRecord)
014100          Resp(MyResp)
014200     End-Exec
014300     .
014400*--------------------------------------------
014500 MyDBRewrite.
014600*--------------------------------------------
014700     Perform MyTSQCheck
014800     If MyTSQDBRecord = MyDBRecordDBUpdate
014900        Exec CICS
015000             Rewrite
015100             File(MyEdempFile)
015200             From(MyDBRecord)
015300             Resp(MyResp)
015400        End-Exec
015500        Evaluate True
015600           When Myresp = DFHRESP(NORMAL)
015700              Set DBUpdateOK to True
015800           When Other
015900              Set DBUpdateError to True
016000        End-Evaluate
016100     Else
016200        Set DBUpdateDBRecordError to True
016300     End-If
016400     .
016500*--------------------------------------------
016600 MyDBDelete.
016700*--------------------------------------------
016800     Exec CICS
016900          Delete
017000          File(MyEdempFile)
017100          Ridfld(Empno)
017200          Resp(MyResp)
017300     End-Exec
017400     Evaluate True
017500        When Myresp = DFHRESP(NORMAL)
017600           Set DBDeleteOK to True
017700        When Myresp = DFHRESP(NOTFND)
017800           Set DBDeleteNotfnd to True
017900        When Other
018000           Set DBDeleteError to True
018100     End-Evaluate
018200     .
018300*--------------------------------------------
018400 MyDBAdd.
018500*--------------------------------------------
018600     Exec CICS
018700          Write
018800          File(MyEdempFile)
018900          Ridfld(Empno)
019000          From(MyDBRecord)
019100          Resp(MyResp)
019200     End-Exec
019300     Evaluate True
019400        When Myresp = DFHRESP(NORMAL)
019500           Set DBAddOK  to True
019600        When Myresp = DFHRESP(DUPREC)
019700           Set DBAddDuprec to True
019800        When Other
019900           Set DBAddError to True
020000     End-Evaluate
020100     .
020200*--------------------------------------------
020300 End Program ED0DB1C.
020400*--------------------------------------------