The following sample program is included on the CA IDMS installation media. This program requires the employee demo database.
*RETRIEVAL
*NO-ACTIVITY-LOG
*DMLIST
IDENTIFICATION DIVISION.
PROGRAM-ID. PROCORGU.
ENVIRONMENT DIVISION.
IDMS-CONTROL SECTION.
PROTOCOL. MODE IS BATCH DEBUG
IDMS-RECORDS MANUAL.
DATA DIVISION.
SCHEMA SECTION.
DB EMPSS01 WITHIN EMPSCHM VERSION 100.
WORKING-STORAGE SECTION.
01 WORK-FIELDS.
02 IN01-RPB PIC X(36).
02 IN01-REQUEST.
03 IN01-REQUEST-CODE PIC S9(8) COMP SYNC.
03 IN01-RETURN PIC S9(8) COMP SYNC.
02 IN01-DATE-FORMAT PIC S9(8) COMP SYNC.
02 I PIC S9(4) COMP SYNC.
02 ROW-FOUND-FLAG PIC X.
88 ROW-FOUND VALUE '1'.
01 COPY IDMS SUBSCHEMA-NAMES.
01 WK-DBKEYS.
02 WK-NEW-MGR-DBKEY PIC S9(8) COMP SYNC.
02 WK-NEW-EMP-DBKEY PIC S9(8) COMP SYNC.
02 WK-MGR-DBKEY PIC S9(8) COMP SYNC.
02 WK-EMP-DBKEY PIC S9(8) COMP SYNC.
02 WK-PRIOR-DBKEY PIC S9(8) COMP SYNC.
02 WK-STRUCT-DBKEY PIC S9(8) COMP SYNC.
01 WK-DATE-TIME.
02 WK-DATE.
03 FILLER PIC 99 VALUE 19.
03 WK-YY PIC 99.
03 FILLER PIC X VALUE '-'.
03 WK-MM PIC 99.
03 FILLER PIC X VALUE '-'.
03 WK-DD PIC 99.
02 WK-TIME PIC X(16) VALUE '-00.00.00.000000'.
01 WK-NEW-DATE.
02 WK-NEW-YY PIC 99.
02 WK-NEW-MM PIC 99.
02 WK-NEW-DD PIC 99.
01 DB-MSG.
02 FILLER PIC X(22) VALUE
'Database error status '.
02 DB-STAT PIC X(4).
02 FILLER PIC X(16) VALUE ', during: '.
02 DB-VERB PIC X(12).
01 INVDELSEQ-MSG.
02 FILLER PIC X(43) VALUE
'Internal sequence error during delete for: '.
02 DEL-PROC PIC X(18).
01 INVUPDSEQ-MSG.
02 FILLER PIC X(43) VALUE
'Internal sequence error during update for: '.
02 UPD-PROC PIC X(18).
01 EMPID-MSG.
02 FILLER PIC X(28) VALUE
'EMP_ID is missing or invalid'.
01 MGRID-MSG.
02 FILLER PIC X(28) VALUE
'MGR_ID is missing or invalid'.
01 STRUCTCD-MSG.
02 FILLER PIC X(36) VALUE
'STRUCTURE_CODE is missing or invalid'.
LINKAGE SECTION.
* PROCEDURE PARAMETERS
77 TOP-KEY PIC 9(4).
77 LEVEL-NO PIC S9(4) COMP SYNC.
77 MGR-ID PIC 9(4).
77 MGR-LNAME PIC X(25).
77 EMP-ID PIC 9(4).
77 EMP-LNAME PIC X(25).
77 START-DATE PIC X(10).
77 STRUCTURE-CODE PIC XX.
* PROCEDURE PARAMETER INDICATORS
77 TOP-KEY-I PIC S9(4) COMP SYNC.
77 LEVEL-NO-I PIC S9(4) COMP SYNC.
77 MGR-ID-I PIC S9(4) COMP SYNC.
77 MGR-LNAME-I PIC S9(4) COMP SYNC.
77 EMP-ID-I PIC S9(4) COMP SYNC.
77 EMP-LNAME-I PIC S9(4) COMP SYNC.
77 START-DATE-I PIC S9(4) COMP SYNC.
77 STRUCTURE-CODE-I PIC S9(4) COMP SYNC.
* CONTROL PARAMETERS
77 RESULT-IND PIC S9(4) USAGE COMP SYNC.
01 SQLSTATE.
02 SQLSTATE-CLASS PIC XX.
02 SQLSTATE-SUBCLASS PIC XXX.
77 PROCEDURE-NAME PIC X(18).
77 SPECIFIC-NAME PIC X(8).
77 MESSAGE-TEXT PIC X(80).
01 SQL-COMMAND-CODE PIC S9(8) USAGE COMP SYNC.
01 SQL-OP-CODE PIC S9(8) USAGE COMP SYNC.
88 SQL-OPEN-SCAN VALUE +12.
88 SQL-NEXT-ROW VALUE +16.
88 SQL-CLOSE-SCAN VALUE +20.
88 SQL-SUSPEND-SCAN VALUE +24.
88 SQL-RESUME-SCAN VALUE +28.
88 SQL-INSERT-ROW VALUE +32.
88 SQL-DELETE-ROW VALUE +36.
88 SQL-UPDATE-ROW VALUE +40.
01 INSTANCE-ID PIC S9(8) USAGE COMP SYNC.
01 LOCAL-WORK-AREA.
02 SCAN-INFO.
03 SCAN-MGR-DBKEY PIC S9(8) USAGE COMP SYNC.
03 SCAN-TOP-DBKEY PIC S9(8) USAGE COMP SYNC.
03 SCAN-STACK-STRDBKEY OCCURS 50 TIMES
PIC S9(8) USAGE COMP SYNC.
03 SCAN-STACK-EMPDBKEY OCCURS 50 TIMES
PIC S9(8) USAGE COMP SYNC.
03 SCAN-TYPE PIC S9(4) USAGE COMP SYNC.
03 SCAN-LEVEL PIC S9(4) USAGE COMP SYNC.
03 SCAN-MAX-LEVEL PIC S9(4) USAGE COMP SYNC.
03 SCAN-TOP-KEY PIC 9(4).
03 SCAN-MGR-KEY PIC 9(4).
03 SCAN-MGR-NAME PIC X(25).
01 GLOBAL-WORK-AREA.
02 COPY IDMS SUBSCHEMA-CTRL.
02 COPY IDMS RECORD EMPLOYEE.
02 COPY IDMS RECORD STRUCTURE.
02 RUN-UNIT-FLAG PIC X.
88 RUN-UNIT-BOUND VALUE '1'.
*********************************************************
PROCEDURE DIVISION USING
TOP-KEY
LEVEL-NO
MGR-ID
MGR-LNAME
EMP-ID
EMP-LNAME
START-DATE
STRUCTURE-CODE
TOP-KEY-I
LEVEL-NO-I
MGR-ID-I
MGR-LNAME-I
EMP-ID-I
EMP-LNAME-I
START-DATE-I
STRUCTURE-CODE-I
RESULT-IND
SQLSTATE
PROCEDURE-NAME
SPECIFIC-NAME
MESSAGE-TEXT
SQL-COMMAND-CODE
SQL-OP-CODE
INSTANCE-ID
LOCAL-WORK-AREA
GLOBAL-WORK-AREA.
MAINLINE SECTION.
*
* PROCESS DML-ONLY OPERATIONS
*
IF SQL-NEXT-ROW
PERFORM NEXT-ROW
ELSE IF SQL-OPEN-SCAN
PERFORM OPEN-SCAN
ELSE IF SQL-INSERT-ROW
PERFORM INSERT-ROW
ELSE IF SQL-UPDATE-ROW
PERFORM UPDATE-ROW
ELSE IF SQL-DELETE-ROW
PERFORM DELETE-ROW.
GOBACK.
*************************************************************
**** FUNCTION MAINLINE ROUTINES ****
*************************************************************
DELETE-ROW SECTION.
*
* DELETE MUST HAVE BEEN PRECEDED BY A "NEXT ROW"
* CALL RETRIEVING THE ROW TO BE DELETED
* DELETE "CURRENT" ROW AND
* RESET CURRENCY TO ITS PRIOR IN SET
*
MOVE SCAN-LEVEL TO I.
FIND STRUCTURE DB-KEY SCAN-STACK-STRDBKEY (I)
IF ERROR-STATUS NOT = '0000'
PERFORM INVDELSEQ-ERROR
GO TO DELETE-ROW-X
MOVE 'ACCEPT PRIO' TO DB-VERB.
IF SCAN-TYPE = 3
ACCEPT SCAN-STACK-STRDBKEY (I) FROM
REPORTS-TO PRIOR CURRENCY
ELSE
ACCEPT SCAN-STACK-STRDBKEY (I) FROM
MANAGES PRIOR CURRENCY.
IF ERROR-STATUS = '0000'
MOVE 'ERASE' TO DB-VERB
ERASE STRUCTURE.
IF ERROR-STATUS NOT = '0000'
PERFORM DB-ERROR.
DELETE-ROW-X.
EXIT.
INSERT-ROW SECTION.
*
* MAKE SURE RUNUNIT IS BOUND BEFORE STORING ROW
*
PERFORM RU-BIND.
IF SQLSTATE NOT = '00000'
GO TO INSERT-ROW-X.
PERFORM VALIDATE-INPUT.
IF SQLSTATE NOT = '00000'
GO TO INSERT-ROW-X.
MOVE 'FIND DBKEY' TO DB-VERB.
FIND DB-KEY WK-NEW-MGR-DBKEY.
IF ERROR-STATUS = '0000'
MOVE WK-NEW-DATE TO STRUCTURE-DATE-0460
MOVE STRUCTURE-CODE TO STRUCTURE-CODE-0460
MOVE 'STORE' TO DB-VERB
STORE STRUCTURE.
IF ERROR-STATUS = '0000'
MOVE 'FIND DBKEY' TO DB-VERB
FIND DB-KEY WK-NEW-EMP-DBKEY
IF ERROR-STATUS = '0000'
MOVE 'CONNECT' TO DB-VERB
CONNECT STRUCTURE TO REPORTS-TO.
IF ERROR-STATUS NOT = '0000'
PERFORM DB-ERROR.
INSERT-ROW-X.
EXIT.
OPEN-SCAN SECTION.
*
* DETERMINE TYPE OF SCAN TO DO. CHOICES:
* 1) BOM EXPLOSION BASED ON TOP KEY
* 2) DIRECT EMPLOYEES OF A GIVEN MANAGER
* 3) DIRECT MANAGERS OF A GIVEN EMPLOYEE
* 4) AREA SWEEP OF ALL MANAGERS
*
MOVE 1 TO SCAN-MAX-LEVEL.
IF MGR-ID-I = 0
MOVE MGR-ID TO SCAN-TOP-KEY
MOVE 2 TO SCAN-TYPE
ELSE IF EMP-ID-I = 0
MOVE EMP-ID TO SCAN-TOP-KEY
MOVE 3 TO SCAN-TYPE
ELSE IF TOP-KEY-I = 0
MOVE TOP-KEY TO SCAN-TOP-KEY
MOVE 1 TO SCAN-TYPE
MOVE 50 TO SCAN-MAX-LEVEL
ELSE
MOVE 4 TO SCAN-TYPE.
MOVE -1 TO SCAN-LEVEL.
PERFORM RU-BIND.
OPEN-SCAN-X.
EXIT.
NEXT-ROW SECTION.
*
* THE FIRST TIME THRU, SCAN-LEVEL = -1
* WE MUST POSITION OURSELVES ON THE APPROPRIATE EMPLOYEE
* ON SUBSEQUENT ENTRY, SCAN-LEVEL >= 0
*
MOVE '0' TO ROW-FOUND-FLAG.
IF SCAN-LEVEL = -1
MOVE 0 TO SCAN-LEVEL
PERFORM POSITION-FIRST-TIME.
IF SQLSTATE = '00000'
PERFORM GET-FIRST-WORKER
IF SQLSTATE = '02000'
AND SCAN-TYPE = 4
MOVE '00000' TO SQLSTATE
PERFORM PROCESS-NEXT-MGR UNTIL SQLSTATE NOT = '00000'
OR ROW-FOUND.
* FILL IN OUTPUT VALUES IF SUCCESSFULLY RETRIEVED ROW
*
IF ROW-FOUND
MOVE SCAN-LEVEL TO LEVEL-NO
IF SCAN-TYPE = 3
MOVE SCAN-MGR-KEY TO EMP-ID
MOVE SCAN-MGR-NAME TO EMP-LNAME
MOVE EMP-ID-0415 TO MGR-ID
MOVE EMP-LAST-NAME-0415 TO MGR-LNAME
ELSE
MOVE SCAN-MGR-KEY TO MGR-ID
MOVE SCAN-MGR-NAME TO MGR-LNAME
MOVE EMP-ID-0415 TO EMP-ID
MOVE EMP-LAST-NAME-0415 TO EMP-LNAME
END-IF
MOVE STRUCTURE-YEAR-0460 TO WK-YY
MOVE STRUCTURE-MONTH-0460 TO WK-MM
MOVE STRUCTURE-DAY-0460 TO WK-DD
MOVE 5 TO IN01-REQUEST-CODE
MOVE 2 TO IN01-DATE-FORMAT
CALL 'IDMSIN01' USING IN01-RPB
IN01-REQUEST
IN01-DATE-FORMAT
WK-DATE-TIME
START-DATE
MOVE STRUCTURE-CODE-0460 TO STRUCTURE-CODE
MOVE 0 TO LEVEL-NO-I
MOVE 0 TO MGR-ID-I
MOVE 0 TO MGR-LNAME-I
MOVE 0 TO EMP-ID-I
MOVE 0 TO EMP-LNAME-I
MOVE 0 TO START-DATE-I
MOVE 0 TO STRUCTURE-CODE-I
IF SCAN-TYPE = 1
MOVE 0 TO TOP-KEY-I
MOVE SCAN-TOP-KEY TO TOP-KEY
ELSE
MOVE -1 TO TOP-KEY-I.
NEXT-ROW-X.
EXIT.
UPDATE-ROW SECTION.
*
* UPDATE MUST HAVE BEEN PRECEDED BY A "NEXT ROW"
* CALL RETRIEVING THE ROW TO BE UPDATED
* UPDATE "CURRENT" ROW
* IF CHANGING OWNERS (MANAGER OR EMPLOYEE)
* ADJUST SET CONNECTIONS APPROPRIATELY
*
PERFORM VALIDATE-INPUT.
IF SQLSTATE NOT = '00000'
GO TO UPDATE-ROW-X.
MOVE SCAN-LEVEL TO I.
OBTAIN STRUCTURE DB-KEY SCAN-STACK-STRDBKEY (I)
IF ERROR-STATUS NOT = '0000'
PERFORM INVUPDSEQ-ERROR
GO TO UPDATE-ROW-X.
MOVE 'ACCEPT OWNR' TO DB-VERB.
ACCEPT WK-MGR-DBKEY FROM MANAGES OWNER CURRENCY.
IF ERROR-STATUS = '0000'
ACCEPT WK-EMP-DBKEY FROM REPORTS-TO OWNER CURRENCY.
IF ERROR-STATUS = '0000'
AND WK-MGR-DBKEY NOT = WK-NEW-MGR-DBKEY
PERFORM SWITCH-MANAGERS.
IF ERROR-STATUS = '0000'
AND SQLSTATE = '00000'
AND WK-EMP-DBKEY NOT = WK-NEW-EMP-DBKEY
PERFORM SWITCH-EMPLOYEES.
IF ERROR-STATUS = '0000'
AND SQLSTATE = '00000'
AND (STRUCTURE-CODE NOT = STRUCTURE-CODE-0460
OR WK-NEW-DATE NOT = STRUCTURE-DATE-0460)
MOVE WK-NEW-DATE TO STRUCTURE-DATE-0460
MOVE STRUCTURE-CODE TO STRUCTURE-CODE-0460
MOVE 'MODIFY' TO DB-VERB
MODIFY STRUCTURE.
IF ERROR-STATUS NOT = '0000'
AND SQLSTATE = '00000'
PERFORM DB-ERROR.
UPDATE-ROW-X.
EXIT.
***************************************************************
**** SUBROUTINES ****
***************************************************************
CHECK-CYCLE SECTION.
*
* COMPARE CURRENT EMPLOYEE DBKEY WITH DBKEYS FROM
* ALL PRIOR LEVELS. IF A MATCH IS FOUND, THEN WE
* HAVE A CYCLE.
* ON EXIT I = 0, IF NO CYCLE DETECTED
* I > 0, IF A CYCLE EXISTS
*
IF SCAN-LEVEL > 0
IF DBKEY = SCAN-TOP-DBKEY
MOVE 99 TO I
ELSE
SUBTRACT 1 FROM SCAN-LEVEL GIVING I
IF I > 0
PERFORM DECR-I UNTIL I = 0
OR SCAN-STACK-EMPDBKEY (I) = DBKEY
END-IF
END-IF
ELSE
MOVE 0 TO I.
DECR-I SECTION.
SUBTRACT 1 FROM I.
GET-FIRST-WORKER SECTION.
*
* WE ARE POSITIONED ON A WORKER WHO MAY OR MAY NOT ALSO
* BE A MANAGER. IF THEY ARE A MANAGER, THEN WE MUST
* RETURN THEIR FIRST WORKER AS A ROW AND ALSO PUSH
* THEM ONTO THE STACK. BEFORE PUTTING THEM ON THE
* STACK, WE MUST CHECK FOR A CYCLE. IF ONE EXISTS,
* THEN WE WILL TREAT IT AS IF IT WEREN'T A MANAGER.
*
MOVE 'OBTAIN DBKEY' TO DB-VERB.
OBTAIN EMPLOYEE DB-KEY SCAN-MGR-DBKEY.
IF ERROR-STATUS = '0000'
PERFORM CHECK-CYCLE.
IF ERROR-STATUS = '0000'
AND I = 0
MOVE 'OBTAIN FIRST' TO DB-VERB
IF SCAN-TYPE = 3
OBTAIN FIRST STRUCTURE WITHIN REPORTS-TO
ELSE
OBTAIN FIRST STRUCTURE WITHIN MANAGES.
IF ERROR-STATUS = '0000'
AND SCAN-LEVEL < SCAN-MAX-LEVEL
AND I = 0
PERFORM PUSH-STACK
PERFORM GET-WORKER-INFO
ELSE
IF I = 0
AND ERROR-STATUS NOT = '0307'
AND ERROR-STATUS NOT = '0000'
PERFORM DB-ERROR
ELSE
PERFORM GET-NEXT-ROW UNTIL SQLSTATE NOT = '00000'
OR ROW-FOUND.
GET-NEXT-ROW SECTION.
*
* IF THE STACK IS EMPTY, WE'VE PROCESSED ALL THE ROWS
* OTHERWISE REPOSITION ON THE RECORD WHOSE DBKEY IS AT THE
* TOP OF THE STACK AND OBTAIN THE NEXT IN SET.
* IF END-OF-SET IS ENCOUNTERED,
* WE'VE PROCESSED ALL THE WORKERS AT THIS
* LEVEL AND WE MUST MOVE UP A LEVEL TO CONTINUE
*
IF SCAN-LEVEL = 0
MOVE '02000' TO SQLSTATE
ELSE
MOVE 'FIND DBKEY' TO DB-VERB
MOVE SCAN-LEVEL TO I
FIND DB-KEY SCAN-STACK-STRDBKEY (I)
IF ERROR-STATUS = '0000'
MOVE 'OBTAIN NEXT' TO DB-VERB
IF SCAN-TYPE = 3
OBTAIN NEXT STRUCTURE WITHIN REPORTS-TO
ELSE
OBTAIN NEXT STRUCTURE WITHIN MANAGES
END-IF
END-IF
IF ERROR-STATUS = '0000'
PERFORM GET-WORKER-INFO
ELSE IF ERROR-STATUS = '0307'
PERFORM POP-STACK
ELSE
PERFORM DB-ERROR.
GET-WORKER-INFO SECTION.
*
* SAVE THE CURRENT DBKEY ON THE STACK
* RETRIEVE THE NAME OF THE CURRENT WORKER
*
MOVE SCAN-LEVEL TO I.
MOVE DBKEY TO SCAN-STACK-STRDBKEY (I).
MOVE 'OBTAIN OWNER' TO DB-VERB.
IF SCAN-TYPE = 3
OBTAIN OWNER WITHIN MANAGES
ELSE
OBTAIN OWNER WITHIN REPORTS-TO.
IF ERROR-STATUS = '0000'
MOVE DBKEY TO SCAN-MGR-DBKEY
MOVE DBKEY TO SCAN-STACK-EMPDBKEY (I)
MOVE '1' TO ROW-FOUND-FLAG
ELSE
PERFORM DB-ERROR.
POP-STACK SECTION.
*
* WHEN WE POP THE STACK, WE ARE CHANGING MANAGERS ALSO
*
SUBTRACT 1 FROM SCAN-LEVEL.
IF SCAN-LEVEL > 0
MOVE 'OBTAIN DBKEY' TO DB-VERB
MOVE SCAN-LEVEL TO I
FIND DB-KEY SCAN-STACK-STRDBKEY (I)
IF ERROR-STATUS = '0000'
MOVE 'OBTAIN OWNER' TO DB-VERB
IF SCAN-TYPE = 3
OBTAIN OWNER WITHIN REPORTS-TO
ELSE
OBTAIN OWNER WITHIN MANAGES
END-IF
END-IF
IF ERROR-STATUS = '0000'
MOVE EMP-ID-0415 TO SCAN-MGR-KEY
MOVE EMP-LAST-NAME-0415 TO SCAN-MGR-NAME
ELSE
PERFORM DB-ERROR.
POSITION-FIRST-TIME SECTION.
*
* ON FIRST "NEXT-ROW" REQUEST AFTER OPEN, POSITION
* ON FIRST EMPLOYEE FOR SCAN
*
IF SCAN-TYPE = 1
OR SCAN-TYPE = 2
OR SCAN-TYPE = 3
MOVE SCAN-TOP-KEY TO EMP-ID-0415
OBTAIN CALC EMPLOYEE
ELSE
OBTAIN FIRST EMPLOYEE WITHIN EMP-DEMO-REGION
IF ERROR-STATUS = '0000'
MOVE EMP-ID-0415 TO SCAN-TOP-KEY.
IF ERROR-STATUS = '0000'
MOVE DBKEY TO SCAN-MGR-DBKEY
MOVE DBKEY TO SCAN-TOP-DBKEY
ELSE
MOVE '02000' TO SQLSTATE.
PROCESS-NEXT-MGR SECTION.
*
* CONTINUE WITH AREA SWEEP ON MANAGERS...
* FIND NEXT EMPLOYEE IN AREA AND RETURN ALL THEIR
* DIRECT EMPLOYEES.
* ON EXIT, SQLSTATE = '02000' IF LAST EMPLOYEE PROCESSED
* '00000' IF MORE EMPLOYEES TO PROCESS
* '38XXX' IF ERROR
*
FIND EMPLOYEE DB-KEY SCAN-TOP-DBKEY.
IF ERROR-STATUS = '0000'
OBTAIN NEXT EMPLOYEE WITHIN EMP-DEMO-REGION.
IF ERROR-STATUS = '0000'
MOVE EMP-ID-0415 TO SCAN-TOP-KEY
MOVE DBKEY TO SCAN-MGR-DBKEY
MOVE DBKEY TO SCAN-TOP-DBKEY
PERFORM GET-FIRST-WORKER
IF SQLSTATE = '02000'
MOVE '00000' TO SQLSTATE
END-IF
ELSE
MOVE '02000' TO SQLSTATE.
PUSH-STACK SECTION.
*
* WHEN WE PUSH THE STACK, WE ALSO HAVE A NEW MANAGER
*
MOVE EMP-ID-0415 TO SCAN-MGR-KEY
MOVE EMP-LAST-NAME-0415 TO SCAN-MGR-NAME
ADD 1 TO SCAN-LEVEL.
RU-BIND SECTION.
*
* BIND RUNUNIT AND READY AREA...
* IF RUNUNIT ALREADY BOUND, IGNORE. IT JUST MEANS
* ANOTHER SCAN HAD CAUSED IT TO BE BOUND PREVIOUSLY.
*
IF RUN-UNIT-BOUND
GO TO RU-BINDX.
MOVE 'BIND RUNUNIT' TO DB-VERB
BIND RUN-UNIT DBNAME 'EMPDEMO '.
IF ERROR-STATUS = '0000'
MOVE '1' TO RUN-UNIT-FLAG
BIND EMPLOYEE
BIND STRUCTURE
MOVE 'READY AREA' TO DB-VERB
READY EMP-DEMO-REGION USAGE-MODE UPDATE
ELSE
IF ERROR-STATUS = '1477'
OR ERROR-STATUS = '0077'
MOVE '0000' TO ERROR-STATUS.
IF ERROR-STATUS NOT = '0000'
PERFORM DB-ERROR.
RU-BINDX. EXIT.
SWITCH-EMPLOYEES SECTION.
IF SCAN-TYPE = 3
MOVE 'ACCEPT PRIO' TO DB-VERB
ACCEPT SCAN-STACK-STRDBKEY (I) FROM
REPORTS-TO PRIOR CURRENCY.
MOVE DBKEY TO WK-STRUCT-DBKEY.
IF ERROR-STATUS = '0000'
MOVE 'DISCONNECT' TO DB-VERB
DISCONNECT STRUCTURE FROM REPORTS-TO.
IF ERROR-STATUS = '0000'
FIND DB-KEY WK-NEW-EMP-DBKEY
FIND DB-KEY WK-STRUCT-DBKEY
MOVE 'CONNECT' TO DB-VERB
CONNECT STRUCTURE TO REPORTS-TO.
IF ERROR-STATUS NOT = '0000'
PERFORM DB-ERROR.
SWITCH-MANAGERS SECTION.
MOVE 'ACCEPT PRIO' TO DB-VERB
ACCEPT WK-PRIOR-DBKEY FROM
REPORTS-TO PRIOR CURRENCY.
IF SCAN-TYPE NOT = 3
AND ERROR-STATUS = '0000'
ACCEPT SCAN-STACK-STRDBKEY (I) FROM
MANAGES PRIOR CURRENCY.
IF ERROR-STATUS = '0000'
MOVE 'ERASE' TO DB-VERB
ERASE STRUCTURE.
IF ERROR-STATUS = '0000'
FIND DB-KEY WK-NEW-MGR-DBKEY
MOVE 'STORE' TO DB-VERB
STORE STRUCTURE
MOVE DBKEY TO WK-STRUCT-DBKEY.
IF ERROR-STATUS = '0000'
FIND DB-KEY WK-PRIOR-DBKEY
FIND DB-KEY WK-STRUCT-DBKEY
MOVE 'CONNECT' TO DB-VERB
CONNECT STRUCTURE TO REPORTS-TO.
IF ERROR-STATUS NOT = '0000'
PERFORM DB-ERROR.
VALIDATE-INPUT SECTION.
* VALIDATE EMPLOYEE-ID
IF EMP-ID-I = 0
MOVE EMP-ID TO EMP-ID-0415
OBTAIN CALC EMPLOYEE.
IF ERROR-STATUS = '0326'
OR EMP-ID-I NOT = 0
PERFORM EMPID-ERROR
GO TO VALIDATE-X.
IF ERROR-STATUS NOT = '0000'
MOVE 'OBTAIN CALC' TO DB-VERB
PERFORM DB-ERROR
GO TO VALIDATE-X.
MOVE DBKEY TO WK-NEW-EMP-DBKEY.
* VALIDATE MANAGER-ID
IF MGR-ID-I = 0
MOVE MGR-ID TO EMP-ID-0415
OBTAIN CALC EMPLOYEE.
IF ERROR-STATUS = '0326'
OR MGR-ID-I NOT = 0
PERFORM MGRID-ERROR
GO TO VALIDATE-X.
IF ERROR-STATUS NOT = '0000'
MOVE 'OBTAIN CALC' TO DB-VERB
PERFORM DB-ERROR
GO TO VALIDATE-X.
MOVE DBKEY TO WK-NEW-MGR-DBKEY.
* VALIDATE STRUCTURE-CODE & DATE
MOVE STRUCTURE-CODE TO STRUCTURE-CODE-0460.
IF (ADMIN-0460
OR PROJECT-0460)
AND STRUCTURE-CODE-I = 0
NEXT SENTENCE
ELSE
PERFORM STRUCTCD-ERROR.
IF START-DATE-I = 0
MOVE 5 TO IN01-REQUEST-CODE
MOVE 0 TO IN01-DATE-FORMAT
CALL 'IDMSIN01' USING IN01-RPB
IN01-REQUEST
IN01-DATE-FORMAT
START-DATE
WK-DATE-TIME
MOVE WK-YY TO WK-NEW-YY
MOVE WK-DD TO WK-NEW-DD
MOVE WK-MM TO WK-NEW-MM
ELSE
ACCEPT WK-NEW-DATE FROM DATE.
VALIDATE-X.
EXIT.
***************************************************************
**** ERROR ROUTINES ****
***************************************************************
DB-ERROR SECTION.
MOVE '38001' TO SQLSTATE.
MOVE ERROR-STATUS TO DB-STAT.
MOVE DB-MSG TO MESSAGE-TEXT.
INVDELSEQ-ERROR SECTION.
MOVE '38006' TO SQLSTATE.
MOVE PROCEDURE-NAME TO DEL-PROC.
MOVE INVDELSEQ-MSG TO MESSAGE-TEXT.
INVUPDSEQ-ERROR SECTION.
MOVE '38007' TO SQLSTATE.
MOVE PROCEDURE-NAME TO UPD-PROC.
MOVE INVUPDSEQ-MSG TO MESSAGE-TEXT.
EMPID-ERROR SECTION.
MOVE '38008' TO SQLSTATE.
MOVE EMPID-MSG TO MESSAGE-TEXT.
MGRID-ERROR SECTION.
MOVE '38009' TO SQLSTATE.
MOVE MGRID-MSG TO MESSAGE-TEXT.
STRUCTCD-ERROR SECTION.
MOVE '38010' TO SQLSTATE.
MOVE STRUCTCD-MSG TO MESSAGE-TEXT.
|
Copyright © 2014 CA.
All rights reserved.
|
|