|
DataMuseum.dkPresents historical artifacts from the history of: MIKADOS |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about MIKADOS Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 17540 (0x4484)
Types: SPC/1-COMAL-80
Notes: Mikados_B, UNKNOWN_TOKEN_ca, UNKNOWN_TOKEN_cb, UNKNOWN_TOKEN_cc, UNKNOWN_TOKEN_cd
Names: »SYSUKY.B«
└─⟦86fa88d8d⟧ Bits:30005772 Bogføringssystemet 'SYS-KAMMS' v.1.0
└─⟦this⟧ »SYSUKY.B«
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 FKT_MENU
0280 CHAIN PROGRAM$
0290 // =========== Procedurer starter ==============
0300 PROC DIMENSIONER
0310 // Standard variable
0320 DIM SPC$ OF 80,SVAR$ OF 10,PRGFL$ OF 8,ALFA$ OF 28,TAL$ OF 10
0330 DIM PROGRAM$ OF 17,PRTNR$ OF 1
0340 REAL RESRV,PPAR
0350 INTEGER OK,TRUE,FALSE,I,J
0360 // Hjælpevariable
0370 DIM A_KTONR$ OF 8,OUT_WAY$ OF 1
0380 REAL TOT(2)
0390 INTEGER IDXPOS,HIGH,LOW,KREDIT,DEBET,LIN_T,MAX_LIN,T_IDX,K,NUL,F_IDX
0400 INTEGER SIDENR
0410 // Variable til filen SYSPARA
0420 DIM SYSPARA$ OF 17
0430 DIM SYST_NAVN$ OF 30,S_KODE$ OF 1
0440 DIM DATAFL$ OF 8,T_KODE$ OF 1
0450 // Variable til filen @@PARAM
0460 DIM PARAM$ OF 17
0470 DIM FIRMANAVN$ OF 30,SYST_DAT$ OF 6
0480 REAL MOMS
0490 DIM ST_DATO$ OF 6
0500 INTEGER ANT_PER,PER_NR
0510 // Variable til filen @@KONTO
0520 DIM KONTO$ OF 17
0530 INTEGER N_FRIREC,N_MAXREC
0540 DIM KTO_TYPE$ OF 1,KTO_NAVN$ OF 40
0550 REAL KTO_PRIMO,KTO_ULTIMO
0560 INTEGER KTO_FP,KTO_SP
0570 // Variable til filen @@KTOIDX
0580 DIM KTOIDX$ OF 17
0590 INTEGER I_HØJREC,I_MAXREC
0600 DIM KTONR$ OF 8
0610 INTEGER RECNR
0620 // Variable til filen @@ST_KTO
0630 DIM ST_KTO$ OF 17
0640 DIM KASSE_KTO$ OF 8,BANK_KTO$ OF 8,GIRO_KTO$ OF 8
0650 DIM K_DIFF_KTO$ OF 8,INDMOMS_KTO$ OF 8,UDMOMS_KTO$ OF 8
0660 // Variable til filen @@TRANS
0670 DIM TRANS$ OF 17
0680 INTEGER T_HØJREC,T_MAXREC
0690 DIM BKTONR$ OF 8,BDATO$ OF 6,BLGNR$ OF 5,BTXT$ OF 20
0700 REAL BMOMS,BBELØB
0710 INTEGER DK,NTRANS
0720 ENDPROC DIMENSIONER
0730
0740 PROC INITIER
0750 LET PRGFL$ := "DP2"
0760 LET PROGRAM$ := PRGFL$ + ":SYSU"
0770 LET TAL$ := "0123456789" ; NULR := 0
0780 FOR I := ╱cc╱ ("A") TO ("Å") DO LET ALFA$ := ALFA$ + CHR$ (I)
0790 LET SPC$ := " "
0800 LET SPC$ := SPC$ + SPC$
0810 LET FALSE := 0 ; TRUE := 1 // boolske variable
0820 LET KREDIT := - 1 ; DEBET := 1
0830 LET SYSPARA$ := PRGFL$ + ":SYSPARA"
0840 EXEC OPENFIL(SYSPARA$,"R")
0850 GET SYSPARA$,1 : SYST_NAVN$,S_KODE$
0860 EXEC TERMINAL_IDX
0870 CLOSE SYSPARA$
0880 LET PARAM$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "PARAM"
0890 EXEC OPENFIL(PARAM$,"R")
0900 GET PARAM$,1 : FIRMANAVN$,SYST_DAT$,MOMS
0910 GET PARAM$,2 : ST_DATO$,ANT_PER,PER_NR
0920 CLOSE PARAM$
0930 LET KTOIDX$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "KTOIDX"
0940 LET KONTO$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "KONTO"
0950 LET ST_KTO$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "ST_KTO"
0960 LET TRANS$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "TRANS"
0970 EXEC OPENFIL(KTOIDX$,"R")
0980 EXEC OPENFIL(KONTO$,"R")
0990 EXEC OPENFIL(TRANS$,"R")
1000 ENDPROC INITIER
1010
1020 PROC TERMINAL_IDX
1030 LET PPAR := 5 ; RESRV := 0
1040 CALL :PRES"
1050 GET SYSPARA$,1 + RESRV : DATAFL$,T_KODE$
1060 ENDPROC TERMINAL_IDX
1070
1080 PROC OPENFIL(FNAVN$,WAY$)
1090 REPEAT
1100 IF AY$ = "W" OR WAY$ = "w" THEN
1110 OPEN FNAVN$,W
1120 ELSE
1130 OPEN FNAVN$,R
1140 ENDIF
1150 IF (FNAVN$) THEN
1160 PRINT "<SC0123>" ; CHR$ (7)
1170 IF (FNAVN$) = 6 THEN
1180 PRINT "<SC1602>*** Fejl nr. 6 - indsæt diskette og tryk RETURN ***"
1190 INPUT "" : SVAR$
1200 ELSE
1210 PRINT "<SC1802>*** Fejl nr. " ; CHR$ ( ╱cd╱ (FNAVN$),2) ; " ved åbning af "
1220 PRINT "<S>" ; FNAVN$ ; " ***"
1230 INPUT "" : SVAR$
1240 PRINT "<C0102>" ; SPC$
1250 ENDIF
1260 ENDIF
1270 UNTIL NOT ╱cd╱ (FNAVN$)
1280 ENDPROC OPENFIL
1290
1300 PROC TAL_CONTROL( REF RST$)
1310 LET J := 0 ; OK := TRUE
1320 FOR I := 1 TO (RST$) DO
1330 IF RST$(I) IN TAL$ + "." THEN LET J := J + 1 ; RST$(J) := RST$(I)
1340 NEXT I
1350 IF = 0 THEN
1360 LET OK := FALSE
1370 ELSE
1380 LET RST$ := RST$(1 : J)
1390 ENDIF
1400 ENDPROC TAL_CONTROL
1410
1420 PROC OVERSKRIFT(ST$,L)
1430 PRINT "<XC0101>Firmanavn: " ; FIRMANAVN$
1440 PRINT "<SC6501>Dato: " ; SYST_DAT$(1 : 2) ; "." ; SYST_DAT$(3 : 2) ; "."
1450 PRINT SYST_DAT$(5 : 2)
1460 CURSOR 34 - ╱cb╱ (ST$) DIV 2,L
1470 PRINT "*** " ; ST$ ; " ***"
1480 ENDPROC OVERSKRIFT
1490
1500 PROC SL_FEJLLINIE
1510 LET OK := TRUE
1520 PRINT "<C0102>" ; SPC$
1530 ENDPROC SL_FEJLLINIE
1540
1550 PROC FEJL(ST$)
1560 LET OK := FALSE
1570 CURSOR 36 - ╱cb╱ (ST$) / 2,2
1580 PRINT "*** " + ST$ + " ***" ; CHR$ (7)
1590 ENDPROC FEJL
1600
1610 PROC LÆS_KONTO(P)
1620 GET KONTO$,P : KTO_TYPE$,KTO_NAVN$,KTO_PRIMO,KTO_ULTIMO,KTO_FP,KTO_SP
1630 ENDPROC LÆS_KONTO
1640
1650 PROC SKRIV_KONTO(P)
1660 PUT KONTO$,P : KTO_TYPE$,KTO_NAVN$,KTO_PRIMO,KTO_ULTIMO,KTO_FP,KTO_SP
1670 ENDPROC SKRIV_KONTO
1680
1690 PROC LÆS_TRANS(P)
1700 GET TRANS$,P : BKTONR$,BDATO$,BLGNR$,BTXT$,BMOMS,BBELØB,DK,NTRANS
1710 ENDPROC LÆS_TRANS
1720
1730 PROC ST_BGST( REF RST$)
1740 FOR I := 1 TO (RST$) DO
1750 IF RST$(I) =< "å" AND RST$(I) >= "a" THEN LET RST$(I) := CHR$ ( ╱cc╱ (RST$(I)) - 32)
1760 NEXT I
1770 ENDPROC ST_BGST
1780 PROC FKT_MENU
1790 REPEAT
1800 EXEC OVERSKRIFT("Udskrivning af kontokort",6)
1810 LET A_KTONR$ := ""
1820 REPEAT
1830 EDIT "<C2810>Fra kontonr: " : A_KTONR$
1840 EXEC SL_FEJLLINIE
1850 LET F_IDX := FIND_KTO(A_KTONR$)
1860 IF NOT OK THEN EXEC FEJL("Kontonr findes ikke")
1870 UNTIL OK
1880 LET A_KTONR$ := ""
1890 REPEAT
1900 EDIT "<C2812>Til kontonr: " : A_KTONR$
1910 EXEC SL_FEJLLINIE
1920 LET T_IDX := FIND_KTO(A_KTONR$)
1930 IF OK THEN
1940 EXEC FEJL("Kontonr findes ikke")
1950 ELSE
1960 IF T_IDX < F_IDX THEN EXEC FEJL("Fra kontonr > Til kontonr")
1970 ENDIF
1980 UNTIL OK
1990 LET OUT_WAY$ := "P"
2000 REPEAT
2010 EDIT "<SC1814>Udskrift på (P)rinter eller (S)kærm? " : OUT_WAY$
2020 EXEC SL_FEJLLINIE
2030 EXEC ST_BGST(OUT_WAY$)
2040 IF "/" + OUT_WAY$ + "/" IN "/S/P/" THEN
2050 EXEC FEJL("Ukendt svar: '" + OUT_WAY$ + "'")
2060 ENDIF
2070 UNTIL OK
2090 EXEC UDSKRIV
2100 CLEAR
2110 LET SVAR$ := "n"
2120 EDIT "<C2012>Udskrivning af flere kontokort (j/n)? " : SVAR$(1)
2130 UNTIL NOT "/" + SVAR$ + "/" IN "/J/j/"
2140 ENDPROC FKT_MENU
2150
2160 PROC UDSKRIV
2170 IF UT_WAY$ = "P" THEN
2170 EXEC PRINTRES("smal EDB-liste",16)
2190 LET MAX_LIN := 36
2200 ELSE
2210 LET MAX_LIN := 24
2220 ENDIF
2230 FOR IDXPOS := F_IDX TO _IDX DO
2240 LET SIDENR := 0 ; TOT(1),TOT(2) := 0 ; LIN_T := 40
2250 GET KTOIDX$,IDXPOS : KTONR$,RECNR
2260 EXEC LÆS_KONTO(RECNR)
2270 IF TO_TYPE$ = "A" THEN
2270 LET BLGNR$ := " " ; BTXT$ := "GAMMEL SALDO"
2280 LET BMOMS := 0 ; DK := SGN(KTO_PRIMO)
2300 LET KTO_PRIMO := ABS(KTO_PRIMO)
2310 EXEC SKRIV_LIN(ST_DATO$,BLGNR$,BTXT$,BMOMS,KTO_PRIMO,DK)
2320 IF TO_FP > 0 THEN
2330 LET NTRANS := KTO_FP
2340 REPEAT
2350 EXEC LÆS_TRANS(NTRANS)
2410 EXEC SKRIV_LIN(BDATO$,BLGNR$,BTXT$,BMOMS,BBELØB,DK)
2420 UNTIL NTRANS = 0
2430 ENDIF
2440 EXEC AFSLUT
2450 ENDIF
2460 NEXT IDXPOS
2470 IF UT_WAY$ = "P" THEN
2480 EXEC PRINTREL
2490 ELSE
2500 INPUT "<SC5023>Næste side - tryk RETURN" : SVAR$(1)
2510 ENDIF
2520 ENDPROC UDSKRIV
2530
2480 PROC SIDESKIFT
2490 IF OT(1) > 0 OR TOT(2) > 0 THEN
2500 PRINT "<S>---------------------------------------"
2510 PRINT "---------------------------------------"
2520 PRINT TAB(18) ; "TRANSPORT" ; TAB(54) ; CHR$ (TOT(1),9,2) ; TAB(67) ;
2530 PRINT CHR$ (TOT(2),9,2)
2540 LET LIN_T := LIN_T + 2
2550 EXEC NYSIDE
2560 PRINT TAB(18) ; "TRANSPORT" ; TAB(54) ; CHR$ (TOT(1),9,2) ; TAB(67) ;
2570 PRINT CHR$ (TOT(2),9,2)
2580 LET LIN_T := LIN_T + 1
2590 ELSE
2600 EXEC NYSIDE
2610 ENDIF
2620 ENDPROC SIDESKIFT
2630 PROC NYSIDE
2640 IF UT_WAY$ = "P" THEN
2650 FOR I := LIN_T TO AX_LIN DO PRINT
2660 ELSE
2670 INPUT "<SC5523>Næste side - tryk RETURN" : SVAR$
2680 CLEAR
2690 ENDIF
2700 LET LIN_T := 9 ; SIDENR := SIDENR + 1
2710 PRINT "*** " ; SYST_NAVN$ ; " ***" ; TAB(41) ;
2720 PRINT "*** UDSKREVET PR. " ; SYST_DAT$(1 : 2) ; "." ; SYST_DAT$(3 : 2) ; "." ;
2730 PRINT SYST_DAT$(5 : 2) ; " *** SIDE: " ; SIDENR
2740 PRINT
2750 PRINT "Firmanavn: " ; FIRMANAVN$ ; TAB(54) ; "** KONTOKORT **"
2760 PRINT
2770 PRINT "** KONTONR: " ; KTONR$ ; TAB(25) ; "KONTONAVN: " ; KTO_NAVN$ ; TAB(77) ; "**"
2780 PRINT "<S>---------------------------------------"
2790 PRINT "---------------------------------------"
2800 PRINT "<S> DATO BILAG TEKST" ; TAB(47) ; "MOMSBELØB DEBETBELØB"
2810 PRINT " KREDITBELØB"
2820 PRINT "<S>---------------------------------------"
2830 PRINT "---------------------------------------"
2840 ENDPROC NYSIDE
2850
2860 PROC SKRIV_LIN(Q_D$,Q_B$,Q_T$,Q_M,Q_K,Q_DK)
2870 IF LIN_T + 6 > MAX_LIN THEN EXEC SIDESKIFT
2880 LET LIN_T := LIN_T + 1
2890 PRINT Q_D$(1 : 2) ; "." ; Q_D$(3 : 2) ; "." ; Q_D$(5 : 2) ; TAB(11) ;
2900 PRINT Q_B$ ; TAB(11) ; Q_B$ ; TAB(18) ; Q_T$ ; TAB(41) ;
2910 IF Q_M > 0 THEN PRINT CHR$ (Q_M,9,2) ;
2920 IF _DK = DEBET THEN
2930 PRINT TAB(54) ; CHR$ (Q_K,9,2) ;
2940 LET TOT(1) := TOT(1) + Q_K
2950 ELSE
2960 PRINT TAB(67) ; CHR$ (Q_K,9,2) ;
2970 LET TOT(2) := TOT(2) + Q_K
2980 ENDIF
2990 PRINT
3000 ENDPROC SKRIV_LIN
3010
3020 PROC AFSLUT
3030 FOR I := LIN_T TO AX_LIN - 6 DO PRINT
3040 LET LIN_T := MAX_LIN - 5
3050 PRINT "<S>---------------------------------------"
3060 PRINT "---------------------------------------"
3070 PRINT TAB(54) ; CHR$ (TOT(1),9,2) ; TAB(67) ; CHR$ (TOT(2),9,2)
3080 PRINT TAB(18) ; "NY SALDO " ;
3090 IF OT(1) - TOT(2) > 0 THEN
3100 PRINT TAB(67) ; CHR$ (TOT(1) - TOT(2),9,2)
3110 LET TOT(2) := TOT(1)
3120 ELSE
3130 PRINT TAB(54) ; CHR$ (TOT(2) - TOT(1),9,2)
3140 LET TOT(1) := TOT(2)
3150 ENDIF
3160 PRINT TAB(18) ; "BALANCE" ; TAB(54) ; CHR$ (TOT(1),9,2) ; " " ; CHR$ (TOT(1),9,2)
3170 IF UT_WAY$ = "P" THEN
3180 PRINT
3190 PRINT
3200 ENDIF
3210 ENDPROC AFSLUT
3220 PROC FIND_KTO( REF R_KTONR$)
3230 LET OK := FALSE
3240 GET KTOIDX$,1 : I_HØJREC,I_MAXREC
3250 LET LOW := 1 ; HIGH := I_HØJREC ; POS := 2
3260 IF IGH > 1 THEN
3270 REPEAT
3280 LET POS := INT((HIGH - LOW) / 2 + .5) + LOW
3290 GET KTOIDX$,POS : KTONR$,RECNR
3300 IF TONR$ > R_KTONR$ THEN
3270 LET HIGH := POS
3280 ELSE
3290 IF TONR$ < R_KTONR$ THEN
3300 LET LOW := POS
3310 ENDIF
3320 ENDIF
3330 UNTIL HIGH - LOW =< 1 OR R_KTONR$ = KTONR$
3340 LET POS := INT((HIGH - LOW) / 2 + .5) + LOW
3350 GET KTOIDX$,POS : KTONR$,RECNR
3360 IF KTONR$ = R_KTONR$ THEN LET OK := TRUE
3370 ENDIF
3380 LET FIND_KTO := POS
3390 ENDPROC FIND_KTO
3400 //
3410 PROC PRINTRES(PAGETYPE$,LINE) // PRINTER RESERVATION
3420 LET PRTNR$ := "1" ; OK := TRUE
3430 REPEAT
3440 CURSOR 15,LINE
3450 EDIT "<Z>Udskrivning på printer nr. ? (1/2/3/4) " : PRTNR$
3460 UNTIL "/" + PRTNR$ + "/" IN "/1/2/3/4/"
3490 CURSOR (39 - ╱cb╱ (PAGETYPE$)) DIV 2,LINE
3500 PRINT "<SZ> Monter " ; PAGETYPE$ ; " i printeren - tryk RETURN "
3510 INPUT "" : SVAR$
3520 SELECT OUTPUT "P" + PRTNR$
3530 IF ("P") THEN
3540 CURSOR 12,LINE
3550 PRINT "<SZ>Printeren er reserveret af en anden bruger,"
3560 CURSOR 12,LINE + 1
3570 INPUT "<SZ>Skal der ventes på at den bliver ledig ? (j/n) " : SVAR$
3580 IF VAR$ = "J" OR SVAR$ = "j" THEN
3590 CURSOR 12,LINE
3600 PRINT "<Z> Der ventes på at printeren bliver ledig...."
3610 PRINT "<SZ>"
3620 WHILE ╱cd╱ ("P") DO
3630 LET SEK := ╱ca╱ (5)
3640 SELECT OUTPUT "P" + PRTNR$
3650 ENDWHILE
3660 ELSE
3670 LET OK := FALSE
3680 ENDIF
3690 ENDIF
3700 CURSOR 1,LINE
3710 PRINT "<Z>"
3720 PRINT "<SZ>"
3730 ENDPROC PRINTRES
3740 //
3750 PROC PRINTREL // RELEASE PRINTER
3760 SELECT OUTPUT "T"
3770 ENDPROC PRINTREL