|
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: 50560 (0xc580)
Types: Q1_Text, reclen=79
Notes: q1file
Names: »V111«
└─⟦256585323⟧ Bits:30008759 50001598
└─⟦this⟧ »V111«
/* V11 SKRIVER UT KONTOUTDRAG & SALDOLISTOR
FRÅN SPECIELL PARAMETERFIL INNEHÅLLANDE KONTOINTERVALL FÖR BOKSLUT
V 0:1
790515 OLLE */
DCL KONTO1 CHAR(11),
KONTO2 CHAR(11),
RKONTO1 CHAR(13) INIT('-----.---.---'),
RKONTO2 CHAR(13) INIT('-----.---.---'),
DATUM1 CHAR(6),
DATUM2 CHAR(6),
DAT1BIN BINARY,
DAT2BIN BINARY,
SPTYP BINARY,
STAB(11) BINARY,
S_MARK CHAR(13) INIT(' . . ');
DCL 1 PARAPOST,
2 PKONTO1 CHAR (13),
2 PKONTO2 CHAR (13),
2 PDAG CHAR (1),
2 PSUM CHAR (13);
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 RTP CHAR (8) INIT ('00000000');
DCL VERTEXT FILE,
VERBELOP FILE,
PARAMETR FILE,
REDTRACE FILE,
BSTRL BINARY INIT(61),
MAX BINARY,
BLOCKANT BINARY,
JK BINARY,
JJ BINARY,
LISTTYP BINARY,
RCODE BINARY,
KONTOG CHAR(11),
SIDA BINARY INIT(1),
R BINARY INIT(0),
RADANT BINARY INIT (0),
NAMN(2) CHAR(10) INIT('KVV/KWAROS','AROS'),
RTEXT(8) CHAR(22) INIT(
'KONTOUTDRAG',
'SALDOBESKED',
'PERDAG',
'BOKDAG',
'BOKDAG PERDAG VER.',
'',
'TEXT',
''),
RKONTO CHAR(13),
KONTONRG CHAR(11),
KONSTANT BINARY,
BUFF CHAR(20),
T1 CHAR(1),
T61 CHAR(6),
T62 CHAR(6),
T11 CHAR(11),
T13 CHAR(13),
T14 CHAR(14),
KT1 CHAR(1),
KT2 CHAR(2),
KT3 CHAR(3),
KT4 CHAR(4),
KT5 CHAR(5),
KT6 CHAR(6),
KT7 CHAR(7),
KT8 CHAR(8),
KT9 CHAR(9),
KT10 CHAR(10),
KT11 CHAR(11),
FX6 FIXED(6),
TYP1 BINARY INIT(0),
TYP2 BINARY INIT(0),
OFFSET BINARY INIT(1),
LENGD BINARY INIT(0),
SUMMA(11) FIXED(11) INIT((11)0),
P POINTER,
D CHAR(6) BASED(P),
DATUM CHAR(6),
PP POINTER,
1 STR BASED(PP),
2 X CHAR(2),
2 Y CHAR(2),
2 FIRMA CHAR(1),
T4 CHAR(4),
ANTAL_KONT BINARY INIT(0),
TOT_ANTAL_KONT BINARY INIT(0),
VERSION CHAR(47) INIT(' V10 Version 1.2 790323'),
RT CHAR (1) INIT ('0');
DCL KFLAGG BINARY INIT (0);
/* PROCEDURE DIVISION. */
RTSKRIV: PROC;
WRITE FILE (REDTRACE) FROM (RTP);
RETURN;
END;
KONTORED:PROC;
K0:
RTP = ('K0');
IF RT = '1' THEN CALL RTSKRIV;
KONTO2='-----------';
RKONTO='-----.---.---';
T1=SUBSTR(BUFF,1,1);
IF T1¬='8' & T1¬='9' & Y='5 ' THEN DO;
T1=SUBSTR(BUFF,7,1);
I=6;
J=7;
TYP2=1; /* UNDERKONTO */
IF INDEX('0123456789',T1)¬=0 THEN GO TO K1;
T1=SUBSTR(BUFF,11,1);
I=9;
J=11;
TYP2=2; /* IK-SLAG */
IF INDEX('0123456789',T1)=0 THEN GO TO KUT;
K1:
RTP = ('K1');
IF RT = '1' THEN CALL RTSKRIV;
DO K=1 TO 3;
SUBSTR(KONTO2,I,1)=T1;
SUBSTR(RKONTO,J,1)=T1;
T1=SUBSTR(BUFF,J+1,1);
IF INDEX('0123456789',T1)=0 THEN GO TO KUT;
J=J+1;
I=I+1;
END;
GO TO KUT;
END;
J=0;
TYP2=0;
DO I=1 TO 11;
IF I=6 ö I=9 THEN J=J+2;
ELSE J=J+1;
T1=SUBSTR(BUFF,J,1);
IF INDEX('0123456789',T1)=0 & LENGD>0 THEN GO TO KUT;
IF INDEX('0123456789',T1)¬=0 THEN DO;
SUBSTR(KONTO2,I,1)=T1;
SUBSTR(RKONTO,J,1)=T1;
LENGD=LENGD+1;
END;
ELSE DO;
OFFSET=OFFSET+1;
SUBSTR(KONTO2,I,1)='-';
SUBSTR(RKONTO,J,1)='-';
END;
END;
KUT:
RTP = ('KUT');
IF RT = '1' THEN CALL RTSKRIV;
IF KFLAGG=0 THEN DO;
KONTO1=KONTO2;
KFLAGG=1;
TYP1=TYP2;
END;
RETURN;
END;
SRED:PROC;
SR10:
RTP = ('SR10');
IF RT = '1' THEN CALL RTSKRIV;
J=14;
DO I=11 TO 1 BY -1;
IF (I=5) ö (I=8) THEN J=J-2;
ELSE J=J-1;
IF SUBSTR(BUFF,J,1)='S' THEN DO;
STAB(I)=1;
SUBSTR(S_MARK,J,1)='S';
END;
ELSE DO;
STAB(I)=0;
END;
END;
RETURN;
END;
RUB:PROC;
RU10:
RTP = ('RU10');
IF RT = '1' THEN CALL RTSKRIV;
I_R=LISTTYP;
PUT SKIP(R+3) EDIT(NAMN(FIRMA-7))(A(20))(RTEXT(I_R))(A(35))('19')(A)
(SUBSTR(DATUM,1,2))(A)('-')(A)(SUBSTR(DATUM,3,2))(A)('-')(A)
(SUBSTR(DATUM,5,2))(A(5))('SID')(A(4))(SIDA)(A) SKIP EDIT
('Fr.o.m konto')(A(13))(RKONTO1)(A)(', till konto')(A(13))(RKONTO2)
(A) SKIP EDIT(' ')(A(13))(S_MARK)(A) SKIP EDIT('Fr.o.m datum')(A(13))
(DATUM1)(A(7))('till datum')(A(11))(DATUM2)(A(7))('m.a.p')(A(6))
(RTEXT(SPTYP+2))(A) SKIP EDIT(' ')(A(12))('KONTO')(A(18))(RTEXT(I_R+4))
(A)(' ')(A(6))('BELOPP')(A(13))(RTEXT(I_R+6))(A) SKIP;
SIDA=SIDA+1;
R = RADANT - 8;
RETURN;
END;
STYRDATA:PROC;
S0:
RTP = ('S0');
IF RT = '1' THEN CALL RTSKRIV;
PUT FILE(D) SKIP EDIT(VERSION)(A(49))(' ')(A(47));
J = 94;
CALL MOVEBUFF (J);
PUT FILE (D) EDIT ('Fr.o.m. datum:') (A(41));
GET LIST (D);
CALL DATCHECK (DATUM1);
J = 135;
CALL MOVEBUFF (J);
PUT FILE (D) EDIT (DATUM1) (A);
J = 141;
CALL MOVEBUFF (J);
PUT FILE (D) EDIT ('Till datum:') (A(41));
GET LIST (D);
CALL DATCHECK (DATUM2);
J = 182;
CALL MOVEBUFF (J);
PUT FILE (D) EDIT (DATUM2) (A);
IF DATUM1 >= DATUM2 THEN GO TO S0;
D='0';
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;
END;
PARALAES: PROC;
P10:
RTP = ('P10');
IF RT = '1' THEN CALL RTSKRIV;
ON ERROR GO TO P80;
ON ENDFILE GO TO SLUT;
READ FILE (PARAMETR) INTO (PARAPOST);
J = 235;
CALL MOVEBUFF (J);
PUT FILE (D) EDIT ('Fr.o.m KONTO:') (A(34));
J = 269;
CALL MOVEBUFF (J);
BUFF = PKONTO1;
CALL KONTORED;
RKONTO1 = RKONTO;
PUT FILE (D) EDIT (RKONTO1) (A(6));
J = 282;
CALL MOVEBUFF (J);
PUT FILE (D) EDIT ('Till KONTO:') (A(34));
J = 316;
CALL MOVEBUFF (J);
BUFF = PKONTO2;
CALL KONTORED;
RKONTO2 = RKONTO;
PUT FILE (D) EDIT (RKONTO2) (A(6));
J = 329;
CALL MOVEBUFF (J);
PUT FILE (D) EDIT ('Summering:') (A(34));
J = 363;
CALL MOVEBUFF (J);
S_MARK = PSUM;
S_MARK = ('SSS . . ');
CALL SRED;
PUT FILE (D) EDIT (S_MARK) (A(13));
J = 376;
CALL MOVEBUFF (J);
PUT FILE (D) EDIT ('Datumtyp:') (A(46));
J = 422;
CALL MOVEBUFF (J);
PUT FILE (D) EDIT PDAG (A(1));
SPTYP = PDAG;
GO TO P99;
P80:
PUT SKIP LIST ('LÄSFEL I PARAMETERFILEN');
P99:
RETURN;
END;
STARTPOST:PROC;
STA0:
RTP = ('STA0');
IF RT = '1' THEN CALL RTSKRIV;
RCODE=0;
PK=ADDR(AREA);
OPEN VERBELOP;
CALL SEOF(VERBELOP);
MAX=UNSPEC(VERBELOP);
UNSPEC(VERBELOP)=0;
IF OFFSET>1 THEN DO;
READ FILE(VERBELOP) INTO(BSTR);
GO TO ST2;
END;
J=INDEX(KONTO1,'-')-1;
IF J=1 THEN DO;
KT1=KONTO1;
ON ERROR GO TO ST1;
READ KEY(KT1) FILE(VERBELOP) INTO(AREA);
END;
IF J=2 THEN DO;
KT2=KONTO1;
ON ERROR GO TO ST1;
READ KEY(KT2) FILE(VERBELOP) INTO(AREA);
END;
IF J=3 THEN DO;
KT3=KONTO1;
ON ERROR GO TO ST1;
READ KEY(KT3) FILE(VERBELOP) INTO(AREA);
END;
IF J=4 THEN DO;
KT4=KONTO1;
ON ERROR GO TO ST1;
READ KEY(KT4) FILE(VERBELOP) INTO(AREA);
END;
IF J=5 THEN DO;
KT5=KONTO1;
ON ERROR GO TO ST1;
READ KEY(KT5) FILE(VERBELOP) INTO(AREA);
END;
IF J=6 THEN DO;
KT6= KONTO1;
ON ERROR GO TO ST1;
READ KEY(KT6) FILE(VERBELOP) INTO(AREA);
END;
IF J=7 THEN DO;
KT7=KONTO1;
ON ERROR GO TO ST1;
READ KEY(KT7) FILE(VERBELOP) INTO(AREA);
END;
IF J=8 THEN DO;
KT8=KONTO1;
ON ERROR GO TO ST1;
READ KEY(KT8) FILE(VERBELOP) INTO(AREA);
END;
IF J=9 THEN DO;
KT9=KONTO1;
ON ERROR GO TO ST1;
READ KEY(KT9) FILE(VERBELOP) INTO(AREA);
END;
IF J=10 THEN DO;
KT10=KONTO1;
ON ERROR GO TO ST1;
READ KEY(KT10) FILE(VERBELOP) INTO(AREA);
END;
IF J=-1 THEN DO;
KT11=KONTO1;
ON ERROR GO TO ST1;
READ KEY(KT11) FILE(VERBELOP) INTO(AREA);
END;
GO TO ST2;
ST1:
RTP = ('ST1');
IF RT = '1' THEN CALL RTSKRIV;
IF ONCODE¬=4 THEN DO;
PUT SKIP LIST('LÄSFEL I VERBELOP',RCODE);
D=DATUM;
CALL PLOAD('Q ');
END;
RCODE=1;
RETURN;
ST2:
RTP = ('ST2');
IF RT = '1' THEN CALL RTSKRIV;
KONTONRG=KONTONR;
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;
END;
POST:PROC;
P1:
RTP = ('P1');
IF RT = '1' THEN CALL RTSKRIV;
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 VERBELOP',RCODE);
PK=ADDR(AREA);
END;
ELSE DO;
KONTONR='99999999999';
PDATUM=DAT1BIN;
DATUMT=DAT1BIN;
RETURN;
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;
END;
DATTEST:PROC;
D0:
RTP = ('D0');
IF RT = '1' THEN CALL RTSKRIV;
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;
D1:
RTP = ('D1');
IF RT = '1' THEN CALL RTSKRIV;
PUT SKIP LIST('LÄSFEL I VERTEXT',ONCODE);
R=R-1;
RCODE=1;
RETURN;
END;
KONTOTEST: PROC;
KTO10:
RTP = ('KTO10');
IF RT = '1' THEN CALL RTSKRIV;
RCODE=0;
IF SUBSTR(KONTONR,OFFSET,LENGD)=SUBSTR(KONTO2,OFFSET,LENGD) THEN RETURN;
IF KONTONR¬='99999999999' THEN RCODE=1;
RETURN;
END;
SKRIV_SUMMA: PROC;
SKR0:
RTP = ('SKR0');
IF RT = '1' THEN CALL RTSKRIV;
T13=' ';
T11=T13;
DO I=2 TO 11;
SUMMA(I)=SUMMA(I)+SUMMA(1);
END;
T4=ANTAL_KONT;
TOT_ANTAL_KONT=TOT_ANTAL_KONT+ANTAL_KONT;
DO I=1 TO 11;
IF SUBSTR(KONTONRG,I,1)¬=SUBSTR(KONTONR,I,1) THEN GO TO SKR1;
END;
SKR1:
RTP = ('SKR1');
IF RT = '1' THEN CALL RTSKRIV;
DO N=11 TO 1 BY-1;
IF SUBSTR(KONTONRG,N,1)¬='0' THEN GO TO SKR2;
END;
SKR2:
RTP = ('SKR2');
IF RT = '1' THEN CALL RTSKRIV;
IF R<8 THEN CALL RUB;
K=11;
DO J=1 TO 12-I;
IF STAB(12-J)=1 THEN DO;
IF R<2 THEN CALL RUB;
SUBSTR(T11,K,1)='*';
K=K-1;
CALL BELRED(SUMMA(J),T14);
M=0;
T13=' ';
DO L=1 TO 12-J;
M=M+1;
IF (L=6) ö (L=9) THEN DO;
SUBSTR(T13,M,1)='.';
M=M+1;
END;
SUBSTR(T13,M,1)=SUBSTR(KONTONRG,L,1);
END;
IF LISTTYP=1 THEN M=28;
ELSE M=2;
PUT SKIP EDIT(T11)(A(12))(T13)(A)(' ')(A(M))(T14)(A(33))(T4)(A);
T4=' ';
R=R-1;
END;
SUMMA(J)=0;
END;
KONTONRG=KONTONR;
SUMMA(1)=0;
IF K¬=11 THEN DO;
PUT SKIP;
R=R-1;
ANTAL_KONT=0;
END;
RETURN;
END;
POSTSKRIV:PROC;
P0:
RTP = ('P0');
IF RT = '1' THEN CALL RTSKRIV;
IF R<8 THEN CALL RUB;
IF VERNR¬=VERNRT THEN DO;
UNSPEC(VERTEXT)=VERNR-KONSTANT;
ON ERROR GO TO P3;
ON ENDFILE GO TO D1;
READ FILE(VERTEXT) INTO(TSTR);
GO TO P2;
P3:
RTP = ('P3');
IF RT = '1' THEN CALL RTSKRIV;
TEXT='**** FINNS EJ';
DATUMT=PDATUM;
P2:
RTP = ('P2');
IF RT = '1' THEN CALL RTSKRIV;
END;
I=0;
DO J=1 TO 11;
IF (J=6) ö (J=9) THEN DO;
I=I+1;
SUBSTR(T13,I,1)='.';
END;
I=I+1;
SUBSTR(T13,I,1)=SUBSTR(KONTONR,J,1);
END;
IF PDATUM<0 THEN PDATUM=-PDATUM;
IIII=DATUMT;
CALL BINTOCH(IIII,T61);
CALL BINTOCH(PDATUM,T62);
CALL BELRED(BELOPP,T14);
IF T61=T62 THEN T62=' ';
PUT SKIP EDIT(' ')(A(12))(T13)(A(18))(T61)(A(8))(T62)(A(8))
(VERNR)(P'-----9',X(1))(T14)(A(18))(TEXT)(A);
R=R-1;
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:
PUT FILE (D) SKIP EDIT (' Hur många rader har blanketten? ') (A(45));
GET LIST (RADANT);
IF RADANT < 30 ö RADANT > 80 THEN GO TO START;
CALL DATCHECK(DATUM);
IF DATUM='0 ' THEN CALL PLOAD('Q ');
PUT SKIP EDIT ('HÄR') (A);
UNSPEC(P)=16570;
D='0';
UNSPEC(PP)=16616;
OPEN REDTRACE;
OPEN PARAMETR;
CALL STYRDATA;
L0:
RTP = ('L0');
IF RT = '1' THEN CALL RTSKRIV;
CALL PARALAES;
IF Y='6 ' ö Y='7 ' THEN DO;
D=DATUM;
CALL PLOAD('V12 ');
END;
CALL STARTPOST;
IF RCODE=1 THEN GO TO L0;
L1:
RTP = ('L1');
IF RT = '1' THEN CALL RTSKRIV;
CALL POST;
CALL DATTEST;
IF RCODE¬=0 THEN GO TO L1;
IF OFFSET>1 THEN DO;
CALL KONTOTEST;
IF RCODE¬=0 THEN GO TO L1;
IF KONTONR='99999999999' THEN DO;
IF R<3 THEN CALL RUB;
CALL BELRED(SUMMA(1),T14);
T4=ANTAL_KONT;
TOT_ANTAL_KONT=ANTAL_KONT;
PUT SKIP EDIT(RKONTO1)(X(12),A(41))(T14)(A(33))(T4)(A);
R=R-1;
END;
END;
ELSE DO;
IF KONTONR>=KONTO2 THEN KONTONR='99999999999';
IF KONTONR¬=KONTONRG THEN CALL SKRIV_SUMMA;
END;
IF KONTONR='99999999999' THEN GO TO UT;
IF LISTTYP=1 THEN CALL POSTSKRIV;
SUMMA(1)=SUMMA(1)+BELOPP;
ANTAL_KONT=ANTAL_KONT+1;
GO TO L1;
UT:
RTP = ('UT');
IF RT = '1' THEN CALL RTSKRIV;
IF TOT_ANTAL_KONT=0 THEN DO;
CALL OUTPUT(1,6);
PUT SKIP(2) EDIT('**** INGEN KONTERING INOM BEGÄRT OMRÅDE')(A);
R=R-2;
END;
IF R¬=0 THEN PUT SKIP(R);
CLOSE VERBELOP;
GO TO L0;
SLUT:
RTP = ('SLUT');
IF RT = '1' THEN CALL RTSKRIV;
CLOSE REDTRACE;
D=DATUM;
CALL PLOAD('Q ');
END;