|
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: 19908 (0x4dc4)
Types: Q1_Text, reclen=79
Notes: q1file
Names: »V41«
└─⟦256585323⟧ Bits:30008759 50001598
└─⟦this⟧ »V41«
/* V41 ÄR ETT PROGRAM FÖR UTSKRIFT AV KONTO,UKONTO & IK-SLAG.
V 0:1
PRG JÅ 780907
Ändring 800312 rättelse av pgmfel. Det gick inte att välja utskrift på
antingen 'ALLA' eller '5-siffriga'. Alla blev alltid utskrivna. OBg.
VERSION 1:4 Nivåerna markeras med asterisker i vänstra kanten. Utskriften
modifierad med hänsyn till kontots knytning till olika UKTO-tabeller */
DCL 1 KONTOSTR,
2 KONTO5 CHAR(5),
2 SDATUM5 FIXED(6),
2 TEXT5 CHAR(32),
2 UHMARK5 CHAR(1),
2 LISTB BINARY,
2 IKB BINARY;
/* 46 BYTES */
DCL 1 UKSTR,
2 KONTO3 CHAR(3),
2 SDATUM3 FIXED(6),
2 TEXT CHAR(32),
2 UHMARK CHAR(1);
/* 40 BYTES */
DCL 1 FSTR,
2 FIL1 FILE;
DCL 1 STR,
2 XN CHAR(24) INIT(' KONTOP ');
DCL T7 CHAR (7) INIT ('KONTO '),
T6BL CHAR (6) INIT (' '),
T70 CHAR(70) INIT
(' TEXT SDATUM UM LISTM UK IKSLAG'),
T74 CHAR(74) INIT
(' 12345 0123456789'),
TAB(5) CHAR(25) INIT('KONTOPLAN ',
' UKT-TABELL ',
' KIS-TABELL ',
'ALLA KONTON ',
'ENDAST 5-SIFFRIGA KONTON '),
LISTM CHAR(5),
UK CHAR(1),
IKSLAG CHAR(10),
TOM CHAR(10) INIT(' '),
NAMN(2) CHAR(10) INIT('KVV/KWAROS','AROS'),
SDATUM CHAR(6),
KONTO CHAR(5),
ASTER CHAR (5) INIT (' '),
L BINARY,
N BINARY,
FIL BINARY,
SIDA BINARY INIT(0),
R BINARY INIT(0),
S CHAR(1),
DATUM CHAR(6),
P POINTER,
D BASED(P) CHAR(6),
PP POINTER,
1 STRX BASED(PP),
2 X CHAR(2),
2 Y CHAR(2), /* 1 = KTOTAB, 2 = UKTOTAB, 3 = IKSLAGTAB */
2 FIRMA CHAR(1),
2 OP_KOD BINARY,
2 RADANT BINARY,
VERSION CHAR (47) INIT (' V41 Version 1.4 800701');
STRGEN:PROC;
IF FIL=1 THEN DO;
LISTM=TOM;
IKSLAG=TOM;
J=1;
DO I=1 TO 5;
IF (J&LISTB)=J THEN SUBSTR(LISTM,I,1)='1';
J=J*2;
END;
J=1;
DO I=0 TO 9;
UK=I;
IF (J&IKB)=J THEN SUBSTR(IKSLAG,I+1,1)=UK;
J=J*2;
END;
UK=' ';
IF (J & IKB) = J THEN UK='1';
SDATUM=SDATUM5;
TEXT=TEXT5;
UHMARK=UHMARK5;
J = K;
RETURN;
END;
ELSE DO;
SDATUM=SDATUM3;
J = K;
RETURN;
END;
END;
RUB:PROC;
SIDA=SIDA+1;
PUT SKIP(R+4) EDIT(NAMN(FIRMA-7))(A(19))(TAB(FIL))(A)(TAB(S+3))(A)
(' ')(A(6))('19')(A)(DATUM)(A(2))('-')(A)(SUBSTR(DATUM,3,2))(A(2))
('-')(A)(SUBSTR(DATUM,5,2))(A(5))('SID')(A(4))(SIDA)(A) SKIP(2);
PUT EDIT (T7) (A);
IF FIL=1 THEN PUT EDIT(T70)(A)SKIP EDIT (T6BL) (A) EDIT (T74)(A) SKIP;
ELSE PUT EDIT(T70)(A(51))SKIP(2);
R= RADANT - 8;
RETURN;
END;
SKRIV:PROC;
IF S = '2' THEN GO TO SKR55;
DO N = 1 TO 5;
IF SUBSTR(KONTO,N,1) = ' ' THEN GO TO SKR33;
END;
N = 6;
SKR33:
N = N - 1;
IF FIL ¬= 1 THEN GO TO SKR44;
IF N = 1 THEN ASTER = ' ****';
IF N = 2 THEN ASTER = ' ***';
IF N = 3 THEN ASTER = ' **';
IF N = 4 THEN ASTER = ' *';
IF N = 5 THEN ASTER = ' ';
IF M = 1 THEN GO TO SKR88;
GO TO SKR55;
SKR44:
IF N = 1 THEN ASTER = ' **';
IF N = 2 THEN ASTER = ' *';
IF N = 3 THEN ASTER = ' ';
IF M = 1 THEN GO TO SKR88;
SKR55:
IF S = '2' THEN GO TO SKR66;
O = 3;
IF FIL = 1 THEN O = 5;
IF SUBSTR (KONTO,O,1) = '0' THEN DO;
PUT SKIP EDIT (' ') (A);
R = R - 1;
END;
SKR66:
PUT SKIP EDIT (KONTO) (A(6)) (ASTER) (A(7)) (TEXT) (A(34));
IF SDATUM=0 THEN PUT EDIT(TOM)(A(8))(UHMARK)(A(4));
ELSE PUT EDIT(SDATUM)(A(8))(UHMARK)(A(4));
IF FIL=1 THEN PUT EDIT(LISTM)(A(7))(UK)(A(4))(IKSLAG)(A);
R=R-1;
SKR88:
M = 0;
SKR99:
RETURN;
END;
FRAEGA:PROC;
PUT FILE(D) SKIP EDIT('SKA ALLA KONTON SKRIVAS UT, ELLER')(A(47))
('BARA DE')(A(8))(J)(A)('-SIFFRIGA')(A(38))
('DVS DE SOM ÄR AKTUELLA VID KONTERING') (A(47))
('1 = ALLA')(A(47))('2 = ENDAST')(A(11))(J)(A)('-SIFFRIGA')(A(35));
GET SKIP LIST(S);
IF VERIFY(S,'12')=0 THEN GO TO UT;
PUT FILE(D) SKIP EDIT(VERSION)(A(105))('*** UTSKRIFT PÅGÅR ***')
(A(36));
CALL CORED(0);
RETURN;
END;
KTORED: PROC;
KTO11:
DO N = 1 TO 5;
IF SUBSTR (KONTO,N,1) = ' ' THEN GO TO KTO15;
END;
KTO15:
/* PUT SKIP LIST ('KTO15 ',N); */
N = N - 1;
IF N = L THEN GO TO KTO22;
/* PUT SKIP LIST ('KTO= ',KONTO);
PUT SKIP LIST ('N= ',N);
PUT SKIP LIST ('L= ',L); */
GO TO KTO99;
KTO22:
M = 1;
CALL SKRIV;
PUT SKIP (2) EDIT (KONTO) (A(6)) (ASTER) (A(6)) (TEXT) (A(34));
R = R - 2;
KTO99:
RETURN;
END;
/* H Ä R B Ö R J A R H U V U D P R O G R A M M E T */
START:
UNSPEC(P)=16570;
UNSPEC(PP)=16616;
CALL DATCHECK(DATUM);
IF DATUM='0 ' THEN GO TO UT;
D='0';
J=5;
FIL=Y; /* VAL I UNDERMENYN */
IF FIL¬=1 THEN DO;
SUBSTR(TAB(5),8,1)='3'; /* ÄNDRAR RUBRIKTEXT 5- TILL 3-SIFFR */
J=3;
END;
IF FIL=2 THEN XN=' UKONTOP ';
IF FIL=3 THEN XN=' KSKONTOP';
FSTR=STR;
OPEN FIL1;
L = 0;
IF FIL = 1 THEN L = 1;
M = 0;
CALL FRAEGA;
L0: IF R < 7 THEN CALL RUB;
L1:
N = 0;
IF FIL=1 THEN DO;
ON ENDFILE GO TO UT;
READ FILE(FIL1) INTO(KONTOSTR);
KONTO=KONTO5;
END;
ELSE DO;
ON ENDFILE GO TO UT;
READ FILE(FIL1) INTO(UKSTR);
KONTO=KONTO3;
SUBSTR (KONTO,4,2) = ' ';
END;
IF (SUBSTR(KONTO,J,1)=' ') & (S='2') THEN GO TO L1;
K = J;
CALL STRGEN;
IF S = '1' THEN DO;
CALL KTORED;
END;
IF S = '1' & N ¬= L + 1 THEN GO TO L0;
/* PUT SKIP LIST ('S= ',S); */
CALL SKRIV;
GO TO L0;
UT:
L = L + 1;
IF (FIL = 1) & (S = '1') & (L < 5) THEN DO;
OPEN FIL1;
GO TO L1;
END;
IF (FIL ¬= 1) & (S = '1') & (L < 3) THEN DO;
OPEN FIL1;
GO TO L1;
END;
D=DATUM;
PUT SKIP(R);
CALL PLOAD('Q ');
END;