DataMuseum.dk

top - download

    Length: 8401 (0x20d1)
    Types: SPC/1-COMAL-80
    Notes: Mikados_B, UNKNOWN_TOKEN_cb, UNKNOWN_TOKEN_cc, UNKNOWN_TOKEN_cd
    Names: »SYSFB.B«

└─⟦86fa88d8d⟧ Bits:30005772 Bogføringssystemet 'SYS-KAMMS' v.1.0
    └─⟦this⟧ »SYSFB.B« 

SPC/1 COMAL-80

0100 // **************************************************
0110 // *                                                *
0120 // *          Bogføringssystemet 'SYS-KAS'          *
0130 // *                  vers. 1.0                     *
0140 // *                                                *
0150 // * Udviklet marts 1983 på en 'SPC/1' mikrodatamat *
0160 // * Programsystemet er skrevet i COMAL80 vers. 1.2 *
0170 // *                                                *
0180 // * Udviklet af : Peter Kristensen                 *
0190 // *               Vestervang 6, 6920 Videbæk       *
0200 // *                                                *
0210 // *   (C)       : forlaget systime a/s             *
0220 // *               Klokkebakken 20, Gjellerup       *
0230 // *               7400  Herning                    *
0240 // **************************************************
0250 EXEC DIMENSIONER
0260 EXEC INITIER
0270 EXEC FUNKTIONSMENU
0280 CHAIN PROGRAM$
0290 // ============= procedurer starter =============
0300 PROC DIMENSIONER
0310 // Standard variable
0320 DIM SPC$ OF 80,TAL$ OF 10,ALFA$ OF 28,SVAR$ OF 12,PRGFL$ OF 8
0330 DIM PROGRAM$ OF 17
0340 REAL RESRV,PPAR
0350 INTEGER OK,TRUE,FALSE,I,J,K
0360 // Hjælpevariable
0370 DIM HJ_ST$ OF 10,A_TXT$ OF 20,A_BNR$ OF 5,A_KTONR$ OF 8,NONBOOK$ OF 60
0380 DIM A_KTO_TYPE$ OF 1,A_KTO_NAVN$ OF 40
0390 REAL A_KTO_ULTIMO,NULR,TÆLLER(3),OVERSKUD
0400 INTEGER POS,HIGH,LOW,IDXPOS,DEBET,KREDIT,NUL,KOLNR,MAX_LIN
0410 INTEGER A_NTRANS,A_KTO_SP,LIN_T,TABNR(2),SIDENR
0420 // Variable til filen SYSPARA
0430 DIM SYSPARA$ OF 17
0440 DIM SYST_NAVN$ OF 30,S_KODE$ OF 1
0450 DIM DATAFL$ OF 8,T_KODE$ OF 1
0460 // Variable til filen @@PARAM
0470 DIM PARAM$ OF 17
0480 DIM FIRMANAVN$ OF 30,SYST_DAT$ OF 8
0490 REAL MOMS
0500 DIM ST_DATO$ OF 6
0510 INTEGER ANT_PER,PER_NR
0520 // Variable til filen @@TRANS
0530 DIM TRANS$ OF 17
0540 INTEGER T_HØJREC,T_MAXREC
0550 DIM BKTONR$ OF 8,BDATO$ OF 6,BLGNR$ OF 5,BTXT$ OF 20
0560 REAL BMOMS,BBELØB
0570 INTEGER NTRANS,DK
0580 // Variable til filen @@DRIFTØ
0590 DIM DRIFTØ$ OF 17
0600 DIM PRIMODAT$ OF 6
0610 REAL DRIFT(2)
0620 // Variable til filen @@KONTO
0630 DIM KONTO$ OF 17
0640 INTEGER N_FRIREC,N_MAXREC
0650 DIM KTO_TYPE$ OF 1,KTO_NAVN$ OF 40
0660 REAL KTO_PRIMO,KTO_ULTIMO
0670 INTEGER KTO_FP,KTO_SP
0680 // Variable til filen @@KTOIDX
0690 DIM KTOIDX$ OF 17
0700 INTEGER I_HØJREC,I_MAXREC
0710 DIM KTONR$ OF 8
0720 INTEGER RECNR
0730 // Variable til filen @@FKTONR
0740 DIM FKTONR$ OF 17
0750 DIM BAL_KTO$ OF 8,RES_KTO$ OF 8,BALANCE$ OF 8,PRIVATF$ OF 8,OVERSK$ OF 8
0760 DIM INDMOMS_KTO$ OF 8,UDMOMS_KTO$ OF 8
0770 // Variable til filen @@KTOGRP
0780 DIM KTOGRP$ OF 17
0790 DIM KREDGRP$ OF 8,DEBGRP$ OF 8
0800 ENDPROC DIMENSIONER
0810
0820 PROC INITIER
0830 LET PRGFL$ := "DP2"
0840 LET PROGRAM$ := PRGFL$ + ":SYSA"
0850 LET TAL$ := "0123456789"
0860 FOR I := ╱cc╱ ("A") TO ("Å") DO LET ALFA$ := ALFA$ + CHR$ (I)
0870 LET SPC$ := "                                        "
0880 LET SPC$ := SPC$ + SPC$
0890 LET FALSE := 0 ; TRUE := 1 // boolske variable
0900 LET DEBET := 1 ; KREDIT := - 1 ; NULR := 0
0910 LET SYSPARA$ := PRGFL$ + ":SYSPARA"
0920 EXEC OPENFIL(SYSPARA$,"R")
0930 GET SYSPARA$,1 : SYST_NAVN$,S_KODE$
0940 EXEC TERMINAL_IDX
0950 CLOSE SYSPARA$
0960 LET PARAM$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "PARAM"
0970 EXEC OPENFIL(PARAM$,"W")
0980 GET PARAM$,1 : FIRMANAVN$,SYST_DAT$,MOMS
0990 GET PARAM$,2 : ST_DATO$,ANT_PER,PER_NR
1000 LET KTOIDX$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "KTOIDX"
1010 LET KONTO$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "KONTO"
1020 LET TRANS$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "TRANS"
1030 LET DRIFTØ$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "DRIFTØ"
1040 LET FKTONR$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "FKTONR"
1050 LET KTOGRP$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "KTOGRP"
1060 EXEC OPENFIL(TRANS$,"W")
1070 EXEC OPENFIL(KTOIDX$,"W")
1080 EXEC OPENFIL(KONTO$,"W")
1090 EXEC OPENFIL(FKTONR$,"R")
1100 GET FKTONR$,7 : RES_KTO$
1110 GET FKTONR$,8 : BAL_KTO$
1120 CLOSE FKTONR$
1130 EXEC OPENFIL(KTOGRP$,"R")
1140 GET KTOGRP$,12 : DEBGRP$
1150 GET KTOGRP$,17 : KREDGRP$
1160 CLOSE KTOGRP$
1170 ENDPROC INITIER
1180
1190 //
1200 PROC TERMINAL_IDX
1210 LET PPAR := 5 ; RESRV := 0
1220 CALL 7"DDE:PRES"
1230 GET SYSPARA$,1 + RESRV : DATAFL$,T_KODE$
1240 ENDPROC TERMINAL_IDX
1250
1260 PROC OPENFIL(FNAVN$,WAY$)
1270 REPEAT
1280 IF AY$ = "W" OR WAY$ = "w" THEN
1290 OPEN FNAVN$,W
1300 ELSE
1310 OPEN FNAVN$,R
1320 ENDIF
1330 IF (FNAVN$) THEN
1340 PRINT "<S>" ; CHR$ (7)
1350 IF (FNAVN$) = 6 THEN
1360 PRINT "<SC1602>*** Fejl nr. 6 - indsæt diskette og tryk <RETURN> ***"
1370 INPUT "" : SVAR$
1380 ELSE
1390 PRINT "<SC1802>*** Fejl nr. " ; CHR$ ( ╱cd╱ (FNAVN$),2) ; " ved åbning af "
1400 PRINT "<S>" ; FNAVN$ ; " ***"
1410 INPUT "" : SVAR$
1420 PRINT "<C0102>" ; SPC$
1430 ENDIF
1440 ENDIF
1450 UNTIL NOT ╱cd╱ (FNAVN$)
1460 ENDPROC OPENFIL
1470
1480 PROC OVERSKRIFT(ST$,L)
1490 PRINT "<XC0101>Firmanavn: " ; FIRMANAVN$
1500 PRINT "<SC6501>Dato: " ; SYST_DAT$(1 : 2) ; "." ; SYST_DAT$(3 : 2) ; "."
1510 PRINT SYST_DAT$(5 : 2)
1520 CURSOR 34 - INT( ╱cb╱ (ST$) / 2),L
1530 PRINT "*** " ; ST$ ; " ***"
1540 ENDPROC OVERSKRIFT
1550
1560 PROC SL_FEJLLINIE
1570 LET OK := TRUE
1580 PRINT "<C0102>" ; SPC$
1590 ENDPROC SL_FEJLLINIE
1600
1610 PROC FEJL(ST$)
1620 LET OK := FALSE
1630 CURSOR 36 - ( ╱cb╱ (ST$) / 2),2
1640 PRINT "<S>*** " + ST$ + " ***" ; CHR$ (7)
1650 ENDPROC FEJL
1660
1670 PROC SKRIV_KONTOOPL
1680 IF OPRET THEN EXEC FIND_IDXPLADS
1690 LET KTO_TYPE$ := A_KTO_TYPE$
1700 EXEC SKRIV_KONTO(RECNR)
1710 ENDPROC SKRIV_KONTOOPL
1720
1730 PROC LÆS_KONTO(P)
1740 GET KONTO$,P : KTO_TYPE$,KTO_NAVN$,KTO_PRIMO,KTO_ULTIMO,KTO_FP,KTO_SP
1750 ENDPROC LÆS_KONTO
1760
1770 PROC SKRIV_KONTO(P)
1780 PUT KONTO$,P : KTO_TYPE$,KTO_NAVN$,KTO_PRIMO,KTO_ULTIMO,KTO_FP,KTO_SP
1790 ENDPROC SKRIV_KONTO
1800
1810 PROC ST_BGST( REF RST$)
1820 FOR J := 1 TO (RST$) DO
1830 IF "a" =< RST$(J) AND RST$(J) =< "å" THEN LET RST$(J) := CHR$ ( ╱cc╱ (RST$(J)) - 32)
1840 NEXT J
1850 ENDPROC ST_BGST
1860
1870 PROC TAL_CONTROL( REF RST$)
1880 LET J := 0 ; OK := TRUE ; K := 0
1890 FOR I := 1 TO (RST$) DO
1900 IF RST$(I) IN "0123456789" THEN LET J := J + 1 ; RST$(J) := RST$(I)
1910 IF RST$(I) = "." AND K = 0 THEN LET J := J + 1 ; K := K + 1 ; RST$(J) := RST$(I)
1920 NEXT I
1930 IF = 0 THEN
1940 LET OK := FALSE
1950 ELSE
1960 LET RST$ := RST$(1 : J)
1970 ENDIF
1980 ENDPROC TAL_CONTROL
1990
2000 PROC FIND_KTO( REF R_KTONR$)
2010 LET OK := FALSE
2020 GET KTOIDX$,1 : I_HØJREC,I_MAXREC
2030 LET LOW := 1 ; HIGH := I_HØJREC ; POS := 2
2040 IF IGH > 1 THEN
2050 REPEAT
2060 LET POS := INT((HIGH - LOW) / 2 + .5) + LOW
2070 GET KTOIDX$,POS : KTONR$,RECNR
2080 IF TONR$ > R_KTONR$ THEN
2090 LET HIGH := POS
2100 ELSE
2110 IF TONR$ < R_KTONR$ THEN
2120 LET LOW := POS
2130 ENDIF
2140 ENDIF
2150 UNTIL HIGH - LOW =< 1 OR R_KTONR$ = KTONR$
2160 LET POS := INT((HIGH - LOW) / 2 + .5) + LOW
2170 GET KTOIDX$,POS : KTONR$,RECNR
2180 IF KTONR$ = R_KTONR$ THEN LET OK := TRUE
2190 ENDIF
2200 LET FIND_KTO := POS
2210 ENDPROC FIND_KTO
2220
2230 PROC FUNKTIONSMENU
2240 IF ER_NR = 0 THEN
2250 EXEC OVERSKRIFT("Fremføring af balancetal i ny regning",6)
2260 PRINT "<C1809>Har du fået udskrevet kontokort "
2270 PRINT "<C1810>Er datoen = den første dato i det nye regnskabsår "
2280 PRINT "<C1811>Er der foretaget sikkerhedskopiering"
2290 EDIT "<C3414>(j/n)? " : SVAR$(1)
2300 IF VAR$ IN "JAja" AND SVAR$ >< "" THEN
2310 EXEC TILBAGEFØR
2320 EXEC FREMFØR
2330 ENDIF
2340 ELSE
2350 PRINT "<XSC0712>Ulovlig fremføring af balancetal - regnskabsåret ikke "
2360 PRINT "afsluttet"
2370 INPUT "<SC6523>Tryk RETURN" : SVAR$
2380 ENDIF
2390 CHAIN PROGRAM$
2400 ENDPROC FUNKTIONSMENU
2410
2420 PROC BOGFØR( REF Q_KTO$, REF Q_DAT$, REF Q_TXT$, REF Q_M, REF Q_KR,Q_DK,QN$)
2430 EXEC FIND_KTO(Q_KTO$)
2440 IF OK THEN
2450 EXEC FEJL("UKENDT KONTONR: " + Q_KTO$)
2460 EXIT
2470 ELSE
2480 EXEC LÆS_KONTO(RECNR)
2490 IF TO_TYPE$ >< "A" THEN
2500 EXEC FEJL("ULOVLIG KONTONR: " + Q_KTO$)
2510 EXIT
2520 ENDIF
2530 ENDIF
2540 GET TRANS$,1 : T_HØJREC,T_MAXREC
2550 IF _HØJREC = T_MAXREC THEN
2560 EXEC FEJL("TRANSAKTIONSFILEN ER FULD")
2570 EXIT
2580 ENDIF
2590 LET T_HØJREC := T_HØJREC + 1
2600 IF TO_FP > 0 THEN
2610 EXEC LÆS_TRANS(KTO_SP)
2620 LET NTRANS := T_HØJREC
2630 EXEC SKRIV_TRANS(KTO_SP)
2640 ELSE
2650 LET KTO_FP := T_HØJREC
2660 ENDIF
2670 LET BKTONR$ := Q_KTO$ ; BDATO$ := Q_DAT$ ; BTXT$ := Q_TXT$ ; BMOMS := Q_M ; BBELØB := Q_KR
2680 LET DK := Q_DK ; NTRANS := NUL ; BLGNR$ := QN$
2690 EXEC SKRIV_TRANS(T_HØJREC)
2700 LET KTO_SP := T_HØJREC
2710 IF K = DEBET THEN
2720 LET KTO_ULTIMO := KTO_ULTIMO + BBELØB
2730 ELSE
2740 LET KTO_ULTIMO := KTO_ULTIMO - BBELØB
2750 ENDIF
2760 EXEC SKRIV_KONTO(RECNR)
2770 PUT TRANS$,1 : T_HØJREC,T_MAXREC
2780 ENDPROC BOGFØR
2790
2800 PROC SKRIV_TRANS(P)
2810 PUT TRANS$,P : BKTONR$,BDATO$,BLGNR$,BTXT$,BMOMS,BBELØB,DK,NTRANS
2820 ENDPROC SKRIV_TRANS
2830
2840 PROC LÆS_TRANS(P)
2850 GET TRANS$,P : BKTONR$,BDATO$,BLGNR$,BTXT$,BMOMS,BBELØB,DK,NTRANS
2860 ENDPROC LÆS_TRANS
2870
2880 PROC TILBAGEFØR
2890 EXEC FIND_KTO(BAL_KTO$)
2900 EXEC LÆS_KONTO(RECNR)
2910 LET A_NTRANS := KTO_FP ; A_KTO_SP := KTO_SP
2920 REPEAT
2930 EXEC LÆS_TRANS(A_NTRANS)
2940 LET A_NTRANS := NTRANS
2950 LET A_KTONR$ := BTXT$(11 : 8) ; A_TXT$ := "OVERFØRT TIL " + A_KTONR$
2960 LET A_DK := DK * ( - 1) ; A_BNR$ := "  " ; A_KTO_ULTIMO := BBELØB
2970 EXEC BOGFØR(BAL_KTO$,SYST_DAT$,A_TXT$,NULR,A_KTO_ULTIMO,A_DK,A_BNR$)
2980 LET A_TXT$ := "OVERFØRT FRA " + BAL_KTO$ ; A_DK := A_DK * ( - 1)
2990 EXEC BOGFØR(A_KTONR$,SYST_DAT$,A_TXT$,NULR,A_KTO_ULTIMO,A_DK,A_BNR$)
3000 PRINT "<SC3613>" ; A_KTONR$ ; SPC$(1 : 10)
3010 UNTIL A_NTRANS > A_KTO_SP
3020 LET PER_NR := PER_NR + 1 ; ST_DATO$ := SYST_DAT$
3030 PUT PARAM$,2 : ST_DATO$,ANT_PER,PER_NR
3040 PUT DRIFTØ$,1 : SYST_DAT$
3050 ENDPROC TILBAGEFØR
3060 PROC FREMFØR
3070 GET KTOIDX$,1 : I_HØJREC,I_MAXREC
3080 FOR I := 2 TO _HØJREC DO
3090 GET KTOIDX$,I : KTONR$,RECNR
3100 EXEC LÆS_KONTO(RECNR)
3110 PRINT "<C3613>" ; KTONR$ ; SPC$(1 : 10)
3120 LET KTO_PRIMO := KTO_ULTIMO ; KTO_FP := 0 ; KTO_SP := 0
3130 EXEC SKRIV_KONTO(RECNR)
3140 NEXT I
3150 GET TRANS$,1 : T_HØJREC,T_MAXREC
3160 LET T_HØJREC := 1
3170 PUT TRANS$,1 : T_HØJREC,T_MAXREC
3180 LET PER_NR := PER_NR + 1 ; ST_DATO$ := SYST_DAT$
3190 ENDPROC FREMFØR