ADVANCED COBOL FOR STRUCTURED AND OBJECT-ORIENTED PROGRAMMING, THIRD EDITION
SOURCE CODE FOR PROGRAMS IN THE BOOK
The programs listed here were extracted from the text of Advanced COBOL for Structured
and Object-Oriented Programming. The SELECT statements have all been modified for the PC.
To run on the mainframe, you must change the SELECT statements by
removing the ORGANIZATION IS LINE SEQUENTIAL and adding the necessary JCL.
Chapter 1
INTRODUCTION
Simplest COBOL program. Page 5
This illustrates about as simple a COBOL program as can be written.
IDENTIFICATION DIVISION.
PROGRAM-ID. HELLO.
PROCEDURE DIVISION.
DISPLAY "hello world."
GOBACK
.
END PROGRAM HELLO.
Simple COBOL program. Page 5-6
This illustrates a simple COBOL program, but is more typical in that many of the required
statements are coded.
IDENTIFICATION DIVISION.
PROGRAM-ID. EINSTEIN.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT In-File ASSIGN TO "EINSTEIN.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD IN-FILE BLOCK CONTAINS 0 RECORDS.
01 IN-REC.
02 M PIC S9(10).
02 C PIC S9(10).
WORKING-STORAGE SECTION.
01 E PIC S9(10) PACKED-DECIMAL.
PROCEDURE DIVISION.
BEGIN-PROGRAM.
OPEN INPUT IN-FILE
READ IN-FILE
COMPUTE E = M * (C ** 2)
CLOSE IN-FILE
GOBACK
.
END PROGRAM EINSTEIN.
EINSTEIN.TXT:
00000100000000020000
0059">
Chapter 2
COBOL OVERVIEW
A complete COBOL program. Page 26-27
This program reads a file containing an employee name, birth date, and hire date. It computes
the person's age and adds this to the record and writes it out.
IDENTIFICATION DIVISION.
PROGRAM-ID. Empage.
*****************************************************************
* PROGRAM TO READ INPUT FILE, COMPUTE PERSON'S AGE, AND WRITE *
* OUTPUT FILE. *
* IN: In-File CONTAINS INPUT FILE. *
* OUT: Out-File CONTAINS INPUT FILE RECORDS WITH AGE ADDED. *
*****************************************************************
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT In-File ASSIGN TO "OLDFILE.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT Out-File ASSIGN TO "NEWFILE.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD In-File BLOCK CONTAINS 0 RECORDS.
01 In-Emp.
02 In-Name PIC X(30).
02 In-Birth-Date.
03 In-Birth-Yr PIC 99.
03 In-Birth-Mo PIC 99.
03 In-Birth-Dy PIC 99.
02 PIC X.
02 In-Hire-Date.
03 In-Hire-Yr PIC 99.
03 In-Hire-Mo PIC 99.
03 In-Hire-Dy PIC 99.
FD Out-File BLOCK CONTAINS 0 RECORDS.
01 Out-Emp.
02 Out-Name PIC X(30).
02 Out-Birth-Date.
03 Out-Birth-Yr PIC 99.
03 Out-Birth-Mo PIC 99.
03 Out-Birth-Dy PIC 99.
02 PIC X.
02 Out-Hire-Date.
03 Out-Hire-Yr PIC 99.
03 Out-Hire-Mo PIC 99.
03 Out-Hire-Dy PIC 99.
02 Hire-Age PIC 999.
WORKING-STORAGE SECTION.
01 EOF-In-File PIC X.
* EOF-In-File is end of file flag for In-File.
* "N" if no EOF. "Y" for EOF.
PROCEDURE DIVISION.
A00-Begin.
OPEN INPUT In-File, OUTPUT Out-File
PERFORM WITH TEST AFTER UNTIL EOF-In-File = "Y"
READ In-File
AT END MOVE "Y" TO EOF-In-File
NOT AT END
MOVE "N" TO EOF-In-File
MOVE In-Emp TO Out-Emp
COMPUTE Hire-Age = In-Hire-Yr - In-Birth-Yr
IF In-Hire-Mo < In-Birth-Mo
THEN COMPUTE Hire-Age = Hire-Age - 1
END-IF
IF In-Hire-Mo = In-Birth-Mo AND
In-Hire-Dy < In-Birth-Dy
THEN COMPUTE Hire-Age = Hire-Age - 1
END-IF
WRITE Out-Emp
END-READ
END-PERFORM
CLOSE In-File, Out-File
GOBACK
.
END PROGRAM Empage.
OLDFILE.TXT:
Able, John A. 590201 950924
Baker, Harry M. 620511 950924
Cox, Mary T. 730330 950924
Minow, Samuel T. 681221 950924
Smith, Joseph L. 641121 950924
Zach, Thomas W. 750913 950924
0059">
Chapter 3
GENERAL LANGUAGE RULES
Prototype COBOL program. Page 46-47
This illustrates the usual statements coded in a COBOL program and can be used as a template
for writing COBOL programs.
IDENTIFICATION DIVISION.
PROGRAM-ID. PROTO.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT In-File ASSIGN TO "PROTOIN.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT Out-File ASSIGN TO "PROTOOUT.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD In-File
BLOCK CONTAINS 0 RECORDS.
01 In-Record.
05 K PIC X(15).
05 L.
10 M PIC S9.
10 N PIC X(4).
FD Out-File BLOCK CONTAINS 0 RECORDS.
01 Out-Record PIC X(20).
WORKING-STORAGE SECTION.
01 In-EOF PIC X.
* Flag for end of file. "Y", EOF. "N", no EOF.
01 Record-Count PIC S9(8).
* Record-Count counts the records read and written.
PROCEDURE DIVISION.
A00-Begin.
OPEN INPUT In-File, OUTPUT Out-File
MOVE "N" TO In-EOF
MOVE ZEROS to Record-Count
PERFORM A10-Copy-File WITH TEST AFTER UNTIL In-EOF = "Y"
CLOSE In-File, Out-File
DISPLAY "Records copied: ", Record-Count
GOBACK
.
**** End of program execution.
A10-Copy-File.
READ In-File
AT END MOVE "Y" TO In-EOF
DISPLAY "END OF FILE"
NOT AT END
MOVE In-Record TO Out-Record
WRITE Out-Record
ADD 1 TO Record-Count
END-READ
.
**** Exit
END PROGRAM PROTO.
PROTOIN.TXT:
111111111111111AAAA
222222222222221AAAA
222222222222222AAAA
222222222222222DDDD
444444444444441BBBB
555555555555552CCCC
0059">
Chapter 8
STRUCTURED PROGRAMMING IN COBOL
Nonstructured COBOL program. Page 131-132
This program illustrated a typical nonstructured COBOL program. It reads a master file,
applies some transactions, and writes out a new master file.
IDENTIFICATION DIVISION.
PROGRAM-ID. NONSTRUCT.
*****************************************************************
* PROGRAM TO READ INPUT FILE, UPDATE IT FROM A TRANSACTIONS *
* FILE, AND WRITE AN OUTPUT FILE. *
* IN: In-File CONTAINS INPUT FILE. *
* Trans-File CONTAINS THE TRANSACTIONS FILE. *
* OUT: Out-File CONTAINS THE UPDATED OUTPUT FILE. *
*****************************************************************
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT In-File ASSIGN TO "NONSTIN.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT Out-File ASSIGN TO "NONSTOUT.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT Trans-File ASSIGN TO "NONSTTR.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD In-File
BLOCK CONTAINS 0 RECORDS.
01 In-Record.
05 K PIC X(15).
05 L.
10 M PIC S9.
10 N PIC X(4).
FD Out-File BLOCK CONTAINS 0 RECORDS.
01 Out-Rec.
05 K PIC X(15).
05 L.
10 M PIC S9.
10 N PIC X(4).
FD Trans-File BLOCK CONTAINS 0 RECORDS.
01 Trans-Record.
05 K PIC X(15).
05 L.
10 M PIC S9.
10 N PIC X(4).
WORKING-STORAGE SECTION.
01 In-Rec.
05 K PIC X(15).
05 L.
10 M PIC S9.
10 N PIC X(4).
01 Trans-Rec.
05 K PIC X(15).
05 L.
10 M PIC S9.
10 N PIC X(4).
01 Out-Record.
05 K PIC X(15).
05 L.
10 M PIC S9.
10 N PIC X(4).
01 In-EOF PIC X.
* Flag for end of file. "Y", EOF. "N", no EOF.
01 Record-Count PIC S9(8).
* Record-Count counts the records read and written.
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING NONSTRUCT PROGRAM."
OPEN INPUT In-File Trans-File, OUTPUT Out-File
MOVE LOW-VALUES TO Trans-Rec
.
A10-Read-Next.
READ In-File INTO In-Rec
AT END DISPLAY "EOF IN"
GO TO A70-Purge-Trans
END-READ
IF Trans-Rec = LOW-VALUES
THEN GO TO A40-Read-Trans
END-IF
.
A20-Check-For-Delete.
IF Trans-Rec < In-Rec
THEN DISPLAY "TRANSACTION IGNORED: ", Trans-Rec
GO TO A40-Read-Trans
END-IF
IF Trans-Rec = In-Rec
THEN DISPLAY "DELETING: ", In-Rec
MOVE LOW-VALUES TO Trans-Rec
GO TO A10-Read-Next
END-IF
.
A30-Write-Out.
WRITE Out-Rec FROM In-Rec
DISPLAY "WRITING: ", In-Rec
GO TO A10-Read-Next
.
A40-Read-Trans.
READ Trans-File INTO Trans-Rec
AT END MOVE HIGH-VALUES TO Trans-Rec
DISPLAY "EOF TRANS"
GO TO A30-Write-Out
END-READ
GO TO A20-Check-For-Delete
.
A70-Purge-Trans.
IF Trans-Rec = HIGH-VALUES
THEN GO TO Z90-Stop-Run
END-IF
.
A80-Skip-Trans.
DISPLAY "TRANSACTION IGNORED: ", Trans-Rec
READ Trans-File INTO In-Rec
AT END GO TO Z90-Stop-Run
END-READ
GO TO A80-Skip-Trans
.
Z90-Stop-Run.
DISPLAY "END OF PROGRAM"
CLOSE In-File, Trans-File, Out-File
GOBACK
.
END PROGRAM NONSTRUCT.
NONSTIN.TXT:
111111111111111AAAA
222222222222221AAAA
222222222222222AAAA
222222222222222DDDD
444444444444441BBBB
555555555555552CCCC
NONSTTR.TXT:
111111111111111BBBB
222222222222221AAAA
222222222222222AAAA
222222222222222EEEE
444444444444441BBBB
555555555555553CCCC
0059">
Structured COBOL Program. Page 139
This is the same program as the previous one, except it is written as a structured program.
IDENTIFICATION DIVISION.
PROGRAM-ID. STRUCT.
*****************************************************************
* PROGRAM TO READ INPUT FILE, UPDATE IT FROM A TRANSACTIONS *
* FILE, AND WRITE AN OUTPUT FILE. *
* IN: In-File CONTAINS INPUT FILE. *
* Trans-File CONTAINS THE TRANSACTIONS FILE. *
* OUT: Out-File CONTAINS THE UPDATED OUTPUT FILE. *
*****************************************************************
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT In-File ASSIGN TO "NONSTIN.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT Out-File ASSIGN TO "NONSTOUT.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT Trans-File ASSIGN TO "NONSTTR.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD In-File
BLOCK CONTAINS 0 RECORDS.
01 In-Record.
05 K PIC X(15).
05 L.
10 M PIC S9.
10 N PIC X(4).
FD Out-File BLOCK CONTAINS 0 RECORDS.
01 Out-Rec.
05 K PIC X(15).
05 L.
10 M PIC S9.
10 N PIC X(4).
FD Trans-File BLOCK CONTAINS 0 RECORDS.
01 Trans-Record.
05 K PIC X(15).
05 L.
10 M PIC S9.
10 N PIC X(4).
WORKING-STORAGE SECTION.
01 In-Rec.
05 K PIC X(15).
05 L.
10 M PIC S9.
10 N PIC X(4).
01 Trans-Rec.
05 K PIC X(15).
05 L.
10 M PIC S9.
10 N PIC X(4).
01 Out-Record.
05 K PIC X(15).
05 L.
10 M PIC S9.
10 N PIC X(4).
01 In-EOF PIC X.
* Flag for end of file. "Y", EOF. "N", no EOF.
01 Record-Count PIC S9(8).
* Record-Count counts the records read and written.
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING STRUCT PROGRAM."
OPEN INPUT In-File, Trans-File, OUTPUT Out-File
MOVE LOW-VALUES TO In-Rec, Trans-Rec
PERFORM A10-READ-In-File WITH TEST AFTER
UNTIL In-Rec = HIGH-VALUES
DISPLAY "END OF PROGRAM"
CLOSE In-File, Trans-File, Out-File
GOBACK
.
**** Exit
A10-Read-In-File.
READ In-File INTO In-Rec
AT END MOVE HIGH-VALUES TO In-Rec
END-READ
PERFORM WITH TEST BEFORE UNTIL Trans-Rec >= In-Rec
IF Trans-Rec - LOW-VALUES
THEN READ Trans-File INTO Trans-Rec
AT END MOVE HIGH-VALUES TO Trans-Rec
END-READ
END-IF
IF Trans-Rec < In-Rec
THEN DISPLAY "TRANSACTION IGNORED:", Trans-Rec
MOVE LOW-VALU"ES TO Trans-Rec
END-IF
END-PERFORM
EVALUATE TRUE
WHEN In-Rec = HIGH-VALUES CONTINUE
WHEN Trans-Rec = In-Rec DISPLAY "DELETING:", In-Rec
WHEN OTHER
DISPLAY "WRITING: ", In-Rec
WRITE Out-Rec FROM In-Rec
END-EVALUATE
.
**** Exit
END PROGRAM STRUCT.
NONSTIN.TXT:
111111111111111AAAA
222222222222221AAAA
222222222222222AAAA
222222222222222DDDD
444444444444441BBBB
555555555555552CCCC
NONSTTR.TXT:
111111111111111BBBB
222222222222221AAAA
222222222222222AAAA
222222222222222EEEE
444444444444441BBBB
555555555555553CCCC
0059">
Chapter 13
TABLES
Program to determine minimum and maximum. Page 221
This is a simple program that illustrates tables by determining the minimum and maximum
populations of the 50 states. The table size has been increased to 51 to include the
District of Columbia. The population numbers are Bureau of Census estimates for 1997.
IDENTIFICATION DIVISION.
PROGRAM-ID. MINMAX.
*****************************************************************
* PROGRAM TO READ FILE CONTAINING STATE NAMES AND POPULATIONS. *
* CALCULATES THE MINIMUM AND MAXIMUM POPULATIONS AND DISPLAYS *
* THEM. *
* IN: In-File CONTAINS INPUT FILE OF STATE NAMES, POPULATIONS. *
* OUT: MINIMUM AND MAXIMUM POPULATIONS DISPLAYED. *
*****************************************************************
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT In-File ASSIGN TO "MINMAX.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD In-File
BLOCK CONTAINS 0 RECORDS.
01 In-Record PIC X(31).
WORKING-STORAGE SECTION.
01 In-Rec.
05 State-Name PIC X(20).
05 State-Pop PIC 9(11).
01 In-EOF PIC X.
* Flag for end of file. "Y", EOF. "N", no EOF.
01 States.
05 No-States PIC S9(4) BINARY VALUE 51.
05 Population OCCURS 51 TIMES
INDEXED BY Ix
PIC S9(11) PACKED-DECIMAL.
01 Population-Count PIC S9(14) PACKED-DECIMAL.
01 Max-No PIC S9(11) PACKED-DECIMAL.
01 Min-No PIC S9(11) PACKED-DECIMAL.
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING MINMAX PROGRAM."
OPEN INPUT In-File
MOVE "N" TO IN-EOF
SET IX TO 1
PERFORM WITH TEST AFTER UNTIL In-EOF = "Y"
READ In-File INTO In-Rec
AT END MOVE "Y" TO In-EOF
NOT AT END
IF Ix > No-States
THEN DISPLAY "Too many states, ",
" States table overflow. "
"Killing job."
CLOSE In-File
GOBACK
END-IF
MOVE State-Pop TO Population(Ix)
SET Ix UP BY 1
END-READ
END-PERFORM
CLOSE In-File
MOVE ZERO TO Population-Count, Max-No
MOVE 99999999999 TO Min-No
PERFORM VARYING Ix FROM 1 BY 1 UNTIL Ix > No-States
ADD Population(Ix) TO Population-Count
IF Population(Ix) < Min-No
THEN MOVE Population(Ix) TO Min-No
END-IF
IF Population(Ix) > Max-No
THEN MOVE Population(Ix) TO Max-No
END-IF
END-PERFORM
DISPLAY "Population total is: ", Population-Count
DISPLAY "Minimum population is: ", Min-No
DISPLAY "Maximum population is: ", Max-No
GOBACK
.
END PROGRAM MINMAX.
MINMAX.TXT:
Alabama 00004319154
Alaska 00000609311
Arizona 00004554966
Arkansas 00002522819
California 00032268301
Colorado 00003892644
Connecticut 00003269858
Delaware 00000731581
District of Columbia00000528964
Florida 00014653945
Georgia 00007486242
Hawaii 00001186602
Idaho 00001210232
Illinois 00011895849
Indiana 00005864108
Iowa 00002852423
Kansas 00002594840
Kentucky 00003908124
Louisiana 00004351769
Maine 00001242051
Maryland 00005094289
Massachusetts 00006117520
Michigan 00009773892
Minnesota 00004685549
Mississippi 00002730501
Missouri 00005402058
Montana 00000878810
Nebraska 00001656870
Nevada 00001676809
New Hampshire 00001172709
New Jersey 00008052849
New Mexico 00001729751
New York 00018137226
North Carolina 00007425183
North Dakota 00000640883
Ohio 00011186331
Oklahoma 00003317091
Oregon 00003243487
Pennsylvania 00012019661
Rhode Island 00000987429
South Carolina 00003760181
South Dakota 00000737973
Tennessee 00005368198
Texas 00019439337
Utah 00002059148
Vermont 00000588978
Virginia 00006733996
Washington 00005610362
West Virginia 00001815787
Wisconsin 00005169677
Wyoming 00000479743
0059">
Program to initialize complex structure. Page 224-225.
This program shows how to write a procedure to initialize a complex structure.
IDENTIFICATION DIVISION.
PROGRAM-ID. INITL.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Record-Out.
05 Increments OCCURS 600 TIMES
INDEXED BY Ix.
10 Increment-Value PIC S9(3) PACKED-DECIMAL.
10 Decrement-Value PIC S9(3) PACKED-DECIMAL.
01 Dec-No PIC S9(3) PACKED-DECIMAL.
PROCEDURE DIVISION.
DISPLAY "BEGINNING INITIAL PROGRAM."
PERFORM B100-Initialize
GOBACK
.
B100-Initialize.
MOVE 600 TO Dec-No
PERFORM VARYING Ix FROM 1 BY 1 UNTIL Ix > 600
SET Decrement-Value(Ix) TO Ix
MOVE Dec-No TO Decrement-Value(Ix)
SUBTRACT 1 FROM Dec-No
END-PERFORM
.
**** EXIT
END PROGRAM INITL.
0059">
Program utilizing hash table. Page 243-246
This program illustrates how to write records into a hash table and retrieve them.
IDENTIFICATION DIVISION.
PROGRAM-ID. HASH.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 SS-Table.
05 SS-Name PIC X(25).
05 SS-No PIC 9(9).
05 SS-Div PIC S9(9) PACKED-DECIMAL
VALUE 1499.
05 SS-Max-Size PIC S9(4) BINARY SYNC
VALUE 1500.
05 SS-Subscript PIC S9(9) PACKED-DECIMAL.
05 SS-Person OCCURS 1500 TIMES
INDEXED BY Ip.
10 SS-Person-No PIC 9(9).
10 SS-Person-Name PIC X(25).
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING HASH PROGRAM."
* First zero out the SS-Person-No elements.
PERFORM VARYING Ip FROM 1 BY 1 UNTIL Ip > SS-Max-Size
MOVE ZEROS TO SS-Person-No(Ip)
END-PERFORM
MOVE "111111111" TO SS-No
MOVE "John Doe" TO SS-Name
PERFORM C10-Add-Name
DISPLAY "Added John Doe at: ", SS-Subscript
MOVE "222222222" TO SS-No
MOVE "Harry Smith" TO SS-Name
PERFORM C10-Add-Name
DISPLAY "Added Harry Smith at: ", SS-Subscript
MOVE "555555555" TO SS-No
MOVE "Mary Clark" TO SS-Name
PERFORM C10-Add-Name
DISPLAY "Added Mary Clark at: ", SS-Subscript
MOVE "222222222" TO SS-No
PERFORM C20-Retrieve-Name
DISPLAY "Found Harry Smith at: ", SS-Subscript
GOBACK
.
C10-Add-Name.
************************************************************
* PROCEDURE TO ADD ENTRIES TO Person TABLE. *
* IN: SS-No contains Social Security number. *
* SS-Name contains person's name. *
* OUT: Ip points to where SS-No stored. *
* SS-No stored in SS-Person-No(Ip). *
* SS-Name stored in SS-Person-Name(Ip). *
************************************************************
COMPUTE SS-Subscript = FUNCTION REM(SS-No, SS-Div) + 1
SET Ip TO SS-Subscript
SEARCH SS-Person
AT END
SET Ip TO 1
SEARCH SS-Person
WHEN Ip = SS-Subscript
DISPLAY
"ERROR - SS-Person TABLE FULL, RUN TERMINATED."
DISPLAY
"INCREASE SS-Person- SS-Div, SS-Max-Size AND RECOMPILE."
GO TO Z90-Stop-Run
WHEN SS-Person-No(Ip) = ZEROS
MOVE SS-No TO SS-Person-No(Ip)
MOVE SS-Name TO SS-Person-Name(Ip)
END-SEARCH
WHEN SS-Person-No(Ip) = ZEROS
MOVE SS-No TO SS-Person-No(Ip)
MOVE SS-Name TO SS-Person-Name(Ip)
END-SEARCH
SET SS-Subscript TO Ip
.
**** Exit
C20-Retrieve-Name.
************************************************************
* PROCEDURE TO RETRIEVE A Person's NAME. *
* IN: SS-No contains Social Security number. *
* OUT: If found: *
* SS-Subscript points to entry in table. *
* SS-Name contains person's name. *
* Not found: *
* SS-Subscript contains ZERO. *
* SS-Name contains SPACES. *
************************************************************
COMPUTE SS-Subscript = FUNCTION REM(SS-No, SS-Div) + 1
SET Ip TO SS-Subscript
SEARCH SS-Person
AT END
SET Ip TO 1
SEARCH SS-Person
WHEN Ip = SS-Subscript OR SS-Person-No(Ip) = ZERO
MOVE SPACES TO SS-Name
MOVE ZERO TO SS-Subscript
WHEN SS-No = SS-Person-No(Ip)
MOVE SS-Person-Name(Ip) TO SS-Name
SET SS-Subscript TO Ip
END-SEARCH
WHEN SS-Person-No(Ip) = ZERO
MOVE SPACES TO SS-Name
MOVE ZERO TO SS-Subscript
WHEN SS-No = SS-Person-No(Ip)
MOVE SS-Person-Name(Ip) TO SS-Name
SET SS-Subscript TO Ip
END-SEARCH
.
**** Exit
Z90-Stop-Run.
DISPLAY "TERMINATING PROGRAM HASH."
GOBACK
.
END PROGRAM HASH.
0059">
Program to read in a table. Page 246-247
This program illustrates how to read in a table into storage, checking for table overflow.
The record length has been reduced from 1000 to 11 to make it easier to create data for
the program with a text editor.
IDENTIFICATION DIVISION.
PROGRAM-ID. READTBL.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT Pay-In ASSIGN TO "READTBL.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD Pay-In
BLOCK CONTAINS 0 RECORDS.
01 Pay-Record PIC X(11).
WORKING-STORAGE SECTION.
01 Old-Id PIC X(10).
* Old-Id checks the sort
* order of Input-File.
**** Employee file. Record length = 11.
01 Employee.
05 Employee-Id PIC X(10).
05 FILLER PIC X(1).
**** Table of employee IDs.
01 ID-Record.
05 ID-Max PIC S9(4) BINARY VALUE 1000.
* Maximum IDs in table.
05 ID-No PIC S9(4) BINARY VALUE ZERO.
* Current size of table.
05 ID-Table OCCURS 0 TO 1000 TIMES
DEPENDING ON ID-No
ASCENDING KEY IS ID-Id
INDEXED BY Idx.
10 ID-Id PIC X(10).
PROCEDURE DIVISION.
A00-Begin.
OPEN INPUT Pay-In
MOVE LOW-VALUES TO Employee-Id, Old-Id
PERFORM B20-Store-Ids WITH TEST AFTER
UNTIL Employee-Id = HIGH-VALUES
CLOSE Pay-In
SEARCH ALL ID-Table
AT END DISPLAY "ID Found."
WHEN ID-Id(Idx) = "A23456789" DISPLAY "ID FOUND"
END-SEARCH
GOBACK
.
B20-Store-Ids.
************************************************************
* PROCEDURE TO READ IDS AND STORE THEM IN THE TABLE. *
* IN: Pay-In file open. *
* ID-No points to last entry in table. *
* Old-Id contains previous ID. *
* OUT: Pay-In file open. One record read. *
* ID-No increased by 1. *
* Employee-Id stored in Old-Id, ID-Id(ID-No). *
* Employee-Id contains HIGH-VALUES if EOF. *
************************************************************
READ Pay-In INTO Employee
AT END MOVE HIGH-VALUES TO Employee-Id
NOT AT END
IF Employee-Id < Old-Id
THEN DISPLAY
"ERROR - PAYROLL FILE NOT IN SORT, RUN TERMINATED."
DISPLAY "OLD ID: ", Old-Id, " CURRENT ID: ",
Employee-Id
GO TO Z90-Stop-Run
END-IF
MOVE Employee-Id TO Old-Id
ADD 1 TO ID-No
IF ID-No > ID-Max
THEN DISPLAY
"ERROR - ID-Table OVERFLOW, RUN TERMINATED."
DISPLAY "PAYROLL RECORD: ", Employee-Id
DISPLAY
"INCREASE ID-Max, ID-Table AND RECOMPILE PROGRAM."
GO TO Z90-Stop-Run
END-IF
MOVE Employee-Id TO ID-Id(ID-No)
END-READ
.
**** Exit
Z90-Stop-Run.
DISPLAY "TERMINATING PROGRAM READTBL."
GOBACK
.
END PROGRAM READTBL.
READTBL.TXT:
A00000000X
A11111111X
A22222222X
A23456789X
A23456799X
B00000000X
B12345678X
0059">
Chapter 15
SEQUENTIAL INPUT/OUTPUT
Program illustrating order of statements. Page 271-272
This program does nothing except to illustrate the order in which the various statements are
coded.
IDENTIFICATION DIVISION.
PROGRAM-ID. ORDR.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
ALPHABET An-Alphabet IS ASCII.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT In-File
ASSIGN TO INFILE.
SELECT File-1
RESERVE 2 AREAS
ORGANIZATION IS SEQUENTIAL
ACCESS MODE IS SEQUENTIAL
LOCK MODE IS AUTOMATIC
PASSWORD IS A-Password
FILE STATUS IS A-Status
ASSIGN TO INFILE1
.
SELECT File-2 ASSIGN TO INFILE2.
SELECT Sort-1 ASSIGN TO SORT1.
SELECT Sort-2 ASSIGN TO SORT1.
I-O-CONTROL.
SAME RECORD AREA FOR File-1, FILE-2,
SAME SORT AREA FOR Sort-1, Sort-2,
RERUN ON File-2 EVERY 100 RECORDS
APPLY WRITE ONLY ON File-2
.
DATA DIVISION.
FILE SECTION.
FD In-File.
01 Infile-Rec PIC X(10).
FD File-1
EXTERNAL
GLOBAL
BLOCK CONTAINS 0 RECORDS
RECORD CONTAINS 20 CHARACTERS
LINAGE IS 60 LINES
RECORDING MODE IS F
CODE-SET IS An-Alphabet.
01 File-1-Rec PIC X(10).
FD File-2.
01 File-2-Rec PIC X(10).
SD Sort-1.
01 Sort-In-1 PIC X(10).
SD Sort-2.
01 Sort-In-2 PIC X(10).
WORKING-STORAGE SECTION.
01 A-Password PIC X(8).
01 A-Status PIC X(2).
LINKAGE SECTION.
PROCEDURE DIVISION.
DECLARATIVES.
A-Section SECTION.
USE AFTER ERROR PROCEDURE ON INPUT.
A-Paragraph.
MOVE SPACES TO A-Status
.
END DECLARATIVES.
END PROGRAM ORDR.
Sequential copy program. Page 288-289
This program illustrates copying a sequential file.
IDENTIFICATION DIVISION.
PROGRAM-ID. COPY-PROGRAM.
*****************************************************************
* PROGRAM TO COPY A FILE. *
* IN: In-File CONTAINS INPUT FILE. *
* OUT: Out-File IS A COPY OF THE INPUT FILE. *
*****************************************************************
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT In-File ASSIGN TO "COPYIN.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT Out-File ASSIGN TO "COPYOUT.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD In-File BLOCK CONTAINS 0 RECORDS.
01 In-Rec PIC X(40).
* NOTE: THE RECORD LENGTH HAS BEEN SHORTENED FROM 100 TO 40 CHARACTERS
* FOR THIS EXAMPLE FOR CONVENIENCE IN FITTING THE DATA INTO A LISTING.
FD Out-File BLOCK CONTAINS 0 RECORDS.
01 Out-Rec PIC X(40).
WORKING-STORAGE SECTION.
01 In-Record PIC X(40).
01 Record-Counts.
05 In-File-No PIC S9(9) BINARY VALUE 0.
05 Out-File-No PIC S9(9) BINARY VALUE 0.
01 EOF-In-Flag PIC X.
88 EOF-In VALUE "Y".
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING COPY PROGRAM"
OPEN INPUT In-File OUTPUT Out-File
MOVE "N" TO EOF-In-Flag
PERFORM WITH TEST AFTER UNTIL EOF-In
READ In-File INTO In-Record
AT END SET EOF-In TO TRUE
NOT AT END
ADD 1 TO In-File-No
WRITE Out-Rec FROM In-Record
ADD 1 TO Out-File-No
END-READ
END-PERFORM
DISPLAY "In-File-No: ", In-File-No,
" Out-File-No: ", Out-File-No
CLOSE In-File, Out-File
GOBACK
.
END PROGRAM COPY-PROGRAM.
COPYIN.TXT:
1111111111111111111111111111111111111111
1111111111111111111111111111111111111111
1111111111111111111111111111111111111111
1111111111111111111111111111111111111111
1111111111111111111111111111111111111111
1111111111111111111111111111111111111111
1111111111111111111111111111111111111111
1111111111111111111111111111111111111111
1111111111111111111111111111111111111111
1111111111111111111111111111111111111111
1111111111111111111111111111111111111111
0059">
Sequential Update Program. Page 289-291
This program updates a sequential file. It reads a master file, applies transactions to it from a
transactions file, and writes an output file.
IDENTIFICATION DIVISION.
PROGRAM-ID. UPDT.
*****************************************************************
* PROGRAM TO READ INPUT FILE, UPDATE IT FROM A TRANSACTIONS *
* FILE, AND WRITE AN OUTPUT FILE. *
* IN: Master-In CONTAINS INPUT FILE. *
* Trans-In CONTAINS THE TRANSACTIONS FILE. *
* OUT: Master-Out CONTAINS THE UPDATED OUTPUT FILE. *
*****************************************************************
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT Master-In ASSIGN TO "UPDAIN.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT Master-Out ASSIGN TO "UPDAOUT.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT Trans-In ASSIGN TO "UPDATR.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD Master-In BLOCK CONTAINS 0 RECORDS.
01 Master-In-Rec PIC X(10).
FD Master-Out BLOCK CONTAINS 0 RECORDS.
01 Master-Out-Rec PIC X(10).
FD Trans-In BLOCK CONTAINS 0 RECORDS.
01 Trans-In-Rec PIC X(10).
WORKING-STORAGE SECTION.
01 Master-Rec.
05 Master-Key PIC X(10).
01 Trans-Rec.
05 Trans-Key PIC X(10).
01 EOF-Master-Flag PIC X.
88 EOF-Master VALUE "Y".
01 EOF-Trans-Flag PIC X.
88 EOF-Trans VALUE "Y".
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING UPDT PROGRAM."
OPEN INPUT Master-In, Trans-In, OUTPUT Master-Out
MOVE "N" TO EOF-Master-Flag, EOF-Trans-Flag
MOVE LOW-VALUES TO Trans-Key
PERFORM WITH TEST AFTER UNTIL EOF-Master
READ Master-In INTO Master-Rec
AT END SET EOF-Master TO TRUE
NOT AT END
IF Trans-Key NOT = LOW-VALUES AND < Master-Key
THEN DISPLAY "NO MASTER FOR TRANS RECORD."
DISPLAY "Trans-Key: ", Trans-Key
END-IF
PERFORM A20-Read-Trans WITH TEST BEFORE
UNTIL Trans-Key >= Master-Key OR
EOF-Trans
IF (NOT EOF-Trans) AND Trans-Key = Master-Key
THEN DISPLAY "UPDATING MASTER: ", Master-Key
MOVE LOW-VALUES TO Trans-Key
END-IF
WRITE Master-Out-Rec FROM Master-Rec
END-READ
END-PERFORM
.
**** Exit
A20-Read-Trans.
READ Trans-In INTO Trans-Rec
AT END SET EOF-Trans TO TRUE
NOT AT END
IF Trans-Key < Master-Key
THEN DISPLAY "NO MASTER FOR TRANS RECORD."
DISPLAY "Trans-Key: ", Trans-Key
END-IF
END-READ
.
**** Exit
END PROGRAM UPDT.
UPDAIN.TXT:
1111111111
2222222222
3333333333
6666666666
7777777777
9999999999
UPDATR.TXT:
2222222222
4444444444
5555555555
9999999999
0059">
Program to update with REWRITE statement. Page 292-293
This program rewrites records in a sequential file.
IDENTIFICATION DIVISION.
PROGRAM-ID. PROG-REWRITE.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT Payroll-IO ASSIGN TO "REWIN.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD Payroll-IO BLOCK CONTAINS 0 RECORDS.
01 Payroll-Record PIC X(80).
WORKING-STORAGE SECTION.
01 Pay-Rec.
05 Pay-Key PIC X(20).
05 Pay-Type PIC X.
05 Pay-Amt PIC S9(5)V99.
05 Pay-Rest PIC X(52).
01 EOF-Pay-Flag PIC X.
88 EOF-Pay VALUE "Y".
PROCEDURE DIVISION.
A00-Begin.
OPEN I-O Payroll-IO
MOVE "N" TO EOF-Pay-Flag
PERFORM WITH TEST AFTER UNTIL Pay-Key = HIGH-VALUES OR
EOF-Pay
READ Payroll-IO INTO Pay-Rec
AT END SET EOF-Pay TO TRUE
NOT AT END
IF Pay-Type = "A"
THEN MOVE ZERO TO Pay-Amt
REWRITE Payroll-Record FROM Pay-Rec
END-IF
END-READ
END-PERFORM
END PROGRAM PROG-REWRITE.
0059">
Sequential file update example. Page 294-300
This program updates records in a sequential file. The master file is read, and
transactions are applied to it, and the updated records are written into an output file.
IDENTIFICATION DIVISION.
PROGRAM-ID. UPDATE-IT.
*****************************************************************
* PROGRAM TO READ INPUT FILE, UPDATE IT FROM A TRANSACTIONS *
* FILE, AND WRITE AN OUTPUT FILE. *
* IN: Old-Master CONTAINS INPUT FILE. *
* Trans-File CONTAINS THE TRANSACTIONS FILE. *
* OUT: New-Master CONTAINS THE UPDATED OUTPUT FILE. *
*****************************************************************
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT Old-Master ASSIGN TO "MASTER.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT Trans-File ASSIGN TO "TRANS.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT New-Master ASSIGN TO "MSTROUT.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD Old-Master BLOCK CONTAINS 0 RECORDS.
01 Old-Master-Record PIC X(40).
* NOTE: THE RECORD LENGTH HAS BEEN SHORTENED FROM 100 TO 40 CHARACTERS
* FOR THIS EXAMPLE FOR CONVENIENCE IN FITTING THE DATA INTO A LISTING.
FD Trans-File BLOCK CONTAINS 0 RECORDS.
01 Trans-Record PIC X(41).
FD New-Master BLOCK CONTAINS 0 RECORDS.
01 New-Master-Record.
05 New-Master-Key PIC X(5).
05 New-Master-Fields PIC X(35).
WORKING-STORAGE SECTION.
01 Master-Rec.
05 Master-Key PIC X(5).
* LOW-VALUES: No record. HIGH-VALUES: EOF.
88 EOF-Master VALUE HIGH-VALUES.
88 No-Master-Rec VALUE LOW-VALUES.
05 Master-Fields PIC X(35).
01 Prev-Master-Key PIC X(5).
01 Trans-Rec.
05 Trans-Key PIC X(5).
* LOW-VALUES: No record. HIGH-VALUES: EOF.
88 EOF-Trans VALUE HIGH-VALUES.
88 No-Trans-Rec VALUE LOW-VALUES.
05 Trans-Action PIC X.
* I - Insert, D - Delete, U - Update.
05 Trans-Fields PIC X(35).
01 Hold-Rec.
* Hold-Rec contains inserted Trans-Rec until written.
05 Hold-Key PIC X(5).
* LOW-VALUES: Record deleted. HIGH-VALUES: No record.
88 EOF-Hold VALUE HIGH-VALUES.
88 No-Hold-Rec VALUE LOW-VALUES.
05 Hold-Fields PIC X(35).
01 Prev-Trans.
05 Prev-Trans-Key PIC X(5).
05 Prev-Trans-Action PIC X.
01 Record-Counts.
05 Old-Master-Count PIC S9(9) BINARY VALUE 0.
05 Trans-File-Count PIC S9(9) BINARY VALUE 0.
05 New-Master-Count PIC S9(9) BINARY VALUE 0.
05 Trans-Change-Count PIC S9(9) BINARY VALUE 0.
05 Trans-Add-Count PIC S9(9) BINARY VALUE 0.
05 Trans-Del-Count PIC S9(9) BINARY VALUE 0.
05 Trans-Error-Count PIC S9(9) BINARY VALUE 0.
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "START OF UPDATE PROGRAM"
OPEN INPUT Old-Master, Trans-File, OUTPUT New-Master
SET No-Master-Rec, No-Trans-Rec TO TRUE
MOVE LOW-VALUES TO Trans-Action
SET EOF-HOLD TO TRUE
PERFORM A00-Read-Master WITH TEST AFTER
UNTIL EOF-Master AND EOF-Trans
CLOSE Old-Master, Trans-File, New-Master
DISPLAY "OLD MASTER RECORDS READ: ", Old-Master-Count
DISPLAY "TRANS RECORDS READ: ", Trans-File-Count
DISPLAY "NEW MASTER RECORDS WRITTEN: ", New-Master-Count
DISPLAY "OLD MASTER RECORDS DELETED: ", Trans-Del-Count
DISPLAY "OLD MASTER RECORDS CHANGED: ", Trans-Change-Count
DISPLAY "NEW TRANSACTIONS ADDED: ", Trans-Add-Count
DISPLAY "TRANS ERROR COUNT: ", Trans-Error-Count
DISPLAY "END OF UPDATE PROGRAM EXECUTION"
GOBACK
.
A00-Read-Master.
************************************************************
* PROCEDURE TO READ ALL MASTER RECORDS. *
* IN: MASTER, TRANS, New-Master files open. *
* OUT: MASTER and TRANS file records read. *
* Master-Key, Trans-Key contain HIGH-VALUES when both *
* reach EOF. *
************************************************************
* Get a master record.
PERFORM A10-Get-Next-Master WITH TEST BEFORE
UNTIL NOT No-Master-Rec
* Process transactions up to the master record.
PERFORM A30-Get-Next-Trans WITH TEST BEFORE
UNTIL NOT No-Trans-Rec
* If you are holding a record less than the
* transaction record, write it out.
IF NOT No-Hold-Rec AND NOT EOF-Hold AND Hold-Key < Trans-Key
THEN MOVE Hold-Rec TO New-Master-Record
PERFORM A50-Write-Master
SET EOF-Hold TO TRUE
END-IF
EVALUATE TRUE
WHEN EOF-Trans AND EOF-Master
* EOF for both files.
CONTINUE
WHEN Trans-Key < Master-Key AND
EOF-Hold OR No-Hold-Rec
* Apply transaction where it doesn't match a master
* record.
PERFORM A60-Apply-Trans
SET No-Trans-Rec TO TRUE
WHEN Trans-Key < Master-Key AND
NOT EOF-Hold AND NOT No-Hold-Rec
* Apply transaction where you have a record held.
PERFORM A70-Apply-To-Hold
SET No-Trans-Rec TO TRUE
WHEN Trans-Key = Master-Key
* Apply transaction to master record.
PERFORM A80-Apply-To-Master
SET No-Trans-Rec TO TRUE
WHEN Trans-Key > Master-Key AND No-Master-Rec
* Delete master file record.
ADD 1 TO Trans-Del-Count
SET No-Trans-Rec TO TRUE
WHEN Trans-Key > Master-Key AND
NOT No-Master-Rec
* All transactions applied. Write master record.
MOVE Master-Rec TO New-Master-Record
PERFORM A50-Write-Master
MOVE Master-Key TO Prev-Master-Key
SET No-Master-Rec TO TRUE
END-EVALUATE
.
**** Exit
A10-Get-Next-Master.
************************************************************
* PROCEDURE TO READ NEXT MASTER RECORD. *
* IN: MASTER file open. *
* OUT: Master-Rec contains record. *
* Master-Key contains HIGH-VALUES if EOF. *
************************************************************
READ Old-Master INTO Master-Rec
AT END SET EOF-Master TO TRUE
NOT AT END
ADD 1 TO Old-Master-Count
PERFORM A20-Validate-Master
END-READ
.
**** Exit
A20-Validate-Master.
************************************************************
* PROCEDURE TO VALIDATE MASTER RECORD. *
* IN: Master-Rec contains record. *
* OUT: Master-Key set to LOW-VALUES if invalid. *
************************************************************
IF Master-Key < Prev-Master-Key
THEN DISPLAY "ERROR--MASTER FILE NOT IN SEQUENCE:"
DISPLAY "Prev-Master-Key: ", Prev-Master-Key,
" Master-Key: ", Master-Key
GO TO Z90-Stop-Run
END-IF
IF Master-Key = Prev-Master-Key
THEN DISPLAY "ERROR--DUPLICATE MASTER RECORDS:"
DISPLAY "Master-Key: ", Master-Key
ADD 1 TO Trans-Error-Count
SET No-Master-Rec TO TRUE
END-IF
.
**** Exit
A30-Get-Next-Trans.
************************************************************
* PROCEDURE TO READ NEXT TRANS RECORD. *
* IN: TRANS file open. *
* OUT: Trans-Rec contains record. *
* Trans-Key contains HIGH-VALUES if EOF. *
************************************************************
MOVE Trans-Key TO Prev-Trans-Key
MOVE Trans-Action TO Prev-Trans-Action
READ Trans-File INTO Trans-Rec
AT END SET EOF-Trans TO TRUE
NOT AT END
ADD 1 TO Trans-File-Count
PERFORM A40-Validate-Trans
END-READ
.
**** Exit
A40-Validate-Trans.
************************************************************
* PROCEDURE TO VALIDATE TRANS RECORD. *
* IN: Trans-Rec contains record. *
* OUT: Trans-Key set to LOW-VALUES if invalid. *
************************************************************
EVALUATE TRUE
WHEN Trans-Key < Prev-Trans-Key
DISPLAY "ERROR--TRANS FILE OUT OF SEQUENCE"
DISPLAY "OLD-Key: ", Prev-Trans-Key,
" New-Key: ", Trans-Key
GO TO Z90-Stop-Run
WHEN Trans-Key = Prev-Trans-Key AND
Trans-Action < Prev-Trans-Action
DISPLAY "ERROR--TRANS ACTIONS OUT OF SEQUENCE"
DISPLAY "OLD Key: ", Prev-Trans-Key,
" OLD ACTION: ", Prev-Trans-Action,
" New KEY: ", Trans-Key,
" New ACTION: ", Trans-Action
GO TO Z90-Stop-Run
END-EVALUATE
IF Trans-Action = "I" OR "U" OR "D"
THEN CONTINUE
ELSE DISPLAY "ERROR--BAD TRANS ACTION. KEY: ", Trans-Key,
" ACTION: ", Trans-Action
SET No-Trans-Rec TO TRUE
ADD 1 TO Trans-Error-Count
END-IF
.
**** Exit
A50-Write-Master.
************************************************************
* PROCEDURE TO WRITE NEW MASTER RECORD. *
* IN: Record stored in New-Master-Record. *
* OUT: New-Master-Record written. *
************************************************************
ADD 1 TO New-Master-Count
WRITE New-Master-Record
.
**** Exit
A60-Apply-Trans.
************************************************************
* PROCEDURE TO APPLY TRANSACTION WHERE NO MASTER RECORD. *
* IN: Trans-Rec contains record. *
* OUT: Trans-Rec stored in Hold-Rec if insert. *
************************************************************
EVALUATE Trans-Action
WHEN "D"
DISPLAY "ERROR--DELETE WITH NO MASTER RECORD"
DISPLAY "IGNORING Trans-Key: ", Trans-Key
ADD 1 TO Trans-Error-Count
WHEN "I" PERFORM A90-Trans-Add
WHEN "U"
DISPLAY "ERROR--UPDATE WITH NO MASTER RECORD"
DISPLAY "IGNORING Trans-Key: ", Trans-Key
ADD 1 TO Trans-Error-Count
END-EVALUATE
.
**** Exit
A70-Apply-To-Hold.
************************************************************
* PROCEDURE TO APPLY TRANS TO HOLD RECORD. *
* IN: Trans-Rec contains transaction. *
* Trans-Key = Hold-Key. *
* Hold-Rec contains previous TRANSACTION. *
* OUT: Record applied to Hold-Rec. *
* Hold-Key set to HIGH-VALUES if Hold-Rec written. *
* LOW-VALUES if Hold-Rec deleted. *
************************************************************
EVALUATE TRUE
WHEN Trans-Key > Hold-Key
MOVE Hold-Rec TO New-Master-Record
PERFORM A50-Write-Master
SET EOF-Hold TO TRUE
PERFORM A60-Apply-Trans
WHEN Trans-Action = "D"
SET No-Hold-Rec TO TRUE
ADD 1 TO Trans-Del-Count
WHEN Trans-Action = "I"
DISPLAY "ERROR--INSERTING WITH MASTER RECORD"
DISPLAY "IGNORING Trans-Key: ", Trans-Key
ADD 1 TO Trans-Error-Count
WHEN Trans-Action = "U"
MOVE Trans-Fields TO Hold-Fields
ADD 1 TO Trans-Change-Count
END-EVALUATE
.
**** Exit
A80-Apply-To-Master.
************************************************************
* PROCEDURE TO APPLY TRANS TO MASTER RECORD. *
* IN: Trans-Rec contains transaction. *
* Trans-Key = Master-Key *
* Master-Rec contains master record. *
* OUT: RECORD applied to Master-Rec. *
* Master-Key set to LOW-VALUES if deleted. *
************************************************************
EVALUATE TRUE
WHEN Trans-Action = "I" AND No-Master-Rec
PERFORM A90-Trans-Add
WHEN Trans-Action = "I" AND NOT No-Master-Rec
DISPLAY "ERROR--Add WHEN MASTER PRESENT: ",
Trans-Key
ADD 1 TO Trans-Error-Count
WHEN Trans-Action = "D" AND NOT No-Master-Rec
MOVE Master-Key TO Prev-Master-Key
SET No-Master-Rec TO TRUE
ADD 1 TO Trans-Del-Count
WHEN Trans-Action = "D" AND No-Master-Rec
DISPLAY "ERROR-DELETING DELETED RECORD: ", Trans-Key
ADD 1 TO Trans-Error-Count
WHEN Trans-Action = "U" AND NOT No-Master-Rec
ADD 1 TO Trans-Change-Count
MOVE Trans-Fields TO Master-Fields
WHEN Trans-Action = "U" AND No-Master-Rec
DISPLAY "ERROR--CHANGING DELETED RECORD: ", Trans-Key
ADD 1 TO Trans-Error-Count
END-EVALUATE
.
**** Exit
A90-Trans-Add.
************************************************************
* PROCEDURE TO INSERT A Trans-Rec RECORD. *
* IN: Trans-Rec contains transaction. *
* OUT: Hold-Rec contains transaction. *
************************************************************
ADD 1 TO Trans-Add-Count
MOVE Trans-Key TO Hold-Key
MOVE Trans-Fields TO Hold-Fields
.
**** Exit
Z90-Stop-Run.
************************************************************
* PROCEDURE TO TERMINATE RUN IF ERROR. *
* IN: All files open. *
* OUT: RETURN-CODE set to 16. *
* All files closed. *
************************************************************
DISPLAY "RUN TERMINATED FOR ERRORS."
MOVE 16 TO RETURN-CODE
CLOSE Old-Master, Trans-File, New-Master
GOBACK
.
END PROGRAM UPDATE-IT.
MASTER.TXT:
AAAAA-----------------------------------
AAAAB-----------------------------------
AAAAC-----------------------------------
AAAAD-----------------------------------
AAAAE-----------------------------------
AAAAF-----------------------------------
AAAAG-----------------------------------
AAAAH-----------------------------------
AAAAI-----------------------------------
AAAAJ-----------------------------------
AAAAK-----------------------------------
AAAAL-----------------------------------
AAAAM-----------------------------------
AAAAN-----------------------------------
AAAAO-----------------------------------
AAAAP-----------------------------------
AAAAQ-----------------------------------
AAAAR-----------------------------------
AAAAS-----------------------------------
AAAAT-----------------------------------
AAAAU-----------------------------------
AAAAV-----------------------------------
AAAAW-----------------------------------
AAAAX-----------------------------------
AAAAY-----------------------------------
AAAAZ-----------------------------------
BBBAB-----------------------------------
BBBBB-----------------------------------
BBBCB-----------------------------------
BBBDB-----------------------------------
BBBEB-----------------------------------
BBBFB-----------------------------------
BBBGB-----------------------------------
BBBHB-----------------------------------
BBBIB-----------------------------------
BBBJB-----------------------------------
BBBKB-----------------------------------
BBBLB-----------------------------------
BBBMB-----------------------------------
BBBNB-----------------------------------
BBBOB-----------------------------------
BBBPB-----------------------------------
BBBQB-----------------------------------
BBBRB-----------------------------------
BBBSB-----------------------------------
BBBTB-----------------------------------
BBBUB-----------------------------------
BBBVB-----------------------------------
BBBWB-----------------------------------
BBBXB-----------------------------------
BBBYB-----------------------------------
BBBZB-----------------------------------
CCACC-----------------------------------
CCBCC-----------------------------------
CCCCC-----------------------------------
CCDCC-----------------------------------
CCECC-----------------------------------
CCFCC-----------------------------------
CCGCC-----------------------------------
CCHCC-----------------------------------
CCICC-----------------------------------
CCJCC-----------------------------------
CCKCC-----------------------------------
CCLCC-----------------------------------
CCMCC-----------------------------------
CCNCC-----------------------------------
CCOCC-----------------------------------
CCPCC-----------------------------------
CCQCC-----------------------------------
CCRCC-----------------------------------
CCSCC-----------------------------------
CCTCC-----------------------------------
CCUCC-----------------------------------
CCVCC-----------------------------------
CCWCC-----------------------------------
CCXCC-----------------------------------
CCYCC-----------------------------------
CCZCC-----------------------------------
DADDD-----------------------------------
DBDDD-----------------------------------
DCDDD-----------------------------------
DDDDD-----------------------------------
DEDDD-----------------------------------
DFDDD-----------------------------------
DGDDD-----------------------------------
DHDDD-----------------------------------
DIDDD-----------------------------------
DJDDD-----------------------------------
DKDDD-----------------------------------
DLDDD-----------------------------------
DMDDD-----------------------------------
DNDDD-----------------------------------
DODDD-----------------------------------
DPDDD-----------------------------------
DQDDD-----------------------------------
DRDDD-----------------------------------
DSDDD-----------------------------------
DTDDD-----------------------------------
DUDDD-----------------------------------
DVDDD-----------------------------------
TRANS.TXT:
AAAAAI+++++++++++++++++++++++++++++++++++
AAAABU+++++++++++++++++++++++++++++++++++
AAAACD+++++++++++++++++++++++++++++++++++
AAAAEI+++++++++++++++++++++++++++++++++++
DADDDD+++++++++++++++++++++++++++++++++++
DBDDDD+++++++++++++++++++++++++++++++++++
DCDDDD+++++++++++++++++++++++++++++++++++
DDDDDD+++++++++++++++++++++++++++++++++++
DEDDDD+++++++++++++++++++++++++++++++++++
ZAAAAI+++++++++++++++++++++++++++++++++++
0059">
Chapter 19
PROGRAM ORGANIZATION
Program showing main program divisions and their order. Page 378-
380
This program does nothing except to show the main program division and the order in which
they must be coded.
IDENTIFICATION DIVISION.
PROGRAM-ID. MAIN-PGM.
AUTHOR. John Doe.
INSTALLATION. Some Place.
DATE-WRITTEN. Today.
DATE-COMPILED. Today.
SECURITY. Not much.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. PC.
OBJECT-COMPUTER. PC.
SPECIAL-NAMES.
ALPHABET Vowels IS "A", "E", "I", "O", "U"
SYMBOLIC CHARACTERS A-Dash IS 97
CLASS Odd-Num IS "1", "3", "5", "7", "9"
CURRENCY SIGN IS "F"
DECIMAL-POINT IS COMMA
.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT In-File ASSIGN TO INFILE
RESERVE 2 AREAS
ORGANIZATION IS SEQUENTIAL
ACCESS IS SEQUENTIAL
LOCK MODE IS AUTOMATIC
PASSWORD IS A-Password
FILE STATUS IS A-Status
.
SELECT File-1 ASSIGN TO INFILE1.
SELECT File-2 ASSIGN TO INFILE2.
SELECT Sort-1 ASSIGN TO SORT1.
SELECT Sort-2 ASSIGN TO SORT1.
I-O-CONTROL.
SAME RECORD AREA FOR File-1, File-2,
SAME SORT AREA FOR Sort-1, Sort-2,
RERUN ON File-2 EVERY 100 RECORDS
APPLY WRITE ONLY ON File-2
.
DATA DIVISION.
FILE SECTION.
FD In-File
EXTERNAL
GLOBAL
BLOCK CONTAINS 0 RECORDS
RECORD CONTAINS 20 CHARACTERS
LINAGE IS 60 LINES
RECORDING MODE IS F
CODE-SET IS An-Alphabet
.
01 In-File-Rec PIC X(20).
FD File-1.
01 File-1-Rec PIC X(10).
FD File-2.
01 File-2-Rec PIC X(10).
SD Sort-1.
01 Sort-In-1 PIC X(10).
SD Sort-2.
01 Sort-In-2 PIC X(10).
WORKING-STORAGE SECTION.
01 A-Password PIC X(9).
01 A-Status PIC X(2).
LOCAL-STORAGE SECTION.
LINKAGE SECTION.
PROCEDURE DIVISION.
DECLARATIVES.
A-Section SECTION.
USE AFTER ERROR PROCEDURE ON INPUT
.
A-Paragraph.
DISPLAY "I'm here."
.
END DECLARATIVES.
A00-Begin.
DISPLAY "Hello world."
.
END PROGRAM MAIN-PGM.
0059">
Program showing usual statements needed. Page 380
This is a prototype program showing the statement usually coded in a COBOL program.
IDENTIFICATION DIVISION.
PROGRAM-ID. USUAL.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT In-File ASSIGN TO "USUAL.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD In-File
BLOCK CONTAINS 0 RECORDS.
01 In-File-Rec PIC X(20).
WORKING-STORAGE SECTION.
01 In-Rec PIC X(20).
PROCEDURE DIVISION.
A00-Begin.
GOBACK
.
END PROGRAM USUAL.
0059">
Program to accept PARM information. Page 385-386
This program illustrates how to code a program to accept OS/390 JCL PARM information.
IDENTIFICATION DIVISION.
PROGRAM-ID. PARM-IN.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT In-File ASSIGN TO "PARM.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD In-File
BLOCK CONTAINS 0 RECORDS.
01 In-File-Rec PIC X(20).
WORKING-STORAGE SECTION.
01 In-Rec PIC X(20).
01 EOF-In PIC X.
01 The-Value PIC 99.
01 In-Count PIC S9(4) BINARY VALUE 0.
* Counts the In-File records.
LINKAGE SECTION.
01 Parm.
05 Parm-Length PIC S9(4) BINARY SYNC.
05 Parm-Value.
10 Parm-Debug PIC X.
* "Y" turns debugging on.
10 Parm-Cutoff PIC 9(5).
* Cutoff count
05 FILLER PIC X(74).
PROCEDURE DIVISION USING Parm.
A00-Begin.
IF Parm-Length = ZERO
THEN MOVE "N" TO Parm-Debug
MOVE 99999 TO Parm-Cutoff
ELSE DISPLAY "DEBUG FLAG: ", Parm-Debug
DISPLAY "INPUT RECORD CUTOFF: ", Parm-Cutoff
END-IF
READ In-File INTO In-Rec
AT END MOVE "Y" TO EOF-In
NOT AT END
ADD 1 TO In-Count
IF (Parm-Cutoff < 99999) AND
(In-Count = Parm-Cutoff)
THEN MOVE "Y" TO EOF-In
END-IF
END-Read
IF Parm-Debug = "Y"
THEN DISPLAY "The Value: ", The-Value
END-IF
END PROGRAM PARM-IN.
0059">
Program illustrating parameters used for debugging. Page 391-394
This program illustrates how to use OS/390 JCL PARM information for debugging.
IDENTIFICATION DIVISION.
PROGRAM-ID. TESTPGM.
*****************************************************************
* This program reads in a file and selects records with an *
* "X" in column 80. The selected records are written into an *
* output file. The program serves no purpose but to illustrate *
* how a simple COBOL program might be written. *
* RETURN-CODE is ZERO for normal run; 4 for bad PARM field. *
*****************************************************************
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-390 WITH DEBUGGING MODE.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT In-File ASSIGN TO "TSTIN.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT Out-File ASSIGN TO "TSTOUT.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
DATA DIVISION.
FILE SECTION.
FD In-File BLOCK CONTAINS 0 RECORDS.
01 In-File-Image PIC X(80).
FD Out-File BLOCK CONTAINS 0 RECORDS.
01 Out-File-Image PIC X(80).
WORKING-STORAGE SECTION.
01 In-File-Read PIC S9(4) BINARY VALUE ZERO.
01 Out-File-Written PIC S9(4) BINARY VALUE ZERO.
01 In-File-EOF PIC X.
01 File-Image.
* This is the line read in.
05 FILLER PIC X(79).
* Columns 1 to 79 ignored.
05 CC-80 PIC X.
* Look for "X" in column 80.
LINKAGE SECTION.
******************************************************************
* The PARM field is set up to allow the program to be cut off *
* after some number of records has been read. Code the *
* following on the EXEC statement to cut off early for debugging *
* purposes, where nnnnn is the maximum number of records to *
* read. Remember to code the leading zeros. p is flag to *
* print input records read and output records written. Code *
* "Y" to print, "N" to not print. *
* *
* // EXEC COB2UCLG,PARM.GO='nnnnnp' *
* *
* // EXEC COB2UCLG,PARM.GO='00100Y' CUTOFF AFTER 100 RECORDS. *
* PRINT RECORDS. *
******************************************************************
01 Parm.
05 Parm-Length PIC S9(4) BINARY SYNC.
05 Parm-Field.
10 Parm-Cutoff PIC 9(5).
10 Parm-Print PIC X.
10 FILLER PIC X(94).
PROCEDURE DIVISION USING Parm.
DECLARATIVES.
Debug-It SECTION.
* This provides a trace of the procedures invoked.
USE FOR DEBUGGING ON ALL PROCEDURES.
Debug-Procedures.
DISPLAY DEBUG-LINE, DEBUG-NAME, DEBUG-CONTENTS.
END DECLARATIVES.
A00-Begin.
DISPLAY "PROGRAM TEST EXECUTION BEGINS."
PERFORM A10-Initialize
MOVE "N" TO In-File-EOF
PERFORM A20-Read-All-Records WITH TEST AFTER
UNTIL In-File-EOF = "Y"
PERFORM A40-Terminate
GOBACK
.
A10-Initialize.
************************************************************
* PROCEDURE TO ADD INITIALIZE FOR RUN. *
* IN: All files closed. *
* PARM fields stored in LINKAGE SECTION. *
* OUT: Parm-Cutoff contains valid cutoff value. *
* In-File opened for input. *
* Out-File opened for output. *
************************************************************
IF Parm-Length NOT = 6
THEN MOVE 99999 TO Parm-Cutoff
MOVE "N" TO Parm-Print
ELSE IF Parm-Cutoff NOT NUMERIC
THEN DISPLAY "WARNING--BAD PARM RECORD COUNT: ",
Parm-Cutoff
MOVE 4 TO RETURN-CODE
MOVE 99999 TO Parm-Print
ELSE DISPLAY "WILL CUTOFF AFTER ", Parm-Cutoff,
"RECORDS READ FOR DEBUGGING"
END-IF
IF Parm-Print NOT = "Y" AND Parm-Print NOT = "N"
THEN DISPLAY
"WARNING--INCORRECT PARM PRINT FLAG: ",
Parm-Print
MOVE 4 TO RETURN-CODE
MOVE "N" TO Parm-Print
ELSE DISPLAY "PARM PRINT FLAG: ", Parm-Print
END-IF
END-IF
OPEN INPUT In-File, OUTPUT Out-File
.
**** Exit
A20-Read-All-Records.
*************************************************************
* PROCEDURE TO READ ALL THE RECORDS IN In-File. *
* IN: In-File opened for input. *
* Out-File opened for output. *
* In-File-EOF contains "N". *
* OUT: Records with X in column 80 written into Out-File. *
* Out-File-Written bumped by 1 if record written. *
*************************************************************
MOVE SPACE TO CC-80
PERFORM A30-Select-A-Record WITH TEST AFTER
UNTIL (CC-80 = "X") OR (In-File-EOF = "Y")
IF In-File-EOF NOT = "Y"
THEN WRITE Out-File-Image FROM File-Image
ADD 1 TO Out-File-Written
IF Parm-Print = "Y"
THEN DISPLAY "Out-File: ", File-Image
END-IF
END-IF
.
**** Exit
A30-Select-A-Record.
************************************************************
* PROCEDURE TO ADD ENTRIES TO PERSON TABLE. *
* IN: In-File opened for input. *
* In-File-EOF contains "N". *
* OUT: In-File-EOF set to "Y" if EOF for In-File or *
* Parm-Cutoff records read. *
* In-File bumped by 1 to count In-File record read. *
* File-Image contains input record if no EOF. *
************************************************************
READ In-File INTO File-Image
AT END MOVE "Y" TO In-File-EOF
NOT AT END
IF (Parm-Cutoff < 99999) AND
(In-File-Read = Parm-Cutoff)
THEN MOVE "Y" TO In-File-EOF
DISPLAY "CUTOFF FOR DEBUGGING."
ELSE ADD 1 TO In-File-Read
IF Parm-Print = "Y"
THEN DISPLAY "File-Image: ", File-Image
END-IF
END-IF
END-Read
.
**** Exit
A40-Terminate.
************************************************************
* PROCEDURE TO TERMINATE PROGRAM. *
* IN: In-File-Read contains count of In-File records read *
* Out-File-Written contains count of Out-File records *
* written. *
* In-File and Out-File files open. *
* OUT: End message and record counts displayed. *
* In-File and Out-File files closed. *
************************************************************
CLOSE In-File, Out-File
DISPLAY "NORMAL COMPLETION OF PROGRAM TESTPGM."
DISPLAY "RECORDS READ: ", In-File-Read
DISPLAY "RECORDS WRITTEN: ", Out-File-Written
.
**** Exit
END PROGRAM TESTPGM.
TSTIN.TXT:
1111111111111111111111111111111111111111111111111111111111111111111111111111111X
22222222222222222222222222222222222222222222222222222222222222222222222222222222
33333333333333333333333333333333333333333333333333333333333333333333333333333333
4444444444444444444444444444444444444444444444444444444444444444444444444444444X
5555555555555555555555555555555555555555555555555555555555555555555555555555555X
66666666666666666666666666666666666666666666666666666666666666666666666666666666
0059">
Chapter 20
SUBPROGRAMS
Subprogram showing needed statements. Page 403-404
This illustrates the statement needed to code a subprogram.
IDENTIFICATION DIVISION.
PROGRAM-ID. A-SUB.
DATA DIVISION.
FILE SECTION.
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 Arg-1 PIC X.
01 Arg-2 PIC X.
01 Arg-3 PIC X.
PROCEDURE DIVISION USING Arg-1, Arg-2, Arg-3.
DISPLAY "ENTERED SUBPROGRAM A-SUB"
GOBACK.
END PROGRAM A-SUB.
0059">
Program illustrating call to subprogram. Page 404
This program calls the TABLEPGM subprogram, supplying three arguments.
IDENTIFICATION DIVISION.
PROGRAM-ID. TESTPGM.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 A.
05 Dd OCCURS 5 TIMES INDEXED BY Idd
PIC X(20).
01 B PIC S9(4) BINARY.
01 C PIC X(20).
PROCEDURE DIVISION.
A00-Begin.
MOVE 3 TO B
MOVE SPACES TO C
CALL "TABLEPGM" USING A, B, C
GOBACK
.
END PROGRAM TESTPGM.
0059">
Subprogram example. Page 405.
This program illustrated a subprogram that has three arguments as input. It is called by the
previous main program.
IDENTIFICATION DIVISION.
PROGRAM-ID. TABLEPGM.
DATA DIVISION.
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 X.
05 Xx PIC X(20) OCCURS 5 TIMES
INDEXED BY Ixx.
01 Y PIC S9(4) BINARY.
01 Z PIC X(20).
PROCEDURE DIVISION USING X, Y, Z.
A00-Begin.
PERFORM VARYING IXX FROM 1 BY 1 UNTIL Ixx > Y
MOVE Z TO Xx(Ixx)
END-PERFORM
MOVE ZERO TO Y
GOBACK
.
END PROGRAM TABLEPGM.
0059">
Chapter 21
FUNCTIONS
Program illustrating writing function. Page 430-431
This function converts minutes to seconds.
IDENTIFICATION DIVISION.
FUNCTION-ID. Min-To-Sec.
*****************************************************************
* FUNCTION TO CONVERT MINUTES TO SECONDS. *
* INVOKED: Seconds - FUNCTION(Minute) *
* IN: Minutes contains minutes in PIC S9(9) BINARY. *
* OUT: Seconds contains seconds in PIC S9(9) BINARY. *
*****************************************************************
DATA DIVISION
LINKAGE SECTION.
01 Min PIC S9(9) BINARY.
01 Sec PIC S9(9) BINARY.
PROCEDURE DIVISION USING Min RETURNING Sec.
A00-Begin
COMPUTE Sec = Min * 60
EXIT FUNCTION
.
END FUNCTION Min-To-Sec.
0059">
Program illustrating use of function. Page 431
This program invokes the Min-To-Sec function to illustrate its use.
IDENTIFICATION DIVISION.
PROGRAM-ID. Some-Program.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
REPOSITORY.
FUNCTION Min-To-Sec.
WORKING-STORAGE SECTION.
01 Minutes PIC S9(9).
01 Seconds PIC S9(9).
PROCEDURE DIVISION.
A00-Begin.
MOVE 32 TO Minutes
COMPUTE Seconds = Min-To-Sec(Minutes)
DISPLAY Seconds
GOBACK
.
END PROGRAM Some-Program.
0059">
Chapter 22
ADVANCED CHARACTER MANIPULATION
Program illustrating character manipulation. Page 450-452
This program concatenates "MARY HAD A LITTLE LAMB." with "ITS FLEECE WAS
WHITE AS SNOW."
IDENTIFICATION DIVISION.
PROGRAM-ID. CHAREXAMP.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Point-1 PIC S9(4) BINARY.
01 No-Moved PIC S9(4) BINARY.
01 Point-3 PIC S9(4) BINARY.
01 Point-4 PIC S9(4) BINARY.
01 String-1 PIC X(23) VALUE
"MARY HAD A LITTLE LAMB.".
01 String-2 PIC X(29) VALUE
"ITS FLEECE WAS WHITE AS SNOW.".
01 String-3 PIC X(55).
01 String-4 PIC X(55).
01 String-5 PIC X(55).
PROCEDURE DIVISION.
A00-Begin.
***************************************************************
* See if String-1 contains "LAMB" *
***************************************************************
MOVE ZERO TO Point-1
INSPECT String-1 TALLYING Point-1 FOR ALL "LAMB"
***************************************************************
* Concatenate String-1 and String-2 into String-3. *
***************************************************************
MOVE SPACES TO String-3
MOVE 1 TO Point-1
STRING String-1 DELIMITED "." INTO String-3 POINTER Point-1
STRING ". " DELIMITED SIZE INTO String-3 POINTER Point-1
STRING String-2 DELIMITED "." INTO String-3 POINTER Point-1
STRING "." DELIMITED SIZE INTO String-3 POINTER Point-1
DISPLAY String-3
***************************************************************
* FIND string "LITTLE LAMB" and move it to String-4. *
***************************************************************
MOVE SPACES TO String-4
MOVE 1 TO Point-3
STRING String-3 DELIMITED "LITTLE LAMB" INTO String-5
POINTER Point-3
IF Point-3 > 1
THEN MOVE String-3(Point-3:FUNCTION LENGTH("LITTLE LAMB"))
TO String-4
END-IF
DISPLAY String-4
***************************************************************
* Replace "LAMB" with "TOFU". *
***************************************************************
INSPECT String-3 REPLACING ALL "LAMB" BY "TOFU"
DISPLAY String-3
***************************************************************
* Replace "LITTLE" with "BIG" and store in String-4. *
***************************************************************
MOVE SPACES TO String-4
MOVE 1 TO Point-3
MOVE 1 TO Point-4
PERFORM WITH TEST AFTER UNTIL Point-3 > LENGTH OF String-3
UNSTRING String-3 DELIMITED "LITTLE" INTO String-5
COUNT No-Moved
POINTER Point-3
ON OVERFLOW
MOVE String-5(1:No-Moved) TO
String-4(Point-4:No-Moved)
ADD No-Moved TO Point-4
STRING "BIG" DELIMITED SIZE INTO String-4
POINTER Point-4
END-STRING
NOT ON OVERFLOW
IF No-Moved > ZERO THEN
MOVE String-5(1:No-Moved) TO
String-4(Point-4:No-Moved)
ADD No-Moved TO Point-4
END-IF
END-UNSTRING
END-PERFORM
DISPLAY String-4
GOBACK
.
END PROGRAM CHAREXAMP.
0059">
Chapter 23
SORTING
Program sorting dates with two-digit years. Page 466-467
This program illustrates the use of both sort input and output procedures to sort dates.
It uses the sliding window to convert the two-digit year to four digits for the sort.
IDENTIFICATION DIVISION.
PROGRAM-ID. SORT-IT.
*****************************************************************
* PROGRAM TO SORT INPUT FILE, CONVERT TWO-DIGIT YEARS TO FOUR *
* DIGITS FOR THE SORT, AND WRITE THE SORTED OUTPUT FILE. *
* IN: File-I CONTAINS THE INPUT FILE. *
* OUT: File-O CONTAINS THE SORTED INPUT FILE. *
*****************************************************************
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT File-I ASSIGN TO "SORTIN.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT File-O ASSIGN TO "SORTOUT.TXT"
ORGANIZATION IS LINE SEQUENTIAL.
SELECT Sort-File ASSIGN TO "SORTWK.TXT".
DATA DIVISION.
FILE SECTION.
FD File-I.
01 File-I-Rec PIC X(66).
FD File-O.
01 File-O-Rec PIC X(68).
SD Sort-File.
01 Sort-Rec.
05 Sort-Data PIC X(30).
05 Sort-Date.
10 Sort-Yr PIC 9(4).
10 Sort-Mo PIC 99.
10 Sort-Dy PIC 99.
05 Sort-More-Data PIC X(30).
WORKING-STORAGE SECTION.
01 In-Rec.
05 In-Data PIC X(30).
05 In-Date.
10 In-Yr PIC 99.
10 In-Mo PIC 99.
10 In-Dy PIC 99.
05 In-More-Data PIC X(30).
01 EOF-In-Flag PIC X.
88 EOF-In VALUE "Y".
01 EOF-Sort-Flag PIC X.
88 EOF-Sort VALUE "Y".
01 N PIC S99 VALUE 2.
01 Curr-Yr PIC 9(4).
PROCEDURE DIVISION.
SORT Sort-File
ON ASCENDING KEY Sort-Date
INPUT PROCEDURE IS B10-Get-Records
OUTPUT PROCEDURE IS C10-Write-Records
GOBACK
.
B10-Get-Records.
MOVE "N" TO EOF-In-Flag
OPEN INPUT File-I
PERFORM UNTIL EOF-In
READ File-I INTO In-Rec
AT END SET EOF-In TO TRUE
NOT AT END
MOVE In-Data TO Sort-Data
MOVE In-More-Data TO Sort-More-Data
MOVE FUNCTION CURRENT-DATE(1:4) TO Curr-Yr
MOVE In-Mo TO Sort-Mo
MOVE In-Dy TO Sort-Dy
COMPUTE Curr-Yr, Sort-Yr = Curr-Yr + N
MOVE "00" TO Sort-Yr(3:2)
IF In-Yr > Curr-Yr(3:2)
THEN COMPUTE Sort-Yr = In-Yr + Sort-Yr - 100
ELSE COMPUTE Sort-Yr = In-Yr + Sort-Yr
END-IF
RELEASE Sort-Rec
END-READ
END-PERFORM
CLOSE File-I
.
**** EXIT
C10-Write-Records.
MOVE "N" TO EOF-Sort-Flag
OPEN OUTPUT File-O
PERFORM UNTIL EOF-Sort
RETURN Sort-File
AT END SET EOF-Sort TO TRUE
NOT AT END
MOVE Sort-Data TO In-Data
MOVE Sort-More-Data TO In-More-Data
MOVE Sort-Yr(3:2) TO In-Yr
MOVE Sort-Mo TO In-Mo
MOVE Sort-Dy TO In-DY
WRITE File-O-Rec FROM In-Rec
END-RETURN
END-PERFORM
CLOSE File-O
.
**** EXIT
END PROGRAM SORT-IT.
SORTIN.TXT:
111111111111111111111111111111640228111111111111111111111111111111
222222222222222222222222222222660101222222222222222222222222222222
333333333333333333333333333333651231333333333333333333333333333333
444444444444444444444444444444671111444444444444444444444444444444
555555555555555555555555555555680606555555555555555555555555555555
0059">
Chapter 24
FULL-SCREEN I/O IN PC APPLICATIONS
Program illustrating full-screen I/O. Page 490-491
This program asks a person to enter their name and ID.
IDENTIFICATION DIVISION.
PROGRAM-ID. FULLSCR.
*****************************************************************
* PROGRAM TO ASK PERSON TO ENTER THEIR NAME AND ID. *
* IN: Nothing. *
* OUT: The-Name CONTAINS THE NAME. *
* The-Id CONTAINS THE Id. *
*****************************************************************
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 The-Name PIC X(40).
01 The-Id PIC X(6).
SCREEN SECTION.
01 Screen-1 BLANK SCREEN
AUTO PROMPT REQUIRED
BACKGROUND-COLOR 1
FOREGROUND-COLOR 7.
05 First-Line.
10 LINE 5 COL 10 VALUE "Enter your name: "
HIGHLIGHT.
10 COL 30 PIC X(40) REVERSE-VIDEO
TO The-Name.
05 Second-Line.
10 LINE 7 COL 10 VALUE "Enter your id: "
HIGHLIGHT.
10 COL 40 PIC X(6) REVERSE-VIDEO
TO The-Id.
PROCEDURE DIVISION.
DISPLAY Screen-1
ACCEPT Screen-1
GOBACK
.
END PROGRAM FULLSCR.
0059">
Chapter 25
POINTER DATA AND CICS
Program illustrating subprogram using pointers. Page 495-497
This program illustrates how to obtain the address of an item and use the address to count
blanks in the item.
IDENTIFICATION DIVISION.
PROGRAM-ID. TNOBLNK.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 A-Table.
05 A-Tbl-V.
10 PIC X(10) VALUE " ".
10 PIC X(10) VALUE "1111111111".
10 PIC X(10) VALUE " 111111111".
10 PIC X(10) VALUE "1 1111111".
10 PIC X(10) VALUE "11 11111".
10 PIC X(10) VALUE "111 111".
10 PIC X(10) VALUE "11111 ".
05 A-Tbl REDEFINES A-Tbl-V OCCURS 7 TIMES PIC X(10).
01 Ix PIC S9(4) BINARY.
01 Max-Tbl PIC S9(4) BINARY VALUE 7.
01 An-Address POINTER.
01 An-Item PIC X(100).
01 No-Blanks PIC 9(9) BINARY.
01 Len-Item PIC 9(9) BINARY.
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING TNOBLNK PROGRAM."
PERFORM WITH TEST BEFORE VARYING Ix FROM 1 BY 1
UNTIL Ix > Max-Tbl
CALL "GETADD" USING BY REFERENCE An-Item, An-Address
MOVE A-Tbl(Ix) TO An-Item
MOVE 10 TO Len-Item
CALL "NOBLANKS" USING BY CONTENT An-Address, Len-Item
BY REFERENCE No-Blanks
DISPLAY "An-Item: ", An-Item, " Blanks: ", No-Blanks
END-PERFORM
GOBACK
.
IDENTIFICATION DIVISION.
PROGRAM-ID. NOBLANKS.
*****************************************************************
* SUBPROGRAM TO COUNT NUMBER OF BLANKS IN AN ITEM. *
* CALL "NOBLANKS" USING BY CONTENT A-Pointer, Len-Item, *
* BY REFERENCE Num-Blanks *
* IN: A-Pointer points to data item. POINTER *
* Len-Item contains length of data item. PIC 9(9) BINARY *
* OUT: Num-Blanks contains count of blanks in data item. *
* PIC 9(9) BINARY *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Num-Item PIC S9(4) BINARY.
LINKAGE SECTION.
01 A-Pointer POINTER.
01 Len-Item PIC 9(9) BINARY.
01 Num-Blanks PIC 9(9) BINARY.
01 The-Item PIC X(1).
PROCEDURE DIVISION USING A-Pointer, Len-Item, Num-Blanks.
A00-Begin.
SET ADDRESS OF The-Item TO A-Pointer
MOVE ZEROS TO Num-Blanks
PERFORM VARYING Num-Item FROM 1 BY 1
UNTIL Num-Item > Len-Item
IF The-Item(Num-Item:1) = SPACE
THEN ADD 1 TO Num-Blanks
END-IF
END-PERFORM
EXIT PROGRAM.
END PROGRAM NOBLANKS.
IDENTIFICATION DIVISION.
PROGRAM-ID. GETADD.
*****************************************************************
* SUBPROGRAM TO OBTAIN THE ADDRESS OF AN ITEM. *
* CALL "GETADD" USING BY REFERENCE A-Rec, A-Pointer *
* IN: A-Rec is any data item: DISPLAY, BINARY, PACKED, etc. *
* OUT: A-Pointer contains the address of A-Rec. POINTER *
*****************************************************************
DATA DIVISION.
LINKAGE SECTION.
01 A-Rec PIC X(1).
01 A-Pointer POINTER.
PROCEDURE DIVISION USING A-Rec, A-Pointer.
A00-Begin.
SET A-Pointer TO ADDRESS OF A-Rec
EXIT PROGRAM.
END PROGRAM GETADD.
END PROGRAM TNOBLNK.
0059">
Program illustrating using an address to store data in an item. Page
497
This program illustrates how to use an address to store data in an item.
IDENTIFICATION DIVISION.
PROGRAM-ID. ADDR-USE.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 An-Address POINTER.
01 Part-1.
05 Part-A PIC X(4) VALUE "1234".
05 Part-B PIC S9(4) BINARY VALUE 10.
05 Part-C PIC S9(6) PACKED-DECIMAL
VALUE 20.
05 Part-D PIC X(2) VALUE "YZ".
01 P-Part-1.
05 P-Part-A PIC X(4).
05 P-Part-B PIC S9(4) BINARY.
05 P-Part-C PIC S9(6) PACKED-DECIMAL.
05 P-Part-D PIC X(2).
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING ADDR-USE PROGRAM."
CALL "GETADD" USING BY REFERENCE Part-1, An-Address
CALL "STOREADD" USING BY CONTENT An-Address,
FUNCTION LENGTH(Part-1), BY REFERENCE P-Part-1
DISPLAY "P-Part-A: ", P-Part-A
DISPLAY "P-Part-B: ", P-Part-B
DISPLAY "P-Part-C: ", P-Part-C
DISPLAY "P-Part-D: ", P-Part-D
GOBACK
.
IDENTIFICATION DIVISION.
PROGRAM-ID. GETADD.
*****************************************************************
* SUBPROGRAM TO OBTAIN THE ADDRESS OF AN ITEM. *
* CALL "GETADD" USING BY REFERENCE A-Rec, A-Pointer *
* IN: A-Rec is any data item: DISPLAY, BINARY, PACKED, etc. *
* OUT: A-Pointer contains the address of A-Rec. POINTER *
*****************************************************************
DATA DIVISION.
LINKAGE SECTION.
01 A-Rec PIC X(1).
01 A-Pointer POINTER.
PROCEDURE DIVISION USING A-Rec, A-Pointer.
A00-Begin.
SET A-Pointer TO ADDRESS OF A-Rec
EXIT PROGRAM.
END PROGRAM GETADD.
IDENTIFICATION DIVISION.
PROGRAM-ID. STOREADD.
*****************************************************************
* SUBPROGRAM TO STORE ITEM IN IDENTIFIER, GIVEN ITEM'S ADDRESS. *
* CALL "STOREADD" USING BY CONTENT A-Pointer, Len-Item, *
* BY REFERENCE A-Rec *
* IN: A-Pointer contains address of item to store. POINTER *
* Len-Item contains the length of item. PIC 9(9) BINARY *
* OUT: A-Rec contains the contents of item pointed to. *
* Should be same PIC as data item, but data is *
* moved to it without conversion regardless of its *
* format. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Num-Item PIC 9(9) BINARY.
LINKAGE SECTION.
01 A-Rec PIC X(1).
01 Len-Item PIC 9(9) BINARY.
01 A-Pointer POINTER.
01 The-Item PIC X(1).
PROCEDURE DIVISION USING A-Pointer, Len-Item, A-Rec.
SET ADDRESS OF The-Item TO A-Pointer
PERFORM WITH TEST AFTER
VARYING Num-Item FROM 1 BY 1
UNTIL Num-Item > Len-Item
MOVE The-Item(Num-Item:1) TO A-Rec(Num-Item:1)
END-PERFORM
EXIT PROGRAM.
END PROGRAM STOREADD.
END PROGRAM ADDR-USE.
0059">
Another program illustrating calling subprograms to store item, given
its address. Page 498-499
This program also illustrates calls to GETADD and STOREADD.
IDENTIFICATION DIVISION.
PROGRAM-ID. MORE-ADDR.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Rec-Table.
05 Rec-1 PIC X(10) VALUE "1111111111".
05 Rec-2 PIC X(10) VALUE "2222222222".
05 Rec-3 PIC X(10) VALUE "3333333333".
05 Rec-4 PIC X(10) VALUE "4444444444".
05 Rec-5 PIC X(10) VALUE "5555555555".
05 Rec-No PIC S9(4) BINARY VALUE 5.
01 REDEFINES Rec-Table.
05 Rec-Item OCCURS 5 TIMES
INDEXED BY Rec-X
PIC X(10).
01 Ptr-Table.
05 Ptr-Entry OCCURS 10 TIMES
INDEXED BY Ptr-X
POINTER.
01 Next-Rec PIC X(10).
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING MORE-ADDR PROGRAM."
PERFORM WITH TEST BEFORE VARYING Rec-X FROM 1 BY 1
UNTIL Rec-X > Rec-No
SET Ptr-X TO Rec-X
CALL "GETADD" USING BY REFERENCE Rec-Item(Rec-X),
Ptr-Entry(Ptr-X)
END-PERFORM
SET Ptr-Entry(Rec-No + 1) TO NULLS
MOVE SPACES TO Next-Rec
PERFORM WITH TEST BEFORE VARYING Ptr-X FROM 1 BY 1
UNTIL Ptr-Entry(Ptr-X) = NULLS
CALL "STOREADD" USING BY CONTENT Ptr-Entry(Ptr-X),
FUNCTION LENGTH(Rec-1), BY REFERENCE Next-Rec
DISPLAY "NEXT REC: ", Next-Rec
END-PERFORM
GOBACK
.
IDENTIFICATION DIVISION.
PROGRAM-ID. GETADD.
*****************************************************************
* SUBPROGRAM TO OBTAIN THE ADDRESS OF AN ITEM. *
* CALL "GETADD" USING BY REFERENCE A-Rec, A-Pointer *
* IN: A-Rec is any data item: DISPLAY, BINARY, PACKED, etc. *
* OUT: A-Pointer contains the address of A-Rec. POINTER *
*****************************************************************
DATA DIVISION.
LINKAGE SECTION.
01 A-Rec PIC X(1).
01 A-Pointer POINTER.
PROCEDURE DIVISION USING A-Rec, A-Pointer.
A00-Begin.
SET A-Pointer TO ADDRESS OF A-Rec
EXIT PROGRAM.
END PROGRAM GETADD.
IDENTIFICATION DIVISION.
PROGRAM-ID. STOREADD.
*****************************************************************
* SUBPROGRAM TO STORE ITEM IN IDENTIFIER, GIVEN ITEM'S ADDRESS. *
* CALL "STOREADD" USING BY CONTENT A-Pointer, Len-Item, *
* BY REFERENCE A-Rec *
* IN: A-Pointer contains address of item to store. POINTER *
* Len-Item contains the length of item. PIC 9(9) BINARY *
* OUT: A-Rec contains the contents of item pointed to. *
* Should be same PIC as data item, but data is *
* moved to it without conversion regardless of its *
* format. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Num-Item PIC 9(9) BINARY.
LINKAGE SECTION.
01 A-Rec PIC X(1).
01 Len-Item PIC 9(9) BINARY.
01 A-Pointer POINTER.
01 The-Item PIC X(1).
PROCEDURE DIVISION USING A-Pointer, Len-Item, A-Rec.
SET ADDRESS OF The-Item TO A-Pointer
PERFORM WITH TEST AFTER
VARYING Num-Item FROM 1 BY 1
UNTIL Num-Item > Len-Item
MOVE The-Item(Num-Item:1) TO A-Rec(Num-Item:1)
END-PERFORM
EXIT PROGRAM.
END PROGRAM STOREADD.
END PROGRAM MORE-ADDR.
0059">
Chapter 26
ALL ABOUT DATES
Program example, sliding window technique. Page 512
This program converts a two-digit year to four-digits using the sliding window technique.
IDENTIFICATION DIVISION.
PROGRAM-ID. TSLIDE.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Yr-Table.
05 Yr-Tbl-V.
10 PIC 9(6) VALUE 000102.
10 PIC 9(6) VALUE 200304.
10 PIC 9(6) VALUE 300506.
10 PIC 9(6) VALUE 960708.
10 PIC 9(6) VALUE 970910.
10 PIC 9(6) VALUE 981112.
10 PIC 9(6) VALUE 991314.
05 Yr-Tbl REDEFINES Yr-Tbl-V OCCURS 7 TIMES PIC 9(6).
01 Ix PIC S9(4) BINARY.
01 Max-Tbl PIC S9(4) BINARY VALUE 7.
01 New-Date.
05 New-Yr PIC 9(4).
05 New-Mo PIC 99.
05 New-Dy PIC 99.
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING TSLIDE PROGRAM."
PERFORM WITH TEST BEFORE VARYING Ix FROM 1 BY 1
UNTIL Ix > Max-Tbl
CALL "SLIDE-W" USING BY CONTENT Yr-Tbl(Ix)
BY REFERENCE New-Date
DISPLAY Yr-Tbl(Ix), ": ", New-Date
END-PERFORM
GOBACK
.
IDENTIFICATION DIVISION.
PROGRAM-ID. SLIDE-W.
*****************************************************************
* SUBPROGRAM TO CONVERT A TWO-DIGIT YEAR TO FOUR DIGITS, USING *
* THE SLIDING YEAR TECHNIQUE. *
* CALL "SLIDE-W" USING BY CONTENT Some-Date, *
* BY REFERENCE New-Date *
* IN: Some-Date CONTAINS THE YEAR AS PIC 9(6) IN yymmdd FORM. *
* OUT: New-Date CONTAINS THE YEAR AS PIC 9(8) IN yyyymmdd FORM. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 N PIC S99 VALUE 2.
01 Curr-Yr PIC 9(4).
LINKAGE SECTION.
01 Some-Date.
05 Yr PIC 99.
05 Mo PIC 99.
05 Dy PIC 99.
01 New-Date.
05 New-Yr PIC 9(4).
05 New-Mo PIC 99.
05 New-Dy PIC 99.
PROCEDURE DIVISION USING Some-Date, New-Date.
A00-Begin.
MOVE FUNCTION CURRENT-DATE(1:4) TO Curr-Yr
MOVE Mo TO New-Mo
MOVE Dy TO New-Dy
COMPUTE Curr-Yr, New-Yr = Curr-Yr + N
MOVE "00" TO New-Yr(3:2)
IF Yr > Curr-Yr(3:2)
THEN COMPUTE New-Yr = Yr + New-Yr - 100
ELSE COMPUTE New-Yr = Yr + New-Yr
END-IF
GOBACK
.
END PROGRAM SLIDE-W.
END PROGRAM TSLIDE.
0059">
Program example, sliding window technique with packed decimal.
Page 512
This subprogram also illustrates the sliding window technique, but with packed-decimal data.
IDENTIFICATION DIVISION.
PROGRAM-ID. TSLIDE2.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Yr-Table.
05 Yr-Tbl-V.
10 D1.
15 PIC 9(2) VALUE 00
PACKED-DECIMAL.
15 PIC 9(2) VALUE 01
PACKED-DECIMAL.
15 PIC 9(2) VALUE 02
PACKED-DECIMAL.
10 D2.
15 PIC 9(2) VALUE 20
PACKED-DECIMAL.
15 PIC 9(2) VALUE 03
PACKED-DECIMAL.
15 PIC 9(2) VALUE 04
PACKED-DECIMAL.
10 D3.
15 PIC 9(2) VALUE 30
PACKED-DECIMAL.
15 PIC 9(2) VALUE 05
PACKED-DECIMAL.
15 PIC 9(2) VALUE 06
PACKED-DECIMAL.
10 D4.
15 PIC 9(2) VALUE 96
PACKED-DECIMAL.
15 PIC 9(2) VALUE 07
PACKED-DECIMAL.
15 PIC 9(2) VALUE 08
PACKED-DECIMAL.
10 D5.
15 PIC 9(2) VALUE 97
PACKED-DECIMAL.
15 PIC 9(2) VALUE 09
PACKED-DECIMAL.
15 PIC 9(2) VALUE 10
PACKED-DECIMAL.
10 D6.
15 PIC 9(2) VALUE 98
PACKED-DECIMAL.
15 PIC 9(2) VALUE 11
PACKED-DECIMAL.
15 PIC 9(2) VALUE 12
PACKED-DECIMAL.
10 D7.
15 PIC 9(2) VALUE 99
PACKED-DECIMAL.
15 PIC 9(2) VALUE 13
PACKED-DECIMAL.
15 PIC 9(2) VALUE 14
PACKED-DECIMAL.
05 Yr-Tbl REDEFINES Yr-Tbl-V OCCURS 7 TIMES.
10 Yr-Table-Date.
15 Yr-Tbl-Yr PIC 9(2) PACKED-DECIMAL.
15 Yr-Tbl-Mo PIC 9(2) PACKED-DECIMAL.
15 Yr-Tbl-Dy PIC 9(2) PACKED-DECIMAL.
01 Ix PIC S9(4) BINARY.
01 Max-Tbl PIC S9(4) BINARY VALUE 7.
01 New-Date.
05 New-Yr PIC 9(4) PACKED-DECIMAL.
05 New-Mo PIC 99 PACKED-DECIMAL.
05 New-Dy PIC 99 PACKED-DECIMAL.
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING TSLIDE2 PROGRAM."
PERFORM WITH TEST BEFORE VARYING Ix FROM 1 BY 1
UNTIL Ix > Max-Tbl
CALL "SLIDE-W-2" USING BY CONTENT Yr-Tbl(Ix)
BY REFERENCE New-Date
DISPLAY Yr-Tbl-Yr(Ix), Yr-Tbl-Mo(Ix), Yr-Tbl-Dy(Ix),
": ", New-Yr, New-Mo, New-Dy
END-PERFORM
GOBACK
.
IDENTIFICATION DIVISION.
PROGRAM-ID. SLIDE-W-2.
*****************************************************************
* SUBPROGRAM TO CONVERT A TWO-DIGIT YEAR TO FOUR DIGITS, USING *
* THE SLIDING YEAR TECHNIQUE. *
* CALL "SLIDE-W" USING BY CONTENT Some-Date, *
* BY REFERENCE New-Date *
* IN: Some-Date CONTAINS THE YEAR AS PIC 99 (yy), PIC 99 (mm), *
* PIC 99 (dd), all in PACKED-DECIMAL. *
* OUT: New-Date CONTAINS THE YEAR AS PIC 9(4) (yy), *
* PIC 99 (mm), PIC 99 (yy), all in PACKED-DECIMAL. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 N PIC S99 VALUE 2.
01 Curr-Yr PIC 9(4).
LINKAGE SECTION.
01 Some-Date.
05 Yr PIC 99 PACKED-DECIMAL.
05 Mo PIC 99 PACKED-DECIMAL.
05 Dy PIC 99 PACKED-DECIMAL.
01 New-Date.
05 New-Yr PIC 9(4) PACKED-DECIMAL.
05 New-Mo PIC 99 PACKED-DECIMAL.
05 New-Dy PIC 99 PACKED-DECIMAL.
PROCEDURE DIVISION USING Some-Date, New-Date.
A00-Begin.
MOVE FUNCTION CURRENT-DATE(1:4) TO Curr-Yr
MOVE Mo TO New-Mo
MOVE Dy TO New-Dy
COMPUTE Curr-Yr = Curr-Yr + N
COMPUTE New-Yr = (FUNCTION INTEGER(Curr-Yr / 100)) * 100
IF Yr > FUNCTION NUMVAL(Curr-Yr(3:2))
THEN COMPUTE New-Yr = Yr + New-Yr - 100
ELSE COMPUTE New-Yr = Yr + New-Yr
END-IF
GOBACK
.
END PROGRAM SLIDE-W-2.
END PROGRAM TSLIDE2.
0059">
Program example, determining leap year. Page 515
This program illustrates a subprogram to determine whether a year is a leap year.
IDENTIFICATION DIVISION.
PROGRAM-ID. TLEAP.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Yr-Table.
05 Yr-Tbl-V.
10 PIC 9(4) VALUE 1900.
10 PIC 9(4) VALUE 2000.
10 PIC 9(4) VALUE 3000.
10 PIC 9(4) VALUE 1999.
10 PIC 9(4) VALUE 1998.
10 PIC 9(4) VALUE 1997.
10 PIC 9(4) VALUE 1996.
05 Yr-Tbl REDEFINES Yr-Tbl-V OCCURS 7 TIMES PIC 9(4).
01 Ix PIC S9(4) BINARY.
01 Max-Tbl PIC S9(4) BINARY VALUE 7.
01 Leap-Flag PIC X.
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING TLEAP PROGRAM."
PERFORM WITH TEST BEFORE VARYING Ix FROM 1 BY 1
UNTIL Ix > Max-Tbl
CALL "LEAP-YR" USING BY CONTENT Yr-Tbl(Ix)
BY REFERENCE Leap-Flag
DISPLAY Yr-Tbl(Ix), ": ", Leap-Flag
END-PERFORM
GOBACK
.
IDENTIFICATION DIVISION.
PROGRAM-ID. LEAP-YR.
*****************************************************************
* SUBPROGRAM TO DETERMINE WHETHER A YEAR IS A LEAP YEAR. *
* CALL "LEAP-YEAR" USING BY CONTENT The-Year, *
* BY REFERENCE Leap-Year *
* IN: The-Year is PIC 9(4) item containing four-digit year. *
* OUT: Leap-Year is PIC X item. "N" returned if not leap year. *
* "Y" returned if leap year. *
*****************************************************************
DATA DIVISION.
LINKAGE SECTION.
01 The-Year PIC 9(4).
01 Leap-Year PIC X.
* "N"-Not a leap year.
* "Y"-Leap year.
PROCEDURE DIVISION USING The-Year, Leap-Year.
MOVE "N" TO Leap-Year
IF FUNCTION REM(The-Year, 400) = ZERO
THEN MOVE "Y" TO Leap-Year
ELSE IF FUNCTION REM(The-Year, 4) = ZERO
AND NOT FUNCTION REM(The-Year, 100) = ZERO
THEN MOVE "Y" TO Leap-Year
END-IF
END-IF
GOBACK
.
END PROGRAM LEAP-YR.
END PROGRAM TLEAP.
0059">
Program example, age calculation. Page 515
This program illustrates a subprogram to calculate the age, given a birth date.
IDENTIFICATION DIVISION.
PROGRAM-ID. TAGE.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Yr-Table.
05 Yr-Tbl-V.
10 PIC 9(8) VALUE 19960229.
10 PIC 9(8) VALUE 19960228.
10 PIC 9(8) VALUE 19901221.
10 PIC 9(8) VALUE 19720101.
10 PIC 9(8) VALUE 19941231.
10 PIC 9(8) VALUE 19970101.
10 PIC 9(8) VALUE 19960606.
05 Yr-Tbl REDEFINES Yr-Tbl-V OCCURS 7 TIMES PIC 9(8).
01 Ix PIC S9(4) BINARY.
01 Max-Tbl PIC S9(4) BINARY VALUE 7.
01 Age PIC S9(4) BINARY.
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING TAGE PROGRAM."
PERFORM WITH TEST BEFORE VARYING Ix FROM 1 BY 1
UNTIL Ix > Max-Tbl
CALL "GET-AGE" USING BY CONTENT Yr-Tbl(Ix)
BY REFERENCE Age
DISPLAY Yr-Tbl(Ix), ": ", Age
END-PERFORM
GOBACK
.
IDENTIFICATION DIVISION.
PROGRAM-ID. GET-AGE.
*****************************************************************
* SUBPROGRAM TO COMPUTE A PERSON'S AGE GIVEN THE BIRTH DATE. *
* CALL "GET-AGE" USING BY CONTENT Birth-Date, *
* BY REFERENCE Age *
* IN: Birth-date is year--PIC 9(4), month--PIC 9(2), *
* day--PIC 9(2). *
* OUT: Age, PIC S9(4) BINARY. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 The-Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
LINKAGE SECTION.
01 Birth-Date.
05 Bd-Yr PIC 9(4).
05 Bd-Mo PIC 99.
05 Bd-Dy PIC 99.
01 Age PIC S9(4) BINARY.
PROCEDURE DIVISION USING Birth-Date, Age.
A00-Begin.
MOVE FUNCTION CURRENT-DATE TO The-Current-Date
IF Birth-Date(5:4) > The-Current-Date(5:4)
THEN COMPUTE Age = Cd-Yr - Bd-Yr - 1
ELSE COMPUTE Age = Cd-Yr - Bd-Yr
END-IF
GOBACK
.
END PROGRAM GET-AGE.
END PROGRAM TAGE.
0059">
Program example, convert calendar date to Julian. Page 516
This subprogram illustrates how to convert a calendar date to a Julian date.
IDENTIFICATION DIVISION.
PROGRAM-ID. TTOJUL.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Yr-Table.
05 Yr-Tbl-V.
10 PIC 9(8) VALUE 19960229.
10 PIC 9(8) VALUE 19960228.
10 PIC 9(8) VALUE 19901221.
10 PIC 9(8) VALUE 19720101.
10 PIC 9(8) VALUE 19981231.
10 PIC 9(8) VALUE 19970101.
10 PIC 9(8) VALUE 19960606.
05 Yr-Tbl REDEFINES Yr-Tbl-V OCCURS 7 TIMES PIC 9(8).
01 Ix PIC S9(4) BINARY.
01 Max-Tbl PIC S9(4) BINARY VALUE 7.
01 Julian-Date.
05 Julian-Yr PIC 9(4).
05 Julian-Dy PIC 9(3).
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING TTOJUL PROGRAM."
PERFORM WITH TEST BEFORE VARYING Ix FROM 1 BY 1
UNTIL Ix > Max-Tbl
CALL "TO-JULIAN" USING BY CONTENT Yr-Tbl(Ix)
BY REFERENCE Julian-Date
DISPLAY Yr-Tbl(Ix), ": ", Julian-Date
END-PERFORM
GOBACK
.
IDENTIFICATION DIVISION.
PROGRAM-ID. TO-JULIAN.
*****************************************************************
* SUBPROGRAM TO CONVERT A CALENDAR DATE TO JULIAN. *
* CALL "TO-JULIAN" USING BY CONTENT The-Current-Date, *
* BY REFERENCE Julian-Date *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Julian-Date is the Julian date in year--PIC 9(4), *
* Day of year--PIC 9(3).
*****************************************************************
DATA DIVISION.
LINKAGE SECTION.
01 Julian-Date.
05 Julian-Yr PIC 9(4).
05 Julian-Dy PIC 9(3).
01 Julian-I-Date REDEFINES Julian-Date
PIC 9(7).
01 The-Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Current-I-Date REDEFINES The-Current-Date
PIC 9(8).
PROCEDURE DIVISION USING The-Current-Date, Julian-Date.
A00-Begin.
MOVE Cd-Yr TO Julian-Yr
MOVE 1 TO Julian-Dy
COMPUTE Julian-Dy =
FUNCTION INTEGER-OF-DATE(Current-I-date) -
FUNCTION INTEGER-OF-DAY(Julian-I-Date) + 1
GOBACK
.
END PROGRAM TO-JULIAN.
END PROGRAM TTOJUL.
0059">
Program example, convert Julian date to calendar. Page 516
This subprogram illustrates how to convert a Julian date to a calendar date.
IDENTIFICATION DIVISION.
PROGRAM-ID. TFROMJUL.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Yr-Table.
05 Yr-Tbl-V.
10 PIC 9(7) VALUE 1996001.
10 PIC 9(7) VALUE 1996366.
10 PIC 9(7) VALUE 1996365.
10 PIC 9(7) VALUE 1972002.
10 PIC 9(7) VALUE 1998125.
10 PIC 9(7) VALUE 1997100.
10 PIC 9(7) VALUE 1996200.
05 Yr-Tbl REDEFINES Yr-Tbl-V OCCURS 7 TIMES PIC 9(7).
01 Ix PIC S9(4) BINARY.
01 Max-Tbl PIC S9(4) BINARY VALUE 7.
01 The-Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING TFROMJUL PROGRAM."
PERFORM WITH TEST BEFORE VARYING Ix FROM 1 BY 1
UNTIL Ix > Max-Tbl
CALL "FROM-JULIAN" USING BY CONTENT Yr-Tbl(Ix)
BY REFERENCE The-Current-Date
DISPLAY Yr-Tbl(Ix), ": ", The-Current-Date
END-PERFORM
GOBACK
.
IDENTIFICATION DIVISION.
PROGRAM-ID. FROM-JULIAN.
*****************************************************************
* SUBPROGRAM TO CONVERT A JULIAN DATE TO A CALENDAR DATE. *
* CALL "FROM-JULIAN" USING BY CONTENT Julian-Date, *
* BY REFERENCE The-Current-Date *
* IN: Julian-Date is the Julian date in year--PIC 9(4), *
* Day of year--PIC 9(3).
* OUT: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
*****************************************************************
DATA DIVISION.
LINKAGE SECTION.
01 Julian-Date.
05 Julian-Yr PIC 9(4).
05 Julian-Dy PIC 9(3).
01 Julian-I-Date REDEFINES Julian-Date
PIC 9(7).
01 The-Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Current-I-Date REDEFINES The-Current-Date
PIC 9(8).
PROCEDURE DIVISION USING Julian-Date, The-Current-Date.
A00-Begin.
COMPUTE Current-I-Date =
FUNCTION DATE-OF-INTEGER(
FUNCTION INTEGER-OF-DAY(Julian-I-Date))
GOBACK
.
END PROGRAM FROM-JULIAN.
END PROGRAM TFROMJUL.
0059">
Program example, calculate elapsed days. Page 516-517
This subprogram illustrates how to calculate elapsed days, given a start and end date.
IDENTIFICATION DIVISION.
PROGRAM-ID. TTWEEN.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Yr-Table.
05 Yr-Tbl-V.
10 PIC 9(8) VALUE 19960229.
10 PIC 9(8) VALUE 19960228.
10 PIC 9(8) VALUE 19901221.
10 PIC 9(8) VALUE 19720101.
10 PIC 9(8) VALUE 19980228.
10 PIC 9(8) VALUE 19970101.
10 PIC 9(8) VALUE 19960606.
05 Yr-Tbl REDEFINES Yr-Tbl-V OCCURS 7 TIMES PIC 9(8).
05 Yr-Tbl-W.
10 PIC 9(8) VALUE 19960229.
10 PIC 9(8) VALUE 19970228.
10 PIC 9(8) VALUE 19901231.
10 PIC 9(8) VALUE 19720201.
10 PIC 9(8) VALUE 19980302.
10 PIC 9(8) VALUE 19971201.
10 PIC 9(8) VALUE 19960706.
05 Yr-Tbl-1 REDEFINES Yr-Tbl-W OCCURS 7 TIMES PIC 9(8).
01 Ix PIC S9(4) BINARY.
01 Max-Tbl PIC S9(4) BINARY VALUE 7.
01 First-Date.
05 F-Yr PIC 9(4).
05 F-Mo PIC 99.
05 F-Dy PIC 99.
01 Last-Date.
05 L-Yr PIC 9(4).
05 L-Mo PIC 99.
05 L-Dy PIC 99.
01 No-Days PIC S9(9) BINARY.
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING TTWEEN PROGRAM."
PERFORM WITH TEST BEFORE VARYING Ix FROM 1 BY 1
UNTIL Ix > Max-Tbl
CALL "DAYS-TWEEN" USING BY CONTENT Yr-Tbl(Ix),
Yr-Tbl-1(Ix)
BY REFERENCE No-Days
DISPLAY Yr-Tbl(Ix), ", ", Yr-Tbl-1(Ix), ": ", No-Days
END-PERFORM
GOBACK
.
IDENTIFICATION DIVISION.
PROGRAM-ID. DAYS-TWEEN.
*****************************************************************
* SUBPROGRAM TO DETERMINE THE NUMBER OF DAYS BETWEEN TWO DATES. *
* CALL "DAYS-TWEEN" USING BY CONTENT First-Date, Last-Date, *
* BY REFERENCE No-Days *
* IN: First-Date is the first date, year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* Last-Date is the last date in the same format. *
* OUT: No-Days is the days between the two dates, *
* PIC S9(9) BINARY. *
*****************************************************************
DATA DIVISION.
LINKAGE SECTION.
01 First-Date.
05 F-Yr PIC 9(4).
05 F-Mo PIC 99.
05 F-Dy PIC 99.
01 First-I-Date REDEFINES First-Date PIC 9(8).
01 Last-Date.
05 L-Yr PIC 9(4).
05 L-Mo PIC 99.
05 L-Dy PIC 99.
01 Last-I-Date REDEFINES Last-Date PIC 9(8).
01 No-Days PIC S9(9) BINARY.
PROCEDURE DIVISION USING First-Date, Last-Date, No-Days.
A00-Begin.
COMPUTE No-Days = FUNCTION INTEGER-OF-DATE(Last-I-Date) -
FUNCTION INTEGER-OF-DATE(First-I-Date)
GOBACK
.
END PROGRAM DAYS-TWEEN.
END PROGRAM TTWEEN.
0059">
Program example, determine day of week. Page 517
This subprogram illustrates how to determine the day of week.
IDENTIFICATION DIVISION.
PROGRAM-ID. TDWK.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Yr-Table.
05 Yr-Tbl-V.
10 PIC 9(8) VALUE 19960229.
10 PIC 9(8) VALUE 19960228.
10 PIC 9(8) VALUE 19901221.
10 PIC 9(8) VALUE 19720101.
10 PIC 9(8) VALUE 19981231.
10 PIC 9(8) VALUE 19970101.
10 PIC 9(8) VALUE 19960606.
05 Yr-Tbl REDEFINES Yr-Tbl-V OCCURS 7 TIMES PIC 9(8).
01 Ix PIC S9(4) BINARY.
01 Max-Tbl PIC S9(4) BINARY VALUE 7.
01 Dy-Of-Week PIC S9(8) BINARY.
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING TDWK PROGRAM."
PERFORM WITH TEST BEFORE VARYING Ix FROM 1 BY 1
UNTIL Ix > Max-Tbl
CALL "DAY-WK" USING BY CONTENT Yr-Tbl(Ix)
BY REFERENCE Dy-Of-Week
DISPLAY Yr-Tbl(Ix), ": ", Dy-Of-Week
END-PERFORM
GOBACK
.
IDENTIFICATION DIVISION.
PROGRAM-ID. DAY-WK.
*****************************************************************
* SUBPROGRAM TO DETERMINE THE DAY OF THE WEEK OF A DATE. *
* CALL "DAY-WK" USING BY CONTENT The-Current-Date, *
* BY REFERENCE Dy-Of-Week *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Dy-Of-Week is the day of week PIC S9(8) BINARY. *
* 1 is Monday, 2 is Tuesday, ..., 7 is Sunday. *
*****************************************************************
DATA DIVISION.
LINKAGE SECTION.
01 The-Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Current-I-Date REDEFINES The-Current-Date PIC 9(8).
01 Dy-Of-Week PIC S9(8) BINARY.
PROCEDURE DIVISION USING The-Current-Date, Dy-Of-Week.
A00-Begin.
COMPUTE Dy-Of-Week =
FUNCTION REM(FUNCTION
INTEGER-OF-DATE(Current-I-Date), 7)
IF Dy-Of-Week = 0
THEN COMPUTE Dy-Of-Week = 7
END-IF
GOBACK
.
END PROGRAM DAY-WK.
END PROGRAM TDWK.
0059">
Program example, convert day of week to text. Page 517-518
This subprogram illustrates how to convert the day of the week to text form.
IDENTIFICATION DIVISION.
PROGRAM-ID. TTXT.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Yr-Table.
05 Yr-Tbl-V.
10 PIC 9(8) VALUE 19960229.
10 PIC 9(8) VALUE 19960228.
10 PIC 9(8) VALUE 19901221.
10 PIC 9(8) VALUE 19720101.
10 PIC 9(8) VALUE 19981231.
10 PIC 9(8) VALUE 19970101.
10 PIC 9(8) VALUE 19960606.
05 Yr-Tbl REDEFINES Yr-Tbl-V OCCURS 7 TIMES PIC 9(8).
01 Ix PIC S9(4) BINARY.
01 Max-Tbl PIC S9(4) BINARY VALUE 7.
01 Dy-Of-Week PIC S9(8) BINARY.
01 Txt-Dy-Of-Week PIC X(9).
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING TTXT PROGRAM."
PERFORM WITH TEST BEFORE VARYING Ix FROM 1 BY 1
UNTIL Ix > Max-Tbl
CALL "DAY-Wk" USING BY CONTENT Yr-Tbl(Ix)
BY REFERENCE Dy-Of-Week
DISPLAY Yr-Tbl(Ix), ": ", Dy-Of-Week
CALL "Txt-Day" USING BY CONTENT Dy-Of-Week,
BY REFERENCE Txt-Dy-Of-Week
DISPLAY Dy-Of-Week, ": ", Txt-Dy-Of-Week
END-PERFORM
GOBACK
.
IDENTIFICATION DIVISION.
PROGRAM-ID. Txt-Day.
*****************************************************************
* SUBPROGRAM TO CONVERT THE DAY OF WEEK TO TEXT FORM. *
* CALL "Txt-Day" USING BY CONTENT Dy-Of-Week, *
* BY REFERENCE Txt-Dy-Of-Week *
* IN: Dy-Of-Week is the day of week PIC S9(8) BINARY. *
* 1 is Monday, 2 is Tuesday, ..., 7 is Sunday. *
* OUT: Txt-Dy-Of-Week PIC X(8) is the text may of week: Monday, *
* Tuesday, etc. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Dy-Table.
05 Dy-Tbl-Values.
10 Dy-Tbl-Mon PIC X(9) VALUE "Monday".
10 Dy-Tbl-Tue PIC X(9) VALUE "Tuesday".
10 Dy-Tbl-Wed PIC X(9) VALUE "Wednesday".
10 Dy-Tbl-Thu PIC X(9) VALUE "Thursday".
10 Dy-Tbl-Fri PIC X(9) VALUE "Friday".
10 Dy-Tbl-Sat PIC X(9) VALUE "Saturday".
10 Dy-Tbl-Sun PIC X(9) VALUE "Sunday".
05 Dy-Tbl REDEFINES Dy-Tbl-Values OCCURS 7 TIMES PIC X(9).
LINKAGE SECTION.
01 Dy-Of-Week PIC S9(8) BINARY.
01 Txt-Dy-Of-Week PIC X(9).
PROCEDURE DIVISION USING Dy-Of-Week, Txt-Dy-Of-Week.
A00-Begin.
MOVE Dy-Tbl(Dy-Of-Week) TO Txt-Dy-Of-Week
GOBACK
.
END PROGRAM Txt-Day.
IDENTIFICATION DIVISION.
PROGRAM-ID. DAY-WK.
*****************************************************************
* SUBPROGRAM TO DETERMINE THE DAY OF THE WEEK OF A DATE. *
* CALL "DAY-WK" USING BY CONTENT The-Current-Date, *
* BY REFERENCE Dy-Of-Week *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Dy-Of-Week is the day of week PIC S9(8) BINARY. *
* 1 is Monday, 2 is Tuesday, ..., 7 is Sunday. *
*****************************************************************
DATA DIVISION.
LINKAGE SECTION.
01 The-Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Current-I-Date REDEFINES The-Current-Date PIC 9(8).
01 Dy-Of-Week PIC S9(8) BINARY.
PROCEDURE DIVISION USING The-Current-Date, Dy-Of-Week.
A00-Begin.
COMPUTE Dy-Of-Week =
FUNCTION REM(FUNCTION
INTEGER-OF-DATE(Current-I-Date), 7)
IF Dy-Of-Week = 0
THEN COMPUTE Dy-Of-Week = 7
END-IF
GOBACK
.
END PROGRAM DAY-WK.
END PROGRAM TTXT.
0059">
Program example, convert calendar date to text. Page 518-519
This subprogram illustrates how to convert a calendar date to text form.
IDENTIFICATION DIVISION.
PROGRAM-ID. TDATE.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Yr-Table.
05 Yr-Tbl-V.
10 PIC 9(8) VALUE 19960229.
10 PIC 9(8) VALUE 19960228.
10 PIC 9(8) VALUE 19901221.
10 PIC 9(8) VALUE 19720101.
10 PIC 9(8) VALUE 19981231.
10 PIC 9(8) VALUE 19970101.
10 PIC 9(8) VALUE 19960606.
05 Yr-Tbl REDEFINES Yr-Tbl-V OCCURS 7 TIMES PIC 9(8).
01 Ix PIC S9(4) BINARY.
01 Max-Tbl PIC S9(4) BINARY VALUE 7.
01 Formatted-Date PIC X(30).
PROCEDURE DIVISION.
A00-Begin.
DISPLAY "BEGINNING TDATE PROGRAM."
PERFORM WITH TEST BEFORE VARYING Ix FROM 1 BY 1
UNTIL Ix > Max-Tbl
CALL "Txt-Date" USING BY CONTENT Yr-Tbl(Ix)
BY REFERENCE Formatted-Date
DISPLAY Yr-Tbl(Ix), ": ", Formatted-Date
END-PERFORM
GOBACK
.
IDENTIFICATION DIVISION.
PROGRAM-ID. Txt-Date.
*****************************************************************
* SUBPROGRAM TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL "Txt-Date" USING BY CONTENT The-Current-Date, *
* BY REFERENCE Formatted-Date *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Formatted-Date is PIC X(30). It contains the date in *
* text form, such as "January 1, 2000. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Fmt-Dy PIC X(3).
01 Mo-Table.
05 Mo-Tbl-V.
10 Mo-Tbl-Jan PIC X(9) VALUE "January".
10 Mo-Tbl-Feb PIC X(9) VALUE "February".
10 Mo-Tbl-Mar PIC X(9) VALUE "March".
10 Mo-Tbl-Apr PIC X(9) VALUE "April".
10 Mo-Tbl-May PIC X(9) VALUE "May".
10 Mo-Tbl-Jun PIC X(9) VALUE "June".
10 Mo-Tbl-Jul PIC X(9) VALUE "July".
10 Mo-Tbl-Aug PIC X(9) VALUE "August".
10 Mo-Tbl-Sep PIC X(9) VALUE "September".
10 Mo-Tbl-Oct PIC X(9) VALUE "October".
10 Mo-Tbl-Nov PIC X(9) VALUE "November".
10 Mo-Tbl-Dec PIC X(9) VALUE "December".
05 Mo-Tbl REDEFINES Mo-Tbl-V OCCURS 12 TIMES
PIC X(9).
LINKAGE SECTION.
01 The-Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Formatted-Date PIC X(30).
PROCEDURE DIVISION USING The-Current-Date, Formatted-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Fmt-Dy DELIMITED " ", ", " DELIMITED SIZE
Cd-Yr DELIMITED SIZE
INTO Formatted-Date
END-STRING
GOBACK
.
END PROGRAM TXT-DATE.
END PROGRAM TDATE.
0059">
Chapter 27
DEMYSTIFYING OBJECT-ORIENTED COBOL
Program example, subprogram to convert date to text. Page 527
IDENTIFICATION DIVISION.
PROGRAM-ID. MoTextDate.
*****************************************************************
* SUBPROGRAM TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL "MoTextDate" USING BY CONTENT The-Current-Date, *
* BY REFERENCE Formatted-Date *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Formatted-Date is PIC X(30). It contains the date in *
* text form, such as "January 1, 2000. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Fmt-Dy PIC X(3).
01 Mo-Table.
05 Mo-Tbl-V.
10 Mo-Tbl-Jan PIC X(9) VALUE "January".
10 Mo-Tbl-Feb PIC X(9) VALUE "February".
10 Mo-Tbl-Mar PIC X(9) VALUE "March".
10 Mo-Tbl-Apr PIC X(9) VALUE "April".
10 Mo-Tbl-May PIC X(9) VALUE "May".
10 Mo-Tbl-Jun PIC X(9) VALUE "June".
10 Mo-Tbl-Jul PIC X(9) VALUE "July".
10 Mo-Tbl-Aug PIC X(9) VALUE "August".
10 Mo-Tbl-Sep PIC X(9) VALUE "September".
10 Mo-Tbl-Oct PIC X(9) VALUE "October".
10 Mo-Tbl-Nov PIC X(9) VALUE "November".
10 Mo-Tbl-Dec PIC X(9) VALUE "December".
05 Mo-Tbl REDEFINES Mo-Tbl-V OCCURS 12 TIMES PIC X(9).
LINKAGE SECTION.
01 The-Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Formatted-Date PIC X(30).
PROCEDURE DIVISION USING The-Current-Date, Formatted-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Fmt-Dy DELIMITED " ", ", " DELIMITED SIZE
Cd-Yr DELIMITED SIZE INTO Formatted-Date
END-STRING
GOBACK
.
END PROGRAM MoTextDate.
0059">
Program example, function to convert date to text. Page 527-528
IDENTIFICATION DIVISION.
FUNCTION-ID. MoTextDate.
*****************************************************************
* FUNCTION TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL: Formatted-Date = FUNCTION MoTextDate(The-Current-Date) *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Formatted date in form PIC X(30). The formatted date *
* is in text form, such as "January 1, 2000. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Fmt-Dy PIC X(3).
01 Mo-Table.
05 Mo-Tbl-V.
10 Mo-Tbl-Jan PIC X(9) VALUE "January".
10 Mo-Tbl-Feb PIC X(9) VALUE "February".
10 Mo-Tbl-Mar PIC X(9) VALUE "March".
10 Mo-Tbl-Apr PIC X(9) VALUE "April".
10 Mo-Tbl-May PIC X(9) VALUE "May".
10 Mo-Tbl-Jun PIC X(9) VALUE "June".
10 Mo-Tbl-Jul PIC X(9) VALUE "July".
10 Mo-Tbl-Aug PIC X(9) VALUE "August".
10 Mo-Tbl-Sep PIC X(9) VALUE "September".
10 Mo-Tbl-Oct PIC X(9) VALUE "October".
10 Mo-Tbl-Nov PIC X(9) VALUE "November".
10 Mo-Tbl-Dec PIC X(9) VALUE "December".
05 Mo-Tbl REDEFINES Mo-Tbl-V OCCURS 12 TIMES PIC X(9).
LINKAGE SECTION.
01 Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Formatted-Date PIC X(30).
PROCEDURE DIVISION USING Current-Date,
RETURNING Formatted-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Fmt-Dy DELIMITED " ", ", " DELIMITED SIZE
Cd-Yr DELIMITED SIZE INTO Formatted-Date
END-STRING
GOBACK
.
END FUNCTION MoTextDate.
Program example, method to convert date to text. Page 528
IDENTIFICATION DIVISION.
METHOD-ID. MoTextDate.
*****************************************************************
* METHOD TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL: Formatted-Date - class :: MoTextDate(The-Current-Date) *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Formatted date in form PIC X(30). The formatted date *
* is in text form, such as "January 1, 2000. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Fmt-Dy PIC X(3).
01 Mo-Table.
05 Mo-Tbl-V.
10 Mo-Tbl-Jan PIC X(9) VALUE "January".
10 Mo-Tbl-Feb PIC X(9) VALUE "February".
10 Mo-Tbl-Mar PIC X(9) VALUE "March".
10 Mo-Tbl-Apr PIC X(9) VALUE "April".
10 Mo-Tbl-May PIC X(9) VALUE "May".
10 Mo-Tbl-Jun PIC X(9) VALUE "June".
10 Mo-Tbl-Jul PIC X(9) VALUE "July".
10 Mo-Tbl-Aug PIC X(9) VALUE "August".
10 Mo-Tbl-Sep PIC X(9) VALUE "September".
10 Mo-Tbl-Oct PIC X(9) VALUE "October".
10 Mo-Tbl-Nov PIC X(9) VALUE "November".
10 Mo-Tbl-Dec PIC X(9) VALUE "December".
05 Mo-Tbl REDEFINES Mo-Tbl-V OCCURS 12 TIMES PIC X(9).
LINKAGE SECTION.
01 Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Formatted-Date PIC X(30).
PROCEDURE DIVISION USING Current-Date,
RETURNING Formatted-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Fmt-Dy DELIMITED " ", ", " DELIMITED SIZE
Cd-Yr DELIMITED SIZE INTO Formatted-Date
END-STRING
GOBACK
.
END METHOD MoTextDate.
0059">
Program example, coding the class. Page 532
CLASS-ID. The-Dates INHERITS Base.
ENVIRONMENT DIVISION.
*****************************************************************
* CLASS TO OPERATE ON DATES. *
* DATA: MoTable is table of 12 months in PIC X(9) format. *
* METHODS: MoTextDate to convert yyyymmdd to form such as *
* January 1, 2000.
* DyTextDate to convert yyyymmdd to form such as *
* 1 January 2000.
*****************************************************************
CONFIGURATION SECTION.
REPOSITORY.
CLASS The-Dates AS "DATES".
FACTORY.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Fmt-Dy PIC X(3).
01 Mo-Table.
05 Mo-Tbl-V.
10 Mo-Tbl-Jan PIC X(9) VALUE "January".
10 Mo-Tbl-Feb PIC X(9) VALUE "February".
10 Mo-Tbl-Mar PIC X(9) VALUE "March".
10 Mo-Tbl-Apr PIC X(9) VALUE "April".
10 Mo-Tbl-May PIC X(9) VALUE "May".
10 Mo-Tbl-Jun PIC X(9) VALUE "June".
10 Mo-Tbl-Jul PIC X(9) VALUE "July".
10 Mo-Tbl-Aug PIC X(9) VALUE "August".
10 Mo-Tbl-Sep PIC X(9) VALUE "September".
10 Mo-Tbl-Oct PIC X(9) VALUE "October".
10 Mo-Tbl-Nov PIC X(9) VALUE "November".
10 Mo-Tbl-Dec PIC X(9) VALUE "December".
05 Mo-Tbl REDEFINES Mo-Tbl-V OCCURS 12 TIMES PIC X(9).
PROCEDURE DIVISION.
METHOD-ID. DyTextDate.
DATA DIVISION.
*****************************************************************
* METHOD TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL: Formatted-Date - class :: DyTextDate(The-Current-Date) *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Formatted date in form PIC X(30). The formatted date *
* is in text form, such as "1 January 2000. *
*****************************************************************
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Formatted-Date PIC X(30).
PROCEDURE DIVISION USING Current-Date,
RETURNING Formatted-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Fmt-Dy DELIMITED ".",
" " DELIMITED SIZE,
Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Cd-Yr DELIMITED SIZE INTO Formatted-Date
END-STRING
GOBACK
.
END METHOD DyTextDate.
METHOD-ID. MoTextDate.
DATA DIVISION.
*****************************************************************
* METHOD TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL: Formatted-Date = class :: MoTextDate(The-Current-Date) *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Formatted date in form PIC X(30). The formatted date *
* is in text form, such as "January 1, 2000. *
*****************************************************************
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Formatted-Date PIC X(30).
PROCEDURE DIVISION USING Current-Date,
RETURNING Formatted-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Fmt-Dy DELIMITED " ", ", " DELIMITED SIZE
Cd-Yr DELIMITED SIZE INTO Formatted-Date
END-STRING
GOBACK
.
END METHOD MoTextDate.
END FACTORY.
END CLASS The-Dates
0059">
Program example, object-oriented driver program. Page 533.
PROGRAM-ID. TESTDATE.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
REPOSITORY.
CLASS Base AS "BASE"
CLASS The-Dates AS "DATES".
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Date-Storage PIC X(30).
PROCEDURE DIVISION.
A00-Begin.
MOVE The-Dates :: "DyTextDate"("20030427") TO Date-Storage
DISPLAY Date-Storage
GOBACK
.
END PROGRAM TESTDATE.
0059">
Program example, creating an object. Page 535.
CLASS-ID. The-Dates INHERITS Base.
ENVIRONMENT DIVISION.
*****************************************************************
* CLASS TO OPERATE ON DATES. *
* DATA: MoTable is table of 12 months in PIC X(9) format. *
* METHODS: MoTextDate to convert yyyymmdd to form such as *
* January 1, 2000.
* DyTextDate to convert yyyymmdd to form such as *
* 1 January 2000.
*****************************************************************
CONFIGURATION SECTION.
REPOSITORY.
CLASS The-Dates AS "DATES".
FACTORY.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Fmt-Dy PIC X(3).
01 Mo-Table.
05 Mo-Tbl-V.
10 Mo-Tbl-Jan PIC X(9) VALUE "January".
10 Mo-Tbl-Feb PIC X(9) VALUE "February".
10 Mo-Tbl-Mar PIC X(9) VALUE "March".
10 Mo-Tbl-Apr PIC X(9) VALUE "April".
10 Mo-Tbl-May PIC X(9) VALUE "May".
10 Mo-Tbl-Jun PIC X(9) VALUE "June".
10 Mo-Tbl-Jul PIC X(9) VALUE "July".
10 Mo-Tbl-Aug PIC X(9) VALUE "August".
10 Mo-Tbl-Sep PIC X(9) VALUE "September".
10 Mo-Tbl-Oct PIC X(9) VALUE "October".
10 Mo-Tbl-Nov PIC X(9) VALUE "November".
10 Mo-Tbl-Dec PIC X(9) VALUE "December".
05 Mo-Tbl REDEFINES Mo-Tbl-V OCCURS 12 TIMES PIC X(9).
PROCEDURE DIVISION.
METHOD-ID. DyTextDate.
DATA DIVISION.
*****************************************************************
* METHOD TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL: Formatted-Date = class :: DyTextDate(The-Current-Date) *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Formatted date in form PIC X(30). The formatted date *
* is in text form, such as "1 January 2000. *
*****************************************************************
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Formatted-Date PIC X(30).
PROCEDURE DIVISION USING Current-Date,
RETURNING Formatted-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Fmt-Dy DELIMITED ".",
" " DELIMITED SIZE,
Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Cd-Yr DELIMITED SIZE INTO Formatted-Date
END-STRING
GOBACK
.
END METHOD DyTextDate.
METHOD-ID. MoTextDate.
*****************************************************************
* METHOD TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL: Formatted-Date = class :: MoTextDate(The-Current-Date) *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Formatted date in form PIC X(30). The formatted date *
* is in text form, such as "January 1, 2000. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Formatted-Date PIC X(30).
PROCEDURE DIVISION USING Current-Date,
RETURNING Formatted-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Fmt-Dy DELIMITED " ", ", " DELIMITED SIZE
Cd-Yr DELIMITED SIZE INTO Formatted-Date
END-STRING
GOBACK
.
END METHOD MoTextDate.
OBJECT.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Date-Storage PIC X(30).
PROCEDURE DIVISION.
END OBJECT.
END CLASS The-Dates.
0059">
Program example, main program to create an object. Page 536
PROGRAM-ID. TESTDATE.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
REPOSITORY.
CLASS Base AS "BASE"
CLASS The-Dates AS "DATES".
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Obj-Ptr OBJECT REFERENCE.
PROCEDURE DIVISION.
A00-Begin.
INVOKE The-Dates "NEW" RETURNING Obj-Ptr
GOBACK
.
END PROGRAM TESTDATE.
0059">
Program example, creating multiple objects. Page 538
PROGRAM-ID. TESTDATE.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
REPOSITORY.
CLASS Base AS "BASE"
The-Dates AS CLASS "DATES".
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Obj-Table.
05 Obj-Ptr OCCURS 10 TIMES INDEXED BY Ix
OBJECT REFERENCE.
PROCEDURE DIVISION.
A00-Begin.
PERFORM WITH TEST AFTER VARYING Ix FROM 1 BY 1 UNTIL Ix = 10
INVOKE The-Dates "NEW" RETURNING Obj-Ptr(Ix)
END-PERFORM
PERFORM WITH TEST AFTER VARYING Ix FROM 1 BY 1 UNTIL Ix = 10
INVOKE Obj-Ptr(Ix) "StoreDate" USING "20030421"
END-PERFORM
PERFORM WITH TEST AFTER VARYING Ix FROM 1 BY 1 UNTIL Ix = 10
INVOKE Obj-Ptr(Ix) "FINALIZE" RETURNING Obj-Ptr(Ix)
END-PERFORM
GOBACK
.
END PROGRAM TESTDATE.
0059">
Program example, class to get dates. Page 538-539
CLASS-ID. The-Dates INHERITS Base.
ENVIRONMENT DIVISION.
*****************************************************************
* CLASS TO OPERATE ON DATES. *
* DATA: MoTable is table of 12 months in PIC X(9) format. *
* METHODS: MoTextDate to convert yyyymmdd to form such as *
* January 1, 2000.
* DyTextDate to convert yyyymmdd to form such as *
* 1 January 2000.
*****************************************************************
CONFIGURATION SECTION.
REPOSITORY.
CLASS The-Dates AS "DATES".
FACTORY.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Fmt-Dy PIC X(3).
01 Mo-Table.
05 Mo-Tbl-V.
10 Mo-Tbl-Jan PIC X(9) VALUE "January".
10 Mo-Tbl-Feb PIC X(9) VALUE "February".
10 Mo-Tbl-Mar PIC X(9) VALUE "March".
10 Mo-Tbl-Apr PIC X(9) VALUE "April".
10 Mo-Tbl-May PIC X(9) VALUE "May".
10 Mo-Tbl-Jun PIC X(9) VALUE "June".
10 Mo-Tbl-Jul PIC X(9) VALUE "July".
10 Mo-Tbl-Aug PIC X(9) VALUE "August".
10 Mo-Tbl-Sep PIC X(9) VALUE "September".
10 Mo-Tbl-Oct PIC X(9) VALUE "October".
10 Mo-Tbl-Nov PIC X(9) VALUE "November".
10 Mo-Tbl-Dec PIC X(9) VALUE "December".
05 Mo-Tbl REDEFINES Mo-Tbl-V OCCURS 12 TIMES PIC X(9).
PROCEDURE DIVISION.
METHOD-ID. DyTextDate.
*****************************************************************
* METHOD TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL: Formatted-Date = class :: DyTextDate(The-Current-Date) *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Formatted date in form PIC X(30). The formatted date *
* is in text form, such as "1 January 2000. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Formatted-Date PIC X(30).
PROCEDURE DIVISION USING Current-Date,
RETURNING Formatted-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Fmt-Dy DELIMITED ".",
" " DELIMITED SIZE,
Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Cd-Yr DELIMITED SIZE INTO Formatted-Date
END-STRING
GOBACK
.
END METHOD DyTextDate.
METHOD-ID. MoTextDate.
*****************************************************************
* METHOD TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL: Formatted-Date = class :: MoTextDate(The-Current-Date) *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Formatted date in form PIC X(30). The formatted date *
* is in text form, such as "January 1, 2000. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Formatted-Date PIC X(30).
PROCEDURE DIVISION USING Current-Date,
RETURNING Formatted-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Fmt-Dy DELIMITED " ", ", " DELIMITED SIZE
Cd-Yr DELIMITED SIZE INTO Formatted-Date
END-STRING
GOBACK
.
END METHOD MoTextDate.
END FACTORY.
OBJECT.
*****************************************************************
* OBJECT TO REPRESENT AN INDIVIDUAL DATE. *
* DATA: Date-Storage is date as PIC X(30) item. *
* METHODS: StoreDate to convert a date in form yyyymmdd to *
* text form (PIC X(30)) and return it. *
* GetDate to retrieve an object Date-Storage. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Date-Storage PIC X(30).
METHOD-ID. StoreDate.
*****************************************************************
* METHOD TO STORE A DATE IN A DATE OBJECT. *
* CALL: ptr :: "StoreDate"(Some-Date) *
* IN: Some-Date is PIC 9(8) and contains date as yyyymmdd. *
* OUT: Date is converted to text form and stored in *
* Date-Storage for object as PIC X(30). *
*****************************************************************
DATA DIVISION.
LINKAGE SECTION.
01 Some-Date PIC 9(8).
PROCEDURE DIVISION USING Some-Date.
MOVE The-Dates :: "MoTextDate"(Some-Date) TO Date-Storage
GOBACK
.
END METHOD StoreDate.
METHOD-ID. GetDate.
*****************************************************************
* METHOD TO RETRIEVE A DATE FROM AN OBJECT. *
* CALL: Some-Date = ptr :: "GetDate"(I) *
* IN: I is PIC S9(5) item containing subscript to *
* The-Objects-Table. *
* OUT: Some-Date is the date in Date-Storage as PIC X(30). *
*****************************************************************
LINKAGE SECTION.
01 Some-Date PIC X(30).
PROCEDURE DIVISION RETURNING Some-Date.
MOVE Date-Storage TO Some-Date
GOBACK
.
END METHOD GetDate.
END OBJECT.
END CLASS The-Dates.
0059">
Programming example, class program of application using objects.
Page 546-549
This program is the class program for the application using objects.
The program is written for Micro Focus COBOL.
$set mfoo
IDENTIFICATION DIVISION.
PROGRAM-ID. DATEPLAY.
*****************************************************************
* DRIVER PROGRAM TO DISPLAY DATES AND ALLOW USER AT TERMIAL TO *
* SELECT A DATE SO THAT IT IS DISPLAYED IN TEXT FORM. *
* IN: Four dates in Date-Tbl-Values. *
* USES: Bdates CLASS. *
*****************************************************************
* ENVIRONMENT DIVISION.
* CONFIGURATION SECTION.
CLASS-CONTROL.
* CLASS BASE IS "BASE"
BASE IS CLASS "BASE"
* CLASS BDates IS "BDATES.
BDates IS CLASS "BDATES".
*REPOSITORY.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Date-Tbl-Values.
05 First-Date PIC 9(8) VALUE 20030407.
05 FILLER PIC 9(8) VALUE 20011028.
05 FILLER PIC 9(8) VALUE 20060914.
05 FILLER PIC 9(8) VALUE 19990228.
01 Date-Tbl REDEFINES Date-Tbl-Values.
05 Date-Tbl-Entry OCCURS 4 TIMES INDEXED BY Dx
PIC 9(8).
01 LRow PIC 99 VALUE 5.
01 LCol PIC 99 VALUE 2.
01 RRow PIC 99.
01 UCol PIC 99.
01 First-Ptr OBJECT REFERENCE VALUE NULLS.
01 Last-Ptr OBJECT REFERENCE VALUE NULLS.
01 Date-Ptr OBJECT REFERENCE.
PROCEDURE DIVISION.
PERFORM WITH TEST AFTER VARYING Dx FROM 1 BY 1
UNTIL Dx = 4
COMPUTE UCol = LCol + FUNCTION LENGTH(First-Date) - 1
COMPUTE RRow = LRow - 1
INVOKE BDates "NEW" RETURNING Date-Ptr
IF First-Ptr = NULLS
THEN SET First-Ptr TO Date-Ptr
END-IF
INVOKE Date-Ptr "CreateDate" USING Date-Tbl-Entry(Dx),
LRow, LCol, RRow, UCol, Last-Ptr
SET Last-Ptr TO Date-Ptr
COMPUTE LCol = LCol + FUNCTION LENGTH(First-Date) + 2
END-PERFORM
INVOKE BDates "UserPlay" USING First-Ptr
INVOKE First-Ptr "DestroyAll" RETURNING First-Ptr
GOBACK.
END PROGRAM DATEPLAY.
0059">
Program example, class application using objects. Page 550-554
This program is written in Micro Focus COBOL.
$set mfoo
CLASS-ID. BDates INHERITS BASE.
*****************************************************************
* CLASS TO OPERATE ON DATES. *
* DATA: MoTable is table of 12 months in PIC X(9) format. *
* The-Objects-Tbl stores next pointer and row, column *
* positions of box around each date displayed. *
* METHODS: MoTextDate to convert yyyymmdd to form such as *
* January 1, 2000. *
* DyTextDate to convert yyyymmdd to form such as *
* 1 January 2000. *
* UserPlay to allow user to play with dates on screen.*
*****************************************************************
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
CURSOR IS Csr-Loc
CRT STATUS IS PF-Key.
*REPOSITORY.
OBJECT SECTION.
CLASS-CONTROL.
* CLASS BDates IS "BDATES".
BDates IS CLASS "BDATES".
*FACTORY.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Csr-Loc PIC 9(6).
01 Csr-Loc-Parts REDEFINES Csr-Loc.
05 Csr-Row PIC 999.
05 Csr-Col PIC 999.
01 PF-Key PIC 99X.
01 Fmt-Dy PIC X(3).
01 Mo-Table.
05 Mo-Tbl-V.
10 Mo-Tbl-Jan PIC X(9) VALUE "January".
10 Mo-Tbl-Feb PIC X(9) VALUE "February".
10 Mo-Tbl-Mar PIC X(9) VALUE "March".
10 Mo-Tbl-Apr PIC X(9) VALUE "April".
10 Mo-Tbl-May PIC X(9) VALUE "May".
10 Mo-Tbl-Jun PIC X(9) VALUE "June".
10 Mo-Tbl-Jul PIC X(9) VALUE "July".
10 Mo-Tbl-Aug PIC X(9) VALUE "August".
10 Mo-Tbl-Sep PIC X(9) VALUE "September".
10 Mo-Tbl-Oct PIC X(9) VALUE "October".
10 Mo-Tbl-Nov PIC X(9) VALUE "November".
10 Mo-Tbl-Dec PIC X(9) VALUE "December".
05 Mo-Tbl REDEFINES Mo-Tbl-V OCCURS 12 TIMES PIC X(9).
01 The-Objects-Table.
05 Obj-Entries OCCURS 4 TIMES.
10 S-Next-Ptr OBJECT REFERENCE.
10 S-The-Date PIC 9(8).
10 S-L-Row PIC 99.
10 S-L-Col PIC 99.
10 S-U-Row PIC 99.
10 S-R-Col PIC 99.
01 Formatted-Date PIC X(30) VALUE SPACES.
01 End-Message PIC X(12) VALUE "PRESS TO END".
SCREEN SECTION.
01 Screen-1 BLANK SCREEN BACKGROUND-COLOR 1,
FOREGROUND-COLOR 7.
05 First-Line.
10 LINE S-L-Row(1) COLUMN S-L-Col(1)
REVERSE-VIDEO PIC 9(8) USING S-The-Date(1).
10 LINE S-L-Row(2) COLUMN S-L-Col(2)
REVERSE-VIDEO PIC 9(8) USING S-The-Date(2).
10 LINE S-L-Row(3) COLUMN S-L-Col(3)
REVERSE-VIDEO PIC 9(8) USING S-The-Date(3).
10 LINE S-L-Row(4) COLUMN S-L-Col(4)
REVERSE-VIDEO PIC 9(8) USING S-The-Date(4).
05 Second-Line LINE 12 COLUMN 20 PIC X(12)
USING End-Message.
05 Last-Line.
10 LINE 24 COLUMN 1 REVERSE-VIDEO
PIC X(30) FROM Formatted-Date.
PROCEDURE DIVISION.
METHOD-ID. UserPlay.
*****************************************************************
* METHOD TO DISPLAY ALL DATES ON THE SCREEN AND LET THE USER *
* SELECT A DATE. WHEN DATE IS SELECTED, IT IS DISPLAYED IN *
* TEXT FORM AND USER CAN SELECT ANOTHER DATE OR TERMINATE. *
* CALL: class :: "UserPlay"(First-Ptr) *
* IN: First-Ptr is pointer to first date object. *
* OUT: Nothing. *
*****************************************************************
DATA DIVISION.
01 I PIC S9(5).
LINKAGE SECTION.
01 A-Ptr OBJECT REFERENCE.
PROCEDURE DIVISION USING A-Ptr.
A00-Begin.
PERFORM WITH TEST AFTER VARYING I FROM 1 BY 1
UNTIL A-Ptr = NULLS
INVOKE A-Ptr "GetDates" USING I RETURNING A-Ptr
END-PERFORM
PERFORM WITH TEST AFTER
UNTIL Csr-Row <= 12 AND Csr-COL >= 20 AND
Csr-Row >= 11 AND Csr-Col <= 32
MOVE S-L-Row(1) TO Csr-Row
MOVE S-L-Col(1) TO Csr-Col
DISPLAY Screen-1
ACCEPT Screen-1
MOVE 1 TO I
PERFORM WITH TEST BEFORE
UNTIL I = ZERO OR S-NEXT-PTR(I) = NULLS
IF Csr-Row <= S-L-Row(I) AND Csr-Col >= S-L-Col(I)
AND
Csr-Row >= S-U-Row(I) AND Csr-Col <= S-R-Col(I)
THEN INVOKE "MoTextDate" USING S-The-Date(I),
RETURNING Formatted-Date
MOVE ZERO TO I
ELSE ADD 1 TO I
END-IF
END-PERFORM
END-PERFORM
GOBACK.
END METHOD UserPlay.
METHOD-ID. MoTextDate.
*****************************************************************
* METHOD TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL: Fmt-Date = class :: MoTextDate(The-Current-Date) *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Fmt-Date is formatted date in form PIC X(30). The *
* formatted date is in text form, such as "January 1, 2000.*
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Fmt-Date PIC X(30).
PROCEDURE DIVISION USING Current-Date,
RETURNING Fmt-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Fmt-Dy DELIMITED " ", ", " DELIMITED SIZE
Cd-Yr DELIMITED SIZE INTO Fmt-Date
END-STRING
GOBACK.
END METHOD MoTextDate.
METHOD-ID. DyTextDate.
*****************************************************************
* METHOD TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL: Fmt-Date = class :: DyTextDate(The-Current-Date) *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Fmt-Date is formatted date in form PIC X(30). The *
* formatted date is in text form, such as "1 January 2000. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Fmt-Date PIC X(30).
PROCEDURE DIVISION USING Current-Date,
RETURNING Fmt-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Fmt-Dy DELIMITED " ",
" " DELIMITED SIZE,
Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Cd-Yr DELIMITED SIZE INTO Fmt-Date
END-STRING
GOBACK.
END METHOD DyTextDate.
*END FACTORY.
OBJECT.
*DATA DIVISION.
*WORKING-STORAGE SECTION.
OBJECT-STORAGE SECTION.
01 Date-Data.
05 Date-Ptr OBJECT REFERENCE.
05 The-Date PIC 9(8).
05 L-Row PIC 99.
05 L-Col PIC 99.
05 U-Row PIC 99.
05 R-Col PIC 99.
PROCEDURE DIVISION.
METHOD-ID. CreateDate.
*****************************************************************
* METHOD TO CREATE A DATE OBJECT AND STORE DATA IN IT. *
* CALL: ptr :: "CreateDate"(Date,LRow,LCol,URow,Rcol, *
* Last-Ptr) *
* IN: Date is PIC 9(8) item containing date as yyyymmdd *
* LRow, LCol,URow,RCol, are screen row, column positions *
* of box around date, in PIC 99 format. *
* Last-Ptr is pointer to last date object. *
* OUT: Date object is created and linked to last date object *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 T-Last-Ptr OBJECT REFERENCE.
01 T-The-Date PIC 9(8).
01 T-L-Row PIC 99.
01 T-L-Col PIC 99.
01 T-U-Row PIC 99.
01 T-R-Col PIC 99.
PROCEDURE DIVISION USING T-The-Date, T-L-Row, T-L-Col,
T-U-Row, T-R-Col, T-Last-Ptr.
A00-Begin.
MOVE T-L-Row TO L-Row
MOVE T-L-Col TO L-Col
MOVE T-U-Row TO U-Row
MOVE T-R-Col TO R-Col
MOVE T-The-Date TO The-Date
SET Date-Ptr TO NULLS
IF T-Last-Ptr NOT = NULL
THEN INVOKE T-Last-Ptr "LinkDate" USING SELF
END-IF
GOBACK.
END PROGRAM CreateDate.
METHOD-ID. LinkDate.
DATA DIVISION.
*****************************************************************
* METHOD TO LINK A NEW DATE OBJECT TO THE LAST DATE OBJECT. *
* CALL: ptr :: "LinkDate"(SELF) *
* IN: Pointer to the object being linked. *
* OUT: Date-Ptr is set to the address of the current object. *
*****************************************************************
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 A-Ptr OBJECT REFERENCE.
PROCEDURE DIVISION USING A-Ptr.
A00-Begin.
Set Date-Ptr TO A-Ptr
GOBACK.
END METHOD LinkDate.
METHOD-ID. GetDates.
*****************************************************************
* METHOD TO GET THE INFORMATION FROM THE CURRENT DATE OBJECT. *
* CALL: A-Ptr = ptr :: "GetDates"(I) *
* IN: Index to The-Objects-Table as PIC S9(5). *
* OUT: A-Ptr contains pointer to the current object. *
*****************************************************************
DATA DIVISION.
LINKAGE SECTION.
01 I PIC S9(5).
01 A-Ptr OBJECT REFERENCE.
PROCEDURE DIVISION USING I RETURNING A-Ptr.
A00-Begin.
SET S-Next-Ptr(I) TO Date-Ptr
MOVE The-Date TO S-The-Date(I)
MOVE L-Row TO S-L-Row(I)
MOVE L-Col TO S-L-Col(I)
MOVE U-Row TO S-U-Row(I)
MOVE R-Col TO S-R-Col(I)
SET A-Ptr TO Date-Ptr
GOBACK.
END METHOD GetDates.
METHOD-ID. GetLCol.
*****************************************************************
* METHOD TO GET THE LEFT COLUMN POSITION OF THE DATE OBJECT. *
* CALL: I = ptr :: "GetLCol" *
* IN: Nothing. *
* OUT: I is left column position of the current object as *
* PIC 999. *
* NOTE: THIS METHOD IS NOT USED IN THE APPLICATION. *
*****************************************************************
DATA DIVISION.
LINKAGE SECTION.
01 I PIC 999.
PROCEDURE DIVISION RETURNING I.
A00-Begin.
MOVE L-Col TO I
GOBACK.
END METHOD GetLCol.
METHOD-ID. DestroyAll.
*****************************************************************
* METHOD TO DESTROY ALL THE DATE OBJECTS IN THE LINKED LIST. *
* CALL: Date-Ptr = ptr :: "DestroyAll"(First-Ptr) *
* IN: First-Ptr is pointer to first object in linked list. *
* OUT: Date-Ptr contains First-Ptr pointer. *
*****************************************************************
DATA DIVISION.
LINKAGE SECTION.
01 A-Ptr OBJECT REFERENCE.
01 B-Ptr OBJECT REFERENCE.
PROCEDURE DIVISION USING A-Ptr RETURNING B-Ptr.
A00-Begin.
IF Date-Ptr NOT = NULLS
THEN INVOKE Date-Ptr "DestroyAll" RETURNING Date-Ptr
END-IF
INVOKE A-Ptr "FINALIZE" RETURNING A-Ptr
GOBACK.
END METHOD DestroyAll.
END OBJECT.
END CLASS BDates.
0059">
For comparison, here is the equivalent of the previous object-oriented program written as a
standard COBOL program.
IDENTIFICATION DIVISION.
PROGRAM-ID. TESTDATE.
*****************************************************************
* PROGRAM TO DISPLAY NUMERIC DATES AND THEN LET THE PERSON AT *
* THE TERMINAL SELECT A DATE FOR THE PROGRAM TO DISPLAY IN TEXT *
* FORM. *
* IN: First-Date, Second-Date, and Third-Date contains the *
* three dates to display. *
* OUT: The formatted date is displayed as PIC X(30) in the form *
* such as "January 1, 2000. *
*****************************************************************
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SPECIAL-NAMES.
CURSOR IS Csr-Loc
CRT STATUS IS PF-Key.
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Csr-Loc GLOBAL PIC 9(6).
01 Csr-Loc-Parts REDEFINES Csr-Loc GLOBAL.
05 Csr-Row PIC 999.
05 Csr-Col PIC 999.
01 PF-Key PIC 99X.
01 First-Ptr PIC 99 GLOBAL.
01 I PIC 99.
01 The-Obj GLOBAL.
05 Obj-Nos OCCURS 3 TIMES.
10 Next-Ptr PIC 99.
10 The-Date PIC 9(8).
10 LL-Row PIC 99.
10 LL-Col PIC 99.
10 UR-Row PIC 99.
10 UR-Col PIC 99.
01 One PIC 99 VALUE 1.
01 Two PIC 99 VALUE 2.
01 Three PIC 99 VALUE 3.
01 Four PIC 99 VALUE 4.
01 Five PIC 99 VALUE 5.
01 Ten PIC 99 VALUE 10.
01 Twelve PIC 99 VALUE 12.
01 Twenty PIC 99 VALUE 20.
01 Twentytwo PIC 99 VALUE 22.
01 Thirty PIC 99 VALUE 30.
01 First-Date PIC 9(8) VALUE 20030407.
01 Second-Date PIC 9(8) VALUE 20011028.
01 Third-Date PIC 9(8) VALUE 20060914.
01 J PIC 99.
PROCEDURE DIVISION.
A00-Begin.
CALL "CreateDate" USING First-Date,
Five, Two, Four, Ten,
One, First-Ptr
CALL "CreateDate" USING Second-Date,
Five, Twelve, Four,
Twenty, Two, I
COMPUTE J = I - 1
CALL "LinkDate" USING I, J
CALL "CreateDate" USING Third-Date,
Five, Twentytwo, Four,
Thirty, Three, I
COMPUTE J = I - 1
CALL "LinkDate" USING I, J
CALL "UserPlay"
GOBACK.
IDENTIFICATION DIVISION.
PROGRAM-ID. CreateDate.
*****************************************************************
* SUBPROGRAM TO CREATE A NEW DATE TO STORE IN THE DATE TABLE. *
* CALL: CreateDate USING First-Date, Upper-Row, Left-Col, *
* Lower-Row, Right-Col, Idx, Date *
* IN: First-Date is date in the form yyyymmdd in PIC 9(8). *
* Upper-Row, Left-Col, Lower-Row, Right-Col is row, column *
* positions of box around date in the form PIC 99. *
* OUT: The values are stored in the The-Obj table. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 T-Next-Ptr PIC 99.
01 T-The-Date PIC 9(8).
01 T-LL-Row PIC 99.
01 T-LL-Col PIC 99.
01 T-UR-Row PIC 99.
01 T-UR-Col PIC 99.
01 I PIC 99.
PROCEDURE DIVISION USING T-The-Date,
T-LL-Row, T-LL-Col, T-UR-Row,
T-UR-Col, I,
T-Next-Ptr.
A00-Begin.
MOVE I TO T-Next-Ptr
MOVE T-LL-Row TO LL-Row(I)
MOVE T-LL-Col TO LL-Col(I)
MOVE T-UR-Row TO UR-Row(I)
MOVE T-UR-Col TO UR-Col(I)
MOVE T-The-Date TO The-Date(I)
MOVE ZEROS TO Next-Ptr(I)
GOBACK.
END PROGRAM CreateDate.
IDENTIFICATION DIVISION.
PROGRAM-ID. LinkDate.
*****************************************************************
* SUBPROGRAM TO LINK A NEW DATE TO THE LIST OF DATES. *
* CALL: LinkDate USING A-Ptr, I *
* IN: A-Ptr is a subscript to the new date to link to the date *
* list. *
* I is a subscript to the last date in the date list. *
* OUT: The new date is linked to the end of the date list. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
LINKAGE SECTION.
01 A-Ptr PIC 99.
01 I PIC 99.
PROCEDURE DIVISION USING A-Ptr, I.
A00-Begin.
MOVE A-Ptr TO Next-Ptr(I)
GOBACK.
END PROGRAM LinkDate.
IDENTIFICATION DIVISION.
PROGRAM-ID. UserPlay.
*****************************************************************
* SUBPROGRAM TO LINK A NEW DATE TO THE LIST OF DATES. *
* CALL: UserPlay *
* IN: LL-Row(I) contains row at which to display line. *
* I is a subscript to the last date in the date list. *
* OUT: The new date is linked to the end of the date list. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Formatted-Date PIC X(30).
01 End-Message PIC X(12)
VALUE "PRESS TO END".
01 I PIC 99 BINARY.
SCREEN SECTION.
01 Screen-1 BLANK SCREEN
BACKGROUND-COLOR 1 FOREGROUND-COLOR 7.
05 First-Line.
10 LINE LL-Row(1) COLUMN LL-Col(1)
REVERSE-VIDEO PIC 9(8) USING The-Date(1).
10 LINE LL-Row(2) COLUMN LL-Col(2)
REVERSE-VIDEO PIC 9(8) USING The-Date(2).
10 LINE LL-Row(3) COLUMN LL-Col(3)
REVERSE-VIDEO PIC 9(8) USING The-Date(3).
05 Second-Line LINE 12 COLUMN 20
PIC X(12) USING End-Message.
05 Last-Line.
10 LINE 24 COLUMN 1
REVERSE-VIDEO PIC X(30) FROM Formatted-Date.
PROCEDURE DIVISION.
A00-Begin.
MOVE SPACES TO Formatted-Date
PERFORM WITH TEST AFTER
UNTIL Csr-Row <= 12 AND Csr-Col >= 20 AND
Csr-Row >= 11 AND Csr-Col <= 32
MOVE LL-Row(1) TO Csr-Row
MOVE LL-Col(1) TO Csr-Col
DISPLAY Screen-1
ACCEPT Screen-1
MOVE First-Ptr TO I
PERFORM WITH TEST BEFORE UNTIL I = ZERO
IF Csr-Row <= LL-Row(I) AND Csr-Col >= LL-Col(I) AND
Csr-Row >= UR-Row(I) AND Csr-Col <= UR-Col(I)
THEN CALL "MoTextDate" USING The-Date(I),
Formatted-Date
MOVE ZERO TO I
ELSE MOVE Next-Ptr(I) TO I
END-IF
END-PERFORM
END-PERFORM
GOBACK.
IDENTIFICATION DIVISION.
PROGRAM-ID. MoTextDate.
*****************************************************************
* METHOD TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL: class :: MoTextDate(The-Current-Date) *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Formatted date in form PIC X(30). The formatted date *
* is in text form, such as "January 1, 2000. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Fmt-Dy PIC X(3).
01 Mo-Table.
05 Mo-Tbl-Values.
10 Mo-Tbl-Jan PIC X(9) VALUE "January".
10 Mo-Tbl-Feb PIC X(9) VALUE "February".
10 Mo-Tbl-Mar PIC X(9) VALUE "March".
10 Mo-Tbl-Apr PIC X(9) VALUE "April".
10 Mo-Tbl-May PIC X(9) VALUE "May".
10 Mo-Tbl-Jun PIC X(9) VALUE "June".
10 Mo-Tbl-Jul PIC X(9) VALUE "July".
10 Mo-Tbl-Aug PIC X(9) VALUE "August".
10 Mo-Tbl-Sep PIC X(9) VALUE "September".
10 Mo-Tbl-Oct PIC X(9) VALUE "October".
10 Mo-Tbl-Nov PIC X(9) VALUE "November".
10 Mo-Tbl-Dec PIC X(9) VALUE "December".
05 Mo-Tbl REDEFINES Mo-Tbl-Values OCCURS 12 TIMES
PIC X(9).
LINKAGE SECTION.
01 Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Formatted-Date PIC X(30).
PROCEDURE DIVISION USING Current-Date,
Formatted-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Fmt-Dy DELIMITED " ", ", " DELIMITED SIZE
Cd-Yr DELIMITED SIZE INTO Formatted-Date
END-STRING
GOBACK.
END PROGRAM MoTextDate.
IDENTIFICATION DIVISION.
PROGRAM-ID. DyTextDate.
DATA DIVISION.
*****************************************************************
* METHOD TO CONVERT A CALENDAR DATE TO TEXT FORM. *
* CALL: class :: DyTextDate(The-Current-Date) *
* IN: The-Current-Date is the calendar date in year--PIC 9(4), *
* month--PIC 9(2), day--PIC 9(2). *
* OUT: Formatted date in form PIC X(30). The formatted date *
* is in text form, such as "1 January 2000. *
*****************************************************************
WORKING-STORAGE SECTION.
01 Fmt-Dy PIC X(3).
01 Mo-Table.
05 Mo-Tbl-Values.
10 Mo-Tbl-Jan PIC X(9) VALUE "January".
10 Mo-Tbl-Feb PIC X(9) VALUE "February".
10 Mo-Tbl-Mar PIC X(9) VALUE "March".
10 Mo-Tbl-Apr PIC X(9) VALUE "April".
10 Mo-Tbl-May PIC X(9) VALUE "May".
10 Mo-Tbl-Jun PIC X(9) VALUE "June".
10 Mo-Tbl-Jul PIC X(9) VALUE "July".
10 Mo-Tbl-Aug PIC X(9) VALUE "August".
10 Mo-Tbl-Sep PIC X(9) VALUE "September".
10 Mo-Tbl-Oct PIC X(9) VALUE "October".
10 Mo-Tbl-Nov PIC X(9) VALUE "November".
10 Mo-Tbl-Dec PIC X(9) VALUE "December".
05 Mo-Tbl REDEFINES Mo-Tbl-Values OCCURS 12 TIMES
PIC X(9).
LINKAGE SECTION.
01 Current-Date.
05 Cd-Yr PIC 9(4).
05 Cd-Mo PIC 99.
05 Cd-Dy PIC 99.
01 Formatted-Date PIC X(30).
PROCEDURE DIVISION USING Current-Date,
Formatted-Date.
A00-Begin.
IF Cd-Dy < 10
THEN MOVE Cd-Dy(2:1) TO Fmt-Dy
ELSE MOVE Cd-Dy to Fmt-Dy
END-IF
MOVE SPACES TO Formatted-Date
STRING Fmt-Dy DELIMITED ".",
" " DELIMITED SIZE,
Mo-Tbl(Cd-Mo) DELIMITED " ", " " DELIMITED SIZE
Cd-Yr DELIMITED SIZE INTO Formatted-Date
END-STRING
GOBACK.
END PROGRAM DyTextDate.
END PROGRAM UserPlay.
END PROGRAM TESTDATE.
0059">
Chapter 29 READING PROGRAMS
Program example, for reading unstructured program. Page 568-575
This is a sample program of a typical legacy system written in unstructured COBOL.
000001 IDENTIFICATION DIVISION.
000002 PROGRAM-ID. PAYYE.
000003* REMARKS.
000004* THIS PROGRAM COPIES THE PAY FILE AND EXCLUDES THOSE
000005* PERSONNEL RECORDS WHICH ARE NOT NEEDED IN NEW FISCAL YEAR.
000006* RECORDS ARE NOT NEEDED FOR NEW FISCAL YEAR IF THE PERSON
000007* IS INACTIVE, DOES NOT HAVE A COST IN THE COST
000008* FILE, AND DOES NOT APPEAR AS A PERSON RESPONSIBLE FOR A
000009* PROJECT IN THE PROJ FILE.
000010 ENVIRONMENT DIVISION.
000011 CONFIGURATION SECTION.
000012 SOURCE-COMPUTER. IBM-370.
000013 OBJECT-COMPUTER. IBM-370.
000014 INPUT-OUTPUT SECTION.
000015 FILE-CONTROL.
000016 SELECT In-Pay-File ASSIGN TO PAY.
000017 SELECT In-Cost-File ASSIGN TO SCOST.
000018 SELECT In-Proj-File ASSIGN TO PROJ.
000019 SELECT Out-Pay-File ASSIGN TO PAYOUT.
000020 DATA DIVISION.
000021 FILE SECTION.
000022 FD In-Pay-File
000025 BLOCK CONTAINS 0 RECORDS
000024 RECORD CONTAINS 80 CHARACTERS
000025 LABEL RECORDS ARE STANDARD.
000026***** PAY FILE RECORD LAYOUT. RECORD LENGTH = 80.
000027***** RELATIVE BYTE POSITION IN COLUMNS 75-77.
000028 01 Pay-Record.
00002 05 Pay-Key.
000030* RECORD KEY.
000031 10 Pay-Emp-Id PIC X(9).
000032* PERSONS ID
000035 05 Pay-Name PIC X(25).
000034* PERSONS NAME.
000035 05 Pay-Org-Person PIC X(3).
000036* ORG OF PERSON.
000037 05 Pay-Salary PIC S9(9)V9(2).
000038* ANNUAL SALARY IN DOLLARS.
000039 05 Pay-Status PIC X(1).
000040* PERSONS STATUS.
000041* A-ACTIVE- I-INACTIVE.
000042 05 Pay-Date-Updated PIC X(6).
000043* DATE RECORD LAST UPDATED.
000044* YYMMDD
000045 05 FILLER PIC X(25).
000046* AVAILABLE SPACE.
000047 FD In-Cost-File
000048 RECORD CONTAINS 80 CHARACTERS
000049 BLOCK CONTAINS 0 RECORDS
000050 LABEL RECORDS ARE STANDARD.
000051***** COST FILE RECORD LAYOUT. RECORD LENGTH = 80.
000052***** RELATIVE BYTE POSITION IN COLUMNS 73-77.
000053 01 Cost-Record.
000054 05 Cost-Key.
000055 10 Cost-Emp-Id PIC X(9).
000056* ID or PERSON.
000057 05 Cost-Chg PIC X(4).
000058* CHARGE NUMBER.
000059 05 Cost-Obj PIC X(3).
000060* OBJECT CODE OF PERSON.
000061 05 Cost-To-Date.
000062* CUMULATIVE AMOUNTS TO DATE
000065 10 Cost-Amt PIC S9(9)V99.
000064* DOLLAR AMOUNT EXCLUDING FRINGE
000065* AND OVERHEAD
000066 10 Cost-Days PIC S9(9)V99.
000067* DAYS WORKED
000065 10 Cost-Fringe PIC S9(9)V99.
000069* DOLLAR AMOUNT OF FRINGE.
000070 10 Cost-Overhead PIC S9(9)V99.
000071* DOLLAR AMOUNT OF OVERHEAD.
000072 05 Cost-Date-Updated PIC X(6).
000075* DATE RECORD LAST UPDATED.
000074* YYMMDD
000075 05 FILLER PIC X(14).
000076* AVAILABLE SPACE.
000077 FD In-Proj-File
000078 BLOCK CONTAINS 0 RECORDS
000079 RECORD CONTAINS 80 CHARACTERS
000080 LABEL RECORDS ARE STANDARD.
000081***** PROJ FILE RECORD LAYOUT. RECORD LENGTH = 80.
000082***** RELATIVE BYTE POSITION IN COLUMNS 73-77.
000085 01 Proj-Record.
000084 05 Proj-Key.
000085* RECORD KEY
000086 10 Proj-Chg PIC X(4).
000087* CHARGE NUMBER.
000088 05 Proj-Chg-Title PIC X(25).
000089* PROJECT TITLE.
000090 05 Proj-Act-Type PIC X(1).
000091* ACTIVITY TYPE.
000092* D-DIRECT
000093* I-INDIRECT
000094 05 Proj-Person PIC X(9).
000095* ID OF PERSON RESPONSIBLE.
000096 05 Proj-Amount PIC S9(9)V9(2).
000097* TOTAL CONTRACT AMOUNT.
000098 05 Proj-Start-Date.
000099* CONTRACT START DATE.
000100 10 Proj-Start-Yr PIC 9(2).
000101 10 Proj-Start-Mo PIC 9(2).
000102 10 Proj-Start-Dy PIC 9(2).
000103 05 Proj-End-Date.
000104* CONTRACT END DATE.
000105 10 Proj-End-Yr PIC 9(2).
000106 10 Proj-End-Mo PIC 9(2).
000107 10 Proj-End-Dy PIC 9(2).
000108 05 Proj-Active-Flag PIC X(1).
000109* ACTIVE FLAG.
000110* A - ACTIVE.
000111* I - INACTIVE.
000112 05 Proj-Date-Updated PIC X(6).
000113* DATE RECORD LAST UPDATED.
000114* YYMMDD.
000115 05 FILLER PIC X(11).
000116* AVAILABLE SPACE.
000117 FD Out-Pay-File
000118 BLOCK CONTAINS 0 RECORDS
000119 RECORD CONTAINS 80 CHARACTERS
000120 LABEL RECORDS ARE STANDARD.
000121 01 Out-Pay-Rec.
000122 05 Out-Pay-Key PIC X(9).
000123 05 FILLER PIC X(71).
000124 WORKING-STORAGE SECTION.
000125 01 FILLER COMP SYNC.
000126 05 In-Count PIC S9(4) VALUE 0.
000127 05 Out-Count PIC S9(4) VALUE 0.
000128 05 Drop-Count PIC S9(4) VALUE 0.
000129 01 FILLER.
000130 05 Proj-Table-Size PIC S9(4) COMP SYNC VALUE 1000.
000131 05 Proj-Table OCCURS 1000 DEPENDING ON Proj-Table-Size
000132 INDEXED BY Projx PIC X(6).
000133 PROCEDURE DIVISION.
000134 A10-Begin.
000135 OPEN INPUT In-Proj-File.
000136 SET Projx TO 1.
000137 A20-Read-Proj.
000138 READ In-Proj-File AT END GO TO A30.
000139 MOVE Proj-Person TO Proj-Table (Projx).
000140 SET Projx UP BY 1.
000141 GO TO A20-Read-Proj.
000142 A30.
000143 SET Projx DOWN BY 1.
000144 SET Proj-Table-Size TO Projx.
000145 CLOSE In-Proj-File.
000146 OPEN INPUT In-Pay-File.
000147 OPEN INPUT In-Cost-File.
000148 OPEN OUTPUT Out-Pay-File.
000149 MOVE LOW-VALUES TO Cost-Emp-Id.
000150 B10-Read-Pay.
000151 READ In-Pay-File AT END GO TO D10-End.
000152 ADD 1 TO In-Count.
000153 IF Pay-Status = "A" GO TO B30-Keep-Pay.
000154 PERFORM C10-Level-Cost THRU C20-Exit.
000155 IF Pay-Emp-Id = Cost-Emp-Id GO TO B30-Keep-Pay.
000156 SET Projx TO 1.
000157 SEARCH Proj-Table
000158 WHEN Pay-Emp-Id = Proj-Table (Projx)
000159 GO TO B30-Keep-Pay.
000160 B20-Drop-Pay.
000161 ADD 1 TO Drop-Count.
000162 DISPLAY "Pay-Key: ", Pay-Key.
000163 GO TO B10-Read-Pay.
000164 B30-Keep-Pay.
000165 WRITE Out-Pay-Rec FROM Pay-Record.
000166 ADD 1 TO Out-Count.
000167 GO TO B10-Read-Pay.
000168 C10-Level-Cost.
000169 IF Cost-Emp-Id NOT < Pay-Emp-Id GO TO C20-Exit.
000170 READ In-Cost-File AT END
000171 MOVE HIGH-VALUES TO Cost-Emp-Id
000172 GO TO C20-Exit.
000173 IF Cost-Emp-Id < Pay-Emp-Id GO TO C10-Level-Cost.
000174 C20-Exit. EXIT.
000175 D10-End.
000176 DISPLAY "PAY IN =" In-Count.
000177 DISPLAY "PAY OUT =" Out-Count.
000175 DISPLAY "PAY DROP =" Drop-Count.
000179 CLOSE In-Pay-File.
000180 CLOSE Out-Pay-File.
000181 CLOSE In-Cost-File.
000182 STOP RUN.
000183*** END OF PROGRAM ***
0059">
Chapter 31
APPLICATION PROGRAMMING INTERFACES
Program example, application programming interface. Page 592-593
This program illustrates the SQL interface.
IDENTIFICATION DIVISION.
PROGRAM-ID. PARTQUERY.
*****************************************************************
* PROGRAM TO ACCEPT A PART NUMBER AND THEN RETRIEVE INFORMATION *
* ABOUT THE PART USING SQL. *
* IN: LIBRARY (TESTDB2.DCLGENS COBOL (PARTS) *
* TEST.PARTS TABLE *
* OUT: PARTS INFORMATION DISPLAYED. *
*****************************************************************
DATA DIVISION.
WORKING-STORAGE SECTION.
01 Switches.
05 End-Of-Query-Sw PIC X VALUE "N".
88 End-Of-Query VALUE "Y".
05 Part-Located-Sw PIC X VALUE "N".
88 Part-Located VALUE "Y".
EXEC SQL
INCLUDE PARTS
END-EXEC.
EXEC SQL
INCLUDE SQLCA
END-EXEC.
PROCEDURE DIVISION.
A00-Begin.
PERFORM A10-Get-Parts UNTIL End-Of-Query
GOBACK
.
A10-Get-Parts.
DISPLAY "Type in the part number and press the Enter key"
DISPLAY "or type in xxxxxx and press the Enter key to quit."
ACCEPT PartNo.
IF PartNo = "xxxxxx"
THEN MOVE "Y" TO End-Of-Query-Sw
END-IF
IF NOT End-Of-Query
THEN MOVE "Y" TO Part-Located-Sw
PERFORM A30-Retrieve-Part-Row
IF Part-Located
THEN DISPLAY " PART NUMBER ", PartNo
DISPLAY " SUPPLIER ", Supplier
DISPLAY " Phone ", Phone
ELSE DISPLAY "PART NUMBER NOT FOUND ", PartNo
END-IF
END-IF
.
**** EXIT
A30-Retrieve-Part-Row.
EXEC SQL
SELECT Supplier, Phone
INTO :Supplier,:Phone
FROM TEST.PARTS
WHERE PartNo = :PartNo
END-EXEC.
IF SQLCODE NOT = 0
THEN MOVE "N" TO Part-Located-Sw
END-IF
.
**** EXIT
END PROGRAM PARTQUERY.
83
0059">
|
ISBN 0-471-31481-1
656 pages
November, 1998
Wiley
Computer Publishing
Timely. Practical. Reliable.
Email the author with questions and comments
WCP Home Page
|
