DataMuseum.dk

Presents historical artifacts from the history of:

MIKADOS

This is an automatic "excavation" of a thematic subset of
artifacts from Datamuseum.dk's BitArchive.

See our Wiki for more about MIKADOS

Excavated with: AutoArchaeologist - Free & Open Source Software. 

top - metrics - download

⟦d3078bdda⟧ SPC/1-COMAL-80

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

Derivation

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

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 // =============…procedurer…starter…=============
00290 PROC DIMENSIONER
00300 // Standard…variable
00310 DIM SPC $ OF 80 , TAL $ OF 10 , ALFA $ OF 28 , SVAR $ OF 8 , PRGFL $ OF 8
00320 DIM PROGRAM $ OF 17
00330 REAL RESRV , PPAR
00340 INTEGER OK , TRUE , FALSE , I , J
00350 // Hj{lpevariable
00360 DIM A_KTO_NAVN $ OF 40 , A_KTO_TYPE $ OF 1 , A_KTONR $ OF 8 , HJ_ST $ OF 10
00370 INTEGER POS , HIGH , LOW , OPRET , IDXPOS
00380 // Variable…til…filen…SYSPARA
00390 DIM SYSPARA $ OF 17
00400 DIM SYST_NAVN $ OF 30 , S_KODE $ OF 1
00410 DIM DATAFL $ OF 8 , T_KODE $ OF 1
00420 // Variable…til…filen…@@PARAM
00430 DIM PARAM $ OF 17
00440 DIM FIRMANAVN $ OF 30 , SYST_DAT $ OF 8
00450 REAL MOMS
00460 // Variable…til…filen…@@KONTO
00470 DIM KONTO $ OF 17
00480 DIM ST_DATO $ OF 6
00490 INTEGER N_FRIREC , N_MAXREC , ANT_PER , PER_NR
00500 DIM KTO_TYPE $ OF 1 , KTO_NAVN $ OF 40
00510 REAL KTO_PRIMO , KTO_ULTIMO
00520 INTEGER KTO_FP , KTO_SP
00530 // Variable…til…filen…@@KTOIDX
00540 DIM KTOIDX $ OF 17
00550 INTEGER I_H\JREC , I_MAXREC
00560 DIM KTONR $ OF 8
00570 INTEGER RECNR
00580 ENDPROC DIMENSIONER
00590
00600 PROC INITIER
00610 LET PRGFL $ := "DP2"
00620 LET PROGRAM $ := PRGFL $ + ":SYS"
00630 LET TAL $ := "0123456789"
00640 FOR I := ╱cc╱ ( "A" ) TO ( "]" ) DO LET ALFA $ := ALFA $ + CHR$ ( I )
00650 LET SPC $ := "…………………………………………………………………………………………………………"
00660 LET SPC $ := SPC $ + SPC $
00670 LET FALSE := 0 ; TRUE := 1 // boolske…variable
00680 LET SYSPARA $ := PRGFL $ + ":SYSPARA"
00690 EXEC OPENFIL ( SYSPARA $ , "R" )
00700 GET SYSPARA $ , 1 : SYST_NAVN $ , S_KODE $
00710 EXEC TERMINAL_IDX
00720 CLOSE SYSPARA $
00730 LET PARAM $ := DATAFL $ + ":" + S_KODE $ + T_KODE $ + "PARAM"
00740 EXEC OPENFIL ( PARAM $ , "R" )
00750 GET PARAM $ , 1 : FIRMANAVN $ , SYST_DAT $ , MOMS
00760 CLOSE PARAM $
00770 LET KTOIDX $ := DATAFL $ + ":" + S_KODE $ + T_KODE $ + "KTOIDX"
00780 LET KONTO $ := DATAFL $ + ":" + S_KODE $ + T_KODE $ + "KONTO"
00790 EXEC OPENFIL ( KTOIDX $ , "W" )
00800 EXEC OPENFIL ( KONTO $ , "W" )
00810 ENDPROC INITIER
00820
00830 PROC FUNKTIONSMENU
00840 REPEAT
00850 EXEC OVERSKRIFT ( "Kontofunktioner" , 6 )
00860 PRINT "<C2309>Opret/ret…konti………………………………………OK"
00870 PRINT "<C2311>Slet…konti……………………………………………………SK"
00880 PRINT "<C2314>Programfordeler…………………………………RETURN"
00890 LET SVAR $ := "……"
00900 REPEAT
00910 EDIT "<C2617>Indtast…funktionskode:…" : SVAR $ ( 1 : 2 )
00920 EXEC SL_FEJLLINIE
00930 IF "/" + SVAR $ + "/" IN "/……/OK/ok/SK/sk//" THEN
00940 EXEC FEJL ( "Ulovlig…funktionskode:…'" + SVAR $ + "'" )
00950 ENDIF
00960 UNTIL "/" + SVAR $ + "/" IN "/……/OK/ok/SK/sk//"
00970 CASE SVAR $ OF
00980 WHILE "OK" , "ok"
00990 EXEC OPRET_RET_KONTI
01000 WHILE "SK" , "sk"
01010 EXEC SLET_KONTI
01020 OTHERWISE
01030 CLOSE
01040 CHAIN PROGRAM $
01050 ENDCASE
01060 UNTIL FALSE
01070 ENDPROC FUNKTIONSMENU
01080 //
01090 PROC TERMINAL_IDX
01100 LET PPAR := 5 ; RESRV := 0
01110 CALL :PRES"
01120 GET SYSPARA $ , 1 + RESRV : DATAFL $ , T_KODE $
01130 ENDPROC TERMINAL_IDX
01140
01150 PROC OPENFIL ( FNAVN $ , WAY $ )
01160 REPEAT
01170 IF AY $ = "W" OR WAY $ = "w" THEN
01180 OPEN FNAVN $ , W
01190 ELSE
01200 OPEN FNAVN $ , R
01210 ENDIF
01220 IF ( FNAVN $ ) THEN
01230 PRINT "<S>" ; CHR$ ( 7 )
01240 IF ( FNAVN $ ) = 6 THEN
01250 PRINT "<SC1602>***…Fejl…nr.…6…-…inds{t…diskette…og…tryk…<RETURN>…***"
01260 INPUT "" : SVAR $
01270 ELSE
01280 PRINT "<SC1802>***…Fejl…nr.…" ; CHR$ ( ╱cd╱ ( FNAVN $ ) , 2 ) ; "…ved…}bning…af…"
01290 PRINT "<S>" ; FNAVN $ ; "…***"
01300 INPUT "" : SVAR $
01310 PRINT "<C0102>" ; SPC $
01320 ENDIF
01330 ENDIF
01340 UNTIL NOT ╱cd╱ ( FNAVN $ )
01350 ENDPROC OPENFIL
01360
01370 PROC OVERSKRIFT ( ST $ , L )
01380 PRINT "<XC0101>Firmanavn:…" ; FIRMANAVN $
01390 PRINT "<SC6501>Dato:…" ; SYST_DAT $ ( 1 : 2 ) ; "." ; SYST_DAT $ ( 3 : 2 ) ; "."
01400 PRINT SYST_DAT $ ( 5 : 2 )
01410 CURSOR 34 - INT ( ╱cb╱ ( ST $ ) / 2 ) , L
01420 PRINT "***…" ; ST $ ; "…***"
01430 ENDPROC OVERSKRIFT
01440
01450 PROC SL_FEJLLINIE
01460 LET OK := TRUE
01470 PRINT "<C0102>" ; SPC $
01480 ENDPROC SL_FEJLLINIE
01490
01500 PROC FEJL ( ST $ )
01510 LET OK := FALSE
01520 CURSOR 36 - ( ╱cb╱ ( ST $ ) / 2 ) , 2
01530 PRINT "<S>***…" + ST $ + "…***" ; CHR$ ( 7 )
01540 ENDPROC FEJL
01550
01560 PROC OPRET_RET_KONTI
01570 REPEAT
01580 LET A_KTONR $ := "" ; A_KTO_TYPE $ := "" ; KTO_NAVN $ := ""
01590 EXEC OVERSKRIFT ( "Opret/ret…konti" , 6 )
01600 FOR I := 1 TO DO
01610 EXEC RET_LINIE ( I )
01620 NEXT I
01630 REPEAT
01640 LET SVAR $ := "…"
01650 REPEAT
01660 PRINT "<SC0118>" ; SPC $ ( 1 : 78 )
01670 IF PRET THEN
01680 GET KONTO $ , 1 : N_FRIREC , N_MAXREC
01690 IF _FRIREC > N_MAXREC THEN
01700 EXEC FEJL ( "Der…kan…ikke…oprettes…flere…konti" )
01710 INPUT "<SC6524>Tryk…<RETURN>" : SVAR $
01720 // CHAIN…PROGRAM$
01730 ENDIF
01740 LET HJ_ST $ := "/J/j/N/n/"
01750 PRINT "<SC1318>Opret…konto…(j/n)…eller…linienummer…der…skal…"
01760 ELSE
01770 LET HJ_ST $ := "/J/j/"
01780 PRINT "<SC1218>Kontooplysninger…ok…(j)…eller…linienummer…der…skal…"
01790 ENDIF
01800 EDIT "rettes?…" : SVAR $ ( 1 )
01810 EXEC SL_FEJLLINIE
01820 IF "/" + SVAR $ ( 1 ) + "/" IN HJ_ST $ THEN
01830 EXEC TAL_CONTROL ( SVAR $ )
01840 IF OK THEN EXEC RET_LINIE ( ASC ( SVAR $ ) )
01850 LET OK := FALSE ; SVAR $ := "…"
01860 ENDIF
01870 UNTIL ╱cb╱ ( SVAR $ ) > 0 AND OK
01880 UNTIL "/" + SVAR $ + "/" IN HJ_ST $
01890 IF "/" + SVAR $ + "/" IN "/J/j/" THEN EXEC SKRIV_KONTOOPL
01900 CLEAR
01910 LET SVAR $ := "j"
01920 EDIT "<C1212>Opret/ret…flere…konti…(j/n)?…" : SVAR $ ( 1 )
01930 UNTIL NOT "/" + SVAR $ + "/" IN "/J/j/"
01940 ENDPROC OPRET_RET_KONTI
01950
01960 PROC RET_LINIE ( R_LIN )
01970 CASE R_LIN OF
01980 WHILE 1
01990 REPEAT
02000 EDIT "<C1710>1.…Kontonr……:…" : A_KTONR $
02010 UNTIL NOT A_KTONR $ IN "………………………"
02020 LET IDXPOS := FIND_KTO ( A_KTONR $ )
02030 IF OPRET = OK THEN LET KTO_NAVN $ := ""
02040 IF OK THEN
02050 LET OPRET := TRUE
02060 ELSE
02070 EXEC L[S_KONTO ( RECNR )
02080 LET A_KTO_TYPE $ := KTO_TYPE $
02090 LET OPRET := FALSE
02100 ENDIF
02110 PRINT "<C1711>2.…Kontonavn:…" ; KTO_NAVN $ ; SPC $ ( 1 : 40 - ╱cb╱ ( KTO_NAVN $ ) )
02120 PRINT "<C1712>3.…Kontotype:…" ; A_KTO_TYPE $ ; SPC $ ( 1 )
02130 WHILE 2
02140 EDIT "<C1711>2.…Kontonavn:…" : KTO_NAVN $
02150 WHILE 3
02160 IF _KTO_TYPE $ >< "A" OR OPRET THEN
02170 IF A_KTO_TYPE $ IN "…………" THEN LET A_KTO_TYPE $ := "A"
02180 REPEAT
02190 EDIT "<C1712>3.…Kontotype:…" : A_KTO_TYPE $
02200 EXEC SL_FEJLLINIE
02210 EXEC ST_BGST ( A_KTO_TYPE $ )
02220 IF "/" + A_KTO_TYPE $ + "/" IN "/A/B/C/D/E/F/G/H/I/J/K/L/" THEN
02230 EXEC FEJL ( "Ulovlig…kontotype:…'" + A_KTO_TYPE $ + "'" )
02240 ELSE
02250 PRINT "<C1712>3.…Kontotype:…" ; A_KTO_TYPE $
02260 LET OK := TRUE
02270 ELSE
02280 ENDIF
02290 UNTIL OK
02300 ENDIF
02310 ENDCASE
02320 ENDPROC RET_LINIE
02330
02340 PROC SKRIV_KONTOOPL
02350 IF OPRET THEN EXEC FIND_IDXPLADS
02360 LET KTO_TYPE $ := A_KTO_TYPE $
02370 EXEC SKRIV_KONTO ( RECNR )
02380 ENDPROC SKRIV_KONTOOPL
02390
02400 PROC FIND_IDXPLADS
02410 EXEC FIND_TOM_PLADS ( A_RECNR )
02420 LET I_H\JREC := I_H\JREC + 1 ; IDXPOS := IDXPOS
02430 FOR I := I_H\JREC - 1 TO DXPOS STEP - 1 DO
02440 GET KTOIDX $ , I : KTONR $ , RECNR
02450 PUT KTOIDX $ , I + 1 : KTONR $ , RECNR
02460 NEXT I
02470 LET KTONR $ := A_KTONR $ ; RECNR := A_RECNR
02480 PUT KTOIDX $ , IDXPOS : KTONR $ , RECNR
02490 PUT KTOIDX $ , 1 : I_H\JREC , I_MAXREC
02500 LET KTO_PRIMO , KTO_ULTIMO := 0 ; KTO_FP , KTO_SP := 0
02510 ENDPROC FIND_IDXPLADS
02520
02530 PROC FIND_TOM_PLADS ( REF R_NR )
02540 GET KONTO $ , 1 : N_FRIREC , N_MAXREC
02550 LET R_NR := N_FRIREC
02560 GET KONTO $ , N_FRIREC : N_FRIREC
02570 PUT KONTO $ , 1 : N_FRIREC , N_MAXREC
02580 ENDPROC FIND_TOM_PLADS
02590 PROC L[S_KONTO ( P )
02600 GET KONTO $ , P : KTO_TYPE $ , KTO_NAVN $ , KTO_PRIMO , KTO_ULTIMO , KTO_FP , KTO_SP
02610 ENDPROC L[S_KONTO
02620
02630 PROC SKRIV_KONTO ( P )
02640 PUT KONTO $ , P : KTO_TYPE $ , KTO_NAVN $ , KTO_PRIMO , KTO_ULTIMO , KTO_FP , KTO_SP
02650 ENDPROC SKRIV_KONTO
02660
02670 PROC ST_BGST ( REF RST $ )
02680 FOR J := 1 TO ( RST $ ) DO
02690 IF "a" =< RST $ ( J ) AND RST $ ( J ) =< "}" THEN LET RST $ ( J ) := CHR$ ( ╱cc╱ ( RST $ ( J ) ) - 32 )
02700 NEXT J
02710 ENDPROC ST_BGST
02720
02730 PROC TAL_CONTROL ( REF RST $ )
02740 LET J := 0 ; OK := TRUE
02750 FOR I := 1 TO ( RST $ ) DO
02760 IF RST $ ( I ) IN "0123456789" THEN LET J := J + 1 ; RST $ ( J ) := RST $ ( I )
02770 NEXT I
02780 IF = 0 THEN
02790 LET OK := FALSE
02800 ELSE
02810 LET RST $ := RST $ ( 1 : J )
02820 ENDIF
02830 ENDPROC TAL_CONTROL
02840
02850 PROC SLET_KONTI
02860 REPEAT
02870 EXEC OVERSKRIFT ( "Slet…konti" , 6 )
02880 LET A_KTONR $ := "" ; A_KTO_TYPE $ := "" ; KTO_NAVN $ := ""
02890 REPEAT
02900 EXEC RET_LINIE ( 1 )
02910 EXEC SL_FEJLLINIE
02920 IF OPRET THEN EXEC FEJL ( "konto…eksisterer…ikke" )
02930 IF K THEN
02940 IF KTO_ULTIMO >< 0 THEN EXEC FEJL ( "Ulovlig…sletning:…Saldo…<>…0…" )
02950 ENDIF
02960 UNTIL OK
02970 REPEAT
02980 LET SVAR $ := "…"
02990 EDIT "<C2718>Slet…konto…(j/n)?…" : SVAR $ ( 1 )
03000 UNTIL "/" + SVAR $ ( 1 ) + "/" IN "/J/j/N/n/"
03010 IF "/" + SVAR $ ( 1 ) + "/" IN "/J/j/" THEN EXEC SLET
03020 CLEAR
03030 LET SVAR $ := "j"
03040 EDIT "<C1212>Skal…der…slettes…flere…konti…(j/n)?…" : SVAR $ ( 1 )
03050 UNTIL NOT "/" + SVAR $ + "/" IN "/J/j/"
03060 ENDPROC SLET_KONTI
03070
03080 PROC SLET
03090 LET KTO_TYPE $ := "*"
03100 EXEC SKRIV_KONTO ( RECNR )
03110 GET KONTO $ , 1 : N_FRIREC , N_MAXREC
03120 PUT KONTO $ , RECNR : N_FRIREC
03130 LET N_FRIREC := RECNR
03140 PUT KONTO $ , 1 : N_FRIREC , N_MAXREC
03150 GET KTOIDX $ , 1 : I_H\JREC , I_MAXREC
03160 FOR I := IDXPOS TO _H\JREC - 1 DO
03170 GET KTOIDX $ , I + 1 : KTONR $ , RECNR
03180 PUT KTOIDX $ , I : KTONR $ , RECNR
03190 NEXT I
03200 LET I_H\JREC := I_H\JREC - 1
03210 PUT KTOIDX $ , 1 : I_H\JREC , I_MAXREC
03220 ENDPROC SLET
03230 PROC FIND_KTO ( REF R_KTONR $ )
03240 LET OK := FALSE
03250 GET KTOIDX $ , 1 : I_H\JREC , I_MAXREC
03260 LET LOW := 1 ; HIGH := I_H\JREC ; POS := 2
03270 IF IGH > 1 THEN
03280 REPEAT
03290 LET POS := INT ( ( HIGH - LOW ) / 2 + .5 ) + LOW
03300 GET KTOIDX $ , POS : KTONR $ , RECNR
03310 IF TONR $ > R_KTONR $ THEN
03320 LET HIGH := POS
03330 ELSE
03340 IF TONR $ < R_KTONR $ THEN
03350 LET LOW := POS
03360 ENDIF
03370 ENDIF
03380 UNTIL HIGH - LOW =< 1 OR R_KTONR $ = KTONR $
03390 LET POS := INT ( ( HIGH - LOW ) / 2 + .5 ) + LOW
03400 GET KTOIDX $ , POS : KTONR $ , RECNR
03410 IF KTONR $ = R_KTONR $ THEN LET OK := TRUE
03420 IF KTONR $ < R_KTONR $ AND POS = I_H\JREC THEN LET POS := POS + 1
03430 ENDIF
03440 LET FIND_KTO := POS
03450 ENDPROC FIND_KTO
01600 FOR I := 1 TO DO
01720 CHAIN PROGRAM $
02170 LET A_KTO_TYPE $ := "A"
01600 FOR I := 1 TO DO
38382 ╱00╱ ╱00╱

Full view