|
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 - metrics - download
Length: 15232 (0x3b80)
Types: TextFile
Names: »OPG9PHA.LST«
└─⟦c154ac35e⟧ Bits:30002656 COBOL-programmer til undervisning
└─⟦this⟧ »OPG9PHA.LST«
\f
* Level II COBOL V2.1 OPG9PHA.CBL Page 0001
*
* Options: REF
IDENTIFICATION DIVISION. 011E
PROGRAM-ID. OPG9. 0120
AUTHOR. HOLD 4. 0120
DATE-WRITTEN. 18/11/85. 0120
DATE-COMPILED. 18/11/85. 0120
*
* PROGRAMMET LÆSER FILEN "IXPERSON.REG" FRA DISKEN
* OG UDSKRIVER EN LISTE MED OPLYSNINGER PÅ PRINTEREN.
*
ENVIRONMENT DIVISION. 0120
CONFIGURATION SECTION. 0120
SOURCE-COMPUTER. PICCOLINE. 0120
SPECIAL-NAMES. CONSOLE IS CRT,DECIMAL-POINT IS COMMA. 0120
*
INPUT-OUTPUT SECTION. 0120
FILE-CONTROL. 018C
SELECT INDFIL ASSIGN TO "IXPERSON.REG" 018E
ORGANIZATION IS INDEXED 018E
ACCESS MODE IS DYNAMIC 018E
RECORD KEY IS IXPERS-NR 018E
FILE STATUS IS SVAR-KEY. 018E
SELECT LISTE ASSIGN TO "LST:". 01CC
*
DATA DIVISION. 0200
FILE SECTION. 0200
FD INDFIL 0200
LABEL RECORD IS STANDARD. 0200
01 IXPERSREG. 0200
02 IXPERS-NR PIC 9(10). 0200
02 IXPERS-FNVN PIC X(15). 020A
02 IXPERS-EFNVN PIC X(20). 0219
02 IXPERS-GNVN PIC X(20). 022D
02 IXPERS-POSTNR PIC 9(4). 0241
02 IXPERS-BYNAVN PIC X(20). 0245
02 IXPERS-TLFNR PIC 9(8). 0259
FD LISTE 0263
LABEL RECORD IS OMITTED. 0264
01 UDLINIE PIC X(132). 0264
*
WORKING-STORAGE SECTION. 036E 00
01 OVERSKRIFT0. 036E 00
02 FILLER PIC X(132) VALUE SPACE. 036E 00
01 OVERSKRIFT1. 03F2 84
02 FILLER PIC X(30) VALUE SPACE. 03F2 84
02 FILLER PIC X(20) VALUE "CPR-LISTE". 0410 A2
02 FILLER PIC X(5) VALUE "PR.". 0424 B6
02 MMDDAA PIC 99B99B99. 0429 BB
02 FILLER PIC X(26) VALUE SPACE. 0431 C3
02 FILLER PIC X(6) VALUE "SIDE". 044B DD
02 SIDENR PIC 999. 0451 E3
02 FILLER PIC X(33) VALUE SPACE. 0454 E6
01 OVERSKRIFT2. 0475
02 FILLER PIC X(14) VALUE "PERSON-NR:". 0475
02 FILLER PIC X(16) VALUE "FORNAVN:". 0483
02 FILLER PIC X(21) VALUE "EFTERNAVN:". 0493
02 FILLER PIC X(21) VALUE "GADENAVN:". 04A8
02 FILLER PIC X(26) VALUE "P-NR BYNAVN:". 04BD
02 FILLER PIC X(8) VALUE "TLF-NR:". 04D7
02 FILLER PIC X(26) VALUE SPACE. 04DF
\f
* Level II COBOL V2.1 OPG9PHA.CBL Page 0002
*
01 PERSREG1. 04F9
02 PERS-NR1 PIC 99.99.99B9999B. 04F9
02 PERS-FNVN1 PIC X(16). 0507
02 PERS-EFNVN1 PIC X(21). 0517
02 PERS-GNVN1 PIC X(21). 052C
02 PERS-POSTNR1 PIC 9999B. 0541
02 PERS-BYNAVN1 PIC X(21). 0546
02 PERS-TLFNR1 PIC 99.999999. 055B
02 FILLER PIC X(25) VALUE SPACE. 0564
01 TAELLER PIC 99 VALUE 18. 057D
01 DATO PIC 999999. 057F
01 EFTERSKRIFT PIC X(132) VALUE "CPR-LISTE FÆRDIG". 0585
01 TIL-NR PIC 9(10). 0609
01 FRA-NR PIC 9(10). 0613
01 EOF PIC X(4) VALUE SPACE. 061D
01 OKAY PIC 9 VALUE 0. 0621
01 SVAR-KEY. 0622
05 SVAR-1 PIC X. 0622
05 SVAR-2 PIC X. 0623
*
*
PROCEDURE DIVISION. 0000
STYRINGS SECTION. 0040
STYR-IND. 0041
PERFORM INIT. 0042
PERFORM BEHANDLE UNTIL FRA-NR = 9999999999. 0045
PERFORM LUK. 005F
STOP RUN. 0062
STYR-UD. 0063
EXIT. 0064
*
*
INIT SECTION. 0068
INIT-IND. 0069
OPEN INPUT INDFIL. 006A
OPEN OUTPUT LISTE. 006E
MOVE 001 TO SIDENR. 0072
DISPLAY SPACE. 0079
DISPLAY "UDSKRIVNING AF INDEX CPR-LISTE." AT 0101. 007E
DISPLAY "INDTAST DATO (MM.DD.AA) " AT 0201. 00A7
ACCEPT DATO AT 0225. 00C9
MOVE DATO TO MMDDAA. 00D6
DISPLAY SPACES. 00E1
INIT-UD. 00E6
EXIT. 00E7
*
*
LAES-INTERVAL SECTION. 00EB
L-IND. 00EC
DISPLAY "FRA NR: " AT 0301. 00ED
ACCEPT FRA-NR AT 0309. 00FF
IF FRA-NR = 9999999999 NEXT SENTENCE 010C
ELSE DISPLAY "TIL NR: " AT 0401 011F
ACCEPT TIL-NR AT 0409 0126
MOVE FRA-NR TO IXPERS-NR 0138
START INDFIL KEY IS NOT < IXPERS-NR 013F
INVALID KEY MOVE 1 TO OKAY. 0146
L-UD. 015F
EXIT. 0160
\f
* Level II COBOL V2.1 OPG9PHA.CBL Page 0003
*
*
*
FEJL SECTION. 0164
F-IND. 0165
DISPLAY "GALT INTERVAL INDTAST NYT:" AT 0501 0166
UPON CRT-UNDER. 016C
PERFORM LAES-INTERVAL UNTIL TIL-NR < FRA-NR. 018A
F-UD. 019C
EXIT. 019D
*
*
FOR-STOR SECTION. 01A1
FST-IND. 01A2
DISPLAY "INGEN PERSONER MED SÅ STORT NR." AT 1515. 01A3
PERFORM LAES-INTERVAL. 01CC
FST-UD. 01CF
EXIT. 01D0
*
*
BEHANDLE SECTION. 01D4
BEHA-IND. 01D5
PERFORM BEH. 01D6
IF OKAY = 1 PERFORM FOR-STOR. 01D9
BEHA-UD. 01E7
EXIT. 01E8
*
*
BEH SECTION. 01EC
B2-IND. 01ED
MOVE ZERO TO OKAY. 01EE
PERFORM LAES-INTERVAL. 01F4
IF FRA-NR = 9999999999 NEXT SENTENCE 01F7
ELSE IF FRA-NR > TIL-NR PERFORM FEJL 020A
ELSE MOVE FRA-NR TO IXPERS-NR 0216
PERFORM INDLAES 021A
PERFORM SKRIV UNTIL FRA-NR > TIL-NR 0221
MOVE SPACES TO UDLINIE 0224
WRITE UDLINIE BEFORE ADVANCING PAGE 0236
MOVE 18 TO TAELLER. 023D
B2-UD. 024A
EXIT. 024B
*
*
INDLAES SECTION. 024F
LAES-IND. 0250
READ INDFIL NEXT RECORD AT END 0251
MOVE 999999998 TO IXPERS-NR. 025A
MOVE IXPERS-NR TO FRA-NR. 0269
IF SVAR-1 NOT = ZERO MOVE 1 TO OKAY. 0270
LAES-UD. 027E
EXIT. 027F
*
*
FLYT SECTION. 0283
FLYT-IND. 0284
MOVE IXPERS-NR TO PERS-NR1. 0285
MOVE IXPERS-FNVN TO PERS-FNVN1. 0294
MOVE IXPERS-EFNVN TO PERS-EFNVN1. 029B
MOVE IXPERS-GNVN TO PERS-GNVN1. 02A2
\f
* Level II COBOL V2.1 OPG9PHA.CBL Page 0004
*
MOVE IXPERS-POSTNR TO PERS-POSTNR1. 02A9
MOVE IXPERS-BYNAVN TO PERS-BYNAVN1. 02B2
MOVE IXPERS-TLFNR TO PERS-TLFNR1. 02B9
FLYT-UD. 02C3
EXIT. 02C4
*
*
SKRIV SECTION. 02C8
SKRIV-IND. 02C9
IF TAELLER = 18 02CA
PERFORM OVERSKRIFT. 02CA
PERFORM FLYT. 02D9
WRITE UDLINIE FROM PERSREG1 AFTER ADVANCING 2 LINES. 02DC
ADD 1 TO TAELLER. 02EE
PERFORM INDLAES. 02F4
SKRIV-UD. 02F7
EXIT. 02F8
*
*
OVERSKRIFT SECTION. 02FC
OV-IND. 02FD
WRITE UDLINIE FROM OVERSKRIFT0 AFTER ADVANCING PAGE. 02FE
WRITE UDLINIE FROM OVERSKRIFT1 AFTER ADVANCING 1 LINE. 030A
WRITE UDLINIE FROM OVERSKRIFT2 AFTER ADVANCING 2 LINES. 031B
ADD 1 TO SIDENR. 032D
MOVE 0 TO TAELLER. 0332
OV-UD. 0338
EXIT. 0339
*
*
LUK SECTION. 033D
LUK-IND. 033E
CLOSE INDFIL, LISTE. 033F
LUK-UD. 0347
EXIT. 0348
0348
* Level II COBOL V2.1 REVISION 9 URN EY/0011/GA
* Compiler Copyright (C) 1983 Micro Focus Ltd
*
* ERRORS=00000 DATA=01792 CODE=01280 DICT=01515:60292/61807 GSA FLAGS = OFF
«eof»