|
DataMuseum.dkPresents historical artifacts from the history of: Q1 computer |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Q1 computer Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 10902 (0x2a96)
Types: Q1_Text, reclen=79
Notes: q1file
Names: »UPPDAT2«
└─⟦4578d4c41⟧ Bits:30008744 50001576
└─⟦this⟧ »UPPDAT2«
/* PROGRAM-ID. UPPDAT */
/* DATE-WRITTEN. 1978-08-18 */
/* AUTHOR. OLLE */
/* REMARKS. PROGRAMMET UPPDATERAR PERS-REG MED NYA OCH */
/* ÄNDRADE POSTER */
/* */
/* WORKING-STORAGE SECTION. */
DCL PREGI FILE,
PREGU FILE,
PTRANS FILE;
DCL RIACC BINARY INIT (0);
DCL RUACC BINARY INIT (0);
DCL TACC BINARY INIT (0);
DCL RIANT BINARY INIT (0);
DCL TIANT BINARY INIT (0);
DCL KOD BINARY INIT (0);
DCL 1 REG,
2 RFILLER CHAR (511);
DCL R POINTER;
DCL RAREA BASED (R) CHAR (1);
DCL 1 WREG,
2 ANSTNR CHAR (6),
2 RES1 CHAR (2),
2 ENAMN CHAR (20),
2 FNAMN CHAR (12),
2 TITEL CHAR (11),
2 ADRESS CHAR (25),
2 GATUNR CHAR (4),
2 ING CHAR (4),
2 POSTNR CHAR (6),
2 RES2 CHAR (6),
2 ORTNAMN CHAR (11),
2 RIKTNR CHAR (4),
2 TELNR CHAR (6),
2 RRES3 CHAR (16);
DCL 1 TRANS,
2 TFILLER CHAR (511);
DCL T POINTER;
DCL TAREA BASED (T) CHAR (1);
DCL 1 WTRANS,
2 TANSTNR CHAR (6),
2 TKOD CHAR (2),
2 TENAMN CHAR (20),
2 TFNAMN CHAR (12),
2 TTITEL CHAR (11),
2 TADRESS CHAR (25),
2 TGATUNR CHAR (4),
2 TING CHAR (4),
2 TPOSTNR CHAR (6),
2 TRES2 CHAR (2),
2 TORTNAMN CHAR (11),
2 TRIKTNR CHAR (4),
2 TTELNR CHAR (6),
2 TRES3 CHAR (16);
/* PROCEDURE DIVISION. */
R100:
PROC;
J = RIANT;
IF J > 25 THEN J = 25;
RIANT = RIANT - J;
R = ADDR REG;
CALL BLOCKARE (PREGI, RAREA, J, KOD);
IF J ¬= 0 THEN
PUT FILE (D) EDIT ('LÄSFEL INREG') (A(45));
RIACC = RIACC + J;
RETURN;
END;
T100:
PROC;
I = TIANT;
IF I > 25 THEN I = 25;
TIANT = TIANT - I;
T = ADDR TRANS;
CALL BLOCKARE (PTRANS, TAREA, I, KOD);
IF I ¬= 0 THEN
PUT FILE (D) EDIT ('LÄSFEL TRANS') (A(45));
TIACC = TIACC + 1;
RETURN;
END;
A100:
OPEN PREGI;
CALL SEOF (PREGI);
RIANT = UNSPEC (PREGI);
OPEN PREGU;
OPEN PTRANS;
CALL SEOF (PTRANS);
TIANT = UNSPEC (PTRANS);
PUT FILE (D) SKIP EDIT (' BEARBETNING PÅGÅR') (A(47));
A200:
WREG = REG (J);
IF ANSTNR = '999999' THEN GO TO A250;
IF J = 25 THEN CALL R100;
J = J + 1;
A250:
WTRANS = TRANS (I);
IF TANSTNR = '999999' THEN GO TO A300;
IF I = 25 THEN CALL T100;
I = I + 1;
A300:
IF TANSTNR = ANSTNR THEN GO TO B100;
IF TANSTNR > ANSTNR THEN GO TO C100;
IF TANSTNR < ANSTNR THEN GO TO D100;
PUT FILE (D) SKIP EDIT ('FEL I UPPDAT') (A(47));
GET SKIP LIST (TRES3);
WRITE FILE (PREGU) FROM (WTRANS);
B100:
IF ANSTNR = '999999' THEN GO TO G100;
IF TKOD = DL THEN GO TO D200;
WRITE FILE (PREGU) FROM (WTRANS);
RUACC = RUACC + 1;
GO TO A200;
C100:
WRITE FILE (PREGU) FROM (WREG);
RUACC = RUACC + 1;
IF ANSTNR = '999999' THEN GO TO A300;
IF J = 25 THEN CALL R100;
J = J + 1;
WREG = REG (J);
GO TO A300;
D100:
WRITE FILE (PREGU) FROM (WTRANS);
RUACC = RUACC + 1;
D200:
IF TANSTNR = '999999' THEN GO TO A300;
IF I = 25 THEN CALL T100;
I = I + 1;
WTRANS = TRANS (I);
GO TO A300;
G100:
WRITE FILE (PREGU) FROM (REG);
RUACC = RUACC + 1;
CLOSE PREGI;
CLOSE PREGU;
CLOSE PTRANS;
PUT SKIP (5) EDIT ('ANTAL REGPOSTER IN') (A(25)) (RIACC) (P'ZZZ9');
PUT SKIP (1) EDIT ('ANTAL REGPOSTER UT') (A(25)) (RUACC) (P'ZZZ9');
PUT SKIP (1) EDIT ('ANTAL TRANSPOSTER') (A(25)) (TACC) (P'ZZZ9');
END;