DataMuseum.dk

top - metrics - download

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

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

SPC/1 COMAL-80

00100 // **************************************************
00110 // *………………………………………………………………………………………………………………………………*
00120 // *…………………………Bogf|ringssystemet…'SYS-KAS'…………………………*
00130 // *………………………………………………vers.…1.0………………………………………………………*
00140 // *………………………………………………………………………………………………………………………………*
00150 // *…Udviklet…marts…1983…p}…en…'SPC/1'…mikrodatamat…*
00160 // *…Programsystemet…er…skrevet…i…COMAL80…vers.…1.2…*
00170 // *………………………………………………………………………………………………………………………………*
00180 // *…Udviklet…af…:…Peter…Kristensen……………………………………………*
00190 // *………………………………………Vestervang…6,…6920…Videb{k…………………*
00200 // *………………………………………………………………………………………………………………………………*
00210 // *………(C)…………………:…forlaget…systime…a/s…………………………………*
00220 // *………………………………………Klokkebakken…20,…Gjellerup…………………*
00230 // *………………………………………7400……Herning……………………………………………………*
00240 // **************************************************
00250 EXEC DIMENSIONER
00260 EXEC INITIER
00270 EXEC FUNKTIONSMENU
00280 CHAIN PROGRAM $
00290 // =============…procedurer…starter…=============
00300 PROC DIMENSIONER
00310 // Standard…variable
00320 DIM SPC $ OF 80 , TAL $ OF 10 , ALFA $ OF 28 , SVAR $ OF 12 , PRGFL $ OF 8
00330 DIM PROGRAM $ OF 17
00340 REAL RESRV , PPAR
00350 INTEGER OK , TRUE , FALSE , I , J , K
00360 // Hj{lpevariable
00370 DIM HJ_ST $ OF 10 , A_TXT $ OF 20 , A_BNR $ OF 5 , A_KTONR $ OF 8 , NONBOOK $ OF 60
00380 DIM A_KTO_TYPE $ OF 1 , A_KTO_NAVN $ OF 40
00390 REAL A_KTO_ULTIMO , NULR , T[LLER ( 3 ) , OVERSKUD
00400 INTEGER POS , HIGH , LOW , IDXPOS , DEBET , KREDIT , NUL , KOLNR , MAX_LIN
00410 INTEGER A_NTRANS , A_KTO_SP , LIN_T , TABNR ( 2 ) , SIDENR
00420 // Variable…til…filen…SYSPARA
00430 DIM SYSPARA $ OF 17
00440 DIM SYST_NAVN $ OF 30 , S_KODE $ OF 1
00450 DIM DATAFL $ OF 8 , T_KODE $ OF 1
00460 // Variable…til…filen…@@PARAM
00470 DIM PARAM $ OF 17
00480 DIM FIRMANAVN $ OF 30 , SYST_DAT $ OF 8
00490 REAL MOMS
00500 DIM ST_DATO $ OF 6
00510 INTEGER ANT_PER , PER_NR
00520 // Variable…til…filen…@@TRANS
00530 DIM TRANS $ OF 17
00540 INTEGER T_H\JREC , T_MAXREC
00550 DIM BKTONR $ OF 8 , BDATO $ OF 6 , BLGNR $ OF 5 , BTXT $ OF 20
00560 REAL BMOMS , BBEL\B
00570 INTEGER NTRANS , DK
00580 // Variable…til…filen…@@DRIFT\
00590 DIM DRIFT\ $ OF 17
00600 DIM PRIMODAT $ OF 6
00610 REAL DRIFT ( 2 )
00620 // Variable…til…filen…@@KONTO
00630 DIM KONTO $ OF 17
00640 INTEGER N_FRIREC , N_MAXREC
00650 DIM KTO_TYPE $ OF 1 , KTO_NAVN $ OF 40
00660 REAL KTO_PRIMO , KTO_ULTIMO
00670 INTEGER KTO_FP , KTO_SP
00680 // Variable…til…filen…@@KTOIDX
00690 DIM KTOIDX $ OF 17
00700 INTEGER I_H\JREC , I_MAXREC
00710 DIM KTONR $ OF 8
00720 INTEGER RECNR
00730 // Variable…til…filen…@@FKTONR
00740 DIM FKTONR $ OF 17
00750 DIM BAL_KTO $ OF 8 , RES_KTO $ OF 8 , BALANCE $ OF 8 , PRIVATF $ OF 8 , OVERSK $ OF 8
00760 DIM INDMOMS_KTO $ OF 8 , UDMOMS_KTO $ OF 8
00770 // Variable…til…filen…@@KTOGRP
00780 DIM KTOGRP $ OF 17
00790 DIM KREDGRP $ OF 8 , DEBGRP $ OF 8
00800 ENDPROC DIMENSIONER
00810
00820 PROC INITIER
00830 LET PRGFL $ := "DP2"
00840 LET PROGRAM $ := PRGFL $ + ":SYSA"
00850 LET TAL $ := "0123456789"
00860 FOR I := ╱cc╱ ( "A" ) TO ( "]" ) DO LET ALFA $ := ALFA $ + CHR$ ( I )
00870 LET SPC $ := "…………………………………………………………………………………………………………"
00880 LET SPC $ := SPC $ + SPC $
00890 LET FALSE := 0 ; TRUE := 1 // boolske…variable
00900 LET DEBET := 1 ; KREDIT := - 1 ; NULR := 0
00910 LET SYSPARA $ := PRGFL $ + ":SYSPARA"
00920 EXEC OPENFIL ( SYSPARA $ , "R" )
00930 GET SYSPARA $ , 1 : SYST_NAVN $ , S_KODE $
00940 EXEC TERMINAL_IDX
00950 CLOSE SYSPARA $
00960 LET PARAM $ := DATAFL $ + ":" + S_KODE $ + T_KODE $ + "PARAM"
00970 EXEC OPENFIL ( PARAM $ , "W" )
00980 GET PARAM $ , 1 : FIRMANAVN $ , SYST_DAT $ , MOMS
00990 GET PARAM $ , 2 : ST_DATO $ , ANT_PER , PER_NR
01000 LET KTOIDX $ := DATAFL $ + ":" + S_KODE $ + T_KODE $ + "KTOIDX"
01010 LET KONTO $ := DATAFL $ + ":" + S_KODE $ + T_KODE $ + "KONTO"
01020 LET TRANS $ := DATAFL $ + ":" + S_KODE $ + T_KODE $ + "TRANS"
01030 LET DRIFT\ $ := DATAFL $ + ":" + S_KODE $ + T_KODE $ + "DRIFT\"
01040 LET FKTONR $ := DATAFL $ + ":" + S_KODE $ + T_KODE $ + "FKTONR"
01050 LET KTOGRP $ := DATAFL $ + ":" + S_KODE $ + T_KODE $ + "KTOGRP"
01060 EXEC OPENFIL ( TRANS $ , "W" )
01070 EXEC OPENFIL ( KTOIDX $ , "W" )
01080 EXEC OPENFIL ( KONTO $ , "W" )
01090 EXEC OPENFIL ( FKTONR $ , "R" )
01100 GET FKTONR $ , 7 : RES_KTO $
01110 GET FKTONR $ , 8 : BAL_KTO $
01120 CLOSE FKTONR $
01130 EXEC OPENFIL ( KTOGRP $ , "R" )
01140 GET KTOGRP $ , 12 : DEBGRP $
01150 GET KTOGRP $ , 17 : KREDGRP $
01160 CLOSE KTOGRP $
01170 ENDPROC INITIER
01180
01190 //
01200 PROC TERMINAL_IDX
01210 LET PPAR := 5 ; RESRV := 0
01220 CALL 7"DDE:PRES"
01230 GET SYSPARA $ , 1 + RESRV : DATAFL $ , T_KODE $
01240 ENDPROC TERMINAL_IDX
01250
01260 PROC OPENFIL ( FNAVN $ , WAY $ )
01270 REPEAT
01280 IF AY $ = "W" OR WAY $ = "w" THEN
01290 OPEN FNAVN $ , W
01300 ELSE
01310 OPEN FNAVN $ , R
01320 ENDIF
01330 IF ( FNAVN $ ) THEN
01340 PRINT "<S>" ; CHR$ ( 7 )
01350 IF ( FNAVN $ ) = 6 THEN
01360 PRINT "<SC1602>***…Fejl…nr.…6…-…inds{t…diskette…og…tryk…<RETURN>…***"
01370 INPUT "" : SVAR $
01380 ELSE
01390 PRINT "<SC1802>***…Fejl…nr.…" ; CHR$ ( ╱cd╱ ( FNAVN $ ) , 2 ) ; "…ved…}bning…af…"
01400 PRINT "<S>" ; FNAVN $ ; "…***"
01410 INPUT "" : SVAR $
01420 PRINT "<C0102>" ; SPC $
01430 ENDIF
01440 ENDIF
01450 UNTIL NOT ╱cd╱ ( FNAVN $ )
01460 ENDPROC OPENFIL
01470
01480 PROC OVERSKRIFT ( ST $ , L )
01490 PRINT "<XC0101>Firmanavn:…" ; FIRMANAVN $
01500 PRINT "<SC6501>Dato:…" ; SYST_DAT $ ( 1 : 2 ) ; "." ; SYST_DAT $ ( 3 : 2 ) ; "."
01510 PRINT SYST_DAT $ ( 5 : 2 )
01520 CURSOR 34 - INT ( ╱cb╱ ( ST $ ) / 2 ) , L
01530 PRINT "***…" ; ST $ ; "…***"
01540 ENDPROC OVERSKRIFT
01550
01560 PROC SL_FEJLLINIE
01570 LET OK := TRUE
01580 PRINT "<C0102>" ; SPC $
01590 ENDPROC SL_FEJLLINIE
01600
01610 PROC FEJL ( ST $ )
01620 LET OK := FALSE
01630 CURSOR 36 - ( ╱cb╱ ( ST $ ) / 2 ) , 2
01640 PRINT "<S>***…" + ST $ + "…***" ; CHR$ ( 7 )
01650 ENDPROC FEJL
01660
01670 PROC SKRIV_KONTOOPL
01680 IF OPRET THEN EXEC FIND_IDXPLADS
01690 LET KTO_TYPE $ := A_KTO_TYPE $
01700 EXEC SKRIV_KONTO ( RECNR )
01710 ENDPROC SKRIV_KONTOOPL
01720
01730 PROC L[S_KONTO ( P )
01740 GET KONTO $ , P : KTO_TYPE $ , KTO_NAVN $ , KTO_PRIMO , KTO_ULTIMO , KTO_FP , KTO_SP
01750 ENDPROC L[S_KONTO
01760
01770 PROC SKRIV_KONTO ( P )
01780 PUT KONTO $ , P : KTO_TYPE $ , KTO_NAVN $ , KTO_PRIMO , KTO_ULTIMO , KTO_FP , KTO_SP
01790 ENDPROC SKRIV_KONTO
01800
01810 PROC ST_BGST ( REF RST $ )
01820 FOR J := 1 TO ( RST $ ) DO
01830 IF "a" =< RST $ ( J ) AND RST $ ( J ) =< "}" THEN LET RST $ ( J ) := CHR$ ( ╱cc╱ ( RST $ ( J ) ) - 32 )
01840 NEXT J
01850 ENDPROC ST_BGST
01860
01870 PROC TAL_CONTROL ( REF RST $ )
01880 LET J := 0 ; OK := TRUE ; K := 0
01890 FOR I := 1 TO ( RST $ ) DO
01900 IF RST $ ( I ) IN "0123456789" THEN LET J := J + 1 ; RST $ ( J ) := RST $ ( I )
01910 IF RST $ ( I ) = "." AND K = 0 THEN LET J := J + 1 ; K := K + 1 ; RST $ ( J ) := RST $ ( I )
01920 NEXT I
01930 IF = 0 THEN
01940 LET OK := FALSE
01950 ELSE
01960 LET RST $ := RST $ ( 1 : J )
01970 ENDIF
01980 ENDPROC TAL_CONTROL
01990
02000 PROC FIND_KTO ( REF R_KTONR $ )
02010 LET OK := FALSE
02020 GET KTOIDX $ , 1 : I_H\JREC , I_MAXREC
02030 LET LOW := 1 ; HIGH := I_H\JREC ; POS := 2
02040 IF IGH > 1 THEN
02050 REPEAT
02060 LET POS := INT ( ( HIGH - LOW ) / 2 + .5 ) + LOW
02070 GET KTOIDX $ , POS : KTONR $ , RECNR
02080 IF TONR $ > R_KTONR $ THEN
02090 LET HIGH := POS
02100 ELSE
02110 IF TONR $ < R_KTONR $ THEN
02120 LET LOW := POS
02130 ENDIF
02140 ENDIF
02150 UNTIL HIGH - LOW =< 1 OR R_KTONR $ = KTONR $
02160 LET POS := INT ( ( HIGH - LOW ) / 2 + .5 ) + LOW
02170 GET KTOIDX $ , POS : KTONR $ , RECNR
02180 IF KTONR $ = R_KTONR $ THEN LET OK := TRUE
02190 ENDIF
02200 LET FIND_KTO := POS
02210 ENDPROC FIND_KTO
02220
02230 PROC FUNKTIONSMENU
02240 IF ER_NR = 0 THEN
02250 EXEC OVERSKRIFT ( "Fremf|ring…af…balancetal…i…ny…regning" , 6 )
02260 PRINT "<C1809>Har…du…f}et…udskrevet…kontokort…"
02270 PRINT "<C1810>Er…datoen…=…den…f|rste…dato…i…det…nye…regnskabs}r…"
02280 PRINT "<C1811>Er…der…foretaget…sikkerhedskopiering"
02290 EDIT "<C3414>(j/n)?…" : SVAR $ ( 1 )
02300 IF VAR $ IN "JAja" AND SVAR $ >< "" THEN
02310 EXEC TILBAGEF\R
02320 EXEC FREMF\R
02330 ENDIF
02340 ELSE
02350 PRINT "<XSC0712>Ulovlig…fremf|ring…af…balancetal…-…regnskabs}ret…ikke…"
02360 PRINT "afsluttet"
02370 INPUT "<SC6523>Tryk…RETURN" : SVAR $
02380 ENDIF
02390 CHAIN PROGRAM $
02400 ENDPROC FUNKTIONSMENU
02410
02420 PROC BOGF\R ( REF Q_KTO $ , REF Q_DAT $ , REF Q_TXT $ , REF Q_M , REF Q_KR , Q_DK , QN $ )
02430 EXEC FIND_KTO ( Q_KTO $ )
02440 IF OK THEN
02450 EXEC FEJL ( "UKENDT…KONTONR:…" + Q_KTO $ )
02460 EXIT
02470 ELSE
02480 EXEC L[S_KONTO ( RECNR )
02490 IF TO_TYPE $ >< "A" THEN
02500 EXEC FEJL ( "ULOVLIG…KONTONR:…" + Q_KTO $ )
02510 EXIT
02520 ENDIF
02530 ENDIF
02540 GET TRANS $ , 1 : T_H\JREC , T_MAXREC
02550 IF _H\JREC = T_MAXREC THEN
02560 EXEC FEJL ( "TRANSAKTIONSFILEN…ER…FULD" )
02570 EXIT
02580 ENDIF
02590 LET T_H\JREC := T_H\JREC + 1
02600 IF TO_FP > 0 THEN
02610 EXEC L[S_TRANS ( KTO_SP )
02620 LET NTRANS := T_H\JREC
02630 EXEC SKRIV_TRANS ( KTO_SP )
02640 ELSE
02650 LET KTO_FP := T_H\JREC
02660 ENDIF
02670 LET BKTONR $ := Q_KTO $ ; BDATO $ := Q_DAT $ ; BTXT $ := Q_TXT $ ; BMOMS := Q_M ; BBEL\B := Q_KR
02680 LET DK := Q_DK ; NTRANS := NUL ; BLGNR $ := QN $
02690 EXEC SKRIV_TRANS ( T_H\JREC )
02700 LET KTO_SP := T_H\JREC
02710 IF K = DEBET THEN
02720 LET KTO_ULTIMO := KTO_ULTIMO + BBEL\B
02730 ELSE
02740 LET KTO_ULTIMO := KTO_ULTIMO - BBEL\B
02750 ENDIF
02760 EXEC SKRIV_KONTO ( RECNR )
02770 PUT TRANS $ , 1 : T_H\JREC , T_MAXREC
02780 ENDPROC BOGF\R
02790
02800 PROC SKRIV_TRANS ( P )
02810 PUT TRANS $ , P : BKTONR $ , BDATO $ , BLGNR $ , BTXT $ , BMOMS , BBEL\B , DK , NTRANS
02820 ENDPROC SKRIV_TRANS
02830
02840 PROC L[S_TRANS ( P )
02850 GET TRANS $ , P : BKTONR $ , BDATO $ , BLGNR $ , BTXT $ , BMOMS , BBEL\B , DK , NTRANS
02860 ENDPROC L[S_TRANS
02870
02880 PROC TILBAGEF\R
02890 EXEC FIND_KTO ( BAL_KTO $ )
02900 EXEC L[S_KONTO ( RECNR )
02910 LET A_NTRANS := KTO_FP ; A_KTO_SP := KTO_SP
02920 REPEAT
02930 EXEC L[S_TRANS ( A_NTRANS )
02940 LET A_NTRANS := NTRANS
02950 LET A_KTONR $ := BTXT $ ( 11 : 8 ) ; A_TXT $ := "OVERF\RT…TIL…" + A_KTONR $
02960 LET A_DK := DK * ( - 1 ) ; A_BNR $ := "……" ; A_KTO_ULTIMO := BBEL\B
02970 EXEC BOGF\R ( BAL_KTO $ , SYST_DAT $ , A_TXT $ , NULR , A_KTO_ULTIMO , A_DK , A_BNR $ )
02980 LET A_TXT $ := "OVERF\RT…FRA…" + BAL_KTO $ ; A_DK := A_DK * ( - 1 )
02990 EXEC BOGF\R ( A_KTONR $ , SYST_DAT $ , A_TXT $ , NULR , A_KTO_ULTIMO , A_DK , A_BNR $ )
03000 PRINT "<SC3613>" ; A_KTONR $ ; SPC $ ( 1 : 10 )
03010 UNTIL A_NTRANS > A_KTO_SP
03020 LET PER_NR := PER_NR + 1 ; ST_DATO $ := SYST_DAT $
03030 PUT PARAM $ , 2 : ST_DATO $ , ANT_PER , PER_NR
03040 PUT DRIFT\ $ , 1 : SYST_DAT $
03050 ENDPROC TILBAGEF\R
03060 PROC FREMF\R
03070 GET KTOIDX $ , 1 : I_H\JREC , I_MAXREC
03080 FOR I := 2 TO _H\JREC DO
03090 GET KTOIDX $ , I : KTONR $ , RECNR
03100 EXEC L[S_KONTO ( RECNR )
03110 PRINT "<C3613>" ; KTONR $ ; SPC $ ( 1 : 10 )
03120 LET KTO_PRIMO := KTO_ULTIMO ; KTO_FP := 0 ; KTO_SP := 0
03130 EXEC SKRIV_KONTO ( RECNR )
03140 NEXT I
03150 GET TRANS $ , 1 : T_H\JREC , T_MAXREC
03160 LET T_H\JREC := 1
03170 PUT TRANS $ , 1 : T_H\JREC , T_MAXREC
03180 LET PER_NR := PER_NR + 1 ; ST_DATO $ := SYST_DAT $
03190 ENDPROC FREMF\R
38382 ╱00╱ ╱00╱