|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 6016 (0x1780)
Types: TextFile
Names: »OPG4.LST«
└─⟦c154ac35e⟧ Bits:30002656 COBOL-programmer til undervisning
└─ ⟦this⟧ »OPG4.LST«
\f
* Level II COBOL V2.1 OPG4.CBL Page 0001
*
* Options:
IDENTIFICATION DIVISION.
PROGRAM-ID. OPG4.
AUTHOR. HOLD 4.
DATE-WRITTEN. 5/9/85.
DATE-COMPILED. 5/9/85.
*
* PROGRAMMET LÆSER FILEN "PERSON.TRA" FRA DISKEN
* OG UDSKRIVER EN LISTE MED OPLYSNINGER PÅ PRINTEREN.
*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. PICCOLINE.
SPECIAL-NAMES. CONSOLE IS CRT,DECIMAL-POINT IS COMMA.
*
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT INDFIL ASSIGN TO "PERSON.TRA".
SELECT LISTE ASSIGN TO "LST:".
*
DATA DIVISION.
FILE SECTION.
FD INDFIL
LABEL RECORD IS STANDARD.
01 PERSREG.
02 PERS-NR PIC 9(10).
02 PERS-FNVN PIC X(15).
02 PERS-EFNVN PIC X(20).
02 PERS-GNVN PIC X(20).
02 PERS-POSTNR PIC 9(4).
02 PERS-BYNAVN PIC X(20).
02 PERS-TLFNR PIC 9(8).
FD LISTE
LABEL RECORD IS OMITTED.
01 UDLINIE PIC X(132).
*
WORKING-STORAGE SECTION.
01 OVERSKRIFT0.
02 FILLER PIC X(132) VALUE SPACE.
01 OVERSKRIFT1.
02 FILLER PIC X(30) VALUE SPACE.
02 FILLER PIC X(20) VALUE "CPR-LISTE".
02 FILLER PIC X(5) VALUE "PR.".
02 MMDDAA PIC 99B99B99.
02 FILLER PIC X(26) VALUE SPACE.
02 FILLER PIC X(6) VALUE "SIDE".
02 SIDENR PIC 999.
02 FILLER PIC X(33) VALUE SPACE.
01 OVERSKRIFT2.
02 FILLER PIC X(14) VALUE "PERSON-NR:".
02 FILLER PIC X(16) VALUE "FORNAVN:".
02 FILLER PIC X(21) VALUE "EFTERNAVN:".
02 FILLER PIC X(21) VALUE "GADENAVN:".
02 FILLER PIC X(26) VALUE "P-NR BYNAVN:".
02 FILLER PIC X(8) VALUE "TLF-NR:".
02 FILLER PIC X(26) VALUE SPACE.
01 PERSREG1.
02 PERS-NR1 PIC 99.99.99B9999B.
02 PERS-FNVN1 PIC X(16).
02 PERS-EFNVN1 PIC X(21).
\f
* Level II COBOL V2.1 OPG4.CBL Page 0002
*
02 PERS-GNVN1 PIC X(21).
02 PERS-POSTNR1 PIC 9999B.
02 PERS-BYNAVN1 PIC X(21).
02 PERS-TLFNR1 PIC 99.999999.
02 FILLER PIC X(25) VALUE SPACE.
01 ANTAL PIC 99.
01 FLAG PIC X(4).
01 TAELLER PIC 99.
01 DATO PIC 999999.
01 EFTERSKRIFT PIC X(132) VALUE "CPR-LISTE FÆRDIG".
*
*
PROCEDURE DIVISION.
STYRINGS SECTION.
STYR-IND.
PERFORM INIT.
PERFORM BEHANDL UNTIL FLAG = "SLUT".
DISPLAY SPACE.
DISPLAY "PROGRAM SLUT" AT 1230.
WRITE UDLINIE FROM EFTERSKRIFT AFTER ADVANCING 5 LINES.
PERFORM LUK.
STOP RUN.
STYR-UD.
EXIT.
*
*
INIT SECTION.
INIT-IND.
OPEN INPUT INDFIL.
OPEN OUTPUT LISTE.
MOVE 001 TO SIDENR.
DISPLAY SPACE.
DISPLAY "UDSKRIVNING AF CPR-LISTE." AT 0101.
DISPLAY "INDTAST DATO (MM.DD.AA) " AT 0201.
ACCEPT DATO AT 0225.
DISPLAY "INDTAST ANTAL PERSONER PR. SIDE" AT 0301.
ACCEPT ANTAL AT 0335.
MOVE DATO TO MMDDAA.
INIT-UD.
EXIT.
*
*
BEHANDL SECTION.
BEH-IND.
WRITE UDLINIE FROM OVERSKRIFT0 AFTER ADVANCING PAGE.
WRITE UDLINIE FROM OVERSKRIFT1 AFTER ADVANCING 1 LINE.
WRITE UDLINIE FROM OVERSKRIFT2 AFTER ADVANCING 2 LINES.
ADD 1 TO SIDENR.
MOVE 0 TO TAELLER.
PERFORM LAES
PERFORM BEHANDL2 UNTIL TAELLER = ANTAL.
BEH-UD.
EXIT.
*
*
BEHANDL2 SECTION.
BEH2-IND.
PERFORM FLYT.
PERFORM SKRIV.
\f
* Level II COBOL V2.1 OPG4.CBL Page 0003
*
ADD 1 TO TAELLER.
PERFORM LAES.
IF FLAG = "SLUT" MOVE ANTAL TO TAELLER.
BEH-UD.
EXIT.
*
*
LAES SECTION.
LAES-IND.
READ INDFIL INTO PERSREG AT END MOVE "SLUT" TO FLAG.
LAES-UD.
EXIT.
*
*
FLYT SECTION.
FLYT-IND.
MOVE PERS-NR TO PERS-NR1.
MOVE PERS-FNVN TO PERS-FNVN1.
MOVE PERS-EFNVN TO PERS-EFNVN1.
MOVE PERS-GNVN TO PERS-GNVN1.
MOVE PERS-POSTNR TO PERS-POSTNR1.
MOVE PERS-BYNAVN TO PERS-BYNAVN1.
MOVE PERS-TLFNR TO PERS-TLFNR1.
FLYT-UD.
EXIT.
*
*
SKRIV SECTION.
SKRIV-IND.
WRITE UDLINIE FROM PERSREG1 AFTER ADVANCING 2 LINES.
SKRIV-UD.
EXIT.
*
*
LUK SECTION.
LUK-IND.
CLOSE INDFIL, LISTE.
LUK-UD.
EXIT.
* Level II COBOL V2.1 REVISION 9 URN EY/0011/GA
* Compiler Copyright (C) 1983 Micro Focus Ltd
*
* ERRORS=00000 DATA=01792 CODE=01024 DICT=01210:60597/61807 GSA FLAGS = OFF
«eof»