*RETRIEVAL
*NO-ACTIVITY-LOG
*DMLIST
IDENTIFICATION DIVISION.
PROGRAM-ID. CTICOBL.
ENVIRONMENT DIVISION.
IDMS-CONTROL SECTION.
PROTOCOL. MODE IS BATCH DEBUG
IDMS-RECORDS WITHIN WORKING-STORAGE.
DATA DIVISION.
SCHEMA SECTION.
************************************************************'
*EMPSS01 = OLD-SSC
*EMPSCHM = OLD-SCHEMA
************************************************************'
DB EMPSS01 WITHIN EMPSCHM VERSION 100.
WORKING-STORAGE SECTION.
01 MISC-WORK-FIELDS.
02 WS-END-OF-MEM1-SW PIC X(01) VALUE 'N'.
88 END-OF-MEM1 VALUE 'Y'.
02 WS-END-OF-OWN1-SW PIC X(01) VALUE 'N'.
88 END-OF-OWN1 VALUE 'Y'.
02 WS-END-OF-MEM2-SW PIC X(01) VALUE 'N'.
88 END-OF-MEM2 VALUE 'Y'.
02 WS-END-OF-OWN2-SW PIC X(01) VALUE 'N'.
88 END-OF-OWN2 VALUE 'Y'.
********************************************
* EMPSS02 -> NEW-SSC
* EMPDEMO -> DBNAME
* R180DMCL -> DMCL
********************************************
01 SUBSCHEMA-TYPE.
02 FILLER PIC S9(8) COMP VALUE +1.
02 FILLER PIC X(8) VALUE IS 'EMPSS02 '.
02 FILLER PIC X(8) VALUE IS 'EMPDEMO '.
02 FILLER PIC X(8) VALUE IS 'R180DMCL'.
01 OWNER-TYPE.
02 FILLER PIC S9(8) COMP VALUE +2.
02 OWNER-FUNCTION PIC X(8).
02 OWNER-SET PIC X(16).
02 OWNER-DBKEY PIC S9(8) COMP.
01 MEMBER-TYPE.
02 FILLER PIC S9(8) COMP VALUE +3.
02 MEMBER-REC PIC X(16).
02 MEMBER-DBKEY PIC S9(8) COMP.
02 MEMBER-NUM-SETS PIC S9(8) COMP VALUE IS +1.
02 MEMBER-SET PIC X(16).
02 MEMBER-OWN-DBK PIC S9(8) COMP.
01 EOF-TYPE.
02 FILLER PIC S9(8) COMP VALUE IS -1.
*
PROCEDURE DIVISION.
*
0010-INITIALIZATION SECTION.
*
MOVE 'CTICOBL ' TO PROGRAM-NAME.
BIND RUN-UNIT.
PERFORM IDMS-STATUS.
BIND EMPLOYEE.
PERFORM IDMS-STATUS.
BIND COVERAGE.
PERFORM IDMS-STATUS.
READY USAGE-MODE IS RETRIEVAL.
PERFORM IDMS-STATUS.
CALL 'IDMSTBLU' USING SUBSCHEMA-TYPE.
***************************************************************
* MAIN PROCESSING LOOP
*EMPLOYEE -> OWNER RECORD
*EMP-DEMO-REGION -> OWNER AREA
***************************************************************
OBTAIN FIRST EMPLOYEE WITHIN EMP-DEMO-REGION.
IF DB-STATUS-OK
PERFORM 2200-REPORT-OWNER THRU 2299-EXIT
UNTIL END-OF-OWN2
ELSE
DISPLAY 'NO EMPLOYEES IN DB '
'(ERROR STATUS: ' ERROR-STATUS ')'.
CALL 'IDMSTBLU' USING EOF-TYPE.
FINISH.
PERFORM IDMS-STATUS.
GOBACK.
***************************************************************
2200-REPORT-OWNER.
MOVE 'N' TO WS-END-OF-MEM2-SW.
***************************************************************
*EMP-COVERAGE -> SET NAME
***************************************************************
MOVE 'BUILD ' TO OWNER-FUNCTION.
MOVE 'EMP-COVERAGE ' TO OWNER-SET.
MOVE DBKEY TO OWNER-DBKEY.
CALL 'IDMSTBLU' USING OWNER-TYPE.
***************************************************************
*COVERAGE -> MEMBER RECORD
*EMP-COVERAGE -> SET NAME
***************************************************************
OBTAIN FIRST COVERAGE WITHIN EMP-COVERAGE.
IF DB-STATUS-OK
PERFORM 2300-REPORT-MEM THRU 2399-EXIT
UNTIL END-OF-MEM2
ELSE
DISPLAY ' NO COVERAGES FOR THIS EMPLOYEE '
'(ERROR STATUS: ' ERROR-STATUS ')'.
2280-GET-NEXT-OWN.
***************************************************************
*EMPLOYEE -> OWNER RECORD
*EMP-DEMO-REGION -> OWNER AREA
***************************************************************
OBTAIN NEXT EMPLOYEE WITHIN EMP-DEMO-REGION.
IF ERROR-STATUS = '0307'
MOVE 'Y' TO WS-END-OF-OWN2-SW.
2299-EXIT.
EXIT.
***************************************************************
*COVERAGE -> MEMBER RECORD
*EMP-COVERAGE -> SET NAME
***************************************************************
2300-REPORT-MEM.
MOVE 'COVERAGE ' TO MEMBER-REC.
MOVE 'EMP-COVERAGE ' TO MEMBER-SET.
MOVE OWNER-DBKEY TO MEMBER-OWN-DBK.
MOVE DBKEY TO MEMBER-DBKEY.
CALL 'IDMSTBLU' USING MEMBER-TYPE.
***************************************************************
*COVERAGE -> MEMBER RECORD
*EMP-COVERAGE -> SET NAME
***************************************************************
2380-GET-NEXT-COVERAGE.
OBTAIN NEXT COVERAGE WITHIN EMP-COVERAGE.
IF ERROR-STATUS = '0307'
MOVE 'Y' TO WS-END-OF-MEM2-SW.
2399-EXIT.
EXIT.
*
*
COPY IDMS IDMS-STATUS
IDMS-ABORT SECTION.
IDMS-ABORT-EXIT.
EXIT.
This Documentation, which includes embedded help systems and electronically distributed materials, (hereinafter referred to as the “Documentation”) is for your informational purposes only and is subject to change or withdrawal by CA at any time. This Documentation is proprietary information of CA and may not be copied, transferred, reproduced, disclosed, modified or duplicated, in whole or in part, without the prior written consent of CA.
If you are a licensed user of the software product(s) addressed in the Documentation, you may print or otherwise make available a reasonable number of copies of the Documentation for internal use by you and your employees in connection with that software, provided that all CA copyright notices and legends are affixed to each reproduced copy.
The right to print or otherwise make available copies of the Documentation is limited to the period during which the applicable license for such software remains in full force and effect. Should the license terminate for any reason, it is your responsibility to certify in writing to CA that all copies and partial copies of the Documentation have been returned to CA or destroyed.
TO THE EXTENT PERMITTED BY APPLICABLE LAW, CA PROVIDES THIS DOCUMENTATION “AS IS” WITHOUT WARRANTY OF ANY KIND, INCLUDING WITHOUT LIMITATION, ANY IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NONINFRINGEMENT. IN NO EVENT WILL CA BE LIABLE TO YOU OR ANY THIRD PARTY FOR ANY LOSS OR DAMAGE, DIRECT OR INDIRECT, FROM THE USE OF THIS DOCUMENTATION, INCLUDING WITHOUT LIMITATION, LOST PROFITS, LOST INVESTMENT, BUSINESS INTERRUPTION, GOODWILL, OR LOST DATA, EVEN IF CA IS EXPRESSLY ADVISED IN ADVANCE OF THE POSSIBILITY OF SUCH LOSS OR DAMAGE.
The use of any software product referenced in the Documentation is governed by the applicable license agreement and such license agreement is not modified in any way by the terms of this notice.
The manufacturer of this Documentation is CA.
Provided with “Restricted Rights.” Use, duplication or disclosure by the United States Government is subject to the restrictions set forth in FAR Sections 12.212, 52.227-14, and 52.227-19(c)(1) - (2) and DFARS Section 252.227-7014(b)(3), as applicable, or their successors.
Copyright © 2013 CA. All rights reserved. All trademarks, trade names, service marks, and logos referenced herein belong to their respective companies.
|
Copyright © 2013 CA.
All rights reserved.
|
|