<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html
PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html lang="en-us" xml:lang="en-us">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<meta name="security" content="public" />
<meta name="Robots" content="index,follow" />
<meta http-equiv="PICS-Label" content='(PICS-1.1 "http://www.icra.org/ratingsv02.html" l gen true r (cz 1 lz 1 nz 1 oz 1 vz 1) "http://www.rsac.org/ratingsv01.html" l gen true r (n 0 s 0 v 0 l 0) "http://www.classify.org/safesurf/" l gen true r (SS~~000 1))' />
<meta name="DC.Type" content="reference" />
<meta name="DC.Title" content="Example in OPM COBOL: Retrieve exit point and exit program information" />
<meta name="abstract" content="This program retrieves exit point and exit program information. After retrieving the exit point information, the program calls each exit program. The Retrieve Exit Information API returns a continuation handle when it has more information to return than what fits in the receiver variable." />
<meta name="description" content="This program retrieves exit point and exit program information. After retrieving the exit point information, the program calls each exit program. The Retrieve Exit Information API returns a continuation handle when it has more information to return than what fits in the receiver variable." />
<meta name="DC.Relation" scheme="URI" content="ileScenario.htm" />
<meta name="DC.Relation" scheme="URI" content="conContinuation.htm" />
<meta name="copyright" content="(C) Copyright IBM Corporation 1998, 2006" />
<meta name="DC.Rights.Owner" content="(C) Copyright IBM Corporation 1998, 2006" />
<meta name="DC.Format" content="XHTML" />
<meta name="DC.Identifier" content="ileRetrieveCOBOL" />
<meta name="DC.Language" content="en-us" />
<!-- All rights reserved. Licensed Materials Property of IBM -->
<!-- US Government Users Restricted Rights -->
<!-- Use, duplication or disclosure restricted by -->
<!-- GSA ADP Schedule Contract with IBM Corp. -->
<link rel="stylesheet" type="text/css" href="./ibmdita.css" />
<link rel="stylesheet" type="text/css" href="./ic.css" />
<title>Example in OPM COBOL: Retrieve exit point and exit program information</title>
</head>
<body id="ileRetrieveCOBOL"><a name="ileRetrieveCOBOL"><!-- --></a>
<!-- Java sync-link --><script language="Javascript" src="../rzahg/synch.js" type="text/javascript"></script>
<h1 class="topictitle1">Example in OPM COBOL: Retrieve exit point and exit program information</h1>
<div><p>This program retrieves exit point and exit program information.
After retrieving the exit point information, the program calls each exit
program. The Retrieve Exit Information API returns a continuation handle when
it has more information to return than what fits in the receiver variable.</p>
<div class="section"><div class="note"><span class="notetitle">Note:</span> Read the <a href="codedisclaimer.htm">Code license and disclaimer information</a> for important
legal information.</div>
<pre> IDENTIFICATION DIVISION.
***************************************************************
***************************************************************
*
* Program: Retrieve Exit Point and Exit Program Information
*
* Language: OPM COBOL
*
* Description: This program retrieves exit point and exit
* program information. After retrieving the
* exit point information, the program calls each
* exit program.
*
* APIs Used: QUSCRTUS - Create User Space
* QUSPTRUS - Retrieve Pointer to User Space
* QUSRTVEI - Retrieve Exit Information
*
***************************************************************
***************************************************************
*
PROGRAM-ID. REGFAC2.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-AS400.
OBJECT-COMPUTER. IBM-AS400.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT LISTING ASSIGN TO PRINTER-QPRINT
ORGANIZATION IS SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD LISTING RECORD CONTAINS 132 CHARACTERS
LABEL RECORDS ARE STANDARD
DATA RECORD IS LIST-LINE.
01 LIST-LINE PIC X(132).
WORKING-STORAGE SECTION.
*
* Error Code parameter include. As this sample program
* uses COPY to include the error code structure, only the first
* 16 bytes of the error code structure are available. If the
* application program needs to access the variable length
* exception data for the error, the developer should physically
* copy the QSYSINC include and modify the copied include to
* define additional storage for the exception data.
*
COPY QUSEC OF QSYSINC-QLBLSRC.
*
* Error message text
*
01 BAD-EXIT-POINT.
05 TEXT1 PIC X(40)
VALUE "Attempt to retrieve information failed: ".
05 EXCEPTION-ID PIC X(07).
01 BAD-EXIT-PGM.
05 TEXT1 PIC X(42)
VALUE "Attempt to retrieve Exit Programs failed: ".
05 EXCEPTION-ID PIC X(07).
01 BAD-CREATE.
05 TEXT1 PIC X(37)
VALUE "Allocation of RCVVAR storage failed: ".
05 EXCEPTION-ID PIC X(07).
*
* Miscellaneous elements
*
01 MISC.
05 EXIT-POINT-NAME PIC X(20) VALUE "EXAMPLE_EXIT_POINT".
05 EXIT-PGM-NBR PIC S9(09) VALUE -1 BINARY.
05 EXIT-PARAMETERS PIC X(10).
05 FORMAT-NAME PIC X(08) VALUE "EXTI0100".
05 FORMAT-NAME-1 PIC X(08) VALUE "EXTI0200".
05 FORMAT-NAME-2 PIC X(08) VALUE "EXMP0100".
05 NBR-OF-SELECT-CRITERIA PIC S9(09) VALUE 0 BINARY.
05 CONTINUATION-HDL PIC X(16).
05 BASE-POINTER POINTER.
05 INFO-POINTER POINTER.
05 SPACE-NAME PIC X(20) VALUE "RCVVAR QTEMP ".
05 SPACE-ATTR PIC X(10).
05 SPACE-SIZE PIC S9(09) VALUE 3500 BINARY.
05 SPACE-VALUE PIC X(01) VALUE X"00".
05 SPACE-AUTH PIC X(10) VALUE "*USE".
05 SPACE-TEXT PIC X(50).
05 SPACE-REPLACE PIC X(10) VALUE "*NO".
05 SPACE-DOMAIN PIC X(10) VALUE "*USER".
*
LINKAGE SECTION.
*
* Variable to hold results of QUSRTVEI. The storage for this
* variable will be allocated by way of a User Space.
*
01 RCVVAR PIC X(3500).
*
* Registration Facility API include. These includes will be
* mapped over the RCVVAR (User Space) previously defined.
*
COPY QUSREG OF QSYSINC-QLBLSRC.
*
* Beginning of mainline
*
PROCEDURE DIVISION.
MAIN-LINE.
*
* Retrieve the exit point information first. If the current
* number of exit programs is not zero, retrieve the exit
* programs. It is not necessary to call for the exit point
* information to determine if the exit point has any exit
* programs. It is done here for illustrative purposes only.
* You can make one call to the API for the exit program
* information and check the number of exit program entries
* returned field to see if there are any exit programs to call.
*
* Initialize the error code to inform the API that all
* exceptions should be returned through the error code parameter.
*
MOVE 16 TO BYTES-PROVIDED OF QUS-EC.
*
* Create a User Space for RCVVAR.
*
CALL "QUSCRTUS" USING SPACE-NAME, SPACE-ATTR, SPACE-SIZE,
SPACE-VALUE, SPACE-AUTH, SPACE-TEXT,
SPACE-REPLACE, QUS-EC, SPACE-DOMAIN.
*
* If an exception occurs, the API returns the exception in the
* error code parameter. The bytes available field is set to
* zero if no exception occurs and greater than zero if an
* exception does occur.
*
IF BYTES-AVAILABLE OF QUS-EC > 0
IF EXCEPTION-ID OF QUS-EC = "CPF9870"
CONTINUE
ELSE
OPEN OUTPUT LISTING,
MOVE EXCEPTION-ID OF QUS-EC
TO EXCEPTION-ID OF BAD-CREATE,
WRITE LIST-LINE FROM BAD-CREATE,
STOP RUN.
*
* Assign BASE-POINTER to address RCVVAR
*
CALL "QUSPTRUS" USING SPACE-NAME, BASE-POINTER, QUS-EC.
*
* If an exception occurs, the API returns the exception in the
* error code parameter. The bytes available field is set to
* zero if no exception occurs and greater than zero if an
* exception does occur.
*
IF BYTES-AVAILABLE OF QUS-EC > 0
OPEN OUTPUT LISTING,
MOVE EXCEPTION-ID OF QUS-EC
TO EXCEPTION-ID OF BAD-CREATE,
WRITE LIST-LINE FROM BAD-CREATE,
STOP RUN.
*
SET ADDRESS OF RCVVAR TO BASE-POINTER.
*
* Blank out the continuation handle to let the API know that this
* is a first attempt at the retrieve operation.
*
MOVE SPACES TO CONTINUATION-HDL.
*
* Call the API to retrieve the exit programs
*
CALL "QUSRTVEI" USING CONTINUATION-HDL, RCVVAR,
BY CONTENT LENGTH OF RCVVAR,
FORMAT-NAME OF MISC,
EXIT-POINT-NAME OF MISC,
FORMAT-NAME-2, EXIT-PGM-NBR,
NBR-OF-SELECT-CRITERIA, QUS-EC.
*
* If an exception occurs, the API returns the exception in the
* error code parameter. The bytes available field is set to
* zero if no exception occurs and greater than zero if an
* exception does occur.
*
IF BYTES-AVAILABLE OF QUS-EC > 0
OPEN OUTPUT LISTING,
MOVE EXCEPTION-ID OF QUS-EC
TO EXCEPTION-ID OF BAD-EXIT-POINT,
WRITE LIST-LINE FROM BAD-EXIT-POINT,
STOP RUN.
*
* If the call to retrieve exit point information is successful,
* check to see if there are any exit programs to call.
*
SET ADDRESS OF QUS-EXTI0100 TO BASE-POINTER.
SET ADDRESS OF QUS-EXTI0200 TO BASE-POINTER.
*
IF NUMBER-POINTS-RETURNED OF QUS-EXTI0100 > 0
SET ADDRESS OF QUS-EXTI0100-ENTRY TO
ADDRESS OF RCVVAR((OFFSET-EXIT-POINT-ENTRY OF
QUS-EXTI0100 + 1):)
ELSE STOP RUN.
*
IF NUMBER-EXIT-PROGRAMS OF QUS-EXTI0100-ENTRY > 0
*
* There are some exit programs to call. Blank out the continuation
* handle to let the API know that this is a first attempt at the
* retrieve operation.
*
MOVE SPACES TO CONTINUATION-HDL,
*
* Call the exit programs
*
PERFORM CALL-EXIT-PROGRAMS,
*
* If the continuation handle field in the receiver variable is
* not set to blanks, the API has more information to return than
* what could fit in the receiver variable. Call the API for
* more exit programs to call.
*
PERFORM UNTIL CONTINUE-HANDLE OF QUS-EXTI0200 = SPACES
MOVE CONTINUE-HANDLE OF QUS-EXTI0200
TO CONTINUATION-HDL,
PERFORM CALL-EXIT-PROGRAMS,
END-PERFORM.
*
STOP RUN.
*
* End of MAINLINE
*
*
* Process exit programs in receiver variable
*
CALL-EXIT-PROGRAMS.
*
* Call the API to retrieve the exit program information
*
CALL "QUSRTVEI" USING CONTINUATION-HDL, RCVVAR,
BY CONTENT LENGTH OF RCVVAR,
FORMAT-NAME-1,
EXIT-POINT-NAME OF MISC,
FORMAT-NAME-2, EXIT-PGM-NBR,
NBR-OF-SELECT-CRITERIA, QUS-EC.
*
* If an exception occurs, the API returns the exception in the
* error code parameter. The bytes available field is set to
* zero if no exception occurs and greater than zero if an
* exception does occur.
*
IF BYTES-AVAILABLE OF QUS-EC > 0
OPEN OUTPUT LISTING,
MOVE EXCEPTION-ID OF QUS-EC
TO EXCEPTION-ID OF BAD-EXIT-PGM,
WRITE LIST-LINE FROM BAD-EXIT-PGM,
STOP RUN.
*
* If the call to retrieve exit program information is successful,
* check to see if there are any exit programs to call.
*
* The receiver variable offers enough room for a minimum of one
* exit program entry because the receiver variable was declared
* as 3500 bytes. Therefore, this example only checks the
* number of exit programs returned field. If the receiver
* variable were not large enough to hold at least one entry,
* the bytes available field would need to be checked as well as
* the number of exit programs returned field. If the number of
* exit programs returned field is set to zero and the bytes
* available field is greater than the bytes returned field, the
* API had at least one exit program entry to return but was
* unable to because the receiver variable was too small.
*
SET ADDRESS OF QUS-EXTI0200-ENTRY
TO ADDRESS OF RCVVAR(OFFSET-PROGRAM-ENTRY
OF QUS-EXTI0200 + 1:).
PERFORM CALL-PGMS
NUMBER-PROGRAMS-RETURNED OF QUS-EXTI0200 TIMES.
*
CALL-PGMS.
*
* Call the exit program while ignoring failures on the call
*
CALL PROGRAM-NAME OF QUS-EXTI0200-ENTRY USING
EXIT-PARAMETERS
ON EXCEPTION CONTINUE.
*
* Address the next exit program entry
*
SET ADDRESS OF QUS-EXTI0200-ENTRY
TO ADDRESS OF RCVVAR(OFFSET-NEXT-ENTRY
OF QUS-EXTI0200-ENTRY + 1:).</pre>
</div>
</div>
<div>
<div class="familylinks">
<div class="parentlink"><strong>Parent topic:</strong> <a href="ileScenario.htm" title="The example APIs in this section represent two general functions of APIs--change and retrieve.">Scenario: Integrated Language Environment (ILE) APIs</a></div>
</div>
<div class="reltasks"><strong>Related tasks</strong><br />
<div><a href="conContinuation.htm" title="Some APIs that return information offer a continuation handle.">Continuation handle</a></div>
</div>
</div>
</body>
</html>