|
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: 7296 (0x1c80)
Types: TextFile
Names: »OPG9PHA.BAK«
└─⟦c154ac35e⟧ Bits:30002656 COBOL-programmer til undervisning
└─ ⟦this⟧ »OPG9PHA.BAK«
IDENTIFICATION DIVISION.
PROGRAM-ID. OPG9.
AUTHOR. HOLD 4.
DATE-WRITTEN. 18/11/85.
DATE-COMPILED. 18/11/85.
*
* PROGRAMMET LÆSER FILEN "IXPERSON.REG" 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 "IXPERSON.REG"
ORGANIZATION IS INDEXED
ACCESS MODE IS DYNAMIC
RECORD KEY IS IXPERS-NR
FILE STATUS IS SVAR-KEY.
SELECT LISTE ASSIGN TO "LST:".
*
DATA DIVISION.
FILE SECTION.
FD INDFIL
LABEL RECORD IS STANDARD.
01 IXPERSREG.
02 IXPERS-NR PIC 9(10).
02 IXPERS-FNVN PIC X(15).
02 IXPERS-EFNVN PIC X(20).
02 IXPERS-GNVN PIC X(20).
02 IXPERS-POSTNR PIC 9(4).
02 IXPERS-BYNAVN PIC X(20).
02 IXPERS-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).
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 TAELLER PIC 99 VALUE 18.
01 DATO PIC 999999.
01 EFTERSKRIFT PIC X(132) VALUE "CPR-LISTE FÆRDIG".
01 TIL-NR PIC 9(10).
01 FRA-NR PIC 9(10).
01 EOF PIC X(4) VALUE SPACE.
01 OKAY PIC 9 VALUE 0.
01 SVAR-KEY.
05 SVAR-1 PIC X.
05 SVAR-2 PIC X.
*
*
PROCEDURE DIVISION.
STYRINGS SECTION.
STYR-IND.
PERFORM INIT.
PERFORM BEHANDLE UNTIL FRA-NR = 9999999999.
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 INDEX CPR-LISTE." AT 0101.
DISPLAY "INDTAST DATO (MM.DD.AA) " AT 0201.
ACCEPT DATO AT 0225.
MOVE DATO TO MMDDAA.
DISPLAY SPACES.
INIT-UD.
EXIT.
*
*
LAES-INTERVAL SECTION.
L-IND.
DISPLAY "FRA NR: " AT 0301.
ACCEPT FRA-NR AT 0309.
IF FRA-NR = 9999999999 NEXT SENTENCE
ELSE DISPLAY "TIL NR: " AT 0401
ACCEPT TIL-NR AT 0409
START INDFIL KEY IS NOT < IXPERS-NR
INVALID KEY MOVE 1 TO OKAY.
L-UD.
EXIT.
*
*
FEJL SECTION.
F-IND.
DISPLAY "GALT INTERVAL INDTAST NYT:" AT 0501
UPON CRT-UNDER.
PERFORM LAES-INTERVAL UNTIL TIL-NR < FRA-NR.
F-UD.
EXIT.
*
*
FOR-STOR SECTION.
FST-IND.
DISPLAY "INGEN PERSONER MED SÅ STORT NR." AT 1515.
PERFORM LAES-INTERVAL.
FST-UD.
EXIT.
*
*
BEHANDLE SECTION.
BEHA-IND.
PERFORM BEH.
IF OKAY = 1 PERFORM FOR-STOR.
BEHA-UD.
EXIT.
*
*
BEH SECTION.
B2-IND.
MOVE ZERO TO OKAY.
PERFORM LAES-INTERVAL.
IF FRA-NR = 9999999999 NEXT SENTENCE
ELSE IF FRA-NR > TIL-NR PERFORM FEJL
ELSE MOVE FRA-NR TO IXPERS-NR
PERFORM INDLAES
PERFORM SKRIV UNTIL FRA-NR > TIL-NR
MOVE SPACES TO UDLINIE
WRITE UDLINIE BEFORE ADVANCING PAGE
MOVE 18 TO TAELLER.
B2-UD.
EXIT.
*
*
INDLAES SECTION.
LAES-IND.
READ INDFIL NEXT RECORD AT END
MOVE 999999998 TO IXPERS-NR.
MOVE IXPERS-NR TO FRA-NR.
IF SVAR-1 NOT = ZERO MOVE 1 TO OKAY.
LAES-UD.
EXIT.
*
*
FLYT SECTION.
FLYT-IND.
MOVE IXPERS-NR TO PERS-NR1.
MOVE IXPERS-FNVN TO PERS-FNVN1.
MOVE IXPERS-EFNVN TO PERS-EFNVN1.
MOVE IXPERS-GNVN TO PERS-GNVN1.
MOVE IXPERS-POSTNR TO PERS-POSTNR1.
MOVE IXPERS-BYNAVN TO PERS-BYNAVN1.
MOVE IXPERS-TLFNR TO PERS-TLFNR1.
FLYT-UD.
EXIT.
*
*
SKRIV SECTION.
SKRIV-IND.
IF TAELLER = 18
PERFORM OVERSKRIFT.
PERFORM FLYT.
WRITE UDLINIE FROM PERSREG1 AFTER ADVANCING 2 LINES.
ADD 1 TO TAELLER.
PERFORM INDLAES.
SKRIV-UD.
EXIT.
*
*
OVERSKRIFT SECTION.
OV-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.
OV-UD.
EXIT.
*
*
LUK SECTION.
LUK-IND.
CLOSE INDFIL, LISTE.
LUK-UD.
EXIT.
«eof»