Sybase.com

COBOL Code Sample: * MODELRSP - SAMPLE TO ILLUSTRATE SQLDA USAGE

000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. RSPVSCOB.
000300 AUTHOR. RICK BLAZE/SCOTT JACKSON.
000400 DATE-WRITTEN. MAY 17,1995.
000500*****************************************************************
000600* MODELRSP - SAMPLE TO ILLUSTRATE SQLDA USAGE. *
000700* **** NOTE!!!! ****** *
000710* THIS PROGRAM IS RICK BLAZE'S MOST EXCELLENT MODEL.RSP *
000720* MODIFIED FOR USE WITH VS COBOL. DO NOT GIVE THIS TO ANYONE *
000730* OTHER THAN THOSE WHO DO NO HAVE VS COBOL II! *
000740* **** NOTE!!!! ****** *
000750* *
001100* THIS SAMPLE STORED PROCEDURE HAS A LOT OF INTERNAL * *
001200* DOCUMENTATION TO HELP EXPLAIN AND ILLUSTRATE THE PROPER *
001300* USAGE OF THE SQLDA FOR A DB2 OUTPUT PIPE. A ROW IS SET UP *
001400* FOR ALL DATATYPES AND ALL WILL BE SET TO ALLOW NULLS. *
001500* *
001600*****************************************************************
001700
001800 ENVIRONMENT DIVISION.
001900 DATA DIVISION.
002000 WORKING-STORAGE SECTION.
002100
002200 01 FILLER PIC X(27) VALUE
002300 'WORKING-STORAGE STARTS HERE'.
002400
002500 01 SQLDA-POINTER PIC S9(8) COMP.
002600 01 EMPLOYEE-DATA-POINTER PIC S9(8) COMP.
002700 01 INDICATOR-VAR-POINTER PIC S9(8) COMP.
002800 01 SQLDA-SIZE PIC S9(8) COMP.
002900 01 COMPUTED-POINTER PIC S9(8) COMP.
003000
003100 01 WS-LITERALS.
003200 05 WS-STATUS PIC X(06) VALUE 'STATUS'.
003300 05 WS-MESSAGE PIC X(07) VALUE 'MESSAGE'.
003400 05 WS-COMMIT PIC X(06) VALUE 'COMMIT'.
003500 05 WS-ROLLBACK PIC X(08) VALUE 'ROLLBACK'.
003600 05 WS-OPENPIPE PIC X(08) VALUE 'OPENPIPE'.
003700 05 WS-PUTPIPE PIC X(07) VALUE 'PUTPIPE'.
003800 05 WS-GETPIPE PIC X(07) VALUE 'GETPIPE'.
003900 05 WS-CLOSPIPE PIC X(08) VALUE 'CLOSPIPE'.
004000
004100 01 MESSAGES.
004200 05 ERROR1-MSG.
004300 07 ERROR1-TEXT1 PIC X(19) VALUE
004400 'ERROR WITH CALL TO '.
004500 07 ERROR1-CALL PIC X(10) VALUE SPACES.
004600 07 ERROR1-TEXT2 PIC X(14) VALUE
004700 ' - SPRC CODE: '.
004800 07 ERROR1-SPRC PIC X(03) VALUE SPACES.
004900 05 ERROR2-MSG.
005000 07 ERROR2-TEXT2 PIC X(46) VALUE SPACES.
005100 05 WS-LONG-VARCHAR-TEXT.
005200 07 FILLER PIC X(50) VALUE
005300 'THIS IS A LINE OF VERY LONG TEXT TO DEMOMONSTRATE '.
005400 07 FILLER PIC X(50) VALUE
005500 'THAT A LONG VARCHAR DATATYPE CAN BE SENT DOWN A DB'.
005600 07 FILLER PIC X(50) VALUE
005700 '2 OUTPUT PIPE WITH NO PROBLEMS, WORRIES, OR CONSOL'.
005800 07 FILLER PIC X(50) VALUE
005900 'ATION, AS LONG AS ONE REMEMBERS THAT LARGE AMOUNTS'.
006000 07 FILLER PIC X(50) VALUE
006100 ' OF DATA WILL ALWAYS HAVE AN ELEMENT OF UNEXPECTED'.
006200 07 FILLER PIC X(50) VALUE
006300 'NESS. REGARDLESS, USE MDI FOR ALL YOUR SOLUTIONS!'.
006400
006500******************************************************************
006600* DESCRIPTION OF THE MODEL SQLDA *
006700******************************************************************
006800*
006900* SQLTYPES USED IN SQLDA:
007000* VALUE DATA TYPE NULLS ALLOWED
007100* ======= =================== =============
007200* 384/385 DATE NO/YES
007300* 388/389 TIME NO/YES
007400* 392/393 TIMESTAMP NO/YES
007500* 448/449 CHAR VARIABLE LENG NO/YES
007600* 452/453 CHAR FIXED LENGTH NO/YES
007700* 456/457 CHAR LONG VARIABLE NO/YES
007800* 480/481 FLOATING-POINT NO/YES
007900* 484/485 DECMIAL NO/YES
008000* 496/497 LARGE INTEGER NO/YES
008100* 500/501 SMALL INTERGER NO/YES
008200********************************************************
008300* NOTE: ALL DATATYPES IN THIS EXAMPLE ARE DEFINED AS NULLABLE
008400********************************************************
008500 01 MODEL-SQLDA.
008600* - EYE CATCHER - MUST ALWAYS SAY 'SQLDA '.
008700 03 MS-SQLAID PIC X(08) VALUE 'SQLDA '.
008800* - SIZE OF SQLDA = 16 + (44 * SQLN VALUE)
008900 03 MS-SQLDABC PIC S9(8) COMP VALUE 500.
009000* - NUMBER OF SQLVAR OCCURENCES
009100* - MUST MATCH VALUE OF MS-SQLD
009200 03 MS-SQLN PIC S9(4) COMP VALUE 11.
009300* - NUMBER OF SQLVAR OCCURENCES ACTUALLY USED
009400* - MUST MATCH VALUE OF MS-SQLN
009500 03 MS-SQLD PIC S9(4) COMP VALUE 11.
009600 03 MS-COL01.
009700* - 1ST COLUMN DATATYPE = FIXED CHAR (LENGTH 1 - 256)
009800 05 MS-COL01-SQLTYPE PIC S9(4) COMP VALUE 453.
009900 05 MS-COL01-SQLLEN PIC S9(4) COMP VALUE 5.
010000* - SQLDATA WILL BE SET TO ADDRESS OF DATA FIELD
010100 05 MS-COL01-SQLDATA PIC S9(8) COMP.
010200* - SQLIND WILL BE SET TO ADDRESS OF A S9(4) COMP FIELD
010300* - WHEN COMP FIELD'S VALUE IS LESS THAN ZERO THEN
010400* - COLUMN IS NULL - ONLY USED WHEN COLUMN IS NULLABLE
010500 05 MS-COL01-SQLIND PIC S9(8) COMP VALUE ZERO.
010600* - SQLNAMEL IS THE LENGTH OF THE COLUMN NAME
010700 05 MS-COL01-SQLNAMEL PIC S9(4) COMP VALUE 10.
010800* - SQLNAME IS ALWAYS 30 IN LENGTH
010900 05 MS-COL01-SQLNAME PIC X(30) VALUE 'FIXED_CHAR'.
011000 03 MS-COL02.
011100* - 2ND COLUMN DATATYPE = DATE (LENGTH ALWAYS 10)
011200 05 MS-COL02-SQLTYPE PIC S9(4) COMP VALUE 385.
011300 05 MS-COL02-SQLLEN PIC S9(4) COMP VALUE 10.
011400 05 MS-COL02-SQLDATA PIC S9(8) COMP.
011500 05 MS-COL02-SQLIND PIC S9(8) COMP VALUE ZERO.
011600 05 MS-COL02-SQLNAMEL PIC S9(4) COMP VALUE 4.
011700 05 MS-COL02-SQLNAME PIC X(30) VALUE 'DATE'.
011800 03 MS-COL03.
011900* - 3RD COLUMN DATATYPE = VARIABLE LENGTH CHAR (1-256)
012000 05 MS-COL03-SQLTYPE PIC S9(4) COMP VALUE 449.
012100 05 MS-COL03-SQLLEN PIC S9(4) COMP VALUE 30.
012200 05 MS-COL03-SQLDATA PIC S9(8) COMP.
012300 05 MS-COL03-SQLIND PIC S9(8) COMP VALUE ZERO.
012400 05 MS-COL03-SQLNAMEL PIC S9(4) COMP VALUE 7.
012500 05 MS-COL03-SQLNAME PIC X(30) VALUE 'VARCHAR'.
012600 03 MS-COL04.
012700* - 4TH COL - DATATYPE = SMALL INTEGER (LENGTH ALWAYS 2)
012800* - CORRESPONDING PIC S9(4) COMP - UP TO 5 DIGITS.
012900 05 MS-COL04-SQLTYPE PIC S9(4) COMP VALUE 501.
013000 05 MS-COL04-SQLLEN PIC S9(4) COMP VALUE 2.
013100 05 MS-COL04-SQLDATA PIC S9(8) COMP.
013200 05 MS-COL04-SQLIND PIC S9(8) COMP VALUE ZERO.
013300 05 MS-COL04-SQLNAMEL PIC S9(4) COMP VALUE 9.
013400 05 MS-COL04-SQLNAME PIC X(30) VALUE 'SMALL_INT'.
013500 03 MS-COL05.
013600* - 5TH COL - DATATYPE = PACKED DECIMAL
013700 05 MS-COL05-SQLTYPE PIC S9(4) COMP VALUE 485.
013800*******- NOTE: FOR PACKED DECIMAL DATATYPES ONLY!!!!!
013900* - LENGTH IS DECIMAL TRANSLATION OF HEX "PPSS"
014000* - WHERE "PP" = NUMBER OF TOTAL DIGITS
014100* - AND "SS" = NUMBER OF DIGITS TO RIGHT OF DECIMAL
014200* - S9(3)V99 COMP-3 WOULD BE X'0502' OR IN DEC '1282'
014300* - S9(11)V99 COMP-3 WOULD BE X'0D02' OR IN DEC '3330'
014400 05 MS-COL05-SQLLEN PIC S9(4) COMP VALUE 1282.
014500* 05 MS-COL05-SQLLEN-X PIC X(2) VALUE X'0502'.
014600* 05 MS-COL05-SQLLEN REDEFINES MS-COL05-SQLLEN-X
014700* PIC S9(4) COMP.
014800 05 MS-COL05-SQLDATA PIC S9(8) COMP.
014900 05 MS-COL05-SQLIND PIC S9(8) COMP VALUE ZERO.
015000 05 MS-COL05-SQLNAMEL PIC S9(4) COMP VALUE 10.
015100 05 MS-COL05-SQLNAME PIC X(30) VALUE 'PACKED_DEC'.
015200 03 MS-COL06.
015300* - 6TH COL - DATATYPE = TIME (LENGTH ALWAYS 8) 'HH.MM.SS'
015400 05 MS-COL06-SQLTYPE PIC S9(4) COMP VALUE 389.
015500 05 MS-COL06-SQLLEN PIC S9(4) COMP VALUE 8.
015600 05 MS-COL06-SQLDATA PIC S9(8) COMP.
015700 05 MS-COL06-SQLIND PIC S9(8) COMP VALUE ZERO.
015800 05 MS-COL06-SQLNAMEL PIC S9(4) COMP VALUE 4.
015900 05 MS-COL06-SQLNAME PIC X(30) VALUE 'TIME'.
016000 03 MS-COL07.
016100* - 7TH COL - DATATYPE = TIMESTAMP (LENGTH 19 OR 26)
016200* - PIC X(19) VALUE 'YYYY-MM-DD:HH:MM:SS'
016300* - PIC X(26) VALUE 'YYYY-MM-DD:HH:MM:SS:NNNNNN'
016400 05 MS-COL07-SQLTYPE PIC S9(4) COMP VALUE 393.
016500 05 MS-COL07-SQLLEN PIC S9(4) COMP VALUE 26.
016600 05 MS-COL07-SQLDATA PIC S9(8) COMP.
016700 05 MS-COL07-SQLIND PIC S9(8) COMP VALUE ZERO.
016800 05 MS-COL07-SQLNAMEL PIC S9(4) COMP VALUE 9.
016900 05 MS-COL07-SQLNAME PIC X(30) VALUE 'TIMESTAMP'.
017000 03 MS-COL08.
017100* - 8TH COL - DATATYPE = FLOAT (COMP-1 LENGTH ALWAYS 4)
017200* - SINGLE PERCISION FLOAT (COMP-1 LENGTH ALWAYS 4)
017300 05 MS-COL08-SQLTYPE PIC S9(4) COMP VALUE 481.
017400 05 MS-COL08-SQLLEN PIC S9(4) COMP VALUE 4.
017500 05 MS-COL08-SQLDATA PIC S9(8) COMP.
017600 05 MS-COL08-SQLIND PIC S9(8) COMP VALUE ZERO.
017700 05 MS-COL08-SQLNAMEL PIC S9(4) COMP VALUE 10.
017800 05 MS-COL08-SQLNAME PIC X(30) VALUE 'FLOATING_P'.
017900 03 MS-COL09.
018000* - 9TH COL - DATATYPE = FLOAT (COMP-2 LENGTH ALWAYS 8)
018100* - DOUBLE PERCISION FLOAT (COMP-2 LENGTH ALWAYS 8)
018200 05 MS-COL09-SQLTYPE PIC S9(4) COMP VALUE 481.
018300 05 MS-COL09-SQLLEN PIC S9(4) COMP VALUE 8.
018400 05 MS-COL09-SQLDATA PIC S9(8) COMP.
018500 05 MS-COL09-SQLIND PIC S9(8) COMP VALUE ZERO.
018600 05 MS-COL09-SQLNAMEL PIC S9(4) COMP VALUE 10.
018700 05 MS-COL09-SQLNAME PIC X(30) VALUE 'DBL_FLOATP'.
018800 03 MS-COL10.
018900* -10TH COL - DATATYPE = LARGE INTEGER (LENGTH ALWAYS 4)
019000* - CORRESPONDING PIC S9(8) COMP - UP TO 10 DIGITS.
019100 05 MS-COL10-SQLTYPE PIC S9(4) COMP VALUE 497.
019200 05 MS-COL10-SQLLEN PIC S9(4) COMP VALUE 4.
019300 05 MS-COL10-SQLDATA PIC S9(8) COMP.
019400 05 MS-COL10-SQLIND PIC S9(8) COMP VALUE ZERO.
019500 05 MS-COL10-SQLNAMEL PIC S9(4) COMP VALUE 7.
019600 05 MS-COL10-SQLNAME PIC X(30) VALUE 'INTEGER'.
019700 03 MS-COL11.
019800* - 11TH COL DATATYPE = LONG VARIABLE LENGTH CHAR (1-32K)
019900 05 MS-COL11-SQLTYPE PIC S9(4) COMP VALUE 457.
020000 05 MS-COL11-SQLLEN PIC S9(4) COMP VALUE 300.
020100 05 MS-COL11-SQLDATA PIC S9(8) COMP.
020200 05 MS-COL11-SQLIND PIC S9(8) COMP VALUE ZERO.
020300 05 MS-COL11-SQLNAMEL PIC S9(4) COMP VALUE 8.
020400 05 MS-COL11-SQLNAME PIC X(30) VALUE 'LVARCHAR'.
020500
020600 LINKAGE SECTION.
020700**************************************************************
020800* THE LINKAGE SECTION DEFINES MASKS FOR DATA AREAS
020900* THAT ARE EITHER PASSED TO THE PROGRAM IN THE CASE OF THE
021000* COMMAREA OR CREATED BY THE PROGRAM IN THE CASE OF THE SQLDA
021100* AND DATA FIELDS.
021200*
021300* UNLIKE WORKING-STORAGE, STORAGE ASSOCIATED WITHIN THE LINKAGE
021400* SECTION IS AVAILABLE TO OTHER PROGRAMS BY PASSING ADDRESSES
021500* AND USING MASKS.
021600*
021700* IT IS IMPORTANT TO NOTE, THAT EVEN THOUGH THE DEFINES IN
021800* THE LINKAGE SECTION LOOKS EXACTLY LIKE THOSE IN WORKING
021900* STORAGE, NO SPACE IS ASSOCIATED WITH THESE DEFINED IN LINKAGE
022000* UNTIL IT IS "GETMAINED".
022100**************************************************************
022200
022300 01 DFHCOMMAREA.
022400 COPY SPAREAC.
022500
022600 01 BLLCELLS.
022700 02 FILLER PIC S9(8) COMP.
022800** 02 SPA-PTR PIC S9(8) COMP.
022900 02 IND-PTR PIC S9(8) COMP.
023000 02 EMP-PTR PIC S9(8) COMP.
023100 02 SQLDA-PTR PIC S9(8) COMP.
023200******************************************************************
023300* NULL INDICATOR VARIABLES - SET TO -1 IF NULL; 0 IF NOTZERO. *
023400* ONLY REQUIRED FOR COLUMNS DEFINED AS ALLOWING NULLS! *
023500******************************************************************
023600 01 INDICATOR-VARIABLES.
023700 10 FIXED-CHAR-IND PIC S9(4) COMP.
023800 10 DATE-OUT-IND PIC S9(4) COMP.
023900 10 VAR-CHAR-IND PIC S9(4) COMP.
024000 10 SMALL-INT-IND PIC S9(4) COMP.
024100 10 PACKED-DEC-IND PIC S9(4) COMP.
024200 10 TIME-OUT-IND PIC S9(4) COMP.
024300 10 TIMESTAMP-IND PIC S9(4) COMP.
024400 10 FLOAT-SGL-IND PIC S9(4) COMP.
024500 10 FLOAT-DBL-IND PIC S9(4) COMP.
024600 10 LARGE-INT-IND PIC S9(4) COMP.
024700 10 LARGE-VCHAR-IND PIC S9(4) COMP.
024800
024900******************************************************************
025000* DESCRIPTION OF THE EMPLOYEE DATA *
025100******************************************************************
025200* NOTE THAT VARCHAR AND LONG-VARCHAR FIELDS ARE PRECEEDED BY *
025300* A TWO-BYTE COMP LENGTH FIELD. SQLDA KNOWS NOT TO INCLUDE THE *
025400* EXTRA TWO BYTES IN THE LENGTH OF THE DATA. WANT TO SEE YOUR *
025500* REGION COME DOWN? TRY LEAVING THE LENGTH FIELD OUT... *
025600* THE FIRST TWO BYTES OF YOUR DATA WILL BE USED TO CALC THE *
025700* LENGTH OF YOUR DATA AND CICS WILL START TO EAT ITSELF... *
025800******************************************************************
025900 01 EMPLOYEE-DATA.
026000 10 FIXED-CHAR PIC X(05).
026100 10 DATE-OUT PIC X(10).
026200 10 VAR-CHAR.
026300 15 VCHAR-LENGTH PIC S9(4) COMP.
026400 15 VCHAR-DATA PIC X(30).
026500 10 SMALL-INT PIC S9(4) USAGE COMP.
026600 10 PACKED-DEC PIC S999V99 USAGE COMP-3.
026700 10 TIME-OUT PIC X(08).
026800 10 TIMESTAMP PIC X(26).
026900 10 FLOAT-SGL COMP-1.
027000 10 FLOAT-DBL COMP-2.
027100 10 LARGE-INT PIC S9(8) USAGE COMP.
027200 10 LARGE-VAR-CHAR.
027300 15 L-VCHAR-LENGTH PIC S9(4) COMP.
027400 15 L-VCHAR-DATA PIC X(300).
027500
027600******************************************************************
027700* DESCRIPTION OF THE SQLDA MASK *
027800******************************************************************
027900 01 SQLDA.
028000 03 SQLDAID PIC X(8).
028100 03 SQLDABC PIC S9(8) COMP.
028200 03 SQLN PIC S9(4) COMP.
028300 03 SQLD PIC S9(4) COMP.
028400 03 SQLVARN OCCURS 11.
028500 05 SQLTYPE PIC S9(4) COMP.
028600 05 SQLLEN PIC S9(4) COMP.
028700 05 SQLDATA PIC S9(8) COMP.
028800 05 SQLIND PIC S9(8) COMP.
028900 05 SQLNAMEL PIC S9(4) COMP.
029000 05 SQLNAME PIC X(30).
029100
029200*-------------------------------------------------------*
029300 PROCEDURE DIVISION.
029400*-------------------------------------------------------*
029500 EXEC CICS HANDLE CONDITION
029600 INVREQ(9999-RETURN-TO-CALLER)
029700 END-EXEC.
029800
029900 0000-MAIN-PROCESSING.
030000
030100 SERVICE RELOAD BLLCELLS.
030200
030300 PERFORM 1000-INITIALIZATION THRU 1000-EXIT.
030400
030500 PERFORM 5000-PROCESS-DATA THRU 5000-EXIT.
030600
030700 PERFORM 9000-WRAP-UP THRU 9000-EXIT.
030800
030900 EXEC CICS
031000 RETURN
031100 END-EXEC.
031200
031300 GOBACK.
031400
031500*-------------------------------------------------------*
031600 1000-INITIALIZATION.
031700*-------------------------------------------------------*
031800
031900 PERFORM 1100-TEST-SQLDA THRU 1100-EXIT.
032000
032100 PERFORM 1200-GET-STORAGE THRU 1200-EXIT.
032200
032300 PERFORM 1300-SET-ADDRESSES THRU 1300-EXIT.
032400
032500 PERFORM 1400-OPEN-OUTPUT-PIPE THRU 1400-EXIT.
032600
032700 1000-EXIT.
032800 EXIT.
032900
033000*-------------------------------------------------------*
033100 1100-TEST-SQLDA.
033200*-------------------------------------------------------*
033300
033400******************************************************
033500* CALCULATE THE CORRECT SQLDA SIZE INTO "SQLDA-SIZE"
033600
033700 MULTIPLY MS-SQLN BY 44 GIVING SQLDA-SIZE.
033800 ADD +16 TO SQLDA-SIZE.
033900 MOVE SQLDA-SIZE TO MS-SQLDABC.
034000
034100
034200******************************************************
034300* CHECK TO MAKE SURE THE CALCULATED SIZE EQUALS ACTUAL SIZE
034400* IF IT DOESN'T THEN AN SQLDA FIELD IS MISSING OR ONE
034500* OF THE SQLDA FIELDS HAS THE WRONG PICTURE SIZE.
034600
034700* IF (LENGTH OF MODEL-SQLDA) NOT EQUAL SQLDA-SIZE
034800* MOVE 'SQLDA/SQLN SIZE IN ERROR' TO ERROR2-TEXT2
034900* PERFORM 9810-ERROR-MSG THRU 9810-EXIT
035000* GO TO 9999-RETURN-TO-CALLER.
035100
035200 1100-EXIT.
035300 EXIT.
035400
035500*-------------------------------------------------------*
035600 1200-GET-STORAGE.
035700*-------------------------------------------------------*
035800
035900******************************************************
036000* ALLOCATE A BLOCK OF STORAGE TO BE USED FOR THE SQLDA
036100* SET POINTER VARIABLE TO ADDRESS OF ALLOCATED STORAGE
036200* USE FLENGTH TO ALLOCATE STORAGE ABOVE THE 16M LINE
036300 EXEC CICS GETMAIN
036400 SET (SQLDA-PTR)
036500 LENGTH (500)
036600 END-EXEC.
036700
036800******************************************************
036900* ASSOCIATE THE LINKAGE SQLDA MASK TO THE ALLOCATED STORAGE
037000* BY SETTING THE MASK ADDRESS TO THE ADDRESS OF THE STORAGE
037100* SET ADDRESS OF SQLDA TO SQLDA-POINTER.
037200 SERVICE RELOAD SQLDA.
037300
037400******************************************************
037500* ALLOCATE A BLOCK OF STORAGE TO BE USED FOR THE DATA
037600* SET POINTER VARIABLE TO ADDRESS OF ALLOCATED STORAGE
037700 EXEC CICS GETMAIN
037800 SET(EMP-PTR)
037900 LENGTH(400)
038000 END-EXEC.
038100* SET ADDRESS OF EMPLOYEE-DATA TO EMPLOYEE-DATA-POINTER.
038200 SERVICE RELOAD EMPLOYEE-DATA.
038300
038400
038500******************************************************
038600* ALLOCATE A BLOCK OF STORAGE TO BE USED FOR NULL INDICATORS
038700* ONLY REQUIRED FOR COLUMNS DEFINED AS ALLOWING NULLS
038800* SET POINTER VARIABLE TO ADDRESS OF ALLOCATED STORAGE
038900 EXEC CICS GETMAIN
039000 SET(IND-PTR)
039100 FLENGTH(200)
039200 END-EXEC.
039300* SET ADDRESS OF INDICATOR-VARIABLES TO INDICATOR-VAR-POINTER.
039400 SERVICE RELOAD INDICATOR-VARIABLES.
039500
039600 1200-EXIT.
039700 EXIT.
039800
039900*-------------------------------------------------------*
040000 1300-SET-ADDRESSES.
040100*-------------------------------------------------------*
040200
040300
040400*********************************************************
040500* SET THE POINTER VARIABLES IN THE LINKAGE SECTION SQLDA TO
040600* THE ADDRESSES OF THE DATA LOCATIONS ALSO IN THE LINKAGE
040700* SECTION IE: THE DATA FIELDS IN EMPLOYEE-DATA
040800*
040900* THESE ADDRESSES MUST BE ADDRESSES ASSOCIATED WITH VARIABLES
041000* DEFINED IN THE LINKAGE SECTION BECAUSE THE CALLED MDI
041100* PROGRAM MUST BE ABLE TO ACCESS THIS STORAGE.
041200*********************************************************
041300 MOVE MODEL-SQLDA TO SQLDA.
041400
041500 MOVE EMP-PTR TO SQLDATA(1).
041600* SET SQLDATA(2) TO ADDRESS OF DATE-OUT.
041700 COMPUTE SQLDATA(2) = EMP-PTR + 5.
041800* SET SQLDATA(3) TO ADDRESS OF VAR-CHAR.
041900 COMPUTE SQLDATA(3) = EMP-PTR + 17.
042000* SET SQLDATA(4) TO ADDRESS OF SMALL-INT.
042100 COMPUTE SQLDATA(4) = EMP-PTR + 47.
042200* SET SQLDATA(5) TO ADDRESS OF PACKED-DEC.
042300 COMPUTE SQLDATA(5) = EMP-PTR + 49.
042400* SET SQLDATA(6) TO ADDRESS OF TIME-OUT.
042500 COMPUTE SQLDATA(6) = EMP-PTR + 52.
042600* SET SQLDATA(7) TO ADDRESS OF TIMESTAMP.
042700 COMPUTE SQLDATA(7) = EMP-PTR + 60.
042800* SET SQLDATA(8) TO ADDRESS OF FLOAT-SGL.
042900 COMPUTE SQLDATA(8) = EMP-PTR + 86.
043000* SET SQLDATA(9) TO ADDRESS OF FLOAT-DBL.
043100 COMPUTE SQLDATA(9) = EMP-PTR + 94.
043200* SET SQLDATA(10) TO ADDRESS OF LARGE-INT.
043300 COMPUTE SQLDATA(10) = EMP-PTR + 110.
043400* SET SQLDATA(11) TO ADDRESS OF LARGE-VAR-CHAR.
043500 COMPUTE SQLDATA(11) = EMP-PTR + 116.
043600
043700****************************************************
043800* SET SQLIND TO ADDRESS OF NULL INDICATOR FIELDS
043900* FOR ANY COLUMN DEFINED AS NULLABLE
044000
044100* SET SQLIND(1) TO ADDRESS OF FIXED-CHAR-IND.
044200 MOVE IND-PTR TO SQLIND(1).
044300* SET SQLIND(2) TO ADDRESS OF DATE-OUT-IND.
044400 COMPUTE SQLIND(2) = IND-PTR + 2.
044500* SET SQLIND(3) TO ADDRESS OF VAR-CHAR-IND.
044600 COMPUTE SQLIND(3) = IND-PTR + 4.
044700* SET SQLIND(4) TO ADDRESS OF SMALL-INT-IND.
044800 COMPUTE SQLIND(4) = IND-PTR + 6.
044900* SET SQLIND(5) TO ADDRESS OF PACKED-DEC-IND.
045000 COMPUTE SQLIND(5) = IND-PTR + 8.
045100* SET SQLIND(6) TO ADDRESS OF TIME-OUT-IND.
045200 COMPUTE SQLIND(6) = IND-PTR + 10.
045300* SET SQLIND(7) TO ADDRESS OF TIMESTAMP-IND.
045400 COMPUTE SQLIND(7) = IND-PTR + 12.
045500* SET SQLIND(8) TO ADDRESS OF FLOAT-SGL-IND.
045600 COMPUTE SQLIND(8) = IND-PTR + 14.
045700* SET SQLIND(9) TO ADDRESS OF FLOAT-DBL-IND.
045800 COMPUTE SQLIND(9) = IND-PTR + 16.
045900* SET SQLIND(10) TO ADDRESS OF LARGE-INT-IND.
046000 COMPUTE SQLIND(10) = IND-PTR + 18.
046100* SET SQLIND(11) TO ADDRESS OF LARGE-VCHAR-IND.
046200 COMPUTE SQLIND(11) = IND-PTR + 20.
046300
046400 1300-EXIT.
046500 EXIT.
046600
046700*-------------------------------------------------------*
046800 1400-OPEN-OUTPUT-PIPE.
046900*-------------------------------------------------------*
047000
047100****************************************************
047200* AFTER A SUCCESSFUL OPENPIPE: HEADER, TABLE, AND
047300* COLUMN IXF RECORDS ARE GENERATED AND SENT TO APPC.
047400
047500 MOVE 'OUTPUT' TO SPMODE.
047600 MOVE 'DB2' TO SPFORMAT.
047700* SET SPSQLDA TO ADDRESS OF SQLDA.
047800 MOVE SQLDA-PTR TO SPSQLDA.
047900
049200 CALL 'OPENPIPE' USING SPAREA.
049300
049400 IF SPRC IS NOT EQUAL TO '000'
049500 MOVE WS-OPENPIPE TO ERROR1-CALL
049600 PERFORM 9800-PIPE-ERROR-MSG THRU 9800-EXIT
049700 GO TO 9999-RETURN-TO-CALLER.
049800
049900 1400-EXIT.
050000 EXIT.
050100
050200*-------------------------------------------------------*
050300 5000-PROCESS-DATA.
050400*-------------------------------------------------------*
050500
050600 PERFORM 5300-LOAD-A-ROW THRU 5300-EXIT.
050700
050800 PERFORM 5500-SEND-A-ROW THRU 5500-EXIT.
050900
051000 PERFORM 5400-LOAD-A-NULL-ROW THRU 5400-EXIT.
051100
051200 PERFORM 5500-SEND-A-ROW THRU 5500-EXIT.
051300
051400 5000-EXIT.
051500 EXIT.
051600
051700*-------------------------------------------------------*
051800 5300-LOAD-A-ROW.
051900*-------------------------------------------------------*
052000 MOVE '00100' TO FIXED-CHAR.
052100 MOVE '1993-09-16' TO DATE-OUT.
052200 MOVE 30 TO VCHAR-LENGTH.
052300 MOVE 'A ROSE BY ANY OTHER..' TO VCHAR-DATA.
052400 MOVE 123 TO SMALL-INT.
052500 MOVE 123.45 TO PACKED-DEC.
052600 MOVE '11.35.25' TO TIME-OUT.
052700 MOVE '1993-10-31:10:34:24' TO TIMESTAMP.
052800 MOVE 1.00345 TO FLOAT-SGL.
052900 MOVE 0.0023544 TO FLOAT-DBL.
053000 MOVE 1234567 TO LARGE-INT.
053100 MOVE 300 TO L-VCHAR-LENGTH.
053200 MOVE WS-LONG-VARCHAR-TEXT TO L-VCHAR-DATA.
053300
053400***************************************************
053500* MOVE ZERO TO NULL INDICATOR FIELDS TO INDICATE NOT NULL
053600
053700 MOVE 0 TO FIXED-CHAR-IND.
053800 MOVE 0 TO DATE-OUT-IND.
053900 MOVE 0 TO VAR-CHAR-IND.
054000 MOVE 0 TO SMALL-INT-IND.
054100 MOVE 0 TO PACKED-DEC-IND.
054200 MOVE 0 TO TIME-OUT-IND.
054300 MOVE 0 TO TIMESTAMP-IND.
054400 MOVE 0 TO FLOAT-SGL-IND.
054500 MOVE 0 TO FLOAT-DBL-IND.
054600 MOVE 0 TO LARGE-INT-IND.
054700 MOVE 0 TO LARGE-VCHAR-IND.
054800
054900 5300-EXIT.
055000 EXIT.
055100
055200
055300*-------------------------------------------------------*
055400 5400-LOAD-A-NULL-ROW.
055500*-------------------------------------------------------*
055600
055700***************************************************
055800* MOVE -1 TO NULL INDICATOR FIELDS TO INDICATE NULL
055900* LEFTOVER DATA IN DATA FIELDS WILL BE IGNORED
056000
056100 MOVE -1 TO FIXED-CHAR-IND.
056200 MOVE -1 TO DATE-OUT-IND.
056300 MOVE -1 TO VAR-CHAR-IND.
056400 MOVE -1 TO SMALL-INT-IND.
056500 MOVE -1 TO PACKED-DEC-IND.
056600 MOVE -1 TO TIME-OUT-IND.
056700 MOVE -1 TO TIMESTAMP-IND.
056800 MOVE -1 TO FLOAT-SGL-IND.
056900 MOVE -1 TO FLOAT-DBL-IND.
057000 MOVE -1 TO LARGE-INT-IND.
057100 MOVE -1 TO LARGE-VCHAR-IND.
057200
057300 5400-EXIT.
057400 EXIT.
057500
057600
057700*-------------------------------------------------------*
057800 5500-SEND-A-ROW.
057900*-------------------------------------------------------*
058000
058100*********************************************************
058200* EACH PUTPIPE GENERATES ONE IXF DATA RECORD/ROW
058300
058400 CALL 'PUTPIPE' USING SPAREA.
058500
058600 IF SPRC IS NOT EQUAL TO '000'
058700 MOVE WS-PUTPIPE TO ERROR1-CALL
058800 PERFORM 9800-PIPE-ERROR-MSG THRU 9800-EXIT
058900 GO TO 9999-RETURN-TO-CALLER.
059000
059100 5500-EXIT.
059200 EXIT.
059300
059400
059500*-------------------------------------------------------*
059600 9000-WRAP-UP.
059700*-------------------------------------------------------*
059800
059900 PERFORM 9200-CLOSE-PIPE THRU 9200-EXIT.
060000
060100 PERFORM 9900-ALL-DONE THRU 9900-EXIT.
060200
060300 9000-EXIT.
060400 EXIT.
060500
060600
060700*-------------------------------------------------------*
060800 9200-CLOSE-PIPE.
060900*-------------------------------------------------------*
061000
061100 CALL 'CLOSPIPE' USING SPAREA.
061200
061300 IF SPRC IS NOT EQUAL TO '000'
061400 MOVE WS-CLOSPIPE TO ERROR1-CALL
061500 PERFORM 9800-PIPE-ERROR-MSG THRU 9800-EXIT
061600 GO TO 9999-RETURN-TO-CALLER.
061700
061800 9200-EXIT.
061900 EXIT.
062000
062100
062200*-------------------------------------------------------*
062300 9800-PIPE-ERROR-MSG.
062400*-------------------------------------------------------*
062500
062600********************************************************
062700* IF NO ERRORS, MOVE 'OK' TO SPSTATUS BEFORE CALLING MESSAGE
062800* IF ERRORS, MOVE 'E' TO SPSTATUS (SPCODE IN IGNORED)
062900* EITHER WAY MOVE UP TO A 100 CHAR MESSAGE INTO SPMSG
063000
063100 MOVE SPRC TO ERROR1-SPRC.
063200 MOVE ERROR1-MSG TO SPMSG.
063300 MOVE 'E' TO SPSTATUS.
063400
063500 CALL 'MESSAGE' USING SPAREA.
063600
063700 9800-EXIT.
063800 EXIT.
063900
064000
064100*-------------------------------------------------------*
064200 9810-ERROR-MSG.
064300*-------------------------------------------------------*
064400
064500 MOVE ERROR2-MSG TO SPMSG.
064600 MOVE 'E' TO SPSTATUS.
064700 CALL 'MESSAGE' USING SPAREA.
064800
064900 9810-EXIT.
065000 EXIT.
065100
065200
065300*-------------------------------------------------------*
065400 9900-ALL-DONE.
065500*-------------------------------------------------------*
065600
065700********************************************************
065800* IF NO ERRORS, MOVE 'OK' TO SPSTATUS BEFORE CALLING STATUS
065900* IF ERRORS, MOVE 'E' TO SPSTATUS BEFORE CALLING STATUS
066000* CAN MOVE UP TO 8 CHARS INTO SPCODE (SPMSG IS IGNORED)
066100* BUT EITHER WAY ALWAYS CALL STATUS AFTER CLOSPIPE
066200
066300 MOVE 'OK' TO SPSTATUS.
066400 CALL 'STATUS' USING SPAREA.
066500
066600 9900-EXIT.
066700 EXIT.
066800
066900
067000*-------------------------------------------------------*
067100 9999-RETURN-TO-CALLER.
067200*-------------------------------------------------------*
067300
067400********************************************************
067500* FOR EMERGENCY BAIL-OUT
067600
067700 EXEC CICS
067800 RETURN
067900 END-EXEC.
068000
068100 9999-EXIT.
068200 EXIT.