DataMuseum.dk

top - download

    Length: 5969 (0x1751)
    Types: SPC/1-COMAL-80
    Notes: Mikados_B, UNKNOWN_TOKEN_cb, UNKNOWN_TOKEN_cc, UNKNOWN_TOKEN_cd
    Names: »SYSIÅ.B«

└─⟦86fa88d8d⟧ Bits:30005772 Bogføringssystemet 'SYS-KAMMS' v.1.0
    └─⟦this⟧ »SYSIÅ.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 INDTASTSALDI
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 A_KTONR$ OF 8,HJ_ST$ OF 10,KODE$ OF 1
0380 INTEGER POS,HIGH,LOW,IDXPOS
0390 // Variable til filen SYSPARA
0400 DIM SYSPARA$ OF 17
0410 DIM SYST_NAVN$ OF 30,S_KODE$ OF 1
0420 DIM DATAFL$ OF 8,T_KODE$ OF 1
0430 // Variable til filen @@PARAM
0440 DIM PARAM$ OF 17
0450 DIM FIRMANAVN$ OF 30,SYST_DAT$ OF 8
0460 REAL MOMS
0470 // Variable til filen @@KONTO
0480 DIM KONTO$ OF 17
0490 DIM ST_DATO$ OF 6
0500 INTEGER N_FRIREC,N_MAXREC,ANT_PER,PER_NR
0510 DIM KTO_TYPE$ OF 1,KTO_NAVN$ OF 40
0520 REAL KTO_PRIMO,KTO_ULTIMO
0530 INTEGER KTO_FP,KTO_SP
0540 // Variable til filen @@KTOIDX
0550 DIM KTOIDX$ OF 17
0560 INTEGER I_HØJREC,I_MAXREC
0570 DIM KTONR$ OF 8
0580 INTEGER RECNR
0590 ENDPROC DIMENSIONER
0600
0610 PROC INITIER
0620 LET PRGFL$ := "DP2"
0630 LET PROGRAM$ := PRGFL$ + ":SYSA"
0640 LET TAL$ := "0123456789"
0650 FOR I := ╱cc╱ ("A") TO ("Å") DO LET ALFA$ := ALFA$ + CHR$ (I)
0660 LET SPC$ := "                                        "
0670 LET SPC$ := SPC$ + SPC$
0680 LET FALSE := 0 ; TRUE := 1 // boolske variable
0690 LET SYSPARA$ := PRGFL$ + ":SYSPARA"
0700 EXEC OPENFIL(SYSPARA$,"R")
0710 GET SYSPARA$,1 : SYST_NAVN$,S_KODE$
0720 EXEC TERMINAL_IDX
0730 CLOSE SYSPARA$
0740 LET PARAM$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "PARAM"
0750 EXEC OPENFIL(PARAM$,"R")
0760 GET PARAM$,1 : FIRMANAVN$,SYST_DAT$,MOMS
0770 CLOSE PARAM$
0780 LET KTOIDX$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "KTOIDX"
0790 LET KONTO$ := DATAFL$ + ":" + S_KODE$ + T_KODE$ + "KONTO"
0800 EXEC OPENFIL(KTOIDX$,"W")
0810 EXEC OPENFIL(KONTO$,"W")
0820 ENDPROC INITIER
0830
0840 //
0850 PROC TERMINAL_IDX
0860 LET PPAR := 5 ; RESRV := 0
0870 CALL L"DDE:PRES"
0880 GET SYSPARA$,1 + RESRV : DATAFL$,T_KODE$
0890 ENDPROC TERMINAL_IDX
0900
0910 PROC OPENFIL(FNAVN$,WAY$)
0920 REPEAT
0930 IF AY$ = "W" OR WAY$ = "w" THEN
0940 OPEN FNAVN$,W
0950 ELSE
0960 OPEN FNAVN$,R
0970 ENDIF
0980 IF (FNAVN$) THEN
0990 PRINT "<S>" ; CHR$ (7)
1000 IF (FNAVN$) = 6 THEN
1010 PRINT "<SC1602>*** Fejl nr. 6 - indsæt diskette og tryk <RETURN> ***"
1020 INPUT "" : SVAR$
1030 ELSE
1040 PRINT "<SC1802>*** Fejl nr. " ; CHR$ ( ╱cd╱ (FNAVN$),2) ; " ved åbning af "
1050 PRINT "<S>" ; FNAVN$ ; " ***"
1060 INPUT "" : SVAR$
1070 PRINT "<C0102>" ; SPC$
1080 ENDIF
1090 ENDIF
1100 UNTIL NOT ╱cd╱ (FNAVN$)
1110 ENDPROC OPENFIL
1120
1130 PROC OVERSKRIFT(ST$,L)
1140 PRINT "<XC0101>Firmanavn: " ; FIRMANAVN$
1150 PRINT "<SC6501>Dato: " ; SYST_DAT$(1 : 2) ; "." ; SYST_DAT$(3 : 2) ; "."
1160 PRINT SYST_DAT$(5 : 2)
1170 CURSOR 34 - INT( ╱cb╱ (ST$) / 2),L
1180 PRINT "*** " ; ST$ ; " ***"
1190 ENDPROC OVERSKRIFT
1200
1210 PROC SL_FEJLLINIE
1220 LET OK := TRUE
1230 PRINT "<C0102>" ; SPC$
1240 ENDPROC SL_FEJLLINIE
1250
1260 PROC FEJL(ST$)
1270 LET OK := FALSE
1280 CURSOR 36 - ( ╱cb╱ (ST$) / 2),2
1290 PRINT "<S>*** " + ST$ + " ***" ; CHR$ (7)
1300 ENDPROC FEJL
1310
1320 PROC INDTASTSALDI
1330 REPEAT
1340 EXEC OVERSKRIFT("Indtastning af åbningssaldi",6)
1350 EXEC FIND_KONTO
1360 LET KODE$ := "D"
1370 IF KTO_PRIMO < 0 THEN LET KODE$ := "K"
1380 LET SVAR$ := CHR$ (ABS(KTO_PRIMO),9,2)
1390 IF KTO_PRIMO = 0 THEN LET SVAR$ := ""
1400 REPEAT
1410 PRINT "<SC1816>" ; SPC$
1420 EDIT "<SC1816>Saldo primo: " : SVAR$
1430 EXEC SL_FEJLLINIE
1440 EXEC TAL_CONTROL(SVAR$)
1450 IF NOT "." IN SVAR$ THEN LET SVAR$ := SVAR$ + "."
1460 UNTIL OK
1470 LET KTO_PRIMO := ASC (SVAR$)
1480 REPEAT
1490 EDIT "<SC1817>(D)ebet eller (K)redit? " : KODE$
1500 EXEC ST_BGST(KODE$)
1510 EXEC SL_FEJLLINIE
1520 IF "/" + KODE$ + "/" IN "/D/K/" THEN
1530 EXEC FEJL("Ukendt svar: '" + KODE$ + "'")
1540 ENDIF
1550 UNTIL OK
1560 IF KODE$ = "K" THEN LET KTO_PRIMO := KTO_PRIMO * ( - 1)
1570 LET KTO_ULTIMO := KTO_PRIMO
1580 EXEC SKRIV_KONTO(RECNR)
1590 CLEAR
1600 LET SVAR$ := "j"
1610 EDIT "<C1212>Indtast flere åbningssaldi (j/n)? " : SVAR$(1)
1620 UNTIL NOT "/" + SVAR$ + "/" IN "/J/j/"
1630 ENDPROC INDTASTSALDI
1640
1650 PROC FIND_KONTO
1660 LET A_KTONR$ := ""
1670 REPEAT
1680 REPEAT
1690 EDIT "<C1710>1. Kontonr  : " : A_KTONR$
1700 UNTIL NOT A_KTONR$ IN "         "
1710 EXEC SL_FEJLLINIE
1720 LET IDXPOS := FIND_KTO(A_KTONR$)
1730 IF NOT OK THEN EXEC FEJL("Konto findes ikke")
1740 IF OK THEN EXEC LÆS_KONTO(RECNR)
1750 IF TO_TYPE$ >< "A" AND OK THEN
1760 EXEC FEJL("Ulovlig kontonr - kontotype < > 'A'")
1770 ENDIF
1780 IF TO_FP > 0 AND OK THEN
1790 EXEC FEJL("Der er påbegyndt bogføring på kontoen")
1800 ENDIF
1810 UNTIL OK
1820 PRINT "<C1711>2. Kontonavn: " ; KTO_NAVN$ ; SPC$(1 : 40 - ╱cb╱ (KTO_NAVN$))
1830 PRINT "<C1712>3. Kontotype: " ; KTO_TYPE$
1840 ENDPROC FIND_KONTO
1850
1860 PROC SKRIV_KONTOOPL
1870 IF OPRET THEN EXEC FIND_IDXPLADS
1880 LET KTO_TYPE$ := A_KTO_TYPE$
1890 EXEC SKRIV_KONTO(RECNR)
1900 ENDPROC SKRIV_KONTOOPL
1910
1920
1930 PROC LÆS_KONTO(P)
1940 GET KONTO$,P : KTO_TYPE$,KTO_NAVN$,KTO_PRIMO,KTO_ULTIMO,KTO_FP,KTO_SP
1950 ENDPROC LÆS_KONTO
1960
1970 PROC SKRIV_KONTO(P)
1980 PUT KONTO$,P : KTO_TYPE$,KTO_NAVN$,KTO_PRIMO,KTO_ULTIMO,KTO_FP,KTO_SP
1990 ENDPROC SKRIV_KONTO
2000
2010 PROC ST_BGST( REF RST$)
2020 FOR J := 1 TO (RST$) DO
2030 IF "a" =< RST$(J) AND RST$(J) =< "å" THEN LET RST$(J) := CHR$ ( ╱cc╱ (RST$(J)) - 32)
2040 NEXT J
2050 ENDPROC ST_BGST
2060
2070 PROC TAL_CONTROL( REF RST$)
2080 LET J := 0 ; OK := TRUE ; K := 0
2090 FOR I := 1 TO (RST$) DO
2100 IF RST$(I) IN "0123456789" THEN LET J := J + 1 ; RST$(J) := RST$(I)
2110 IF RST$(I) = "." AND K = 0 THEN LET J := J + 1 ; K := K + 1 ; RST$(J) := RST$(I)
2120 NEXT I
2130 IF = 0 THEN
2140 LET OK := FALSE
2150 ELSE
2160 LET RST$ := RST$(1 : J)
2170 ENDIF
2180 ENDPROC TAL_CONTROL
2190
2200 PROC FIND_KTO( REF R_KTONR$)
2210 LET OK := FALSE
2220 GET KTOIDX$,1 : I_HØJREC,I_MAXREC
2230 LET LOW := 1 ; HIGH := I_HØJREC ; POS := 2
2240 IF IGH > 1 THEN
2250 REPEAT
2260 LET POS := INT((HIGH - LOW) / 2 + .5) + LOW
2270 GET KTOIDX$,POS : KTONR$,RECNR
2280 IF TONR$ > R_KTONR$ THEN
2290 LET HIGH := POS
2300 ELSE
2310 IF TONR$ < R_KTONR$ THEN
2320 LET LOW := POS
2330 ENDIF
2340 ENDIF
2350 UNTIL HIGH - LOW =< 1 OR R_KTONR$ = KTONR$
2360 LET POS := INT((HIGH - LOW) / 2 + .5) + LOW
2370 GET KTOIDX$,POS : KTONR$,RECNR
2380 IF KTONR$ = R_KTONR$ THEN LET OK := TRUE
2390 ENDIF
2400 LET FIND_KTO := POS
2410 ENDPROC FIND_KTO