|
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: 21014 (0x5216)
Types: Q1_Text, reclen=79
Notes: q1file
Names: »RESRÄKN1«
└─⟦d1c33ffd3⟧ Bits:30008583 DDMQ1-0017_Bokforingssystem_kallkod_Msab_790411
└─⟦this⟧ »RESRÄKN1«
└─⟦f4c608b16⟧ Bits:30008624 DDMQ1-0064_LMC_Kopia_Generall_pgm_for_bokforing_Endast_PL1-vers_781105_B
└─⟦this⟧ »RESRÄKN1«
/*FÖRSTA RADEN*/
/*RESRÄKN TOTAL RESULTATRÄKNING. GENERELLT PGM. KLART:781104 PROGR:TD */
DCL 1 DUM,2 DUM1 CHAR(3),2 BUDKOD CHAR(1),2 DUM2 CHAR(51);
DCL 1 SAM,2 SSTR,3 SKO FIXED(4),3 SAVD CHAR(3),
2 SAD(12) FIXED(11,2),2 SAK(12) FIXED(11,2);
DCL 1 KTX,2 KSTR,3 TKO FIXED(4),3 TKOD CHAR(1),2 TKO2 CHAR(4),2 TEXT CHAR(34),
2 IB FIXED(13,2);
DCL 1 TX,2 KSTRX,3 KNR FIXED(4),3 ZZ CHAR(1),2 XKK CHAR(4),2 XTXT CHAR(34),
2 XXIB FIXED(13,2);
DCL 1 KBU,2 BSTR,3 BKO FIXED(4),3 BKOD CHAR(1),2 BAVD CHAR(3),
2 XBUD(12) FIXED(7);
DCL 1 DATREC,2 XDAG CHAR(6),2 MON CHAR(3),2 MNR FIXED(2),2 SK(14) CHAR(1),
2 KOD FIXED(1);
DCL DATFIL FILE,KTOTX FILE,S CHAR(1),RAD FIXED(2),SIDA FIXED(4),IND FIXED(1),
DAG CHAR(6),AVDSIDA FIXED(4),SAMFIL FILE,NI FIXED(1),
P1 FIXED(13,2),P2 FIXED(13,2),P3 FIXED(13,2),P4 FIXED(13,2),
B1 FIXED(8,1),B2 FIXED(8,1),B3 FIXED(8,1),B4 FIXED(8,1),BX FIXED(8,1),
S1 FIXED(13,2),S2 FIXED(13,2),S3 FIXED(13,2),S4 FIXED(13,2),
PB1 FIXED(8,1),PB2 FIXED(8,1),PB3 FIXED(8,1),PB4 FIXED(8,1),
K30P FIXED(13,2),K30S FIXED(13,2),K4P FIXED(13,2),K4S FIXED(13,2),
DIF1 FIXED(8,1),DIF2 FIXED(8,1),DIF3 FIXED(8,1),DIF4 FIXED(8,1),
DIFX FIXED(8,1),
SUB FIXED(1),PU(6) FIXED(13,2),BU(6) FIXED(8,1),SU(6) FIXED(13,2),
PBU(6) FIXED(8,1),DIFU(6) FIXED(8,1),UT(5) FIXED(13,2),
TP FIXED(13,2),TS FIXED(13,2),TPB FIXED(8,1),TB FIXED(8,1),TDIF FIXED(8,1),
TBP FIXED(13,2),TBS FIXED(13,2),TGP FLOAT(9),TGS FLOAT(9),
XSKO FIXED(4),XSAVD CHAR(3),TXT CHAR(34),RECNR BINARY,SAMSLUT BINARY,
KTOSLUT BINARY,JUMP FIXED(1),C CHAR(17)INIT('------------9V.99'),
CC CHAR(17)INIT('-----------9V.99*'),
CCC CHAR(16)INIT('-----9V.99% '),CCCC CHAR(15)INIT('----9V.99% '),
D CHAR(4)INIT('ZZZ9'),E CHAR(12)INIT('-------9V.9 '),PERC FLOAT(9),
F CHAR(12)INIT('-------9V.9%'),
EE CHAR(12)INIT('-------9V.9*'),J FIXED(4),K FIXED(4),L FIXED(4);
ABORT:PROC(ABTX);
DCL ABTX CHAR(15);
PUT SKIP EDIT('FEL! ')(A)(ABTX)(A)SKIP(RAD-4);GOTO SLUTT;
RETURN;
END;
RUB:PROC;
SIDA=SIDA+1;PUT SKIP(RAD)EDIT('RESULTATRÄKNING NIVÅ ')
(A)(NI)(A)(',TOTALT. ')(A)
('AVSEENDE MÅNAD ')(A)(MON)(A(5))(' DATUM:')(A)(DAG)(A(10))
('SIDA:')(A)(SIDA)(A)SKIP(2)EDIT('KTO')(A(5))('BENÄMNING')(A(44))
('MÅN. SALDO')(A(16))('ACK. SALDO')(A(15))('MÅN.BUD(kkr)')(A(16))
('ACK BUD')(A(10))('ACK DIFF')(A(10))('ACK %-DIFF')(A)SKIP;RAD=45;
RETURN;END;
ABSS:PROC(QQ);
DCL QQ FLOAT(13);
IF QQ<0 THEN QQ=-QQ;RETURN(QQ);END;
PROCENT:PROC(DIFF,TAL);
DCL DIFF FIXED(8,1),TAL FIXED(8,1);
IF TAL¬=0 THEN DO;
PERC=ABSS((DIFF*100)/TAL)+.05;PERC=-PERC;IF DIFF*TAL<0 THEN PERC=-PERC;
END;
IF TAL=0 THEN PERC=0;
RETURN;END;
NI1UT:PROC(JX,SUBSUBKO);
DCL JX FIXED(4),SUBSUBKO FIXED(4);
IF RAD<12 THEN CALL RUB;
XTXT='*** FINNS EJ I KONTOPLANEN ***';KNR=JX;ZZ='A';
ON ERROR GO TO X4;READ KEY(KSTRX)FILE(KTOTX)INTO(TX);
X4:CALL PROCENT(DIF1,B1);
PUT SKIP EDIT(JX)(A(5))(XTXT)(A(39))(-P1)(PCC)(-S1)(PCC,X(6))
(-PB1)(PE)(-B1)(PE)(-DIF1)(PE)(-PERC)(PF)SKIP(2);RAD=RAD-3;
TP=TP+P1;TS=TS+S1;TPB=TPB+PB1;TB=TB+B1;TDIF=TDIF+DIF1;
IF JX=4 THEN DO;K4P=P1;K4S=S1;END;
P1=0;S1=0;B1=0;PB1=0;DIF1=0;
RETURN;END;
SUBA:PROC(SUBKO);
DCL SUBKO FIXED(4);
IF P4=0&S4=0&B4=0&PB4=0&SUBKO¬=9999 THEN GO TO A1;
IF IND=1 THEN GO TO A6;
NI3UT:J=XKTO/10;K=SUBKO/10;L=XKTO/1000;
IF J=K THEN GO TO A6;
IF RAD<12 THEN CALL RUB;
IF (NI=3)&(J=XKTO/10) THEN J=XKTO;
IF((J¬=XKTO/10)&(NI>3))ö(NI=3) THEN DO;
XTXT='*** FINNS EJ I KONTOPLANEN ***';KNR=J;ZZ='A';
ON ERROR GO TO X2;READ KEY(KSTRX)FILE(KTOTX)INTO(TX);
X2:CALL PROCENT(DIF3,B3);
PUT SKIP EDIT(J)(A(5))(XTXT)(A(38))(-P3)(PC)(-S3)(PC,X(7));
IF PB3¬=0öB3¬=0öDIF3¬=0 THEN PUT EDIT(-PB3)(PE)(-B3)(PE)(-DIF3)(PE)(-PERC)(PF);
RAD=RAD-1;IF NI>3 THEN DO;PUT SKIP;RAD=RAD-1;END;END;
P2=P2+P3;B2=B2+B3;S2=S2+S3;PB2=PB2+PB3;DIF2=DIF2+DIF3;I=0;
IF NI=3&J=XKTO THEN J=XKTO/10;
IF J>299&J<340 THEN I=1;IF J>339&J<400 THEN I=2;IF J>399&J<600 THEN I=3;
IF J>599&J<790 THEN I=4;IF J>789&J<800 THEN I=5;IF J>799&J<999 THEN I=6;
IF I¬=0 THEN DO;PU(I)=PU(I)+P3;BU(I)=BU(I)+B3;SU(I)=SU(I)+S3;
DIFU(I)=DIFU(I)+DIF3;PBU(I)=PBU(I)+PB3;END;
P3=0;B3=0;S3=0;PB3=0;DIF3=0;
J=XKTO/100;K=SUBKO/100;IF J¬=K THEN GO TO NI2UT;
GO TO A6;
NI2UT:IF RAD<14 THEN CALL RUB;
IF NI>1 THEN DO;
XTXT='*** FINNS EJ I KONTOPLANEN ***';KNR=J;ZZ='A';
ON ERROR GO TO X3;READ KEY(KSTRX)FILE(KTOTX)INTO(TX);
X3:CALL PROCENT(DIF2,B2);
PUT SKIP EDIT(J)(A(5))(XTXT)(A(38))(-P2)(PC)(-S2)(PC,X(7));
IF PB2¬=0öB2¬=0öDIF2¬=0 THEN PUT EDIT(-PB2)(PE)(-B2)(PE)(-DIF2)(PE)(-PERC)(PF);
RAD=RAD-1;IF NI>2 THEN DO;PUT SKIP;RAD=RAD-1;END;END;
P1=P1+P2;B1=B1+B2;S1=S1+S2;PB1=PB1+PB2;DIF1=DIF1+DIF2;
IF J=30 THEN DO;K30P=P2;K30S=S2;END;
P2=0;B2=0;S2=0;PB2=0;DIF2=0;SUB=0;TXT=' ';
IF J<34&K>33 THEN DO;TXT='SUMMA FÖRSÄLJNING';SUB=1;END;
IF J>33&J<40&K>39 THEN DO;TXT='SUMMA ÖVRIGA INTÄKTER';SUB=2;END;
IF J>59&J<79&K>78 THEN DO;TXT='SUMMA ÖVRIGA KOSTNADER';SUB=4;END;
IF SUB¬=0 THEN DO;
UT(1)=PU(SUB);UT(2)=SU(SUB);UT(3)=PBU(SUB);UT(4)=BU(SUB);UT(5)=DIFU(SUB);
CALL PROCENT(DIFU(SUB),BU(SUB));
PUT SKIP EDIT('')(A(5))(TXT)(A(38))(-UT(1))(PC)(-UT(2))(PC,X(7))(-UT(3))(PE)
(-UT(4))(PE)(-UT(5))(PE)(-PERC)(PF)SKIP;RAD=RAD-2;END;
IF J<79&K>78 THEN DO;
DO JJ=1 TO 5;UT(JJ)=0;END;
DO JJ=1 TO 4;UT(1)=UT(1)+PU(JJ);UT(2)=UT(2)+SU(JJ);UT(3)=UT(3)+PBU(JJ);
UT(4)=UT(4)+BU(JJ);UT(5)=UT(5)+DIFU(JJ);END;
BX=UT(4);DIFX=UT(5);CALL PROCENT(DIFX,BX);
PUT SKIP EDIT('')(A(5))('RESULTAT FÖRE AVSKRIVNINGAR')(A(38))(-UT(1))(PC)
(-UT(2))(PC,X(7))(-UT(3))(PE)(-UT(4))(PE)(-UT(5))(PE)(-PERC)(PF)SKIP;RAD=RAD-2;
END;
IF J<80&K>79 THEN DO;
DO JJ=1 TO 5;UT(JJ)=0;END;
DO JJ=1 TO 5;UT(1)=UT(1)+PU(JJ);UT(2)=UT(2)+SU(JJ);UT(3)=UT(3)+PBU(JJ);
UT(4)=UT(4)+BU(JJ);UT(5)=UT(5)+DIFU(JJ);END;
BX=UT(4);DIFX=UT(5);CALL PROCENT(DIFX,BX);
PUT SKIP EDIT('')(A(5))('RESULTAT EFTER AVSKRIVNINGAR')(A(38))(-UT(1))(PC)
(-UT(2))(PC,X(7))(-UT(3))(PE)(-UT(4))(PE)(-UT(5))(PE)(-PERC)(PF)SKIP;RAD=RAD-2;
END;
IF J<88&K>87 THEN DO;
IF J<80 THEN DO;CALL NI1UT(L,8000);IND=2;END;
DO JJ=1 TO 5;UT(JJ)=0;END;
DO JJ=1 TO 6;UT(1)=UT(1)+PU(JJ);UT(2)=UT(2)+SU(JJ);UT(3)=UT(3)+PBU(JJ);
UT(4)=UT(4)+BU(JJ);UT(5)=UT(5)+DIFU(JJ);END;
BX=UT(4);DIFX=UT(5);CALL PROCENT(DIFX,BX);
PUT SKIP EDIT('')(A(5))('RESULTAT EFTER FIN. INT. & KOSTNADER')(A(38))(-UT(1))
(PC)(-UT(2))(PC,X(7))(-UT(3))(PE)(-UT(4))(PE)(-UT(5))(PE)(-PERC)(PF)SKIP;
RAD=RAD-2;END;
J=XKTO/1000;K=SUBKO/1000;IF J¬=K & IND¬=2 THEN CALL NI1UT(J,SUBKO);
IF SUBKO=9999 THEN GO TO TOTUT;
GO TO A6;
A6:
IND=0;
IF RAD<12 THEN CALL RUB;
DIF4=ABSS((S4-1000*B4)/1000)+.05;IF S4-1000*B4<0 THEN DIF4=-DIF4;
IF B4=0&PB4=0 THEN DIF4=0;
CALL PROCENT(DIF4,B4);
J=SUBKO/10;
IF NI>3 THEN DO;
PUT SKIP EDIT(SUBKO)(A(5))(TEXT)(A(38))(-P4)(PC)(-S4)(PC,X(7));
IF B4¬=0&PB4¬=0 THEN PUT EDIT(-PB4)(PE)(-B4)(PE)(-DIF4)(PE)(-PERC)(PF);
RAD=RAD-1;END;
XKTO=SUBKO;
P3=P3+P4;S3=S3+S4;B3=B3+B4;PB3=PB3+PB4;DIF3=DIF3+DIF4;
A1:
P4=0;S4=0;B4=0;PB4=0;DIF4=0;
RETURN;
TOTUT:IF RAD<14 THEN CALL RUB;
CALL PROCENT(TDIF,TB);
PUT SKIP(3)EDIT('')(A(5))
('*** TOTALT RESULTAT')(A(39))(-TP)(PCC)(-TS)(PCC,X(6))
(-TPB)(PEE)(-TB)(PEE)(-TDIF)(PEE)(-PERC)(PF);RAD=RAD-3;
GO TO SLUT;
RETURN;
END;
PROCB:PROC; /*UPPREPAR ACKUMULERING AV SALDON OCH LÄSNING I SAMFIL
TILLS ETT RECORD MED ANNAT KONTONUMMER HITTAS,ELLER FILEN TAR SLUT*/
S4=-IB;
SAMIN:XSKO=SKO;
DO I=1 TO MNR;S4=S4+SAD(I)-SAK(I);END;
P4=P4+SAD(MNR)-SAK(MNR);
ON ENDFILE GOTO SAMUT;READ FILE(SAMFIL)INTO(SAM);
GOTO SAMOK;
SAMUT:SAMSLUT=1;
SAMOK:IF SAMSLUT=0 & XSKO=SKO THEN GOTO SAMIN;
RETURN;END;
PROCC:PROC; /*UPPREPAR LÄSNING I KTOTX OCH ACKUMULERAR BUDGET TILLS ETT
RECORD MED ANNAT KONTONUMMER HITTAS, ELLER FILEN TAR SLUT*/
UNSPEC(KTOTX)=RECNR;
KTOIN:ON ENDFILE GOTO KTOUT;READ FILE(KTOTX)INTO(DUM);
RECNR=UNSPEC(KTOTX);GOTO KTOOK;
KTOUT:KTOSLUT=1;GOTO KTOKLAR;
KTOOK:IF BUDKOD='A' THEN GOTO KTOKLAR;
KBU=DUM;
IF BKO¬=TKO THEN CALL ABORT('BKO¬=TKO');
DO I=1 TO MNR;B4=B4-XBUD(I)/10;END;PB4=PB4-XBUD(MNR)/10;
GOTO KTOIN;
KTOKLAR:CALL SUBA(TKO);
KTX=DUM;
RETURN;END;
OPEN KTOTX;OPEN DATFIL;OPEN SAMFIL;
READ FILE(DATFIL)INTO(DATREC);IF XDAG='XXXXXX' THEN GO TO SLUTT;
DAG=XDAG;XDAG='XXXXXX';
REWRITE FILE(DATFIL)FROM(DATREC);
PUT FILE(D) SKIP EDIT(' ')(A(37))('*** RESULTATRÄKNING ***')
(A(74))('STÄLL IN PERFORERINGEN')(A(37))('TRYCK SEDAN RETURN.')(A(37));
GET SKIP LIST(S);
TAB:PUT FILE(D)SKIP EDIT('VILKEN NIVÅ?')(A(37))
('1 - ENDAST KONTOKLASS')(A(37))('2 - PER KONTOGRUPP')(A(37))
('3 - PER KONTO (3-SIFFRIGT)')(A(37))
('4 - PER UNDERKONTO (4-SIFFRIGT)')(A(35));
GET SKIP LIST(NI);IF NI<1öNI>4 THEN GO TO TAB;
PUT FILE(D)SKIP EDIT(' ')(A(43))('*** UTSKRIFT PÅGÅR ***')(A(67));
DEL=0;RECNR=0;JUMP=0;RAD=5;SIDA=0;IND=1;SAMSLUT=0;KTOSLUT=0;
P1=0;P2=0;P3=0;P4=0;B1=0;B2=0;B3=0;B4=0;S1=0;S2=0;S3=0;S4=0;
PB1=0;PB2=0;PB3=0;PB4=0;B1=0;DIF1=0;DIF2=0;DIF3=0;DIF4=0;
K30P=0;K30S=0;K4P=0;K4S=0;TP=0;TS=0;TPB=0;TB=0;TDIF=0;
DO I=1 TO 6;PU(I)=0;BU(I)=0;SU(I)=0;PBU(I)=0;DIFU(I)=0;END;
/*START AV SJÄLVA PROGRAMMET!*/
START:
A000:UNSPEC(SAMFIL)=UNSPEC(SAMFIL)+10;
ON ENDFILE GOTO A00X;READ FILE(SAMFIL)INTO(SAM);
IF SKO<3000 THEN GO TO A000;
A00X:UNSPEC(SAMFIL)=UNSPEC(SAMFIL)-11;
IF UNSPEC(SAMFIL)<0 THEN UNSPEC(SAMFIL)=0;
A00:ON ENDFILE GO TO SAMUT2;READ FILE(SAMFIL)INTO(SAM);
IF SKO<3000 THEN GO TO A00;GOTO SAMOK2;
SAMUT2:SAMSLUT=1;
SAMOK2:
A0000:UNSPEC(KTOTX)=UNSPEC(KTOTX)+10;
ON ENDFILE GOTO A0X;READ FILE(KTOTX)INTO(KTX);
IF TKO<3000 THEN GOTO A0000;
A0X:UNSPEC(KTOTX)=UNSPEC(KTOTX)-11;
IF UNSPEC(KTOTX)<0 THEN UNSPEC(KTOTX)=0;
A0:ON ENDFILE GO TO KTOUT2;READ FILE(KTOTX)INTO(KTX);
IF TKO<3000 THEN GO TO A0;GOTO KTOOK2;
KTOUT2:KTOSLUT=1;
KTOOK2:RECNR=UNSPEC(KTOTX);
NY:
IF KTOSLUT=1 & SAMSLUT=1 THEN GO TO AVSLUTA;
IF TKOD¬='A' THEN CALL ABORT('TKOD EJ "A"');
IF(SAMSLUT=0 & SKO<TKO) ö (KTOSLUT=1)THEN DO;
PUT SKIP LIST('SAMSLUT:',SAMSLUT,' KTOSLUT:',KTOSLUT,
' SKO:',SKO,' TKO:',TKO);CALL ABORT('');END;
IF SAMSLUT=0 & KTOSLUT=0 & SKO=TKO THEN GO TO BOTH;
ONE:S4=-IB;
CALL PROCC;
GOTO NY;
BOTH:
CALL PROCB;
CALL PROCC;
GOTO NY;
AVSLUTA:SKO=9999;CALL SUBA(SKO);
SLUT:IF K30P¬=0öK30S¬=0 THEN DO;
TBP=K30P+K4P;TBS=K30S+K4S;
TGP=ABSS((TBP*100)/K30P)+.05;IF TBP*K30P<0 THEN TGP=-TGP;
TGS=ABSS((TBS*100)/K30S)+.05;IF TBS*K30S<0 THEN TGS=-TGS;
PUT SKIP EDIT(' FÖRS. TÄCKNINGSBIDRAG:')(A(44))
(-TBP)(PCC)(-TBS)(PCC)SKIP EDIT(' FÖRS. TÄCKNINGSGRAD:')(A(48))
(TGP)(PF,X(5))(TGS)(PF);
RAD=RAD-2;
END;
PUT SKIP(RAD-5);
SLUTT:CALL LOAD('BOKRUT',6);END;