|
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: 10112 (0x2780)
Types: TextFile
Names: »OPG6B.LST«
└─⟦c154ac35e⟧ Bits:30002656 COBOL-programmer til undervisning
└─⟦this⟧ »OPG6B.LST«
\f
* Level II COBOL V2.1 OPG6B.CBL Page 0001
*
* Options:
IDENTIFICATION DIVISION.
PROGRAM-ID. OPG6.
AUTHOR. HOLD 4.
DATE-WRITTEN. 24.09.85.
DATE-COMPILED. .09.85.
*
*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. PICCOLINE.
OBJECT-COMPUTER. PICCOLINE.
SPECIAL-NAMES. CONSOLE IS CRT.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT LAES-FIL1 ASSIGN TO "PERSON.TRA".
SELECT LAES-FIL2 ASSIGN TO "P-TRANS.TRA".
SELECT AJOUR-FIL ASSIGN TO "A-PERSON.TRA".
SELECT PRINTER ASSIGN TO "LST:".
*
*
DATA DIVISION.
FILE SECTION.
FD LAES-FIL1
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 LAES-FIL2
LABEL RECORD IS STANDARD.
01 TRANSREG.
02 TRANS-TYPE PIC 9.
02 TRANS-NR PIC 9(10).
02 TRANS-FNVN PIC X(15).
02 TRANS-EFNVN PIC X(20).
02 TRANS-GNVN PIC X(20).
02 TRANS-POSTNR PIC 9(4).
02 TRANS-BYNAVN PIC X(20).
02 TRANS-TLFNR PIC 9(8).
*
FD AJOUR-FIL
LABEL RECORD IS STANDARD.
01 AJOUR-REG.
02 AJOUR-NR PIC 9(10).
02 AJOUR-FNVN PIC X(15).
02 AJOUR-EFNVN PIC X(20).
02 AJOUR-GNVN PIC X(20).
02 AJOUR-POSTNR PIC 9999.
02 AJOUR-BYNAVN PIC X(20).
02 AJOUR-TLFNR PIC 9(8).
*
FD PRINTER
LABEL RECORD IS OMITTED.
\f
* Level II COBOL V2.1 OPG6B.CBL Page 0002
*
01 PRINT-LINIE PIC X(132).
*
*
WORKING-STORAGE SECTION.
01 RAPPORT-LINIE.
02 RAPP-PERSNR PIC 99B99B99B9999.
02 FILLER PIC X(5) VALUE ": ".
02 KOMMENTAR PIC X(114) VALUE SPACE.
01 EOF-LAES1 PIC XXX VALUE "NEJ".
01 EOF-LAES2 PIC XXX VALUE "NEJ".
01 DATO PIC 999999.
01 OVERSKRIFT-1.
02 FILLER PIC X(37) VALUE SPACES.
02 OVS1 PIC X(45) VALUE
"A J O U R F Ø R I N G S R A P P O R T PR. ".
02 OVS1-DATO PIC 99B99B99.
02 FILLER PIC X(34) VALUE SPACES.
02 FILLER PIC XXXXX VALUE "SIDE ".
02 SIDE-NR PIC ZZ9.
01 OVERSKRIFT-2.
02 FILLER PIC X(132) VALUE
"PERSON-NUMMER: FORKLARING:".
01 LINIE-TAELLER PIC 99 VALUE 18.
01 SIDETAL PIC 999 VALUE 001.
01 TEMP-REG.
02 TEMP-NR PIC 9(10).
02 TEMP-FNVN PIC X(15).
02 TEMP-EFNVN PIC X(20).
02 TEMP-GNVN PIC X(20).
02 TEMP-POSTNR PIC 9999.
02 TEMP-BYNAVN PIC X(20).
02 TEMP-TLFNR PIC 9(8).
*
*
PROCEDURE DIVISION.
STYR SECTION.
STYR-IND.
PERFORM OPEN-FILER.
PERFORM INDLAES-DATO.
PERFORM TRANS UNTIL EOF-LAES1="JA " OR EOF-LAES2="JA ".
IF EOF-LAES2="JA "
PERFORM LAES-NAESTE UNTIL EOF-LAES1="JA "
ELSE
PERFORM TRANS UNTIL EOF-LAES2="JA ".
PERFORM LUK-FILER.
STOP RUN.
STYR-UD.
EXIT.
*
*
OPEN-FILER SECTION.
OPEN-IND.
OPEN INPUT LAES-FIL1.
OPEN INPUT LAES-FIL2.
OPEN OUTPUT AJOUR-FIL.
OPEN OUTPUT PRINTER.
PERFORM LAES-LAES1.
MOVE PERSREG TO TEMP-REG.
PERFORM LAES-LAES2.
\f
* Level II COBOL V2.1 OPG6B.CBL Page 0003
*
OPEN-UD.
EXIT.
*
*
INDLAES-DATO SECTION.
DATO-IND.
PERFORM CLEAR.
DISPLAY "DAGS DATO:" AT 0101.
ACCEPT DATO AT 0112.
PERFORM CLEAR.
DATO-UD.
EXIT.
*
*
CLEAR SECTION.
CLS-IND.
DISPLAY SPACES UPON CRT.
CLS-UD.
EXIT.
*
*
TRANS SECTION.
TRANS-IND.
IF EOF-LAES1="NEJ"
PERFORM LAES-NAESTE UNTIL PERS-NR NOT < TRANS-NR.
MOVE SPACES TO KOMMENTAR.
IF TRANS-TYPE=1
PERFORM OPRET
ELSE IF TRANS-TYPE=2
PERFORM AENDRE
ELSE
PERFORM SLET.
TRANS-UD.
EXIT.
*
*
LUK-FILER SECTION.
LUK-IND.
CLOSE LAES-FIL1.
CLOSE LAES-FIL2.
CLOSE AJOUR-FIL.
CLOSE PRINTER.
LUK-UD.
EXIT.
*
*
LAES-NAESTE SECTION.
LNST-IND.
WRITE AJOUR-REG FROM TEMP-REG.
PERFORM LAES-LAES1.
LNST-UD.
EXIT.
*
*
OPRET SECTION.
OPR-IND.
IF PERS-NR=TRANS-NR
MOVE "OPRETTELSE AF EKSISTERENDE POST" TO KOMMENTAR
ELSE
\f
* Level II COBOL V2.1 OPG6B.CBL Page 0004
*
PERFORM FLYT-LAES2-TIL-AJOUR
MOVE "OPRETTET" TO KOMMENTAR.
MOVE TRANSREG TO TEMP-REG.
PERFORM SKRIV-DETAIL.
OPR-UD.
EXIT.
*
*
AENDRE SECTION.
AENDRE-IND.
IF PERS-NR = TRANS-NR
PERFORM FLYT-LAES2-TIL-AJOUR
MOVE "ÆNDRET" TO KOMMENTAR
PERFORM LAES-LAES1
ELSE
IF TEMP-NR = TRANS-NR
PERFORM FLYT-LAES2-TIL-AJOUR
MOVE "ÆNDRET" TO KOMMENTAR
ELSE
MOVE "ÆNDRING AF IKKE EKSISTERENDE POST" TO KOMMENTAR.
MOVE TRANSREG TO TEMP-REG.
PERFORM SKRIV-DETAIL.
AENDRE-UD.
EXIT.
*
*
SLET SECTION.
SLET-IND.
IF PERS-NR = TRANS-NR OR TEMP-NR = TRANS-NR
MOVE "SLETTET" TO KOMMENTAR
PERFORM LAES-LAES1
ELSE
MOVE "SLETNING AF IKKE EKSISTERENDE POST" TO KOMMENTAR.
PERFORM SKRIV-DETAIL.
SLET-UD.
EXIT.
*
*
FLYT-LAES2-TIL-AJOUR SECTION.
FLYT-IND.
MOVE SPACES TO AJOUR-REG.
MOVE TRANS-NR TO AJOUR-NR.
IF TRANS-FNVN NOT = SPACES MOVE TRANS-FNVN TO AJOUR-FNVN
ELSE MOVE TEMP-FNVN TO AJOUR-FNVN.
IF TRANS-EFNVN NOT = SPACES MOVE TRANS-EFNVN TO AJOUR-EFNVN
ELSE MOVE TEMP-EFNVN TO AJOUR-EFNVN.
IF TRANS-GNVN NOT = SPACES MOVE TRANS-GNVN TO AJOUR-GNVN
ELSE MOVE TEMP-GNVN TO AJOUR-GNVN.
IF TRANS-POSTNR NOT = SPACES MOVE TRANS-POSTNR TO AJOUR-POSTNR
ELSE MOVE TEMP-POSTNR TO AJOUR-POSTNR.
IF TRANS-BYNAVN NOT = SPACES MOVE TRANS-BYNAVN TO AJOUR-BYNAVN
ELSE MOVE TEMP-BYNAVN TO AJOUR-BYNAVN.
IF TRANS-TLFNR NOT = ZEROES MOVE TRANS-TLFNR TO AJOUR-TLFNR
ELSE MOVE TEMP-TLFNR TO AJOUR-TLFNR.
WRITE AJOUR-REG.
FLYT-UD.
EXIT.
*
*
\f
* Level II COBOL V2.1 OPG6B.CBL Page 0005
*
SKRIV-DETAIL SECTION.
SK-DET-IND.
MOVE TRANS-NR TO RAPP-PERSNR.
MOVE SIDETAL TO SIDE-NR.
MOVE DATO TO OVS1-DATO.
PERFORM LINIE-SKRIV.
PERFORM LAES-LAES2.
SK-DET-UD.
EXIT.
*
*
LINIE-SKRIV SECTION.
LS-IND.
IF LINIE-TAELLER = 18
WRITE PRINT-LINIE FROM OVERSKRIFT-1 AFTER ADVANCING PAGE
WRITE PRINT-LINIE FROM OVERSKRIFT-2 AFTER ADVANCING 2 LINES
ADD 1 TO SIDETAL
WRITE PRINT-LINIE FROM RAPPORT-LINIE
MOVE ZERO TO LINIE-TAELLER
ELSE
WRITE PRINT-LINIE FROM RAPPORT-LINIE AFTER ADVANCING 2 LINES.
ADD 1 TO LINIE-TAELLER.
LS-UD.
EXIT.
*
*
LAES-LAES1 SECTION.
L-L1-IND.
IF EOF-LAES1="JA "
MOVE ZEROES TO PERS-NR
ELSE
READ LAES-FIL1 AT END MOVE "JA " TO EOF-LAES1.
MOVE PERSREG TO TEMP-REG.
L-L1-UD.
EXIT.
*
*
LAES-LAES2 SECTION.
L-L2-IND.
IF EOF-LAES2="JA "
MOVE 9999999999 TO TRANS-NR
ELSE
READ LAES-FIL2 AT END MOVE "JA " TO EOF-LAES2.
L-L2-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=01536 DICT=01963:59844/61807 GSA FLAGS = OFF
«eof»