In general, this cannot be done without having the data set layout available. For example, X'0097994D' could be treated as -97994 as a packed decimal number PIC S9(07) COMP-3, or as 9935181 as a binary number PIC S9(09) COMP, or as a LOW-VALUE followed by 'pr(' as a text value PIC X(04). The same 4 bytes but 3 very different interpretations (which depends upon the layout of the record).I am writing a tool to convert any raw cobol dataset to a readable form (Meaning upacked to Zoned).
COBOL file conversion to readable format
Re: COBOL file conversion to readable format
by Robert Sample » Mon Apr 17, 2017 6:43 pm
- Robert Sample
- Global moderator
- Posts: 3720
- Joined: Sat Dec 19, 2009 8:32 pm
- Location: Dubuque, Iowa, USA
- Has thanked: 1 time
- Been thanked: 279 times
Re: COBOL file conversion to readable format
by rakeshsneha1212 » Wed Apr 19, 2017 8:42 pm
Hi aki88,
Regarding your questions.
A) every time it's only one single dataset and it's corresponding copybook is used and should be converted so that it will easy for business to understand the data when they look at it.
I got a COBOL program which dynamically convert the any copy book layout to the CSV format and builds a SAS JCL as output which then need to submitted along with input dataset to get the corresponding CSV converted dataset and then put it into a excel which finishes the job of conversion and ready to be read easily on excel. unluckily this SAS not supported in our entity.
Now I'm stuck with SAS JCL which is built from the program.
Regarding your questions.
A) every time it's only one single dataset and it's corresponding copybook is used and should be converted so that it will easy for business to understand the data when they look at it.
I got a COBOL program which dynamically convert the any copy book layout to the CSV format and builds a SAS JCL as output which then need to submitted along with input dataset to get the corresponding CSV converted dataset and then put it into a excel which finishes the job of conversion and ready to be read easily on excel. unluckily this SAS not supported in our entity.
Now I'm stuck with SAS JCL which is built from the program.
- rakeshsneha1212
- Posts: 30
- Joined: Thu Mar 30, 2017 2:09 pm
- Has thanked: 5 times
- Been thanked: 0 time
Re: COBOL file conversion to readable format
by Aki88 » Thu Apr 20, 2017 2:27 am
Hello,
I am sorry, the site I've been working with over the years does not have SAS (I know it sounds lame; can't help it), so I won't be of much help here. Though if you post the SAS JCL I am sure the seniors on the forum will definitely be able to guide you; please also refer Mr. Sample's post, it gives some very important insights on data conversion.
Aside, since the SAS is simply being used for conversion, why not use REXX? Since we haven't seen the code, so my statement is pure conjecture; yet REXX is an option you can definitely look for; having said that, please do share the SAS code so that someone can guide you.
rakeshsneha1212 wrote:.... Now I'm stuck with SAS JCL which is built from the program.
I am sorry, the site I've been working with over the years does not have SAS (I know it sounds lame; can't help it), so I won't be of much help here. Though if you post the SAS JCL I am sure the seniors on the forum will definitely be able to guide you; please also refer Mr. Sample's post, it gives some very important insights on data conversion.
Aside, since the SAS is simply being used for conversion, why not use REXX? Since we haven't seen the code, so my statement is pure conjecture; yet REXX is an option you can definitely look for; having said that, please do share the SAS code so that someone can guide you.
Re: COBOL file conversion to readable format
by rakeshsneha1212 » Thu Apr 20, 2017 2:09 pm
Hi Aki88,
regarding your questions.
a) during run time it's only single dataset along with the CSV layout is used.
I have a cobol program which does below things :
1) taking COBOL copy book as input
2) build a SAS JCL with converting the COBOL copy book fields to subsequent SAS related fields (it take care of conversion here and all redefines).
3) We now give the COBOL dataset to the SAS JCL as input and submit it to get the CSV converted dataset as output.
But i'm facing problem in redefines as all the copy books here are majorily with redefining and COBOL program which is built (reading a copy book) is not able to recognise it correctly and building a wrong SAS JCL.
i can provide you the COBOL program which guves you better idea on this and also you can help me in analysing what can be changed to handle it correctly. Will send you the Code snippet separately.
regards,
Rakesh MS
regarding your questions.
a) during run time it's only single dataset along with the CSV layout is used.
I have a cobol program which does below things :
1) taking COBOL copy book as input
2) build a SAS JCL with converting the COBOL copy book fields to subsequent SAS related fields (it take care of conversion here and all redefines).
3) We now give the COBOL dataset to the SAS JCL as input and submit it to get the CSV converted dataset as output.
But i'm facing problem in redefines as all the copy books here are majorily with redefining and COBOL program which is built (reading a copy book) is not able to recognise it correctly and building a wrong SAS JCL.
i can provide you the COBOL program which guves you better idea on this and also you can help me in analysing what can be changed to handle it correctly. Will send you the Code snippet separately.
regards,
Rakesh MS
- rakeshsneha1212
- Posts: 30
- Joined: Thu Mar 30, 2017 2:09 pm
- Has thanked: 5 times
- Been thanked: 0 time
Re: COBOL file conversion to readable format
by Robert Sample » Thu Apr 20, 2017 5:04 pm
COB2SAS not handling multiple REDEFINES correctly is a known issue that goes back quite a few years. So I doubt you'll easily get a better solution from SAS. Your choices then become:
1. write your OWN modifications to COB2SAS to properly handle the copy book
2. add by hand the extra SAS variables that COB2SAS couldn't handle correctly
3. accept that what you want is not available and move on to a different project
1. write your OWN modifications to COB2SAS to properly handle the copy book
2. add by hand the extra SAS variables that COB2SAS couldn't handle correctly
3. accept that what you want is not available and move on to a different project
- Robert Sample
- Global moderator
- Posts: 3720
- Joined: Sat Dec 19, 2009 8:32 pm
- Location: Dubuque, Iowa, USA
- Has thanked: 1 time
- Been thanked: 279 times
Re: COBOL file conversion to readable format
by Aki88 » Thu Apr 20, 2017 5:10 pm
Hello,
In the PM you sent me, I could not find the attachment; I think the forum doesn't allow attachments in PM, haven't tried it, so am not very sure if they can be sent.
<Personal Opinion On>
Having said that, it is generally considered rude to send unsolicited PMs on a professional forum - unless you know the responder personally (in which case again it unto their discretion to read/respond to the PM).
It would do you tons of good if you pasted the relevant code here as a post, because it'd give others/experts data to understand the issue better and guide you. You can of course mask/edit/remove the site/business/proprietary specific code and share the remaining pieces; and we can definitely guide you.
</Personal Opinion Off>
In the PM you sent me, I could not find the attachment; I think the forum doesn't allow attachments in PM, haven't tried it, so am not very sure if they can be sent.
<Personal Opinion On>
Having said that, it is generally considered rude to send unsolicited PMs on a professional forum - unless you know the responder personally (in which case again it unto their discretion to read/respond to the PM).
It would do you tons of good if you pasted the relevant code here as a post, because it'd give others/experts data to understand the issue better and guide you. You can of course mask/edit/remove the site/business/proprietary specific code and share the remaining pieces; and we can definitely guide you.
</Personal Opinion Off>
Re: COBOL file conversion to readable format
by rakeshsneha1212 » Thu Apr 20, 2017 8:58 pm
Hi aki88,
Roger that !!
Here's code which converts the COBOL copy book to SAS.
Roger that !!
Here's code which converts the COBOL copy book to SAS.
*
******************************************************************
* *
******************************************************************
* PROGRAM FUNCTION *
* CONVERT/CREATE ROSCOE OFFSET RPF FOR SAS FIELD POSITIONS *
******************************************************************
* INPUT FILES : COPYBOOKS ICOPY *
* OUTPUT FILES : SAS LAYOUT SYSOUT *
*** *
******************************************************************
* VERSION NO : *
* MODIFIED BY : *
* MODIFIED ON : DD/MM/YYYY *
* SHARPOWL NUMBER : *
* SHARPOWL PROJECT : *
* MOD NUMBER : *
* COMMENTS : *
******************************************************************
*
ENVIRONMENT DIVISION.
*
CONFIGURATION SECTION.
*
INPUT-OUTPUT SECTION.
*
FILE-CONTROL.
*
*##############################################################
* FILE-CONTROL
*##############################################################
*
SELECT COPY-FILE
ASSIGN TO ICOPY
FILE STATUS IS WS-FS-ICOPY.
*
DATA DIVISION.
*
FILE SECTION.
*
*##############################################################
* FILE-SECTION
*##############################################################
*
FD COPY-FILE
BLOCK CONTAINS 0 RECORDS
LABEL RECORDS STANDARD
RECORDING MODE IS F.
01 ICOPY-REC PIC X(80).
*
WORKING-STORAGE SECTION.
*
*##############################################################
* WORKING STORAGE
*##############################################################
* FILE STATUS
*--------------------------------------------------------------
01 WS-FS-FILE-STATUS-VARS.
03 WS-FS-ICOPY PIC X(02).
88 ICOPY-OK VALUE '00'.
88 ICOPY-EOF VALUE '10'.
*
*--------------------------------------------------------------
* ARRAY STORAGE FOR DATA LINES FROM COPYBOOK
*--------------------------------------------------------------
01 ARRAY-ELEMENTS PIC 9999 VALUE ZERO.
01 ARRAY-ELEMENTS-D PIC 9999 VALUE ZERO.
01 WS-ARRAY.
02 ARRAY-DATA OCCURS 9999.
03 ARRAY-WHOLE-LINE PIC X(132).
03 ARRAY-LEVEL PIC 99.
03 ARRAY-DATA-FIELD PIC X.
03 ARRAY-SAS-NO PIC 9999.
03 ARRAY-FIELD-NAME PIC X(35).
03 ARRAY-REDEFINE-NAME PIC X(35).
03 ARRAY-REDEFINE PIC X.
03 ARRAY-FIELD-TYPE PIC X.
03 ARRAY-SIGNED PIC X.
03 ARRAY-WHOLE PIC 9999.
03 ARRAY-DECIMALS PIC 9999.
03 ARRAY-LENGTH PIC 9999.
03 ARRAY-START-POS PIC 9(5).
03 ARRAY-CUM PIC 9(5).
03 ARRAY-NO-OF-OCCURS PIC 9.
03 ARRAY-OCCURS-L1 PIC 999.
03 ARRAY-OCCURS-L2 PIC 999.
03 ARRAY-OCCURS-L3 PIC 999.
03 ARRAY-SAS-DATA PIC X(80).
*
*--------------------------------------------------------------
* ANALYSING VARIALBES / FLAGS
*--------------------------------------------------------------
01 WS-ANALYSING-VARIABLES.
03 DATA-LENGTH PIC 999.
03 TEMP-SAS-NAME PIC X(35).
03 COPY-REC PIC X(132).
03 TEMP-COPY-REC PIC X(66).
03 WS-DONE PIC X.
88 DONE VALUE 'Y'.
03 WS-TEMP-START PIC 9.
03 WS-START PIC 99999.
03 WS-END PIC 99999.
03 WS-LENGTH PIC 99999.
03 WS-TEMP.
05 WS-TEMP-NUMERIC PIC 9999.
*
03 WS-FIELD-NAME-POS-START PIC 999.
03 WS-FIELD-NAME-POS-END PIC 999.
03 WS-FIELD-NAME-FOUND PIC X.
88 FIELD-NAME-NOT-FOUND VALUE 'N'.
88 FIELD-NAME-FOUND VALUE 'Y'.
*
03 WS-LEVEL-POS PIC 999.
03 WS-LEVEL PIC 99.
03 WS-LEVEL-FOUND PIC X.
88 LEVEL-NOT-FOUND VALUE 'N'.
88 LEVEL-FOUND VALUE 'Y'.
*
03 WS-COMP-FOUND PIC X.
88 COMP-FOUND VALUE 'Y'.
88 COMP-NOT-FOUND VALUE 'N'.
03 WS-COMP-1-FOUND PIC X.
88 COMP-1-FOUND VALUE 'Y'.
88 COMP-1-NOT-FOUND VALUE 'N'.
03 WS-COMP-2-FOUND PIC X.
88 COMP-2-FOUND VALUE 'Y'.
88 COMP-2-NOT-FOUND VALUE 'N'.
03 WS-COMP-3-FOUND PIC X.
88 COMP-3-FOUND VALUE 'Y'.
88 COMP-3-NOT-FOUND VALUE 'N'.
*
03 WS-OCCURS-POS PIC 999.
03 WS-OCCURS-FOUND PIC X.
88 OCCURS-FOUND VALUE 'Y'.
*
03 WS-DISPLAY-FOUND PIC X.
88 DISPLAY-FOUND VALUE 'Y'.
*
03 WS-PLUS-FOUND PIC X.
88 PLUS-FOUND VALUE 'Y'.
*
03 WS-REDEFINES-NAME PIC X(35).
03 WS-REDEFINES-POS PIC 999.
03 WS-REDEFINES-LEVEL PIC 99 VALUE 99.
03 WS-REDEFINES-FOUND PIC X.
88 REDEFINES-FOUND VALUE 'Y'.
03 WS-REDEFINES-SET-START PIC 999999.
03 WS-REDEFINES-SET PIC X.
88 REDEFINES-SET VALUE 'Y'.
88 REDEFINES-NOT-SET VALUE 'Y'.
*
03 WS-FULLSTOP-FOUND PIC X.
88 FULLSTOP-FOUND VALUE 'Y'.
88 FULLSTOP-NOT-FOUND VALUE 'N'.
*
03 WS-DATA-FOUND PIC X.
88 DATA-FOUND VALUE 'Y'.
*
03 WS-FLAG-SET PIC X.
88 FLAG-SET VALUE 'Y'.
*
03 WS-PIC-POS PIC 999.
03 WS-PIC-FOUND PIC X VALUE 'N'.
88 PIC-NOT-FOUND VALUE 'N'.
88 PIC-FOUND VALUE 'Y'.
*
03 WS-SIGN-FOUND PIC X.
88 SIGN-FOUND VALUE 'Y'.
88 SIGN-NOT-FOUND VALUE 'N'.
*
03 WS-DECIMAL-POS PIC 9999.
03 WS-DECIMAL-PLACES PIC 9999.
03 WS-DECIMAL-FOUND PIC X.
88 DECIMAL-FOUND VALUE 'Y'.
88 DECIMAL-NOT-FOUND VALUE 'N'.
03 WS-NEGATIVE-FOUND PIC X.
88 NEGATIVE-FOUND VALUE 'Y'.
88 NEGATIVE-NOT-FOUND VALUE 'N'.
*
03 WS-CHARS PIC 9999.
03 WS-CHAR-POS PIC 999.
03 WS-CHAR-FOUND PIC X.
88 CHAR-FOUND VALUE 'Y'.
88 CHAR-NOT-FOUND VALUE 'N'.
*
03 WS-WHOLE PIC 9999.
03 WS-WHOLE-POS PIC 999.
03 WS-WHOLE-FOUND PIC X.
88 WHOLE-FOUND VALUE 'Y'.
88 WHOLE-NOT-FOUND VALUE 'N'.
*
03 WS-SUB PIC 9999.
03 WS-SUB2 PIC 9999.
03 WS-SUB3 PIC 9999.
03 WS-PROCESS PIC X.
88 PROCESS-COMPLETE VALUE 'Y'.
*
03 WS-OCCURS-VARS.
05 NO-OCCURS PIC 9.
05 O-TABLE OCCURS 3.
07 O-ARRAY-POS PIC 9999.
07 O-LEVEL PIC 999.
07 O-MAX PIC 999.
07 O-START PIC 9999.
07 O-END PIC 9999.
*
*--------------------------------------------------------------
* ABEND PROCESSING
*--------------------------------------------------------------
01 WS-MISCELLANEOUS.
03 WS-ABEND-CODE PIC 9(03) VALUE ZERO.
03 WS-ABEND-SEC PIC X(04) VALUE SPACES.
03 WS-DUMP-FLAG PIC X VALUE 'Y'.
*
*--------------------------------------------------------------
* ERROR MESSAGES
*--------------------------------------------------------------
01 WS-ERROR-FIELDS.
03 WS-FILE-STATUS PIC 9(02) VALUE ZERO.
03 WS-ERROR-CODE PIC 9(02) VALUE ZERO.
03 WS-ERROR-TEXTS.
05 FILLER PIC X(50) VALUE
01 '*** OPEN ERROR - INPUT COPYBOOK ***'.
05 FILLER PIC X(50) VALUE
02 '*** READ ERROR - EMPTY INPUT COPYBOOK ***'.
05 FILLER PIC X(50) VALUE
03 '*** READ ERROR - INPUT COPYBOOK ***'.
05 FILLER PIC X(50) VALUE
04 '*** CLOSE ERROR - INPUT COPYBOOK ***'.
03 FILLER REDEFINES WS-ERROR-TEXTS.
05 WS-ERROR-TEXT PIC X(50) OCCURS 4.
*
*--------------------------------------------------------------
* SAS REPORT HEADER LINES
*--------------------------------------------------------------
01 WS-SAS-HEADER-LINES.
02 WS-SAS-HEADER-1.
03 FILLER PIC X(80) VALUE
'//AH05T87* JOB (ZZZZ),''LM - K DESAI'','.
02 WS-SAS-HEADER-2.
03 FILLER PIC X(80) VALUE
'// CLASS=C,MSGCLASS=R,PRTY=00,REGION=4M'.
02 WS-SAS-HEADER-3.
03 FILLER PIC X(80) VALUE
'//*'.
02 WS-SAS-HEADER-3A.
03 FILLER PIC X(80) VALUE
'//**************************************************'.
02 WS-SAS-HEADER-3B.
03 FILLER PIC X(80) VALUE
'//******************* S A S ************************'.
02 WS-SAS-HEADER-3C.
03 FILLER PIC X(80) VALUE
'//* DATE :'.
02 WS-SAS-HEADER-3D.
03 FILLER PIC X(80) VALUE
'//* CR/QUERY CODE :'.
02 WS-SAS-HEADER-3E.
03 FILLER PIC X(80) VALUE
'//* DESCRIPTION :'.
02 WS-SAS-HEADER-3F.
03 FILLER PIC X(80) VALUE
'//**************************************************'.
02 WS-SAS-HEADER-3G.
03 FILLER PIC X(80) VALUE
'//*'.
02 WS-SAS-HEADER-4.
03 FILLER PIC X(80) VALUE
'//*MAIN CLASS=SAS'.
02 WS-SAS-HEADER-5.
03 FILLER PIC X(80) VALUE
'//*'.
02 WS-SAS-HEADER-6.
03 FILLER PIC X(80) VALUE
'//SASSTEP EXEC SAS,REGION=4096K'.
02 WS-SAS-HEADER-7.
03 FILLER PIC X(80) VALUE
'//WORK DD UNIT=SORT,SPACE=(CYL,(250,250))'.
02 WS-SAS-HEADER-8.
03 FILLER PIC X(80) VALUE
'//SASIN DD DSN=ENTER-INPUT-FILE-HERE,DISP=SHR'.
02 WS-SAS-HEADER-8A.
03 FILLER PIC X(80) VALUE
'//FT12F001 DD DSN=ENTER-OUT-FILE-HERE,'.
02 WS-SAS-HEADER-8B.
03 FILLER PIC X(80) VALUE
'// DISP=(NEW,CATLG,DELETE),'.
02 WS-SAS-HEADER-8C.
03 FILLER PIC X(80) VALUE
'// UNIT=3390,SPACE=(TRK,(1,1)),'.
02 WS-SAS-HEADER-8D.
03 FILLER PIC X(80) VALUE
'// DCB=(DSCB,RECFM=FB,LRECL=133)'.
02 WS-SAS-HEADER-8E.
03 FILLER PIC X(80) VALUE
'//*'.
02 WS-SAS-HEADER-9.
03 FILLER PIC X(80) VALUE
'//SYSIN DD *'.
02 WS-SAS-HEADER-10.
03 FILLER PIC X(80) VALUE
' OPTIONS DATE ;'.
02 WS-SAS-HEADER-11.
03 FILLER PIC X(80) VALUE
'DATA ;'.
02 WS-SAS-HEADER-12.
03 FILLER PIC X(80) VALUE
'INFILE SASIN END=_END MISSOVER ;'.
02 WS-SAS-HEADER-13.
03 FILLER PIC X(80) VALUE
' INPUT'.
*
*--------------------------------------------------------------
* SAS REPORT MID LINES
*--------------------------------------------------------------
01 WS-SAS-MIDDLE-1.
03 FILLER PIC X(30) VALUE ' ;'.
03 FILLER PIC X(50) VALUE
' /* << END OF ''INPUT'' STATEMENTS >> */'.
*
*--------------------------------------------------------------
* SAS REPORT FOOTER LINES
*--------------------------------------------------------------
01 WS-SAS-FOOTER-1.
03 FILLER PIC X(20) VALUE SPACES.
03 FILLER PIC X(60) VALUE
'/* << END OF ''LABEL'' STATEMENTS >> */'.
01 WS-SAS-FOOTER-2.
03 FILLER PIC X(80) VALUE ' _ERROR_=0;'.
01 WS-SAS-FOOTER-3.
03 FILLER PIC X(80) VALUE
' TITLE "SAS PRINT OF XXXXX " ;'.
01 WS-SAS-FOOTER-4.
03 FILLER PIC X(80) VALUE
'PROC PRINT LABEL ;'.
*
*--------------------------------------------------------------
* SAS REPORT LINES - 80 BYTES
*--------------------------------------------------------------
01 WS-SAS-DATA-LINES.
03 FILLER PIC X(3) VALUE ' @'.
03 SAS-START PIC 9(5).
03 FILLER PIC X(3) VALUE ' A'.
03 SAS-NUMBER PIC 9(4).
03 FILLER PIC X(3) VALUE SPACES.
03 SAS-TYPE PIC X(5).
03 SAS-LENGTH PIC 9(4).
03 FILLER PIC X(1) VALUE '.'.
03 SAS-DECIMALS.
05 SAS-DECIMALS-N PIC 9(2).
03 FILLER PIC X(5) VALUE ' /* '.
03 SAS-NAME.
05 FILLER PIC X(20).
05 SAS-OCCURS-1.
07 FILLER PIC X.
07 SAS-O1 PIC 999.
07 FILLER PIC X.
05 SAS-OCCURS-2.
07 FILLER PIC X.
07 SAS-O2 PIC 999.
07 FILLER PIC X.
05 SAS-OCCURS-3.
07 FILLER PIC X.
07 SAS-O3 PIC 999.
07 FILLER PIC X.
03 FILLER PIC X(5) VALUE '*/ '.
03 FILLER PIC X(5) VALUE SPACES.
*
01 WS-SAS-LABEL-LINES.
03 FILLER PIC X(12) VALUE ' LABEL A'.
03 LABEL-NUMBER PIC 9(4).
03 FILLER PIC X(8) VALUE ' = "'.
03 LABEL-NAME PIC X(35) VALUE SPACES.
03 FILLER PIC X(4) VALUE '" ;'.
03 FILLER PIC X(17) VALUE SPACES.
*
PROCEDURE DIVISION.
*
*##############################################################
* PROCEDURE DIVISION
*##############################################################
*
A000 SECTION.
***************************************************************
* PROGRAM CONTROL SECTION
***************************************************************
A000-START.
PERFORM B000-INITIALISE.
PERFORM C000-MAIN UNTIL ICOPY-EOF.
PERFORM D000-TERMINATE.
STOP RUN.
A000-EXIT.
EXIT.
*
B000-INITIALISE SECTION.
***************************************************************
* OPEN COPYBOOK
***************************************************************
B005-OPEN-COPYBOOK-FILE.
OPEN INPUT COPY-FILE.
IF NOT ICOPY-OK
MOVE WS-FS-ICOPY TO WS-FILE-STATUS
MOVE 1 TO WS-ERROR-CODE
MOVE 'B005' TO WS-ABEND-SEC
MOVE 001 TO WS-ABEND-CODE
PERFORM Z000-ABEND
END-IF.
*
B035-CHECK-COPYBOOK-FILE-EMPTY.
PERFORM R000-READ-COPYBOOK.
IF ICOPY-EOF
MOVE WS-FS-ICOPY TO WS-FILE-STATUS
MOVE 2 TO WS-ERROR-CODE
MOVE 'B035' TO WS-ABEND-SEC
MOVE 2 TO WS-ABEND-CODE
PERFORM Z000-ABEND
END-IF.
*
MOVE 'N' TO WS-PROCESS.
MOVE 0 TO NO-OCCURS.
*
B999-EXIT.
EXIT.
*
C000-MAIN SECTION.
***************************************************************
* MAIN PROCESSING SECTION
***************************************************************
*
C000-PROCESS-EXIT.
PERFORM UNTIL 'Y' = WS-PROCESS
* CHECK IF OCCURS BLOCK HAS COME TO AN END
IF NO-OCCURS > 0 THEN
IF O-LEVEL(NO-OCCURS) > WS-LEVEL
MOVE ARRAY-ELEMENTS TO O-END(NO-OCCURS)
PERFORM C400-POPULATE-ARRAY-OCCURS
GO TO C000-PROCESS-EXIT
END-IF
END-IF
* NEW OCCURS FOUND, ADD INFO ABOUT IT TO STORAGE ARRAY
IF OCCURS-FOUND AND PIC-NOT-FOUND THEN
IF NOT O-LEVEL(NO-OCCURS) = WS-LEVEL THEN
PERFORM C210-PROCESS-OCCURS
PERFORM C300-POPULATE-ARRAY
PERFORM R000-READ-COPYBOOK
GO TO C000-PROCESS-EXIT
END-IF
END-IF
* CHECK IF OCCURS & PIC CLAUSE ON SAME LINE = SINGLE DATA REPEATED
IF OCCURS-FOUND AND PIC-FOUND THEN
PERFORM C210-PROCESS-OCCURS
PERFORM C250-SCAN-PICTURE
PERFORM C300-POPULATE-ARRAY
ADD -1 TO O-START(NO-OCCURS)
MOVE O-START(NO-OCCURS) TO O-END(NO-OCCURS)
PERFORM C400-POPULATE-ARRAY-OCCURS
PERFORM R000-READ-COPYBOOK
GO TO C000-PROCESS-EXIT
END-IF
* CHECK IF REDEFINES AND PIC CLAUSE ON SAME LINE
IF REDEFINES-FOUND AND PIC-FOUND THEN
PERFORM C250-SCAN-PICTURE
PERFORM C270-PROCESS-REDEFINE
PERFORM C300-POPULATE-ARRAY
PERFORM R000-READ-COPYBOOK
GO TO C000-PROCESS-EXIT
END-IF
* PROCESS REDEFINE BLOCK
IF REDEFINES-FOUND AND PIC-NOT-FOUND THEN
PERFORM C270-PROCESS-REDEFINE
PERFORM C300-POPULATE-ARRAY
PERFORM R000-READ-COPYBOOK
GO TO C000-PROCESS-EXIT
END-IF
* PROCESS DATA LINE DEPENDANT ON WHEATHER INSIDE OCCURS BLOCK
EVALUATE NO-OCCURS
WHEN 0
PERFORM C250-SCAN-PICTURE
PERFORM C300-POPULATE-ARRAY
PERFORM R000-READ-COPYBOOK
WHEN OTHER
* STILL SCANING DOWN COPYBOOK WITHIN THIS BLOCK OCCURS
IF O-LEVEL(NO-OCCURS) < WS-LEVEL AND
WS-FS-ICOPY = '00' THEN
PERFORM C250-SCAN-PICTURE
PERFORM C300-POPULATE-ARRAY
PERFORM R000-READ-COPYBOOK
ELSE
* PROCESS 2+ OCCURS USING DATA IN TEMP ARRAY
MOVE ARRAY-ELEMENTS TO O-END(NO-OCCURS)
PERFORM C400-POPULATE-ARRAY-OCCURS
END-IF
END-EVALUATE
*
* CHECK IF EOF REACHED AND ALL OCCUR BLOCKS HAVE BEEN PROCESSED
IF NOT WS-FS-ICOPY = '00' AND NO-OCCURS = 0 THEN
MOVE 'Y' TO WS-PROCESS
END-IF
END-PERFORM.
*
C999-EXIT.
EXIT.
*
C010-INITIALISE-FLAGS SECTION.
***************************************************************
* RESET ALL FLAG READY FOR THE PROCESSING OF THE NEXT LINE
***************************************************************
*
MOVE 'N' TO WS-LEVEL-FOUND
WS-FIELD-NAME-FOUND
WS-LEVEL-FOUND
WS-COMP-FOUND
WS-COMP-1-FOUND
WS-COMP-2-FOUND
WS-COMP-3-FOUND
WS-OCCURS-FOUND
WS-REDEFINES-FOUND
WS-NEGATIVE-FOUND
WS-FULLSTOP-FOUND
WS-SIGN-FOUND
WS-PLUS-FOUND
WS-DISPLAY-FOUND
WS-DECIMAL-FOUND
WS-WHOLE-FOUND
WS-CHAR-FOUND
WS-PIC-FOUND.
MOVE ZEROS TO WS-DECIMAL-PLACES.
*
C019-EXIT.
EXIT.
*
C200-SCAN-FOR-KEYS SECTION.
***************************************************************
* SCAN LINE OF COPYBOOK FOR CERTAIN KEYS WORDS
***************************************************************
*
MOVE 66 TO DATA-LENGTH.
*
C200-BEGIN.
*
PERFORM VARYING WS-SUB FROM 1 BY 1 UNTIL WS-SUB > DATA-LENGTH
* CHECK FOR FULLSTOP
IF COPY-REC(WS-SUB:1) = '.' THEN
MOVE 'Y' TO WS-FULLSTOP-FOUND
END-IF
* CALCULATE FIELD NAME START POSITION
IF LEVEL-FOUND AND COPY-REC(WS-SUB:1) NOT = ' ' AND
WS-SUB > WS-FIELD-NAME-POS-START AND
FIELD-NAME-NOT-FOUND THEN
MOVE WS-SUB TO WS-FIELD-NAME-POS-START
MOVE 'Y' TO WS-FIELD-NAME-FOUND
END-IF
* CHECK FOR COPYBOOK LEVEL POSITION
IF COPY-REC(WS-SUB:1) IS NUMERIC AND LEVEL-NOT-FOUND THEN
MOVE WS-SUB TO WS-LEVEL-POS WS-FIELD-NAME-POS-START
MOVE COPY-REC(WS-LEVEL-POS:2) TO WS-LEVEL
ADD 2 TO WS-FIELD-NAME-POS-START
MOVE 'Y' TO WS-LEVEL-FOUND
END-IF
* CHECK FOR COPYBOOK OCCURS POSITION
IF COPY-REC(WS-SUB:6) = 'OCCURS' THEN
MOVE 'Y' TO WS-OCCURS-FOUND
MOVE WS-SUB TO WS-OCCURS-POS
ADD 7 TO WS-OCCURS-POS
END-IF
* CHECK FOR COPYBOOK PIC POSITION
IF COPY-REC(WS-SUB:3) = 'PIC' THEN
MOVE 'Y' TO WS-PIC-FOUND
MOVE WS-SUB TO WS-PIC-POS
ADD 4 TO WS-PIC-POS
END-IF
* CHECK FOR COPYBOOK REDEFINES POSITION
IF COPY-REC(WS-SUB:9) = 'REDEFINES' THEN
MOVE 'Y' TO WS-REDEFINES-FOUND
MOVE WS-SUB TO WS-REDEFINES-POS
ADD 10 TO WS-REDEFINES-POS
END-IF
END-PERFORM.
*
* HANDLING FOR DATA ON 2 LINES
IF FULLSTOP-NOT-FOUND THEN
MOVE COPY-REC(1:66) TO TEMP-COPY-REC
PERFORM R100-READ
MOVE COPY-REC(7:66) TO COPY-REC(67:66)
MOVE TEMP-COPY-REC TO COPY-REC(1:66)
MOVE 132 TO DATA-LENGTH
GO TO C200-BEGIN
END-IF.
*
C209-EXIT.
EXIT.
*
C210-PROCESS-OCCURS SECTION.
***************************************************************
* FIND OCCURS NUMBER
***************************************************************
*
ADD 1 TO NO-OCCURS.
MOVE ARRAY-ELEMENTS TO O-START(NO-OCCURS)
ADD 2 TO O-START(NO-OCCURS)
MOVE 'N' TO WS-FULLSTOP-FOUND.
MOVE WS-OCCURS-POS TO WS-START.
ADD -1 TO WS-START.
*
PERFORM VARYING WS-SUB FROM WS-OCCURS-POS BY 1
UNTIL FULLSTOP-FOUND
IF COPY-REC(WS-SUB:1) = '.' OR
COPY-REC(WS-SUB:1) = ' ' THEN
MOVE 'Y' TO WS-FULLSTOP-FOUND
MOVE WS-SUB TO WS-END
END-IF
END-PERFORM.
PERFORM C260-CALC-NUMERIC.
*
MOVE COPY-REC(WS-LEVEL-POS:2) TO O-LEVEL(NO-OCCURS).
MOVE WS-TEMP-NUMERIC TO O-MAX(NO-OCCURS).
*
C219-EXIT.
EXIT.
*
C250-SCAN-PICTURE SECTION.
***************************************************************
* SCAN AND BREAKDOWN PICTURE CLAUSE
***************************************************************
*
PERFORM VARYING WS-SUB FROM WS-PIC-POS BY 1 UNTIL
WS-SUB > DATA-LENGTH
EVALUATE TRUE
WHEN COPY-REC(WS-SUB:1) = 'S'
MOVE 'Y' TO WS-SIGN-FOUND
WHEN COPY-REC(WS-SUB:1) = '-' OR
COPY-REC(WS-SUB:1) = '+'
MOVE 'Y' TO WS-PLUS-FOUND
WHEN COPY-REC(WS-SUB:1) = '9' AND WHOLE-NOT-FOUND
MOVE 'Y' TO WS-WHOLE-FOUND
MOVE WS-SUB TO WS-WHOLE-POS
WHEN COPY-REC(WS-SUB:1) = 'X' AND CHAR-NOT-FOUND
MOVE 'Y' TO WS-CHAR-FOUND
MOVE WS-SUB TO WS-CHAR-POS
WHEN COPY-REC(WS-SUB:1) = 'V' AND DECIMAL-NOT-FOUND
MOVE 'Y' TO WS-DECIMAL-FOUND
MOVE WS-SUB TO WS-DECIMAL-POS
WHEN COPY-REC(WS-SUB:2) = '.9'
MOVE 'Y' TO WS-DECIMAL-FOUND
MOVE 'Y' TO WS-DISPLAY-FOUND
MOVE WS-SUB TO WS-DECIMAL-POS
WHEN COPY-REC(WS-SUB:1) = '-'
MOVE 'Y' TO WS-NEGATIVE-FOUND
WHEN COPY-REC(WS-SUB:4) = 'COMP'
IF COPY-REC(WS-SUB:5) = 'COMP ' OR
COPY-REC(WS-SUB:5) = 'COMP.' THEN
MOVE 'Y' TO WS-COMP-FOUND
END-IF
IF COPY-REC(WS-SUB:6) = 'COMP-1' THEN
MOVE 'Y' TO WS-COMP-1-FOUND
END-IF
IF COPY-REC(WS-SUB:6) = 'COMP-2' THEN
MOVE 'Y' TO WS-COMP-2-FOUND
END-IF
IF COPY-REC(WS-SUB:6) = 'COMP-3' THEN
MOVE 'Y' TO WS-COMP-3-FOUND
END-IF
END-EVALUATE
END-PERFORM.
*
* CALCULATE NUMBER OF DECIMAL PLACES
IF DECIMAL-FOUND THEN
MOVE ZERO TO WS-DECIMAL-PLACES WS-START WS-END
PERFORM VARYING WS-SUB FROM WS-DECIMAL-POS BY 1
UNTIL COPY-REC(WS-SUB:1) = ' '
IF COPY-REC(WS-SUB:1) = '9' AND WS-START = 0 THEN
ADD 1 TO WS-DECIMAL-PLACES
END-IF
IF COPY-REC(WS-SUB:1) = '(' THEN
MOVE WS-SUB TO WS-START
END-IF
IF COPY-REC(WS-SUB:1) = ')' THEN
MOVE WS-SUB TO WS-END
END-IF
END-PERFORM
IF WS-START > 0 AND WS-END > 0 THEN
PERFORM C260-CALC-NUMERIC
COMPUTE WS-DECIMAL-PLACES =
WS-TEMP-NUMERIC + WS-DECIMAL-PLACES - 1
END-IF
END-IF.
*
* CALCULATE NUMBER OF CHARACTERS
IF CHAR-FOUND THEN
MOVE ZERO TO WS-CHARS WS-START WS-END
PERFORM VARYING WS-SUB FROM WS-CHAR-POS BY 1
UNTIL COPY-REC(WS-SUB:1) = ' '
IF COPY-REC(WS-SUB:1) = 'X' AND WS-START = 0 THEN
ADD 1 TO WS-CHARS
END-IF
IF COPY-REC(WS-SUB:1) = '(' THEN
MOVE WS-SUB TO WS-START
END-IF
IF COPY-REC(WS-SUB:1) = ')' THEN
MOVE WS-SUB TO WS-END
END-IF
END-PERFORM
IF WS-START > 0 AND WS-END > 0 THEN
PERFORM C260-CALC-NUMERIC
COMPUTE WS-CHARS = WS-TEMP-NUMERIC + WS-CHARS - 1
END-IF
END-IF.
*
* CALCULATE NUMBER WHOLE DIGITS FOR NUMERICS
IF WHOLE-FOUND THEN
MOVE ZERO TO WS-WHOLE WS-START WS-END
PERFORM VARYING WS-SUB FROM WS-WHOLE-POS BY 1
UNTIL COPY-REC(WS-SUB:1) = ' '
OR COPY-REC(WS-SUB:1) = '.'
OR COPY-REC(WS-SUB:1) = 'V'
IF COPY-REC(WS-SUB:1) = '9' AND WS-START = 0 THEN
ADD 1 TO WS-WHOLE
END-IF
IF COPY-REC(WS-SUB:1) = '(' THEN
MOVE WS-SUB TO WS-START
END-IF
IF COPY-REC(WS-SUB:1) = ')' THEN
MOVE WS-SUB TO WS-END
END-IF
END-PERFORM
IF WS-START > 0 AND WS-END > 0 THEN
PERFORM C260-CALC-NUMERIC
COMPUTE WS-WHOLE = WS-TEMP-NUMERIC + WS-WHOLE - 1
END-IF
END-IF.
*
C259-EXIT.
EXIT.
*
C260-CALC-NUMERIC SECTION.
***************************************************************
* CALCULATES THE NUMERIC WITHIN BRACKETS AND POSITION OF THEM
***************************************************************
*
ADD 1 TO WS-START.
MOVE ZERO TO WS-TEMP-NUMERIC.
COMPUTE WS-LENGTH = WS-END - WS-START.
COMPUTE WS-TEMP-START = 4 - WS-LENGTH + 1.
MOVE COPY-REC(WS-START:WS-LENGTH) TO
WS-TEMP(WS-TEMP-START:WS-LENGTH).
COMPUTE WS-TEMP-START = 4 - WS-LENGTH
PERFORM VARYING WS-SUB FROM 1 BY 1
UNTIL WS-SUB > WS-TEMP-START
MOVE '0' TO WS-TEMP-START(WS-SUB:1)
END-PERFORM.
*
C269-EXIT.
EXIT.
*
C270-PROCESS-REDEFINE SECTION.
***************************************************************
* FIND REDEFINE DATA
***************************************************************
*
* FIND START OF REDEFINE FIELD NAME
MOVE 'N' TO WS-FULLSTOP-FOUND.
PERFORM VARYING WS-SUB FROM WS-REDEFINES-POS BY 1
UNTIL FULLSTOP-FOUND
IF NOT COPY-REC(WS-SUB:1) = ' ' THEN
MOVE 'Y' TO WS-FULLSTOP-FOUND
MOVE WS-SUB TO WS-START
END-IF
END-PERFORM.
*
MOVE 'N' TO WS-FULLSTOP-FOUND.
PERFORM VARYING WS-SUB FROM WS-START BY 1
UNTIL FULLSTOP-FOUND
IF COPY-REC(WS-SUB:1) = '.' OR
COPY-REC(WS-SUB:1) = ' ' THEN
MOVE 'Y' TO WS-FULLSTOP-FOUND
MOVE WS-SUB TO WS-END
END-IF
END-PERFORM.
*
COMPUTE WS-LENGTH = WS-END - WS-START.
MOVE COPY-REC(WS-START:WS-LENGTH) TO WS-REDEFINES-NAME.
*
C279-EXIT.
EXIT.
*
C300-POPULATE-ARRAY SECTION.
***************************************************************
* POPULATE COMPONENTS OF THE DATA LINE
***************************************************************
*
* INCREASE NUMBER OF ELEMENTS BY 1
ADD 1 TO ARRAY-ELEMENTS.
INITIALIZE ARRAY-DATA(ARRAY-ELEMENTS).
* POPULATE WHOLE DATA LINE
MOVE COPY-REC TO ARRAY-WHOLE-LINE(ARRAY-ELEMENTS)
* POPULATE LEVEL OF COPYBOOK DATA ITEM
MOVE COPY-REC(WS-LEVEL-POS:2) TO
ARRAY-LEVEL(ARRAY-ELEMENTS).
* POPULATE NUMBER WHOLE DIGITS FOR NUMERICS
MOVE WS-WHOLE TO ARRAY-WHOLE(ARRAY-ELEMENTS).
* POPULATE NUMBER OF DECIMAL PLACES
MOVE WS-DECIMAL-PLACES TO ARRAY-DECIMALS(ARRAY-ELEMENTS).
* POPULATE NUMBER CHARACTERS
IF CHAR-FOUND THEN
MOVE WS-CHARS TO ARRAY-LENGTH(ARRAY-ELEMENTS)
END-IF.
* POPULATE ZONED DECIMAL
IF CHAR-NOT-FOUND AND COMP-NOT-FOUND AND COMP-1-NOT-FOUND AND
COMP-2-NOT-FOUND AND COMP-3-NOT-FOUND THEN
COMPUTE ARRAY-LENGTH(ARRAY-ELEMENTS) =
WS-WHOLE + WS-DECIMAL-PLACES
END-IF.
* POPULATE DISPLAY NUMERIC LENGTH
IF DISPLAY-FOUND THEN
COMPUTE ARRAY-LENGTH(ARRAY-ELEMENTS) =
WS-WHOLE + WS-DECIMAL-PLACES + 1
END-IF.
IF PLUS-FOUND THEN
ADD 1 TO ARRAY-LENGTH(ARRAY-ELEMENTS)
END-IF.
* POPULATE LENGTH OF BYTES REQUIRED OF PACKED NUMERIC COMP
IF COMP-FOUND THEN
MOVE WS-DECIMAL-PLACES TO WS-TEMP-NUMERIC
ADD WS-WHOLE TO WS-TEMP-NUMERIC
COMPUTE WS-TEMP-NUMERIC = (WS-TEMP-NUMERIC / 2)
MOVE WS-TEMP-NUMERIC TO ARRAY-LENGTH(ARRAY-ELEMENTS)
END-IF.
* POPULATE LENGTH OF BYTES REQUIRED OF PACKED NUMERIC COMP-3
IF COMP-3-FOUND THEN
MOVE WS-DECIMAL-PLACES TO WS-TEMP-NUMERIC
ADD WS-WHOLE TO WS-TEMP-NUMERIC
COMPUTE WS-TEMP-NUMERIC = WS-TEMP-NUMERIC / 2
ADD 1 TO WS-TEMP-NUMERIC
MOVE WS-TEMP-NUMERIC TO ARRAY-LENGTH(ARRAY-ELEMENTS)
END-IF.
* POPULATE TYPE OF DATA
EVALUATE TRUE
WHEN COMP-FOUND
MOVE 'A' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
WHEN COMP-1-FOUND
MOVE 'B' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
WHEN COMP-2-FOUND
MOVE 'C' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
WHEN COMP-3-FOUND
MOVE 'D' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
WHEN DISPLAY-FOUND
MOVE 'E' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
WHEN CHAR-FOUND
MOVE 'X' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
WHEN OTHER
MOVE 'Y' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
END-EVALUATE.
* POPULATE FLAG TO SHOW IF COPYBOOK LINE CONTAINS A PIC CLAUSE
IF PIC-FOUND THEN
MOVE 'Y' TO ARRAY-DATA-FIELD(ARRAY-ELEMENTS)
ADD 1 TO ARRAY-ELEMENTS-D
MOVE ARRAY-ELEMENTS-D TO ARRAY-SAS-NO(ARRAY-ELEMENTS)
ELSE
MOVE 'N' TO ARRAY-DATA-FIELD(ARRAY-ELEMENTS)
END-IF.
* POPULATE FLAG TO SHOW IF NUMERIC IS SIGNED
IF SIGN-FOUND THEN
MOVE 'Y' TO ARRAY-SIGNED(ARRAY-ELEMENTS)
ELSE
MOVE 'N' TO ARRAY-SIGNED(ARRAY-ELEMENTS)
END-IF.
* POPULATE FLAG TO SHOW REDEFINE FOUND
IF REDEFINES-FOUND THEN
MOVE 'Y' TO ARRAY-REDEFINE(ARRAY-ELEMENTS)
MOVE WS-REDEFINES-NAME TO
ARRAY-REDEFINE-NAME(ARRAY-ELEMENTS)
MOVE WS-LEVEL TO WS-REDEFINES-LEVEL
ELSE
MOVE 'N' TO ARRAY-REDEFINE(ARRAY-ELEMENTS)
MOVE 99 TO WS-REDEFINES-LEVEL
END-IF.
* POPULATE FIELD NAME OF COPYBOOK
MOVE 'N' TO WS-DONE.
PERFORM VARYING WS-SUB FROM WS-FIELD-NAME-POS-START BY 1
UNTIL DONE
IF COPY-REC(WS-SUB:1) = SPACE OR
COPY-REC(WS-SUB:1) = '.' THEN
MOVE WS-SUB TO WS-FIELD-NAME-POS-END
MOVE 'Y' TO WS-DONE
END-IF
END-PERFORM.
COMPUTE WS-FIELD-NAME-POS-END =
WS-FIELD-NAME-POS-END - WS-FIELD-NAME-POS-START.
MOVE COPY-REC(WS-FIELD-NAME-POS-START:WS-FIELD-NAME-POS-END)
TO ARRAY-FIELD-NAME(ARRAY-ELEMENTS).
* POPULATE OCCURS FIELDS
MOVE NO-OCCURS TO
ARRAY-NO-OF-OCCURS(ARRAY-ELEMENTS).
EVALUATE NO-OCCURS
WHEN 1
MOVE 1 TO ARRAY-OCCURS-L1(ARRAY-ELEMENTS)
MOVE ZERO TO ARRAY-OCCURS-L2(ARRAY-ELEMENTS)
ARRAY-OCCURS-L3(ARRAY-ELEMENTS)
WHEN 2
MOVE 1 TO ARRAY-OCCURS-L1(ARRAY-ELEMENTS)
ARRAY-OCCURS-L2(ARRAY-ELEMENTS)
MOVE ZERO TO ARRAY-OCCURS-L3(ARRAY-ELEMENTS)
WHEN 3
MOVE 1 TO ARRAY-OCCURS-L1(ARRAY-ELEMENTS)
ARRAY-OCCURS-L2(ARRAY-ELEMENTS)
ARRAY-OCCURS-L3(ARRAY-ELEMENTS)
END-EVALUATE.
* CORRECT IF DISPLAY SIGN FOUND
IF NEGATIVE-FOUND THEN
ADD 1 TO ARRAY-LENGTH(ARRAY-ELEMENTS)
END-IF.
*
C399-EXIT.
EXIT.
*
C400-POPULATE-ARRAY-OCCURS SECTION.
***************************************************************
* PROCESS DATA HELD WITHIN ARRAY FOR OCCURS
***************************************************************
*
* PROCESS 2ND+ OCCURS
PERFORM VARYING WS-SUB FROM 2
BY 1 UNTIL WS-SUB > O-MAX(NO-OCCURS)
* PROCESS ITEMS WITHIN OCCURS
PERFORM VARYING WS-SUB2 FROM O-START(NO-OCCURS)
BY 1 UNTIL WS-SUB2 > O-END(NO-OCCURS)
ADD 1 TO ARRAY-ELEMENTS
MOVE ARRAY-DATA(WS-SUB2) TO
ARRAY-DATA(ARRAY-ELEMENTS)
KDD IF ARRAY-DATA-FIELD(WS-SUB2) = 'Y' THEN
ADD 1 TO ARRAY-ELEMENTS-D
MOVE ARRAY-ELEMENTS-D TO
ARRAY-SAS-NO(ARRAY-ELEMENTS)
END-IF
EVALUATE NO-OCCURS
WHEN 1 MOVE WS-SUB TO
ARRAY-OCCURS-L1(ARRAY-ELEMENTS)
WHEN 2 MOVE WS-SUB TO
ARRAY-OCCURS-L2(ARRAY-ELEMENTS)
WHEN 3 MOVE WS-SUB TO
ARRAY-OCCURS-L3(ARRAY-ELEMENTS)
WHEN OTHER
EXIT
END-EVALUATE
END-PERFORM
END-PERFORM.
ADD -1 TO NO-OCCURS.
*
C499-EXIT.
EXIT.
*
C500-CALC-OFFSETS SECTION.
***************************************************************
* CALCULATE OFFSETS SETS AND CUM LENGTH
***************************************************************
*
MOVE ZERO TO WS-LENGTH.
MOVE 'N' TO WS-REDEFINES-SET.
MOVE 1 TO WS-START.
PERFORM VARYING WS-SUB FROM 1 BY 1
UNTIL WS-SUB > ARRAY-ELEMENTS
IF ARRAY-REDEFINE(WS-SUB) = 'Y' THEN
MOVE 'N' TO WS-DATA-FOUND WS-FLAG-SET
WS-REDEFINES-SET
*---------- FIND ARRAY POSITION WHERE REDEFINE FIELD SITS -----
PERFORM VARYING WS-SUB2 FROM 1 BY 1
UNTIL WS-SUB2 > ARRAY-ELEMENTS OR DATA-FOUND
IF ARRAY-FIELD-NAME(WS-SUB2) =
ARRAY-REDEFINE-NAME(WS-SUB) AND
ARRAY-LEVEL(WS-SUB) =
ARRAY-LEVEL(WS-SUB2) THEN
*----------------- FIND START OF 1ST REDEFINE DATA LINE
PERFORM VARYING WS-SUB3 FROM WS-SUB2 BY 1
UNTIL FLAG-SET AND
ARRAY-DATA-FIELD(WS-SUB3) = 'Y'
IF ARRAY-DATA-FIELD(WS-SUB3) = 'Y' AND
ARRAY-OCCURS-L1(WS-SUB3) =
ARRAY-OCCURS-L1(WS-SUB) AND
ARRAY-OCCURS-L2(WS-SUB3) =
ARRAY-OCCURS-L2(WS-SUB) AND
ARRAY-OCCURS-L3(WS-SUB3) =
ARRAY-OCCURS-L3(WS-SUB) THEN
MOVE 'Y' TO WS-FLAG-SET
WS-DATA-FOUND
WS-REDEFINES-SET
IF WS-SUB2 = WS-SUB3 THEN
MOVE 'N' TO WS-REDEFINES-SET
END-IF
COMPUTE WS-REDEFINES-SET-START =
ARRAY-CUM(WS-SUB3) + 1 -
ARRAY-LENGTH(WS-SUB3)
MOVE ARRAY-START-POS(WS-SUB3) TO
ARRAY-START-POS(WS-SUB)
END-IF
END-PERFORM
*-----------------------------------------------------
END-IF
END-PERFORM
*--------------------------------------------------------------
ELSE
IF ARRAY-DATA-FIELD(WS-SUB) = 'Y' AND
REDEFINES-SET THEN
MOVE 'N' TO WS-REDEFINES-SET
MOVE WS-REDEFINES-SET-START TO
ARRAY-START-POS(WS-SUB)
WS-LENGTH
ADD ARRAY-LENGTH(WS-SUB) TO WS-LENGTH
ADD -1 TO WS-LENGTH
MOVE WS-LENGTH TO ARRAY-CUM(WS-SUB)
COMPUTE WS-START = WS-REDEFINES-SET-START +
ARRAY-LENGTH(WS-SUB)
ELSE
IF ARRAY-LEVEL(WS-SUB) = '01' THEN
MOVE 1 TO WS-START
MOVE ZERO TO WS-LENGTH
END-IF
IF ARRAY-DATA-FIELD(WS-SUB) = 'Y' THEN
ADD ARRAY-LENGTH(WS-SUB) TO WS-LENGTH
MOVE WS-LENGTH TO ARRAY-CUM(WS-SUB)
MOVE WS-START TO ARRAY-START-POS(WS-SUB)
ADD ARRAY-LENGTH(WS-SUB) TO WS-START
END-IF
END-IF
END-IF
END-PERFORM.
*
C599-EXIT.
EXIT.
*
C600-CREATE-SAS SECTION.
***************************************************************
*
***************************************************************
*
* PRINT SAS HEADER LINES
DISPLAY WS-SAS-HEADER-1.
DISPLAY WS-SAS-HEADER-2.
DISPLAY WS-SAS-HEADER-3.
DISPLAY WS-SAS-HEADER-3A.
DISPLAY WS-SAS-HEADER-3B.
DISPLAY WS-SAS-HEADER-3C.
DISPLAY WS-SAS-HEADER-3D.
DISPLAY WS-SAS-HEADER-3E.
DISPLAY WS-SAS-HEADER-3F.
DISPLAY WS-SAS-HEADER-3G.
DISPLAY WS-SAS-HEADER-4.
DISPLAY WS-SAS-HEADER-5.
DISPLAY WS-SAS-HEADER-6.
DISPLAY WS-SAS-HEADER-7.
DISPLAY WS-SAS-HEADER-8.
DISPLAY WS-SAS-HEADER-8A.
DISPLAY WS-SAS-HEADER-8B.
DISPLAY WS-SAS-HEADER-8C.
DISPLAY WS-SAS-HEADER-8D.
DISPLAY WS-SAS-HEADER-8E.
DISPLAY WS-SAS-HEADER-9.
DISPLAY WS-SAS-HEADER-10.
DISPLAY WS-SAS-HEADER-11.
DISPLAY WS-SAS-HEADER-12.
DISPLAY WS-SAS-HEADER-13.
* PRINT SAS DATA LINES
PERFORM VARYING WS-SUB FROM 1 BY 1
UNTIL WS-SUB > ARRAY-ELEMENTS
IF ARRAY-DATA-FIELD(WS-SUB) = 'Y' THEN
INITIALIZE WS-SAS-DATA-LINES
MOVE ARRAY-START-POS(WS-SUB) TO SAS-START
MOVE ARRAY-SAS-NO(WS-SUB) TO SAS-NUMBER
IF ARRAY-DECIMALS(WS-SUB) > 0 AND
NOT ARRAY-FIELD-TYPE(WS-SUB) = 'E' THEN
MOVE ARRAY-DECIMALS(WS-SUB) TO SAS-DECIMALS-N
ELSE
MOVE SPACES TO SAS-DECIMALS
END-IF
MOVE ARRAY-LENGTH(WS-SUB) TO SAS-LENGTH
EVALUATE ARRAY-FIELD-TYPE(WS-SUB)
WHEN 'E'
MOVE '£CHAR' TO SAS-TYPE
WHEN 'X'
MOVE '£CHAR' TO SAS-TYPE
WHEN 'Y'
MOVE ' ZD' TO SAS-TYPE
WHEN OTHER
MOVE ' PD' TO SAS-TYPE
END-EVALUATE
MOVE ARRAY-FIELD-NAME(WS-SUB) TO SAS-NAME
* MOVING OCCUR NUMBERS
EVALUATE ARRAY-NO-OF-OCCURS(WS-SUB)
WHEN 1
MOVE '( )' TO SAS-OCCURS-3
MOVE ARRAY-OCCURS-L1(WS-SUB) TO SAS-O3
WHEN 2
MOVE '( )' TO SAS-OCCURS-2
SAS-OCCURS-3
MOVE ARRAY-OCCURS-L1(WS-SUB) TO SAS-O2
MOVE ARRAY-OCCURS-L2(WS-SUB) TO SAS-O3
WHEN 3
MOVE '( )' TO SAS-OCCURS-1
SAS-OCCURS-2
SAS-OCCURS-3
MOVE ARRAY-OCCURS-L1(WS-SUB) TO SAS-O1
MOVE ARRAY-OCCURS-L2(WS-SUB) TO SAS-O2
MOVE ARRAY-OCCURS-L3(WS-SUB) TO SAS-O3
WHEN OTHER
EXIT
END-EVALUATE
MOVE SAS-NAME TO ARRAY-SAS-DATA(WS-SUB)
DISPLAY WS-SAS-DATA-LINES
END-IF
END-PERFORM.
*
* PRINT SAS MIDDLE LINES
DISPLAY WS-SAS-MIDDLE-1.
*
* PRINT SAS LABEL LINES
PERFORM VARYING WS-SUB FROM 1 BY 1
UNTIL WS-SUB > ARRAY-ELEMENTS
IF ARRAY-DATA-FIELD(WS-SUB) = 'Y' THEN
INITIALIZE WS-SAS-LABEL-LINES
* REMOVE SPACES AND '-'
MOVE ARRAY-SAS-DATA(WS-SUB) TO TEMP-SAS-NAME
PERFORM VARYING WS-SUB2 FROM 1 BY 1
UNTIL WS-SUB2 > 35
IF TEMP-SAS-NAME(WS-SUB2:1) = '-' THEN
MOVE ' ' TO LABEL-NAME(WS-SUB2:1)
ELSE
MOVE TEMP-SAS-NAME(WS-SUB2:1) TO
LABEL-NAME(WS-SUB2:1)
END-IF
END-PERFORM
MOVE ARRAY-SAS-NO(WS-SUB) TO LABEL-NUMBER
DISPLAY WS-SAS-LABEL-LINES
END-IF
END-PERFORM.
*
* PRINT SAS FOOTER LINES
DISPLAY WS-SAS-FOOTER-1.
DISPLAY WS-SAS-FOOTER-2.
DISPLAY WS-SAS-FOOTER-3.
DISPLAY WS-SAS-FOOTER-4.
*
C699-EXIT.
EXIT.
*
D000-TERMINATE SECTION.
***************************************************************
* TERMINATION SECTION
***************************************************************
*
PERFORM C500-CALC-OFFSETS.
PERFORM C600-CREATE-SAS.
*
KDD *-------------------------
KDD * ARRAY DEBUGGING DISPLAYS
KDD *-------------------------
KDD * PERFORM VARYING WS-SUB FROM 1 BY 1
KDD * UNTIL WS-SUB > ARRAY-ELEMENTS
KDD * IF ARRAY-DATA-FIELD(WS-SUB) = 'Y' THEN
KDD * DISPLAY '-------------' WS-SUB ' --------------------'
KDD * DISPLAY ARRAY-WHOLE-LINE(WS-SUB)
KDD * DISPLAY 'LEVEL # ' ARRAY-LEVEL(WS-SUB)
KDD * ' DATA Y/N # ' ARRAY-DATA-FIELD(WS-SUB)
KDD * ' SAS NO # ' ARRAY-SAS-NO(WS-SUB)
KDD * DISPLAY 'FIELD NAME # ' ARRAY-FIELD-NAME(WS-SUB)
KDD * DISPLAY 'REDEFINE Y/N # ' ARRAY-REDEFINE(WS-SUB)
KDD * ' REDEF NAME # ' ARRAY-REDEFINE-NAME(WS-SUB)
KDD * DISPLAY 'FIELD TYPE # ' ARRAY-FIELD-TYPE(WS-SUB)
KDD * ' SIGNED # ' ARRAY-SIGNED(WS-SUB)
KDD * ' WHOLE # ' ARRAY-WHOLE(WS-SUB)
KDD * ' DECIMALS # ' ARRAY-DECIMALS(WS-SUB)
KDD * ' LENGTH # ' ARRAY-LENGTH(WS-SUB)
KDD * DISPLAY 'START POS # ' ARRAY-START-POS(WS-SUB)
KDD * ' CUM POS # ' ARRAY-CUM(WS-SUB)
KDD * DISPLAY 'NO OF OCCURS # ' ARRAY-NO-OF-OCCURS(WS-SUB)
KDD * ' OCCURS 1 2 3 # ' ARRAY-OCCURS-L1(WS-SUB) ' '
KDD * ARRAY-OCCURS-L2(WS-SUB) ' '
KDD * ARRAY-OCCURS-L3(WS-SUB) ' '
KDD * END-IF
KDD * END-PERFORM.
*
D005-CLOSE-COPYBOOK-FILE.
CLOSE COPY-FILE.
IF NOT ICOPY-OK
MOVE WS-FS-ICOPY TO WS-FILE-STATUS
MOVE 06 TO WS-ERROR-CODE
MOVE 'D005' TO WS-ABEND-SEC
MOVE 006 TO WS-ABEND-CODE
PERFORM Z000-ABEND
END-IF.
*
D999-EXIT.
EXIT.
*
R000-READ-COPYBOOK SECTION.
***************************************************************
* READ COPYBOOK
***************************************************************
*
MOVE 'N' TO WS-DATA-FOUND.
PERFORM UNTIL NOT WS-FS-ICOPY = '00' OR WS-DATA-FOUND = 'Y'
IF WS-FS-ICOPY = '00' THEN
PERFORM R100-READ
IF WS-FS-ICOPY = '00' THEN
IF COPY-REC(1:1) NOT = '*' AND
COPY-REC NOT = SPACES THEN
PERFORM C010-INITIALISE-FLAGS
PERFORM C200-SCAN-FOR-KEYS
MOVE 'Y' TO WS-DATA-FOUND
END-IF
END-IF
END-IF
END-PERFORM.
R999-EXIT.
EXIT.
*
R100-READ SECTION.
READ COPY-FILE.
MOVE SPACES TO COPY-REC.
MOVE ICOPY-REC(7:66) TO COPY-REC(1:66).
EXIT.
*
Z000-ABEND SECTION.
***************************************************************
* THIS IS THE ERROR HANDLER.
***************************************************************
DISPLAY '*************************************************'.
DISPLAY '*************************************************'.
DISPLAY '*** ***'.
DISPLAY '*** ABEND IN PARA ' WS-ABEND-SEC
' ***'.
DISPLAY '*** ***'.
DISPLAY '*** PROGRAM ZB**** IS ABENDING ***'.
DISPLAY '*** ***'.
DISPLAY WS-ERROR-TEXT (WS-ERROR-CODE).
DISPLAY '*** ***'.
IF WS-FILE-STATUS > ZEROES
DISPLAY '*** FILE STATUS : ' WS-FILE-STATUS
' ***'
END-IF.
DISPLAY '*** ***'.
DISPLAY '*** PROGRAM ZB**** IS ABENDING ***'.
DISPLAY '*** ***'.
DISPLAY '*************************************************'.
DISPLAY '*************************************************'.
CALL 'ABEND' USING WS-ABEND-CODE WS-DUMP-FLAG.
Z099-EXIT.
EXIT.
******************************************************************
* *
******************************************************************
* PROGRAM FUNCTION *
* CONVERT/CREATE ROSCOE OFFSET RPF FOR SAS FIELD POSITIONS *
******************************************************************
* INPUT FILES : COPYBOOKS ICOPY *
* OUTPUT FILES : SAS LAYOUT SYSOUT *
*** *
******************************************************************
* VERSION NO : *
* MODIFIED BY : *
* MODIFIED ON : DD/MM/YYYY *
* SHARPOWL NUMBER : *
* SHARPOWL PROJECT : *
* MOD NUMBER : *
* COMMENTS : *
******************************************************************
*
ENVIRONMENT DIVISION.
*
CONFIGURATION SECTION.
*
INPUT-OUTPUT SECTION.
*
FILE-CONTROL.
*
*##############################################################
* FILE-CONTROL
*##############################################################
*
SELECT COPY-FILE
ASSIGN TO ICOPY
FILE STATUS IS WS-FS-ICOPY.
*
DATA DIVISION.
*
FILE SECTION.
*
*##############################################################
* FILE-SECTION
*##############################################################
*
FD COPY-FILE
BLOCK CONTAINS 0 RECORDS
LABEL RECORDS STANDARD
RECORDING MODE IS F.
01 ICOPY-REC PIC X(80).
*
WORKING-STORAGE SECTION.
*
*##############################################################
* WORKING STORAGE
*##############################################################
* FILE STATUS
*--------------------------------------------------------------
01 WS-FS-FILE-STATUS-VARS.
03 WS-FS-ICOPY PIC X(02).
88 ICOPY-OK VALUE '00'.
88 ICOPY-EOF VALUE '10'.
*
*--------------------------------------------------------------
* ARRAY STORAGE FOR DATA LINES FROM COPYBOOK
*--------------------------------------------------------------
01 ARRAY-ELEMENTS PIC 9999 VALUE ZERO.
01 ARRAY-ELEMENTS-D PIC 9999 VALUE ZERO.
01 WS-ARRAY.
02 ARRAY-DATA OCCURS 9999.
03 ARRAY-WHOLE-LINE PIC X(132).
03 ARRAY-LEVEL PIC 99.
03 ARRAY-DATA-FIELD PIC X.
03 ARRAY-SAS-NO PIC 9999.
03 ARRAY-FIELD-NAME PIC X(35).
03 ARRAY-REDEFINE-NAME PIC X(35).
03 ARRAY-REDEFINE PIC X.
03 ARRAY-FIELD-TYPE PIC X.
03 ARRAY-SIGNED PIC X.
03 ARRAY-WHOLE PIC 9999.
03 ARRAY-DECIMALS PIC 9999.
03 ARRAY-LENGTH PIC 9999.
03 ARRAY-START-POS PIC 9(5).
03 ARRAY-CUM PIC 9(5).
03 ARRAY-NO-OF-OCCURS PIC 9.
03 ARRAY-OCCURS-L1 PIC 999.
03 ARRAY-OCCURS-L2 PIC 999.
03 ARRAY-OCCURS-L3 PIC 999.
03 ARRAY-SAS-DATA PIC X(80).
*
*--------------------------------------------------------------
* ANALYSING VARIALBES / FLAGS
*--------------------------------------------------------------
01 WS-ANALYSING-VARIABLES.
03 DATA-LENGTH PIC 999.
03 TEMP-SAS-NAME PIC X(35).
03 COPY-REC PIC X(132).
03 TEMP-COPY-REC PIC X(66).
03 WS-DONE PIC X.
88 DONE VALUE 'Y'.
03 WS-TEMP-START PIC 9.
03 WS-START PIC 99999.
03 WS-END PIC 99999.
03 WS-LENGTH PIC 99999.
03 WS-TEMP.
05 WS-TEMP-NUMERIC PIC 9999.
*
03 WS-FIELD-NAME-POS-START PIC 999.
03 WS-FIELD-NAME-POS-END PIC 999.
03 WS-FIELD-NAME-FOUND PIC X.
88 FIELD-NAME-NOT-FOUND VALUE 'N'.
88 FIELD-NAME-FOUND VALUE 'Y'.
*
03 WS-LEVEL-POS PIC 999.
03 WS-LEVEL PIC 99.
03 WS-LEVEL-FOUND PIC X.
88 LEVEL-NOT-FOUND VALUE 'N'.
88 LEVEL-FOUND VALUE 'Y'.
*
03 WS-COMP-FOUND PIC X.
88 COMP-FOUND VALUE 'Y'.
88 COMP-NOT-FOUND VALUE 'N'.
03 WS-COMP-1-FOUND PIC X.
88 COMP-1-FOUND VALUE 'Y'.
88 COMP-1-NOT-FOUND VALUE 'N'.
03 WS-COMP-2-FOUND PIC X.
88 COMP-2-FOUND VALUE 'Y'.
88 COMP-2-NOT-FOUND VALUE 'N'.
03 WS-COMP-3-FOUND PIC X.
88 COMP-3-FOUND VALUE 'Y'.
88 COMP-3-NOT-FOUND VALUE 'N'.
*
03 WS-OCCURS-POS PIC 999.
03 WS-OCCURS-FOUND PIC X.
88 OCCURS-FOUND VALUE 'Y'.
*
03 WS-DISPLAY-FOUND PIC X.
88 DISPLAY-FOUND VALUE 'Y'.
*
03 WS-PLUS-FOUND PIC X.
88 PLUS-FOUND VALUE 'Y'.
*
03 WS-REDEFINES-NAME PIC X(35).
03 WS-REDEFINES-POS PIC 999.
03 WS-REDEFINES-LEVEL PIC 99 VALUE 99.
03 WS-REDEFINES-FOUND PIC X.
88 REDEFINES-FOUND VALUE 'Y'.
03 WS-REDEFINES-SET-START PIC 999999.
03 WS-REDEFINES-SET PIC X.
88 REDEFINES-SET VALUE 'Y'.
88 REDEFINES-NOT-SET VALUE 'Y'.
*
03 WS-FULLSTOP-FOUND PIC X.
88 FULLSTOP-FOUND VALUE 'Y'.
88 FULLSTOP-NOT-FOUND VALUE 'N'.
*
03 WS-DATA-FOUND PIC X.
88 DATA-FOUND VALUE 'Y'.
*
03 WS-FLAG-SET PIC X.
88 FLAG-SET VALUE 'Y'.
*
03 WS-PIC-POS PIC 999.
03 WS-PIC-FOUND PIC X VALUE 'N'.
88 PIC-NOT-FOUND VALUE 'N'.
88 PIC-FOUND VALUE 'Y'.
*
03 WS-SIGN-FOUND PIC X.
88 SIGN-FOUND VALUE 'Y'.
88 SIGN-NOT-FOUND VALUE 'N'.
*
03 WS-DECIMAL-POS PIC 9999.
03 WS-DECIMAL-PLACES PIC 9999.
03 WS-DECIMAL-FOUND PIC X.
88 DECIMAL-FOUND VALUE 'Y'.
88 DECIMAL-NOT-FOUND VALUE 'N'.
03 WS-NEGATIVE-FOUND PIC X.
88 NEGATIVE-FOUND VALUE 'Y'.
88 NEGATIVE-NOT-FOUND VALUE 'N'.
*
03 WS-CHARS PIC 9999.
03 WS-CHAR-POS PIC 999.
03 WS-CHAR-FOUND PIC X.
88 CHAR-FOUND VALUE 'Y'.
88 CHAR-NOT-FOUND VALUE 'N'.
*
03 WS-WHOLE PIC 9999.
03 WS-WHOLE-POS PIC 999.
03 WS-WHOLE-FOUND PIC X.
88 WHOLE-FOUND VALUE 'Y'.
88 WHOLE-NOT-FOUND VALUE 'N'.
*
03 WS-SUB PIC 9999.
03 WS-SUB2 PIC 9999.
03 WS-SUB3 PIC 9999.
03 WS-PROCESS PIC X.
88 PROCESS-COMPLETE VALUE 'Y'.
*
03 WS-OCCURS-VARS.
05 NO-OCCURS PIC 9.
05 O-TABLE OCCURS 3.
07 O-ARRAY-POS PIC 9999.
07 O-LEVEL PIC 999.
07 O-MAX PIC 999.
07 O-START PIC 9999.
07 O-END PIC 9999.
*
*--------------------------------------------------------------
* ABEND PROCESSING
*--------------------------------------------------------------
01 WS-MISCELLANEOUS.
03 WS-ABEND-CODE PIC 9(03) VALUE ZERO.
03 WS-ABEND-SEC PIC X(04) VALUE SPACES.
03 WS-DUMP-FLAG PIC X VALUE 'Y'.
*
*--------------------------------------------------------------
* ERROR MESSAGES
*--------------------------------------------------------------
01 WS-ERROR-FIELDS.
03 WS-FILE-STATUS PIC 9(02) VALUE ZERO.
03 WS-ERROR-CODE PIC 9(02) VALUE ZERO.
03 WS-ERROR-TEXTS.
05 FILLER PIC X(50) VALUE
01 '*** OPEN ERROR - INPUT COPYBOOK ***'.
05 FILLER PIC X(50) VALUE
02 '*** READ ERROR - EMPTY INPUT COPYBOOK ***'.
05 FILLER PIC X(50) VALUE
03 '*** READ ERROR - INPUT COPYBOOK ***'.
05 FILLER PIC X(50) VALUE
04 '*** CLOSE ERROR - INPUT COPYBOOK ***'.
03 FILLER REDEFINES WS-ERROR-TEXTS.
05 WS-ERROR-TEXT PIC X(50) OCCURS 4.
*
*--------------------------------------------------------------
* SAS REPORT HEADER LINES
*--------------------------------------------------------------
01 WS-SAS-HEADER-LINES.
02 WS-SAS-HEADER-1.
03 FILLER PIC X(80) VALUE
'//AH05T87* JOB (ZZZZ),''LM - K DESAI'','.
02 WS-SAS-HEADER-2.
03 FILLER PIC X(80) VALUE
'// CLASS=C,MSGCLASS=R,PRTY=00,REGION=4M'.
02 WS-SAS-HEADER-3.
03 FILLER PIC X(80) VALUE
'//*'.
02 WS-SAS-HEADER-3A.
03 FILLER PIC X(80) VALUE
'//**************************************************'.
02 WS-SAS-HEADER-3B.
03 FILLER PIC X(80) VALUE
'//******************* S A S ************************'.
02 WS-SAS-HEADER-3C.
03 FILLER PIC X(80) VALUE
'//* DATE :'.
02 WS-SAS-HEADER-3D.
03 FILLER PIC X(80) VALUE
'//* CR/QUERY CODE :'.
02 WS-SAS-HEADER-3E.
03 FILLER PIC X(80) VALUE
'//* DESCRIPTION :'.
02 WS-SAS-HEADER-3F.
03 FILLER PIC X(80) VALUE
'//**************************************************'.
02 WS-SAS-HEADER-3G.
03 FILLER PIC X(80) VALUE
'//*'.
02 WS-SAS-HEADER-4.
03 FILLER PIC X(80) VALUE
'//*MAIN CLASS=SAS'.
02 WS-SAS-HEADER-5.
03 FILLER PIC X(80) VALUE
'//*'.
02 WS-SAS-HEADER-6.
03 FILLER PIC X(80) VALUE
'//SASSTEP EXEC SAS,REGION=4096K'.
02 WS-SAS-HEADER-7.
03 FILLER PIC X(80) VALUE
'//WORK DD UNIT=SORT,SPACE=(CYL,(250,250))'.
02 WS-SAS-HEADER-8.
03 FILLER PIC X(80) VALUE
'//SASIN DD DSN=ENTER-INPUT-FILE-HERE,DISP=SHR'.
02 WS-SAS-HEADER-8A.
03 FILLER PIC X(80) VALUE
'//FT12F001 DD DSN=ENTER-OUT-FILE-HERE,'.
02 WS-SAS-HEADER-8B.
03 FILLER PIC X(80) VALUE
'// DISP=(NEW,CATLG,DELETE),'.
02 WS-SAS-HEADER-8C.
03 FILLER PIC X(80) VALUE
'// UNIT=3390,SPACE=(TRK,(1,1)),'.
02 WS-SAS-HEADER-8D.
03 FILLER PIC X(80) VALUE
'// DCB=(DSCB,RECFM=FB,LRECL=133)'.
02 WS-SAS-HEADER-8E.
03 FILLER PIC X(80) VALUE
'//*'.
02 WS-SAS-HEADER-9.
03 FILLER PIC X(80) VALUE
'//SYSIN DD *'.
02 WS-SAS-HEADER-10.
03 FILLER PIC X(80) VALUE
' OPTIONS DATE ;'.
02 WS-SAS-HEADER-11.
03 FILLER PIC X(80) VALUE
'DATA ;'.
02 WS-SAS-HEADER-12.
03 FILLER PIC X(80) VALUE
'INFILE SASIN END=_END MISSOVER ;'.
02 WS-SAS-HEADER-13.
03 FILLER PIC X(80) VALUE
' INPUT'.
*
*--------------------------------------------------------------
* SAS REPORT MID LINES
*--------------------------------------------------------------
01 WS-SAS-MIDDLE-1.
03 FILLER PIC X(30) VALUE ' ;'.
03 FILLER PIC X(50) VALUE
' /* << END OF ''INPUT'' STATEMENTS >> */'.
*
*--------------------------------------------------------------
* SAS REPORT FOOTER LINES
*--------------------------------------------------------------
01 WS-SAS-FOOTER-1.
03 FILLER PIC X(20) VALUE SPACES.
03 FILLER PIC X(60) VALUE
'/* << END OF ''LABEL'' STATEMENTS >> */'.
01 WS-SAS-FOOTER-2.
03 FILLER PIC X(80) VALUE ' _ERROR_=0;'.
01 WS-SAS-FOOTER-3.
03 FILLER PIC X(80) VALUE
' TITLE "SAS PRINT OF XXXXX " ;'.
01 WS-SAS-FOOTER-4.
03 FILLER PIC X(80) VALUE
'PROC PRINT LABEL ;'.
*
*--------------------------------------------------------------
* SAS REPORT LINES - 80 BYTES
*--------------------------------------------------------------
01 WS-SAS-DATA-LINES.
03 FILLER PIC X(3) VALUE ' @'.
03 SAS-START PIC 9(5).
03 FILLER PIC X(3) VALUE ' A'.
03 SAS-NUMBER PIC 9(4).
03 FILLER PIC X(3) VALUE SPACES.
03 SAS-TYPE PIC X(5).
03 SAS-LENGTH PIC 9(4).
03 FILLER PIC X(1) VALUE '.'.
03 SAS-DECIMALS.
05 SAS-DECIMALS-N PIC 9(2).
03 FILLER PIC X(5) VALUE ' /* '.
03 SAS-NAME.
05 FILLER PIC X(20).
05 SAS-OCCURS-1.
07 FILLER PIC X.
07 SAS-O1 PIC 999.
07 FILLER PIC X.
05 SAS-OCCURS-2.
07 FILLER PIC X.
07 SAS-O2 PIC 999.
07 FILLER PIC X.
05 SAS-OCCURS-3.
07 FILLER PIC X.
07 SAS-O3 PIC 999.
07 FILLER PIC X.
03 FILLER PIC X(5) VALUE '*/ '.
03 FILLER PIC X(5) VALUE SPACES.
*
01 WS-SAS-LABEL-LINES.
03 FILLER PIC X(12) VALUE ' LABEL A'.
03 LABEL-NUMBER PIC 9(4).
03 FILLER PIC X(8) VALUE ' = "'.
03 LABEL-NAME PIC X(35) VALUE SPACES.
03 FILLER PIC X(4) VALUE '" ;'.
03 FILLER PIC X(17) VALUE SPACES.
*
PROCEDURE DIVISION.
*
*##############################################################
* PROCEDURE DIVISION
*##############################################################
*
A000 SECTION.
***************************************************************
* PROGRAM CONTROL SECTION
***************************************************************
A000-START.
PERFORM B000-INITIALISE.
PERFORM C000-MAIN UNTIL ICOPY-EOF.
PERFORM D000-TERMINATE.
STOP RUN.
A000-EXIT.
EXIT.
*
B000-INITIALISE SECTION.
***************************************************************
* OPEN COPYBOOK
***************************************************************
B005-OPEN-COPYBOOK-FILE.
OPEN INPUT COPY-FILE.
IF NOT ICOPY-OK
MOVE WS-FS-ICOPY TO WS-FILE-STATUS
MOVE 1 TO WS-ERROR-CODE
MOVE 'B005' TO WS-ABEND-SEC
MOVE 001 TO WS-ABEND-CODE
PERFORM Z000-ABEND
END-IF.
*
B035-CHECK-COPYBOOK-FILE-EMPTY.
PERFORM R000-READ-COPYBOOK.
IF ICOPY-EOF
MOVE WS-FS-ICOPY TO WS-FILE-STATUS
MOVE 2 TO WS-ERROR-CODE
MOVE 'B035' TO WS-ABEND-SEC
MOVE 2 TO WS-ABEND-CODE
PERFORM Z000-ABEND
END-IF.
*
MOVE 'N' TO WS-PROCESS.
MOVE 0 TO NO-OCCURS.
*
B999-EXIT.
EXIT.
*
C000-MAIN SECTION.
***************************************************************
* MAIN PROCESSING SECTION
***************************************************************
*
C000-PROCESS-EXIT.
PERFORM UNTIL 'Y' = WS-PROCESS
* CHECK IF OCCURS BLOCK HAS COME TO AN END
IF NO-OCCURS > 0 THEN
IF O-LEVEL(NO-OCCURS) > WS-LEVEL
MOVE ARRAY-ELEMENTS TO O-END(NO-OCCURS)
PERFORM C400-POPULATE-ARRAY-OCCURS
GO TO C000-PROCESS-EXIT
END-IF
END-IF
* NEW OCCURS FOUND, ADD INFO ABOUT IT TO STORAGE ARRAY
IF OCCURS-FOUND AND PIC-NOT-FOUND THEN
IF NOT O-LEVEL(NO-OCCURS) = WS-LEVEL THEN
PERFORM C210-PROCESS-OCCURS
PERFORM C300-POPULATE-ARRAY
PERFORM R000-READ-COPYBOOK
GO TO C000-PROCESS-EXIT
END-IF
END-IF
* CHECK IF OCCURS & PIC CLAUSE ON SAME LINE = SINGLE DATA REPEATED
IF OCCURS-FOUND AND PIC-FOUND THEN
PERFORM C210-PROCESS-OCCURS
PERFORM C250-SCAN-PICTURE
PERFORM C300-POPULATE-ARRAY
ADD -1 TO O-START(NO-OCCURS)
MOVE O-START(NO-OCCURS) TO O-END(NO-OCCURS)
PERFORM C400-POPULATE-ARRAY-OCCURS
PERFORM R000-READ-COPYBOOK
GO TO C000-PROCESS-EXIT
END-IF
* CHECK IF REDEFINES AND PIC CLAUSE ON SAME LINE
IF REDEFINES-FOUND AND PIC-FOUND THEN
PERFORM C250-SCAN-PICTURE
PERFORM C270-PROCESS-REDEFINE
PERFORM C300-POPULATE-ARRAY
PERFORM R000-READ-COPYBOOK
GO TO C000-PROCESS-EXIT
END-IF
* PROCESS REDEFINE BLOCK
IF REDEFINES-FOUND AND PIC-NOT-FOUND THEN
PERFORM C270-PROCESS-REDEFINE
PERFORM C300-POPULATE-ARRAY
PERFORM R000-READ-COPYBOOK
GO TO C000-PROCESS-EXIT
END-IF
* PROCESS DATA LINE DEPENDANT ON WHEATHER INSIDE OCCURS BLOCK
EVALUATE NO-OCCURS
WHEN 0
PERFORM C250-SCAN-PICTURE
PERFORM C300-POPULATE-ARRAY
PERFORM R000-READ-COPYBOOK
WHEN OTHER
* STILL SCANING DOWN COPYBOOK WITHIN THIS BLOCK OCCURS
IF O-LEVEL(NO-OCCURS) < WS-LEVEL AND
WS-FS-ICOPY = '00' THEN
PERFORM C250-SCAN-PICTURE
PERFORM C300-POPULATE-ARRAY
PERFORM R000-READ-COPYBOOK
ELSE
* PROCESS 2+ OCCURS USING DATA IN TEMP ARRAY
MOVE ARRAY-ELEMENTS TO O-END(NO-OCCURS)
PERFORM C400-POPULATE-ARRAY-OCCURS
END-IF
END-EVALUATE
*
* CHECK IF EOF REACHED AND ALL OCCUR BLOCKS HAVE BEEN PROCESSED
IF NOT WS-FS-ICOPY = '00' AND NO-OCCURS = 0 THEN
MOVE 'Y' TO WS-PROCESS
END-IF
END-PERFORM.
*
C999-EXIT.
EXIT.
*
C010-INITIALISE-FLAGS SECTION.
***************************************************************
* RESET ALL FLAG READY FOR THE PROCESSING OF THE NEXT LINE
***************************************************************
*
MOVE 'N' TO WS-LEVEL-FOUND
WS-FIELD-NAME-FOUND
WS-LEVEL-FOUND
WS-COMP-FOUND
WS-COMP-1-FOUND
WS-COMP-2-FOUND
WS-COMP-3-FOUND
WS-OCCURS-FOUND
WS-REDEFINES-FOUND
WS-NEGATIVE-FOUND
WS-FULLSTOP-FOUND
WS-SIGN-FOUND
WS-PLUS-FOUND
WS-DISPLAY-FOUND
WS-DECIMAL-FOUND
WS-WHOLE-FOUND
WS-CHAR-FOUND
WS-PIC-FOUND.
MOVE ZEROS TO WS-DECIMAL-PLACES.
*
C019-EXIT.
EXIT.
*
C200-SCAN-FOR-KEYS SECTION.
***************************************************************
* SCAN LINE OF COPYBOOK FOR CERTAIN KEYS WORDS
***************************************************************
*
MOVE 66 TO DATA-LENGTH.
*
C200-BEGIN.
*
PERFORM VARYING WS-SUB FROM 1 BY 1 UNTIL WS-SUB > DATA-LENGTH
* CHECK FOR FULLSTOP
IF COPY-REC(WS-SUB:1) = '.' THEN
MOVE 'Y' TO WS-FULLSTOP-FOUND
END-IF
* CALCULATE FIELD NAME START POSITION
IF LEVEL-FOUND AND COPY-REC(WS-SUB:1) NOT = ' ' AND
WS-SUB > WS-FIELD-NAME-POS-START AND
FIELD-NAME-NOT-FOUND THEN
MOVE WS-SUB TO WS-FIELD-NAME-POS-START
MOVE 'Y' TO WS-FIELD-NAME-FOUND
END-IF
* CHECK FOR COPYBOOK LEVEL POSITION
IF COPY-REC(WS-SUB:1) IS NUMERIC AND LEVEL-NOT-FOUND THEN
MOVE WS-SUB TO WS-LEVEL-POS WS-FIELD-NAME-POS-START
MOVE COPY-REC(WS-LEVEL-POS:2) TO WS-LEVEL
ADD 2 TO WS-FIELD-NAME-POS-START
MOVE 'Y' TO WS-LEVEL-FOUND
END-IF
* CHECK FOR COPYBOOK OCCURS POSITION
IF COPY-REC(WS-SUB:6) = 'OCCURS' THEN
MOVE 'Y' TO WS-OCCURS-FOUND
MOVE WS-SUB TO WS-OCCURS-POS
ADD 7 TO WS-OCCURS-POS
END-IF
* CHECK FOR COPYBOOK PIC POSITION
IF COPY-REC(WS-SUB:3) = 'PIC' THEN
MOVE 'Y' TO WS-PIC-FOUND
MOVE WS-SUB TO WS-PIC-POS
ADD 4 TO WS-PIC-POS
END-IF
* CHECK FOR COPYBOOK REDEFINES POSITION
IF COPY-REC(WS-SUB:9) = 'REDEFINES' THEN
MOVE 'Y' TO WS-REDEFINES-FOUND
MOVE WS-SUB TO WS-REDEFINES-POS
ADD 10 TO WS-REDEFINES-POS
END-IF
END-PERFORM.
*
* HANDLING FOR DATA ON 2 LINES
IF FULLSTOP-NOT-FOUND THEN
MOVE COPY-REC(1:66) TO TEMP-COPY-REC
PERFORM R100-READ
MOVE COPY-REC(7:66) TO COPY-REC(67:66)
MOVE TEMP-COPY-REC TO COPY-REC(1:66)
MOVE 132 TO DATA-LENGTH
GO TO C200-BEGIN
END-IF.
*
C209-EXIT.
EXIT.
*
C210-PROCESS-OCCURS SECTION.
***************************************************************
* FIND OCCURS NUMBER
***************************************************************
*
ADD 1 TO NO-OCCURS.
MOVE ARRAY-ELEMENTS TO O-START(NO-OCCURS)
ADD 2 TO O-START(NO-OCCURS)
MOVE 'N' TO WS-FULLSTOP-FOUND.
MOVE WS-OCCURS-POS TO WS-START.
ADD -1 TO WS-START.
*
PERFORM VARYING WS-SUB FROM WS-OCCURS-POS BY 1
UNTIL FULLSTOP-FOUND
IF COPY-REC(WS-SUB:1) = '.' OR
COPY-REC(WS-SUB:1) = ' ' THEN
MOVE 'Y' TO WS-FULLSTOP-FOUND
MOVE WS-SUB TO WS-END
END-IF
END-PERFORM.
PERFORM C260-CALC-NUMERIC.
*
MOVE COPY-REC(WS-LEVEL-POS:2) TO O-LEVEL(NO-OCCURS).
MOVE WS-TEMP-NUMERIC TO O-MAX(NO-OCCURS).
*
C219-EXIT.
EXIT.
*
C250-SCAN-PICTURE SECTION.
***************************************************************
* SCAN AND BREAKDOWN PICTURE CLAUSE
***************************************************************
*
PERFORM VARYING WS-SUB FROM WS-PIC-POS BY 1 UNTIL
WS-SUB > DATA-LENGTH
EVALUATE TRUE
WHEN COPY-REC(WS-SUB:1) = 'S'
MOVE 'Y' TO WS-SIGN-FOUND
WHEN COPY-REC(WS-SUB:1) = '-' OR
COPY-REC(WS-SUB:1) = '+'
MOVE 'Y' TO WS-PLUS-FOUND
WHEN COPY-REC(WS-SUB:1) = '9' AND WHOLE-NOT-FOUND
MOVE 'Y' TO WS-WHOLE-FOUND
MOVE WS-SUB TO WS-WHOLE-POS
WHEN COPY-REC(WS-SUB:1) = 'X' AND CHAR-NOT-FOUND
MOVE 'Y' TO WS-CHAR-FOUND
MOVE WS-SUB TO WS-CHAR-POS
WHEN COPY-REC(WS-SUB:1) = 'V' AND DECIMAL-NOT-FOUND
MOVE 'Y' TO WS-DECIMAL-FOUND
MOVE WS-SUB TO WS-DECIMAL-POS
WHEN COPY-REC(WS-SUB:2) = '.9'
MOVE 'Y' TO WS-DECIMAL-FOUND
MOVE 'Y' TO WS-DISPLAY-FOUND
MOVE WS-SUB TO WS-DECIMAL-POS
WHEN COPY-REC(WS-SUB:1) = '-'
MOVE 'Y' TO WS-NEGATIVE-FOUND
WHEN COPY-REC(WS-SUB:4) = 'COMP'
IF COPY-REC(WS-SUB:5) = 'COMP ' OR
COPY-REC(WS-SUB:5) = 'COMP.' THEN
MOVE 'Y' TO WS-COMP-FOUND
END-IF
IF COPY-REC(WS-SUB:6) = 'COMP-1' THEN
MOVE 'Y' TO WS-COMP-1-FOUND
END-IF
IF COPY-REC(WS-SUB:6) = 'COMP-2' THEN
MOVE 'Y' TO WS-COMP-2-FOUND
END-IF
IF COPY-REC(WS-SUB:6) = 'COMP-3' THEN
MOVE 'Y' TO WS-COMP-3-FOUND
END-IF
END-EVALUATE
END-PERFORM.
*
* CALCULATE NUMBER OF DECIMAL PLACES
IF DECIMAL-FOUND THEN
MOVE ZERO TO WS-DECIMAL-PLACES WS-START WS-END
PERFORM VARYING WS-SUB FROM WS-DECIMAL-POS BY 1
UNTIL COPY-REC(WS-SUB:1) = ' '
IF COPY-REC(WS-SUB:1) = '9' AND WS-START = 0 THEN
ADD 1 TO WS-DECIMAL-PLACES
END-IF
IF COPY-REC(WS-SUB:1) = '(' THEN
MOVE WS-SUB TO WS-START
END-IF
IF COPY-REC(WS-SUB:1) = ')' THEN
MOVE WS-SUB TO WS-END
END-IF
END-PERFORM
IF WS-START > 0 AND WS-END > 0 THEN
PERFORM C260-CALC-NUMERIC
COMPUTE WS-DECIMAL-PLACES =
WS-TEMP-NUMERIC + WS-DECIMAL-PLACES - 1
END-IF
END-IF.
*
* CALCULATE NUMBER OF CHARACTERS
IF CHAR-FOUND THEN
MOVE ZERO TO WS-CHARS WS-START WS-END
PERFORM VARYING WS-SUB FROM WS-CHAR-POS BY 1
UNTIL COPY-REC(WS-SUB:1) = ' '
IF COPY-REC(WS-SUB:1) = 'X' AND WS-START = 0 THEN
ADD 1 TO WS-CHARS
END-IF
IF COPY-REC(WS-SUB:1) = '(' THEN
MOVE WS-SUB TO WS-START
END-IF
IF COPY-REC(WS-SUB:1) = ')' THEN
MOVE WS-SUB TO WS-END
END-IF
END-PERFORM
IF WS-START > 0 AND WS-END > 0 THEN
PERFORM C260-CALC-NUMERIC
COMPUTE WS-CHARS = WS-TEMP-NUMERIC + WS-CHARS - 1
END-IF
END-IF.
*
* CALCULATE NUMBER WHOLE DIGITS FOR NUMERICS
IF WHOLE-FOUND THEN
MOVE ZERO TO WS-WHOLE WS-START WS-END
PERFORM VARYING WS-SUB FROM WS-WHOLE-POS BY 1
UNTIL COPY-REC(WS-SUB:1) = ' '
OR COPY-REC(WS-SUB:1) = '.'
OR COPY-REC(WS-SUB:1) = 'V'
IF COPY-REC(WS-SUB:1) = '9' AND WS-START = 0 THEN
ADD 1 TO WS-WHOLE
END-IF
IF COPY-REC(WS-SUB:1) = '(' THEN
MOVE WS-SUB TO WS-START
END-IF
IF COPY-REC(WS-SUB:1) = ')' THEN
MOVE WS-SUB TO WS-END
END-IF
END-PERFORM
IF WS-START > 0 AND WS-END > 0 THEN
PERFORM C260-CALC-NUMERIC
COMPUTE WS-WHOLE = WS-TEMP-NUMERIC + WS-WHOLE - 1
END-IF
END-IF.
*
C259-EXIT.
EXIT.
*
C260-CALC-NUMERIC SECTION.
***************************************************************
* CALCULATES THE NUMERIC WITHIN BRACKETS AND POSITION OF THEM
***************************************************************
*
ADD 1 TO WS-START.
MOVE ZERO TO WS-TEMP-NUMERIC.
COMPUTE WS-LENGTH = WS-END - WS-START.
COMPUTE WS-TEMP-START = 4 - WS-LENGTH + 1.
MOVE COPY-REC(WS-START:WS-LENGTH) TO
WS-TEMP(WS-TEMP-START:WS-LENGTH).
COMPUTE WS-TEMP-START = 4 - WS-LENGTH
PERFORM VARYING WS-SUB FROM 1 BY 1
UNTIL WS-SUB > WS-TEMP-START
MOVE '0' TO WS-TEMP-START(WS-SUB:1)
END-PERFORM.
*
C269-EXIT.
EXIT.
*
C270-PROCESS-REDEFINE SECTION.
***************************************************************
* FIND REDEFINE DATA
***************************************************************
*
* FIND START OF REDEFINE FIELD NAME
MOVE 'N' TO WS-FULLSTOP-FOUND.
PERFORM VARYING WS-SUB FROM WS-REDEFINES-POS BY 1
UNTIL FULLSTOP-FOUND
IF NOT COPY-REC(WS-SUB:1) = ' ' THEN
MOVE 'Y' TO WS-FULLSTOP-FOUND
MOVE WS-SUB TO WS-START
END-IF
END-PERFORM.
*
MOVE 'N' TO WS-FULLSTOP-FOUND.
PERFORM VARYING WS-SUB FROM WS-START BY 1
UNTIL FULLSTOP-FOUND
IF COPY-REC(WS-SUB:1) = '.' OR
COPY-REC(WS-SUB:1) = ' ' THEN
MOVE 'Y' TO WS-FULLSTOP-FOUND
MOVE WS-SUB TO WS-END
END-IF
END-PERFORM.
*
COMPUTE WS-LENGTH = WS-END - WS-START.
MOVE COPY-REC(WS-START:WS-LENGTH) TO WS-REDEFINES-NAME.
*
C279-EXIT.
EXIT.
*
C300-POPULATE-ARRAY SECTION.
***************************************************************
* POPULATE COMPONENTS OF THE DATA LINE
***************************************************************
*
* INCREASE NUMBER OF ELEMENTS BY 1
ADD 1 TO ARRAY-ELEMENTS.
INITIALIZE ARRAY-DATA(ARRAY-ELEMENTS).
* POPULATE WHOLE DATA LINE
MOVE COPY-REC TO ARRAY-WHOLE-LINE(ARRAY-ELEMENTS)
* POPULATE LEVEL OF COPYBOOK DATA ITEM
MOVE COPY-REC(WS-LEVEL-POS:2) TO
ARRAY-LEVEL(ARRAY-ELEMENTS).
* POPULATE NUMBER WHOLE DIGITS FOR NUMERICS
MOVE WS-WHOLE TO ARRAY-WHOLE(ARRAY-ELEMENTS).
* POPULATE NUMBER OF DECIMAL PLACES
MOVE WS-DECIMAL-PLACES TO ARRAY-DECIMALS(ARRAY-ELEMENTS).
* POPULATE NUMBER CHARACTERS
IF CHAR-FOUND THEN
MOVE WS-CHARS TO ARRAY-LENGTH(ARRAY-ELEMENTS)
END-IF.
* POPULATE ZONED DECIMAL
IF CHAR-NOT-FOUND AND COMP-NOT-FOUND AND COMP-1-NOT-FOUND AND
COMP-2-NOT-FOUND AND COMP-3-NOT-FOUND THEN
COMPUTE ARRAY-LENGTH(ARRAY-ELEMENTS) =
WS-WHOLE + WS-DECIMAL-PLACES
END-IF.
* POPULATE DISPLAY NUMERIC LENGTH
IF DISPLAY-FOUND THEN
COMPUTE ARRAY-LENGTH(ARRAY-ELEMENTS) =
WS-WHOLE + WS-DECIMAL-PLACES + 1
END-IF.
IF PLUS-FOUND THEN
ADD 1 TO ARRAY-LENGTH(ARRAY-ELEMENTS)
END-IF.
* POPULATE LENGTH OF BYTES REQUIRED OF PACKED NUMERIC COMP
IF COMP-FOUND THEN
MOVE WS-DECIMAL-PLACES TO WS-TEMP-NUMERIC
ADD WS-WHOLE TO WS-TEMP-NUMERIC
COMPUTE WS-TEMP-NUMERIC = (WS-TEMP-NUMERIC / 2)
MOVE WS-TEMP-NUMERIC TO ARRAY-LENGTH(ARRAY-ELEMENTS)
END-IF.
* POPULATE LENGTH OF BYTES REQUIRED OF PACKED NUMERIC COMP-3
IF COMP-3-FOUND THEN
MOVE WS-DECIMAL-PLACES TO WS-TEMP-NUMERIC
ADD WS-WHOLE TO WS-TEMP-NUMERIC
COMPUTE WS-TEMP-NUMERIC = WS-TEMP-NUMERIC / 2
ADD 1 TO WS-TEMP-NUMERIC
MOVE WS-TEMP-NUMERIC TO ARRAY-LENGTH(ARRAY-ELEMENTS)
END-IF.
* POPULATE TYPE OF DATA
EVALUATE TRUE
WHEN COMP-FOUND
MOVE 'A' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
WHEN COMP-1-FOUND
MOVE 'B' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
WHEN COMP-2-FOUND
MOVE 'C' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
WHEN COMP-3-FOUND
MOVE 'D' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
WHEN DISPLAY-FOUND
MOVE 'E' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
WHEN CHAR-FOUND
MOVE 'X' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
WHEN OTHER
MOVE 'Y' TO ARRAY-FIELD-TYPE(ARRAY-ELEMENTS)
END-EVALUATE.
* POPULATE FLAG TO SHOW IF COPYBOOK LINE CONTAINS A PIC CLAUSE
IF PIC-FOUND THEN
MOVE 'Y' TO ARRAY-DATA-FIELD(ARRAY-ELEMENTS)
ADD 1 TO ARRAY-ELEMENTS-D
MOVE ARRAY-ELEMENTS-D TO ARRAY-SAS-NO(ARRAY-ELEMENTS)
ELSE
MOVE 'N' TO ARRAY-DATA-FIELD(ARRAY-ELEMENTS)
END-IF.
* POPULATE FLAG TO SHOW IF NUMERIC IS SIGNED
IF SIGN-FOUND THEN
MOVE 'Y' TO ARRAY-SIGNED(ARRAY-ELEMENTS)
ELSE
MOVE 'N' TO ARRAY-SIGNED(ARRAY-ELEMENTS)
END-IF.
* POPULATE FLAG TO SHOW REDEFINE FOUND
IF REDEFINES-FOUND THEN
MOVE 'Y' TO ARRAY-REDEFINE(ARRAY-ELEMENTS)
MOVE WS-REDEFINES-NAME TO
ARRAY-REDEFINE-NAME(ARRAY-ELEMENTS)
MOVE WS-LEVEL TO WS-REDEFINES-LEVEL
ELSE
MOVE 'N' TO ARRAY-REDEFINE(ARRAY-ELEMENTS)
MOVE 99 TO WS-REDEFINES-LEVEL
END-IF.
* POPULATE FIELD NAME OF COPYBOOK
MOVE 'N' TO WS-DONE.
PERFORM VARYING WS-SUB FROM WS-FIELD-NAME-POS-START BY 1
UNTIL DONE
IF COPY-REC(WS-SUB:1) = SPACE OR
COPY-REC(WS-SUB:1) = '.' THEN
MOVE WS-SUB TO WS-FIELD-NAME-POS-END
MOVE 'Y' TO WS-DONE
END-IF
END-PERFORM.
COMPUTE WS-FIELD-NAME-POS-END =
WS-FIELD-NAME-POS-END - WS-FIELD-NAME-POS-START.
MOVE COPY-REC(WS-FIELD-NAME-POS-START:WS-FIELD-NAME-POS-END)
TO ARRAY-FIELD-NAME(ARRAY-ELEMENTS).
* POPULATE OCCURS FIELDS
MOVE NO-OCCURS TO
ARRAY-NO-OF-OCCURS(ARRAY-ELEMENTS).
EVALUATE NO-OCCURS
WHEN 1
MOVE 1 TO ARRAY-OCCURS-L1(ARRAY-ELEMENTS)
MOVE ZERO TO ARRAY-OCCURS-L2(ARRAY-ELEMENTS)
ARRAY-OCCURS-L3(ARRAY-ELEMENTS)
WHEN 2
MOVE 1 TO ARRAY-OCCURS-L1(ARRAY-ELEMENTS)
ARRAY-OCCURS-L2(ARRAY-ELEMENTS)
MOVE ZERO TO ARRAY-OCCURS-L3(ARRAY-ELEMENTS)
WHEN 3
MOVE 1 TO ARRAY-OCCURS-L1(ARRAY-ELEMENTS)
ARRAY-OCCURS-L2(ARRAY-ELEMENTS)
ARRAY-OCCURS-L3(ARRAY-ELEMENTS)
END-EVALUATE.
* CORRECT IF DISPLAY SIGN FOUND
IF NEGATIVE-FOUND THEN
ADD 1 TO ARRAY-LENGTH(ARRAY-ELEMENTS)
END-IF.
*
C399-EXIT.
EXIT.
*
C400-POPULATE-ARRAY-OCCURS SECTION.
***************************************************************
* PROCESS DATA HELD WITHIN ARRAY FOR OCCURS
***************************************************************
*
* PROCESS 2ND+ OCCURS
PERFORM VARYING WS-SUB FROM 2
BY 1 UNTIL WS-SUB > O-MAX(NO-OCCURS)
* PROCESS ITEMS WITHIN OCCURS
PERFORM VARYING WS-SUB2 FROM O-START(NO-OCCURS)
BY 1 UNTIL WS-SUB2 > O-END(NO-OCCURS)
ADD 1 TO ARRAY-ELEMENTS
MOVE ARRAY-DATA(WS-SUB2) TO
ARRAY-DATA(ARRAY-ELEMENTS)
KDD IF ARRAY-DATA-FIELD(WS-SUB2) = 'Y' THEN
ADD 1 TO ARRAY-ELEMENTS-D
MOVE ARRAY-ELEMENTS-D TO
ARRAY-SAS-NO(ARRAY-ELEMENTS)
END-IF
EVALUATE NO-OCCURS
WHEN 1 MOVE WS-SUB TO
ARRAY-OCCURS-L1(ARRAY-ELEMENTS)
WHEN 2 MOVE WS-SUB TO
ARRAY-OCCURS-L2(ARRAY-ELEMENTS)
WHEN 3 MOVE WS-SUB TO
ARRAY-OCCURS-L3(ARRAY-ELEMENTS)
WHEN OTHER
EXIT
END-EVALUATE
END-PERFORM
END-PERFORM.
ADD -1 TO NO-OCCURS.
*
C499-EXIT.
EXIT.
*
C500-CALC-OFFSETS SECTION.
***************************************************************
* CALCULATE OFFSETS SETS AND CUM LENGTH
***************************************************************
*
MOVE ZERO TO WS-LENGTH.
MOVE 'N' TO WS-REDEFINES-SET.
MOVE 1 TO WS-START.
PERFORM VARYING WS-SUB FROM 1 BY 1
UNTIL WS-SUB > ARRAY-ELEMENTS
IF ARRAY-REDEFINE(WS-SUB) = 'Y' THEN
MOVE 'N' TO WS-DATA-FOUND WS-FLAG-SET
WS-REDEFINES-SET
*---------- FIND ARRAY POSITION WHERE REDEFINE FIELD SITS -----
PERFORM VARYING WS-SUB2 FROM 1 BY 1
UNTIL WS-SUB2 > ARRAY-ELEMENTS OR DATA-FOUND
IF ARRAY-FIELD-NAME(WS-SUB2) =
ARRAY-REDEFINE-NAME(WS-SUB) AND
ARRAY-LEVEL(WS-SUB) =
ARRAY-LEVEL(WS-SUB2) THEN
*----------------- FIND START OF 1ST REDEFINE DATA LINE
PERFORM VARYING WS-SUB3 FROM WS-SUB2 BY 1
UNTIL FLAG-SET AND
ARRAY-DATA-FIELD(WS-SUB3) = 'Y'
IF ARRAY-DATA-FIELD(WS-SUB3) = 'Y' AND
ARRAY-OCCURS-L1(WS-SUB3) =
ARRAY-OCCURS-L1(WS-SUB) AND
ARRAY-OCCURS-L2(WS-SUB3) =
ARRAY-OCCURS-L2(WS-SUB) AND
ARRAY-OCCURS-L3(WS-SUB3) =
ARRAY-OCCURS-L3(WS-SUB) THEN
MOVE 'Y' TO WS-FLAG-SET
WS-DATA-FOUND
WS-REDEFINES-SET
IF WS-SUB2 = WS-SUB3 THEN
MOVE 'N' TO WS-REDEFINES-SET
END-IF
COMPUTE WS-REDEFINES-SET-START =
ARRAY-CUM(WS-SUB3) + 1 -
ARRAY-LENGTH(WS-SUB3)
MOVE ARRAY-START-POS(WS-SUB3) TO
ARRAY-START-POS(WS-SUB)
END-IF
END-PERFORM
*-----------------------------------------------------
END-IF
END-PERFORM
*--------------------------------------------------------------
ELSE
IF ARRAY-DATA-FIELD(WS-SUB) = 'Y' AND
REDEFINES-SET THEN
MOVE 'N' TO WS-REDEFINES-SET
MOVE WS-REDEFINES-SET-START TO
ARRAY-START-POS(WS-SUB)
WS-LENGTH
ADD ARRAY-LENGTH(WS-SUB) TO WS-LENGTH
ADD -1 TO WS-LENGTH
MOVE WS-LENGTH TO ARRAY-CUM(WS-SUB)
COMPUTE WS-START = WS-REDEFINES-SET-START +
ARRAY-LENGTH(WS-SUB)
ELSE
IF ARRAY-LEVEL(WS-SUB) = '01' THEN
MOVE 1 TO WS-START
MOVE ZERO TO WS-LENGTH
END-IF
IF ARRAY-DATA-FIELD(WS-SUB) = 'Y' THEN
ADD ARRAY-LENGTH(WS-SUB) TO WS-LENGTH
MOVE WS-LENGTH TO ARRAY-CUM(WS-SUB)
MOVE WS-START TO ARRAY-START-POS(WS-SUB)
ADD ARRAY-LENGTH(WS-SUB) TO WS-START
END-IF
END-IF
END-IF
END-PERFORM.
*
C599-EXIT.
EXIT.
*
C600-CREATE-SAS SECTION.
***************************************************************
*
***************************************************************
*
* PRINT SAS HEADER LINES
DISPLAY WS-SAS-HEADER-1.
DISPLAY WS-SAS-HEADER-2.
DISPLAY WS-SAS-HEADER-3.
DISPLAY WS-SAS-HEADER-3A.
DISPLAY WS-SAS-HEADER-3B.
DISPLAY WS-SAS-HEADER-3C.
DISPLAY WS-SAS-HEADER-3D.
DISPLAY WS-SAS-HEADER-3E.
DISPLAY WS-SAS-HEADER-3F.
DISPLAY WS-SAS-HEADER-3G.
DISPLAY WS-SAS-HEADER-4.
DISPLAY WS-SAS-HEADER-5.
DISPLAY WS-SAS-HEADER-6.
DISPLAY WS-SAS-HEADER-7.
DISPLAY WS-SAS-HEADER-8.
DISPLAY WS-SAS-HEADER-8A.
DISPLAY WS-SAS-HEADER-8B.
DISPLAY WS-SAS-HEADER-8C.
DISPLAY WS-SAS-HEADER-8D.
DISPLAY WS-SAS-HEADER-8E.
DISPLAY WS-SAS-HEADER-9.
DISPLAY WS-SAS-HEADER-10.
DISPLAY WS-SAS-HEADER-11.
DISPLAY WS-SAS-HEADER-12.
DISPLAY WS-SAS-HEADER-13.
* PRINT SAS DATA LINES
PERFORM VARYING WS-SUB FROM 1 BY 1
UNTIL WS-SUB > ARRAY-ELEMENTS
IF ARRAY-DATA-FIELD(WS-SUB) = 'Y' THEN
INITIALIZE WS-SAS-DATA-LINES
MOVE ARRAY-START-POS(WS-SUB) TO SAS-START
MOVE ARRAY-SAS-NO(WS-SUB) TO SAS-NUMBER
IF ARRAY-DECIMALS(WS-SUB) > 0 AND
NOT ARRAY-FIELD-TYPE(WS-SUB) = 'E' THEN
MOVE ARRAY-DECIMALS(WS-SUB) TO SAS-DECIMALS-N
ELSE
MOVE SPACES TO SAS-DECIMALS
END-IF
MOVE ARRAY-LENGTH(WS-SUB) TO SAS-LENGTH
EVALUATE ARRAY-FIELD-TYPE(WS-SUB)
WHEN 'E'
MOVE '£CHAR' TO SAS-TYPE
WHEN 'X'
MOVE '£CHAR' TO SAS-TYPE
WHEN 'Y'
MOVE ' ZD' TO SAS-TYPE
WHEN OTHER
MOVE ' PD' TO SAS-TYPE
END-EVALUATE
MOVE ARRAY-FIELD-NAME(WS-SUB) TO SAS-NAME
* MOVING OCCUR NUMBERS
EVALUATE ARRAY-NO-OF-OCCURS(WS-SUB)
WHEN 1
MOVE '( )' TO SAS-OCCURS-3
MOVE ARRAY-OCCURS-L1(WS-SUB) TO SAS-O3
WHEN 2
MOVE '( )' TO SAS-OCCURS-2
SAS-OCCURS-3
MOVE ARRAY-OCCURS-L1(WS-SUB) TO SAS-O2
MOVE ARRAY-OCCURS-L2(WS-SUB) TO SAS-O3
WHEN 3
MOVE '( )' TO SAS-OCCURS-1
SAS-OCCURS-2
SAS-OCCURS-3
MOVE ARRAY-OCCURS-L1(WS-SUB) TO SAS-O1
MOVE ARRAY-OCCURS-L2(WS-SUB) TO SAS-O2
MOVE ARRAY-OCCURS-L3(WS-SUB) TO SAS-O3
WHEN OTHER
EXIT
END-EVALUATE
MOVE SAS-NAME TO ARRAY-SAS-DATA(WS-SUB)
DISPLAY WS-SAS-DATA-LINES
END-IF
END-PERFORM.
*
* PRINT SAS MIDDLE LINES
DISPLAY WS-SAS-MIDDLE-1.
*
* PRINT SAS LABEL LINES
PERFORM VARYING WS-SUB FROM 1 BY 1
UNTIL WS-SUB > ARRAY-ELEMENTS
IF ARRAY-DATA-FIELD(WS-SUB) = 'Y' THEN
INITIALIZE WS-SAS-LABEL-LINES
* REMOVE SPACES AND '-'
MOVE ARRAY-SAS-DATA(WS-SUB) TO TEMP-SAS-NAME
PERFORM VARYING WS-SUB2 FROM 1 BY 1
UNTIL WS-SUB2 > 35
IF TEMP-SAS-NAME(WS-SUB2:1) = '-' THEN
MOVE ' ' TO LABEL-NAME(WS-SUB2:1)
ELSE
MOVE TEMP-SAS-NAME(WS-SUB2:1) TO
LABEL-NAME(WS-SUB2:1)
END-IF
END-PERFORM
MOVE ARRAY-SAS-NO(WS-SUB) TO LABEL-NUMBER
DISPLAY WS-SAS-LABEL-LINES
END-IF
END-PERFORM.
*
* PRINT SAS FOOTER LINES
DISPLAY WS-SAS-FOOTER-1.
DISPLAY WS-SAS-FOOTER-2.
DISPLAY WS-SAS-FOOTER-3.
DISPLAY WS-SAS-FOOTER-4.
*
C699-EXIT.
EXIT.
*
D000-TERMINATE SECTION.
***************************************************************
* TERMINATION SECTION
***************************************************************
*
PERFORM C500-CALC-OFFSETS.
PERFORM C600-CREATE-SAS.
*
KDD *-------------------------
KDD * ARRAY DEBUGGING DISPLAYS
KDD *-------------------------
KDD * PERFORM VARYING WS-SUB FROM 1 BY 1
KDD * UNTIL WS-SUB > ARRAY-ELEMENTS
KDD * IF ARRAY-DATA-FIELD(WS-SUB) = 'Y' THEN
KDD * DISPLAY '-------------' WS-SUB ' --------------------'
KDD * DISPLAY ARRAY-WHOLE-LINE(WS-SUB)
KDD * DISPLAY 'LEVEL # ' ARRAY-LEVEL(WS-SUB)
KDD * ' DATA Y/N # ' ARRAY-DATA-FIELD(WS-SUB)
KDD * ' SAS NO # ' ARRAY-SAS-NO(WS-SUB)
KDD * DISPLAY 'FIELD NAME # ' ARRAY-FIELD-NAME(WS-SUB)
KDD * DISPLAY 'REDEFINE Y/N # ' ARRAY-REDEFINE(WS-SUB)
KDD * ' REDEF NAME # ' ARRAY-REDEFINE-NAME(WS-SUB)
KDD * DISPLAY 'FIELD TYPE # ' ARRAY-FIELD-TYPE(WS-SUB)
KDD * ' SIGNED # ' ARRAY-SIGNED(WS-SUB)
KDD * ' WHOLE # ' ARRAY-WHOLE(WS-SUB)
KDD * ' DECIMALS # ' ARRAY-DECIMALS(WS-SUB)
KDD * ' LENGTH # ' ARRAY-LENGTH(WS-SUB)
KDD * DISPLAY 'START POS # ' ARRAY-START-POS(WS-SUB)
KDD * ' CUM POS # ' ARRAY-CUM(WS-SUB)
KDD * DISPLAY 'NO OF OCCURS # ' ARRAY-NO-OF-OCCURS(WS-SUB)
KDD * ' OCCURS 1 2 3 # ' ARRAY-OCCURS-L1(WS-SUB) ' '
KDD * ARRAY-OCCURS-L2(WS-SUB) ' '
KDD * ARRAY-OCCURS-L3(WS-SUB) ' '
KDD * END-IF
KDD * END-PERFORM.
*
D005-CLOSE-COPYBOOK-FILE.
CLOSE COPY-FILE.
IF NOT ICOPY-OK
MOVE WS-FS-ICOPY TO WS-FILE-STATUS
MOVE 06 TO WS-ERROR-CODE
MOVE 'D005' TO WS-ABEND-SEC
MOVE 006 TO WS-ABEND-CODE
PERFORM Z000-ABEND
END-IF.
*
D999-EXIT.
EXIT.
*
R000-READ-COPYBOOK SECTION.
***************************************************************
* READ COPYBOOK
***************************************************************
*
MOVE 'N' TO WS-DATA-FOUND.
PERFORM UNTIL NOT WS-FS-ICOPY = '00' OR WS-DATA-FOUND = 'Y'
IF WS-FS-ICOPY = '00' THEN
PERFORM R100-READ
IF WS-FS-ICOPY = '00' THEN
IF COPY-REC(1:1) NOT = '*' AND
COPY-REC NOT = SPACES THEN
PERFORM C010-INITIALISE-FLAGS
PERFORM C200-SCAN-FOR-KEYS
MOVE 'Y' TO WS-DATA-FOUND
END-IF
END-IF
END-IF
END-PERFORM.
R999-EXIT.
EXIT.
*
R100-READ SECTION.
READ COPY-FILE.
MOVE SPACES TO COPY-REC.
MOVE ICOPY-REC(7:66) TO COPY-REC(1:66).
EXIT.
*
Z000-ABEND SECTION.
***************************************************************
* THIS IS THE ERROR HANDLER.
***************************************************************
DISPLAY '*************************************************'.
DISPLAY '*************************************************'.
DISPLAY '*** ***'.
DISPLAY '*** ABEND IN PARA ' WS-ABEND-SEC
' ***'.
DISPLAY '*** ***'.
DISPLAY '*** PROGRAM ZB**** IS ABENDING ***'.
DISPLAY '*** ***'.
DISPLAY WS-ERROR-TEXT (WS-ERROR-CODE).
DISPLAY '*** ***'.
IF WS-FILE-STATUS > ZEROES
DISPLAY '*** FILE STATUS : ' WS-FILE-STATUS
' ***'
END-IF.
DISPLAY '*** ***'.
DISPLAY '*** PROGRAM ZB**** IS ABENDING ***'.
DISPLAY '*** ***'.
DISPLAY '*************************************************'.
DISPLAY '*************************************************'.
CALL 'ABEND' USING WS-ABEND-CODE WS-DUMP-FLAG.
Z099-EXIT.
EXIT.
- rakeshsneha1212
- Posts: 30
- Joined: Thu Mar 30, 2017 2:09 pm
- Has thanked: 5 times
- Been thanked: 0 time
Re: COBOL file conversion to readable format
by enrico-sorichetti » Thu Apr 20, 2017 9:40 pm
please certify that the code posted does not infringe/violate any IP rights
cheers
enrico
When I tell somebody to RTFM or STFW I usually have the page open in another tab/window of my browser,
so that I am sure that the information requested can be reached with a very small effort
enrico
When I tell somebody to RTFM or STFW I usually have the page open in another tab/window of my browser,
so that I am sure that the information requested can be reached with a very small effort
- enrico-sorichetti
- Global moderator
- Posts: 3006
- Joined: Fri Apr 18, 2008 11:25 pm
- Has thanked: 0 time
- Been thanked: 165 times
Re: COBOL file conversion to readable format
by rakeshsneha1212 » Fri Apr 21, 2017 9:55 am
Hi Enrico,
It's all good from the code perspective. I have posted my code yesterday and now i see it as blank post any idea on this ??
Regards,
Rakesh MS
It's all good from the code perspective. I have posted my code yesterday and now i see it as blank post any idea on this ??
Regards,
Rakesh MS
- rakeshsneha1212
- Posts: 30
- Joined: Thu Mar 30, 2017 2:09 pm
- Has thanked: 5 times
- Been thanked: 0 time
Re: COBOL file conversion to readable format
by enrico-sorichetti » Fri Apr 21, 2017 11:19 am
It's all good from the code perspective.
You mean that the code is in the public domain and freely available ???
I have posted my code yesterday and now i see it as blank post any idea on this ??
I edited the post to use the code tags to make the source readable
but it looks like phpBB does not handle well large amounts of CODEd data
the code should be visible now
cheers
enrico
When I tell somebody to RTFM or STFW I usually have the page open in another tab/window of my browser,
so that I am sure that the information requested can be reached with a very small effort
enrico
When I tell somebody to RTFM or STFW I usually have the page open in another tab/window of my browser,
so that I am sure that the information requested can be reached with a very small effort
- enrico-sorichetti
- Global moderator
- Posts: 3006
- Joined: Fri Apr 18, 2008 11:25 pm
- Has thanked: 0 time
- Been thanked: 165 times
Return to All other Mainframe Topics
-
- Related topics
- Replies
- Views
- Last post
-
- FB to VB conversion in mainframe
by satlab » Fri Nov 14, 2008 3:45 am - 3 Replies
- 5087 Views
- Last post by dick scherrer
Sat Nov 15, 2008 7:19 am
- FB to VB conversion in mainframe
-
- Comp-3 fields Conversion
by naga821 » Wed Dec 07, 2022 11:45 am - 3 Replies
- 4512 Views
- Last post by sergeyken
Sat Dec 10, 2022 2:30 am
- Comp-3 fields Conversion
-
- Mainframe Date Format
by surferax » Sat Nov 01, 2008 8:16 pm - 4 Replies
- 4843 Views
- Last post by dick scherrer
Mon Nov 03, 2008 8:49 am
- Mainframe Date Format
-
- pdf cobol
1, 2by surime72 » Wed Dec 05, 2012 5:28 pm - 16 Replies
- 5925 Views
- Last post by Ed Goodman
Thu Dec 06, 2012 8:49 pm
- pdf cobol
-
- How to do this, Sort, DB2 or COBOL?
1, 2by bond_ajay » Tue Apr 22, 2008 4:36 pm - 11 Replies
- 6210 Views
- Last post by dick scherrer
Sat Apr 26, 2008 10:59 pm
- How to do this, Sort, DB2 or COBOL?