Picgen InputThis program converts a report image into COBOL working storage. It took less than a second to generate 220 lines of COBOL code using this program on an AMD K5 133 mhz computer. A very handy tool for a COBOL programmer!
********************************************************************
*** Program: PICGEN.Q ***
*** Purpose: Creates a file of COBOL working storage using info ***
*** in a report layout file. COBOL names are matched ***
*** to fields in the order in which they are defined ***
*** within the report layout file, from left to right, ***
*** top to bottom. There should be a one-for-one match ***
*** of COBOL names to fields. This program performs ***
*** no error checking whatsoever. ***
*** ***
*** To run.: Type ==> QUIKCODE PICGEN.Q filename ***
*** Where filename is the report layout file ***
*** to convert to COBOL pictures. See sample ***
*** report layout file, SAMPLE.RPT. ***
*** ***
*** Equates: NAME-FLAG - Defines the start of a COBOL field ***
*** name with a report layout file. ***
*** COBOL field names must not be placed ***
*** same line as fields. ***
*** REPORT-WIDTH - Sets the length of the COBOL ***
*** working-storage records to generate. ***
*** WORK-FILE - Work file name to create. This file ***
*** stores the COBOL field names found ***
*** in the report layout file. ***
*** PIC-FILE - Output file name to create. ***
*** ***
*** Fields.: The position of the field on a line determines its ***
*** position within the COBOL record. The valid field ***
*** types are: ***
*** X - Alphanumeric (PIC X). ***
*** 9 - Numeric (PIC 9). ***
*** Z - Numeric zero suppressed (PIC Z). ***
*** - - Numeric edited signed ***
*** + - Numeric edited signed ***
*** , - Numeric edited with commas. ***
*** MM/DD/YY - 05 DATE. ***
*** 10 DATE-MM PIC X(002). ***
*** 10 DATE-S1 PIC X(001) VALUE '/'. ***
*** 10 DATE-DD PIC X(002). ***
*** 10 DATE-S2 PIC X(001) VALUE '/'. ***
*** 10 DATE-YY PIC X(002). ***
*** MM/DD/YYYY - 05 DATE. ***
*** 10 DATE-MM PIC X(002). ***
*** 10 DATE-S1 PIC X(001) VALUE '/'. ***
*** 10 DATE-DD PIC X(002). ***
*** 10 DATE-S2 PIC X(001) VALUE '/'. ***
*** 10 DATE-YYYY PIC X(004). ***
*** HH:MM:SS - 05 TIME. ***
*** 10 TIME-HH PIC X(002). ***
*** 10 TIME-H1 PIC X(001) VALUE ':'. ***
*** 10 TIME-MM PIC X(002). ***
*** 10 TIME-H2 PIC X(001) VALUE ':'. ***
*** 10 TIME-SS PIC X(002). ***
*** HR:MN:SC - 05 TIME. ***
*** 10 TIME-HR PIC X(002). ***
*** 10 TIME-H1 PIC X(001) VALUE ':'. ***
*** 10 TIME-MN PIC X(002). ***
*** 10 TIME-H2 PIC X(001) VALUE ':'. ***
*** 10 TIME-SC PIC X(002). ***
*** Literal: Any text found within the report layout file that ***
*** is not a COBOL name or a field. To force two or ***
*** or more literals to be placed within one field, ***
*** place a tilde (~) characters between them. ***
*** For example: "REPORT~~~DATE" will generate... ***
*** "05 FILLER PIC X(13) VALUE 'REPORT DATE'." ***
********************************************************************
OPTION LIST = NO * DON'T LIST PROGRAM CODE
OPTION INCLUDE = 'COLORS.INC' * INCLUDE FILE OF SCREEN COLOR CODES
FASTVIDEO OFF * USE BIOS VIDEO CALLS (FOR COMPATIBILITY)
EQUATE REPORT-WIDTH TO 133 * EQU REPORT RECORD WIDTH
EQUATE NAME-FLAG TO '@' * EQU COBOL NAME FLAG
EQUATE WORK-FILE TO 'PICGEN.WRK' * EQU COBOL NAME WORK FILE
EQUATE PIC-FILE TO 'PICGEN.COB' * EQU COBOL PIC FILE
* PROGRAM SUBSCRIPTS
EQUATE SUB1 TO WST500-I * SUB1 IS SUBSCRIPT
EQUATE SUB2 TO WST502-I * SUB2 IS SUBSCRIPT
EQUATE HOLD-SUB TO WST504-I * HOLD-SUB IS SUBSCRIPT
* WORKING WHEEL AREA
EQUATE WORKING-WHEEL-TIMER TO WST506-I
EQUATE WORKING-WHEEL-SUB TO WST508-I
EQUATE WORKING-WHEEL-SPOKES TO WST101-104
EQUATE WORKING-WHEEL-SPOKE TO WST101
* PICGEN.WRK FILE AREA
EQUATE COBOL-NAME-LEN TO IFB1-2
EQUATE COBOL-NAME TO IFB4-33
EQUATE COBOL-NAME-1 TO IFB4
* WORKING STORAGE AREA
EQUATE BYTE-CNT TO WST1-3
EQUATE LINE-CNT TO WST4-5
EQUATE LITERAL TO WST7-60
EQUATE LITERAL-1 TO WST7-7
EQUATE LITERAL-2 TO WST8-8
EQUATE LITERAL-3 TO WST9-9
EQUATE LITERAL-DATE TO WST7-14
EQUATE LITERAL-DATEX TO WST7-16
EQUATE LITERAL-TIME TO WST7-14
* CLS * CLEAR VIDEO SCREEN
COLOR LTWHITE-ON-BLUE
DISPLAY PROG NOSKIP * DISPLAY WORKING MESSAGE
DISPLAY ' WORKING...'
MOVE '\|/-' TO WORKING-WHEEL-SPOKES
PERFORM 100 * GET COBOL FIELDS
PERFORM 200 * GENERATE COBOL PICTURE CLAUSES
DISPLAY
DISPLAY 'OUTPUT WRITTEN TO FILE ' NOSKIP
DISPLAY PIC-FILE
DISPLAY 'PRESS ANY KEY TO CONTINUE'
GETKEY WST1 WST1
SYSTEM 'EDIT PICGEN.COB'
END * TERMINATE PROGRAM
* GET COBOL FIELDS
100 OPEN IFA PARM1-20 251 1000 * OPEN BUFFERED (1000) INPUT FILE - IFA
OPEN OFB WORK-FILE 80 800 * OPEN BUFFERED (800) OUTPUT FILE - OFB
110 READ IFA AT EOF 149 * READ RECORD FROM INPUT FILE - IFA
MOVE 1 TO SUB1 * INITIALIZE SUBSCRIPT S1 TO 1
PERFORM WW * DISPLAY WORKING WHEEL
120 IF SUB1 >= REPORT-WIDTH * SUBSCRIPT SUB1 AT RECORD END?
GO TO 110. * YES, GO READ NEXT INPUT RECORD
IF IFA1-1 (SUB1) = ' ' * CURRENT BYTE IN RECORD A BLANK?
ADD 1 TO SUB1 * YES, ADD 1 TO SUBSCRIPT S1
GO TO 120. * GO CHECK NEXT BYTE IN RECORD
IF IFA1-1 (SUB1) = NAME-FLAG * CURRENT BYTE START OF COBOL FIELD NAME?
PERFORM 150 * YES, GET COBOL FIELD NAME AND LENGTHS ON LINE
WRITE OFB * WRITE OUTPUT RECORD - OFB
GO TO 120. * GO CHECK NEXT BYTE IN INPUT RECORD
GO TO 110 * GO READ NEXT INPUT RECORD
149 CLOSE IFA * CLOSE INPUT FILE
CLOSE OFB * CLOSE OUTPUT FILE
EXIT * RETURN TO CALLER
* GET LENGTH AND NAME OF COBOL FIELDS ON REPORT LINE
150 MOVE SPACES TO OFB * INITIALIZE OUTPUT RECORD - OFB
MOVE 4 TO SUB2 * INITIALIZE SUBSCRIPT S2 TO 4
ADD 1 TO SUB1 * BUMP SUBSCRIPT S1 UP BY 1
160 IF SUB1 > REPORT-WIDTH * SUBSCRIPT SUB1 BEYOND RECORD END?
OR SUB2 > 33 * OR... SUBSCRIPT S2 OVER 33?
OR IFA1 (SUB1) = ' ' * CURRENT BYTE IN RECORD A BLANK?
SUBTRACT 4 FROM SUB2 * YES, SUBSTRACT 4 FROM SUBSCRIPT SUB2
MOVE SUB2 TO OFB1-2 * MOVE COBOL NAME LENGTH TO OUTPUT RECORD
EXIT. * RETURN TO CALLER
MOVE IFA1 (SUB1) TO OFB1 (SUB2) * MOVE COBOL NAME BYTE TO OUTPUT RECORD
ADD 1 TO SUB1 * BUMP SUBSCRIPT S1 UP BY 1
ADD 1 TO SUB2 * BUMP SUBSCRIPT S2 UP BY 1
GO TO 160 * GO CHECK NEXT BYTE IN INPUT RECORD
199 EXIT * RETURN TO CALLER
* GENERATE COBOL PICTURE CLAUSES
200 OPEN IFA PARM1-20 251 1000 * OPEN BUFFERED (1000) INPUT FILE - IFA
OPEN IFB WORK-FILE 80 800 * OPEN BUFFERED (800) INPUT FILE - IFB
OPEN OFA PIC-FILE 80 800 * OPEN BUFFERED (800) OUTPUT FILE - OFA
210 READ IFA AT EOF 299 * READ INPUT FILE - IFA
MOVE 1 TO SUB1 * INITIALIZE SUBSCRIPT S1 TO 1
PERFORM WW * DISPLAY WORKING WHEEL
* BYPASS BLANK LINES AND LINES HAVING A COBOL FIELD NAME
220 IF SUB1 > REPORT-WIDTH * SUBSCRIPT S1 BEYOND REPORT WIDTH?
OR IFA1-1 (SUB1) = NAME-FLAG * CURRENT BYTE START OF COBOL FIELD NAME?
GO TO 210. * YES, GO READ NEXT INPUT RECORD
IF IFA1 (SUB1) IS SPACE * CURRENT BYTE IN RECORD A BLANK?
ADD 1 TO SUB1 * BUMP SUBSCRIPT S1 UP 1
GO TO 220. * GO CHECK NEXT BYTE IN INPUT RECORD
*
ADD 1 TO LINE-CNT * BUMP LINE COUNTER BY 1
MOVE SPACES TO OFA1-80 * INITIALIZE OUTPUT RECORD - OFA
WRITE OFA * WRITE OUTPUT FILE RECORD - OFA
MOVE '01 REPORT-LINE-NN.' TO OFA8
MOVE LINE-CNT TO OFA24-25
WRITE OFA * WRITE OUTPUT FILE RECORD- OFA
MOVE 1 TO SUB1 * SET SUBSCRIPT S1 TO 1
230 IF SUB1 > REPORT-WIDTH * SUBSCRIPT S1 BEYOND REPORT WIDTH?
GO TO 210. * YES, GO READ NEXT INPUT RECORD
MOVE SPACES TO OFA1-15
MOVE '05 FILLER PIC X(XXX)' TO OFA12-76
IF IFA1-1 (SUB1) IS SPACE * CURRENT INPUT
* PROCESS SPACES
PERFORM 500
GO TO 230.
* PROCESS NON-SPACES
PERFORM 600
GO TO 230
299 CLOSE OFA
EXIT
* PROCESS SPACES ROUTINE
500 MOVE ZEROS TO BYTE-CNT
510 IF SUB1 > REPORT-WIDTH
OR IFA1-1 (SUB1) <> ' '
IF IFA1-1 (SUB1) <> '~'
MOVE BYTE-CNT TO OFA52-54
MOVE 'VALUE SPACE.' TO OFA57
WRITE OFA
EXIT.
ADD 1 TO SUB1
ADD 1 TO BYTE-CNT
GO TO 510
599 EXIT
* PROCESS NON-SPACES ROUTINE
600 MOVE ZEROS TO BYTE-CNT
MOVE 1 TO SUB2
MOVE SPACES TO LITERAL
610 IF SUB1 > REPORT-WIDTH
OR IFA1-1 (SUB1) IS SPACES
MOVE BYTE-CNT TO OFA52-54
PERFORM 700
EXIT.
IF SUB2 > 45
IF LITERAL-2 <> 'X'
MOVE BYTE-CNT TO OFA52-54
PERFORM 700
EXIT.
IF IFA1-1 (SUB1) = '~'
MOVE SPACE TO IFA1-1 (SUB1).
MOVE IFA1-1 (SUB1) TO LITERAL-1 (SUB2)
ADD 1 TO SUB1
ADD 1 TO SUB2
ADD 1 TO BYTE-CNT
GO TO 610
699 EXIT
* WRITE LITERAL/COBOL FIELD
* CHECK FOR NUMERIC SIGNED EDITED FIELDS
700 IF LITERAL-1 = '-'
OR LITERAL-1 = '+'
IF LITERAL-2 = '9'
OR LITERAL-2 = 'Z'
OR LITERAL-2 = '+'
OR LITERAL-2 = '-'
OR LITERAL-2 = ','
PERFORM 800
EXIT.
* BYPASS LITERALS STARTING WITH AN 'X'
IF LITERAL-1 = 'X'
IF LITERAL-2 <> 'X'
IF LITERAL-2 <> ' '
GO TO 710.
* CHECK FOR ALL OTHER DEFINED FIELD TYPES
IF LITERAL-1 = '9'
OR LITERAL-1 = 'X'
OR LITERAL-1 = 'Z'
OR LITERAL-DATE = 'MM/DD/YY'
OR LITERAL-DATEX = 'MM/DD/YYYY'
OR LITERAL-TIME = 'HH:MM:SS'
OR LITERAL-TIME = 'HR:MN:SC'
PERFORM 800
EXIT.
710 IF BYTE-CNT <= 3
MOVE 'VALUE ' TO OFA57
MOVE "'" TO OFA63
MOVE BYTE-CNT TO SUB2
ADD 1 TO SUB2
MOVE "'" TO LITERAL-1 (SUB2)
ADD 1 TO SUB2
MOVE "." TO LITERAL-1 (SUB2)
MOVE LITERAL TO OFA64-76
WRITE OFA
EXIT.
WRITE OFA
MOVE SPACES TO OFA1-80
MOVE 'VALUE ' TO OFA15
MOVE "'" TO OFA21
MOVE BYTE-CNT TO SUB2
ADD 1 TO SUB2
MOVE "'" TO LITERAL-1 (SUB2)
ADD 1 TO SUB2
MOVE "." TO LITERAL-1 (SUB2)
MOVE LITERAL TO OFA22-76
WRITE OFA
799 EXIT
* PROCESS COBOL FIELD
800 MOVE '.' TO OFA56
810 IF IFB IS EOF
MOVE LITERAL TO OFA15-44
WRITE OFA
EXIT.
READ IFB AT EOF 810
GO TO 816
816 IF LITERAL-1 = 'X'
MOVE COBOL-NAME TO OFA15-44
WRITE OFA
EXIT.
IF LITERAL-DATE = 'MM/DD/YY'
PERFORM 900
EXIT.
IF LITERAL-TIME = 'HH:MM:SS'
OR LITERAL-TIME = 'HR:MN:SC'
PERFORM 950
EXIT.
IF LITERAL-1 = '9'
OR LITERAL-1 = 'Z'
OR LITERAL-1 = '+'
OR LITERAL-1 = '-'
MOVE COBOL-NAME TO OFA15-44
MOVE SPACES TO OFA50-55
MOVE '.' TO LITERAL-1 (SUB2)
MOVE LITERAL TO OFA50-76
WRITE OFA
EXIT.
899 EXIT
* FORMAT MM/DD/YY & MM/DD/YYYY DATE PICTURES
900 MOVE COBOL-NAME-LEN TO SUB2
ADD 1 TO SUB2
MOVE SUB2 TO HOLD-SUB
MOVE '.' TO COBOL-NAME-1 (SUB2)
MOVE COBOL-NAME TO OFA15-44
MOVE SPACES TO OFA45-76
WRITE OFA
MOVE SPACES TO OFA1-18
MOVE '10 PIC X(002).' TO OFA15-76
MOVE '-MM' TO COBOL-NAME-1 (SUB2)
ADD 2 TO SUB2
MOVE COBOL-NAME TO OFA18-44
WRITE OFA
MOVE HOLD-SUB TO SUB2
MOVE '10 PIC X(001)' TO OFA15-76
MOVE '-S1' TO COBOL-NAME-1 (SUB2)
MOVE "VALUE '/'." TO OFA57-66
ADD 2 TO SUB2
MOVE COBOL-NAME TO OFA18-44
WRITE OFA
MOVE HOLD-SUB TO SUB2
MOVE '10 PIC X(002).' TO OFA15-76
MOVE '-DD' TO COBOL-NAME-1 (SUB2)
ADD 2 TO SUB2
MOVE COBOL-NAME TO OFA18-44
WRITE OFA
MOVE HOLD-SUB TO SUB2
MOVE '10 PIC X(001)' TO OFA15-76
MOVE '-S2' TO COBOL-NAME-1 (SUB2)
MOVE "VALUE '/'." TO OFA57-66
ADD 2 TO SUB2
MOVE COBOL-NAME TO OFA18-44
WRITE OFA
MOVE HOLD-SUB TO SUB2
MOVE '10 PIC X(002).' TO OFA15-76
MOVE '-YY' TO COBOL-NAME-1 (SUB2)
ADD 2 TO SUB2
IF LITERAL-DATEX = 'MM/DD/YYYY'
MOVE '004' TO OFA52-54
ADD 1 TO SUB2
MOVE 'YY' TO COBOL-NAME-1 (SUB2)
ADD 1 TO SUB2.
MOVE COBOL-NAME TO OFA18-44
WRITE OFA
909 EXIT
* FORMAT HH:MM:SS & HR:MN:SC TIME PICTURES
950 MOVE COBOL-NAME-LEN TO SUB2
ADD 1 TO SUB2
MOVE SUB2 TO HOLD-SUB
MOVE '.' TO COBOL-NAME-1 (SUB2)
MOVE COBOL-NAME TO OFA15-44
MOVE SPACES TO OFA45-76
WRITE OFA
MOVE SPACES TO OFA1-18
MOVE '10 PIC X(002).' TO OFA15-76
MOVE '-HR' TO COBOL-NAME-1 (SUB2)
ADD 2 TO SUB2
MOVE COBOL-NAME TO OFA18-44
WRITE OFA
MOVE HOLD-SUB TO SUB2
MOVE '10 PIC X(001)' TO OFA15-76
MOVE '-H1' TO COBOL-NAME-1 (SUB2)
MOVE "VALUE ':'." TO OFA57-66
ADD 2 TO SUB2
MOVE COBOL-NAME TO OFA18-44
WRITE OFA
MOVE HOLD-SUB TO SUB2
MOVE '10 PIC X(002).' TO OFA15-76
MOVE '-MN' TO COBOL-NAME-1 (SUB2)
ADD 2 TO SUB2
MOVE COBOL-NAME TO OFA18-44
WRITE OFA
MOVE HOLD-SUB TO SUB2
MOVE '10 PIC X(001)' TO OFA15-76
MOVE '-H2' TO COBOL-NAME-1 (SUB2)
MOVE "VALUE ':'." TO OFA57-66
ADD 2 TO SUB2
MOVE COBOL-NAME TO OFA18-44
WRITE OFA
MOVE HOLD-SUB TO SUB2
MOVE '10 PIC X(002).' TO OFA15-76
MOVE '-SC' TO COBOL-NAME-1 (SUB2)
ADD 2 TO SUB2
MOVE COBOL-NAME TO OFA18-44
WRITE OFA
959 EXIT
* DISPLAY WORKING WHEEL - Informs the user the program is still running
WW: ADD 1 TO WORKING-WHEEL-TIMER
IF WORKING-WHEEL-TIMER < 2
EXIT.
ADD 1 TO WORKING-WHEEL-SUB
IF WORKING-WHEEL-SUB > 4
MOVE 1 TO WORKING-WHEEL-SUB.
CURSOR 1 20
DISPLAY WORKING-WHEEL-SPOKE (WORKING-WHEEL-SUB) NOSKIP
MOVE ZEROS TO WORKING-WHEEL-TIMER
EXIT
Click on the image to view the sample input file to this program
Click on the image to view the output file from this program
