DataMuseum.dk

top - download

    Length: 8563 (0x2173)
    Types: SPC/1-COMAL-80
    Notes: Mikados_B, UNKNOWN_TOKEN_cb, UNKNOWN_TOKEN_cc, UNKNOWN_TOKEN_cd
    Names: »SYSK.B«

└─⟦86fa88d8d⟧ Bits:30005772 Bogføringssystemet 'SYS-KAMMS' v.1.0
    └─⟦this⟧ »SYSK.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 // ============= procedurer starter =============
0290 PROC DIMENSIONER
0300 // Standard variable
0310 DIM SPC$ OF 80,TAL$ OF 10,ALFA$ OF 28,SVAR$ OF 8,PRGFL$ OF 8
0320 DIM PROGRAM$ OF 17
0330 REAL RESRV,PPAR
0340 INTEGER OK,TRUE,FALSE,I,J
0350 // Hjælpevariable
0360 DIM A_KTO_NAVN$ OF 40,A_KTO_TYPE$ OF 1,A_KTONR$ OF 8,HJ_ST$ OF 10
0370 INTEGER POS,HIGH,LOW,OPRET,IDXPOS
0380 // Variable til filen SYSPARA
0390 DIM SYSPARA$ OF 17
0400 DIM SYST_NAVN$ OF 30,S_KODE$ OF 1
0410 DIM DATAFL$ OF 8,T_KODE$ OF 1
0420 // Variable til filen @@PARAM
0430 DIM PARAM$ OF 17
0440 DIM FIRMANAVN$ OF 30,SYST_DAT$ OF 8
0450 REAL MOMS
0460 // Variable til filen @@KONTO
0470 DIM KONTO$ OF 17
0480 DIM ST_DATO$ OF 6
0490 INTEGER N_FRIREC,N_MAXREC,ANT_PER,PER_NR
0500 DIM KTO_TYPE$ OF 1,KTO_NAVN$ OF 40
0510 REAL KTO_PRIMO,KTO_ULTIMO
0520 INTEGER KTO_FP,KTO_SP
0530 // Variable til filen @@KTOIDX
0540 DIM KTOIDX$ OF 17
0550 INTEGER I_HØJREC,I_MAXREC
0560 DIM KTONR$ OF 8
0570 INTEGER RECNR
0580 ENDPROC DIMENSIONER
0590
0600 PROC INITIER
0610 LET PRGFL$ := "DP2"
0620 LET PROGRAM$ := PRGFL$ + ":SYS"
0630 LET TAL$ := "0123456789"
0640 FOR I := ╱cc╱ ("A") TO ("Å") DO LET ALFA$ := ALFA$ + CHR$ (I)
0650 LET SPC$ := "                                        "
0660 LET SPC$ := SPC$ + SPC$
0670 LET FALSE := 0 ; TRUE := 1 // boolske variable
0680 LET SYSPARA$ := PRGFL$ + ":SYSPARA"
0690 EXEC OPENFIL(SYSPARA$,"R")
0700 GET SYSPARA$,1 : SYST_NAVN$,S_KODE$
0710 EXEC TERMINAL_IDX
0720 CLOSE SYSPARA$
0730 LET PARAM$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "PARAM"
0740 EXEC OPENFIL(PARAM$,"R")
0750 GET PARAM$,1 : FIRMANAVN$,SYST_DAT$,MOMS
0760 CLOSE PARAM$
0770 LET KTOIDX$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "KTOIDX"
0780 LET KONTO$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "KONTO"
0790 EXEC OPENFIL(KTOIDX$,"W")
0800 EXEC OPENFIL(KONTO$,"W")
0810 ENDPROC INITIER
0820
0830 PROC FUNKTIONSMENU
0840 REPEAT
0850 EXEC OVERSKRIFT("Kontofunktioner",6)
0860 PRINT "<C2309>Opret/ret konti               OK"
0870 PRINT "<C2311>Slet konti                    SK"
0880 PRINT "<C2314>Programfordeler             RETURN"
0890 LET SVAR$ := "  "
0900 REPEAT
0910 EDIT "<C2617>Indtast funktionskode: " : SVAR$(1 : 2)
0920 EXEC SL_FEJLLINIE
0930 IF "/" + SVAR$ + "/" IN "/  /OK/ok/SK/sk//" THEN
0940 EXEC FEJL("Ulovlig funktionskode: '" + SVAR$ + "'")
0950 ENDIF
0960 UNTIL "/" + SVAR$ + "/" IN "/  /OK/ok/SK/sk//"
0970 CASE SVAR$ OF
0980 WHILE "OK","ok"
0990 EXEC OPRET_RET_KONTI
1000 WHILE "SK","sk"
1010 EXEC SLET_KONTI
1020 OTHERWISE
1030 CLOSE
1040 CHAIN PROGRAM$
1050 ENDCASE
1060 UNTIL FALSE
1070 ENDPROC FUNKTIONSMENU
1080 //
1090 PROC TERMINAL_IDX
1100 LET PPAR := 5 ; RESRV := 0
1110 CALL :PRES"
1120 GET SYSPARA$,1 + RESRV : DATAFL$,T_KODE$
1130 ENDPROC TERMINAL_IDX
1140
1150 PROC OPENFIL(FNAVN$,WAY$)
1160 REPEAT
1170 IF AY$ = "W" OR WAY$ = "w" THEN
1180 OPEN FNAVN$,W
1190 ELSE
1200 OPEN FNAVN$,R
1210 ENDIF
1220 IF (FNAVN$) THEN
1230 PRINT "<S>" ; CHR$ (7)
1240 IF (FNAVN$) = 6 THEN
1250 PRINT "<SC1602>*** Fejl nr. 6 - indsæt diskette og tryk <RETURN> ***"
1260 INPUT "" : SVAR$
1270 ELSE
1280 PRINT "<SC1802>*** Fejl nr. " ; CHR$ ( ╱cd╱ (FNAVN$),2) ; " ved åbning af "
1290 PRINT "<S>" ; FNAVN$ ; " ***"
1300 INPUT "" : SVAR$
1310 PRINT "<C0102>" ; SPC$
1320 ENDIF
1330 ENDIF
1340 UNTIL NOT ╱cd╱ (FNAVN$)
1350 ENDPROC OPENFIL
1360
1370 PROC OVERSKRIFT(ST$,L)
1380 PRINT "<XC0101>Firmanavn: " ; FIRMANAVN$
1390 PRINT "<SC6501>Dato: " ; SYST_DAT$(1 : 2) ; "." ; SYST_DAT$(3 : 2) ; "."
1400 PRINT SYST_DAT$(5 : 2)
1410 CURSOR 34 - INT( ╱cb╱ (ST$) / 2),L
1420 PRINT "*** " ; ST$ ; " ***"
1430 ENDPROC OVERSKRIFT
1440
1450 PROC SL_FEJLLINIE
1460 LET OK := TRUE
1470 PRINT "<C0102>" ; SPC$
1480 ENDPROC SL_FEJLLINIE
1490
1500 PROC FEJL(ST$)
1510 LET OK := FALSE
1520 CURSOR 36 - ( ╱cb╱ (ST$) / 2),2
1530 PRINT "<S>*** " + ST$ + " ***" ; CHR$ (7)
1540 ENDPROC FEJL
1550
1560 PROC OPRET_RET_KONTI
1570 REPEAT
1580 LET A_KTONR$ := "" ; A_KTO_TYPE$ := "" ; KTO_NAVN$ := ""
1590 EXEC OVERSKRIFT("Opret/ret konti",6)
1600 FOR I := 1 TO DO
1610 EXEC RET_LINIE(I)
1620 NEXT I
1630 REPEAT
1640 LET SVAR$ := " "
1650 REPEAT
1660 PRINT "<SC0118>" ; SPC$(1 : 78)
1670 IF PRET THEN
1680 GET KONTO$,1 : N_FRIREC,N_MAXREC
1690 IF _FRIREC > N_MAXREC THEN
1700 EXEC FEJL("Der kan ikke oprettes flere konti")
1710 INPUT "<SC6524>Tryk <RETURN>" : SVAR$
1720 // CHAIN PROGRAM$
1730 ENDIF
1740 LET HJ_ST$ := "/J/j/N/n/"
1750 PRINT "<SC1318>Opret konto (j/n) eller linienummer der skal "
1760 ELSE
1770 LET HJ_ST$ := "/J/j/"
1780 PRINT "<SC1218>Kontooplysninger ok (j) eller linienummer der skal "
1790 ENDIF
1800 EDIT "rettes? " : SVAR$(1)
1810 EXEC SL_FEJLLINIE
1820 IF "/" + SVAR$(1) + "/" IN HJ_ST$ THEN
1830 EXEC TAL_CONTROL(SVAR$)
1840 IF OK THEN EXEC RET_LINIE( ASC (SVAR$))
1850 LET OK := FALSE ; SVAR$ := " "
1860 ENDIF
1870 UNTIL ╱cb╱ (SVAR$) > 0 AND OK
1880 UNTIL "/" + SVAR$ + "/" IN HJ_ST$
1890 IF "/" + SVAR$ + "/" IN "/J/j/" THEN EXEC SKRIV_KONTOOPL
1900 CLEAR
1910 LET SVAR$ := "j"
1920 EDIT "<C1212>Opret/ret flere konti (j/n)? " : SVAR$(1)
1930 UNTIL NOT "/" + SVAR$ + "/" IN "/J/j/"
1940 ENDPROC OPRET_RET_KONTI
1950
1960 PROC RET_LINIE(R_LIN)
1970 CASE R_LIN OF
1980 WHILE 1
1990 REPEAT
2000 EDIT "<C1710>1. Kontonr  : " : A_KTONR$
2010 UNTIL NOT A_KTONR$ IN "         "
2020 LET IDXPOS := FIND_KTO(A_KTONR$)
2030 IF OPRET = OK THEN LET KTO_NAVN$ := ""
2040 IF OK THEN
2050 LET OPRET := TRUE
2060 ELSE
2070 EXEC LÆS_KONTO(RECNR)
2080 LET A_KTO_TYPE$ := KTO_TYPE$
2090 LET OPRET := FALSE
2100 ENDIF
2110 PRINT "<C1711>2. Kontonavn: " ; KTO_NAVN$ ; SPC$(1 : 40 - ╱cb╱ (KTO_NAVN$))
2120 PRINT "<C1712>3. Kontotype: " ; A_KTO_TYPE$ ; SPC$(1)
2130 WHILE 2
2140 EDIT "<C1711>2. Kontonavn: " : KTO_NAVN$
2150 WHILE 3
2160 IF _KTO_TYPE$ >< "A" OR OPRET THEN
2170 IF A_KTO_TYPE$ IN "    " THEN LET A_KTO_TYPE$ := "A"
2180 REPEAT
2190 EDIT "<C1712>3. Kontotype: " : A_KTO_TYPE$
2200 EXEC SL_FEJLLINIE
2210 EXEC ST_BGST(A_KTO_TYPE$)
2220 IF "/" + A_KTO_TYPE$ + "/" IN "/A/B/C/D/E/F/G/H/I/J/K/L/" THEN
2230 EXEC FEJL("Ulovlig kontotype: '" + A_KTO_TYPE$ + "'")
2240 ELSE
2250 PRINT "<C1712>3. Kontotype: " ; A_KTO_TYPE$
2260 LET OK := TRUE
2270 ELSE
2280 ENDIF
2290 UNTIL OK
2300 ENDIF
2310 ENDCASE
2320 ENDPROC RET_LINIE
2330
2340 PROC SKRIV_KONTOOPL
2350 IF OPRET THEN EXEC FIND_IDXPLADS
2360 LET KTO_TYPE$ := A_KTO_TYPE$
2370 EXEC SKRIV_KONTO(RECNR)
2380 ENDPROC SKRIV_KONTOOPL
2390
2400 PROC FIND_IDXPLADS
2410 EXEC FIND_TOM_PLADS(A_RECNR)
2420 LET I_HØJREC := I_HØJREC + 1 ; IDXPOS := IDXPOS
2430 FOR I := I_HØJREC - 1 TO DXPOS STEP - 1 DO
2440 GET KTOIDX$,I : KTONR$,RECNR
2450 PUT KTOIDX$,I + 1 : KTONR$,RECNR
2460 NEXT I
2470 LET KTONR$ := A_KTONR$ ; RECNR := A_RECNR
2480 PUT KTOIDX$,IDXPOS : KTONR$,RECNR
2490 PUT KTOIDX$,1 : I_HØJREC,I_MAXREC
2500 LET KTO_PRIMO,KTO_ULTIMO := 0 ; KTO_FP,KTO_SP := 0
2510 ENDPROC FIND_IDXPLADS
2520
2530 PROC FIND_TOM_PLADS( REF R_NR)
2540 GET KONTO$,1 : N_FRIREC,N_MAXREC
2550 LET R_NR := N_FRIREC
2560 GET KONTO$,N_FRIREC : N_FRIREC
2570 PUT KONTO$,1 : N_FRIREC,N_MAXREC
2580 ENDPROC FIND_TOM_PLADS
2590 PROC LÆS_KONTO(P)
2600 GET KONTO$,P : KTO_TYPE$,KTO_NAVN$,KTO_PRIMO,KTO_ULTIMO,KTO_FP,KTO_SP
2610 ENDPROC LÆS_KONTO
2620
2630 PROC SKRIV_KONTO(P)
2640 PUT KONTO$,P : KTO_TYPE$,KTO_NAVN$,KTO_PRIMO,KTO_ULTIMO,KTO_FP,KTO_SP
2650 ENDPROC SKRIV_KONTO
2660
2670 PROC ST_BGST( REF RST$)
2680 FOR J := 1 TO (RST$) DO
2690 IF "a" =< RST$(J) AND RST$(J) =< "å" THEN LET RST$(J) := CHR$ ( ╱cc╱ (RST$(J)) - 32)
2700 NEXT J
2710 ENDPROC ST_BGST
2720
2730 PROC TAL_CONTROL( REF RST$)
2740 LET J := 0 ; OK := TRUE
2750 FOR I := 1 TO (RST$) DO
2760 IF RST$(I) IN "0123456789" THEN LET J := J + 1 ; RST$(J) := RST$(I)
2770 NEXT I
2780 IF = 0 THEN
2790 LET OK := FALSE
2800 ELSE
2810 LET RST$ := RST$(1 : J)
2820 ENDIF
2830 ENDPROC TAL_CONTROL
2840
2850 PROC SLET_KONTI
2860 REPEAT
2870 EXEC OVERSKRIFT("Slet konti",6)
2880 LET A_KTONR$ := "" ; A_KTO_TYPE$ := "" ; KTO_NAVN$ := ""
2890 REPEAT
2900 EXEC RET_LINIE(1)
2910 EXEC SL_FEJLLINIE
2920 IF OPRET THEN EXEC FEJL("konto eksisterer ikke")
2930 IF K THEN
2940 IF KTO_ULTIMO >< 0 THEN EXEC FEJL("Ulovlig sletning: Saldo <> 0 ")
2950 ENDIF
2960 UNTIL OK
2970 REPEAT
2980 LET SVAR$ := " "
2990 EDIT "<C2718>Slet konto (j/n)? " : SVAR$(1)
3000 UNTIL "/" + SVAR$(1) + "/" IN "/J/j/N/n/"
3010 IF "/" + SVAR$(1) + "/" IN "/J/j/" THEN EXEC SLET
3020 CLEAR
3030 LET SVAR$ := "j"
3040 EDIT "<C1212>Skal der slettes flere konti (j/n)? " : SVAR$(1)
3050 UNTIL NOT "/" + SVAR$ + "/" IN "/J/j/"
3060 ENDPROC SLET_KONTI
3070
3080 PROC SLET
3090 LET KTO_TYPE$ := "*"
3100 EXEC SKRIV_KONTO(RECNR)
3110 GET KONTO$,1 : N_FRIREC,N_MAXREC
3120 PUT KONTO$,RECNR : N_FRIREC
3130 LET N_FRIREC := RECNR
3140 PUT KONTO$,1 : N_FRIREC,N_MAXREC
3150 GET KTOIDX$,1 : I_HØJREC,I_MAXREC
3160 FOR I := IDXPOS TO _HØJREC - 1 DO
3170 GET KTOIDX$,I + 1 : KTONR$,RECNR
3180 PUT KTOIDX$,I : KTONR$,RECNR
3190 NEXT I
3200 LET I_HØJREC := I_HØJREC - 1
3210 PUT KTOIDX$,1 : I_HØJREC,I_MAXREC
3220 ENDPROC SLET
3230 PROC FIND_KTO( REF R_KTONR$)
3240 LET OK := FALSE
3250 GET KTOIDX$,1 : I_HØJREC,I_MAXREC
3260 LET LOW := 1 ; HIGH := I_HØJREC ; POS := 2
3270 IF IGH > 1 THEN
3280 REPEAT
3290 LET POS := INT((HIGH - LOW) / 2 + .5) + LOW
3300 GET KTOIDX$,POS : KTONR$,RECNR
3310 IF TONR$ > R_KTONR$ THEN
3320 LET HIGH := POS
3330 ELSE
3340 IF TONR$ < R_KTONR$ THEN
3350 LET LOW := POS
3360 ENDIF
3370 ENDIF
3380 UNTIL HIGH - LOW =< 1 OR R_KTONR$ = KTONR$
3390 LET POS := INT((HIGH - LOW) / 2 + .5) + LOW
3400 GET KTOIDX$,POS : KTONR$,RECNR
3410 IF KTONR$ = R_KTONR$ THEN LET OK := TRUE
3420 IF KTONR$ < R_KTONR$ AND POS = I_HØJREC THEN LET POS := POS + 1
3430 ENDIF
3440 LET FIND_KTO := POS
3450 ENDPROC FIND_KTO