|
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: 20066 (0x4e62)
Types: Q1_Text, reclen=79
Notes: q1file
Names: »AVDRES1«
└─⟦d4a65d31f⟧ Bits:30008722 DDMQ1-0163_MSAB_Bokf_pgm_i_PL1_781112_TD
└─⟦this⟧ »AVDRES1«
/*FÖRSTA RADEN*/
/*AVDRES RESULTATRÄKNING PER AVD. 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),
XAVD CHAR(3),XSAVD CHAR(3),AVDSIDA FIXED(4),SAMFIL FILE,NI FIXED(1),
DAG CHAR(6),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),
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),
AP FIXED(13,2),AS FIXED(13,2),APB FIXED(8,1),AB FIXED(8,1),ADIF FIXED(8,1),
TP FIXED(13,2),TS FIXED(13,2),TPB FIXED(8,1),TB FIXED(8,1),TDIF FIXED(8,1),
XSKO FIXED(4),TXT CHAR(34),RECNR BINARY,SAMSLUT BINARY,
BUDSLUT BINARY,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(RAVD);
DCL RAVD CHAR(3);
SIDA=SIDA+1;AVDSIDA=AVDSIDA+1;PUT SKIP(RAD)EDIT('RESULTATRÄKNING NIVÅ ')
(A)(NI)(A)(',SEPARAT PER AVD. *** AVDELNING:')(A)(RAVD)(A)
(' AVD.SIDA:')(A)(AVDSIDA)(A)(' ***')(A(14))
('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)+.005;PERC=-PERC;IF DIFF*TAL<0 THEN PERC=-PERC;
END;
IF TAL=0 THEN PERC=0;
RETURN;END;
AVDUT:PROC(UTAVD);
DCL UTAVD CHAR(3);
IF RAD<12 THEN CALL RUB(UTAVD);
CALL PROCENT(ADIF,AB);
PUT SKIP(2)EDIT('*** TOTALT AVD.')(A(15))(UTAVD)(A(29))(-AP)(PCC)
(-AS)(PCC,X(6))(-APB)(PEE)(-AB)(PEE)(-ADIF)(PEE)(-PERC)(PF);RAD=RAD-2;
AP=0;AS=0;APB=0;AB=0;ADIF=0;AVDSIDA=0;
DO I=1 TO 6;PU(I)=0;BU(I)=0;SU(I)=0;PBU(I)=0;DIFU(I)=0;END;
PUT SKIP(RAD-5);RAD=5;
RETURN;END;
NI1UT:PROC(JX,SUBSUBKO,SUBAVD);
DCL JX FIXED(4),SUBSUBKO FIXED(4),SUBAVD CHAR(3);
IF RAD<12 THEN CALL RUB(SUBAVD);
IND=0;
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;
AP=AP+P1;AS=AS+S1;APB=APB+PB1;AB=AB+B1;ADIF=ADIF+DIF1;
P1=0;S1=0;B1=0;PB1=0;DIF1=0;
RETURN;END;
SUBA:PROC(SUBKO,AVD);
DCL SUBKO FIXED(4),AVD CHAR(3);
IF P4=0&S4=0&B4=0&PB4=0&AVD¬='¬¬¬' THEN GO TO A1;
IF IND=1 THEN GO TO A6;
NI3UT:J=XKTO/10;K=SUBKO/10;L=XKTO/1000;
IF J=K & XAVD=AVD THEN GO TO A6;
IF RAD<12 THEN CALL RUB(XAVD);
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 ö XAVD¬=AVD THEN GO TO NI2UT;
GO TO A6;
NI2UT:IF RAD<14 THEN CALL RUB(XAVD);
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;
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);
BX=UT(4);DIFX=UT(5);CALL PROCENT(DIFX,BX);
PUT SKIP EDIT(TXT)(A(43))(-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
('RESULTAT FÖRE AVSKRIVNINGAR')(A(43))(-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('RESULTAT EFTER AVSKRIVNINGAR')(A(43))(-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('RESULTAT EFTER FIN. INT. & KOSTNADER')(A(43))(-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)öXAVD¬=AVD THEN CALL NI1UT(J,SUBKO,XAVD);
IF XAVD¬=AVD THEN CALL AVDUT(XAVD);
IF AVD='¬¬¬' THEN GOTO SLUT;
A6:IND=0;XAVD=AVD;IF RAD<12 THEN CALL RUB(AVD);
DIF4=ABSS((S4-1000*B4)/1000)+.05;IF S4-1000*B4<0 THEN DIF4=-DIF4;
IF B4=0&PB4=0 THEN DIF4=0;
J=SUBKO/10;
IF NI>3 THEN DO;
XTXT='*** FINNS EJ I KONTOPLANEN ***';KNR=SUBKO;ZZ='A';
ON ERROR GOTO X5;READ KEY(KSTRX)FILE(KTOTX)INTO(TX);
X5:CALL PROCENT(DIF4,B4);
PUT SKIP EDIT(SUBKO)(A(5))(XTXT)(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;
END;
PROCA:PROC; /*UPPREPAR ACKUMULERING AV SALDON OCH LÄSNING I SAMFIL
TILLS ETT RECORD MED ANNAT KONTO ELLER AVD HITTAS,ELLER FILEN TAR SLUT*/
S4=IB;
SAMIN:XSKO=SKO;XSAVD=SAVD;
DO I=1 TO MNR;S4=S4+SAD(I)-SAK(I);END;
P4=P4+SAD(MNR)-SAK(MNR);
SAMIN2:ON ENDFILE GOTO SAMUT;READ FILE(SAMFIL)INTO(SAM);
GOTO SAMOK;
SAMUT:SAMSLUT=1;
SAMOK:IF SAMSLUT=0 & SKO<3000 THEN GOTO SAMIN2;
IF SAMSLUT=0 & XSKO=SKO & XSAVD=SAVD THEN GOTO SAMIN;
CALL SUBA(XSKO,XSAVD);
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));
IB=0;RECNR=0;RAD=5;SIDA=0;AVDSIDA=0;IND=1;SAMSLUT=0;BUDSLUT=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;DIF1=0;DIF2=0;DIF3=0;DIF4=0;
AP=0;TP=0;AS=0;TS=0;APB=0;TPB=0;AB=0;TB=0;ADIF=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öSAVD=' ' 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öSAVD=' ' THEN GO TO A00;GOTO SAMOK2;
SAMUT2:SAMSLUT=1;
SAMOK2:
ON ERROR GOTO KTOUT2;READ KEY('B')FILE(KTOTX)INTO(KBU)KEYTO(BKOD);
IF BAVD¬=' ' THEN GOTO KTOOK2;
A0:ON ENDFILE GO TO KTOUT2;READ FILE(KTOTX)INTO(KBU);
IF BAVD=' ' THEN GO TO A0;GOTO KTOOK2;
KTOUT2:BUDSLUT=1;
KTOOK2:RECNR=UNSPEC(KTOTX);
NY:
IF BUDSLUT=1 & SAMSLUT=1 THEN GO TO AVSLUTA;
IF(SAMSLUT=0&((SAVD¬=BAVD)ö(SAVD=BAVD&SKO<BKO)))ö(BUDSLUT=1)THEN DO;
CALL PROCA; GOTO NY;END;
DO I=1 TO MNR;B4=B4+XBUD(I)/10;END;PB4=PB4+XBUD(MNR)/10;
IF SAMSLUT=0 & BUDSLUT=0 & SAVD=BAVD & SKO=BKO THEN GO TO BOTH;
ONE:
CALL SUBA(BKO,BAVD);
UNSPEC(KTOTX)=RECNR;RECNR=RECNR+1;
ON ENDFILE GOTO KTOUT3;READ FILE(KTOTX)INTO(KBU);
GOTO KTOOK3;
KTOUT3:BUDSLUT=1;
KTOOK3:
GOTO NY;
BOTH:
CALL PROCA;
UNSPEC(KTOTX)=RECNR;RECNR=RECNR+1;
ON ENDFILE GOTO KTOUT4;READ FILE(KTOTX)INTO(KBU);
GOTO KTOOK4;
KTOUT4:BUDSLUT=1;
KTOOK4:
GOTO NY;
AVSLUTA:SAVD='¬¬¬';CALL SUBA(XSKO,SAVD);
SLUT:PUT SKIP(RAD-5);
SLUTT:CALL LOAD('BOKRUT',6);END;