|
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: 40606 (0x9e9e)
Types: Q1_Text, reclen=79
Notes: q1file
Names: »V10KOLJA«
└─⟦ffc5cfcdb⟧ Bits:30008762 50001602
└─⟦this⟧ »V10KOLJA«
/*V10KOLJA SKRIVER I TABELLFORM KONTO I X-LED OCH IK-SLAG I Y-LED KOSTNADER
FÖR OLJA RESP KOLBESTÄLLNINGAR
830601 OBg
*/
DCL RKONTO1 CHAR (3) INIT ('---'),
RKONTO2 CHAR (3) INIT ('---'),
DATUM1 CHAR(6),
DATUM2 CHAR(6),
DAT1BIN BINARY,
DAT2BIN BINARY,
SPTYP BINARY, /* 1 = PERDAG 2 = BOKDAG */
STAB(11) BINARY;
DCL 1 TSTR,
2 VERNRT FIXED(5),
2 DATUMT BINARY,
2 TEXT CHAR(13),
2 ANTVERP BINARY;
DCL PK POINTER,
1 BSTR BASED(PK),
2 KONTONR CHAR(11);
DCL PB POINTER,
1 BELSTR BASED(PB),
2 VERNR BINARY,
2 PDATUM BINARY,
2 BELOPP FIXED(11);
DCL 1 AREA,
2 CH(255) CHAR(61);
/* 15 555 BYTES */
DCL 1 XKTOPOST,
2 XOK CHAR (3),
2 XKONTO FIXED (5),
2 XTEXT1 CHAR (14),
2 XTEXT2 CHAR (14),
2 XTEXT3 CHAR (14),
2 XTEXT4 CHAR (14),
2 XTEXT5 CHAR (14);
DCL 1 RTEXT (5,10) CHAR (14);
DCL 1 YKTOPOST,
2 YKTO FIXED (3),
2 YTEXT CHAR (12);
DCL 1 RYTEXT (40),
2 YRADTEXT CHAR (12),
2 YRADKTO FIXED (3);
DCL IK POINTER,
1 RYTEXTREDEF BASED (IK),
2 YRADTEXTREDEF CHAR (12),
2 YRADKTOREDEF FIXED (3);
DCL XKTO (10) CHAR (5),
SOK CHAR (3);
DCL VERTEXT FILE,
VERBELOP FILE,
XKTOFIL FILE,
YKTOFIL FILE,
BSTRL BINARY INIT(61),
MAX BINARY,
BLOCKANT BINARY,
JK BINARY,
JJ BINARY,
LISTTYP BINARY, /* 1 = KONTOUTDRAG, 2 = SALDOBESKED */
RCODE BINARY,
KONTOG CHAR(11),
SIDA BINARY INIT(1),
R BINARY INIT(0),
NAMN(2) CHAR(10) INIT('KVV/KWAROS','AROSKRAFT'),
T15BELRED CHAR (15),
KONSTANT BINARY,
BUFF CHAR(20),
T1 CHAR(1),
T61 CHAR(6),
T62 CHAR(6),
T11 CHAR(11),
T13 CHAR(13),
T14 CHAR(14),
T15 CHAR (15),
RUBTEXT CHAR (70),
LASNYCKEL CHAR (1) INIT ('0'),
SWFORSTA CHAR (1) INIT ('J'),
KT8 CHAR(8),
FX6 FIXED(6),
TYP1 BINARY INIT(0),
TYP2 BINARY INIT(0),
OFFSET BINARY INIT(1),
LENGD BINARY INIT(0),
SUMMA (39,10) FIXED (11) INIT ((39)0),
SSUMMA FIXED (11,2),
XL BINARY, /* KOORDINAT I X-LED SUMMATAB */
YL BINARY, /* KOORDINAT I Y-LED SUMMATAB */
XANT BINARY,
UANT BINARY,
UIND BINARY,
KIND BINARY,
OKEY CHAR (1),
P POINTER,
D CHAR(6) BASED(P),
DATUM CHAR(6),
PP POINTER,
1 STR BASED(PP),
2 X CHAR(2),
2 Y CHAR(2), /* 6 = UKTO, 7 = IKSLAG */
2 FIRMA CHAR (1),
2 OP_KOD BINARY,
2 RADANT BINARY,
T4 CHAR(4),
ANTAL_KONT BINARY INIT(0),
TOT_ANTAL_KONT BINARY INIT(0),
VERSION CHAR(47) INIT(' TR10KOLJA Version 1.1 830603');
RUB:PROC;
RUB10:
IF FIRMA = '8' THEN DO;
PUT SKIP (2) EDIT ('KVV') (A(40));
END;
IF FIRMA = '9' THEN DO;
PUT SKIP (2) EDIT ('AROS') (A(40));
END;
PUT EDIT (RUBTEXT) (A(86)) ('DATUM:')
(A(8)) (DATUM) (A(6));
DO J = 1 TO 5;
IF J = 2 THEN DO;
PUT SKIP EDIT ('PARA:') (A) (SUBSTR(SOK,1,2)) (A(4));
IF SUBSTR (SOK,1,1) = 'K' THEN PUT EDIT ('KOL') (A(4));
IF SUBSTR (SOK,1,1) = 'O' THEN PUT EDIT ('OLJA') (A(4));
PUT EDIT (' ') (A(6));
GO TO RUB20;
END;
IF J = 3 THEN DO;
PUT SKIP EDIT ('BEST-NR: ') (A) (RKONTO1) (A(3)) ('-') (A)
(RKONTO2 - '001') (P'999') (' ') (A(3));
GO TO RUB20;
END;
IF J = 4 THEN DO;
PUT SKIP;
IF SPTYP = 1 THEN PUT EDIT ('PER-D ') (A);
ELSE PUT EDIT ('BOK-D ') (A);
PUT EDIT (DATUM1) (A) ('-') (A) (DATUM2) (A);
GO TO RUB20;
END;
PUT SKIP EDIT (' ') (A(19));
RUB20:
DO I = 1 TO XANT;
PUT EDIT (RTEXT(J,I)) (A(14));
END;
END;
RUB99:
RETURN; /*234*/
END;
STYRDATA:PROC;
S1:
PUT FILE(D) SKIP EDIT(VERSION)(A(49))('KOL/OLJA')(A(47))
('Fr.o.m. BEST-NR')(A(47))('Till BEST-NR')(A(47));
J=138;
CALL MOVEBUFF(J);
GET SKIP LIST (RKONTO1);
PUT FILE (D) EDIT (RKONTO1) (A);
J=185;
CALL MOVEBUFF(J);
GET SKIP LIST (RKONTO2);
S15:
IF (RKONTO1 > RKONTO2) ö (TYP1¬=TYP2) THEN GO TO S1;
PUT FILE(D) EDIT(RKONTO2)(A);
UANT = RKONTO2 - RKONTO1;
UIND = 0;
J = 237;
CALL MOVEBUFF (J);
S17:
PUT FILE (D) EDIT ('1 = PERDATUM')(A(47))('2 = BOKDATUM')(A(44));
S4: GET SKIP LIST(SPTYP);
IF SPTYP<1 ö SPTYP>2 THEN GO TO S4;
PUT FILE(D) EDIT(SPTYP)(A(3))('Fr.o.m DATUM')(A(47))
('Till DATUM')(A);
J=370;
CALL MOVEBUFF(J);
S3: GET SKIP LIST(D);
CALL DATCHECK(DATUM1);
IF DATUM1='0 ' THEN GO TO S3;
PUT FILE(D) EDIT(DATUM1)(A);
J=417;
CALL MOVEBUFF(J);
S2: GET SKIP LIST(D);
CALL DATCHECK(DATUM2);
IF DATUM1>=DATUM2 THEN GO TO S2;
D='0';
PUT FILE(D) EDIT(DATUM2)(A);
J = 470;
CALL MOVEBUFF;
PUT FILE (D) EDIT (' ') (A(2)) ('OLJA = O, KOL = K') (A(18));
J = 515;
CALL MOVEBUFF (J);
GET SKIP LIST (SOK);
PUT FILE (D) EDIT (SOK) (A);
IF TYP1=1 THEN Y='6 ';
IF TYP1=2 THEN Y='7 ';
IF Y='4 ' THEN LISTTYP=1;
ELSE LISTTYP=2;
DAT1BIN=372*(SUBSTR(DATUM1,1,2)-78)+31*(SUBSTR(DATUM1,3,2)-1)+
SUBSTR(DATUM1,5,2)-1;
DAT2BIN=372*(SUBSTR(DATUM2,1,2)-78)+31*(SUBSTR(DATUM2,3,2)-1)+
SUBSTR(DATUM2,5,2)-1;
RETURN; /*293*/
END;
STARTPOST:PROC;
RCODE=0;
PK=ADDR(AREA);
OPEN VERBELOP;
CALL SEOF(VERBELOP);
MAX=UNSPEC(VERBELOP);
UNSPEC(VERBELOP)=0;
ON ERROR GO TO ST1;
READ KEY(KT8) FILE(VERBELOP) INTO(AREA);
GO TO ST2;
ST1: IF ONCODE¬=4 THEN DO;
PUT SKIP LIST('LÄSFEL I TIMMAR I POST: PROC ',RCODE);
D=DATUM;
CALL PLOAD('TR ');
END;
RCODE=1;
RETURN; /*371*/
ST2:
UNSPEC(VERBELOP)=UNSPEC(VERBELOP)-1;
BLOCKANT=MAX-UNSPEC(VERBELOP);
JJ=5;
JK=0;
IF (LISTTYP=1) ö (SPTYP=2) THEN DO;
OPEN VERTEXT;
READ FILE(VERTEXT) INTO(TSTR);
KONSTANT=VERNRT;
END;
RETURN; /*384*/
END;
POST:PROC;
P1: JJ=JJ+1;
IF JJ>5 THEN DO;
IF JK<1 THEN DO;
IF BLOCKANT>0 THEN DO;
JK=255;
IF JK>BLOCKANT THEN JK=BLOCKANT;
BLOCKANT=BLOCKANT-JK;
CALL RD(VERBELOP,AREA,JK,RCODE);
IF RCODE¬=0 THEN PUT SKIP LIST('LÄSFEL I TIMMAR ',RCODE);
PK=ADDR(AREA);
END;
ELSE DO;
KONTONR='SLUT9999999';
PDATUM=DAT1BIN;
DATUMT=DAT1BIN;
RETURN; /*403*/
END;
END;
ELSE DO;
UNSPEC(PK)=UNSPEC(PK)+BSTRL;
END;
JK=JK-1;
JJ=1;
END;
UNSPEC(PB)=UNSPEC(PK)+JJ*10+1;
IF PDATUM=0 THEN GO TO P1;
RETURN; /*414*/
END;
DATTEST:PROC;
RCODE=0;
IF (SPTYP=2) & (PDATUM<0) THEN DO;
IF VERNR¬=VERNRT THEN DO;
UNSPEC(VERTEXT)=VERNR-KONSTANT;
ON ERROR GO TO D1;
ON ENDFILE GO TO D1;
READ FILE(VERTEXT) INTO(TSTR);
END;
IF (DAT1BIN>DATUMT) ö (DAT2BIN<=DATUMT) THEN RCODE=1;
END;
ELSE DO;
IF PDATUM<0 THEN PDATUM=-PDATUM;
IF (DAT1BIN>PDATUM) ö (DAT2BIN<=PDATUM) THEN RCODE=1;
END;
RETURN; /*432*/
D1: PUT SKIP LIST('LÄSFEL I LÖP-NR UNDER LABEL D1 ',ONCODE);
R=R-1;
RCODE=1;
RETURN; /*437*/
END;
NOLLTAB: PROC;
NP10:
DO YL = 1 TO 39;
DO XL = 1 TO 10;
SUMMA (YL,XL) = 0;
END;
END;
NP99:
RETURN;
END;
KONTORED: PROC;
KP10:
UIND = UIND + 1;
LASNYCKEL = '0';
IF UIND = UANT THEN DO;
LASNYCKEL = '1';
UIND = 0;
GO TO KP20;
END;
IF SWFORSTA = 'J' THEN DO;
UIND = 0;
SWFORSTA = 'N';
GO TO KP20;
END;
GO TO KP90;
KP20:
KIND = KIND + 1;
XL = KIND;
IF KIND = XANT THEN DO;
RCODE = 3;
GO TO KP99;
END;
KP90:
KONTOG = '00000000000';
SUBSTR (KONTOG,1,5) = XKTO (KIND);
IF RKONTO1 + UIND > '99 ' THEN DO;
SUBSTR (KONTOG,6,3) = RKONTO1 + UIND;
GO TO KP95;
END;
IF RKONTO1 + UIND > '9 ' THEN DO;
SUBSTR (KONTOG,7,2) = RKONTO1 + UIND;
GO TO KP95;
END;
SUBSTR (KONTOG,8,1) = RKONTO1 + UIND;
KP95:
KT8 = SUBSTR (KONTOG,1,8);
KP99:
/* PUT SKIP LIST ('KONTO = ',KONTOG); */
RETURN;
END;
SKRIV_SUMMA:PROC;
SKR10:
UNSPEC (IK) = ADDR (RYTEXT(1));
UNSPEC (IK) = UNSPEC (IK) - 14;
DO YL = 1 TO 39;
UNSPEC (IK) = UNSPEC (IK) + 14;
PUT SKIP EDIT (YRADTEXTREDEF) (A(15)) (YRADKTOREDEF) (A(4));
DO XL = 1 TO XANT;
IF SUMMA (YL,XL) = 0 THEN DO;
PUT EDIT (' ') (A(14));
GO TO SKR20;
END;
SSUMMA = SUMMA (YL,XL) * 0.01;
PUT EDIT (SSUMMA) (P'ZZZ.ZZZ.ZZ9V:99');
SKR20:
END;
SKR30:
END;
SKR99:
RETURN;
END;
YKORD: PROC;
YP10:
OKEY = 'N';
UNSPEC (IK) = ADDR (RYTEXT(1));
UNSPEC (IK) = UNSPEC (IK) - 14;
DO I = 1 TO 39;
UNSPEC (IK) = UNSPEC (IK) + 14;
IF SUBSTR (KONTONR,9,3) = YRADKTOREDEF THEN DO;
OKEY = 'J';
YL = I;
GO TO YP99;
END;
END;
YP99:
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:
CALL DATCHECK(DATUM);
IF DATUM='0 ' THEN CALL PLOAD('Q ');
UNSPEC(P)=16570;
D='0';
UNSPEC(PP)=16616;
RADANT = 51;
A10:
CALL STYRDATA;
A20:
OPEN XKTOFIL;
I = 0;
A21:
ON ENDFILE GO TO A29;
READ FILE (XKTOFIL) INTO (XKTOPOST);
IF SUBSTR (XOK,1,2) ¬= SUBSTR (SOK,1,2) THEN GO TO A21;
IF SUBSTR (XOK,3,1) = 'R' THEN DO;
SUBSTR (RUBTEXT,1,14) = XTEXT1;
SUBSTR (RUBTEXT,15,14) = XTEXT2;
SUBSTR (RUBTEXT,29,14) = XTEXT3;
SUBSTR (RUBTEXT,43,14) = XTEXT4;
SUBSTR (RUBTEXT,57,14) = XTEXT5;
GO TO A21;
END;
I = I + 1;
RTEXT (1,I) = XTEXT1;
RTEXT (2,I) = XTEXT2;
RTEXT (3,I) = XTEXT3;
RTEXT (4,I) = XTEXT4;
RTEXT (5,I) = XTEXT5;
XKTO (I) = XKONTO;
GO TO A21;
A29:
IF I = 0 THEN DO;
PUT SKIP LIST ('ANGIVET STYRREGISTER SAKNAS ',SOK);
DO I = 1 TO 1000;
END;
GO TO A10;
END;
XANT = I;
KIND = 0;
A30:
OPEN YKTOFIL;
UNSPEC (IK) = ADDR (RYTEXT (1));
UNSPEC (IK) = IK - 14;
DO I = 1 TO 39;
UNSPEC (IK) = IK + 14;
YRADKTOREDEF = 0;
YRADTEXTREDEF = ' ';
END;
UNSPEC (IK) = ADDR (RYTEXT (1));
UNSPEC (IK) = IK - 14;
DO I = 1 TO 40;
ON ENDFILE GO TO A39;
READ FILE (YKTOFIL) INTO (YKTOPOST);
UNSPEC (IK) = IK + 14;
YRADTEXTREDEF = YTEXT;
YRADKTOREDEF = YKTO;
END;
A39:
L0:
CALL NOLLTAB;
CALL KONTORED;
CALL STARTPOST;
IF RCODE=1 THEN GO TO L3;
L1:
CALL POST; /* INLÄSN. AV 255 REC. FRÅN VERBELOP */
CALL DATTEST;
IF SUBSTR (KONTONR,1,8) > KT8 THEN GO TO L3;
GO TO L5;
L3:
CALL KONTORED;
IF RCODE = 3 THEN GO TO UT;
CALL STARTPOST;
IF RCODE = 1 THEN GO TO L3;
GO TO L1;
L5:
IF KONTONR='SLUT9999999' THEN GO TO UT;
CALL YKORD;
IF OKEY = 'J' THEN GO TO L10;
GO TO L1;
L10:
SUMMA (YL,XL) = SUMMA (YL,XL) + BELOPP;
SUMMA (YL,XANT) = SUMMA (YL,XANT) + BELOPP;
SUMMA (39,KIND) = SUMMA (39,KIND) + BELOPP;
SUMMA (39,XANT) = SUMMA (39,XANT) + BELOPP;
GO TO L1;
UT:
SLUT:
CALL RUB;
CALL SKRIV_SUMMA;
DO I = 1 TO 2000;
END;
PUT SKIP (5);
D=DATUM;
CALL PLOAD('Q ');
END;