000100 Identification Division.
000200 Program-Id. ED0DB1B.
000300*-----------------------------------------------------
000400* This is a sample solution to Exercise 6
000500* the Database Program using VSAM, Read and Update
000600*-----------------------------------------------------
000700 Data Division.
000800 Working-Storage Section.
000900 77 MyResp         Pic S9(08) Binary.
001000 77 MyEdempfile    Pic x(08) Value 'EDEMP0'.
001100
001200 01 MyDBRecordDBUpdate  Pic X(80).
001300
001400 Linkage Section.
001500 01 DFHCOMMAREA.
001600     05 MyDBRequest Pic 9(01).
001700        88 DBRead   Value 1.
001800        88 DBUpdate Value 2.
001900        88 DBDelete Value 3.
002000        88 DBAdd    Value 4.
002100
002200     05 MyDBResponse Pic 9(02).
002300        88 DBReadOK       Value 10.
002400        88 DBReadNotfnd   Value 11.
002500        88 DBReadError    Value 19.
002600
002700        88 DBUpdateOK     Value 20.
002800        88 DBUpdateNotfnd Value 21.
002900        88 DBUpdateError  Value 29.
003000
003100        88 DBDeleteOK     Value 30.
003200        88 DBDeleteNotfnd Value 31.
003300        88 DBDeleteError  Value 39.
003400
003500        88 DBAddOK        Value 40.
003600        88 DBAddDuprec    Value 41.
003700        88 DBAddError     Value 49.
003800
003900        88 DBRequestError Value 99.
004000
004100     05 MyDBRecord.
004200        10 Empno   Pic X(05).
004300        10 Ssno    Pic X(10).
004400        10 Fname   Pic X(20).
004500        10 Lname   Pic X(20).
004600        10 Dpt     Pic X(05).
004700        10         Pic X(20).
004800     05            Pic X(20).
004900
005000 Procedure Division.
005100     Evaluate True
005200        When DBRead
005300           Perform MyDBRead
005400        When DBUpdate
005500           Perform MyDBUpdate
005600        When DBDelete
005700           Perform MyDBDelete
005800        When DBAdd
005900           Perform MyDBAdd
006000        When Other
006100           Set DBRequestError to True
006200     End-Evaluate
006300     Exec CICS
006400          Return
006500     End-Exec
006600     .
006700*--------------------------------------------
006800 MyDBRead.
006900*--------------------------------------------
007000     Exec CICS
007100          Read
007200          File(MyEdempFile)
007300          Into(MyDBRecord)
007400          Ridfld(Empno)
007500          Resp(MyResp)
007600     End-Exec
007700     Evaluate True
007800        When Myresp = DFHRESP(NORMAL)
007900           Set DBReadOK to True
008000        When Myresp = DFHRESP(NOTFND)
008100           Set DBReadNotFnd to True
008200        When Other
008300           Set DBReadError to True
008400     End-Evaluate
008500     .
008600*--------------------------------------------
008700 MyDBUpdate.
008800*--------------------------------------------
008900     Exec CICS
009000          Read
009100          File(MyEdempFile)
009200          Into(MyDBRecordDBUpdate)
009300          Ridfld(Empno)
009400          Update
009500          Resp(MyResp)
009600     End-Exec
009700     Evaluate True
009800        When Myresp = DFHRESP(NORMAL)
009900           Perform MyDBRewrite
010000        When Myresp = DFHRESP(NOTFND)
010100           Set DBUpdateNotfnd to True
010200        When Other
010300           Set DBUpdateError to True
010400     End-Evaluate
010500     .
010600*--------------------------------------------
010700 MyDBRewrite.
010800*--------------------------------------------
010900     Exec CICS
011000          Rewrite
011100          File(MyEdempFile)
011200          From(MyDBRecord)
011300          Resp(MyResp)
011400     End-Exec
011500     Evaluate True
011600        When Myresp = DFHRESP(NORMAL)
011700           Set DBUpdateOK to True
011800        When Other
011900           Set DBUpdateError to True
012000     End-Evaluate
012100     .
012200*--------------------------------------------
012300 MyDBDelete.
012400*--------------------------------------------
012500     Exec CICS
012600          Delete
012700          File(MyEdempFile)
012800          Ridfld(Empno)
012900          Resp(MyResp)
013000     End-Exec
013100     Evaluate True
013200        When Myresp = DFHRESP(NORMAL)
013300           Set DBDeleteOK to True
013400        When Myresp = DFHRESP(NOTFND)
013500           Set DBDeleteNotfnd to True
013600        When Other
013700           Set DBDeleteError to True
013800     End-Evaluate
013900     .
014000*--------------------------------------------
014100 MyDBAdd.
014200*--------------------------------------------
014300     Exec CICS
014400          Write
014500          File(MyEdempFile)
014600          Ridfld(Empno)
014700          From(MyDBRecord)
014800          Resp(MyResp)
014900     End-Exec
015000     Evaluate True
015100        When Myresp = DFHRESP(NORMAL)
015200           Set DBAddOK  to True
015300        When Myresp = DFHRESP(DUPREC)
015400           Set DBAddDuprec to True
015500        When Other
015600           Set DBAddError to True
015700     End-Evaluate
015800     .
015900*--------------------------------------------
016000 End Program ED0DB1B.
016100*--------------------------------------------