000010 IDENTIFICATION DIVISION.
000020 PROGRAM-ID. TB17P2.
000030 AUTHOR. TIMOTHY R P BROWN 494417.
000040 DATE-COMPILED. 16-11-2000.
000050
000060*******************************************************
000070** PROGRAM-2 **
000080** Program to sort validated records from TB17VF.DAT **
000090** into TB17SD.DAT and print sorted records. **
000100*******************************************************
000110
000120 ENVIRONMENT DIVISION.
000130 INPUT-OUTPUT SECTION.
000140 FILE-CONTROL.
000150 SELECT IN-FILE ASSIGN TO 'A:TB17VF.DAT'
000160 ORGANIZATION IS LINE SEQUENTIAL.
000170 SELECT SORTED-FILE ASSIGN TO 'A:TB17SD.DAT'
000180 ORGANIZATION IS LINE SEQUENTIAL.
000190 SELECT WORK-FILE ASSIGN TO 'WORK-FILE.DAT'.
000200 SELECT PRINT-FILE ASSIGN TO PRINTER.
000210
000220
000230*******************************************************
000240
000250 DATA DIVISION.
000260 FILE SECTION.
000270
000280 FD IN-FILE.
000290 01 UNSORTED-REC-IN.
000300 03 PIC X.
000310 03 IN-CUS-CODE PIC 9(4).
000320 03 PIC X(97).
000330
000340 FD SORTED-FILE.
000350 01 IR-REC.
000360 03 IR-REC-TYPE PIC X.
000370 03 IR-CUS-CODE PIC X(5).
000380 03 PART-NO PIC X(6).
000390 03 IR-QUANTITY PIC 9(4).
000400
000410 01 D-REC.
000420 03 D-REC-TYPE PIC X.
000430 03 D-CUS-CODE PIC X(5).
000440
000450 01 C-REC.
000460 03 C-REC-TYPE PIC X.
000470 03 C-CUS-CODE PIC X(5).
000480 03 CUS-NAME PIC X(20).
000490 03 CUS-ADDRESS PIC X(60).
000500 03 CUS-BALANCE PIC S9(7)V99.
000510 03 CUS-CRED-LIMIT PIC 9(7).
000520
000530 SD WORK-FILE.
000540 01 WORK-REC.
000550 03 REC-TYPE-KEY PIC X.
000560 03 CUS-CODE-KEY PIC 9(4).
000570 03 PIC X(97).
000580
000590
000600 FD PRINT-FILE.
000610 01 PRINT-LINE PIC X(130).
000620
000630
000640*******************************************************
000650
000660 WORKING-STORAGE SECTION.
000670
000680* Flags
000690 01 EOF-FLAG PIC X.
000700 88 END-OF-FILE VALUE 'Y'.
000710
000720 01 REC-TYPE-FLAG PIC X VALUE SPACE.
000730 88 I-TYPE VALUE 'I'.
000740 88 R-TYPE VALUE 'R'.
000750 88 D-TYPE VALUE 'D'.
000760 88 C-TYPE VALUE 'C'.
000770
000780* Counters and subscripts
000790 01 PAGE-NO PIC 99 VALUE ZERO.
000800 01 LINE-NO PIC 99 VALUE ZERO.
000810 01 RECORD-COUNT PIC 9(4) VALUE ZERO.
000820 01 SUBS-NO PIC 9.
000830 01 REC-TYPE-COUNTER.
000840 03 I-COUNT PIC 9(4).
000850 03 R-COUNT PIC 9(4).
000860 03 D-COUNT PIC 9(4).
000870 03 C-COUNT PIC 9(4).
000880
000890* Miscellaneous items .
000900 01 ADDRESS-LINE-NO PIC 9.
000910 01 DATE-IN.
000920 03 DOS-YEAR PIC 99.
000930 03 DOS-MONTH PIC 99.
000940 03 DOS-DAY PIC 99.
000950
000960* Temp storage of record
000970 01 W-IN-REC.
000980 03 REC-TYPE PIC X.
000990 03 CUS-CODE PIC X(5).
001000 03 PIC X(96).
001010
001020* Print items
001030 01 P-BLANK-LINE PIC X VALUE SPACES.
001040 01 P-UNDERLINE PIC X(116) VALUE ALL '-'.
001050
001060 01 P-TITLE-1.
001070 03 PIC X(20) VALUE SPACES.
001080 03 PIC X(13) VALUE 'ZENITH PAINTS'.
001090 01 P-TITLE-2.
001100 03 PIC X(14) VALUE SPACES.
001110 03 PIC X(40)
001120 VALUE 'SORTED VALID TRANSACTION FILE REPORT'.
001130 03 PIC X(7) VALUE ' DATE: '.
001140 03 DOS-DAY PIC 99.
001150 03 PIC X VALUE '/'.
001160 03 DOS-MONTH PIC 99.
001170 03 PIC X VALUE '/'.
001180 03 DOS-YEAR PIC 99.
001190
001200 01 P-PAGE-NO-HEAD.
001210 03 PIC X(7) VALUE ' PAGE '.
001220 03 P-PAGE-NO PIC ZZ9.
001230 01 P-HEADING-1.
001240 03 PIC X(5) VALUE SPACES.
001250 03 PIC X(92) VALUE
001260 'RECORD CUSTOMER PART ISSUE/RECEIPT'.
001270 03 PIC X(17) VALUE
001280 'CUSTOMER CREDIT'.
001290 01 P-HEADING-2.
001300 03 PIC X(6) VALUE SPACES.
001310 03 PIC X(61) VALUE
001320 'TYPE CODE NO QUANTITY NAME'.
001330 03 PIC X(30) VALUE 'ADDRESS'.
001340 03 PIC X(19) VALUE
001350 'BALANCE(£) LIMIT(£)'.
001360
001370 01 P-RECORD.
001380 03 PIC X(7) VALUE SPACES.
001390 03 P-REC-TYPE PIC X.
001400 03 PIC X(5) VALUE SPACES.
001410 03 P-CUS-CODE PIC X(5).
001420 03 PIC X(4) VALUE SPACES.
001430 03 P-PART-NO PIC X(6).
001440 03 PIC X(4) VALUE SPACES.
001450 03 P-IR-QUANTITY PIC ZZZ9 BLANK WHEN ZERO.
001460 03 PIC X(7) VALUE SPACES.
001470 03 P-CUS-NAME PIC X(20).
001480 03 PIC X(2) VALUE SPACES.
001490 03 P-CUS-ADDRESS PIC X(30).
001500 03 PIC X VALUE SPACES.
001510 03 P-CUS-BALANCE PIC -(6)9.99 BLANK WHEN ZERO.
001520 03 PIC X VALUE SPACES.
001530 03 P-CUS-CRED-LIMIT PIC -(6)9 BLANK WHEN ZERO.
001540 03 PIC XXXX VALUE SPACES.
001550
001560 01 P-ADDR-TABLE.
001570 03 P-ADDRESS PIC X(30) OCCURS 4.
001580 01 P-EXTRA-LINES.
001590 03 PIC X(65) VALUE SPACES.
001600 03 P-EXTRA-ADDR-LINE PIC X(30).
001610
001620 01 P-REC-TOTAL.
001630 03 PIC X(36)
001640 VALUE ' TOTAL RECORDS READ = '.
001650 03 P-RECORD-COUNT PIC Z(4)9.
001660 01 P-I-TOTAL.
001670 03 PIC X(36)
001680 VALUE ' TOTAL ISSUE RECORDS = '.
001690 03 P-I-COUNT PIC Z(4)9.
001700 01 P-R-TOTAL.
001710 03 PIC X(36)
001720 VALUE ' TOTAL RECEIPT RECORDS = '.
001730 03 P-R-COUNT PIC Z(4)9.
001740 01 P-D-TOTAL.
001750 03 PIC X(36)
001760 VALUE ' TOTAL DELETION RECORDS = '.
001770 03 P-D-COUNT PIC Z(4)9.
001780 01 P-C-TOTAL.
001790 03 PIC X(36)
001800 VALUE ' TOTAL CREATION RECORDS = '.
001810 03 P-C-COUNT PIC Z(4)9.
001820
001830 01 P-KEY-LINES.
001840 03 P-KEY-1 PIC X(47) VALUE
001850 ' KEY: I = ISSUE RECORD; R = RECEIPT RECORD;'.
001860 03 P-KEY-2 PIC X(51) VALUE
001870 ' D = DELETION RECORD; C = CREATION RECORD.'.
001880
001890 01 P-END-MESSAGE PIC X(33) VALUE
001900 ' *** END OF REPORT ***'.
001910
001920* End of Data Division
001930*******************************************************
001940*******************************************************
001950
001960 PROCEDURE DIVISION.
001970
001980 MAIN-PARAGRAPH.
001990
002000 PERFORM SORT-PARAGRAPH
002010 PERFORM INITIATE-PRINT
002020 PERFORM PRINT-RECORD-LINE UNTIL END-OF-FILE
002030 PERFORM TERMINATION-PARAGRAPH
002040 STOP RUN.
002050
002060*******************************************************
002070
002080 SORT-PARAGRAPH.
002090* Paragraph to sort valid file and then remove duplicated
002100* D-type records (to conform with TB17P3 logic)
002110
002120 SORT WORK-FILE
002130 ON ASCENDING KEY CUS-CODE-KEY
002140 DESCENDING KEY REC-TYPE-KEY
002150 USING IN-FILE
002160 GIVING SORTED-FILE.
002170
002180*******************************************************
002190
002200 INITIATE-PRINT.
002210* Paragraph to open files set run date, print titles
002220* and perform prime read
002230
002240 OPEN INPUT SORTED-FILE
002250 OUTPUT PRINT-FILE
002260 INITIALIZE REC-TYPE-COUNTER
002270
002280*--- print titles and headers on report -----*
002290 ACCEPT DATE-IN FROM DATE
002300 MOVE CORRESPONDING DATE-IN TO P-TITLE-2
002310 WRITE PRINT-LINE FROM P-TITLE-1 AFTER PAGE
002320 WRITE PRINT-LINE FROM P-TITLE-2 AFTER 2 LINES
002330
002340 PERFORM PRINT-HEADERS
002350
002360*--- prime read -----*
002370 READ SORTED-FILE INTO W-IN-REC
002380 AT END MOVE 'Y' TO EOF-FLAG
002390 NOT AT END
002400 ADD 1 TO RECORD-COUNT
002410 END-READ.
002420
002430*******************************************************
002440
002450 PRINT-HEADERS.
002460* Paragraph to print page number and column headers
002470
002480 ADD 1 TO PAGE-NO
002490 MOVE PAGE-NO TO P-PAGE-NO
002500 WRITE PRINT-LINE FROM P-PAGE-NO-HEAD AFTER 2 LINES
002510 WRITE PRINT-LINE FROM P-HEADING-1 AFTER 1 LINE
002520 WRITE PRINT-LINE FROM P-HEADING-2 AFTER 1 LINE
002530 WRITE PRINT-LINE FROM P-UNDERLINE AFTER 1 LINE
002540 MOVE ZERO TO LINE-NO.
002550
002560*******************************************************
002570
002580 PRINT-RECORD-LINE.
002590* Paragraph to print record lines
002600
002610 MOVE REC-TYPE TO P-REC-TYPE REC-TYPE-FLAG
002620 MOVE CUS-CODE TO P-CUS-CODE
002630
002640*--- process specific record types -----*
002650 EVALUATE TRUE
002660 WHEN I-TYPE
002670 ADD 1 TO I-COUNT
002680 PERFORM IR-REC-PRINT
002690 WHEN R-TYPE
002700 ADD 1 TO R-COUNT
002710 PERFORM IR-REC-PRINT
002720 WHEN D-TYPE
002730 ADD 1 TO D-COUNT
002740 PERFORM D-REC-PRINT
002750 WHEN C-TYPE
002760 ADD 1 TO C-COUNT
002770 PERFORM C-REC-PRINT
002780 END-EVALUATE
002790
002800 WRITE PRINT-LINE FROM P-RECORD
002810
002820*--- print additional address lines for C type records -----*
002830 IF C-TYPE THEN
002840 PERFORM VARYING SUBS-NO FROM 2 BY 1
002850 UNTIL SUBS-NO > ADDRESS-LINE-NO
002860 IF P-ADDRESS (SUBS-NO) NOT = SPACES THEN
002870 MOVE P-ADDRESS (SUBS-NO) TO P-EXTRA-ADDR-LINE
002880 WRITE PRINT-LINE FROM P-EXTRA-LINES
002890 ADD 1 TO LINE-NO
002900 END-IF
002910 END-PERFORM
002920 END-IF
002930
002940 ADD 1 TO LINE-NO
002950 IF LINE-NO > 50 THEN
002960 WRITE PRINT-LINE FROM P-BLANK-LINE AFTER PAGE
002970 PERFORM PRINT-HEADERS
002980 END-IF
002990
003000*--- read next record -----*
003010 READ SORTED-FILE INTO W-IN-REC
003020 AT END MOVE 'Y' TO EOF-FLAG
003030 NOT AT END
003040 ADD 1 TO RECORD-COUNT
003050 END-READ.
003060
003070*******************************************************
003080
003090 IR-REC-PRINT.
003100* Paragraph to set Issue and Receipt record fields
003110
003120 MOVE PART-NO TO P-PART-NO
003130 MOVE IR-QUANTITY TO P-IR-QUANTITY
003140 MOVE ALL '-' TO P-CUS-NAME P-CUS-ADDRESS
003150 MOVE ZEROS TO P-CUS-BALANCE P-CUS-CRED-LIMIT.
003160
003170*******************************************************
003180
003190 D-REC-PRINT.
003200* Paragraph to set Deletion record fields
003210
003220 MOVE SPACES TO P-PART-NO
003230 MOVE ZEROS TO P-IR-QUANTITY
003240 MOVE ALL '-' TO P-CUS-NAME P-CUS-ADDRESS
003250 MOVE ZERO TO P-CUS-BALANCE P-CUS-CRED-LIMIT.
003260
003270*******************************************************
003280
003290 C-REC-PRINT.
003300* Paragraph to set Creation record print fields
003310
003320 MOVE SPACES TO P-PART-NO
003330 MOVE ZEROS TO P-IR-QUANTITY
003340
003350 MOVE CUS-NAME TO P-CUS-NAME
003360 MOVE CUS-BALANCE TO P-CUS-BALANCE
003370 MOVE CUS-CRED-LIMIT TO P-CUS-CRED-LIMIT
003380
003390*--- space and zero fill address tables for C type records ---*
003400 PERFORM VARYING SUBS-NO FROM 1 BY 1
003410 UNTIL SUBS-NO > 4
003420 MOVE SPACES TO P-ADDRESS (SUBS-NO)
003430 END-PERFORM
003440
003450 MOVE ZERO TO ADDRESS-LINE-NO
003460
003470*--- unstring address into 30-character lines -----*
003480*--- using ';' delimiter -----*
003490 UNSTRING CUS-ADDRESS DELIMITED BY ';'
003500 INTO P-CUS-ADDRESS P-ADDRESS (2)
003510 P-ADDRESS (3) P-ADDRESS (4)
003520 TALLYING IN ADDRESS-LINE-NO
003530 END-UNSTRING.
003540
003550*******************************************************
003560
003570 TERMINATION-PARAGRAPH.
003580* Paragraph to print footers and close files
003590
003600 MOVE RECORD-COUNT TO P-RECORD-COUNT
003610 MOVE I-COUNT TO P-I-COUNT
003620 MOVE R-COUNT TO P-R-COUNT
003630 MOVE D-COUNT TO P-D-COUNT
003640 MOVE C-COUNT TO P-C-COUNT
003650
003660 IF LINE-NO > 28 THEN
003670 WRITE PRINT-LINE FROM P-BLANK-LINE AFTER PAGE
003680 END-IF
003690
003700 WRITE PRINT-LINE FROM P-UNDERLINE AFTER 1 LINE
003710 WRITE PRINT-LINE FROM P-REC-TOTAL AFTER 2 LINES
003720 WRITE PRINT-LINE FROM P-I-TOTAL
003730 WRITE PRINT-LINE FROM P-R-TOTAL
003740 WRITE PRINT-LINE FROM P-D-TOTAL
003750 WRITE PRINT-LINE FROM P-C-TOTAL
003760 WRITE PRINT-LINE FROM P-KEY-1 AFTER 3 LINES
003770 WRITE PRINT-LINE FROM P-KEY-2 AFTER 1 LINE
003780 WRITE PRINT-LINE FROM P-END-MESSAGE AFTER 2 LINES
003790
003800 CLOSE SORTED-FILE PRINT-FILE.
003810
003820
003830*******************************************************
003840** **
003850** END OF PROGRAM-2 **
003860** **
003870*******************************************************
|