DSN8EC1
Demonstrates how a Db2 stored procedure can use IMS Open Database Access (ODBA) to connect to IMS DBCTL and access IMS data.
CBL APOST,LIST,RENT 00000100
IDENTIFICATION DIVISION. 00000200
PROGRAM-ID. DSN8EC1 00000300
00000400
****** DSN8EC1 - DB2 Sample ODBA Stored Procedure *************** 00000500
* * 00000600
* Module Name = DSN8EC1 * 00000700
* * 00000800
* Descriptive Name = DB2 Sample Application * 00000900
* DB2 Sample ODBA Stored Procedure * 00001000
* Batch * 00001100
* Cobol * 00001200
* * 00001300
*LICENSED MATERIALS - PROPERTY OF IBM * 00001400
*5675-DB2 * 00001500
*(C) COPYRIGHT 1999, 2000 IBM CORP. ALL RIGHTS RESERVED. * 00001600
* * 00001700
*STATUS = VERSION 7 * 00001800
* * 00001900
* Function = Demonstrates how a DB2 stored procedure can use * 00002000
* IMS Open Database Access (ODBA) to connect to * 00002100
* IMS DBCTL and access IMS data. * 00002200
* * 00002300
* In particular, this program allows its client * 00002400
* to add, retrieve, update, and delete entries in * 00002500
* the IMS IVP telephone directory database, * 00002600
* DSNIVD1. * 00002700
* * 00002800
* * 00002900
* Notes = The following conditions must be satisfied: * 00003000
* (1) DSN8EC1 is registered in DB2 on a server that also * 00003100
* has an IMS subsystem operating at IMS/ESA V6 or a * 00003200
* subsequent release (required for ODBA). * 00003300
* (2) The following IMS IVP parts are available on that IMS * 00003400
* subsystem: * 00003500
* (1) DFSIVD1, the IMS IVP telephone directory database * 00003600
* (2) DFSIVP64, the IMS IVP Cobol PSB for BMP access to * 00003700
* DFSIVD1 * 00003800
* (3) DSN8EC1 must be run a WLM-established stored proce- * 00003900
* dures address space only * 00004000
* (4) The WLM environment associated with DSN8EC1 in SYSIBM.* 00004100
* SYSPROCEDURES is started by a proc that references * 00004200
* the IMS reslib in both the STEPLIB DD concatenation * 00004300
* and in the DFSRESLB DD. See the DB2 Installation * 00004400
* Guide for more information. * 00004500
* * 00004600
* Module Type = Cobol Program * 00004700
* Processor = DB2 for OS/390 precompiler, IBM Cobol * 00004800
* Module Size = See linkedit output * 00004900
* Attributes = Re-entrant * 00005000
* * 00005100
* * 00005200
* Entry Point = DSN8EC1 * 00005300
* Purpose = See function * 00005400
* Linkage = Standard MVS program invocation * 00005500
* Input = Parameters explicitly passed to this function: * 00005600
* TDBCTLID ...... PIC X(8) * 00005700
* - IMS subsystem id * 00005800
* COMMAND ....... PIC X(8) * 00005900
* - Action to perform: ADD, UPD, DIS, DEL * 00006000
* LAST-NAME ..... PIC X(10) * 00006100
* FIRST-NAME .... PIC X(10) * 00006200
* EXTENSION ..... PIC X(10) * 00006300
* ZIP-CODE ...... PIC X(7) * 00006400
* * 00006500
* Output = Parameters explicitly passed by this function * 00006600
* COMMAND ....... PIC X(8) * 00006700
* - Action performed: ADD, UPD, DIS, DEL * 00006800
* LAST-NAME ..... PIC X(10) * 00006900
* FIRST-NAME .... PIC X(10) * 00007000
* EXTENSION ..... PIC X(10) * 00007100
* ZIP-CODE ...... PIC X(7) * 00007200
* AIBRETRN ...... PIC S9(9) COMP * 00007300
* - Return code from IMS AIB call * 00007400
* AIBREASN ...... PIC S9(9) COMP * 00007500
* - Reason code from IMS AIB call * 00007600
* ERROR-CALL .... PIC X(4) * 00007700
* - DL/I command that failed * 00007800
* * 00007900
* Exit-Normal = Return Code 0 Normal Completion * 00008000
* * 00008100
* Exit-Error = Return Code 0 Abnormal Completion * 00008200
* * 00008300
* Error Messages = None: Errors are signaled by means of * 00008400
* SQLCODEs and DL/I codes returned to the * 00008500
* client. * 00008600
* * 00008700
* External References = * 00008800
* Routines/Services = * 00008900
* AERTDLI - DL/I interface for ODBA * 00009000
* * 00009100
* Data areas = None * 00009200
* * 00009300
* Control Blocks = * 00009400
* AIB - DL/I Application Interface Block * 00009500
* * 00009600
* Tables = None * 00009700
* * 00009800
* * 00009900
* Change Activity = None * 00010000
* * 00010100
* * 00010200
* *Pseudocode* * 00010300
* * 00010400
* PROCEDURE A00000-ODBA-SP * 00010500
* Call B10000-ALLOCATE-AIB to allocate the IMS AIB * 00010600
* Call B20000-PREPARE-REQUEST to format input from the client* 00010700
* Call B30000-PROCESS-REQUEST to access data on IMS * 00010800
* Call C31000-ADD-ENTRY if client passed ADD request * 00010900
* Call D31100-INSERT-TO-DB to process IMS ISRT * 00011000
* Call C32000-UPDATE-ENTRY if client passed UPD request * 00011100
* Call D32100-GET-HOLD-UNIQUE-FROM-DB for IMS GHU * 00011200
* Call D32200-REPLACE-IN-DB for IMS REPL * 00011300
* Call C33000-DELETE-ENTRY if client passed DEL request * 00011400
* Call D32100-GET-HOLD-UNIQUE-FROM-DB for IMS GHU * 00011500
* Call D33200-DELETE-FROM-DB for IMS DLET * 00011600
* Call C34000-DISPLAY-ENTRY if client passed DIS request* 00011700
* Call D34100-GET-UNIQUE-FROM-DB for IMS GU * 00011800
* Call B40000-DEALLOCATE-AIB to pend unit of work on IMS * 00011900
* * 00012000
*---------------------------------------------------------------* 00012100
00012200
00012300
00012400
ENVIRONMENT DIVISION. 00012500
CONFIGURATION SECTION. 00012600
SOURCE-COMPUTER. IBM-370. 00012700
OBJECT-COMPUTER. IBM-370. 00012800
00012900
INPUT-OUTPUT SECTION. 00013000
00013100
DATA DIVISION. 00013200
WORKING-STORAGE SECTION. 00013300
00013400
***************************************************************** 00013500
* DL/I-related declarations 00013600
***************************************************************** 00013700
* Application Interface Block(AIB) mapping 00013800
01 AIB. 00013900
02 AIBID PIC X(8). 00014000
02 AIBLEN PIC 9(9) USAGE BINARY. 00014100
02 AIBSFUNC PIC X(8). 00014200
02 AIBRSNM1 PIC X(8). 00014300
02 AIBRSNM2 PIC X(8). 00014400
02 AIBRESV1 PIC X(8). 00014500
02 AIBOALEN PIC 9(9) USAGE BINARY. 00014600
02 AIBOAUSE PIC 9(9) USAGE BINARY. 00014700
02 AIBRESV2 PIC X(12). 00014800
02 AIBRETRN PIC 9(9) USAGE BINARY. 00014900
02 AIBREASN PIC 9(9) USAGE BINARY. 00015000
02 AIBRESV3 PIC X(4). 00015100
02 AIBRESA1 USAGE POINTER. 00015200
02 AIBRESA2 USAGE POINTER. 00015300
02 AIBRESA3 USAGE POINTER. 00015400
02 AIBRESV4 PIC X(40). 00015500
02 AIBSAVE OCCURS 18 TIMES 00015600
USAGE POINTER. 00015700
02 AIBTOKN OCCURS 6 TIMES 00015800
USAGE POINTER. 00015900
02 AIBTOKC PIC X(16). 00016000
02 AIBTOKV PIC X(16). 00016100
02 AIBTOKA OCCURS 2 TIMES 00016200
PIC 9(9) USAGE BINARY. 00016300
00016400
* Segment Search Argument (SSA) 00016500
01 SSA. 00016600
02 SEGMENT-NAME PIC X(8) VALUE 'A1111111'. 00016700
02 SEG-KEY-NAME PIC X(11) VALUE '(A1111111 ='. 00016800
02 SSA-KEY PIC X(10). 00016900
02 FILLER PIC X VALUE ')'. 00017000
00017100
* Initializers 00017200
77 SSA1 PIC X(9) VALUE 'A1111111 '. 00017300
77 APSBNME PIC X(8) VALUE 'DFSIVP6'. 00017400
77 DPCBNME PIC X(8) VALUE 'TELEPCB1'. 00017500
77 VAIBID PIC X(8) VALUE 'DFSAIB '. 00017600
77 SFPREP PIC X(4) VALUE 'PREP'. 00017700
00017800
* DL/I function codes 00017900
77 GET-UNIQUE PIC X(4) VALUE 'GU '. 00018000
77 GET-HOLD-UNIQUE PIC X(4) VALUE 'GHU '. 00018100
77 GET-NEXT PIC X(4) VALUE 'GN '. 00018200
77 ISRT PIC X(4) VALUE 'ISRT'. 00018300
77 DLET PIC X(4) VALUE 'DLET'. 00018400
77 REPL PIC X(4) VALUE 'REPL'. 00018500
77 APSB PIC X(4) VALUE 'APSB'. 00018600
77 DPSB PIC X(4) VALUE 'DPSB'. 00018700
77 APPERR PIC X(3) VALUE '264'. 00018800
77 INVCMD PIC X(3) VALUE '440'. 00018900
77 NOKEY PIC X(3) VALUE '218'. 00019000
00019100
***************************************************************** 00019200
* I/O area for datacase handling 00019300
***************************************************************** 00019400
01 IOAREA. 00019500
02 IO-BLANK PIC X(37) VALUE SPACES. 00019600
02 IO-DATA REDEFINES IO-BLANK. 00019700
03 IO-LAST-NAME PIC X(10). 00019800
03 IO-FIRST-NAME PIC X(10). 00019900
03 IO-EXTENSION PIC X(10). 00020000
03 IO-ZIP-CODE PIC X(7). 00020100
02 IO-FILLER PIC X(3) VALUE SPACES. 00020200
02 IO-COMMAND PIC X(8) VALUE SPACES. 00020300
00020400
01 DB2IN-COMMAND. 00020500
02 DB2IW-COMMAND PIC X(8). 00020600
02 DB2TEMP-COMMAND REDEFINES DB2IW-COMMAND. 00020700
03 DB2TEMP-IOCMD PIC X(3). 00020800
03 FILLER PIC X(5). 00020900
00021000
***************************************************************** 00021100
* Miscellaneous variables 00021200
***************************************************************** 00021300
77 TEMP-ONE PICTURE X(8) VALUE SPACES. 00021400
77 TEMP-TWO PICTURE X(8) VALUE SPACES. 00021500
77 REPLY PICTURE X(16). 00021600
00021700
01 FLAGS. 00021800
02 SET-DATA-FLAG PIC X VALUE '0'. 00021900
88 NO-SET-DATA VALUE '1'. 00022000
02 TADD-FLAG PIC X VALUE '0'. 00022100
88 PROCESS-TADD VALUE '1'. 00022200
00022300
01 COUNTERS. 00022400
02 L-SPACE-CTR PIC 9(2) COMP VALUE 0. 00022500
00022600
01 RUN-STATUS PIC X(4). 00022700
88 NOT-OKAY VALUE 'BAD'. 00022800
88 OKAY VALUE 'GOOD'. 00022900
00023000
00023100
00023200
LINKAGE SECTION. 00023300
00023400
***************************************************************** 00023500
* Data area for DB2 Stored Procedures input/output 00023600
***************************************************************** 00023700
01 DB2IO-TDBCTLID PIC X(8). 00023800
01 DB2IO-COMMAND PIC X(8). 00023900
01 DB2IO-LAST-NAME PIC X(10). 00024000
01 DB2IO-FIRST-NAME PIC X(10). 00024100
01 DB2IO-EXTENSION PIC X(10). 00024200
01 DB2IO-ZIP-CODE PIC X(7). 00024300
00024400
***************************************************************** 00024500
* Data area for DB2 Stored Procedures output 00024600
***************************************************************** 00024700
01 DB2OUT-AIBRETRN PIC S9(9) COMP. 00024800
01 DB2OUT-AIBREASN PIC S9(9) COMP. 00024900
01 DC-ERROR-CALL PIC X(4). 00025000
00025100
00025200
***************************************************************** 00025300
* Stored Procedure parameter list 00025400
***************************************************************** 00025500
PROCEDURE DIVISION 00025600
USING DB2IO-TDBCTLID, 00025700
DB2IO-COMMAND, 00025800
DB2IO-LAST-NAME, 00025900
DB2IO-FIRST-NAME, 00026000
DB2IO-EXTENSION, 00026100
DB2IO-ZIP-CODE, 00026200
DB2OUT-AIBRETRN, 00026300
DB2OUT-AIBREASN, 00026400
DC-ERROR-CALL. 00026500
00026600
00026700
***************************************************************** 00026800
* Main Driver: Process data passed by client and apply the data 00026900
* to the IMS IVP phone book database, DFSIVD1. 00027000
***************************************************************** 00027100
A00000-ODBA-SP. 00027200
MOVE 'GOOD' TO RUN-STATUS. 00027300
PERFORM B10000-ALLOCATE-AIB. 00027400
IF OKAY THEN 00027500
PERFORM B20000-PREPARE-REQUEST. 00027600
IF OKAY THEN 00027700
PERFORM B30000-PROCESS-REQUEST. 00027800
IF OKAY THEN 00027900
PERFORM B40000-DEALLOCATE-AIB. 00028000
00028100
STOP RUN. 00028200
00028300
00028400
***************************************************************** 00028500
* Initialize and allocate the Application Interface Block 00028600
***************************************************************** 00028700
B10000-ALLOCATE-AIB. 00028800
INITIALIZE AIB. 00028900
SET AIBRESA1 TO NULLS. 00029000
SET AIBRESA2 TO NULLS. 00029100
SET AIBRESA3 TO NULLS. 00029200
MOVE ZEROES to AIBRETRN. 00029300
MOVE ZEROES to AIBREASN. 00029400
MOVE VAIBID to AIBID. 00029500
MOVE LENGTH OF AIB to AIBLEN. 00029600
MOVE SPACES to IOAREA. 00029700
MOVE LENGTH OF IOAREA to AIBOALEN. 00029800
MOVE SPACES TO AIBSFUNC. 00029900
MOVE APSBNME to AIBRSNM1. 00030000
MOVE DB2IO-TDBCTLID to AIBRSNM2. 00030100
00030200
* Allocate the PSB for the AIB 00030300
CALL 'AERTDLI' USING APSB, AIB. 00030400
00030500
IF AIBRETRN EQUAL ZEROES THEN 00030600
MOVE 0 TO SET-DATA-FLAG 00030700
MOVE 0 TO TADD-FLAG 00030800
ELSE 00030900
MOVE 'BAD' TO RUN-STATUS 00031000
MOVE AIBRETRN TO DB2OUT-AIBRETRN 00031100
MOVE AIBREASN TO DB2OUT-AIBREASN. 00031200
00031300
00031400
***************************************************************** 00031500
* Prepare data passed from client for processing by ODBA 00031600
***************************************************************** 00031700
B20000-PREPARE-REQUEST. 00031800
00031900
* Check the leading space in input command and trim it off 00032000
INSPECT DB2IO-COMMAND 00032100
TALLYING L-SPACE-CTR FOR LEADING SPACE 00032200
REPLACING LEADING SPACE BY '*'. 00032300
IF L-SPACE-CTR > 0 THEN 00032400
UNSTRING DB2IO-COMMAND 00032500
DELIMITED BY ALL '*' 00032600
INTO TEMP-ONE TEMP-TWO 00032700
MOVE TEMP-TWO TO DB2IO-COMMAND 00032800
MOVE 0 TO L-SPACE-CTR 00032900
MOVE SPACES TO TEMP-TWO. 00033000
00033100
* Check the leading space in input LAST NAME and trim it off 00033200
INSPECT DB2IO-LAST-NAME 00033300
TALLYING L-SPACE-CTR FOR LEADING SPACE 00033400
REPLACING LEADING SPACE BY '*'. 00033500
IF L-SPACE-CTR > 0 THEN 00033600
UNSTRING DB2IO-LAST-NAME 00033700
DELIMITED BY ALL '*' 00033800
INTO TEMP-ONE TEMP-TWO 00033900
MOVE TEMP-TWO TO DB2IO-LAST-NAME 00034000
MOVE 0 TO L-SPACE-CTR 00034100
MOVE SPACES TO TEMP-TWO. 00034200
00034300
* Check the leading space in input FIRST NAME and trim it off 00034400
INSPECT DB2IO-FIRST-NAME 00034500
TALLYING L-SPACE-CTR FOR LEADING SPACE 00034600
REPLACING LEADING SPACE BY '*'. 00034700
IF L-SPACE-CTR > 0 THEN 00034800
UNSTRING DB2IO-FIRST-NAME 00034900
DELIMITED BY ALL '*' 00035000
INTO TEMP-ONE TEMP-TWO 00035100
MOVE TEMP-TWO TO DB2IO-FIRST-NAME 00035200
MOVE 0 TO L-SPACE-CTR 00035300
MOVE SPACES TO TEMP-TWO. 00035400
00035500
* Check the leading space in input EXTENSION and trim it off 00035600
INSPECT DB2IO-EXTENSION 00035700
TALLYING L-SPACE-CTR FOR LEADING SPACE 00035800
REPLACING LEADING SPACE BY '*'. 00035900
IF L-SPACE-CTR > 0 THEN 00036000
UNSTRING DB2IO-EXTENSION 00036100
DELIMITED BY ALL '*' 00036200
INTO TEMP-ONE TEMP-TWO 00036300
MOVE TEMP-TWO TO DB2IO-EXTENSION 00036400
MOVE 0 TO L-SPACE-CTR 00036500
MOVE SPACES TO TEMP-TWO. 00036600
00036700
* Check the leading space in input ZIP CODE and trim it off 00036800
INSPECT DB2IO-ZIP-CODE 00036900
TALLYING L-SPACE-CTR FOR LEADING SPACE 00037000
REPLACING LEADING SPACE BY '*'. 00037100
IF L-SPACE-CTR > 0 THEN 00037200
UNSTRING DB2IO-ZIP-CODE 00037300
DELIMITED BY ALL '*' 00037400
INTO TEMP-ONE TEMP-TWO 00037500
MOVE TEMP-TWO TO DB2IO-ZIP-CODE 00037600
MOVE 0 TO L-SPACE-CTR 00037700
MOVE SPACES TO TEMP-TWO. 00037800
00037900
* Move the data to IO area for IMS 00038000
MOVE DB2IO-LAST-NAME TO IO-LAST-NAME. 00038100
MOVE DB2IO-COMMAND TO IO-COMMAND. 00038200
MOVE DB2IO-COMMAND TO DB2IN-COMMAND. 00038300
DISPLAY 'TE>DB2TEMP-IOCMD=' DB2TEMP-IOCMD. 00038400
00038500
* If no command specified, issue error 00038600
IF IO-COMMAND EQUAL SPACES THEN 00038700
MOVE 'BAD' TO RUN-STATUS 00038800
MOVE APPERR TO DB2OUT-AIBRETRN 00038900
MOVE INVCMD TO DB2OUT-AIBREASN 00039000
00039100
* If no LAST NAME specified, issue error 00039200
ELSE IF IO-LAST-NAME EQUAL SPACES THEN 00039300
MOVE 'BAD' TO RUN-STATUS 00039400
MOVE APPERR TO DB2OUT-AIBRETRN 00039500
MOVE NOKEY TO DB2OUT-AIBREASN. 00039600
00039700
00039800
***************************************************************** 00039900
* Process the request from the client 00040000
***************************************************************** 00040100
B30000-PROCESS-REQUEST. 00040200
00040300
* If command is ADD, insert a new record 00040400
IF DB2TEMP-IOCMD EQUAL 'ADD' THEN 00040500
PERFORM C31000-ADD-ENTRY 00040600
00040700
* If command is TAD, insert a new record and trace with WTO 00040800
ELSE IF DB2TEMP-IOCMD EQUAL 'TAD' THEN 00040900
MOVE 1 TO TADD-FLAG 00041000
PERFORM C31000-ADD-ENTRY 00041100
00041200
* If command is UPD, update existing record for LAST NAME 00041300
ELSE IF DB2TEMP-IOCMD EQUAL 'UPD' THEN 00041400
PERFORM C32000-UPDATE-ENTRY 00041500
00041600
* If command is DEL, delete record for LAST NAME 00041700
ELSE IF DB2TEMP-IOCMD EQUAL 'DEL' THEN 00041800
PERFORM C33000-DELETE-ENTRY 00041900
00042000
* If command is DIS, display record for LAST NAME 00042100
ELSE IF DB2TEMP-IOCMD EQUAL 'DIS' THEN 00042200
PERFORM C34000-DISPLAY-ENTRY 00042300
00042400
* Otherwise, issue error for unexpected command 00042500
ELSE 00042600
MOVE 'BAD' TO RUN-STATUS 00042700
MOVE APPERR TO DB2OUT-AIBRETRN 00042800
MOVE INVCMD TO DB2OUT-AIBREASN. 00042900
00043000
00043100
***************************************************************** 00043200
* Deallocate the ODBA Application Interface Block 00043300
***************************************************************** 00043400
B40000-DEALLOCATE-AIB. 00043500
MOVE APSBNME to AIBRSNM1. 00043600
* PREP keyword, below, tells IMS to move in-flight transactions 00043700
* to in-doubt state, so checkpoint or rollback can be deferred 00043800
* until DB2 stored procedure client issues COMMIT or ROLLBACK 00043900
MOVE SFPREP to AIBSFUNC. 00044000
00044100
* Deallocate the PSB for the AIB 00044200
CALL 'AERTDLI' USING DPSB, AIB. 00044300
DISPLAY 'AFTER DPSB PREP, DPCBNME=' DPCBNME. 00044400
DISPLAY 'DPSB PREP AIBRETRN=' AIBRETRN. 00044500
DISPLAY 'DPSB PREP AIBREASN=' AIBREASN. 00044600
DISPLAY 'DPSB PREP AIBRSNM1=' AIBRSNM1. 00044700
DISPLAY 'DPSB PREP AIBRSNM2=' AIBRSNM2. 00044800
DISPLAY 'DPSB PREP AIBRESA1=' AIBRESA1. 00044900
DISPLAY 'DPSB PREP AIBRESA2=' AIBRESA2. 00045000
DISPLAY 'DPSB PREP AIBRESA3=' AIBRESA3. 00045100
MOVE AIBRETRN TO DB2OUT-AIBRETRN. 00045200
MOVE AIBREASN TO DB2OUT-AIBREASN. 00045300
00045400
00045500
***************************************************************** 00045600
* Addition request handler 00045700
***************************************************************** 00045800
C31000-ADD-ENTRY. 00045900
MOVE DB2IO-FIRST-NAME TO IO-FIRST-NAME. 00046000
MOVE DB2IO-EXTENSION TO IO-EXTENSION. 00046100
MOVE DB2IO-ZIP-CODE TO IO-ZIP-CODE. 00046200
MOVE IO-COMMAND TO DB2IO-COMMAND. 00046300
00046400
IF DB2IO-FIRST-NAME EQUAL SPACES 00046500
OR DB2IO-EXTENSION EQUAL SPACES 00046600
OR DB2IO-ZIP-CODE EQUAL SPACES THEN 00046700
MOVE 'BAD' TO RUN-STATUS 00046800
MOVE APPERR TO DB2OUT-AIBRETRN 00046900
MOVE INVCMD TO DB2OUT-AIBREASN 00047000
ELSE 00047100
PERFORM D31100-INSERT-TO-DB. 00047200
00047300
00047400
***************************************************************** 00047500
* Update request handler 00047600
***************************************************************** 00047700
C32000-UPDATE-ENTRY. 00047800
MOVE 0 TO SET-DATA-FLAG. 00047900
MOVE IO-LAST-NAME TO SSA-KEY. 00048000
PERFORM D32100-GET-HOLD-UNIQUE-FROM-DB. 00048100
IF AIBRETRN = ZEROES THEN 00048200
IF DB2IO-FIRST-NAME NOT = SPACES THEN 00048300
MOVE 1 TO SET-DATA-FLAG 00048400
MOVE DB2IO-FIRST-NAME TO IO-FIRST-NAME 00048500
END-IF 00048600
IF DB2IO-EXTENSION NOT = SPACES THEN 00048700
MOVE 1 TO SET-DATA-FLAG 00048800
MOVE DB2IO-EXTENSION TO IO-EXTENSION 00048900
END-IF 00049000
IF DB2IO-ZIP-CODE NOT = SPACES THEN 00049100
MOVE 1 TO SET-DATA-FLAG 00049200
MOVE DB2IO-ZIP-CODE TO IO-ZIP-CODE 00049300
END-IF 00049400
MOVE IO-COMMAND TO DB2IO-COMMAND. 00049500
IF NO-SET-DATA THEN 00049600
PERFORM D32200-REPLACE-IN-DB 00049700
ELSE 00049800
MOVE 'BAD' TO RUN-STATUS 00049900
MOVE APPERR TO DB2OUT-AIBRETRN 00050000
MOVE INVCMD TO DB2OUT-AIBREASN. 00050100
00050200
00050300
***************************************************************** 00050400
* Delete request handler 00050500
***************************************************************** 00050600
C33000-DELETE-ENTRY. 00050700
MOVE IO-LAST-NAME TO SSA-KEY. 00050800
PERFORM D32100-GET-HOLD-UNIQUE-FROM-DB. 00050900
IF AIBRETRN = ZEROES THEN 00051000
MOVE IO-COMMAND TO DB2IO-COMMAND 00051100
PERFORM D33200-DELETE-FROM-DB. 00051200
00051300
00051400
***************************************************************** 00051500
* Display request handler 00051600
***************************************************************** 00051700
C34000-DISPLAY-ENTRY. 00051800
MOVE IO-LAST-NAME TO SSA-KEY. 00051900
DISPLAY 'TE>SSA-KEY=' SSA-KEY. 00052000
PERFORM D34100-GET-UNIQUE-FROM-DB. 00052100
IF AIBRETRN = ZEROES THEN 00052200
MOVE IO-LAST-NAME TO DB2IO-LAST-NAME 00052300
MOVE IO-FIRST-NAME TO DB2IO-FIRST-NAME 00052400
MOVE IO-EXTENSION TO DB2IO-EXTENSION 00052500
MOVE IO-ZIP-CODE TO DB2IO-ZIP-CODE 00052600
MOVE IO-COMMAND TO DB2IO-COMMAND. 00052700
00052800
00052900
***************************************************************** 00053000
* Data base segment insert request handler 00053100
***************************************************************** 00053200
D31100-INSERT-TO-DB. 00053300
MOVE DPCBNME to AIBRSNM1. 00053400
CALL 'AERTDLI' USING ISRT, AIB, IOAREA, SSA1. 00053500
IF AIBRETRN = ZEROES THEN 00053600
IF PROCESS-TADD THEN 00053700
DISPLAY 'INSERT IS DONE, REPLY' UPON CONSOLE 00053800
ACCEPT REPLY FROM CONSOLE 00053900
MOVE 0 TO TADD-FLAG 00054000
END-IF 00054100
ELSE 00054200
MOVE 'BAD' TO RUN-STATUS 00054300
DISPLAY 'ISRT AIBRETRN=' AIBRETRN 00054400
DISPLAY 'ISRT AIBREASN=' AIBREASN 00054500
DISPLAY 'ISRT AIBRESA1=' AIBRESA1 00054600
DISPLAY 'ISRT AIBRESA2=' AIBRESA2 00054700
DISPLAY 'ISRT AIBRESA3=' AIBRESA3 00054800
MOVE APPERR TO DB2OUT-AIBRETRN 00054900
MOVE INVCMD TO DB2OUT-AIBREASN 00055000
MOVE ISRT TO DC-ERROR-CALL. 00055100
00055200
00055300
***************************************************************** 00055400
* Data base segment request handler 00055500
***************************************************************** 00055600
D32100-GET-HOLD-UNIQUE-FROM-DB. 00055700
MOVE DPCBNME to AIBRSNM1. 00055800
CALL 'AERTDLI' USING GET-HOLD-UNIQUE, AIB, IOAREA, SSA. 00055900
IF AIBRETRN NOT EQUAL ZEROES THEN 00056000
MOVE 'BAD' TO RUN-STATUS 00056100
MOVE APPERR TO DB2OUT-AIBRETRN 00056200
MOVE INVCMD TO DB2OUT-AIBREASN 00056300
MOVE GET-HOLD-UNIQUE TO DC-ERROR-CALL. 00056400
00056500
00056600
***************************************************************** 00056700
* Data base segment replace request handler 00056800
***************************************************************** 00056900
D32200-REPLACE-IN-DB. 00057000
MOVE DPCBNME to AIBRSNM1. 00057100
CALL 'AERTDLI' USING REPL, AIB, IOAREA. 00057200
IF AIBRETRN NOT EQUAL ZEROES THEN 00057300
MOVE 'BAD' TO RUN-STATUS 00057400
MOVE APPERR TO DB2OUT-AIBRETRN 00057500
MOVE INVCMD TO DB2OUT-AIBREASN 00057600
MOVE REPL TO DC-ERROR-CALL. 00057700
00057800
00057900
***************************************************************** 00058000
* Data base segment delete request handler 00058100
***************************************************************** 00058200
D33200-DELETE-FROM-DB. 00058300
MOVE DPCBNME to AIBRSNM1. 00058400
CALL 'AERTDLI' USING DLET, AIB, IOAREA. 00058500
IF AIBRETRN NOT EQUAL ZEROES THEN 00058600
MOVE 'BAD' TO RUN-STATUS 00058700
MOVE APPERR TO DB2OUT-AIBRETRN 00058800
MOVE INVCMD TO DB2OUT-AIBREASN 00058900
MOVE DLET TO DC-ERROR-CALL. 00059000
00059100
00059200
***************************************************************** 00059300
* Data base segment GET-UNIQUE request handler 00059400
***************************************************************** 00059500
D34100-GET-UNIQUE-FROM-DB. 00059600
MOVE DPCBNME to AIBRSNM1. 00059700
CALL 'AERTDLI' USING GET-UNIQUE, AIB, IOAREA, SSA. 00059800
IF AIBRETRN NOT EQUAL ZEROES THEN 00059900
MOVE 'BAD' TO RUN-STATUS 00060000
DISPLAY 'GU AIBRETRN=' AIBRETRN 00060100
DISPLAY 'GU AIBREASN=' AIBREASN 00060200
DISPLAY 'GU AIBRESA1(ADDR PCB)=' AIBRESA1 00060300
DISPLAY 'GU AIBRESA2=' AIBRESA2 00060400
DISPLAY 'GU AIBRESA3=' AIBRESA3 00060500
MOVE APPERR TO DB2OUT-AIBRETRN 00060600
MOVE INVCMD TO DB2OUT-AIBREASN 00060700
MOVE GET-UNIQUE TO DC-ERROR-CALL. 00060800