|
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: 14464 (0x3880)
Types: TextFile
Names: »OPG8PH.LST«
└─⟦c154ac35e⟧ Bits:30002656 COBOL-programmer til undervisning
└─ ⟦this⟧ »OPG8PH.LST«
\f
* Level II COBOL V2.1 B:OPG8PH.CBL Page 0001
*
* Options:
IDENTIFICATION DIVISION.
PROGRAM-ID. OPG8.
AUTHOR. HOLD 4.
DATE-WRITTEN. 27/10/85.
DATE-COMPILED. 28/1O/85.
*
*
* PROGRAMMET LÆSER FILEN PERSON.TRA TIL EOF.
* FOR HVER POST DANNES EN TILSVARENDE PÅ DEN
* INDEX-SEKVENTIELLE FIL IXPERSON.REG.
*
*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
SOURCE-COMPUTER. PICCOLINE.
OBJECT-COMPUTER. PICCOLINE.
*
SPECIAL-NAMES. CONSOLE IS CRT
DECIMAL-POINT IS COMMA.
*
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT FIL ASSIGN TO "B:IXPERSON.REG"
ORGANIZATION IS INDEXED
ACCESS MODE IS DYNAMIC
RECORD KEY IS NOGLE
FILE STATUS IS SVAR-KEY.
*
*
DATA DIVISION.
FILE SECTION.
FD FIL
LABEL RECORD IS STANDARD.
01 FILDATA.
02 NOGLE 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 9999.
02 PERS-BYNAVN PIC X(20).
02 PERS-TLFNR PIC 9(8).
*
*
WORKING-STORAGE SECTION.
01 SVAR-KEY.
02 SVAR-1 PIC X.
02 SVAR-2 PIC X.
01 RESULT PIC 999.
01 ML-RES PIC 99.
01 CHECKSUM PIC 99V99.
01 FYLD REDEFINES CHECKSUM.
02 F1 PIC 99.
02 F2 PIC 99.
01 PERSONDATA.
02 PERSNR.
03 CIF PIC 9 OCCURS 10 TIMES.
02 F-NVN PIC X(15).
02 E-NVN PIC X(20).
\f
* Level II COBOL V2.1 B:OPG8PH.CBL Page 0002
*
02 ADR PIC X(20).
02 POSTNR PIC 9999.
02 BY-NVN PIC X(20).
02 TLF-NR PIC 9(8).
01 SKAERMSTYRINGSOMRAADE.
02 BINAER-TAL PIC 99 COMP.
02 STYR-TEGN PIC X REDEFINES BINAER-TAL.
01 FORKERT PIC 9 VALUE 0.
01 SVAR PIC 9.
01 V-TAB.
02 FILLER PIC X(10) VALUE "4327654321".
01 V-TAB-R REDEFINES V-TAB.
02 V-F PIC 9 OCCURS 10 TIMES.
01 S-FELT.
02 S-F1 PIC 99.
02 S-F2 PIC 99.
01 OK PIC X VALUE HIGH-VALUE.
01 SW PIC 9 VALUE 0.
01 TAL PIC 99 VALUE 0.
01 RETUR PIC X.
*
*
*
PROCEDURE DIVISION.
STYR SECTION.
STYR-IND.
PERFORM INIT.
PERFORM FUNKTION.
PERFORM BEHANDLE UNTIL SVAR = 5.
PERFORM AFSLUT.
STOP RUN.
STYR-UD.
EXIT.
*
*
INIT SECTION.
INIT-IND.
DISPLAY SPACES UPON CRT.
OPEN I-O FIL.
INIT-UD.
EXIT.
*
FUNKTION SECTION.
FUNK-IND.
DISPLAY "H O V E D M E N U" AT 0331.INDFIL.
DISPLAY "1 = OPRETTELSE:" AT 0603.
DISPLAY "2 = ÆNDRING:" AT 0803.
DISPLAY "3 = SLETNING:" AT 1003.
DISPLAY "4 = UDSKRIVNING:" AT 1203.
DISPLAY "5 = SLUT:" AT 1403.
ACCEPT SVAR AT 1721.
IF SVAR < 6 NEXT SENTENCE
ELSE PERFORM FEJLFUNK UNTIL SVAR < 6.
FUNK-UD.
EXIT.
*
*
FEJLFUNK SECTION.
FEFU-IND.
\f
* Level II COBOL V2.1 B:OPG8PH.CBL Page 0003
*
MOVE 30 TO BINAER-TAL.
DISPLAY STYR-TEGN AT 2401.
DISPLAY "GAL FUNKTIONSTYPE" AT 2403.
ACCEPT SVAR AT 2422.
FEFU-UD.
EXIT.
*
*
BEHANDLE SECTION.
BEHA-IND.
MOVE ZERO TO PERSONDATA.
MOVE 99 TO F2.
IF SVAR = 1 PERFORM OPRET.
IF SVAR = 2 PERFORM AENDRE.
IF SVAR = 3 PERFORM SLET.
IF SVAR = 4 PERFORM UDSKRIV.
DISPLAY SPACES UPON CRT.
PERFORM FUNKTION.
BEHA-UD.
EXIT.
*
OPRET SECTION.
OP-IND.
DISPLAY SPACES UPON CRT.
PERFORM DIALOG.
PERFORM NYDATA UNTIL PERSNR = SPACES.
OP-UD.
EXIT.
*
*
NYDATA SECTION.
NY-IND.
MOVE SPACES TO PERSONDATA.
MOVE 30 TO BINAER-TAL.
MOVE 0331 TO S-FELT.
PERFORM SLETFELT 7 TIMES.
DISPLAY "OPRETTELSE" AT 0110 UPON CRT-UNDER.
DISPLAY STYR-TEGN AT 2401.
DISPLAY STYR-TEGN AT 2501.
ACCEPT PERSNR AT 0331.
IF PERSNR = SPACES NEXT SENTENCE
ELSE PERFORM CHECKPERSNR UNTIL F2 = ZERO
DISPLAY STYR-TEGN AT 2401
MOVE 99 TO F2
PERFORM LAES
IF SVAR-1 = ZERO NEXT SENTENCE
ELSE ACCEPT F-NVN AT 0531
ACCEPT E-NVN AT 0731
ACCEPT ADR AT 0931
ACCEPT POSTNR AT 1131
IF POSTNR = SPACES NEXT SENTENCE
ELSE PERFORM CHECKPOSTNR
DISPLAY STYR-TEGN AT 2401
ACCEPT BY-NVN AT 1331
ACCEPT TLF-NR AT 1531
WRITE FILDATA FROM PERSONDATA
MOVE 30 TO BINAER-TAL
DISPLAY STYR-TEGN AT 2401
DISPLAY "OPRETTET" AT 2403
\f
* Level II COBOL V2.1 B:OPG8PH.CBL Page 0004
*
DISPLAY "TRYK (RETUR)" AT 2503
ACCEPT RETUR AT 2518.
NY-UD.
EXIT.
*
*
LAES SECTION.
LAES-IND.
MOVE PERSNR TO NOGLE.
READ FIL INTO PERSONDATA.
IF SVAR-1 NOT = ZERO NEXT SENTENCE
ELSE DISPLAY "PERSON FINDES" AT 2403 UPON CRT-UNDER
DISPLAY "TRYK (RETUR)" AT 2503
ACCEPT RETUR AT 2518.
MOVE SPACES TO PERSONDATA.
MOVE NOGLE TO PERSNR.
LAES-UD.
EXIT.
*
*
AENDRE SECTION.
AEND-IND.
DISPLAY SPACES UPON CRT.
PERFORM RETDATA UNTIL PERSNR = SPACES.
AEND-UD.
EXIT.
*
*
RETDATA SECTION.
RET-IND.
PERFORM FORNY.
IF SW = 0 PERFORM RESTDATA.
RET-UD.
EXIT.
*
*
FORNY SECTION.
FORN-IND.
MOVE SPACES TO PERSONDATA.
MOVE 30 TO BINAER-TAL.
MOVE 0331 TO S-FELT.
PERFORM SLETFELT 7 TIMES.
DISPLAY STYR-TEGN AT 2401.
DISPLAY STYR-TEGN AT 2501.
DISPLAY "ÆNDRING" AT 0110 UPON CRT-UNDER.
PERFORM SKRIVUD.
ACCEPT PERSNR AT 0331.
MOVE 99 TO SVAR-KEY.
MOVE 1 TO SW.
IF PERSNR = SPACES NEXT SENTENCE
ELSE PERFORM CHECKPERSNR UNTIL F2 = ZERO
DISPLAY STYR-TEGN AT 2401
MOVE PERSNR TO NOGLE
MOVE 99 TO F2
PERFORM INDLAES
IF SVAR-1 = ZERO MOVE ZERO TO SW.
FORN-UD.
EXIT.
*
\f
* Level II COBOL V2.1 B:OPG8PH.CBL Page 0005
*
*
RESTDATA SECTION.
REST-IND.
PERFORM REST-DIALOG.
DISPLAY F-NVN AT 0531.
DISPLAY E-NVN AT 0731.
DISPLAY ADR AT 0931.
DISPLAY POSTNR AT 1131.
DISPLAY BY-NVN AT 1331.
DISPLAY TLF-NR AT 1531.
ACCEPT F-NVN AT 0531.
ACCEPT E-NVN AT 0731.
ACCEPT ADR AT 0931.
ACCEPT POSTNR AT 1131.
IF POSTNR = SPACES NEXT SENTENCE
ELSE PERFORM CHECKPOSTNR.
DISPLAY STYR-TEGN AT 2401.
ACCEPT BY-NVN AT 1331.
ACCEPT TLF-NR AT 1531.
DISPLAY "OK AT ÆNDRE OPLYSNINGER J/N" AT 2403.
ACCEPT OK AT 2431.
IF OK = "J" REWRITE FILDATA FROM PERSONDATA.
MOVE HIGH-VALUE TO OK.
MOVE 1 TO SW.
REST-UD.
EXIT.
*
*
INDLAES SECTION.
INLA-IND.
READ FIL INTO PERSONDATA INVALID KEY
DISPLAY "PERSON FINDES IKKE" AT 2403
DISPLAY "TRYK (RETUR)" AT 2503
ACCEPT RETUR AT 2518.
INLA-UD.
EXIT.
*
*
SLET SECTION.
SLET-IND.
DISPLAY SPACES UPON CRT.
PERFORM SLETTES UNTIL PERSNR = SPACES.
SLET-UD.
EXIT.
*
SLETTES SECTION.
SLET-IND.
MOVE SPACES TO PERSONDATA.
MOVE 30 TO BINAER-TAL.
MOVE 0331 TO S-FELT.
PERFORM SLETFELT.
PERFORM SKRIVUD.
DISPLAY STYR-TEGN AT 2401.
DISPLAY STYR-TEGN AT 2501.
ACCEPT PERSNR AT 0331.
IF PERSNR = SPACES NEXT SENTENCE
ELSE PERFORM CHECKPERSNR UNTIL F2 = ZERO
DISPLAY STYR-TEGN AT 2401
MOVE 99 TO F2
\f
* Level II COBOL V2.1 B:OPG8PH.CBL Page 0006
*
DISPLAY "OK AT SLETTE PERSON (J/N)" AT 2403
ACCEPT OK AT 2431
MOVE PERSNR TO NOGLE
PERFORM LAESFILIND
MOVE HIGH-VALUE TO OK.
SLET-UD.
EXIT.
*
*
LAESFILIND SECTION.
LAFI-IND.
IF OK = "J" DELETE FIL INVALID KEY
DISPLAY STYR-TEGN AT 2401
DISPLAY "PERSON FINDES IKKE" AT 2403
DISPLAY "TRYK (RETUR)" AT 2503
ACCEPT RETUR AT 2518.
LAFI-UD.
EXIT.
*
*
UDSKRIV SECTION.
UDSK-IND.
DISPLAY SPACES UPON CRT.
PERFORM SKRIVER UNTIL PERSNR = SPACES.
UDSK-UD.
EXIT.
*
*
SKRIVER SECTION.
SKRI-IND.
MOVE SPACES TO PERSONDATA.
MOVE 30 TO BINAER-TAL.
MOVE 0331 TO S-FELT.
PERFORM SLETFELT 7 TIMES.
DISPLAY "PERSONNUMMER:" AT 0311.
DISPLAY STYR-TEGN AT 2401.
DISPLAY STYR-TEGN AT 2501.
ACCEPT PERSNR AT 0331.
IF PERSNR = SPACES NEXT SENTENCE
ELSE PERFORM CHECKPERSNR UNTIL F2 = ZERO
DISPLAY STYR-TEGN AT 2401
MOVE PERSNR TO NOGLE
MOVE 99 TO F2
PERFORM INDLEASE
IF SVAR-1 NOT = 0 NEXT SENTENCE
ELSE PERFORM DIALOGUD
DISPLAY "TRYK (RETUR)" AT 2503
ACCEPT RETUR AT 2518.
SKRI-UD.
EXIT.
*
*
INDLEASE SECTION.
INLA-IND.
READ FIL INTO PERSONDATA INVALID KEY
DISPLAY "PERSON FINDES IKKE" AT 2403
DISPLAY "TRYK (RETUR)" AT 2503
ACCEPT RETUR AT 2518.
INLA-UD.
\f
* Level II COBOL V2.1 B:OPG8PH.CBL Page 0007
*
EXIT.
*
*
DIALOGUD SECTION.
SKRIVUD.
DISPLAY "FORNAVN:" AT 0511.
DISPLAY "EFTERNAVN:" AT 0711.
DISPLAY "GADENAVN:" AT 0911.
DISPLAY "POSTNUMMER:" AT 1111.
DISPLAY "BYNAVN:" AT 1311.
DISPLAY "TELEFONNUMMER:" AT 1311.
DISPLAY F-NVN AT 0531.
DISPLAY E-NVN AT 0731.
DISPLAY ADR AT 0931.
DISPLAY POSTNR AT 1131.
DISPLAY BY-NVN AT 1331.
DISPLAY TLF-NR AT 1531.
EXIT.
*
*
CHECKPERSNR SECTION.
CHPE-IND.
MOVE ZERO TO TAL RESULT.
PERFORM REGN 10 TIMES.
DIVIDE RESULT BY 11 GIVING CHECKSUM.
IF F2 = ZERO NEXT SENTENCE
ELSE MOVE 30 TO BINAER-TAL
DISPLAY STYR-TEGN AT 2401
DISPLAY "GALT PERSONNUMMER, TAST NYT" AT 2403
ACCEPT PERSNR AT 2431.
CHPE-UD.
EXIT.
*
*
REGN SECTION.
REGN-IND.
ADD 1 TO TAL.
MULTIPLY CIF (TAL) BY V-F (TAL) GIVING ML-RES.
ADD ML-RES TO RESULT.
REGN-UD.
EXIT.
*
*
CHECKPOSTNR SECTION.
CHPO-IND.
IF POSTNR < 1000 MOVE 1 TO FORKERT.
IF POSTNR > 9998 MOVE 1 TO FORKERT.
PERFORM FEJLPOSTNR UNTIL FORKERT = 0.
CHPO-UD.
EXIT.
*
*
FEJLPOSTNR SECTION.
FEPO-IND.
DISPLAY STYR-TEGN AT 2401.
DISPLAY "GALT NUMMER TAST NYT:" AT 2403.
ACCEPT POSTNR AT 2431.
MOVE ZERO TO FORKERT.
IF POSTNR < 1000 MOVE 1 TO FORKERT.
\f
* Level II COBOL V2.1 B:OPG8PH.CBL Page 0008
*
IF POSTNR > 9998 MOVE 1 TO FORKERT.
FEPO-UD.
EXIT.
*
*
AFSLUT SECTION.
AFSL-IND.
CLOSE FIL.
DISPLAY SPACES UPON CRT.
DISPLAY "ISAM AJOUR AFSLUTTET" AT 0101.
AFSL-UD.
EXIT.
*
*
DIALOG SECTION.
DILO-IND.
DISPLAY "TAST PERSONNUMMER:" AT 0303.
REST-DIALOG.
DISPLAY "TAST FORNAVN:" AT 0503.
DISPLAY "TAST EFTERNAVN:" AT 0703.
DISPLAY "TAST GADENAVN:" AT 0903
DISPLAY "TAST POSTNUMMER:" AT 1103.
DISPLAY "TAST BYNAVN:" AT 1303.
DISPLAY "TAST TELEFONNUMMER:" AT 1503.
DILO-UD.
EXIT.
*
*
SLETFELT SECTION.
SLFE-IND.
DISPLAY STYR-TEGN AT S-FELT.
ADD 2 TO S-F1.
SLFE-UD.
EXIT.
*
*
* Level II COBOL V2.1 REVISION 9 URN EY/0011/GA
* Compiler Copyright (C) 1983 Micro Focus Ltd
*
* ERRORS=00000 DATA=01024 CODE=03584 DICT=02202:59605/61807 GSA FLAGS = OFF
«eof»