This appendix contains a sample CA IDMS online application that illustrates the structure of CA IDMS programs that accept data from a terminal operator and retrieve information from the database. The application program highlights the following CA IDMS features:
The application's components, runtime requirements, and DML code are described below.
This section contains the following topics:
Application Runtime Requirements
The application comprises a program, two tasks, a map, and a subschema:
TSK01 causes the program to perform the INITIAL-MAPOUT portion of the program, mapping out the empty screen with an initial input message.
TSK02 causes the program to perform the GET-EMP portion of the program, mapping in the data, checking the AID byte, performing the error checking and database access portion of the program, and mapping out either an error message or employee data.
Eight literal fields including the title *** EMPLOYEE INFORMATION SCREEN ***.
Ten variable data fields, to contain: employee ID, last name, first name, job title, start date, department name, and office address (street, city, state, and zip code). All data is contained in the EMP-JOB-LR logical record.
Automatic editing for the employee ID field specifies that the field is in error if the ID entered by the terminal operator does not comply with the field's external picture (PIC 9(4)).
Messages are output in the $MESSAGE field.
*** EMPLOYEE INFORMATION SCREEN *** EMPLOYEE ID: LAST NAME : FIRST NAME: JOB TITLE: START DATE: DEPARTMENT NAME: OFFICE: : : ENTER AN EMP ID AND PRESS ENTER ** CLEAR TO EXIT
The following requirements must be met to execute the sample online application under CA IDMS:
*NO-ACTIVITY-LOG
*DMLIST
IDENTIFICATION DIVISION.
PROGRAM-ID. EMPDISP.
AUTHOR. COMPUTER ASSOCIATES INTERNATIONAL.
DATE-WRITTEN. APRIL 1995.
REMARKS. THIS PROGRAM DEMONSTRATES
CA IDMS PROGRAMMING USING
THE LOGICAL RECORD FACILITY.
***************************************************************
ENVIRONMENT DIVISION.
***************************************************************
IDMS-CONTROL SECTION.
PROTOCOL. MODE IS IDMS-DC DEBUG
IDMS-RECORDS MANUAL.
SKIP3
DATA DIVISION.
SCHEMA SECTION.
DB EMPSS09 WITHIN EMPSCHM.
MAP SECTION.
MAX FIELD LIST IS 5.
MAP EMPMAPLR VERSION 1 TYPE IS STANDARD.
WORKING-STORAGE SECTION.
01 TASK-CODE PIC X(8).
01 TSK01 PIC X(8) VALUE 'TSK01'.
01 TSK02 PIC X(8) VALUE 'TSK02'.
01 MESSAGES.
05 INITIAL-MESSAGE PIC X(80) VALUE
'ENTER AN EMP ID AND PRESS ENTER ** CLEAR TO EXIT'.
05 EDIT-ERROR-MESSAGE PIC X(80) VALUE
'EMP-ID EITHER NOT ENTERED OR NOT NUMERIC'.
05 EMP-NOT-FOUND-MESSAGE PIC X(80) VALUE
'SPECIFIED EMPLOYEE COULD NOT BE FOUND'.
05 DISPLAY-MESSAGE PIC X(80) VALUE
'CLEAR TO EXIT ** NEW EMP-ID AND ENTER TO CONTINUE'.
01 COPY IDMS DC-AID-CONDITION-NAMES.
01 COPY IDMS EMP-DATE-WORK-REC.
01 COPY IDMS SUBSCHEMA-LR-CONTROL.
01 COPY IDMS SUBSCHEMA-LR-RECORDS.
03 SUBSCHEMA-LR-CTRL-END PIC X.
01 COPY IDMS MAP-CONTROLS.
EJECT
PROCEDURE DIVISION.
* *********************************************************
* * PROCEDURE DIVISION GENERAL STRATEGY: *
* * RETRIEVE INFORMATION FOR A SPECIFIED EMPLOYEE. *
* * DISPLAYED DATA INCLUDES EMPLOYEE, DEPARTMENT, *
* * JOB, AND OFFICE INFORMATION. *
* * ==> THIS PROGRAM USES THE EMP-JOB-LR LOGICAL RECORD<= *
* * PROGRAM STRATEGY: *
* * ** CHECK FOR TASK CODE: TSK01= INITIAL MAPOUT *
* * ANYTHING ELSE = RETRIEVE LR *
* * ** CLEAR TO EXIT APPLICATION *
* * ** ENTER AND NEW EMP-ID TO CONTINUE *
* *********************************************************
MAIN-LINE.
***************************************************************
* THE BIND MAP STATEMENTS ADVISE IDMS-DC OF THE LOCATION OF *
* THE MRB AND THE MAP RECORDS. *
***************************************************************
BIND MAP EMPMAPLR.
BIND MAP EMPMAPLR RECORD EMPLOYEE.
BIND MAP EMPMAPLR RECORD DEPARTMENT.
BIND MAP EMPMAPLR RECORD JOB.
BIND MAP EMPMAPLR RECORD OFFICE.
BIND MAP EMPMAPLR RECORD EMP-DATE-WORK-REC.
* ACCEPT TASK CODE INTO TASK-CODE.
IF TASK-CODE = TSK01
GO TO INITIAL-MAPOUT
ELSE
GO TO GET-EMP.
***************************************************************
***************************************************************
* THE INITIAL-MAPOUT PARAGRAPH IS PERFORMED IF THE CALLING *
* TASK CODE IS TSK01. *
***************************************************************
* THE MODIFY MAP STATEMENT ASSIGNS THE PROTECTED *
* ATTRIBUTE TO ALL MAP FIELDS EXCEPT EMP-ID-0415. *
***************************************************************
* THE MAP OUT STATEMENT TRANSMITS THE EMPMAPLR MAP *
* TO THE TERMINAL. *
***************************************************************
* THE DC RETURN STATEMENT SPECIFIES THAT THE NEXT *
* TASK THAT WILL BE INITIATED ON THE SAME TERMINAL WHEN THE *
* OPERATOR PRESSES A CONTROL KEY WILL BE TSK02. *
***************************************************************
INITIAL-MAPOUT.
MODIFY MAP EMPMAPLR TEMPORARY
FOR ALL EXCEPT EMP-ID-0415
ATTRIBUTES PROTECTED.
*
MOVE ZERO TO EMP-ID-0415.
MAP OUT USING EMPMAPLR
OUTPUT DATA IS YES NEWPAGE
MESSAGE IS INITIAL-MESSAGE LENGTH 80.
DC RETURN
NEXT TASK CODE TSK02.
INITIAL-MAPOUT-EXIT.
EXIT.
***************************************************************
***************************************************************
* THE GET-EMP PARAGRAPH IS PERFORMED IF THE CALLING TASK *
* CODE IS NOT TSK01. *
***************************************************************
* THE MAP IN STATEMENT TRANSMITS DATA FROM THE TERMINAL TO *
* VARIABLE STORAGE DATA FIELDS. *
***************************************************************
* THIS FIRST INQUIRE MAP STATEMENT IS USED TO DETERMINE *
* THE AID KEY PRESSED. *
***************************************************************
* THIS SECOND INQUIRE MAP STATEMENT USES AUTOMATIC EDITING *
* TO DETERMINE IF THE DATA ENTERED IS CONSISTENT WITH *
* THE EXTERNAL PICTURE OF THE NAMED DATA ELEMENT. *
***************************************************************
* THE MAP OUT STATEMENT TRANSMITS DATA FROM THE *
* EMP-JOB-LR LOGICAL RECORD IN VARIABLE STORAGE TO MAP *
* FIELDS. *
***************************************************************
GET-EMP.
MAP IN USING EMPMAPLR.
*
INQUIRE MAP EMPMAPLR
MOVE AID TO DC-AID-IND-V.
IF CLEAR-HIT
DC RETURN.
*
INQUIRE MAP EMPMAPLR
IF DFLD EMP-ID-0415 EDIT IS ERROR
THEN GO TO EDIT-ERROR.
*
COPY IDMS SUBSCHEMA-BINDS.
READY USAGE-MODE IS RETRIEVAL.
***************************************************************
* SINCE THE MAP FIELD IS ASSOCIATED WITH THE EMP-ID-0415 *
* FIELD, THE PROGRAM USES THE "OF LR" RETRIEVAL. NOTE THAT *
* AUTOSTATUS IMPLICITLY CHECKS FOR THE LR-ERROR PATH STATUS. *
***************************************************************
OBTAIN EMP-JOB-LR
WHERE EMP-ID-0415 = EMP-ID-0415 OF LR
ON LR-NOT-FOUND
GO TO NOT-FOUND.
FINISH.
***************************************************************
* REFORMAT DATE TO MMDDYY; OUTPUT AS MM/DD/YY USING THE OLM *
* EXTERNAL PICTURE SPECIFICATION (XX/XX/XX). *
***************************************************************
MOVE START-YEAR-0415 TO WORK-YY.
MOVE START-MONTH-0415 TO WORK-MM.
MOVE START-DAY-0415 TO WORK-DD.
MAP OUT USING EMPMAPLR
OUTPUT DATA IS YES
MESSAGE IS DISPLAY-MESSAGE LENGTH 80.
*
DC RETURN NEXT TASK CODE TSK02.
GET-EMP-EXIT.
EXIT.
***************************************************************
***************************************************************
* THE MODIFY MAP STATEMENT SPECIFIES THAT ALL MAP *
* FIELDS EXCEPT THE INCORRECT EMP-ID-0415 FIELD WILL BE *
* ERASED ON THE NEXT MAP OUT. *
***************************************************************
EDIT-ERROR.
MODIFY MAP EMPMAPLR TEMPORARY
FOR ALL EXCEPT DFLD EMP-ID-0415
OUTPUT DATA IS ERASE.
*
MAP OUT USING EMPMAPLR
MESSAGE IS EDIT-ERROR-MESSAGE LENGTH 80.
*
DC RETURN
NEXT TASK CODE TSK02.
EDIT-ERROR-EXIT.
EXIT.
***************************************************************
***************************************************************
* THE FOLLOWING MODIFY MAP STATEMENT SPECIFIES THAT ALL *
* MAP FIELDS EXCEPT THE EMP-ID-0415 FIELD WILL BE ERASED *
* ON THE NEXT MAP OUT. *
***************************************************************
NOT-FOUND.
MODIFY MAP EMPMAPLR TEMPORARY
FOR ALL EXCEPT DFLD EMP-ID-0415
OUTPUT DATA IS ERASE.
*
MAP OUT USING EMPMAPLR
MESSAGE IS EMP-NOT-FOUND-MESSAGE LENGTH 80.
*
DC RETURN
NEXT TASK CODE TSK02.
NOT-FOUND-EXIT.
EXIT.
***************************************************************
IDMS-ABORT.
MOVE ERROR-STATUS TO SSC-ERRSTAT-SAVE.
MOVE DML-SEQUENCE TO SSC-DMLSEQ-SAVE.
SNAP FROM SUBSCHEMA-LR-CTRL TO SUBSCHEMA-LR-CTRL-END
ON ANY-STATUS NEXT SENTENCE.
MOVE SSC-ERRSTAT-SAVE TO ERROR-STATUS.
MOVE SSC-DMLSEQ-SAVE TO DML-SEQUENCE.
IDMS-ABORT-EXIT.
EXIT.
COPY IDMS IDMS-STATUS.
00002 *DMLIST
00003
00004 IDENTIFICATION DIVISION.
00005
00006 PROGRAM-ID. EMPDISP.
00007
00008 AUTHOR. COMPUTER ASSOCIATES INTERNATIONAL.
00009
00010 DATE-WRITTEN. APRIL 1995.
00011
00012 REMARKS. THIS PROGRAM DEMONSTRATES
00013 CA IDMS PROGRAMMING USING
00014 THE LOGICAL RECORD FACILITY.
00015
00016 ***************************************************************
00017 ENVIRONMENT DIVISION.
00018 ***************************************************************
DMLC 00019 IDMS-CONTROL SECTION.
00020
DMLC 00021 PROTOCOL. MODE IS IDMS-DC DEBUG
DMLC 00022 IDMS-RECORDS MANUAL.
00023 SKIP3
00024 DATA DIVISION.
00025
DMLC 00026 SCHEMA SECTION.
00027
DMLC 00028 DB EMPSS09 WITHIN EMPSCHM.
00029
DMLC 00030 MAP SECTION.
DMLC 00031 MAX FIELD LIST IS 5.
DMLC 00032 MAP EMPMAPLR VERSION 1 TYPE IS STANDARD.
00033
00034
00035
00036 WORKING-STORAGE SECTION.
00037 01 TASK-CODE PIC X(8).
00038 01 TSK01 PIC X(8) VALUE 'TSK01'.
00039 01 TSK02 PIC X(8) VALUE 'TSK02'.
00040
00041 01 MESSAGES.
00042 05 INITIAL-MESSAGE PIC X(80) VALUE
00043 'ENTER AN EMP ID AND PRESS ENTER ** CLEAR TO EXIT'.
00044 05 EDIT-ERROR-MESSAGE PIC X(80) VALUE
00045 'EMP-ID EITHER NOT ENTERED OR NOT NUMERIC'.
00046 05 EMP-NOT-FOUND-MESSAGE PIC X(80) VALUE
00047 'SPECIFIED EMPLOYEE COULD NOT BE FOUND'.
00048 05 DISPLAY-MESSAGE PIC X(80) VALUE
00049 'CLEAR TO EXIT ** NEW EMP-ID AND ENTER TO CONTINUE'.
00050
DMLC 00051 01 COPY IDMS DC-AID-CONDITION-NAMES.
00052 01 DC-AID-CONDITION-NAMES.
00053 03 DC-AID-IND-V PIC X.
00054 88 ENTER-HIT VALUE QUOTE.
00055 88 CLEAR-HIT VALUE '_'.
00056 88 PF01-HIT VALUE '1'.
00057 88 PF02-HIT VALUE '2'.
00058 88 PF03-HIT VALUE '3'.
00059 88 PF04-HIT VALUE '4'.
00060 88 PF05-HIT VALUE '5'.
00061 88 PF06-HIT VALUE '6'.
00062 88 PF07-HIT VALUE '7'.
00063 88 PF08-HIT VALUE '8'.
00064 88 PF09-HIT VALUE '9'.
00065 88 PF10-HIT VALUE ':'.
00066 88 PF11-HIT VALUE '#'.
00067 88 PF12-HIT VALUE '@'.
00068 88 PF13-HIT VALUE 'A'.
00069 88 PF14-HIT VALUE 'B'.
00070 88 PF15-HIT VALUE 'C'.
00071 88 PF16-HIT VALUE 'D'.
00072 88 PF17-HIT VALUE 'E'.
00073 88 PF18-HIT VALUE 'F'.
00074 88 PF19-HIT VALUE 'G'.
00075 88 PF20-HIT VALUE 'H'.
00076 88 PF21-HIT VALUE 'I'.
00077 88 PF22-HIT VALUE '_'.
00078 88 PF23-HIT VALUE '.'.
00079 88 PF24-HIT VALUE '<'.
00080 88 PA01-HIT VALUE '%'.
00081 88 PA02-HIT VALUE '>'.
00082 88 PA03-HIT VALUE ','.
00083 88 PEN-ATTN-SPACE-NULL VALUE '='.
00084 88 PEN-ATTN VALUE QUOTE.
00085
DMLC 00086 01 COPY IDMS EMP-DATE-WORK-REC.
00087 01 EMP-DATE-WORK-REC.
00088 02 WORK-DATE.
00089 03 WORK-MM PIC 9(2).
00090 03 WORK-DD PIC 9(2).
00091 03 WORK-YY PIC 9(2).
00092
DMLC 00093 01 COPY IDMS SUBSCHEMA-LR-CONTROL.
00094 01 SUBSCHEMA-CTRL.
00095 03 PROGRAM-NAME PIC X(8) VALUE SPACES.
00096 03 ERROR-STATUS PIC X(4) VALUE '1400'.
00097 88 DB-STATUS-OK VALUE '0000'.
00098 88 ANY-STATUS
00099 VALUE '0000' THRU '9999'.
00100 88 ANY-ERROR-STATUS
00101 VALUE '0001' THRU '9999'.
00102 88 DB-END-OF-SET VALUE '0307'.
00103 88 DB-REC-NOT-FOUND VALUE '0326'.
00104 88 DC-DEADLOCK VALUE '3101'
00105 '3201' '3401' '3901'.
00106 88 DC-NO-STORAGE VALUE '3202'
00107 '3402'.
00108 88 DC-AREA-ID-UNK VALUE '4303'.
00109 88 DC-QUEUE-ID-UNK VALUE '4404'.
00110 88 DC-REC-NOT-FOUND VALUE '4305'
00111 '4405'.
00112 88 DC-RESOURCE-NOT-AVAIL
00113 VALUE '3908'.
00114 88 DC-RESOURCE-AVAIL
00115 VALUE '3909'.
00116 88 DC-NEW-STORAGE VALUE '3210'.
00117 88 DC-MAX-TASKS VALUE '3711'.
00118 88 DC-REC-REPLACED VALUE '4317'.
00119 88 DC-TRUNCATED-DATA
00120 VALUE '4319' '4419'
00121 '4519' '4719'.
00122 88 DC-ATTN-INT VALUE '4525'
00123 '4625'.
00124 88 DC-OPER-CANCEL VALUE '4743'.
00125 88 DC-FIRST-PAGE-SENT
00126 VALUE '4676'.
00127 88 DC-SECOND-STARTPAGE
00128 VALUE '4604'.
00129 88 DC-DETAIL-NOT-FOUND
00130 VALUE '4664'.
00131 03 DBKEY PIC S9(8)
00132 USAGE COMP.
00133 03 RECORD-NAME PIC X(16) VALUE SPACES.
00134 03 RRECORD-NAME REDEFINES RECORD-NAME.
00135 05 SSC-NODN PIC X(8).
00136 05 SSC-DBN PIC X(8).
00137 03 AREA-NAME PIC X(16) VALUE SPACES.
00138 03 ERROR-SET PIC X(16) VALUE SPACES.
00139 03 ERROR-RECORD PIC X(16) VALUE SPACES.
00140 03 ERROR-AREA PIC X(16) VALUE SPACES.
00141 03 IDBMSCOM-AREA PIC X(100) VALUE LOW-VALUE.
00142 03 IDBMSCOM REDEFINES IDBMSCOM-AREA
00143 PIC X
00144 OCCURS 100.
00145 03 RIDBMSCOM REDEFINES IDBMSCOM-AREA.
00146 05 DB-SUB-ADDR PIC X(4).
00147 05 FILLER PIC X(0096).
00148 03 DIRECT-DBKEY PIC S9(8)
00149 USAGE COMP.
00150 03 DIRECT-DBK REDEFINES DIRECT-DBKEY
00151 PIC S9(8)
00152 USAGE COMP.
00153 03 DCBMSCOM-AREA PIC X(100) VALUE LOW-VALUE.
00154 03 DCBMSCOM REDEFINES DCBMSCOM-AREA
00155 PIC X
00156 OCCURS 100.
00157 03 R1DCBMSCOM REDEFINES DCBMSCOM-AREA.
00158 05 R2DCBMSCOM PIC S9(8)
00159 OCCURS 11
00160 USAGE COMP.
00161 05 DCSTR1 PIC X(16).
00162 05 R3DCBMSCOM REDEFINES DCSTR1.
00163 07 DCSTR2 PIC X(8).
00164 07 R4DCBMSCOM REDEFINES DCSTR2.
00165 09 DCSTR4 PIC X(4).
00166 09 DCSTR5 PIC X(4).
00167 07 DCSTR3 PIC X(8).
00168 05 R5DCBMSCOM REDEFINES DCSTR1.
00169 07 DCPNUM1 PIC S9(15)
00170 USAGE COMP-3.
00171 05 DCNUM1 PIC S9(8)
00172 USAGE COMP.
00173 05 R6DCBMSCOM REDEFINES DCNUM1.
00174 07 DCPNUM2 PIC S9(7)
00175 USAGE COMP-3.
00176 05 DCNUM2 PIC S9(8)
00177 USAGE COMP.
00178 05 DCNUM3 PIC S9(8)
00179 USAGE COMP.
00180 05 DCFLG1 PIC S9(4)
00181 USAGE COMP.
00182 05 DCFLG2 PIC S9(4)
00183 USAGE COMP.
00184 05 DCFLG3 PIC S9(4)
00185 USAGE COMP.
00186 05 DCFLG4 PIC S9(4)
00187 USAGE COMP.
00188 03 SSC-ERRSTAT-SAVE PIC X(4) VALUE SPACES.
00189 03 SSC-DMLSEQ-SAVE PIC S9(8)
00190 USAGE COMP.
00191 03 DML-SEQUENCE PIC S9(8)
00192 USAGE COMP.
00193 03 RECORD-OCCUR PIC S9(8)
00194 USAGE COMP.
00195 03 SUBSCHEMA-CTRL-END PIC X(4) VALUE SPACES.
00196 01 SUBSCHEMA-LR-CTRL.
00197 03 LRC-LRPXELNG PIC S9(4)
00198 USAGE COMP.
00199 03 LRC-MAXVXP PIC S9(4)
00200 USAGE COMP.
00201 03 LRIDENT PIC X(4) VALUE 'LRC '.
00202 03 LRVERB PIC X(8).
00203 03 LRNAME PIC X(16).
00204 03 LR-STATUS PIC X(16).
00205 03 FILLER PIC X(16).
00206 03 LRPXE PIC X
00207 OCCURS 0 TO 512
00208 DEPENDING ON LRC-LRPXELNG.
00209 03 PXE.
00210 05 PXENEXT PIC S9(8)
00211 USAGE COMP.
00212 05 PXETABO PIC S9(4)
00213 USAGE COMP.
00214 05 PXEDSPL PIC S9(4)
00215 USAGE COMP.
00216 05 PXEDYN PIC S9(4)
00217 USAGE COMP.
00218 05 PXEDLEN PIC S9(4)
00219 USAGE COMP.
00220 05 PXENDEC PIC X.
00221 05 PXEDTYP PIC X.
00222 05 PXEOTYP PIC X.
00223 05 PXEFLAG PIC X.
00224 05 FILLER PIC X(240).
00225 03 PXEDSP256 REDEFINES PXE
00226 PIC X(256).
00227 03 PXEDSP248 REDEFINES PXE
00228 PIC X(248).
00229 03 PXEDSP240 REDEFINES PXE
00230 PIC X(240).
00231 03 PXEDSP232 REDEFINES PXE
00232 PIC X(232).
00233 03 PXEDSP224 REDEFINES PXE
00234 PIC X(224).
00235 03 PXEDSP216 REDEFINES PXE
00236 PIC X(216).
00237 03 PXEDSP208 REDEFINES PXE
00238 PIC X(208).
00239 03 PXEDSP200 REDEFINES PXE
00240 PIC X(200).
00241 03 PXEDSP192 REDEFINES PXE
00242 PIC X(192).
00243 03 PXEDSP184 REDEFINES PXE
00244 PIC X(184).
00245 03 PXEDSP176 REDEFINES PXE
00246 PIC X(176).
00247 03 PXEDSP168 REDEFINES PXE
00248 PIC X(168).
00249 03 PXEDSP160 REDEFINES PXE
00250 PIC X(160).
00251 03 PXEDSP152 REDEFINES PXE
00252 PIC X(152).
00253 03 PXEDSP144 REDEFINES PXE
00254 PIC X(144).
00255 03 PXEDSP136 REDEFINES PXE
00256 PIC X(136).
00257 03 PXEDSP128 REDEFINES PXE
00258 PIC X(128).
00259 03 PXEDSP120 REDEFINES PXE
00260 PIC X(120).
00261 03 PXEDSP112 REDEFINES PXE
00262 PIC X(112).
00263 03 PXEDSP104 REDEFINES PXE
00264 PIC X(104).
00265 03 PXEDSP96 REDEFINES PXE
00266 PIC X(96).
00267 03 PXEDSP88 REDEFINES PXE
00268 PIC X(88).
00269 03 PXEDSP80 REDEFINES PXE
00270 PIC X(80).
00271 03 PXEDSP72 REDEFINES PXE
00272 PIC X(72).
00273 03 PXEDSP64 REDEFINES PXE
00274 PIC X(64).
00275 03 PXEDSP56 REDEFINES PXE
00276 PIC X(56).
00277 03 PXEDSP48 REDEFINES PXE
00278 PIC X(48).
00279 03 PXEDSP40 REDEFINES PXE
00280 PIC X(40).
00281 03 PXEDSP32 REDEFINES PXE
00282 PIC X(32).
00283 03 PXEDSP24 REDEFINES PXE
00284 PIC X(24).
00285 03 PXEDSP16 REDEFINES PXE
00286 PIC X(16).
00287 03 PXEDSP8 REDEFINES PXE
00288 PIC X(8).
00289 03 PXECOMP-1 REDEFINES PXE
00290 USAGE COMP-1.
00291 03 PXECOMP-2 REDEFINES PXE
00292 USAGE COMP-2.
00293 03 PXECOMP-30 REDEFINES PXE
00294 PIC S9(18)
00295 USAGE COMP-3.
00296 03 PXECOMP-31 REDEFINES PXE
00297 PIC S9(17)V9(1)
00298 USAGE COMP-3.
00299 03 PXECOMP-32 REDEFINES PXE
00300 PIC S9(16)V9(2)
00301 USAGE COMP-3.
00302 03 PXECOMP-33 REDEFINES PXE
00303 PIC S9(15)V9(3)
00304 USAGE COMP-3.
00305 03 PXECOMP-34 REDEFINES PXE
00306 PIC S9(14)V9(4)
00307 USAGE COMP-3.
00308 03 PXECOMP-35 REDEFINES PXE
00309 PIC S9(13)V9(5)
00310 USAGE COMP-3.
00311 03 PXECOMP-36 REDEFINES PXE
00312 PIC S9(12)V9(6)
00313 USAGE COMP-3.
00314 03 PXECOMP-37 REDEFINES PXE
00315 PIC S9(11)V9(7)
00316 USAGE COMP-3.
00317 03 PXECOMP-38 REDEFINES PXE
00318 PIC S9(10)V9(8)
00319 USAGE COMP-3.
00320 03 PXECOMP-39 REDEFINES PXE
00321 PIC S9(9)V9(9)
00322 USAGE COMP-3.
00323 03 PXECOMP-310 REDEFINES PXE
00324 PIC S9(8)V9(10)
00325 USAGE COMP-3.
00326 03 PXECOMP-311 REDEFINES PXE
00327 PIC S9(7)V9(11)
00328 USAGE COMP-3.
00329 03 PXECOMP-312 REDEFINES PXE
00330 PIC S9(6)V9(12)
00331 USAGE COMP-3.
00332 03 PXECOMP-313 REDEFINES PXE
00333 PIC S9(5)V9(13)
00334 USAGE COMP-3.
00335 03 PXECOMP-314 REDEFINES PXE
00336 PIC S9(4)V9(14)
00337 USAGE COMP-3.
00338 03 PXECOMP-315 REDEFINES PXE
00339 PIC S9(3)V9(15)
00340 USAGE COMP-3.
00341 03 PXECOMP-316 REDEFINES PXE
00342 PIC S9(2)V9(16)
00343 USAGE COMP-3.
00344 03 PXECOMP-317 REDEFINES PXE
00345 PIC S9(1)V9(17)
00346 USAGE COMP-3.
00347 03 PXECOMP-318 REDEFINES PXE
00348 PIC SV9(18)
00349 USAGE COMP-3.
00350 03 PXECOMP20 REDEFINES PXE
00351 PIC S9(4)
00352 USAGE COMP.
00353 03 PXECOMP21 REDEFINES PXE
00354 PIC S9(3)V9(1)
00355 USAGE COMP.
00356 03 PXECOMP22 REDEFINES PXE
00357 PIC S9(2)V9(2)
00358 USAGE COMP.
00359 03 PXECOMP23 REDEFINES PXE
00360 PIC S9(1)V9(3)
00361 USAGE COMP.
00362 03 PXECOMP24 REDEFINES PXE
00363 PIC SV9(4)
00364 USAGE COMP.
00365 03 PXECOMP40 REDEFINES PXE
00366 PIC S9(9)
00367 USAGE COMP.
00368 03 PXECOMP41 REDEFINES PXE
00369 PIC S9(8)V9(1)
00370 USAGE COMP.
00371 03 PXECOMP42 REDEFINES PXE
00372 PIC S9(7)V9(2)
00373 USAGE COMP.
00374 03 PXECOMP43 REDEFINES PXE
00375 PIC S9(6)V9(3)
00376 USAGE COMP.
00377 03 PXECOMP44 REDEFINES PXE
00378 PIC S9(5)V9(4)
00379 USAGE COMP.
00380 03 PXECOMP45 REDEFINES PXE
00381 PIC S9(4)V9(5)
00382 USAGE COMP.
00383 03 PXECOMP46 REDEFINES PXE
00384 PIC S9(3)V9(6)
00385 USAGE COMP.
00386 03 PXECOMP47 REDEFINES PXE
00387 PIC S9(2)V9(7)
00388 USAGE COMP.
00389 03 PXECOMP48 REDEFINES PXE
00390 PIC S9(1)V9(8)
00391 USAGE COMP.
00392 03 PXECOMP49 REDEFINES PXE
00393 PIC SV9(9)
00394 USAGE COMP.
00395 03 PXECOMP80 REDEFINES PXE
00396 PIC S9(18)
00397 USAGE COMP.
00398 03 PXECOMP81 REDEFINES PXE
00399 PIC S9(17)V9(1)
00400 USAGE COMP.
00401 03 PXECOMP82 REDEFINES PXE
00402 PIC S9(16)V9(2)
00403 USAGE COMP.
00404 03 PXECOMP83 REDEFINES PXE
00405 PIC S9(15)V9(3)
00406 USAGE COMP.
00407 03 PXECOMP84 REDEFINES PXE
00408 PIC S9(14)V9(4)
00409 USAGE COMP.
00410 03 PXECOMP85 REDEFINES PXE
00411 PIC S9(13)V9(5)
00412 USAGE COMP.
00413 03 PXECOMP86 REDEFINES PXE
00414 PIC S9(12)V9(6)
00415 USAGE COMP.
00416 03 PXECOMP87 REDEFINES PXE
00417 PIC S9(11)V9(7)
00418 USAGE COMP.
00419 03 PXECOMP88 REDEFINES PXE
00420 PIC S9(10)V9(8)
00421 USAGE COMP.
00422 03 PXECOMP89 REDEFINES PXE
00423 PIC S9(9)V9(9)
00424 USAGE COMP.
00425 03 PXECOMP810 REDEFINES PXE
00426 PIC S9(8)V9(10)
00427 USAGE COMP.
00428 03 PXECOMP811 REDEFINES PXE
00429 PIC S9(7)V9(11)
00430 USAGE COMP.
00431 03 PXECOMP812 REDEFINES PXE
00432 PIC S9(6)V9(12)
00433 USAGE COMP.
00434 03 PXECOMP813 REDEFINES PXE
00435 PIC S9(5)V9(13)
00436 USAGE COMP.
00437 03 PXECOMP814 REDEFINES PXE
00438 PIC S9(4)V9(14)
00439 USAGE COMP.
00440 03 PXECOMP815 REDEFINES PXE
00441 PIC S9(3)V9(15)
00442 USAGE COMP.
00443 03 PXECOMP816 REDEFINES PXE
00444 PIC S9(2)V9(16)
00445 USAGE COMP.
00446 03 PXECOMP817 REDEFINES PXE
00447 PIC S9(1)V9(17)
00448 USAGE COMP.
00449 03 PXECOMP818 REDEFINES PXE
00450 PIC SV9(18)
00451 USAGE COMP.
00452 01 SUBSCHEMA-SSNAME PIC X(8) VALUE 'EMPSS09 '.
00453 01 SUBSCHEMA-AREANAMES.
00454 03 EMP-DEMO-REGION PIC X(16)
00455 VALUE 'EMP-DEMO-REGION '.
00456 03 INS-DEMO-REGION PIC X(16)
00457 VALUE 'INS-DEMO-REGION '.
00458 03 ORG-DEMO-REGION PIC X(16)
00459 VALUE 'ORG-DEMO-REGION '.
00460
DMLC 00461 01 COPY IDMS SUBSCHEMA-LR-RECORDS.
00462 01 EMP-JOB-LR.
00463 02 EMPLOYEE.
00464 03 EMP-ID-0415 PIC 9(4).
00465 03 EMP-NAME-0415.
00466 04 EMP-FIRST-NAME-0415 PIC X(10).
00467 04 EMP-LAST-NAME-0415 PIC X(15).
00468 03 STATUS-0415 PIC X(2).
00469 88 ACTIVE-0415 VALUE '01'.
00470 88 ST-DISABIL-0415 VALUE '02'.
00471 88 LT-DISABIL-0415 VALUE '03'.
00472 88 LEAVE-OF-ABSENCE-0415
00473 VALUE '04'.
00474 88 TERMINATED-0415 VALUE '05'.
00475 03 SS-NUMBER-0415 PIC 9(9).
00476 03 START-DATE-0415.
00477 04 START-YEAR-0415 PIC 9(2).
00478 04 START-MONTH-0415 PIC 9(2).
00479 04 START-DAY-0415 PIC 9(2).
00480 03 FILLER PIC X(2).
00481 02 DEPARTMENT.
00482 03 DEPT-ID-0410 PIC 9(4).
00483 03 DEPT-NAME-0410 PIC X(45).
00484 03 DEPT-HEAD-ID-0410 PIC 9(4).
00485 03 FILLER PIC XXX.
00486 02 JOB.
00487 03 JOB-ID-0440 PIC 9(4).
00488 03 TITLE-0440 PIC X(20).
00489 02 OFFICE.
00490 03 OFFICE-CODE-0450 PIC X(3).
00491 03 OFFICE-ADDRESS-0450.
00492 04 OFFICE-STREET-0450 PIC X(20).
00493 04 OFFICE-CITY-0450 PIC X(15).
00494 04 OFFICE-STATE-0450 PIC X(2).
00495 04 OFFICE-ZIP-0450.
00496 05 OFFICE-ZIP-FIRST-FIVE-0450
00497 PIC X(5).
00498 05 OFFICE-ZIP-LAST-FOUR-0450
00499 PIC X(4).
00500 03 OFFICE-PHONE-0450 PIC 9(7)
00501 OCCURS 3.
00502 03 OFFICE-AREA-CODE-0450 PIC X(3).
00503 03 SPEED-DIAL-0450 PIC X(3).
00504 03 FILLER PIC X(4).
00505 03 SUBSCHEMA-LR-CTRL-END PIC X.
00506
DMLC 00507 01 COPY IDMS MAP-CONTROLS.
00508 01 MRB-EMPMAPLR.
00509 03 MRB-EMPMAPLR-ID PIC X(8).
00510 03 MRB-EMPMAPLR-MCOMP-VER.
00511 05 MRB-EMPMAPLR-MCOMP-DATE
00512 PIC X(8).
00513 05 MRB-EMPMAPLR-MCOMP-TIME
00514 PIC X(6).
00515 05 MRB-EMPMAPLR-MCOMP-VERID
00516 PIC X(2).
00517 03 MRB-EMPMAPLR-SUBSCHEMA PIC X(8).
00518 03 MRB-EMPMAPLR-FLGS PIC X
00519 OCCURS 4.
00520 03 FILLER PIC X(6).
00521 03 MRB-EMPMAPLR-NFLDS PIC S9(4)
00522 USAGE COMP.
00523 03 MRB-EMPMAPLR-NRECS PIC S9(4)
00524 USAGE COMP.
00525 03 MRB-EMPMAPLR-RECOF PIC S9(4)
00526 USAGE COMP.
00527 03 MRB-EMPMAPLR-PERM-CURSOR
00528 PIC XX.
00529 03 MRB-EMPMAPLR-TEMP-CURSOR
00530 PIC XX.
00531 03 MRB-EMPMAPLR-PERM-WCC PIC X.
00532 03 MRB-EMPMAPLR-TEMP-WCC PIC X.
00533 03 MRB-EMPMAPLR-CURSOR PIC XX.
00534 03 MRB-EMPMAPLR-AID PIC X.
00535 03 MRB-EMPMAPLR-INPUT-FLGS
00536 PIC X.
00537 03 MRB-EMPMAPLR-SEGVIEW PIC X.
00538 03 FILLER PIC X.
00539 03 MRB-EMPMAPLR-MREO PIC S9(4)
00540 USAGE COMP.
00541 03 MRB-EMPMAPLR-ERR-CNT PIC S9(4)
00542 USAGE COMP.
00543 03 MRB-EMPMAPLR-ATTR-FLGS PIC X
00544 OCCURS 4.
00545 03 MRB-EMPMAPLR-CURR-MFLD PIC S9(4)
00546 USAGE COMP.
00547 03 MRB-EMPMAPLR-XTYP PIC X.
00548 03 MRB-EMPMAPLR-FILLER PIC X.
00549 03 MRB-EMPMAPLR-MRE-XLEN PIC S9(4)
00550 USAGE COMP.
00551 03 MRB-EMPMAPLR-MRB-XLEN PIC S9(4)
00552 USAGE COMP.
00553 03 MRB-EMPMAPLR-MRE OCCURS 11.
00554 05 MRB-EMPMAPLR-MRE-FLGS
00555 PIC X
00556 OCCURS 8.
00557 05 MRB-EMPMAPLR-MRE-INLEN
00558 PIC S9(4)
00559 USAGE COMP.
00560 05 MRB-EMPMAPLR-MRE-PAD-CHAR
00561 PIC X
00562 OCCURS 2.
00563 05 MRB-EMPMAPLR-MRE-FLG2
00564 PIC X
00565 OCCURS 2.
00566 03 MRB-EMPMAPLR-RECS PIC S9(8)
00567 OCCURS 5
00568 USAGE COMP
00569 SYNC.
00570 03 MRB-EMPMAPLR-END PIC X.
00571 03 MRB-EMPMAPLR-MRE-SUB PIC S9(4)
00572 USAGE COMP.
00573
00574 EJECT
00575 01 MRB-FLDLST.
00576 02 FLDLST PIC S9(8)
00577 OCCURS 6
00578 USAGE COMP.
00579 PROCEDURE DIVISION.
00580
00581 * *********************************************************
00582 * * PROCEDURE DIVISION GENERAL STRATEGY: *
00583 * * RETRIEVE INFORMATION FOR A SPECIFIED EMPLOYEE. *
00584 * * DISPLAYED DATA INCLUDES EMPLOYEE, DEPARTMENT, *
00585 * * JOB, AND OFFICE INFORMATION. *
00586 * * ==> THIS PROGRAM USES THE EMP-JOB-LR LOGICAL RECORD<= *
00587 * * PROGRAM STRATEGY: *
00588 * * ** CHECK FOR TASK CODE: TSK01= INITIAL MAPOUT *
00589 * * ANYTHING ELSE = RETRIEVE LR *
00590 * * ** CLEAR TO EXIT APPLICATION *
00591 * * ** ENTER AND NEW EMP-ID TO CONTINUE *
00592 * *********************************************************
00593
00594 MAIN-LINE.
00595 ***************************************************************
00596 * THE BIND MAP STATEMENTS ADVISE IDMS-DC OF THE LOCATION OF *
00597 * THE MRB AND THE MAP RECORDS. *
00598 ***************************************************************
DMLC0001 00599 BIND MAP EMPMAPLR.
DMLC0002 00628 BIND MAP EMPMAPLR RECORD EMPLOYEE.
DMLC0003 00635 BIND MAP EMPMAPLR RECORD DEPARTMENT.
DMLC0004 00642 BIND MAP EMPMAPLR RECORD JOB.
DMLC0005 00649 BIND MAP EMPMAPLR RECORD OFFICE.
DMLC0006 00656 BIND MAP EMPMAPLR RECORD EMP-DATE-WORK-REC.
00663 *
DMLC0007 00664 ACCEPT TASK CODE INTO TASK-CODE.
00671 IF TASK-CODE = TSK01
00672 GO TO INITIAL-MAPOUT
00673 ELSE
00674 GO TO GET-EMP.
00675 ***************************************************************
00676 ***************************************************************
00677 * THE INITIAL-MAPOUT PARAGRAPH IS PERFORMED IF THE CALLING *
00678 * TASK CODE IS TSK01. *
00679 ***************************************************************
00680 * THE MODIFY MAP STATEMENT ASSIGNS THE PROTECTED *
00681 * ATTRIBUTE TO ALL MAP FIELDS EXCEPT EMP-ID-0415. *
00682 ***************************************************************
00683 * THE MAP OUT STATEMENT TRANSMITS THE EMPMAPLR MAP *
00684 * TO THE TERMINAL. *
00685 ***************************************************************
00686 * THE DC RETURN STATEMENT SPECIFIES THAT THE NEXT *
00687 * TASK THAT WILL BE INITIATED ON THE SAME TERMINAL WHEN THE *
00688 * OPERATOR PRESSES A CONTROL KEY WILL BE TSK02. *
00689 ***************************************************************
00690 INITIAL-MAPOUT.
DMLC0008 00691 MODIFY MAP EMPMAPLR TEMPORARY
DMLC0008 00692 FOR ALL EXCEPT EMP-ID-0415
DMLC0008 00693 ATTRIBUTES PROTECTED.
00707 *
00708 MOVE ZERO TO EMP-ID-0415.
DMLC0009 00709 MAP OUT USING EMPMAPLR
DMLC0009 00710 OUTPUT DATA IS YES NEWPAGE
DMLC0009 00711 MESSAGE IS INITIAL-MESSAGE LENGTH 80.
00722
DMLC0010 00723 DC RETURN
DMLC0010 00724 NEXT TASK CODE TSK02.
00731 INITIAL-MAPOUT-EXIT.
00732 EXIT.
00733 ***************************************************************
00734 ***************************************************************
00735 * THE GET-EMP PARAGRAPH IS PERFORMED IF THE CALLING TASK *
00736 * CODE IS NOT TSK01. *
00737 ***************************************************************
00738 * THE MAP IN STATEMENT TRANSMITS DATA FROM THE TERMINAL TO *
00739 * VARIABLE STORAGE DATA FIELDS. *
00740 ***************************************************************
00741 * THIS FIRST INQUIRE MAP STATEMENT IS USED TO DETERMINE *
00742 * THE AID KEY PRESSED. *
00743 ***************************************************************
00744 * THIS SECOND INQUIRE MAP STATEMENT USES AUTOMATIC EDITING *
00745 * TO DETERMINE IF THE DATA ENTERED IS CONSISTENT WITH *
00746 * THE EXTERNAL PICTURE OF THE NAMED DATA ELEMENT. *
00747 ***************************************************************
00748 * THE MAP OUT STATEMENT TRANSMITS DATA FROM THE *
00749 * EMP-JOB-LR LOGICAL RECORD IN VARIABLE STORAGE TO MAP *
00750 * FIELDS. *
00751 ***************************************************************
00752 GET-EMP.
DMLC0011 00753 MAP IN USING EMPMAPLR.
00763 *
DMLC0012 00764 INQUIRE MAP EMPMAPLR
DMLC0012 00765 MOVE AID TO DC-AID-IND-V.
00773 IF CLEAR-HIT
DMLC0013 00774 DC RETURN.
00780
00781 *
DMLC0014 00782 INQUIRE MAP EMPMAPLR
DMLC0014 00783 IF DFLD EMP-ID-0415 EDIT IS ERROR
00795 THEN GO TO EDIT-ERROR.
00796 *
DMLC 00797 COPY IDMS SUBSCHEMA-BINDS.
00798 MOVE 'EMPDISP ' TO PROGRAM-NAME
DMLC0015 00799 BIND RUN-UNIT.
DMLC0016 00810 READY USAGE-MODE IS RETRIEVAL.
00815 ***************************************************************
00816 * SINCE THE MAP FIELD IS ASSOCIATED WITH THE EMP-ID-0415 *
00817 * FIELD, THE PROGRAM USES THE "OF LR" RETRIEVAL. NOTE THAT *
00818 * AUTOSTATUS IMPLICITLY CHECKS FOR THE LR-ERROR PATH STATUS. *
00819 ***************************************************************
DMLC 00820 OBTAIN EMP-JOB-LR
DMLC 00821 WHERE EMP-ID-0415 = EMP-ID-0415 OF LR
DMLC0017 00822 ON LR-NOT-FOUND
00845 GO TO NOT-FOUND.
DMLC0018 00846 FINISH.
00851
***************************************************************
00853 * REFORMAT DATE TO MMDDYY; OUTPUT AS MM/DD/YY USING THE OLM *
00854 * EXTERNAL PICTURE SPECIFICATION (XX/XX/XX). *
00855 ***************************************************************
00856 MOVE START-YEAR-0415 TO WORK-YY.
00857 MOVE START-MONTH-0415 TO WORK-MM.
00858 MOVE START-DAY-0415 TO WORK-DD.
00859
DMLC0019 00860 MAP OUT USING EMPMAPLR
DMLC0019 00861 OUTPUT DATA IS YES
DMLC0019 00862 MESSAGE IS DISPLAY-MESSAGE LENGTH 80.
00873 *
DMLC0020 00874 DC RETURN NEXT TASK CODE TSK02.
00881 GET-EMP-EXIT.
00882 EXIT.
00883 ***************************************************************
00884 ***************************************************************
00885 * THE MODIFY MAP STATEMENT SPECIFIES THAT ALL MAP *
00886 * FIELDS EXCEPT THE INCORRECT EMP-ID-0415 FIELD WILL BE *
00887 * ERASED ON THE NEXT MAP OUT. *
00888 ***************************************************************
00889 EDIT-ERROR.
DMLC0021 00890 MODIFY MAP EMPMAPLR TEMPORARY
DMLC0021 00891 FOR ALL EXCEPT DFLD EMP-ID-0415
DMLC0021 00892 OUTPUT DATA IS ERASE.
00906 *
DMLC0022 00907 MAP OUT USING EMPMAPLR
DMLC0022 00908 MESSAGE IS EDIT-ERROR-MESSAGE LENGTH 80.
00919 *
DMLC0023 00920 DC RETURN
DMLC0023 00921 NEXT TASK CODE TSK02.
00928 EDIT-ERROR-EXIT.
00929 EXIT.
00930 ***************************************************************
00931 ***************************************************************
00932 * THE FOLLOWING MODIFY MAP STATEMENT SPECIFIES THAT ALL *
00933 * MAP FIELDS EXCEPT THE EMP-ID-0415 FIELD WILL BE ERASED *
00934 * ON THE NEXT MAP OUT. *
00935 ***************************************************************
00936 NOT-FOUND.
DMLC0024 00937 MODIFY MAP EMPMAPLR TEMPORARY
DMLC0024 00938 FOR ALL EXCEPT DFLD EMP-ID-0415
DMLC0024 00939 OUTPUT DATA IS ERASE.
00953 *
DMLC0025 00954 MAP OUT USING EMPMAPLR
DMLC0025 00955 MESSAGE IS EMP-NOT-FOUND-MESSAGE LENGTH 80.
00966 *
DMLC0026 00967 DC RETURN
DMLC0026 00968 NEXT TASK CODE TSK02.
00975 NOT-FOUND-EXIT.
00976 EXIT.
00977 ***************************************************************
00978 IDMS-ABORT.
00979 MOVE ERROR-STATUS TO SSC-ERRSTAT-SAVE.
00980 MOVE DML-SEQUENCE TO SSC-DMLSEQ-SAVE.
DMLC 00981 SNAP FROM SUBSCHEMA-LR-CTRL TO SUBSCHEMA-LR-CTRL-END
DMLC0027 00982 ON ANY-STATUS
00993 NEXT SENTENCE.
00994 MOVE SSC-ERRSTAT-SAVE TO ERROR-STATUS.
00995 MOVE SSC-DMLSEQ-SAVE TO DML-SEQUENCE.
00996 IDMS-ABORT-EXIT.
00997 EXIT.
DMLC 00998 COPY IDMS IDMS-STATUS.
:edisplay.
00999 ******************************************************************01617000
01000 IDMS-STATUS SECTION.01618000
01001 ********************* IDMS-STATUS FOR IDMS-DC ********************01619000
01002 IF DB-STATUS-OK GO TO ISABEX. 01620000
01003 PERFORM IDMS-ABORT. 01621000
01004 MOVE ERROR-STATUS TO SSC-ERRSTAT-SAVE 01622000
01005 MOVE DML-SEQUENCE TO SSC-DMLSEQ-SAVE 01623000
DMLC 01006 SNAP FROM SUBSCHEMA-CTRL TO SUBSCHEMA-CTRL-END 01624000
DMLC0028 01007 ON ANY-STATUS 01625000
01018 NEXT SENTENCE.
DMLC 01019 ABEND CODE SSC-ERRSTAT-SAVE 01626000
DMLC0029 01020 ON ANY-STATUS 01627000
01028 NEXT SENTENCE.
01029 ISABEX. EXIT. 01628000
***2000 * W BIND RECORD NOT ISSUED
***2400 * W WAS MOST SEVERE ERROR FOUND
0002 MESSAGES FOR PROGRAM EMPDISP
00001 *NO-ACTIVITY-LOG 00002 *DMLIST 00003 00004 IDENTIFICATION DIVISION. 00005 00006 PROGRAM-ID. EMPDISP. 00007 00008 AUTHOR. COMPUTER ASSOCIATES. 00009 00010 DATE-WRITTEN. APRIL 1995. 00011 00012 REMARKS. THIS PROGRAM DEMONSTRATES 00013 CA IDMS PROGRAMMING USING 00014 THE LOGICAL RECORD FACILITY. 00015 00016 *************************************************************** 00017 ENVIRONMENT DIVISION. 00018 *************************************************************** 00019 *IDMS-CONTROL SECTION. 00020 00021 *PROTOCOL. MODE IS IDMS-DC DEBUG 00022 * IDMS-RECORDS MANUAL. 00024 DATA DIVISION. 00025 00026 *SCHEMA SECTION. 00027 00028 * DB EMPSS09 WITHIN EMPSCHM. 00029 00030 *MAP SECTION. 00031 *MAX FIELD LIST IS 5. 00032 *MAP EMPMAPLR VERSION 1 TYPE IS STANDARD.
00033 00034 00035 00036 WORKING-STORAGE SECTION. 00037 01 TASK-CODE PIC X(8). 00038 01 TSK01 PIC X(8) VALUE 'TSK01'. 00039 01 TSK02 PIC X(8) VALUE 'TSK02'. 00040 00041 01 MESSAGES. 00042 05 INITIAL-MESSAGE PIC X(80) VALUE 00043 'ENTER AN EMP ID AND PRESS ENTER ** CLEAR TO EXIT'. 00044 05 EDIT-ERROR-MESSAGE PIC X(80) VALUE 00045 'EMP-ID EITHER NOT ENTERED OR NOT NUMERIC'. 00046 05 EMP-NOT-FOUND-MESSAGE PIC X(80) VALUE 00047 'SPECIFIED EMPLOYEE COULD NOT BE FOUND'. 00048 05 DISPLAY-MESSAGE PIC X(80) VALUE 00049 'CLEAR TO EXIT ** NEW EMP-ID AND ENTER TO CONTINUE'. 00050 00051 *01 COPY IDMS DC-AID-CONDITION-NAMES. 00052 01 DC-AID-CONDITION-NAMES. 00053 03 DC-AID-IND-V PIC X. 00054 88 ENTER-HIT VALUE QUOTE. 00055 88 CLEAR-HIT VALUE '_'. 00056 88 PF01-HIT VALUE '1'. 00057 88 PF02-HIT VALUE '2'. 00058 88 PF03-HIT VALUE '3'. 00059 88 PF04-HIT VALUE '4'. 00060 88 PF05-HIT VALUE '5'. 00061 88 PF06-HIT VALUE '6'. 00062 88 PF07-HIT VALUE '7'. 00063 88 PF08-HIT VALUE '8'. 00064 88 PF09-HIT VALUE '9'. 00065 88 PF10-HIT VALUE ':'.
00066 88 PF11-HIT VALUE '#'. 00067 88 PF12-HIT VALUE '@'. 00068 88 PF13-HIT VALUE 'A'. 00069 88 PF14-HIT VALUE 'B'. 00070 88 PF15-HIT VALUE 'C'. 00071 88 PF16-HIT VALUE 'D'. 00072 88 PF17-HIT VALUE 'E'. 00073 88 PF18-HIT VALUE 'F'. 00074 88 PF19-HIT VALUE 'G'. 00075 88 PF20-HIT VALUE 'H'. 00076 88 PF21-HIT VALUE 'I'. 00077 88 PF22-HIT VALUE '_'. 00078 88 PF23-HIT VALUE '.'. 00079 88 PF24-HIT VALUE '<'. 00080 88 PA01-HIT VALUE '%'. 00081 88 PA02-HIT VALUE '>'. 00082 88 PA03-HIT VALUE ','. 00083 88 PEN-ATTN-SPACE-NULL VALUE '='. 00084 88 PEN-ATTN VALUE QUOTE. 00085 00086 *01 COPY IDMS EMP-DATE-WORK-REC. 00087 01 EMP-DATE-WORK-REC. 00088 02 WORK-DATE. 00089 03 WORK-MM PIC 9(2). 00090 03 WORK-DD PIC 9(2). 00091 03 WORK-YY PIC 9(2).
00092 00093 *01 COPY IDMS SUBSCHEMA-LR-CONTROL. 00094 01 SUBSCHEMA-CTRL. 00095 03 PROGRAM-NAME PIC X(8) VALUE SPACES. 00096 03 ERROR-STATUS PIC X(4) VALUE '1400'. 00097 88 DB-STATUS-OK VALUE '0000'. 00098 88 ANY-STATUS 00099 VALUE '0000' THRU '9999'. 00100 88 ANY-ERROR-STATUS 00101 VALUE '0001' THRU '9999'. 00102 88 DB-END-OF-SET VALUE '0307'. 00103 88 DB-REC-NOT-FOUND VALUE '0326'. 00104 88 DC-DEADLOCK VALUE '3101' 00105 '3201' '3401' '3901'. 00106 88 DC-NO-STORAGE VALUE '3202' 00107 '3402'. 00108 88 DC-AREA-ID-UNK VALUE '4303'. 00109 88 DC-QUEUE-ID-UNK VALUE '4404'. 00110 88 DC-REC-NOT-FOUND VALUE '4305' 00111 '4405'. 00112 88 DC-RESOURCE-NOT-AVAIL 00113 VALUE '3908'. 00114 88 DC-RESOURCE-AVAIL 00115 VALUE '3909'. 00116 88 DC-NEW-STORAGE VALUE '3210'. 00117 88 DC-MAX-TASKS VALUE '3711'. 00118 88 DC-REC-REPLACED VALUE '4317'. 00119 88 DC-TRUNCATED-DATA 00120 VALUE '4319' '4419' 00121 '4519' '4719'. 00122 88 DC-ATTN-INT VALUE '4525'
00123 '4625'. 00124 88 DC-OPER-CANCEL VALUE '4743'. 00125 88 DC-FIRST-PAGE-SENT 00126 VALUE '4676'. 00127 88 DC-SECOND-STARTPAGE 00128 VALUE '4604'. 00129 88 DC-DETAIL-NOT-FOUND 00130 VALUE '4664'. 00131 03 DBKEY PIC S9(8) 00132 USAGE COMP. 00133 03 RECORD-NAME PIC X(16) VALUE SPACES. 00134 03 RRECORD-NAME REDEFINES RECORD-NAME. 00135 05 SSC-NODN PIC X(8). 00136 05 SSC-DBN PIC X(8). 00137 03 AREA-NAME PIC X(16) VALUE SPACES. 00138 03 ERROR-SET PIC X(16) VALUE SPACES. 00139 03 ERROR-RECORD PIC X(16) VALUE SPACES. 00140 03 ERROR-AREA PIC X(16) VALUE SPACES. 00141 03 IDBMSCOM-AREA PIC X(100) VALUE LOW-VALUE. 00142 03 IDBMSCOM REDEFINES IDBMSCOM-AREA 00143 PIC X 00144 OCCURS 100. 00145 03 RIDBMSCOM REDEFINES IDBMSCOM-AREA. 00146 05 DB-SUB-ADDR PIC X(4). 00147 05 FILLER PIC X(0096). 00148 03 DIRECT-DBKEY PIC S9(8) 00149 USAGE COMP.
00150 03 DIRECT-DBK REDEFINES DIRECT-DBKEY 00151 PIC S9(8) 00152 USAGE COMP. 00153 03 DCBMSCOM-AREA PIC X(100) VALUE LOW-VALUE. 00154 03 DCBMSCOM REDEFINES DCBMSCOM-AREA 00155 PIC X 00156 OCCURS 100. 00157 03 R1DCBMSCOM REDEFINES DCBMSCOM-AREA. 00158 05 R2DCBMSCOM PIC S9(8) 00159 OCCURS 11 00160 USAGE COMP. 00161 05 DCSTR1 PIC X(16). 00162 05 R3DCBMSCOM REDEFINES DCSTR1. 00163 07 DCSTR2 PIC X(8). 00164 07 R4DCBMSCOM REDEFINES DCSTR2. 00165 09 DCSTR4 PIC X(4). 00166 09 DCSTR5 PIC X(4). 00167 07 DCSTR3 PIC X(8). 00168 05 R5DCBMSCOM REDEFINES DCSTR1. 00169 07 DCPNUM1 PIC S9(15) 00170 USAGE COMP-3. 00171 05 DCNUM1 PIC S9(8) 00172 USAGE COMP. 00173 05 R6DCBMSCOM REDEFINES DCNUM1. 00174 07 DCPNUM2 PIC S9(7) 00175 USAGE COMP-3. 00176 05 DCNUM2 PIC S9(8) 00177 USAGE COMP. 00178 05 DCNUM3 PIC S9(8) 00179 USAGE COMP. 00180 05 DCFLG1 PIC S9(4)
00181 USAGE COMP. 00182 05 DCFLG2 PIC S9(4) 00183 USAGE COMP. 00184 05 DCFLG3 PIC S9(4) 00185 USAGE COMP. 00186 05 DCFLG4 PIC S9(4) 00187 USAGE COMP. 00188 03 SSC-ERRSTAT-SAVE PIC X(4) VALUE SPACES. 00189 03 SSC-DMLSEQ-SAVE PIC S9(8) 00190 USAGE COMP. 00191 03 DML-SEQUENCE PIC S9(8) 00192 USAGE COMP. 00193 03 RECORD-OCCUR PIC S9(8) 00194 USAGE COMP. 00195 03 SUBSCHEMA-CTRL-END PIC X(4) VALUE SPACES. 00196 01 SUBSCHEMA-LR-CTRL. 00197 03 LRC-LRPXELNG PIC S9(4) 00198 USAGE COMP. 00199 03 LRC-MAXVXP PIC S9(4) 00200 USAGE COMP. 00201 03 LRIDENT PIC X(4) VALUE 'LRC '. 00202 03 LRVERB PIC X(8). 00203 03 LRNAME PIC X(16). 00204 03 LR-STATUS PIC X(16). 00205 03 FILLER PIC X(16). 00206 03 LRPXE PIC X 00207 OCCURS 0 TO 512 00208 DEPENDING ON LRC-LRPXELNG. 00209 03 PXE. 00210 05 PXENEXT PIC S9(8) 00211 USAGE COMP. 00212 05 PXETABO PIC S9(4) 00213 USAGE COMP.
00214 05 PXEDSPL PIC S9(4) 00215 USAGE COMP. 00216 05 PXEDYN PIC S9(4) 00217 USAGE COMP. 00218 05 PXEDLEN PIC S9(4) 00219 USAGE COMP. 00220 05 PXENDEC PIC X. 00221 05 PXEDTYP PIC X. 00222 05 PXEOTYP PIC X. 00223 05 PXEFLAG PIC X. 00224 05 FILLER PIC X(240). 00225 03 PXEDSP256 REDEFINES PXE 00226 PIC X(256). 00227 03 PXEDSP248 REDEFINES PXE 00228 PIC X(248). 00229 03 PXEDSP240 REDEFINES PXE 00230 PIC X(240). 00231 03 PXEDSP232 REDEFINES PXE 00232 PIC X(232). 00233 03 PXEDSP224 REDEFINES PXE 00234 PIC X(224). 00235 03 PXEDSP216 REDEFINES PXE 00236 PIC X(216). 00237 03 PXEDSP208 REDEFINES PXE 00238 PIC X(208). 00239 03 PXEDSP200 REDEFINES PXE 00240 PIC X(200). 00241 03 PXEDSP192 REDEFINES PXE 00242 PIC X(192). 00243 03 PXEDSP184 REDEFINES PXE 00244 PIC X(184). 00245 03 PXEDSP176 REDEFINES PXE 00246 PIC X(176). 00247 03 PXEDSP168 REDEFINES PXE 00248 PIC X(168).
00249 03 PXEDSP160 REDEFINES PXE 00250 PIC X(160). 00251 03 PXEDSP152 REDEFINES PXE 00252 PIC X(152). 00253 03 PXEDSP144 REDEFINES PXE 00254 PIC X(144). 00255 03 PXEDSP136 REDEFINES PXE 00256 PIC X(136). 00257 03 PXEDSP128 REDEFINES PXE 00258 PIC X(128). 00259 03 PXEDSP120 REDEFINES PXE 00260 PIC X(120). 00261 03 PXEDSP112 REDEFINES PXE 00262 PIC X(112). 00263 03 PXEDSP104 REDEFINES PXE 00264 PIC X(104). 00265 03 PXEDSP96 REDEFINES PXE 00266 PIC X(96). 00267 03 PXEDSP88 REDEFINES PXE 00268 PIC X(88). 00269 03 PXEDSP80 REDEFINES PXE 00270 PIC X(80). 00271 03 PXEDSP72 REDEFINES PXE 00272 PIC X(72). 00273 03 PXEDSP64 REDEFINES PXE 00274 PIC X(64). 00275 03 PXEDSP56 REDEFINES PXE 00276 PIC X(56). 00277 03 PXEDSP48 REDEFINES PXE 00278 PIC X(48). 00279 03 PXEDSP40 REDEFINES PXE 00280 PIC X(40). 00281 03 PXEDSP32 REDEFINES PXE 00282 PIC X(32). 00283 03 PXEDSP24 REDEFINES PXE 00284 PIC X(24). 00285 03 PXEDSP16 REDEFINES PXE 00286 PIC X(16). 00287 03 PXEDSP8 REDEFINES PXE 00288 PIC X(8). 00289 03 PXECOMP-1 REDEFINES PXE 00290 USAGE COMP-1. 00291 03 PXECOMP-2 REDEFINES PXE 00292 USAGE COMP-2. 00293 03 PXECOMP-30 REDEFINES PXE 00294 PIC S9(18)
00295 USAGE COMP-3. 00296 03 PXECOMP-31 REDEFINES PXE 00297 PIC S9(17)V9(1) 00298 USAGE COMP-3. 00299 03 PXECOMP-32 REDEFINES PXE 00300 PIC S9(16)V9(2) 00301 USAGE COMP-3. 00302 03 PXECOMP-33 REDEFINES PXE 00303 PIC S9(15)V9(3) 00304 USAGE COMP-3. 00305 03 PXECOMP-34 REDEFINES PXE 00306 PIC S9(14)V9(4) 00307 USAGE COMP-3. 00308 03 PXECOMP-35 REDEFINES PXE 00309 PIC S9(13)V9(5) 00310 USAGE COMP-3. 00311 03 PXECOMP-36 REDEFINES PXE 00312 PIC S9(12)V9(6) 00313 USAGE COMP-3. 00314 03 PXECOMP-37 REDEFINES PXE 00315 PIC S9(11)V9(7) 00316 USAGE COMP-3. 00317 03 PXECOMP-38 REDEFINES PXE 00318 PIC S9(10)V9(8) 00319 USAGE COMP-3. 00320 03 PXECOMP-39 REDEFINES PXE 00321 PIC S9(9)V9(9) 00322 USAGE COMP-3. 00323 03 PXECOMP-310 REDEFINES PXE 00324 PIC S9(8)V9(10) 00325 USAGE COMP-3. 00326 03 PXECOMP-311 REDEFINES PXE 00327 PIC S9(7)V9(11) 00328 USAGE COMP-3. 00329 03 PXECOMP-312 REDEFINES PXE 00330 PIC S9(6)V9(12) 00331 USAGE COMP-3.
00332 03 PXECOMP-313 REDEFINES PXE 00333 PIC S9(5)V9(13) 00334 USAGE COMP-3. 00335 03 PXECOMP-314 REDEFINES PXE 00336 PIC S9(4)V9(14) 00337 USAGE COMP-3. 00338 03 PXECOMP-315 REDEFINES PXE 00339 PIC S9(3)V9(15) 00340 USAGE COMP-3. 00341 03 PXECOMP-316 REDEFINES PXE 00342 PIC S9(2)V9(16) 00343 USAGE COMP-3. 00344 03 PXECOMP-317 REDEFINES PXE 00345 PIC S9(1)V9(17) 00346 USAGE COMP-3. 00347 03 PXECOMP-318 REDEFINES PXE 00348 PIC SV9(18) 00349 USAGE COMP-3. 00350 03 PXECOMP20 REDEFINES PXE 00351 PIC S9(4) 00352 USAGE COMP. 00353 03 PXECOMP21 REDEFINES PXE 00354 PIC S9(3)V9(1) 00355 USAGE COMP. 00356 03 PXECOMP22 REDEFINES PXE 00357 PIC S9(2)V9(2) 00358 USAGE COMP. 00359 03 PXECOMP23 REDEFINES PXE
00360 PIC S9(1)V9(3) 00361 USAGE COMP. 00362 03 PXECOMP24 REDEFINES PXE 00363 PIC SV9(4) 00364 USAGE COMP. 00365 03 PXECOMP40 REDEFINES PXE 00366 PIC S9(9) 00367 USAGE COMP. 00368 03 PXECOMP41 REDEFINES PXE 00369 PIC S9(8)V9(1) 00370 USAGE COMP. 00371 03 PXECOMP42 REDEFINES PXE 00372 PIC S9(7)V9(2) 00373 USAGE COMP. 00374 03 PXECOMP43 REDEFINES PXE 00375 PIC S9(6)V9(3) 00376 USAGE COMP. 00377 03 PXECOMP44 REDEFINES PXE 00378 PIC S9(5)V9(4) 00379 USAGE COMP. 00380 03 PXECOMP45 REDEFINES PXE 00381 PIC S9(4)V9(5) 00382 USAGE COMP. 00383 03 PXECOMP46 REDEFINES PXE 00384 PIC S9(3)V9(6) 00385 USAGE COMP. 00386 03 PXECOMP47 REDEFINES PXE 00387 PIC S9(2)V9(7) 00388 USAGE COMP. 00389 03 PXECOMP48 REDEFINES PXE 00390 PIC S9(1)V9(8) 00391 USAGE COMP.
00392 03 PXECOMP49 REDEFINES PXE 00393 PIC SV9(9) 00394 USAGE COMP. 00395 03 PXECOMP80 REDEFINES PXE 00396 PIC S9(18) 00397 USAGE COMP. 00398 03 PXECOMP81 REDEFINES PXE 00399 PIC S9(17)V9(1) 00400 USAGE COMP. 00401 03 PXECOMP82 REDEFINES PXE 00402 PIC S9(16)V9(2) 00403 USAGE COMP. 00404 03 PXECOMP83 REDEFINES PXE 00405 PIC S9(15)V9(3) 00406 USAGE COMP. 00407 03 PXECOMP84 REDEFINES PXE 00408 PIC S9(14)V9(4) 00409 USAGE COMP. 00410 03 PXECOMP85 REDEFINES PXE 00411 PIC S9(13)V9(5) 00412 USAGE COMP. 00413 03 PXECOMP86 REDEFINES PXE 00414 PIC S9(12)V9(6) 00415 USAGE COMP. 00416 03 PXECOMP87 REDEFINES PXE 00417 PIC S9(11)V9(7) 00418 USAGE COMP. 00419 03 PXECOMP88 REDEFINES PXE 00420 PIC S9(10)V9(8) 00421 USAGE COMP. 00422 03 PXECOMP89 REDEFINES PXE
00423 PIC S9(9)V9(9) 00424 USAGE COMP. 00425 03 PXECOMP810 REDEFINES PXE 00426 PIC S9(8)V9(10) 00427 USAGE COMP. 00428 03 PXECOMP811 REDEFINES PXE 00429 PIC S9(7)V9(11) 00430 USAGE COMP. 00431 03 PXECOMP812 REDEFINES PXE 00432 PIC S9(6)V9(12) 00433 USAGE COMP. 00434 03 PXECOMP813 REDEFINES PXE 00435 PIC S9(5)V9(13) 00436 USAGE COMP. 00437 03 PXECOMP814 REDEFINES PXE 00438 PIC S9(4)V9(14) 00439 USAGE COMP. 00440 03 PXECOMP815 REDEFINES PXE 00441 PIC S9(3)V9(15) 00442 USAGE COMP. 00443 03 PXECOMP816 REDEFINES PXE 00444 PIC S9(2)V9(16) 00445 USAGE COMP. 00446 03 PXECOMP817 REDEFINES PXE 00447 PIC S9(1)V9(17) 00448 USAGE COMP. 00449 03 PXECOMP818 REDEFINES PXE 00450 PIC SV9(18) 00451 USAGE COMP. 00452 01 SUBSCHEMA-SSNAME PIC X(8) VALUE 'EMPSS09 '.
00453 01 SUBSCHEMA-AREANAMES. 00454 03 EMP-DEMO-REGION PIC X(16) 00455 VALUE 'EMP-DEMO-REGION '. 00456 03 INS-DEMO-REGION PIC X(16) 00457 VALUE 'INS-DEMO-REGION '. 00458 03 ORG-DEMO-REGION PIC X(16) 00459 VALUE 'ORG-DEMO-REGION '. 00460 00461 *01 COPY IDMS SUBSCHEMA-LR-RECORDS. 00462 01 EMP-JOB-LR. 00463 02 EMPLOYEE. 00464 03 EMP-ID-0415 PIC 9(4). 00465 03 EMP-NAME-0415. 00466 04 EMP-FIRST-NAME-0415 PIC X(10). 00467 04 EMP-LAST-NAME-0415 PIC X(15). 00468 03 STATUS-0415 PIC X(2). 00469 88 ACTIVE-0415 VALUE '01'. 00470 88 ST-DISABIL-0415 VALUE '02'. 00471 88 LT-DISABIL-0415 VALUE '03'. 00472 88 LEAVE-OF-ABSENCE-0415 00473 VALUE '04'. 00474 88 TERMINATED-0415 VALUE '05'. 00475 03 SS-NUMBER-0415 PIC 9(9). 00476 03 START-DATE-0415. 00477 04 START-YEAR-0415 PIC 9(2). 00478 04 START-MONTH-0415 PIC 9(2). 00479 04 START-DAY-0415 PIC 9(2). 00480 03 FILLER PIC X(2). 00481 02 DEPARTMENT. 00482 03 DEPT-ID-0410 PIC 9(4). 00483 03 DEPT-NAME-0410 PIC X(45). 00484 03 DEPT-HEAD-ID-0410 PIC 9(4).
00485 03 FILLER PIC XXX. 00486 02 JOB. 00487 03 JOB-ID-0440 PIC 9(4). 00488 03 TITLE-0440 PIC X(20). 00489 02 OFFICE. 00490 03 OFFICE-CODE-0450 PIC X(3). 00491 03 OFFICE-ADDRESS-0450. 00492 04 OFFICE-STREET-0450 PIC X(20). 00493 04 OFFICE-CITY-0450 PIC X(15). 00494 04 OFFICE-STATE-0450 PIC X(2). 00495 04 OFFICE-ZIP-0450. 00496 05 OFFICE-ZIP-FIRST-FIVE-0450 00497 PIC X(5). 00498 05 OFFICE-ZIP-LAST-FOUR-0450 00499 PIC X(4). 00500 03 OFFICE-PHONE-0450 PIC 9(7) 00501 OCCURS 3. 00502 03 OFFICE-AREA-CODE-0450 PIC X(3). 00503 03 SPEED-DIAL-0450 PIC X(3). 00504 03 FILLER PIC X(4). 00505 03 SUBSCHEMA-LR-CTRL-END PIC X. 00506 00507 *01 COPY IDMS MAP-CONTROLS. 00508 01 MRB-EMPMAPLR. 00509 03 MRB-EMPMAPLR-ID PIC X(8). 00510 03 MRB-EMPMAPLR-MCOMP-VER. 00511 05 MRB-EMPMAPLR-MCOMP-DATE 00512 PIC X(8). 00513 05 MRB-EMPMAPLR-MCOMP-TIME 00514 PIC X(6). 00515 05 MRB-EMPMAPLR-MCOMP-VERID 00516 PIC X(2).
00517 03 MRB-EMPMAPLR-SUBSCHEMA PIC X(8). 00518 03 MRB-EMPMAPLR-FLGS PIC X 00519 OCCURS 4. 00520 03 FILLER PIC X(6). 00521 03 MRB-EMPMAPLR-NFLDS PIC S9(4) 00522 USAGE COMP. 00523 03 MRB-EMPMAPLR-NRECS PIC S9(4) 00524 USAGE COMP. 00525 03 MRB-EMPMAPLR-RECOF PIC S9(4) 00526 USAGE COMP. 00527 03 MRB-EMPMAPLR-PERM-CURSOR 00528 PIC XX. 00529 03 MRB-EMPMAPLR-TEMP-CURSOR 00530 PIC XX. 00531 03 MRB-EMPMAPLR-PERM-WCC PIC X. 00532 03 MRB-EMPMAPLR-TEMP-WCC PIC X. 00533 03 MRB-EMPMAPLR-CURSOR PIC XX. 00534 03 MRB-EMPMAPLR-AID PIC X. 00535 03 MRB-EMPMAPLR-INPUT-FLGS 00536 PIC X. 00537 03 MRB-EMPMAPLR-SEGVIEW PIC X. 00538 03 FILLER PIC X. 00539 03 MRB-EMPMAPLR-MREO PIC S9(4) 00540 USAGE COMP. 00541 03 MRB-EMPMAPLR-ERR-CNT PIC S9(4) 00542 USAGE COMP. 00543 03 MRB-EMPMAPLR-ATTR-FLGS PIC X 00544 OCCURS 4. 00545 03 MRB-EMPMAPLR-CURR-MFLD PIC S9(4) 00546 USAGE COMP. 00547 03 MRB-EMPMAPLR-XTYP PIC X. 00548 03 MRB-EMPMAPLR-FILLER PIC X.
00549 03 MRB-EMPMAPLR-MRE-XLEN PIC S9(4) 00550 USAGE COMP. 00551 03 MRB-EMPMAPLR-MRB-XLEN PIC S9(4) 00552 USAGE COMP. 00553 03 MRB-EMPMAPLR-MRE OCCURS 11. 00554 05 MRB-EMPMAPLR-MRE-FLGS 00555 PIC X 00556 OCCURS 8. 00557 05 MRB-EMPMAPLR-MRE-INLEN 00558 PIC S9(4) 00559 USAGE COMP. 00560 05 MRB-EMPMAPLR-MRE-PAD-CHAR 00561 PIC X 00562 OCCURS 2. 00563 05 MRB-EMPMAPLR-MRE-FLG2 00564 PIC X 00565 OCCURS 2. 00566 03 MRB-EMPMAPLR-RECS PIC S9(8) 00567 OCCURS 5 00568 USAGE COMP 00569 SYNC. 00570 03 MRB-EMPMAPLR-END PIC X. 00571 03 MRB-EMPMAPLR-MRE-SUB PIC S9(4) 00572 USAGE COMP. 00573 00574 00575 01 MRB-FLDLST. 00576 02 FLDLST PIC S9(8)
00577 OCCURS 6 00578 USAGE COMP. 00579 PROCEDURE DIVISION. 00580 00581 * ********************************************************* 00582 * * PROCEDURE DIVISION GENERAL STRATEGY: * 00583 * * RETRIEVE INFORMATION FOR A SPECIFIED EMPLOYEE. * 00584 * * DISPLAYED DATA INCLUDES EMPLOYEE, DEPARTMENT, * 00585 * * JOB, AND OFFICE INFORMATION. * 00586 * * ==> THIS PROGRAM USES THE EMP-JOB-LR LOGICAL RECORD<= * 00587 * * PROGRAM STRATEGY: * 00588 * * ** CHECK FOR TASK CODE: TSK01= INITIAL MAPOUT * 00589 * * ANYTHING ELSE = RETRIEVE LR * 00590 * * ** CLEAR TO EXIT APPLICATION * 00591 * * ** ENTER AND NEW EMP-ID TO CONTINUE * 00592 * ********************************************************* 00593 00594 MAIN-LINE. 00595 *************************************************************** 00596 * THE BIND MAP STATEMENTS ADVISE IDMS-DC OF THE LOCATION OF * 00597 * THE MRB AND THE MAP RECORDS. * 00598 *************************************************************** 00599 * BIND MAP EMPMAPLR. 00600 MOVE 0001 TO DML-SEQUENCE DMLC0001 00601 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00602 DCBMSCOM (90) 00603 MRB-EMPMAPLR 00604 MRB-EMPMAPLR-END 00605 MOVE '08/12/85112414R2' 00606 TO MRB-EMPMAPLR-MCOMP-VER 00607 MOVE 'EMPSS09 ' 00608 TO MRB-EMPMAPLR-SUBSCHEMA 00609 MOVE 'EMPMAPLR' 00610 TO MRB-EMPMAPLR-ID 00611 MOVE 11
00612 TO MRB-EMPMAPLR-NFLDS 00613 MOVE 5 00614 TO MRB-EMPMAPLR-NRECS 00615 MOVE 156 00616 TO MRB-EMPMAPLR-RECOF 00617 MOVE 76 00618 TO MRB-EMPMAPLR-MREO 00619 MOVE '0' 00620 TO MRB-EMPMAPLR-XTYP 00621 MOVE 0 00622 TO MRB-EMPMAPLR-MRE-XLEN 00623 MOVE 0 00624 TO MRB-EMPMAPLR-MRB-XLEN 00625 MOVE 'Y' 00626 TO MRB-EMPMAPLR-SEGVIEW 00627 PERFORM IDMS-STATUS. 00628 * BIND MAP EMPMAPLR RECORD EMPLOYEE. 00629 MOVE 0002 TO DML-SEQUENCE DMLC0002 00630 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00631 DCBMSCOM (91) 00632 MRB-EMPMAPLR-RECS (1) 00633 EMPLOYEE 00634 PERFORM IDMS-STATUS. 00635 * BIND MAP EMPMAPLR RECORD DEPARTMENT. 00636 MOVE 0003 TO DML-SEQUENCE DMLC0003 00637 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00638 DCBMSCOM (91) 00639 MRB-EMPMAPLR-RECS (2) 00640 DEPARTMENT 00641 PERFORM IDMS-STATUS.
00642 * BIND MAP EMPMAPLR RECORD JOB. 00643 MOVE 0004 TO DML-SEQUENCE DMLC0004 00644 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00645 DCBMSCOM (91) 00646 MRB-EMPMAPLR-RECS (3) 00647 JOB 00648 PERFORM IDMS-STATUS. 00649 * BIND MAP EMPMAPLR RECORD OFFICE. 00650 MOVE 0005 TO DML-SEQUENCE DMLC0005 00651 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00652 DCBMSCOM (91) 00653 MRB-EMPMAPLR-RECS (4) 00654 OFFICE 00655 PERFORM IDMS-STATUS. 00656 * BIND MAP EMPMAPLR RECORD EMP-DATE-WORK-REC. 00657 MOVE 0006 TO DML-SEQUENCE DMLC0006 00658 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00659 DCBMSCOM (91) 00660 MRB-EMPMAPLR-RECS (5) 00661 EMP-DATE-WORK-REC 00662 PERFORM IDMS-STATUS. 00663 * 00664 * ACCEPT TASK CODE INTO TASK-CODE. 00665 MOVE 0007 TO DML-SEQUENCE DMLC0007 00666 MOVE 1 TO DCNUM1 00667 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00668 DCBMSCOM (2) 00669 TASK-CODE 00670 PERFORM IDMS-STATUS.
00671 IF TASK-CODE = TSK01 00672 GO TO INITIAL-MAPOUT 00673 ELSE 00674 GO TO GET-EMP. 00675 *************************************************************** 00676 *************************************************************** 00677 * THE INITIAL-MAPOUT PARAGRAPH IS PERFORMED IF THE CALLING * 00678 * TASK CODE IS TSK01. * 00679 *************************************************************** 00680 * THE MODIFY MAP STATEMENT ASSIGNS THE PROTECTED * 00681 * ATTRIBUTE TO ALL MAP FIELDS EXCEPT EMP-ID-0415. * 00682 *************************************************************** 00683 * THE MAP OUT STATEMENT TRANSMITS THE EMPMAPLR MAP * 00684 * TO THE TERMINAL. * 00685 *************************************************************** 00686 * THE DC RETURN STATEMENT SPECIFIES THAT THE NEXT * 00687 * TASK THAT WILL BE INITIATED ON THE SAME TERMINAL WHEN THE * 00688 * OPERATOR PRESSES A CONTROL KEY WILL BE TSK02. * 00689 *************************************************************** 00690 INITIAL-MAPOUT. 00691 * MODIFY MAP EMPMAPLR TEMPORARY 00692 * FOR ALL EXCEPT EMP-ID-0415 00693 * ATTRIBUTES PROTECTED. 00694 MOVE 0008 TO DML-SEQUENCE DMLC0008 00695 MOVE 8 TO DCNUM1 00696 MOVE 2561 TO DCFLG1 00697 MOVE 0 TO DCFLG2 00698 MOVE 0 TO DCFLG3 00699 MOVE 0 TO DCFLG4 00700 MOVE 1 TO FLDLST (2) 00701 MOVE 1 TO FLDLST (1) 00702 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00703 DCBMSCOM (93) 00704 MRB-EMPMAPLR 00705 MRB-FLDLST
00706 PERFORM IDMS-STATUS. 00707 * 00708 MOVE ZERO TO EMP-ID-0415. 00709 * MAP OUT USING EMPMAPLR 00710 * OUTPUT DATA IS YES NEWPAGE 00711 * MESSAGE IS INITIAL-MESSAGE LENGTH 80. 00712 MOVE 0009 TO DML-SEQUENCE DMLC0009 00713 MOVE 5 TO DCFLG1 00714 MOVE 16 TO DCFLG2 00715 MOVE 1 TO DCFLG3 00716 MOVE 4 TO DCFLG4 00717 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00718 DCBMSCOM (34) 00719 MRB-EMPMAPLR 00720 INITIAL-MESSAGE DCBMSCOM (80) 00721 PERFORM IDMS-STATUS. 00722 00723 * DC RETURN 00724 * NEXT TASK CODE TSK02. 00725 MOVE 0010 TO DML-SEQUENCE DMLC0010 00726 MOVE TSK02 TO DCSTR2 00727 MOVE 128 TO DCFLG1 00728 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00729 DCBMSCOM (19) 00730 PERFORM IDMS-STATUS.
00731 INITIAL-MAPOUT-EXIT. 00732 EXIT. 00733 *************************************************************** 00734 *************************************************************** 00735 * THE GET-EMP PARAGRAPH IS PERFORMED IF THE CALLING TASK * 00736 * CODE IS NOT TSK01. * 00737 *************************************************************** 00738 * THE MAP IN STATEMENT TRANSMITS DATA FROM THE TERMINAL TO * 00739 * VARIABLE STORAGE DATA FIELDS. * 00740 *************************************************************** 00741 * THIS FIRST INQUIRE MAP STATEMENT IS USED TO DETERMINE * 00742 * THE AID KEY PRESSED. * 00743 *************************************************************** 00744 * THIS SECOND INQUIRE MAP STATEMENT USES AUTOMATIC EDITING * 00745 * TO DETERMINE IF THE DATA ENTERED IS CONSISTENT WITH * 00746 * THE EXTERNAL PICTURE OF THE NAMED DATA ELEMENT. * 00747 *************************************************************** 00748 * THE MAP OUT STATEMENT TRANSMITS DATA FROM THE * 00749 * EMP-JOB-LR LOGICAL RECORD IN VARIABLE STORAGE TO MAP * 00750 * FIELDS. * 00751 *************************************************************** 00752 GET-EMP. 00753 * MAP IN USING EMPMAPLR. :edisplay.
00754 MOVE 0011 TO DML-SEQUENCE DMLC0011 00755 MOVE 6 TO DCFLG1 00756 MOVE 0 TO DCFLG2 00757 MOVE 0 TO DCFLG3 00758 MOVE 0 TO DCFLG4 00759 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00760 DCBMSCOM (34) 00761 MRB-EMPMAPLR 00762 PERFORM IDMS-STATUS. 00763 * 00764 * INQUIRE MAP EMPMAPLR 00765 * MOVE AID TO DC-AID-IND-V. 00766 MOVE 0012 TO DML-SEQUENCE DMLC0012 00767 MOVE 7 TO DCNUM1 00768 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00769 DCBMSCOM (92) 00770 MRB-EMPMAPLR 00771 MOVE DCSTR2 TO DC-AID-IND-V 00772 PERFORM IDMS-STATUS. 00773 IF CLEAR-HIT 00774 * DC RETURN. 00775 MOVE 0013 TO DML-SEQUENCE DMLC0013 00776 MOVE 0 TO DCFLG1 00777 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00778 DCBMSCOM (19) 00779 PERFORM IDMS-STATUS. 00780 00781 * 00782 * INQUIRE MAP EMPMAPLR 00783 * IF DFLD EMP-ID-0415 EDIT IS ERROR 00784 MOVE 0014 TO DML-SEQUENCE DMLC0014 00785 MOVE 17 TO DCNUM1 00786 MOVE 5 TO DCNUM2
00787 MOVE 2048 TO DCFLG1 00788 MOVE 1 TO FLDLST (2) 00789 MOVE 1 TO FLDLST (1) 00790 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00791 DCBMSCOM (92) 00792 MRB-EMPMAPLR 00793 MRB-FLDLST; 00794 IF ERROR-STATUS EQUAL TO '4641' 00795 THEN GO TO EDIT-ERROR. 00796 * 00797 * COPY IDMS SUBSCHEMA-BINDS. 00798 MOVE 'EMPDISP ' TO PROGRAM-NAME 00799 * BIND RUN-UNIT. 00800 MOVE 0015 TO DML-SEQUENCE DMLC0015 00801 MOVE 576 TO LRC-LRPXELNG 00802 MOVE 6 TO LRC-MAXVXP 00803 MOVE 'LRF-BIND' TO LR-STATUS 00804 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00805 IDBMSCOM (59) 00806 SUBSCHEMA-CTRL 00807 SUBSCHEMA-SSNAME 00808 SUBSCHEMA-LR-CTRL 00809 PERFORM IDMS-STATUS. 00810 * READY USAGE-MODE IS RETRIEVAL. 00811 MOVE 0016 TO DML-SEQUENCE DMLC0016 00812 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00813 IDBMSCOM (37) 00814 PERFORM IDMS-STATUS.
00815 *************************************************************** 00816 * SINCE THE MAP FIELD IS ASSOCIATED WITH THE EMP-ID-0415 * 00817 * FIELD, THE PROGRAM USES THE "OF LR" RETRIEVAL. NOTE THAT * 00818 * AUTOSTATUS IMPLICITLY CHECKS FOR THE LR-ERROR PATH STATUS. * 00819 *************************************************************** 00820 * OBTAIN EMP-JOB-LR 00821 * WHERE EMP-ID-0415 = EMP-ID-0415 OF LR 00822 * ON LR-NOT-FOUND 00823 MOVE 0017 TO DML-SEQUENCE DMLC0017 00824 MOVE 0 TO LRC-LRPXELNG 00825 MOVE 0036 TO LRC-MAXVXP 00826 MOVE 'LR-ERROR' TO LR-STATUS 00827 MOVE 'OBTAIN N' TO LRVERB 00828 MOVE 'EMP-JOB-LR' TO LRNAME 00856 MOVE START-YEAR-0415 TO WORK-YY. 00857 MOVE START-MONTH-0415 TO WORK-MM. 00858 MOVE START-DAY-0415 TO WORK-DD. 00859 00860 * MAP OUT USING EMPMAPLR 00861 * OUTPUT DATA IS YES 00862 * MESSAGE IS DISPLAY-MESSAGE LENGTH 80. 00863 MOVE 0019 TO DML-SEQUENCE DMLC0019 00864 MOVE 5 TO DCFLG1 00865 MOVE 16 TO DCFLG2 00866 MOVE 0 TO DCFLG3 00867 MOVE 4 TO DCFLG4 00868 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00869 DCBMSCOM (34) 00870 MRB-EMPMAPLR 00871 DISPLAY-MESSAGE DCBMSCOM (80) 00872 PERFORM IDMS-STATUS.
00873 * 00874 * DC RETURN NEXT TASK CODE TSK02. 00875 MOVE 0020 TO DML-SEQUENCE DMLC0020 00876 MOVE TSK02 TO DCSTR2 00877 MOVE 128 TO DCFLG1 00878 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00879 DCBMSCOM (19) 00880 PERFORM IDMS-STATUS. 00881 GET-EMP-EXIT. 00882 EXIT. 00883 *************************************************************** 00884 *************************************************************** 00885 * THE MODIFY MAP STATEMENT SPECIFIES THAT ALL MAP * 00886 * FIELDS EXCEPT THE INCORRECT EMP-ID-0415 FIELD WILL BE * 00887 * ERASED ON THE NEXT MAP OUT. * 00888 *************************************************************** 00889 EDIT-ERROR. 00890 * MODIFY MAP EMPMAPLR TEMPORARY 00891 * FOR ALL EXCEPT DFLD EMP-ID-0415 00892 * OUTPUT DATA IS ERASE. 00893 MOVE 0021 TO DML-SEQUENCE DMLC0021 00894 MOVE 0 TO DCNUM1 00895 MOVE 2561 TO DCFLG1 00896 MOVE 16 TO DCFLG2 00897 MOVE 0 TO DCFLG3 00898 MOVE 0 TO DCFLG4 00899 MOVE 1 TO FLDLST (2) 00900 MOVE 1 TO FLDLST (1) 00901 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00902 DCBMSCOM (93) 00903 MRB-EMPMAPLR 00904 MRB-FLDLST 00905 PERFORM IDMS-STATUS.
00906 * 00907 * MAP OUT USING EMPMAPLR 00908 * MESSAGE IS EDIT-ERROR-MESSAGE LENGTH 80. 00909 MOVE 0022 TO DML-SEQUENCE DMLC0022 00910 MOVE 5 TO DCFLG1 00911 MOVE 0 TO DCFLG2 00912 MOVE 0 TO DCFLG3 00913 MOVE 4 TO DCFLG4 00914 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00915 DCBMSCOM (34) 00916 MRB-EMPMAPLR 00917 EDIT-ERROR-MESSAGE DCBMSCOM (80) 00918 PERFORM IDMS-STATUS. 00919 * 00920 * DC RETURN 00921 * NEXT TASK CODE TSK02. 00922 MOVE 0023 TO DML-SEQUENCE DMLC0023 00923 MOVE TSK02 TO DCSTR2 00924 MOVE 128 TO DCFLG1 00925 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00926 DCBMSCOM (19) 00927 PERFORM IDMS-STATUS. 00928 EDIT-ERROR-EXIT. 00929 EXIT. 00930 *************************************************************** 00931 *************************************************************** 00932 * THE FOLLOWING MODIFY MAP STATEMENT SPECIFIES THAT ALL * 00933 * MAP FIELDS EXCEPT THE EMP-ID-0415 FIELD WILL BE ERASED * 00934 * ON THE NEXT MAP OUT. * 00935 ***************************************************************
00936 NOT-FOUND. 00937 * MODIFY MAP EMPMAPLR TEMPORARY 00938 * FOR ALL EXCEPT DFLD EMP-ID-0415 00939 * OUTPUT DATA IS ERASE. 00940 MOVE 0024 TO DML-SEQUENCE DMLC0024 00941 MOVE 0 TO DCNUM1 00942 MOVE 2561 TO DCFLG1 00943 MOVE 16 TO DCFLG2 00944 MOVE 0 TO DCFLG3 00945 MOVE 0 TO DCFLG4 00946 MOVE 1 TO FLDLST (2) 00947 MOVE 1 TO FLDLST (1) 00948 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00949 DCBMSCOM (93) 00950 MRB-EMPMAPLR 00951 MRB-FLDLST 00952 PERFORM IDMS-STATUS. 00953 * 00954 * MAP OUT USING EMPMAPLR 00955 * MESSAGE IS EMP-NOT-FOUND-MESSAGE LENGTH 80. 00956 MOVE 0025 TO DML-SEQUENCE DMLC0025 00957 MOVE 5 TO DCFLG1 00958 MOVE 0 TO DCFLG2 00959 MOVE 0 TO DCFLG3 00960 MOVE 4 TO DCFLG4 00961 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00962 DCBMSCOM (34) 00963 MRB-EMPMAPLR 00964 EMP-NOT-FOUND-MESSAGE DCBMSCOM (80) 00965 PERFORM IDMS-STATUS.
00966 * 00967 * DC RETURN 00968 * NEXT TASK CODE TSK02. 00969 MOVE 0026 TO DML-SEQUENCE DMLC0026 00970 MOVE TSK02 TO DCSTR2 00971 MOVE 128 TO DCFLG1 00972 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00973 DCBMSCOM (19) 00974 PERFORM IDMS-STATUS. 00975 NOT-FOUND-EXIT. 00976 EXIT. 00977 *************************************************************** 00978 IDMS-ABORT. 00979 MOVE ERROR-STATUS TO SSC-ERRSTAT-SAVE. 00980 MOVE DML-SEQUENCE TO SSC-DMLSEQ-SAVE. 00981 * SNAP FROM SUBSCHEMA-LR-CTRL TO SUBSCHEMA-LR-CTRL-END 00982 * ON ANY-STATUS 00983 MOVE 0027 TO DML-SEQUENCE DMLC0027 00984 MOVE 0 TO DCFLG1 00985 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 00986 DCBMSCOM (22) 00987 DCSTR1 00988 DCSTR1 00989 DCSTR1 00990 SUBSCHEMA-LR-CTRL SUBSCHEMA-LR-CTRL-END DCBMSCOM (1) 00991 IF NOT ANY-STATUS PERFORM IDMS-STATUS; 00992 ELSE 00993 NEXT SENTENCE. 00994 MOVE SSC-ERRSTAT-SAVE TO ERROR-STATUS. 00995 MOVE SSC-DMLSEQ-SAVE TO DML-SEQUENCE. 00996 IDMS-ABORT-EXIT. 00997 EXIT. 00998 * COPY IDMS IDMS-STATUS.
00999 ******************************************************************01617000 01000 IDMS-STATUS SECTION.01618000 01001 ********************* IDMS-STATUS FOR IDMS-DC ********************01619000 01002 IF DB-STATUS-OK GO TO ISABEX. 01620000 01003 PERFORM IDMS-ABORT. 01621000 01004 MOVE ERROR-STATUS TO SSC-ERRSTAT-SAVE 01622000 01005 MOVE DML-SEQUENCE TO SSC-DMLSEQ-SAVE 01623000 01006 * SNAP FROM SUBSCHEMA-CTRL TO SUBSCHEMA-CTRL-END 01624000 01007 * ON ANY-STATUS 01625000 01008 MOVE 0028 TO DML-SEQUENCE DMLC0028 01009 MOVE 0 TO DCFLG1 01010 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 01011 DCBMSCOM (22) 01012 DCSTR1 01013 DCSTR1 01014 DCSTR1 01015 SUBSCHEMA-CTRL SUBSCHEMA-CTRL-END DCBMSCOM (1) 01016 IF NOT ANY-STATUS PERFORM IDMS-STATUS; 01017 ELSE 01018 NEXT SENTENCE. 01019 * ABEND CODE SSC-ERRSTAT-SAVE 01626000 01020 * ON ANY-STATUS 01627000 01021 MOVE 0029 TO DML-SEQUENCE DMLC0029 01022 MOVE SSC-ERRSTAT-SAVE TO DCSTR4 01023 MOVE 2 TO DCFLG1 01024 CALL 'IDMSCOBI' USING SUBSCHEMA-CTRL 01025 DCBMSCOM (1) 01026 IF NOT ANY-STATUS PERFORM IDMS-STATUS; 01027 ELSE 01028 NEXT SENTENCE. 01029 ISABEX. EXIT. 01628000
|
Copyright © 2014 CA.
All rights reserved.
|
|