IDENTIFICATION DIVISION.
PROGRAM-ID. MEMADD.
*PROGRAM: ADD MEMBER
AUTHOR. MARTIN O SULLIVAN
DATE-WRITTEN. FEBRUARY 1999.
*
*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. IBM-AS400.
OBJECT-COMPUTER. IBM-AS400.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT MEMBER-FILE
ASSIGN TO DISK-V1L01
ORGANIZATION IS INDEXED
ACCESS MODE IS RANDOM
RECORD KEY IS MEMNUM OF MEMREC
FILE STATUS IS V1L01-STAT.
SELECT MEMBER-NUMBER-SUPPLY
ASSIGN TO DISK-V8L
ORGANIZATION IS INDEXED
ACCESS MODE IS RANDOM
RECORD KEY IS SFCODE OF MNUMRC
FILE STATUS IS V8L-STAT.
SELECT SCREEN-FILE
ASSIGN TO WORKSTATION-V4SCR
ORGANIZATION IS TRANSACTION
FILE STATUS IS SCREEN-STAT, WA-RETURN-CODE
CONTROL-AREA IS WA-CONTROL-AREA.
SELECT REPORT-FILE
ASSIGN TO PRINTER-QSYSPRT
ORGANIZATION IS SEQUENTIAL
ACCESS MODE IS SEQUENTIAL
FILE STATUS IS RPT-STAT.
DATA DIVISION.
FILE SECTION.
FD MEMBER-FILE
LABEL RECORDS ARE STANDARD
DATA RECORD IS MEMREC.
01 MEMREC.
03 MEMNUM PIC X(8).
03 NAME PIC X(20).
03 ADDRS1 PIC X(20).
03 ADDRS2 PIC X(20).
03 ADDRS3 PIC X(20).
03 TYPEMB PIC X(1).
03 MEMBER-FLAG PIC X(1).
88 GOODMEMBER VALUE 'G'.
FD MEMBER-NUMBER-SUPPLY
LABEL RECORDS ARE STANDARD
DATA RECORD IS MNUMRC.
01 MNUMRC.
03 MEMNUM-NUMERIC PIC 9(8).
03 SFCODE PIC X(3).
FD SCREEN-FILE
LABEL RECORDS ARE OMITTED.
01 SCREEN-REC PIC X(500).
FD REPORT-FILE
LABEL RECORDS ARE OMITTED
RECORD CONTAINS 132 CHARACTERS.
01 REPORT-REC PIC X(132).
WORKING-STORAGE SECTION.
01 SCREEN-CONTROL.
03 SCREEN-STAT PIC X(2).
88 SUCCESSFUL-READ VALUE "00".
03 WA-RETURN-CODE PIC X(4).
03 WA-CONTROL-AREA.
05 AID-BYTE PIC 9(2) VALUE ZEROES.
88 ADD-ABANDONED VALUE 12.
88 WISH-TO-END-ADD-MEMBER VALUE 3.
88 MEMBER-DATA-OK VALUE 0.
88 MEMBER-DATA-NOT-OK VALUE 12.
05 SESSION-ID PIC X(2).
05 FILLER PIC X(8).
01 FILE-STATUS-AND-CONDITIONS.
03 V1L01-STAT PIC X(2).
03 RPT-STAT PIC X(2).
03 V8L-STAT PIC X(2).
01 ADD-BUFFER.
03 NAME PIC X(20).
03 ADDRS1 PIC X(20).
03 ADDRS2 PIC X(20).
03 ADDRS3 PIC X(20).
03 TYPEMB PIC X(1).
* 03 MEMBER-FLAG PIC X(1).
01 MSG-BUFFER PIC X(60).
01 MESSAGES-ETC.
03 ADD-ABANDONED-MSG PIC X(60)
VALUE "NEW RECORD NOT CREATED - PRESS ENTER".
01 LINE-PAGE-COUNTERS.
03 LINE-COUNT PIC 9(2).
88 PAGE-FULL VALUE 51 THRU 64.
03 PAGENUM PIC 9(3) VALUE ZERO.
01 DATE-AND-TIME-STUFF.
03 TODAYS-DATE.
05 YEAR-IN PIC 9(2).
05 MONTH-IN PIC 9(2).
05 DAY-IN PIC 9(2).
03 SYSTEM-TIME.
05 HOUR-IN PIC 9(2).
05 MINUTE-IN PIC 9(2).
05 SECOND-IN PIC 9(2).
01 HEADING-FOOTING-LINES.
03 HEADING-LINE-1.
05 DAY-IN PIC 9(2).
05 FILLER PIC X VALUE "/".
05 MONTH-IN PIC 9(2).
05 FILLER PIC X(3) VALUE "/19".
05 YEAR-IN PIC 9(2).
05 FILLER PIC X(30) VALUE SPACES.
05 FILLER PIC X(25)
VALUE "CONTROL LIST - NEW MEMBER".
05 FILLER PIC X(21) VALUE SPACES.
05 FILLER PIC X(5)
VALUE "PAGE ".
05 PAGENUM-EDT PIC ZZ9.
05 FILLER PIC X(9)
VALUE "VIDEO 092".
03 HEADING-LINE-2.
05 HOUR-IN PIC 9(2).
05 FILLER PIC X VALUE ":".
05 MINUTE-IN PIC 9(2).
05 FILLER PIC X VALUE ":".
05 SECOND-IN PIC 9(2).
05 FILLER PIC X(32) VALUE SPACES.
05 FILLER PIC X(27) VALUE ALL "-".
03 HEADING-SUB-1.
05 FILLER PIC X(9) VALUE SPACES.
05 FILLER PIC X(9)
VALUE "MEMBER ".
05 FILLER PIC X(11)
VALUE "MEMBER NAME".
05 FILLER PIC X(19) VALUE SPACES.
05 FILLER PIC X(14)
VALUE "MEMBER ADDRESS".
03 HEADING-SUB-2.
05 FILLER PIC X(9) VALUE SPACES.
05 FILLER PIC X(6)
VALUE "NUMBER".
05 FILLER PIC X(64) VALUE SPACES.
05 FILLER PIC X(5)
VALUE "TYPE ".
03 SPACER PIC X(89) VALUE ALL "*".
03 FOOTING-LINE.
05 FILLER PIC X(30) VALUE SPACES.
05 FILLER PIC X(43)
VALUE "** END OF CONTROL LIST - ADD MEMBER **".
01 DETAIL-LINES.
03 ADD-LINE-1.
05 FILLER PIC X(8)
VALUE "ADD : ".
05 MEMNUM PIC X(8).
05 FILLER PIC X(2) VALUE SPACES.
05 NAME PIC X(20).
05 FILLER PIC X(2) VALUE SPACES.
05 ADDRS1 PIC X(20).
05 FILLER PIC X(2) VALUE SPACES.
03 ADD-LINE-2.
05 FILLER PIC X(50) VALUE SPACES.
05 ADDRS2 PIC X(20).
03 ADD-LINE-3.
05 FILLER PIC X(50) VALUE SPACES.
05 ADDRS3 PIC X(20).
03 ADD-ABANDON-LINE.
05 FILLER PIC X(36)
VALUE "ADD ABANDONED BY WORKSTATION USER".
PROCEDURE DIVISION.
DECLARATIVES.
I-O-FAIL SECTION.
USE AFTER STANDARD EXCEPTION PROCEDURE ON I-O.
I-O-FAIL-PARA.
DISPLAY "ATTENTION!! ERROR IN I-O CUSMF ", V1L01-STAT.
DISPLAY "ATTENTION!! ERROR IN I-O SCREEN ", SCREEN-CONTROL.
END DECLARATIVES.
MAIN-PROCESSING SECTION.
* 1, 2, 3, 4, 5, 6
CONTROL-PARA.
PERFORM START-UP.
PERFORM PROMPT-USER.
PERFORM FIRST-HEADING.
PERFORM DO-ALL-ADD-NEW-MEMBER.
PERFORM PRINT-FOOTINGS.
PERFORM CLOSE-DOWN.
STOP RUN.
*1
START-UP.
OPEN I-O MEMBER-FILE, MEMBER-NUMBER-SUPPLY.
OPEN I-O SCREEN-FILE.
OPEN OUTPUT REPORT-FILE.
PERFORM SET-UP-HEADING.
SET-UP-HEADING.
ACCEPT TODAYS-DATE FROM DATE.
ACCEPT SYSTEM-TIME FROM TIME.
MOVE CORRESPONDING TODAYS-DATE TO HEADING-LINE-1.
MOVE CORRESPONDING SYSTEM-TIME TO HEADING-LINE-2.
MOVE ZERO TO PAGENUM.
*6
CLOSE-DOWN.
CLOSE MEMBER-FILE, MEMBER-NUMBER-SUPPLY .
CLOSE SCREEN-FILE.
CLOSE REPORT-FILE.
*2
PROMPT-USER.
PERFORM REFRESH-SCREEN.
WRITE SCREEN-REC FORMAT IS "GOONSCR".
READ SCREEN-FILE.
REFRESH-SCREEN.
WRITE SCREEN-REC FORMAT IS "FOOTER".
WRITE SCREEN-REC FORMAT IS "SYSID".
WRITE SCREEN-REC FORMAT IS "SCRHDG6".
WRITE SCREEN-REC FORMAT IS "CASCR1".
*4
DO-ALL-ADD-NEW-MEMBER.
PERFORM DO-ONE-ADD-ASK-MORE
UNTIL WISH-TO-END-ADD-MEMBER.
*7
DO-ONE-ADD-ASK-MORE.
PERFORM TAKE-IN-MEMBER-DATA.
PERFORM POSS-OK-MEMBER-DATA.
PERFORM PROMPT-USER.
*8
TAKE-IN-MEMBER-DATA.
MOVE SPACES TO ADD-BUFFER.
WRITE SCREEN-REC FROM ADD-BUFFER
FORMAT IS "CASCR2".
READ SCREEN-FILE INTO ADD-BUFFER.
*9
POSS-OK-MEMBER-DATA.
IF MEMBER-DATA-OK
PERFORM COMPLETE-ADD-MEMBER
ELSE
PERFORM DO-ADD-ABANDON-JOBS.
*11
COMPLETE-ADD-MEMBER.
PERFORM GENERATE-NEW-MEMBER-NUMBER.
PERFORM ASSEMBLE-NEW-RECORD.
PERFORM WRITE-NEW-RECORD.
PERFORM POSS-NEW-PAGE.
PERFORM ASSEMBLE-ADD-LINES.
PERFORM PRINT-ADD-LINES.
PERFORM PRINT-SPACER-LINE.
*12
DO-ADD-ABANDON-JOBS.
PERFORM REFRESH-SCREEN.
WRITE SCREEN-REC FROM ADD-BUFFER FORMAT IS "CASCR3".
READ SCREEN-FILE.
MOVE ADD-ABANDONED-MSG TO MSG-BUFFER.
WRITE SCREEN-REC FROM MSG-BUFFER
FORMAT IS "MSGSCR".
READ SCREEN-FILE.
WRITE REPORT-REC FROM ADD-ABANDON-LINE
AFTER ADVANCING 2 LINES.
ADD 2 TO LINE-COUNT.
PERFORM PRINT-SPACER-LINE.
*13
GENERATE-NEW-MEMBER-NUMBER.
MOVE "MNS" TO SFCODE.
READ MEMBER-NUMBER-SUPPLY INVALID KEY
PERFORM PROBLEM-READ-NUM-SUPPLY.
ADD 1 TO MEMNUM-NUMERIC GIVING MEMNUM-NUMERIC.
MOVE MEMNUM-NUMERIC TO MEMNUM OF MEMREC.
REWRITE MNUMRC.
PROBLEM-READ-NUM-SUPPLY.
DISPLAY "PROBLEM READING NUMBER-SUPPLY-FILE ".
DISPLAY "RUN ENDS NOW: NUMBER SUPLY FILE FAILED".
DISPLAY MNUMRC .
STOP RUN.
*14A
ASSEMBLE-NEW-RECORD.
MOVE CORRESPONDING ADD-BUFFER TO MEMREC.
SET GOODMEMBER TO TRUE.
*14B
WRITE-NEW-RECORD.
WRITE MEMREC INVALID KEY PERFORM
PROBLEM-WRITE-CUSMF.
*15
POSS-NEW-PAGE.
IF PAGE-FULL
PERFORM CHANGE-PAGE-HEADING.
*16A
ASSEMBLE-ADD-LINES.
MOVE CORRESPONDING MEMREC TO ADD-LINE-1.
MOVE CORRESPONDING ADD-BUFFER TO ADD-LINE-1.
MOVE CORRESPONDING ADD-BUFFER TO ADD-LINE-2.
MOVE CORRESPONDING ADD-BUFFER TO ADD-LINE-3.
*16B
PRINT-ADD-LINES.
WRITE REPORT-REC FROM ADD-LINE-1 AFTER ADVANCING 2 LINES.
WRITE REPORT-REC FROM ADD-LINE-2 AFTER ADVANCING 1 LINES.
WRITE REPORT-REC FROM ADD-LINE-3 AFTER ADVANCING 1 LINES.
ADD 4 TO LINE-COUNT.
PROBLEM-WRITE-CUSMF.
DISPLAY "WRITE FAILED - RECORD DISPLAYED - RUN ENDS NOW ".
DISPLAY MEMREC.
STOP RUN.
*
PRINT-SPACER-LINE.
WRITE REPORT-REC FROM SPACER AFTER ADVANCING 2 LINES.
ADD 2 TO LINE-COUNT.
* HEADINGS AND FOOTINGS
FIRST-HEADING.
ADD 1 TO PAGENUM.
MOVE PAGENUM TO PAGENUM-EDT.
WRITE REPORT-REC FROM HEADING-LINE-1.
PERFORM PRINT-REST-HEADING.
CHANGE-PAGE-HEADING.
ADD 1 TO PAGENUM.
MOVE PAGENUM TO PAGENUM-EDT.
WRITE REPORT-REC FROM HEADING-LINE-1
AFTER ADVANCING PAGE.
PERFORM PRINT-REST-HEADING.
PRINT-REST-HEADING.
WRITE REPORT-REC FROM HEADING-LINE-2 AFTER ADVANCING 1 LINE.
WRITE REPORT-REC FROM HEADING-SUB-1 AFTER ADVANCING 2 LINES.
WRITE REPORT-REC FROM HEADING-SUB-2 AFTER ADVANCING 1 LINES.
MOVE 5 TO LINE-COUNT.
PRINT-FOOTINGS.
WRITE REPORT-REC FROM FOOTING-LINE
AFTER ADVANCING 3 LINES.
Link back to cobol page