DataMuseum.dk

top - metrics - download

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

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

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 INDTASTSALDI
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 A_KTONR $ OF 8 , HJ_ST $ OF 10 , KODE $ OF 1
00380 INTEGER POS , HIGH , LOW , IDXPOS
00390 // Variable…til…filen…SYSPARA
00400 DIM SYSPARA $ OF 17
00410 DIM SYST_NAVN $ OF 30 , S_KODE $ OF 1
00420 DIM DATAFL $ OF 8 , T_KODE $ OF 1
00430 // Variable…til…filen…@@PARAM
00440 DIM PARAM $ OF 17
00450 DIM FIRMANAVN $ OF 30 , SYST_DAT $ OF 8
00460 REAL MOMS
00470 // Variable…til…filen…@@KONTO
00480 DIM KONTO $ OF 17
00490 DIM ST_DATO $ OF 6
00500 INTEGER N_FRIREC , N_MAXREC , ANT_PER , PER_NR
00510 DIM KTO_TYPE $ OF 1 , KTO_NAVN $ OF 40
00520 REAL KTO_PRIMO , KTO_ULTIMO
00530 INTEGER KTO_FP , KTO_SP
00540 // Variable…til…filen…@@KTOIDX
00550 DIM KTOIDX $ OF 17
00560 INTEGER I_H\JREC , I_MAXREC
00570 DIM KTONR $ OF 8
00580 INTEGER RECNR
00590 ENDPROC DIMENSIONER
00600
00610 PROC INITIER
00620 LET PRGFL $ := "DP2"
00630 LET PROGRAM $ := PRGFL $ + ":SYSA"
00640 LET TAL $ := "0123456789"
00650 FOR I := ╱cc╱ ( "A" ) TO ( "]" ) DO LET ALFA $ := ALFA $ + CHR$ ( I )
00660 LET SPC $ := "…………………………………………………………………………………………………………"
00670 LET SPC $ := SPC $ + SPC $
00680 LET FALSE := 0 ; TRUE := 1 // boolske…variable
00690 LET SYSPARA $ := PRGFL $ + ":SYSPARA"
00700 EXEC OPENFIL ( SYSPARA $ , "R" )
00710 GET SYSPARA $ , 1 : SYST_NAVN $ , S_KODE $
00720 EXEC TERMINAL_IDX
00730 CLOSE SYSPARA $
00740 LET PARAM $ := DATAFL $ + ":" + S_KODE $ + T_KODE $ + "PARAM"
00750 EXEC OPENFIL ( PARAM $ , "R" )
00760 GET PARAM $ , 1 : FIRMANAVN $ , SYST_DAT $ , MOMS
00770 CLOSE PARAM $
00780 LET KTOIDX $ := DATAFL $ + ":" + S_KODE $ + T_KODE $ + "KTOIDX"
00790 LET KONTO $ := DATAFL $ + ":" + S_KODE $ + T_KODE $ + "KONTO"
00800 EXEC OPENFIL ( KTOIDX $ , "W" )
00810 EXEC OPENFIL ( KONTO $ , "W" )
00820 ENDPROC INITIER
00830
00840 //
00850 PROC TERMINAL_IDX
00860 LET PPAR := 5 ; RESRV := 0
00870 CALL L"DDE:PRES"
00880 GET SYSPARA $ , 1 + RESRV : DATAFL $ , T_KODE $
00890 ENDPROC TERMINAL_IDX
00900
00910 PROC OPENFIL ( FNAVN $ , WAY $ )
00920 REPEAT
00930 IF AY $ = "W" OR WAY $ = "w" THEN
00940 OPEN FNAVN $ , W
00950 ELSE
00960 OPEN FNAVN $ , R
00970 ENDIF
00980 IF ( FNAVN $ ) THEN
00990 PRINT "<S>" ; CHR$ ( 7 )
01000 IF ( FNAVN $ ) = 6 THEN
01010 PRINT "<SC1602>***…Fejl…nr.…6…-…inds{t…diskette…og…tryk…<RETURN>…***"
01020 INPUT "" : SVAR $
01030 ELSE
01040 PRINT "<SC1802>***…Fejl…nr.…" ; CHR$ ( ╱cd╱ ( FNAVN $ ) , 2 ) ; "…ved…}bning…af…"
01050 PRINT "<S>" ; FNAVN $ ; "…***"
01060 INPUT "" : SVAR $
01070 PRINT "<C0102>" ; SPC $
01080 ENDIF
01090 ENDIF
01100 UNTIL NOT ╱cd╱ ( FNAVN $ )
01110 ENDPROC OPENFIL
01120
01130 PROC OVERSKRIFT ( ST $ , L )
01140 PRINT "<XC0101>Firmanavn:…" ; FIRMANAVN $
01150 PRINT "<SC6501>Dato:…" ; SYST_DAT $ ( 1 : 2 ) ; "." ; SYST_DAT $ ( 3 : 2 ) ; "."
01160 PRINT SYST_DAT $ ( 5 : 2 )
01170 CURSOR 34 - INT ( ╱cb╱ ( ST $ ) / 2 ) , L
01180 PRINT "***…" ; ST $ ; "…***"
01190 ENDPROC OVERSKRIFT
01200
01210 PROC SL_FEJLLINIE
01220 LET OK := TRUE
01230 PRINT "<C0102>" ; SPC $
01240 ENDPROC SL_FEJLLINIE
01250
01260 PROC FEJL ( ST $ )
01270 LET OK := FALSE
01280 CURSOR 36 - ( ╱cb╱ ( ST $ ) / 2 ) , 2
01290 PRINT "<S>***…" + ST $ + "…***" ; CHR$ ( 7 )
01300 ENDPROC FEJL
01310
01320 PROC INDTASTSALDI
01330 REPEAT
01340 EXEC OVERSKRIFT ( "Indtastning…af…}bningssaldi" , 6 )
01350 EXEC FIND_KONTO
01360 LET KODE $ := "D"
01370 IF KTO_PRIMO < 0 THEN LET KODE $ := "K"
01380 LET SVAR $ := CHR$ ( ABS ( KTO_PRIMO ) , 9 , 2 )
01390 IF KTO_PRIMO = 0 THEN LET SVAR $ := ""
01400 REPEAT
01410 PRINT "<SC1816>" ; SPC $
01420 EDIT "<SC1816>Saldo…primo:…" : SVAR $
01430 EXEC SL_FEJLLINIE
01440 EXEC TAL_CONTROL ( SVAR $ )
01450 IF NOT "." IN SVAR $ THEN LET SVAR $ := SVAR $ + "."
01460 UNTIL OK
01470 LET KTO_PRIMO := ASC ( SVAR $ )
01480 REPEAT
01490 EDIT "<SC1817>(D)ebet…eller…(K)redit?…" : KODE $
01500 EXEC ST_BGST ( KODE $ )
01510 EXEC SL_FEJLLINIE
01520 IF "/" + KODE $ + "/" IN "/D/K/" THEN
01530 EXEC FEJL ( "Ukendt…svar:…'" + KODE $ + "'" )
01540 ENDIF
01550 UNTIL OK
01560 IF KODE $ = "K" THEN LET KTO_PRIMO := KTO_PRIMO * ( - 1 )
01570 LET KTO_ULTIMO := KTO_PRIMO
01580 EXEC SKRIV_KONTO ( RECNR )
01590 CLEAR
01600 LET SVAR $ := "j"
01610 EDIT "<C1212>Indtast…flere…}bningssaldi…(j/n)?…" : SVAR $ ( 1 )
01620 UNTIL NOT "/" + SVAR $ + "/" IN "/J/j/"
01630 ENDPROC INDTASTSALDI
01640
01650 PROC FIND_KONTO
01660 LET A_KTONR $ := ""
01670 REPEAT
01680 REPEAT
01690 EDIT "<C1710>1.…Kontonr……:…" : A_KTONR $
01700 UNTIL NOT A_KTONR $ IN "………………………"
01710 EXEC SL_FEJLLINIE
01720 LET IDXPOS := FIND_KTO ( A_KTONR $ )
01730 IF NOT OK THEN EXEC FEJL ( "Konto…findes…ikke" )
01740 IF OK THEN EXEC L[S_KONTO ( RECNR )
01750 IF TO_TYPE $ >< "A" AND OK THEN
01760 EXEC FEJL ( "Ulovlig…kontonr…-…kontotype…<…>…'A'" )
01770 ENDIF
01780 IF TO_FP > 0 AND OK THEN
01790 EXEC FEJL ( "Der…er…p}begyndt…bogf|ring…p}…kontoen" )
01800 ENDIF
01810 UNTIL OK
01820 PRINT "<C1711>2.…Kontonavn:…" ; KTO_NAVN $ ; SPC $ ( 1 : 40 - ╱cb╱ ( KTO_NAVN $ ) )
01830 PRINT "<C1712>3.…Kontotype:…" ; KTO_TYPE $
01840 ENDPROC FIND_KONTO
01850
01860 PROC SKRIV_KONTOOPL
01870 IF OPRET THEN EXEC FIND_IDXPLADS
01880 LET KTO_TYPE $ := A_KTO_TYPE $
01890 EXEC SKRIV_KONTO ( RECNR )
01900 ENDPROC SKRIV_KONTOOPL
01910
01920
01930 PROC L[S_KONTO ( P )
01940 GET KONTO $ , P : KTO_TYPE $ , KTO_NAVN $ , KTO_PRIMO , KTO_ULTIMO , KTO_FP , KTO_SP
01950 ENDPROC L[S_KONTO
01960
01970 PROC SKRIV_KONTO ( P )
01980 PUT KONTO $ , P : KTO_TYPE $ , KTO_NAVN $ , KTO_PRIMO , KTO_ULTIMO , KTO_FP , KTO_SP
01990 ENDPROC SKRIV_KONTO
02000
02010 PROC ST_BGST ( REF RST $ )
02020 FOR J := 1 TO ( RST $ ) DO
02030 IF "a" =< RST $ ( J ) AND RST $ ( J ) =< "}" THEN LET RST $ ( J ) := CHR$ ( ╱cc╱ ( RST $ ( J ) ) - 32 )
02040 NEXT J
02050 ENDPROC ST_BGST
02060
02070 PROC TAL_CONTROL ( REF RST $ )
02080 LET J := 0 ; OK := TRUE ; K := 0
02090 FOR I := 1 TO ( RST $ ) DO
02100 IF RST $ ( I ) IN "0123456789" THEN LET J := J + 1 ; RST $ ( J ) := RST $ ( I )
02110 IF RST $ ( I ) = "." AND K = 0 THEN LET J := J + 1 ; K := K + 1 ; RST $ ( J ) := RST $ ( I )
02120 NEXT I
02130 IF = 0 THEN
02140 LET OK := FALSE
02150 ELSE
02160 LET RST $ := RST $ ( 1 : J )
02170 ENDIF
02180 ENDPROC TAL_CONTROL
02190
02200 PROC FIND_KTO ( REF R_KTONR $ )
02210 LET OK := FALSE
02220 GET KTOIDX $ , 1 : I_H\JREC , I_MAXREC
02230 LET LOW := 1 ; HIGH := I_H\JREC ; POS := 2
02240 IF IGH > 1 THEN
02250 REPEAT
02260 LET POS := INT ( ( HIGH - LOW ) / 2 + .5 ) + LOW
02270 GET KTOIDX $ , POS : KTONR $ , RECNR
02280 IF TONR $ > R_KTONR $ THEN
02290 LET HIGH := POS
02300 ELSE
02310 IF TONR $ < R_KTONR $ THEN
02320 LET LOW := POS
02330 ENDIF
02340 ENDIF
02350 UNTIL HIGH - LOW =< 1 OR R_KTONR $ = KTONR $
02360 LET POS := INT ( ( HIGH - LOW ) / 2 + .5 ) + LOW
02370 GET KTOIDX $ , POS : KTONR $ , RECNR
02380 IF KTONR $ = R_KTONR $ THEN LET OK := TRUE
02390 ENDIF
02400 LET FIND_KTO := POS
02410 ENDPROC FIND_KTO
01760 EXEC FEJL ( "Ulovlig…kontonr…-…konto…ikke…bogf|ringskonto" )
38382 ╱00╱ ╱00╱