The following sample COBOL program calls IDD and requests IDD to display an element.
**************************************************************
IDENTIFICATION DIVISION.
**************************************************************
PROGRAM-ID. CALLIDD.
DATE WRITTEN. MONTH DD, YEAR
DATE COMPILED.
**************************************************************
* REMARKS.
**************************************************************
*
* THIS IS A SAMPLE DC COBOL PROGRAM THAT DEMONSTRATES HOW
* AN APPLICATION PROGRAM CAN CALL IDD AS A SUBPROGRAM AND
* PASS TO IDD A REQUEST TO DISPLAY AN ELEMENT. THE OUTPUT
* OF THE REQUEST IS DISPLAYED BY THE COBOL PROGRAM.
*
**************************************************************
ENVIRONMENT DIVISION.
**************************************************************
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-370.
OBJECT-COMPUTER. IBM-370.
IDMS-CONTROL SECTION.
PROTOCOL. MODE IS IDMS-DC DEBUG
IDMS-RECORDS MANUAL.
**************************************************************
DATA DIVISION.
**************************************************************
MAP SECTION.
MAP CDSIMAP1.
EJECT
**************************************************************
WORKING-STORAGE SECTION.
**************************************************************
01 BEGIN-WS.
03 FILLER PIC X(40) VALUE
'***** WORKING STORAGE BEGINS HERE ******'.
**************************************************************
* SWITCHES-AREA - PROGRAM CONTROL SWITCHES *
**************************************************************
01 SWITCHES-AREA.
03 FILLER PIC X(08) VALUE 'SWITCHES'.
03 IDD-EOF-SW PIC 9 VALUE 0.
88 IDD-EOF VALUE 1.
03 FIRST-TIME-SW PIC 9 VALUE 0.
88 FIRST-TIME VALUE 1.
03 ERROR-SW PIC 9 VALUE 0.
88 NO-ERRORS VALUE 0.
**************************************************************
* WORK-FIELDS - PROGRAM WORK FIELDS *
**************************************************************
01 WORK-FIELDS.
03 FILLER PIC X(08) VALUE 'WORKAREA'.
03 SUB PIC 99 VALUE 0.
03 AID-BYTE PIC X.
88 CLEAR-HIT VALUE '_'.
88 PA1-HIT VALUE '%'.
03 TASK-CODE PIC X(8).
03 GOOD-RC PIC S9(8) COMP VALUE +0.
03 Q-EL PIC X(32) VALUE ALL '?'.
**************************************************************
* MESSAGES-AREA - OPERATOR MESSAGES *
**************************************************************
01 MESSAGES-AREA.
03 FILLER PIC X(08) VALUE 'MESSAGES'.
03 OK-MSG PIC X(40) VALUE
'PROCESSING COMPLETE - PROCEED '.
03 NO-ELEMENT-MSG PIC X(40) VALUE
'ELEMENT NAME MISSING, PLEASE FILL IT IN'.
03 CIO-ERROR-MSG.
05 FILLER PIC X(36) VALUE
'CIO PROCESSING ERROR - RETURN CODE ='.
05 CIO-ERROR-CODE PIC X(4) VALUE '0000'.
**************************************************************
* SCR-RCD - SCRATCH RECORD AREA *
**************************************************************
01 SCR-RCD.
03 SCR-DBK PIC S9(8) COMP.
03 SCR-RCDID PIC S9(8) COMP.
03 SCR-STATUS PIC X.
03 SCR-RCD-END PIC X.
EJECT
**************************************************************
* PARAMETER 1 - THE COMPILER INOUT/OUTPUT BLOCK *
**************************************************************
01 CIO-PARM1.
03 CIO-ID PIC X(4) VALUE 'CIO '.
03 CIO-USER PIC S9(8) COMP VALUE +0.
03 CIO-IO-RC PIC S9(8) COMP VALUE +0.
03 CIO-DDDL-RC PIC S9(8) COMP VALUE +0.
03 CIO-RESERVED PIC X(8) VALUE SPACES.
03 CIO-ERROR-FILE PIC X(8) VALUE SPACES.
88 SYSIPT-ERROR VALUE 'SYSIPT'.
88 SYSLST-ERROR VALUE 'SYSLST'.
88 SYSPCH-ERROR VALUE 'SYSPCH'.
03 CIO-NULL PIC X(4) VALUE 'NULL'.
**************************************************************
* PARAMETER 2 - CIOF INPUT BLOCK *
**************************************************************
01 CIO-PARM2.
03 CIOF-I-TYPE PIC X(8) VALUE 'WORKAREA'.
03 CIOF-I-NAME PIC X(16) VALUE SPACES.
03 CIOF-I-F-RC PIC S9(8) COMP VALUE +0.
03 CIOF-I-SIZE-US PIC S9(8) COMP VALUE +0.
03 CIOF-I-SIZE-MAX PIC S9(8) COMP VALUE +5.
**************************************************************
* PARAMETER 3 - INPUT DATA AREA *
**************************************************************
01 CIO-PARM3.
03 FILLER PIC X(80) VALUE
' SIGNON. '.
03 FILLER PIC X(80) VALUE
' DISPLAY ELEMENT NAME IS'.
03 CIO-I-LINE2.
05 FILLER PIC X(8) VALUE SPACES.
05 CIO-I-NAME PIC X(32) VALUE SPACES.
05 FILLER PIC X(40) VALUE SPACES.
03 FILLER PIC X(80) VALUE
' .'.
03 FILLER PIC X(80) VALUE
' SIGNOFF. '.
**************************************************************
* PARAMETER 4 - CIOF OUTPUT BLOCK *
**************************************************************
01 CIO-PARM4.
03 CIOF-O-TYPE PIC X(8) VALUE 'WORKAREA'.
03 CIOF-O-NAME PIC X(16) VALUE SPACES.
03 CIOF-O-F-RC PIC S9(8) COMP VALUE +0.
03 CIOF-O-SIZE-US PIC S9(8) COMP VALUE +0.
03 CIOF-O-SIZE-MAX PIC S9(8) COMP VALUE +100.
**************************************************************
* PARAMETER 5 - OUTPUT DATA AREA *
**************************************************************
01 CIO-PARM5.
03 CIOF-OUTPUT-LINE PIC X(80)
OCCURS 100 TIMES.
EJECT
**************************************************************
* PARAMETER 6 - CIOF PUNCH BLOCK *
**************************************************************
01 CIO-PARM6.
03 CIOF-P-TYPE PIC X(8) VALUE 'WORKAREA'.
03 CIOF-P-NAME PIC X(16) VALUE SPACES.
03 CIOF-P-F-RC PIC S9(8) COMP VALUE +0.
03 CIOF-P-SIZE-US PIC S9(8) COMP VALUE +0.
03 CIOF-P-SIZE-MAX PIC S9(8) COMP VALUE +0.
**************************************************************
* PARAMETER 7 - PUNCH DATA AREA *
**************************************************************
01 CIO-PARM7 PIC X(80) VALUE 'NULL'.
**************************************************************
* IDMS AREA *
**************************************************************
COPY IDMS SUBSCHEMA-CTRL.
COPY IDMS MAP-CONTROLS.
COPY IDMS MAP-RECORDS.
EJECT
PROCEDURE DIVISION.
**************************************************************
* *
* ROUTINE - 0000-MAIN-LINE *
* *
* THIS ROUTINE IS THE MAIN CONTROL OF THE PROGRAM, CALLING *
* THE OTHER ROUTINES TO DO THE ACTUAL WORK. *
* *
**************************************************************
0000-MAIN-LINE.
PERFORM 1000-GET-SCRATCH-REC THRU 1999-EXIT.
IF FIRST-TIME
PERFORM 2000-DISPLAY-MAP THRU 2999-EXIT
GO TO 0800-RETURN-SCREEN.
PERFORM 3000-GET-MAP THRU 3999-EXIT.
IF CLEAR-HIT
GO TO 0900-DC-RETURN.
PERFORM 4000-EDIT-DATA THRU 4999-EXIT.
IF NO-ERRORS
PERFORM 5000-CALL-IDD THRU 5999-EXIT.
MAP OUT USING CDSIMAP1 WAIT IO OUTPUT DATA YES.
**************************************************************
* *
* ROUTINE - 0800-RETURN-SCREEN *
* *
* THIS ROUTINE SETS UP THE RETURN SO THAT THIS TRANSACTION *
* WILL BE THE NEXT TRANSACTION EXECUTED FROM THE TERMINAL. *
* *
**************************************************************
0800-RETURN-SCREEN.
ACCEPT TASK CODE INTO TASK-CODE.
DC RETURN NEXT TASK CODE TASK-CODE.
**************************************************************
* *
* ROUTINE - 0900-DC-RETURN *
* *
* THIS ROUTINE DELETES THE SCRATCH RECORD AND THEN RETURNS *
* CONTROL TO THE DC SYSTEM. *
* *
**************************************************************
0900-DC-RETURN.
DELETE SCRATCH RECORD ID SCR-RCDID.
DC RETURN.
EJECT
**************************************************************
* *
* ROUTINE - 1000-GET-SCRATCH-REC. *
* *
* THIS ROUTINE ATTEMPTS TO GET THE SCRATCH RECORD, WHICH *
* IS USED TO DETERMINE IF THIS IS THE FIRST TIME THE *
* TRANSACTION HAS BEEN EXECUTED. *
* *
**************************************************************
1000-GET-SCRATCH-REC.
MOVE 1 TO SCR-RCDID.
GET SCRATCH RECORD ID SCR-RCDID KEEP
INTO SCR-RCD TO SCR-RCD-END
ON ANY-ERROR-STATUS
IF ERROR-STATUS NOT = '0000'
MOVE 1 TO FIRST-TIME-SW
ELSE
MOVE 0 TO FIRST-TIME-SW.
1999-EXIT.
EXIT.
**************************************************************
* *
* ROUTINE - 2000-DISPLAY-MAP *
* *
* THIS ROUTINE CREATES A SCRATCH RECORD AND DOES THE INITIAL *
* MAP OUT. *
* *
**************************************************************
2000-DISPLAY-MAP.
MOVE 0 TO SCR-DBK.
MOVE '1' TO SCR-STATUS.
PUT SCRATCH FROM SCR-RCD TO SCR-RCD-END
RECORD ID SCR-RCDID.
PERFORM 8000-INITILIZE-MAP THRU 8099-EXIT.
MAP OUT USING CDSIMAP1 OUTPUT NEWPAGE.
2999-EXIT.
EXIT.
**************************************************************
* *
* ROUTINE - 3000-GET-MAP *
* *
* THIS ROUTINE GETS THE MAP. *
* *
**************************************************************
3000-GET-MAP.
PERFORM 8000-INITILIZE-MAP THRU 8099-EXIT.
MAP IN USING CDSIMAP1.
INQUIRE MAP CDSIMAP1 MOVE AID TO AID-BYTE.
3999-EXIT.
EXIT.
EJECT
**************************************************************
* *
* ROUTINE - 4000-EDIT-DATA *
* *
* THIS ROUTINE CHECKS THE ELEMENT NAME TO SEE IF IT HAS BEEN *
* FILLED IN. IF IT IS BLANK OR NULLS, AN ERROR MESSAGE IS *
* DISPLAYED, AND THE MAP IS RETURNED TO THE OPERATOR FOR *
* CORRECTION. *
* *
**************************************************************
4000-EDIT-DATA.
MOVE 0 TO ERROR-SW.
IF (CDSIELNM = SPACES)
OR (CDSIELNM = LOW-VALUES)
MOVE 1 TO ERROR-SW
MOVE NO-ELEMENT-MSG TO CDSIMSG
MOVE Q-EL TO CDSIELNM
MODIFY MAP CDSIMAP1 TEMPORARY
FOR CDSIELNM ATTRIBUTES BRIGHT
GO TO 4999-EXIT.
MOVE CDSIELNM TO CIO-I-NAME.
4999-EXIT.
EXIT.
**************************************************************
* *
* ROUTINE - 5000-CALL-IDD *
* *
* THIS ROUTINE CALLS IDD, PASSING THE SEVEN PARAMETERS THAT *
* ARE REQUIRED. IF THE RETURN CODE FROM IDD IS GOOD (ALL *
* BINARY ZEROS) THE FIRST TEN LINES FROM THE CIOF OUTPUT *
* WORKAREA (THE IDD SYSLST FILE) ARE MOVED TO THE MAP. *
* IF THE RETURN CODE FROM IDD IS BAD (NOT BINARY ZEROS) AN *
* ERROR MESSAGE IS DISPLAYED WITH THE ERROR CODE. *
* *
**************************************************************
5000-CALL-IDD.
TRANSFER CONTROL TO 'IDMSDDDC' RETURN
USING CIO-PARM1
CIO-PARM2
CIO-PARM3
CIO-PARM4
CIO-PARM5
CIO-PARM6
CIO-PARM7.
IF CIO-IO-RC NOT = GOOD-RC
MOVE CIO-IO-RC TO CIO-ERROR-CODE
MOVE CIO-ERROR-MSG TO CDSIMSG
GO TO 5999-EXIT.
PERFORM 5100-MOVE-IDD-OUTPUT THRU 5109-EXIT
VARYING SUB FROM 1 BY 1
UNTIL IDD-EOF.
MOVE OK-MSG TO CDSIMSG.
GO TO 5999-EXIT.
5100-MOVE-IDD-OUTPUT.
MOVE CIOF-OUTPUT-LINE(SUB) TO CDSILINE(SUB).
IF (SUB = 10) OR (SUB = CIOF-O-SIZE-US)
MOVE 1 TO IDD-EOF-SW.
5109-EXIT.
EXIT.
5999-EXIT.
EXIT.
EJECT
**************************************************************
* *
* ROUTINE - 8000-INITILIZE-MAP *
* *
* THIS ROUTINE DOES THE IDMS MAP BINDS. *
* *
**************************************************************
8000-INITILIZE-MAP.
COPY IDMS MAP-BINDS.
8099-EXIT.
EXIT.
EJECT
COPY IDMS IDMS-STATUS.
IDMS-ABORT.
IDMS-ABORT-EXIT.
EXIT.
|
Copyright © 2014 CA.
All rights reserved.
|
|