000010 IDENTIFICATION DIVISION.
000020
000030 PROGRAM-ID. TB17P1.
000040 AUTHOR. TIMOTHY R P BROWN 494417.
000050 DATE-COMPILED. 20/11/2000.
000060
000070*****************************************************
000080** PROGRAM-1 **
000090** Program to read data file, validate records, **
000100** writing valid records to new file and printing **
000110** an error report of invalid records. **
000120*****************************************************
000130
000140 ENVIRONMENT DIVISION.
000150
000160 INPUT-OUTPUT SECTION.
000170 FILE-CONTROL.
000180 SELECT IN-FILE ASSIGN TO 'TB17TD.DAT'
000190 ORGANIZATION IS LINE SEQUENTIAL.
000200 SELECT VAL-FILE ASSIGN TO 'TB17VF.DAT'
000210 ORGANIZATION IS LINE SEQUENTIAL.
000220 SELECT PRINT-FILE ASSIGN TO 'printout1.txt'
000230 ORGANIZATION IS LINE SEQUENTIAL.
000240
000250*********************************************************
000260
000270 DATA DIVISION.
000280 FILE SECTION.
000290
000300 FD IN-FILE.
000310 01 IR-REC.
000320 03 IR-REC-TYPE PIC X.
000330 03 IR-CUS-CODE.
000340 05 IR-CUS-CODE-DIGITS PIC 9(4).
000350 05 IR-CUS-CODE-CHK PIC X.
000360 03 PART-NO.
000370 05 PART-NO-DIGITS PIC 9(5).
000380 05 PART-NO-CHK PIC X.
000390 03 IR-QUANTITY PIC 9(4).
000400
000410 01 D-REC.
000420 03 D-REC-TYPE PIC X.
000430 03 D-CUS-CODE.
000440 05 D-CUS-CODE-DIGITS PIC 9(4).
000450 05 D-CUS-CODE-CHK PIC X.
000460
000470 01 C-REC.
000480 03 C-REC-TYPE PIC X.
000490 03 C-CUS-CODE.
000500 05 C-CUS-CODE-DIGITS PIC 9(4).
000510 05 C-CUS-CODE-CHK PIC X.
000520 03 CUS-NAME PIC X(20).
000530 03 CUS-ADDRESS PIC X(60).
000540 03 CUS-BALANCE PIC S9(7)V99.
000550 03 CUS-CRED-LIMIT PIC 9(7).
000560
000570 01 UNKNOWN-REC.
000580 03 X-REC-TYPE PIC X.
000590 03 X-CUS-CODE PIC X(5).
000600 03 UNKNOWN-FIELDS PIC X(96).
000610
000620 FD VAL-FILE.
000630 01 OUT-REC PIC X(102).
000640
000650 FD PRINT-FILE.
000660 01 PRINT-LINE PIC X(124).
000670
000680*********************************************************
000690
000700 WORKING-STORAGE SECTION.
000710
000720* Temporary storage of record
000730 01 W-IN-REC.
000740 03 REC-TYPE PIC X.
000750 03 CUS-CODE.
000760 05 CUS-CODE-DIGITS PIC 9(4).
000770 05 CUS-CODE-CHK PIC X.
000780 03 PIC X(5).
000790 03 W-PART-NO PIC X.
000800 03 PIC X(90).
000810
000820* Flags
000830 01 EOF-FLAG PIC X.
000840 88 END-OF-IN-FILE VALUE 'Y'.
000850
000860 01 INVALID-REC-FLAG PIC X VALUE 'N'.
000870 88 INVALID-REC VALUE 'Y'.
000880
000890 01 CUS-CODE-NOTNUMERIC-FLAG PIC X VALUE 'N'.
000900 88 CUS-CODE-NOT-NUMERIC VALUE 'Y'.
000910
000920 01 CUS-CODE-MOD-FLAG PIC X VALUE 'N'.
000930 88 CUS-CODE-MOD-FAIL VALUE 'Y'.
000940
000950 01 PART-NO-NOTNUMERIC-FLAG PIC X VALUE 'N'.
000960 88 PART-NO-NOT-NUMERIC VALUE 'Y'.
000970
000980 01 PART-NO-MOD-FLAG PIC X VALUE 'N'.
000990 88 PART-NO-MOD-FAIL VALUE 'Y'.
001000
001010 01 IR-QUANT-NOTNUMERIC-FLAG PIC X VALUE 'N'.
001020 88 IR-QUANT-NOT-NUMERIC VALUE 'Y'.
001030
001040 01 NO-NAME-FLAG PIC X VALUE 'N'.
001050 88 NO-NAME VALUE 'Y'.
001060
001070 01 NO-ADDRESS-FLAG PIC X VALUE 'N'.
001080 88 NO-ADDRESS VALUE 'Y'.
001090
001100 01 CUS-BALANCE-NOTNUMERIC-FLAG PIC X VALUE 'N'.
001110 88 CUS-BALANCE-NOT-NUMERIC VALUE 'Y'.
001120
001130 01 CRED-LIMIT-NOTNUMERIC-FLAG PIC X VALUE 'N'.
001140 88 CRED-LIMIT-NOT-NUMERIC VALUE 'Y'.
001150
001160 01 NOT-REC-TYPE-FLAG PIC X VALUE 'N'.
001170 88 NOT-REC-TYPE VALUE 'Y'.
001180
001190 01 REC-TYPE-FLAG PIC X VALUE SPACE.
001200 88 IR-TYPE VALUE 'I' 'R'.
001210 88 D-TYPE VALUE 'D'.
001220 88 C-TYPE VALUE 'C'.
001230
001240* Pseudo-flag
001250 01 MOD-FLAG PIC X VALUE 'N'.
001260
001270* Counters and subscripts
001280 01 W-PAGE-NO PIC 99 VALUE ZERO.
001290 01 W-LINE-NO PIC 99 VALUE ZERO.
001300 01 W-REC-COUNT PIC 9(4) VALUE ZERO.
001310 01 W-ERR-REC-COUNT PIC 9999 VALUE ZERO.
001320 01 SUBS-NO PIC 99.
001330
001340* Modulo check items
001350 01 MOD-DIGIT-SIZE PIC 9.
001360 01 W-WEIGHT PIC 9.
001370 01 MOD-CHK PIC X.
001380 01 W-PRODUCT PIC 99.
001390 01 W-SUM PIC 999.
001400 01 W-REM PIC 99.
001410 01 W-CHK.
001420 03 W-CHK-NO PIC 9.
001430 01 CC-DIGITS.
001440 03 CC-TABLE PIC 9 OCCURS 4.
001450 01 PN-DIGITS.
001460 03 PN-TABLE PIC 9 OCCURS 5.
001470 01 CC-WEIGHT-TAB VALUE '5432'.
001480 03 CC-WEIGHTS PIC 9 OCCURS 4.
001490 01 PN-WEIGHT-TAB VALUE '65432'.
001500 03 PN-WEIGHTS PIC 9 OCCURS 5.
001510
001520* Miscellaneous items
001530 01 DATE-IN.
001540 03 DOS-YEAR PIC 99.
001550 03 DOS-MONTH PIC 99.
001560 03 DOS-DAY PIC 99.
001570 01 ANY-ADDRESS PIC X(60) VALUE SPACES.
001580
001590* Print items
001600 01 P-BLANK-LINE PIC X VALUE SPACE.
001610 01 P-UNDERLINE PIC X(122) VALUE ALL '-'.
001620
001630 01 P-TITLE-1.
001640 03 PIC X(20) VALUE SPACES.
001650 03 PIC X(13) VALUE 'ZENITH PAINTS'.
001660 01 P-TITLE-2.
001670 03 PIC X(14) VALUE SPACES.
001680 03 PIC X(58)
001690 VALUE 'TRANSACTION FILE ERROR REPORT (Program 1 output)'.
001700 03 PIC X(6) VALUE 'DATE: '.
001710 03 DOS-DAY PIC 99.
001720 03 PIC X VALUE '/'.
001730 03 DOS-MONTH PIC 99.
001740 03 PIC X VALUE '/'.
001750 03 DOS-YEAR PIC 99.
001760
001770 01 P-PAGE-NO-HEAD.
001780 03 PIC X(7) VALUE ' PAGE '.
001790 03 P-PAGE-NO PIC ZZ9.
001800 01 P-HEADING-1.
001810 03 PIC X(5) VALUE SPACES.
001820 03 PIC X(92) VALUE
001830 'RECORD CUSTOMER PART ISSUE/RECEIPT'.
001840 03 PIC X(25) VALUE
001850 'CUSTOMER CREDIT ERROR'.
001860 01 P-HEADING-2.
001870 03 PIC X(6) VALUE SPACES.
001880 03 PIC X(61) VALUE
001890 'TYPE CODE NO QUANTITY NAME'.
001900 03 PIC X(30) VALUE 'ADDRESS'.
001910 03 PIC X(25) VALUE
001920 'BALANCE(£) LIMIT(£) CODES'.
001930
001940 01 P-RECORD.
001950 03 PIC X(7) VALUE SPACES.
001960 03 P-REC-TYPE PIC X.
001970 03 PIC X(5) VALUE SPACES.
001980 03 P-CUS-CODE PIC X(5).
001990 03 PIC X(4) VALUE SPACES.
002000 03 P-PART-NO PIC X(6).
002010 03 PIC X(4) VALUE SPACES.
002020 03 P-IRQUANT-NN.
002030 05 P-IR-QUANTITY PIC ZZZ9 BLANK WHEN ZERO.
002040 03 PIC X(7) VALUE SPACES.
002050 03 P-CUS-NAME PIC X(20).
002060 03 PIC X(2) VALUE SPACES.
002070 03 P-CUS-ADDRESS PIC X(30).
002080 03 PIC X VALUE SPACES.
002090 03 P-CUSBAL-NN.
002100 05 P-CUS-BALANCE PIC -(6)9.99 BLANK WHEN ZERO.
002110 03 PIC X VALUE SPACES.
002120 03 P-CUSCREDLIM-NN.
002130 05 P-CUS-CRED-LIMIT PIC -(6)9 BLANK WHEN ZERO.
002140 03 PIC XXXX VALUE SPACES.
002150 03 P-ERR-CODE.
002160 05 ERR-CODE PIC X OCCURS 4.
002170
002180 01 P-UNKNOWN-RECORD.
002190 03 PIC X(7) VALUE SPACES.
002200 03 P-REC-TYPE-X PIC X.
002210 03 PIC X(5) VALUE SPACES.
002220 03 P-CUS-CODE-X PIC X(5).
002230 03 PIC X(4) VALUE SPACES.
002240 03 P-UNKNOWN-FIELDS PIC X(89).
002250 03 PIC X(7) VALUE SPACES.
002260 03 P-ERR-CODE-X PIC X VALUE 'U'.
002270
002280 01 P-REC-TOTAL.
002290 03 PIC X(25) VALUE
002300 ' TOTAL RECORDS READ: '.
002310 03 P-REC-COUNT PIC ZZZ9.
002320
002330 01 P-ERR-REC-TOTAL.
002340 03 PIC X(26) VALUE
002350 ' TOTAL ERROR RECORDS: '.
002360 03 P-ERR-REC-COUNT PIC ZZZ9.
002370
002380 01 P-KEY-LINES.
002390 03 P-KEY-1 PIC X(47) VALUE
002400 ' KEY: I = ISSUE RECORD; R = RECEIPT RECORD;'.
002410 03 P-KEY-2 PIC X(51) VALUE
002420 ' D = DELETION RECORD; C = CREATION RECORD.'.
002430
002440 01 P-CODE-LINES.
002450 03 CODES-1 PIC X(17) VALUE
002460 ' ERROR CODES:'.
002470 03 CODES-2 PIC X(34) VALUE
002480 ' 1 = CUSTOMER CODE NON-NUMERIC'.
002490 03 CODES-3 PIC X(39) VALUE
002500 ' 2 = CUSTOMER CODE CHECK DIGIT FAIL'.
002510 03 CODES-4 PIC X(35) VALUE
002520 ' 3 = PART NUMBER IS NON-NUMERIC'.
002530 03 CODES-5 PIC X(37) VALUE
002540 ' 4 = PART NUMBER CHECK DIGIT FAIL'.
002550 03 CODES-6 PIC X(43) VALUE
002560 ' 5 = ISSUE/RECEIPT QUANTITY NOT NUMERIC'.
002570 03 CODES-7 PIC X(30) VALUE
002580 ' 6 = CUSTOMER NAME MISSING'.
002590 03 CODES-8 PIC X(34) VALUE
002600 ' 7 = CUSTOMER ADDRESS MISSING'.
002610 03 CODES-9 PIC X(37) VALUE
002620 ' 8 = CUSTOMER BALANCE NOT NUMERIC'.
002630 03 CODES-10 PIC X(42) VALUE
002640 ' 9 = CUSTOMER CREDIT LIMIT NOT NUMERIC'.
002650 03 CODES-11 PIC X(33) VALUE
002660 ' U = UNRECOGNISED RECORD TYPE'.
002670
002680 01 P-END-MESSAGE PIC X(33) VALUE
002690 ' *** END OF REPORT ***'.
002700
002710* End of Data Division
002720*********************************************************
002730*********************************************************
002740
002750 PROCEDURE DIVISION.
002760
002770 CONTROL-PARAGRAPH.
002780
002790 PERFORM INITIAL-PARAGRAPH
002800 PERFORM MAIN-PROCESS UNTIL END-OF-IN-FILE
002810 PERFORM TERMINATING-PARAGRAPH
002820 STOP RUN.
002830
002840*********************************************************
002850
002860 INITIAL-PARAGRAPH.
002870* Paragraph to open files, print report titles,
002880* and initial read of in-file
002890
002900 OPEN INPUT IN-FILE
002910 OUTPUT VAL-FILE, PRINT-FILE
002920
002930*--- print titles and headers on error report -----*
002940 ACCEPT DATE-IN FROM DATE
002950 MOVE CORRESPONDING DATE-IN TO P-TITLE-2
002960 WRITE PRINT-LINE FROM P-TITLE-1 AFTER PAGE
002970 WRITE PRINT-LINE FROM P-TITLE-2 AFTER 2 LINES
002980 PERFORM PRINT-HEADERS
002990
003000*--- prime read -----*
003010 READ IN-FILE INTO W-IN-REC
003020 AT END MOVE 'Y' TO EOF-FLAG
003030 NOT AT END
003040 ADD 1 TO W-REC-COUNT
003050 PERFORM MAKE-CHARS-UPPCASE
003060 MOVE REC-TYPE TO REC-TYPE-FLAG
003070 END-READ.
003080
003090*********************************************************
003100
003110 PRINT-HEADERS.
003120* Paragraph to print page number and column headers
003130
003140 ADD 1 TO W-PAGE-NO
003150 MOVE W-PAGE-NO TO P-PAGE-NO
003160 WRITE PRINT-LINE FROM P-PAGE-NO-HEAD AFTER 2 LINES
003170 WRITE PRINT-LINE FROM P-HEADING-1 AFTER 2 LINES
003180 WRITE PRINT-LINE FROM P-HEADING-2 AFTER 1 LINE
003190 WRITE PRINT-LINE FROM P-UNDERLINE AFTER 1 LINE
003200 MOVE ZERO TO W-LINE-NO.
003210
003220*********************************************************
003230
003240 MAIN-PROCESS.
003250* Paragraph to process sucessive records from input file
003260
003270 PERFORM VALIDATE-FIELDS
003280
003290*--- returned validity flag to be tested -----*
003300 IF INVALID-REC
003310 THEN PERFORM PRINT-ERROR-RECORD
003320 ELSE
003330 WRITE OUT-REC FROM W-IN-REC
003340 END-IF
003350
003360*--- reset all validity flags -----*
003370 MOVE 'N' TO INVALID-REC-FLAG
003380 CUS-CODE-NOTNUMERIC-FLAG
003390 CUS-CODE-MOD-FLAG
003400 PART-NO-NOTNUMERIC-FLAG
003410 PART-NO-MOD-FLAG
003420 IR-QUANT-NOTNUMERIC-FLAG
003430 NO-NAME-FLAG
003440 NO-ADDRESS-FLAG
003450 CUS-BALANCE-NOTNUMERIC-FLAG
003460 CRED-LIMIT-NOTNUMERIC-FLAG
003470 NOT-REC-TYPE-FLAG
003480 INITIALIZE W-IN-REC
003490
003500*--- read next record -----*
003510 READ IN-FILE INTO W-IN-REC
003520 AT END MOVE 'Y' TO EOF-FLAG
003530 NOT AT END
003540 ADD 1 TO W-REC-COUNT
003550 PERFORM MAKE-CHARS-UPPCASE
003560 MOVE REC-TYPE TO REC-TYPE-FLAG
003570 END-READ.
003580
003590*********************************************************
003600
003610 MAKE-CHARS-UPPCASE.
003620* Paragraph to convert any lower-case characters to upper-case
003630
003640 EVALUATE REC-TYPE
003650 WHEN 'i' MOVE 'I' TO REC-TYPE
003660 WHEN 'r' MOVE 'R' TO REC-TYPE
003670 WHEN 'd' MOVE 'D' TO REC-TYPE
003680 WHEN 'c' MOVE 'C' TO REC-TYPE
003690 END-EVALUATE
003700
003710 IF CUS-CODE-CHK = 'x' THEN
003720 MOVE 'X' TO CUS-CODE-CHK
003730 END-IF
003740
003750 IF ((REC-TYPE = 'I') OR (REC-TYPE = 'R'))
003760 AND ( PART-NO-CHK = 'x' ) THEN
003770 MOVE 'X' TO PART-NO-CHK W-PART-NO
003780 END-IF.
003790
003800*********************************************************
003810
003820 VALIDATE-FIELDS.
003830* Paragraph to examine each record field
003840* and return a valid or invalid record flag.
003850* Also set individual flags for each field.
003860
003870*--- test customer code for all record types -----*
003880 IF CUS-CODE-DIGITS NOT NUMERIC THEN
003890 MOVE 'Y' TO CUS-CODE-NOTNUMERIC-FLAG
003900 ELSE
003910 MOVE 4 TO MOD-DIGIT-SIZE
003920 MOVE CUS-CODE-DIGITS TO CC-DIGITS
003930 MOVE CUS-CODE-CHK TO MOD-CHK
003940 PERFORM MOD-CHECK
003950 MOVE MOD-FLAG TO CUS-CODE-MOD-FLAG
003960 END-IF
003970
003980*--- test record type specific fields -----*
003990 EVALUATE TRUE
004000
004010*------- issue or receipt record -----*
004020 WHEN IR-TYPE
004030 IF PART-NO-DIGITS NOT NUMERIC THEN
004040 MOVE 'Y' TO PART-NO-NOTNUMERIC-FLAG
004050 ELSE
004060 MOVE 5 TO MOD-DIGIT-SIZE
004070 MOVE PART-NO-DIGITS TO PN-DIGITS
004080 MOVE PART-NO-CHK TO MOD-CHK
004090 PERFORM MOD-CHECK
004100 MOVE MOD-FLAG TO PART-NO-MOD-FLAG
004110 END-IF
004120
004130 IF IR-QUANTITY NOT NUMERIC THEN
004140 MOVE 'Y' TO IR-QUANT-NOTNUMERIC-FLAG
004150 END-IF
004160
004170*------- creation type record -----*
004180 WHEN C-TYPE
004190*----------- test name field to ensure a name is present ---*
004200 IF CUS-NAME = SPACES THEN
004210 MOVE 'Y' TO NO-NAME-FLAG
004220 END-IF
004230
004240*----------- test address field to ensure one is present ---*
004250*----------- having first removed any ';' delimiters -------*
004260 MOVE CUS-ADDRESS TO ANY-ADDRESS
004270 INSPECT ANY-ADDRESS REPLACING ALL ';' BY ' '
004280 IF ANY-ADDRESS = SPACES THEN
004290 MOVE 'Y' TO NO-ADDRESS-FLAG
004300 END-IF
004310
004320 IF CUS-BALANCE NOT NUMERIC THEN
004330 MOVE 'Y' TO CUS-BALANCE-NOTNUMERIC-FLAG
004340 END-IF
004350 IF CUS-CRED-LIMIT NOT NUMERIC THEN
004360 MOVE 'Y' TO CRED-LIMIT-NOTNUMERIC-FLAG
004370 END-IF
004380
004390*------- unrecognised record type -----*
004400 WHEN NOT D-TYPE
004410 MOVE 'Y' TO NOT-REC-TYPE-FLAG
004420
004430 END-EVALUATE
004440
004450*--- test all field flags to set main record flag -----*
004460 IF CUS-CODE-NOT-NUMERIC OR CUS-CODE-MOD-FAIL OR
004470 PART-NO-NOT-NUMERIC OR PART-NO-MOD-FAIL OR
004480 IR-QUANT-NOT-NUMERIC OR NO-NAME OR
004490 NO-ADDRESS OR CUS-BALANCE-NOT-NUMERIC OR
004500 CRED-LIMIT-NOT-NUMERIC OR NOT-REC-TYPE
004510 THEN
004520 MOVE 'Y' TO INVALID-REC-FLAG
004530 ADD 1 TO W-ERR-REC-COUNT
004540 END-IF.
004550
004560*********************************************************
004570
004580 MOD-CHECK.
004590* Paragraph to perform modulo 11 test on required fields
004600
004610 MOVE ZERO TO W-SUM
004620
004630 IF MOD-DIGIT-SIZE = 4 THEN
004640*------ calculate sum of products loop for 4 digit number -----*
004650 PERFORM VARYING SUBS-NO FROM 1 BY 1
004660 UNTIL SUBS-NO > MOD-DIGIT-SIZE
004670 MULTIPLY CC-WEIGHTS (SUBS-NO)
004680 BY CC-TABLE (SUBS-NO)
004690 GIVING W-PRODUCT
004700 ADD W-PRODUCT TO W-SUM
004710 END-PERFORM
004720
004730 ELSE
004740*------ calculate sum of products loop for 5 digit number -----*
004750 PERFORM VARYING SUBS-NO FROM 1 BY 1
004760 UNTIL SUBS-NO > MOD-DIGIT-SIZE
004770 MULTIPLY PN-WEIGHTS (SUBS-NO)
004780 BY PN-TABLE (SUBS-NO)
004790 GIVING W-PRODUCT
004800 ADD W-PRODUCT TO W-SUM
004810 END-PERFORM
004820
004830 END-IF
004840
004850 DIVIDE W-SUM BY 11 GIVING W-SUM REMAINDER W-REM
004860*--- set calculated check digit -----*
004870 IF W-REM > 1 THEN
004880 SUBTRACT W-REM FROM 11 GIVING W-CHK-NO
004890 ELSE
004900 IF W-REM = 1 THEN MOVE ZERO TO W-CHK-NO
004910 ELSE MOVE 'X' TO W-CHK
004920 END-IF
004930 END-IF
004940
004950*--- compare calculated mod check digit to that in record ----*
004960 IF W-CHK NOT = MOD-CHK
004970 THEN MOVE 'Y' TO MOD-FLAG
004980 ELSE
004990 MOVE 'N' TO MOD-FLAG
005000 END-IF.
005010
005020*********************************************************
005030
005040 PRINT-ERROR-RECORD.
005050* Paragraph to print records that contain errors
005060
005070 MOVE REC-TYPE TO P-REC-TYPE
005080 MOVE CUS-CODE TO P-CUS-CODE
005090
005100*--- set appropriate print fields for I and R record types---*
005110 IF IR-TYPE THEN
005120 PERFORM SET-IR-PRINT
005130 ELSE
005140 MOVE ZEROS TO P-IR-QUANTITY
005150 MOVE SPACES TO P-PART-NO
005160 END-IF
005170
005180*--- set appropriate print fields for D record type-----*
005190 IF D-TYPE THEN
005200 MOVE ALL '-' TO P-CUS-NAME P-CUS-ADDRESS
005210 END-IF
005220
005230*--- set appropriate print fields for C record type-----*
005240 IF C-TYPE THEN
005250 PERFORM SET-C-PRINT
005260 END-IF
005270
005280 PERFORM SET-ERROR-CODES
005290
005300*--- When unrecognised record type, print only customer code --*
005310*--- and remaining unprocessed fields (if any) alongside. -----*
005320 IF NOT-REC-TYPE THEN
005330 PERFORM PRINT-TYPE-X
005340 ELSE
005350*------ print recognised record line of report -----*
005360 WRITE PRINT-LINE FROM P-RECORD
005370 END-IF
005380
005390 ADD 1 TO W-LINE-NO
005400*--- test for end of page ----*
005410 IF W-LINE-NO > 50 THEN
005420 WRITE PRINT-LINE FROM P-BLANK-LINE AFTER PAGE
005430 PERFORM PRINT-HEADERS
005440 END-IF.
005450
005460*********************************************************
005470
005480 SET-IR-PRINT.
005490* Paragraph to set I and R type print fields
005500
005510 MOVE PART-NO TO P-PART-NO
005520
005530 IF IR-QUANTITY NOT NUMERIC THEN
005540 MOVE IR-QUANTITY TO P-IRQUANT-NN
005550 ELSE
005560 MOVE IR-QUANTITY TO P-IR-QUANTITY
005570 END-IF
005580
005590 MOVE ALL '-' TO P-CUS-NAME P-CUS-ADDRESS
005600 MOVE ZEROS TO P-CUS-BALANCE P-CUS-CRED-LIMIT.
005610
005620
005630*********************************************************
005640
005650 SET-C-PRINT.
005660* Paragraph to set C type print fields
005670
005680 MOVE CUS-NAME TO P-CUS-NAME
005690 MOVE CUS-ADDRESS TO P-CUS-ADDRESS
005700
005710 IF CUS-BALANCE-NOT-NUMERIC THEN
005720 MOVE CUS-BALANCE TO P-CUSBAL-NN
005730 ELSE
005740 MOVE CUS-BALANCE TO P-CUS-BALANCE
005750 END-IF
005760
005770 IF CRED-LIMIT-NOT-NUMERIC THEN
005780 MOVE CUS-CRED-LIMIT TO P-CUSCREDLIM-NN
005790 ELSE
005800 MOVE CUS-CRED-LIMIT TO P-CUS-CRED-LIMIT
005810 END-IF.
005820
005830*********************************************************
005840
005850 PRINT-TYPE-X.
005860* Paragraph to print unrecognised record type and
005870* ignoring any blank lines in transaction file
005880
005890 IF (W-IN-REC NOT = SPACES)
005900 THEN
005910 MOVE UNKNOWN-FIELDS TO P-UNKNOWN-FIELDS
005920 MOVE REC-TYPE TO P-REC-TYPE-X
005930 MOVE CUS-CODE TO P-CUS-CODE-X
005940
005950 WRITE PRINT-LINE FROM P-UNKNOWN-RECORD
005960 ELSE SUBTRACT 1 FROM W-REC-COUNT W-ERR-REC-COUNT
005970 END-IF.
005980
005990*********************************************************
006000
006010 SET-ERROR-CODES.
006020* Paragraph to move appropriate error code(s) to print line
006030
006040*--- space-fill error code table -----*
006050 MOVE ALL SPACES TO P-ERR-CODE
006060 MOVE 1 TO SUBS-NO
006070
006080*--- place required code into error code table -----*
006090 IF CUS-CODE-NOT-NUMERIC THEN
006100 MOVE '1' TO ERR-CODE (SUBS-NO)
006110 ADD 1 TO SUBS-NO
006120 END-IF
006130
006140 IF CUS-CODE-MOD-FAIL THEN
006150 MOVE '2' TO ERR-CODE (SUBS-NO)
006160 ADD 1 TO SUBS-NO
006170 END-IF
006180
006190 IF PART-NO-NOT-NUMERIC THEN
006200 MOVE '3' TO ERR-CODE (SUBS-NO)
006210 ADD 1 TO SUBS-NO
006220 END-IF
006230
006240 IF PART-NO-MOD-FAIL THEN
006250 MOVE '4' TO ERR-CODE (SUBS-NO)
006260 ADD 1 TO SUBS-NO
006270 END-IF
006280
006290 IF IR-QUANT-NOT-NUMERIC THEN
006300 MOVE '5' TO ERR-CODE (SUBS-NO)
006310 ADD 1 TO SUBS-NO
006320 END-IF
006330
006340 IF NO-NAME THEN
006350 MOVE '6' TO ERR-CODE (SUBS-NO)
006360 ADD 1 TO SUBS-NO
006370 END-IF
006380
006390 IF NO-ADDRESS THEN
006400 MOVE '7' TO ERR-CODE (SUBS-NO)
006410 ADD 1 TO SUBS-NO
006420 END-IF
006430
006440 IF CUS-BALANCE-NOT-NUMERIC THEN
006450 MOVE '8' TO ERR-CODE (SUBS-NO)
006460 ADD 1 TO SUBS-NO
006470 END-IF
006480
006490 IF CRED-LIMIT-NOT-NUMERIC THEN
006500 MOVE '9' TO ERR-CODE (SUBS-NO)
006510 ADD 1 TO SUBS-NO
006520 END-IF.
006530
006540
006550*********************************************************
006560
006570 TERMINATING-PARAGRAPH.
006580* Paragraph to print abbreviation key, error code guide
006590* record total, error record total and ending message
006600* and close files.
006610
006620 MOVE W-REC-COUNT TO P-REC-COUNT
006630 MOVE W-ERR-REC-COUNT TO P-ERR-REC-COUNT
006640
006650 IF W-LINE-NO > 36 THEN
006660 WRITE PRINT-LINE FROM P-BLANK-LINE AFTER PAGE
006670 END-IF
006680
006690 WRITE PRINT-LINE FROM P-UNDERLINE AFTER 1 LINE
006700 WRITE PRINT-LINE FROM P-REC-TOTAL AFTER 2 LINES
006710 WRITE PRINT-LINE FROM P-ERR-REC-TOTAL AFTER 1 LINE
006720 WRITE PRINT-LINE FROM P-KEY-1 AFTER 2 LINES
006730 WRITE PRINT-LINE FROM P-KEY-2 AFTER 1 LINE
006740 WRITE PRINT-LINE FROM CODES-1 AFTER 2 LINES
006750 WRITE PRINT-LINE FROM CODES-2 AFTER 1 LINE
006760 WRITE PRINT-LINE FROM CODES-3
006770 WRITE PRINT-LINE FROM CODES-4
006780 WRITE PRINT-LINE FROM CODES-5
006790 WRITE PRINT-LINE FROM CODES-6
006800 WRITE PRINT-LINE FROM CODES-7
006810 WRITE PRINT-LINE FROM CODES-8
006820 WRITE PRINT-LINE FROM CODES-9
006830 WRITE PRINT-LINE FROM CODES-10
006840 WRITE PRINT-LINE FROM CODES-11
006850 WRITE PRINT-LINE FROM P-END-MESSAGE AFTER 3 LINES.
006860
006870 CLOSE IN-FILE VAL-FILE PRINT-FILE.
006880
006890
006900******************************************************
006910** **
006920** END OF PROGRAM-1 **
006930** **
006940******************************************************
006950
006960****************************************************************
006970* ERROR CODES:
006980*
006990* 1 = CUSTOMER CODE NON-NUMERIC
007000* 2 = CUSTOMER CODE CHECK DIGIT FAIL
007010* 3 = PART NUMBER NON-NUMERIC
007020* 4 = PART NUMBER CHECK DIGIT FAIL
007030* 5 = ISSUE/RECEIPT QUANTITY NOT NUMERIC
007040* 6 = CUSTOMER BALANCE NOT NUMERIC
007050* 7 = CUSTOMER NAME MISSING
007060* 8 = CUSTOMER ADDRESS MISSING
007070* 9 = CUSTOMER CREDIT LIMIT NOT NUMERIC
007080* U = UNRECOGNISED RECORD TYPE
007090****************************************************************
|