|
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: 21804 (0x552c)
Types: Q1_Text, reclen=79
Notes: q1file
Names: »V31«
└─⟦256585323⟧ Bits:30008759 50001598
└─⟦this⟧ »V31«
/* V3 ÄR ETT PROGRAM FÖR ÄNDRING OCH UPPLÄGGNING AV KONTO,UKONTU & SKKONTO
"F2" REGISTRERAR POSTEN
"F4" SÖKER NY POST
RUTINEN KONTROLERAR FÖRSTA SIFFRAN I KONTONUMMER
VERSION 1:2 Knytning av unik UKTO-tabell till visst konto. 800701.
PRG JÅ 780906 */
/*DCL DUMM(30) CHAR(120); */
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 SFLAGG BINARY INIT(0),
RFLAGG BINARY,
T3 CHAR(3),
T5 CHAR(5),
T8 CHAR(8),
T21 CHAR(21) INIT('12345 0123456789'),
T27 CHAR(27) INIT('SORT KONTOP SORTFIL 5 0 Q'),
T29 CHAR(29) INIT('SDATUM UM LISTM UK IK-SLAG'),
LISTM CHAR(5),
UK CHAR(1),
IKSLAG CHAR(10),
SDATUM CHAR(6),
BUFF CHAR(32),
TOM CHAR(32) INIT(' '),
UKTOLEDTEXT CHAR (32) INIT ('A-C-E-G-I-K-M-O-Q-S-U-X-Z1-3-5-7'),
FIL BINARY,
FRTYP BINARY,
DATUM CHAR(6),
P POINTER,
D BASED(P) CHAR(6),
PP POINTER,
1 STRX BASED(PP),
2 X CHAR(2),
2 Y CHAR(2),
2 FIRMA CHAR(1);
FILGEN:PROC;
LISTB=0;
IKB=0;
J=1;
DO I=1 TO 5;
IF SUBSTR(LISTM,I,1)='1' THEN LISTB=LISTB+J;
J=J*2;
END;
J=1;
DO I=1 TO 10;
IF SUBSTR(IKSLAG,I,1)¬=' ' THEN IKB=IKB+J;
J=J*2;
END;
IF UK='1' THEN IKB=IKB+J;
KONTO5=T5;
SDATUM5=SDATUM;
TEXT5=TEXT;
UHMARK5=UHMARK;
RETURN;
END;
STRGEN:PROC;
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;
RETURN;
END;
KONTOIN:PROC;
PUT FILE(D) SKIP EDIT(' KONTO')(A(96));
K1: GET SKIP LIST(T5);
IF T5=' ' THEN GO TO SLUT;
IF (FIL=1) & (SUBSTR(T5,1,1)¬=FIRMA) THEN DO;
CALL OUTPUT(1,6);
GO TO K1;
END;
IF FIL=1 THEN DO;
PUT FILE(D) EDIT(T5)(A);
ON ERROR GO TO FEL;
READ KEY(T5) FILE(FIL1) INTO(KONTOSTR);
CALL STRGEN;
END;
ELSE DO;
T3=T5;
PUT FILE(D) EDIT(T3)(A);
ON ERROR GO TO FEL;
READ KEY(T3) FILE(FIL1) INTO(UKSTR);
SDATUM=SDATUM3;
END;
RFLAGG=0;
IF SDATUM='0' THEN SDATUM=' ';
RETURN;
FEL: RFLAGG=1;
TEXT=TOM;
SDATUM=TOM;
UHMARK=TOM;
LISTM=TOM;
UK=TOM;
IKSLAG=TOM;
RETURN;
END;
DISPPUT:PROC;
J=9;
CALL MOVEBUFF(J);
IF FIL=1 THEN PUT FILE(D) EDIT(T29)(A(58))(T21)(A);
ELSE PUT FILE(D) EDIT(T29)(A(10));
J=111;
CALL MOVEBUFF(J);
PUT FILE(D) EDIT(UHMARK)(A(3));
IF FIL=1 THEN DO;
PUT FILE(D) EDIT(LISTM)(A(7))(UK)(A(4))(IKSLAG)(A);
END;
J=237;
CALL MOVEBUFF(J);
PUT FILE(D) EDIT('TEXT')(A);
IF FIL = 2 THEN DO;
J = 284;
CALL MOVEBUFF (J);
PUT FILE (D) EDIT (UKTOLEDTEXT) (A);
END;
J=331;
CALL MOVEBUFF(J);
PUT FILE(D) EDIT(TEXT)(A);
J=103;
CALL MOVEBUFF(J);
CALL TYPIST(SDATUM,6);
CALL TYPIST('┣10┫',1);
CALL CORED(0);
FRTYP=1;
RETURN;
END;
FRAEGA:PROC;
DCL JJ(6) BINARY INIT(103,111,114,121,125,331);
J=JJ(FRTYP);
CALL MOVEBUFF(J);
IF FRTYP=1 THEN CALL TYPIST(SDATUM,6);
IF FRTYP=2 THEN CALL TYPIST(UHMARK,1);
IF FRTYP=3 THEN CALL TYPIST(LISTM,5);
IF FRTYP=4 THEN CALL TYPIST(UK,1);
IF FRTYP=5 THEN CALL TYPIST(IKSLAG,10);
IF FRTYP=6 THEN CALL TYPIST(TEXT,32);
CALL TYPIST('┣10┫',1);
RETURN;
END;
SVAR:PROC;
DCL JJJ(6) BINARY INIT(6,1,5,1,10,32);
IF FRTYP=1 THEN SDATUM=BUFF;
IF FRTYP=2 THEN UHMARK=BUFF;
IF FRTYP=3 THEN LISTM=BUFF;
IF FRTYP=4 THEN UK=BUFF;
IF FRTYP=5 THEN IKSLAG=BUFF;
IF FRTYP=6 THEN TEXT=BUFF;
PUT FILE(D) EDIT(BUFF)(A(JJJ(FRTYP)));
FRTYP=FRTYP+1;
IF FRTYP=3 & FIL¬=1 THEN FRTYP=6;
IF FRTYP=7 THEN FRTYP=1;
RETURN;
END;
GO TO START;
UT:
CALL SVAR;
IF FIL=1 THEN DO; /* KONTOFILEN */
CALL FILGEN;
IF RFLAGG=1 THEN DO; /* SKRIVN AV TILLKOMMANDE POST*/
CALL SEOF(FIL1);
IF UNSPEC(FIL1)=0 THEN OPEN FIL1;
WRITE FILE(FIL1) FROM(KONTOSTR);
CLOSE FIL1;
OPEN FIL1;
SFLAGG=1;
END;
ELSE DO;
REWRITE FILE(FIL1) FROM(KONTOSTR); /*ÅTERSKR. AV BEFINTL. POST */
END;
END;
ELSE DO;
SDATUM3=SDATUM;
KONTO3=T3; /* SKRIVN. AV UKTO- KSFILERNA */
IF RFLAGG=1 THEN DO;
CALL SEOF(FIL1);
IF UNSPEC(FIL1)=0 THEN OPEN FIL1;
WRITE FILE(FIL1) FROM(UKSTR);
CLOSE FIL1;
OPEN FIL1;
SFLAGG=1;
END;
ELSE DO;
REWRITE FILE(FIL1) FROM(UKSTR);
END;
END;
GO TO L1;
/* 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 SLUT;
D='0';
FIL=Y;
IF FIL=2 THEN XN=' UKONTOP ';
IF FIL=3 THEN XN=' KSKONTOP';
FSTR=STR;
OPEN FIL1;
L1: CALL KONTOIN;
CALL DISPPUT;
L3: GET SKIP LIST(BUFF);
CALL KEYFUN(KEYT);
IF KEYT=20 THEN GO TO L1;
IF KEYT=18 THEN GO TO UT;
CALL SVAR;
CALL FRAEGA;
GO TO L3;
SLUT:
D=DATUM;
IF SFLAGG=0 THEN DO;
CALL PLOAD('Q ');
GO TO SLUT1;
END;
IF FIL¬=1 THEN DO;
T8=SUBSTR(XN,3,8);
SUBSTR(T27,6,8)=T8;
SUBSTR(T27,23,1)='3';
END;
CALL LOAD(T27,27);
SLUT1:END;