identification division. program-id. ETPEIMS. author. Heirloom Computing Inc. ****************************************************************** * Copyright (C) 2010-2016 Heirloom Computing Inc. * * * * ALL RIGHTS RESERVED * ****************************************************************** * * * Property of Heirloom Computing Inc. This software contains * * confidential and proprietary information of Heirloom Computing * * Inc. and is made available solely pursuant to the terms of a * * software license agreement, which governs its use. * * * * No disclosure, reproduction or use of any portion of these * * materials may be made without the express written consent of * * Heirloom Computing Inc. * * * ****************************************************************** * ETPEIMS - CICS READ / WRITE / READ NEXT * Use IMS DB from within CICS * * setup required. Use EBP test case job TEST99 * to setup an IMS DB with three segments: LIBSEG (seg# '0'), * BOOKSEG (seg# '1'), and MAGSEG (seg# '2'). * Define the same JDBC connections used there * on the SQL tab of the ETP Deploy Settings * * Postgres and set up the ETP settings SQL tab: * connection name: MYCONN * username: postgres * password: abc000 * url: jdbc:postgres:MYDB * driver: org.postgresql.Driver * * This EIMS transaction allows IMS DB operations GU using 1 or 2 * keys (Library name and Book or Magazine name, plus segment * number 1, 2 or 3 to get a unique IMS DB segment. GN will get * the next segment after that (GNP will get next segment of the * same segment type that is under the current parent). * * This test uses CBLTDLI program calls. No EXEC DLI support yet. * working-storage section. COPY DFHAID. * for IMS-DB COPY DLIUIB. 01 ws-program-name pic x(8) value 'ETPEIMS'. ***--------------------------------------------------------------* *** Menu * ***--------------------------------------------------------------* copy BMSEIMS. 01 ws-cwa-ptr pointer. 01 ws-oper pic s9(4). 01 ws-conn pic x(16). 01 ws-end-msg pic x(30) value ' EIMS session terminated.'. 01 ws-info-msg pic x(30). 01 ws-work. 03 ws-next-tran pic x(4). 01 ws-status pic x(2). 01 ws-sno pic x(1). 01 ws-commarea. 03 ws-map pic x(8). 01 result-code pic s9(5) comp. 01 m-err pic x(80). 01 ws-connectst pic s9(9) binary. 01 ws-disp pic s9(9). 01 seg-i-o Pic X(50). 01 lib-seg. 03 lib-name Pic X(10). 03 lib-addr Pic X(20). 01 book-seg. 03 book-name Pic X(20). 03 book-author Pic X(30). 01 mag-seg. 03 mag-name Pic X(15). 03 mag-publisher Pic X(20). 01 LIB-SSA. 05 SEGMENT-NAME PIC X(8) VALUE 'LIBSEG'. 05 FILLER PIC X VALUE '('. 05 FIELD-NAME PIC X(8) VALUE 'LIBRARY'. 05 REL-OPR PIC X(2) VALUE '='. 05 SEARCH-VALUE PIC X(10). 05 FILLER PIC X VALUE ')'. 01 BOOK-SSA. 05 SEGMENT-NAME PIC X(8) VALUE 'BOOKSEG'. 05 FILLER PIC X VALUE '('. 05 FIELD-NAME PIC X(8) VALUE 'BOOK'. 05 REL-OPR PIC X(2) VALUE '='. 05 SEARCH-VALUE PIC X(20). 05 FILLER PIC X VALUE ')'. 01 MAG-SSA. 05 SEGMENT-NAME PIC X(8) VALUE 'MAGSEG'. 05 FILLER PIC X VALUE '('. 05 FIELD-NAME PIC X(8) VALUE 'MAGAZINE'. 05 REL-OPR PIC X(2) VALUE '='. 05 SEARCH-VALUE PIC X(15). 05 FILLER PIC X VALUE ')'. 77 CICS-RESP PIC S9(8) BINARY. 01 CICS-RESP-DISP PIC S9(8). 01 CUST-LNG PIC S9(4) COMP VALUE +80. 01 ws-external-key PIC X(10). * IMS DB standards 01 DLI-FUNCTIONS. 05 DLI-CALLBACK PIC X(8) VALUE 'CBLTDLI '. 05 DLI-GU PIC X(4) VALUE 'GU '. 05 DLI-GHU PIC X(4) VALUE 'GHU '. 05 DLI-GN PIC X(4) VALUE 'GN '. 05 DLI-GHN PIC X(4) VALUE 'GHN '. 05 DLI-GNP PIC X(4) VALUE 'GNP '. 05 DLI-GHNP PIC X(4) VALUE 'GHNP'. 05 DLI-ISRT PIC X(4) VALUE 'ISRT'. 05 DLI-DLET PIC X(4) VALUE 'DLET'. 05 DLI-REPL PIC X(4) VALUE 'REPL'. 05 DLI-CHKP PIC X(4) VALUE 'CHKP'. 05 DLI-XRST PIC X(4) VALUE 'XRST'. 05 DLI-PCB PIC X(4) VALUE 'PCB '. 01 ETP-PCB. 05 DBD-NAME PIC X(8). 05 SEG-LEVEL PIC XX. 05 STATUS-CODE PIC XX. 05 PROC-OPTIONS PIC X(4). 05 RESERVED-DLI PIC S9(5). 05 SEG-NAME PIC X(8). 05 LENGTH-FB-KEY PIC S9(5). 05 NUMB-SENS-SEGS PIC S9(5). 05 KEY-FB-AREA PIC X. linkage section. 01 dfhcommarea. 03 pic x occurs 0 to 32700 times depending on eibcalen. ***--------------------------------------------------------------* *** CICS Stuff * ***--------------------------------------------------------------* procedure division. main-para. move spaces to ws-next-tran. * enter this main due to (1) CICS transfer from another * transaction or (2) return map from this transaction perform cesn-mainline * return to CICS because we're (1) waiting to receive our map * or (2) we want to transfer to a different transaction if ws-next-tran = spaces exec cics return transid(eibtrnid) commarea(ws-commarea) end-exec else move ws-next-tran to eibtrnid exec cics return immediate transid(eibtrnid) end-exec end-if. stop run . ***--------------------------------------------------------------* cesn-mainline section. cesn-mainline-para. * determine if we are receiving our own map * (shouldn't we check if ws-map = 'BMSEIMS' ??) if eibcalen = length of ws-commarea move dfhcommarea to ws-commarea * receive the map of our screen (if not CLEAR) if eibaid not = DFHCLEAR move SPACES to EIMSSEGI move SPACES to EIMSSEGO move SPACES to EIMSSNOI move SPACES to EIMSSNOO move SPACES to EIMSLIBI move SPACES to EIMSLIBO move SPACES to EIMSBOKI move SPACES to EIMSBOKO move SPACES to EIMSMAGI move SPACES to EIMSMAGO move SPACES to EIMSMSGO perform cics-receive-map end-if * establish the IMS-DB environment CALL DLI-CALLBACK USING DLI-PCB ETP-PCB IF STATUS-CODE NOT = ' ' THEN string 'PCB STATUS ' STATUS-CODE ' - IMS DB NOT OPEN' into EIMSMSGO perform cics-send-scroll exit ELSE * carry out requested operation based on AID key evaluate eibaid * PF12 Exits the CICS-supported Transactions when DFHPF12 * *> PF 12 Key exec cics syncpoint end-exec move eibtrnid to ws-end-msg(1:4) exec cics send text | added text from(ws-end-msg) erase end-exec exec cics return end-exec * PF3 transfers to EMNU menu WHEN DFHPF3 move 'EMNU' to ws-next-tran * PF4 GU the given LIB, BOK and/or MAG keys WHEN DFHPF4 perform dogu perform cics-send-scroll * PF5 GN from the current segment WHEN DFHPF5 perform dogn perform cics-send-scroll * PF6 GNP from the current segment WHEN DFHPF6 perform dognp perform cics-send-scroll * PF7 ISRT using SNO, LIB, BOK, MAG and SEG WHEN DFHPF7 perform doisrt perform cics-send-scroll * PF8 GU + DLET using key fields, seg# WHEN DFHPF8 perform dodlet perform cics-send-scroll * PF9 GU + REPL using key fields, seg# WHEN DFHPF9 perform dorepl perform cics-send-scroll * ENTER does retrieves the first root segment (GU) * and proceeds sequentially from there (GN) when DFHENTER IF EIMSLIBI = SPACES THEN move '0' to EIMSSNOI move spaces to EIMSLIBI perform dogu move EIMSSEGO to EIMSLIBO ELSE perform dogn END-IF perform cics-send-scroll * CLEAR key refreshes the screen when DFHCLEAR * *> Clear Key move SPACES to EIMSSEGI move SPACES to EIMSLIBI move SPACES to EIMSSEGO move SPACES to EIMSLIBO move 'Display reset by clear key' to EIMSMSGO perform cics-send-new * Unknown PF key when other move 'Unexpected 3270 attention key' to EIMSMSGO perform cics-send-new end-evaluate end-if else perform cics-send-new end-if skip. exit . ***--------------------------------------------------------------* cics-receive-map section. cics-receive-map-para. evaluate ws-map when 'BMSEIMS' exec cics receive map(ws-map) into(BMSEIMSI) nohandle end-exec if eibresp = dfhresp(normal) move spaces to ws-next-tran end-if end-evaluate exit ***--------------------------------------------------------------* dogu section. dogu-para. * assume user has put a key in the input key field add 1 to ws-oper * perform IMS DB Get Unique operation EVALUATE EIMSSNOI WHEN ' ' * special case - get the first root segment CALL DLI-CALLBACK USING DLI-GU ETP-PCB LIB-SEG WHEN '0' * get a specific library segment MOVE '0' TO WS-SNO MOVE 'LIBSEG' TO SEG-NAME MOVE EIMSLIBI TO SEARCH-VALUE OF LIB-SSA CALL DLI-CALLBACK USING DLI-GU ETP-PCB LIB-SEG LIB-SSA WHEN '1' * get a specific book within a library segment MOVE '1' TO WS-SNO MOVE 'BOOKSEG' TO SEG-NAME MOVE EIMSLIBI TO SEARCH-VALUE OF LIB-SSA MOVE EIMSBOKI TO SEARCH-VALUE OF BOOK-SSA CALL DLI-CALLBACK USING DLI-GU ETP-PCB BOOK-SEG LIB-SSA BOOK-SSA WHEN '2' * get a specific magazine within a library segment MOVE '2' TO WS-SNO MOVE 'MAGSEG' TO SEG-NAME MOVE EIMSLIBI TO SEARCH-VALUE OF LIB-SSA MOVE EIMSMAGI TO SEARCH-VALUE OF MAG-SSA CALL DLI-CALLBACK USING DLI-GU ETP-PCB MAG-SEG LIB-SSA MAG-SSA WHEN OTHER * not one of those selections MOVE 'SEGMENT NUMBER MUST BE 0, 1 OR 2' TO EIMSMSGO MOVE 'xx' TO STATUS-CODE END-EVALUATE. IF STATUS-CODE NOT = ' ' THEN IF STATUS-CODE NOT = 'xx' THEN string 'GU STATUS ' STATUS-CODE ' - IMS DB ERROR' into EIMSMSGO END-IF MOVE SPACES TO EIMSLIBO MOVE SPACES TO EIMSBOKO MOVE SPACES TO EIMSMAGO MOVE SPACES TO EIMSSEGO MOVE SPACES TO EIMSSNOO ELSE EVALUATE EIMSSNOI WHEN '0' MOVE LIB-SEG TO EIMSSEGO WHEN '1' MOVE BOOK-SEG TO EIMSSEGO WHEN '2' MOVE MAG-SEG TO EIMSSEGO END-EVALUATE string "GU - Segment retrieved " ws-oper into EIMSMSGO END-IF. ***--------------------------------------------------------------* dogn section. dogn-para. add 1 to ws-oper * perform IMS DB Get Next operation (no key, segment # needed) * does CICS IMS-DB maintain state? CICS file I/O does not, you * need to re-establish access to a keyed record to do a READ NEXT * operation in a different transaction. Does GN require a GU * in CICS? It does not in ETP where the "private static" vars CALL DLI-CALLBACK USING DLI-GN ETP-PCB SEG-I-O IF STATUS-CODE NOT = ' ' THEN EVALUATE STATUS-CODE WHEN 'GE' STRING 'GN - STATUS GE - End of segments' into EIMSMSGO WHEN 'AB' STRING 'GN - STATUS AB - Missing parm' into EIMSMSGO WHEN 'ZZ' STRING 'GN - STATUS ZZ - Internal err' into EIMSMSGO WHEN OTHER STRING 'GN - STATUS ' STATUS-CODE into EIMSMSGO END-EVALUATE MOVE SPACES TO EIMSLIBO MOVE SPACES TO EIMSBOKO MOVE SPACES TO EIMSMAGO MOVE SPACES TO EIMSSEGO MOVE SPACES TO EIMSSNOO ELSE * provide feedback as to which segment type was actually retrieved EVALUATE SEG-NAME WHEN 'LIBSEG ' MOVE 0 TO EIMSSNOO MOVE SEG-I-O TO LIB-SEG MOVE LIB-NAME TO EIMSLIBO MOVE SPACES TO EIMSBOKO MOVE SPACES TO EIMSMAGO WHEN 'BOOKSEG ' MOVE 1 TO EIMSSNOO MOVE SEG-I-O TO BOOK-SEG MOVE EIMSLIBI TO EIMSLIBO MOVE BOOK-NAME TO EIMSBOKO MOVE SPACES TO EIMSMAGO WHEN 'MAGSEG ' MOVE 2 TO EIMSSNOO MOVE SEG-I-O TO MAG-SEG MOVE EIMSLIBI TO EIMSLIBO MOVE SPACES TO EIMSBOKO MOVE MAG-NAME TO EIMSMAGO WHEN OTHER MOVE '?' TO EIMSSNOO END-EVALUATE MOVE SEG-I-O TO EIMSSEGO string "GN - Segment retrieved " ws-oper into EIMSMSGO END-IF. ***--------------------------------------------------------------* dognp section. dognp-para. add 1 to ws-oper * perform IMS DB Get Next within Parent operation CALL DLI-CALLBACK USING DLI-GN ETP-PCB SEG-I-O IF STATUS-CODE NOT = ' ' THEN EVALUATE STATUS-CODE WHEN 'GE' STRING 'GNP - STATUS GE - End of segments' into EIMSMSGO WHEN 'AB' STRING 'GNP - STATUS AB - Missing parm' into EIMSMSGO WHEN 'ZZ' STRING 'GNP - STATUS ZZ - Internal err' into EIMSMSGO WHEN OTHER STRING 'GNP - STATUS ' STATUS-CODE into EIMSMSGO END-EVALUATE MOVE SPACES TO EIMSLIBO ELSE * provide feedback as to which segment type was actually retrieved EVALUATE SEG-NAME WHEN 'LIBSEG ' MOVE 0 TO EIMSSNOO MOVE SEG-I-O TO LIB-SEG MOVE LIB-NAME TO EIMSLIBO MOVE SPACES TO EIMSBOKO MOVE SPACES TO EIMSMAGO WHEN 'BOOKSEG ' MOVE 1 TO EIMSSNOO MOVE SEG-I-O TO BOOK-SEG MOVE EIMSLIBI TO EIMSLIBO MOVE BOOK-NAME TO EIMSBOKO MOVE SPACES TO EIMSMAGO WHEN 'MAGSEG ' MOVE 2 TO EIMSSNOO MOVE SEG-I-O TO MAG-SEG MOVE EIMSLIBI TO EIMSLIBO MOVE SPACES TO EIMSBOKO MOVE MAG-NAME TO EIMSMAGO WHEN OTHER MOVE '?' TO EIMSSNOO END-EVALUATE MOVE SEG-I-O TO EIMSSEGO string "GNP - Segment retrieved " ws-oper into EIMSMSGO END-IF. ***--------------------------------------------------------------* doisrt section. doisrt-para. add 1 to ws-oper * perform IMS DB Insert operation EVALUATE EIMSSNOI WHEN '0' MOVE '0' TO WS-SNO MOVE 'LIBSEG' TO SEG-NAME MOVE EIMSSEGI TO LIB-SEG IF EIMSLIBI = SPACES THEN string "ISRT - Must supply library name" into EIMSMSGO ELSE MOVE EIMSLIBI TO SEARCH-VALUE OF LIB-SSA CALL DLI-CALLBACK USING DLI-ISRT ETP-PCB LIB-SEG LIB-SSA END-IF WHEN '1' MOVE '1' TO WS-SNO MOVE 'BOOKSEG' TO SEG-NAME MOVE EIMSSEGI TO BOOK-SEG IF (EIMSLIBI = SPACES) OR (EIMSBOKI = SPACES) THEN string "ISRT - Must supply library, book names" into EIMSMSGO ELSE MOVE EIMSLIBI TO SEARCH-VALUE OF LIB-SSA MOVE EIMSBOKI TO SEARCH-VALUE OF BOOK-SSA CALL DLI-CALLBACK USING DLI-ISRT ETP-PCB BOOK-SEG LIB-SSA BOOK-SSA END-IF WHEN '2' MOVE '2' TO WS-SNO MOVE 'MAGSEG' TO SEG-NAME MOVE EIMSSEGI TO MAG-SEG IF (EIMSLIBI = SPACES) OR (EIMSMAGI = SPACES) THEN string "ISRT - Must supply library, magazine names" into EIMSMSGO ELSE MOVE EIMSLIBI TO SEARCH-VALUE OF LIB-SSA MOVE EIMSMAGI TO SEARCH-VALUE OF MAG-SSA CALL DLI-CALLBACK USING DLI-ISRT ETP-PCB MAG-SEG LIB-SSA MAG-SSA END-IF WHEN OTHER MOVE 'SEGMENT NUMBER MUST BE 0, 1 OR 2' TO EIMSMSGO MOVE 'xx' TO STATUS-CODE END-EVALUATE. IF STATUS-CODE NOT = ' ' THEN IF STATUS-CODE NOT = 'xx' THEN string 'GU STATUS ' STATUS-CODE ' - IMS DB ERROR' into EIMSMSGO END-IF ELSE string "ISRT - Segment inserted " ws-oper into EIMSMSGO END-IF. ***--------------------------------------------------------------* dodlet section. dodlet-para. add 1 to ws-oper * perform IMS DB Delete operation EVALUATE EIMSSNOI WHEN '0' MOVE '0' TO WS-SNO MOVE 'LIBSEG' TO SEG-NAME MOVE EIMSSEGI TO LIB-SEG IF EIMSLIBI = SPACES THEN string "DLET - Must supply library name" into EIMSMSGO ELSE MOVE EIMSLIBI TO SEARCH-VALUE OF LIB-SSA CALL DLI-CALLBACK USING DLI-GHU ETP-PCB LIB-SEG LIB-SSA IF STATUS-CODE = ' ' THEN CALL DLI-CALLBACK USING DLI-DLET ETP-PCB LIB-SEG END-IF END-IF WHEN '1' MOVE '1' TO WS-SNO MOVE 'BOOKSEG' TO SEG-NAME MOVE EIMSSEGI TO BOOK-SEG IF (EIMSLIBI = SPACES) OR (EIMSBOKI = SPACES) THEN string "DLET - Must supply library, book names" into EIMSMSGO ELSE MOVE EIMSLIBI TO SEARCH-VALUE OF LIB-SSA MOVE EIMSBOKI TO SEARCH-VALUE OF BOOK-SSA CALL DLI-CALLBACK USING DLI-GHU ETP-PCB BOOK-SEG LIB-SSA BOOK-SSA IF STATUS-CODE = ' ' THEN CALL DLI-CALLBACK USING DLI-DLET ETP-PCB BOOK-SEG END-IF END-IF WHEN '2' MOVE '2' TO WS-SNO MOVE 'MAGSEG' TO SEG-NAME MOVE EIMSSEGI TO MAG-SEG IF (EIMSLIBI = SPACES) OR (EIMSMAGI = SPACES) THEN string "ISRT - Must supply library, magazine names" into EIMSMSGO ELSE MOVE EIMSLIBI TO SEARCH-VALUE OF LIB-SSA MOVE EIMSMAGI TO SEARCH-VALUE OF MAG-SSA CALL DLI-CALLBACK USING DLI-GHU ETP-PCB MAG-SEG LIB-SSA MAG-SSA IF STATUS-CODE = ' ' THEN CALL DLI-CALLBACK USING DLI-DLET ETP-PCB MAG-SEG END-IF END-IF WHEN OTHER MOVE 'SEGMENT NUMBER MUST BE 0, 1 OR 2' TO EIMSMSGO MOVE 'xx' TO STATUS-CODE END-EVALUATE. IF STATUS-CODE NOT = ' ' THEN IF STATUS-CODE NOT = 'xx' THEN string 'GHU/DLET STATUS ' STATUS-CODE ' - IMS DB ERROR' into EIMSMSGO END-IF ELSE string "DLET - Segment deleted " ws-oper into EIMSMSGO END-IF. ***--------------------------------------------------------------* dorepl section. dorepl-para. add 1 to ws-oper * perform IMS DB Replace operation EVALUATE EIMSSNOI WHEN '0' MOVE '0' TO WS-SNO MOVE 'LIBSEG' TO SEG-NAME IF EIMSLIBI = SPACES THEN string "DLET - Must supply library name" into EIMSMSGO ELSE MOVE EIMSLIBI TO SEARCH-VALUE OF LIB-SSA CALL DLI-CALLBACK USING DLI-GHU ETP-PCB LIB-SEG LIB-SSA IF STATUS-CODE = ' ' THEN MOVE EIMSSEGI TO LIB-SEG CALL DLI-CALLBACK USING DLI-REPL ETP-PCB LIB-SEG END-IF END-IF WHEN '1' MOVE '1' TO WS-SNO MOVE 'BOOKSEG' TO SEG-NAME IF (EIMSLIBI = SPACES) OR (EIMSBOKI = SPACES) THEN string "DLET - Must supply library, book names" into EIMSMSGO ELSE MOVE EIMSLIBI TO SEARCH-VALUE OF LIB-SSA MOVE EIMSBOKI TO SEARCH-VALUE OF BOOK-SSA CALL DLI-CALLBACK USING DLI-GHU ETP-PCB BOOK-SEG LIB-SSA BOOK-SSA IF STATUS-CODE = ' ' THEN MOVE EIMSSEGI TO BOOK-SEG CALL DLI-CALLBACK USING DLI-REPL ETP-PCB BOOK-SEG END-IF END-IF WHEN '2' MOVE '2' TO WS-SNO MOVE 'MAGSEG' TO SEG-NAME IF (EIMSLIBI = SPACES) OR (EIMSMAGI = SPACES) THEN string "ISRT - Must supply library, magazine names" into EIMSMSGO ELSE MOVE EIMSLIBI TO SEARCH-VALUE OF LIB-SSA MOVE EIMSMAGI TO SEARCH-VALUE OF MAG-SSA CALL DLI-CALLBACK USING DLI-GHU ETP-PCB MAG-SEG LIB-SSA MAG-SSA IF STATUS-CODE = ' ' THEN MOVE EIMSSEGI TO MAG-SEG CALL DLI-CALLBACK USING DLI-REPL ETP-PCB MAG-SEG END-IF END-IF WHEN OTHER MOVE 'SEGMENT NUMBER MUST BE 0, 1 OR 2' TO EIMSMSGO MOVE 'xx' TO STATUS-CODE END-EVALUATE. IF STATUS-CODE NOT = ' ' THEN IF STATUS-CODE NOT = 'xx' THEN string 'GHU/REPL STATUS ' STATUS-CODE ' - IMS DB ERROR' into EIMSMSGO END-IF ELSE string "REPL - Segment replaced " ws-oper into EIMSMSGO END-IF. ***--------------------------------------------------------------* cics-send-new section. cics-send-new-para. move spaces to EIMSSEGO. move spaces to EIMSSNOO. move spaces to EIMSLIBO. move spaces to EIMSBOKO. move spaces to EIMSMAGO. move SPACES to EIMSSNOO move spaces to EIMSMSGO. move 'BMSEIMS' to ws-map exec cics send map(ws-map) from(BMSEIMSO) erase end-exec exit. ***--------------------------------------------------------------* cics-send-scroll section. cics-send-scroll-para. move 'BMSEIMS' to ws-map exec cics send map(ws-map) from(BMSEIMSO) erase end-exec exit. end-program.