|
DataMuseum.dkPresents historical artifacts from the history of: Philips Data Systems |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Philips Data Systems Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 14128 (0x3730)
Notes: pts_type(SC)
Names: »RGSUB1.SC«
└─⟦38a30a456⟧ Bits:30009662 Philips computer tape "600104"
└─⟦this⟧ »OD-KOM/RGSUB1.SC«
└─⟦d2cdd233a⟧ Bits:30009674 Philips computer tape "600204"
└─⟦this⟧ »OD-KOM/RGSUB1.SC«
IDENT RGSUB1 830825 EV
DDUM KMD08
PDIV
ENTRY SLUT
ENTRY FLDTST
ENTRY UPDAKK
ENTRY SUMWRT
ENTRY UPDA12
ENTRY FLDIN
EXT PACKST
EXT WRITFD
EXT WRITVO
EXT WRITJT
EXT FRMTJT
EXT FRMXTA
EXT WTALLY
EXT FRMTVO
EXT KTPLAN
EXT SPERR
EXT SPLIN8
EXT SPINF8
INCLUDE EQUATE
EJECT
SLUT PROC
** SLUT - PACKS THE BUFFER
** WRITES TO DISK
** WRITE JOURNAL
** WRITE VOUCHER
** UPDATE ACCUMULATE=ORS
TBT TTINVFLG,SLUT30 IF IN MODPOST
* FIND CORRECT ARKIV KONTO NR
MOVE TTDBKRM,=C'K' IF KREDIT
CBE TTDKDEX,CBIN1,SLUT10
MOVE TTDBKRM,=C'D' IF DEBET
SLUT10
TBF GTCYFLG,SLUT30
TBT TTCY2FLG,SLUT30
CBE GTREGDEX,CBIN3,SLUT30 IF TRANS 3
CBE GTREGDEX,CBIN4,SLUT30 IF TRANS 4
MOVE GTDUPF(CBIN9),TTARKSAV
MOVE GTUSED(CBIN9),CBIN13
CBNE TTARKSAV,=D'0',SLUT30 NO ARKIV?
MOVE TTARKSAV,GTDUPF(CBIN1)
MOVE GTDUPF(CBIN9),TTARKSAV
SLUT30
CBG GTREGDEX,=W'19',SLUT150 TR 50...
* INSERT 'REGNSKABSAAR IF TRANSTYPES 1,2,5-10
CBG GTREGDEX,=W'10',SLUT50
CBE GTREGDEX,=W'3',SLUT50
CBE GTREGDEX,=W'4',SLUT50
* TYPES 1,2,5-10
MOVE GTDUPF(CBIN6),GTDATO
CBE GTREGDEX,CBIN10,SLUT37 TRANS10, ALWAYS SUP
TBT TTSUPFLG,SLUT35
MOVE TTSUPMRK,CBLANKS
B SLUT50
SLUT35
CBE TTSUPMRK,=C'N',SLUT36
B SLUT37
SLUT36
ADD GTDUPF(CBIN6),=D'1' FORSUPP
B SLUT40
SLUT37
SUB GTDUPF(CBIN6),=D'1' SUPP
SLUT40
MOVE TSWBCD2,GTDUPF(CBIN6) ISOLATE LAST DIGIT
MOVE GTDUPF(CBIN6),TSWBCD2
MOVE GTUSED(CBIN6),CBIN10 SET FIELD NO
SLUT50
ADD TTLBNR,=D'1' EKSP. LB. NR
BOFL SLUT51
B SLUT52
SLUT51
MOVE TTLBNR,=D'10001' START VALUE FOR ODENSE
SLUT52
PERF WRITFD
BNOK SLUTNOK
PERF SUMWRT WRITE SUM OR RESTSUM
TBF GTKASSE,SLUT60 ON JOURNAL?
PERF FRMTJT
PERF WRITJT,=W'0'
SLUT60
PERF FRMTVO
PERF WRITVO
* TEST IF IN LISTE
TBF TTLSTFLG,SLUT80
PERF FRMXTA,CBIN4
PERF WTALLY
SLUT80
PERF UPDAKK
SET GTKORTFL
MOVE GSWBIN1,GTKTTYP
IB GSWBIN1, C
SLUT90,SLUT95,SLUT95,SLUT95,SLUT90
SLUT90
CLEAR GTKORTFL
SLUT95
SET TTEORFLG
CLEAR SPME READY FOR FUNCTIONS
CLEAR GTREGFLG
CMP CBIN0,CBIN0 OK, SETCR=0
RET
SLUTNOK
SUB TTLBNR,=D'1' CHANGE LB. NR. AFTER
DISK ERROR
SLUTRET
MOVE SPBINW4,=W'17'
CMP CBIN1,CBIN0
RET
SLUT150 TR 50...
PERF WRITFD
BNOK SLUTRET
MOVE TTCYKTOT,GTDUPF(CBIN6) GET RATE VALUE
CBL GTRTANT,=D'2',SLUT170 CORRECT
MUL TTCYKTOT,GTRTANT FIND TOTAL
SLUT170
ADD GTSUM,TTCYKTOT ADD TO LISTE
ADD GTSUMCNT,TTCYKTOT ADD TO SUM COUNTER
PERF WRITJT,=W'0'
TBF TTLSTFLG,SLUT180 IN LISTE?
MOVE GSWBCD6,TTCYKTOT
PERF FRMXTA,CBIN5 YES
PERF WTALLY
SLUT180
SET GTKORTFL
MOVE GTUSED(CBIN1),=W'0' READY FOR NEW TRANS
B SLUT95
PEND
EJECT
SUMWRT PROC
********************
*
** SUMWRT - CALCULATE AND WRITE SUM/RESTSUM
*
********************
TBF TTSUMFLG,SUMRET ONLY IF SUM
TBF GTCYFLG,SUMADD
TBT TTCY2FLG,SUMADD
SUB GTSUM,GTDUPF(CBIN4) CALCULATE NEW RESTSUM
ADD TTCYKTOT,GTDUPF(CBIN4)
B SUMOUT
SUMADD
ADD GTSUM,GTDUPF(CBIN4) CALCULATE NEW SUM
ADD TTCYKTOT,GTDUPF(CBIN4)
SUMOUT
PERF SPINF8
SUMRET
ADD GTSUMCNT,GTDUPF(CBIN4) ALWAYS ADD TO SUMFUNCTION
RET
PEND
EJECT
UPDAKK PROC
********************
*
* UPDAKK
* ROUTINE FOR UPDATING ACCUMULATORS
*
* TR1-TR10 UPDATES TTACC(IDX1,IDX2)
* IDX1 = TRNR
* IDX2 = DEB/KRE
* TR12 UPDATES TTACC12(IDX1,IDX2)
* IDX1 = TAELLER NR
* IDX2 = DEB/KRE
*
* ALL TRANSACTIONS UPDATE TTTOTDK(IDX2)
* AND IF INVERT TTKORDK(IDX2)
*
********************
CBNE GTREGNR,='12',UPD20
PERF UPDA12 TAELLER 12
B UPDRET
UPD20
CBG GTREGNR,=D'30',UPDRET NO ACCUMULATION FOR
CERTAIN TRANSACTIONS
CBE GTUSED(CBIN6),CBIN0,UPD30
ADD TTACC(CBIN8,TTDKDEX),GTDUPF(CBIN4)
UPDATE SUPL COUNTER
UPD30
TBT GTTESTFL,UPD38
* ACCUMULATE 'BEHOLDNINGSTAELLERE'
MOVE GSWBIN1,CBIN1
UPD35
CBE CBACC(GSWBIN1,CBIN1),GTDUPF(CBIN3),UPD350 BKO?
CBNE CBACC(GSWBIN1,CBIN1),GTDUPF(CBIN1),UPD36 FOUND?
UPD350
ADD CBACC(GSWBIN1,CBIN2),GTDUPF(CBIN4)
ADD CBACC(GSWBIN1,CBIN3),GTDUPF(CBIN4)
UPD36
ADD GSWBIN1,CBIN1 LOOK AT NEXT COUNTER
CBNG GSWBIN1,=W'60',UPD35
UPD38
MOVE GSWBIN1,CCNTDEX(GTREGDEX) GET INDEX
ADD TTACC(GSWBIN1,TTDKDEX),GTDUPF(CBIN4)
UPDATE ACCUMULATOR
IB TTDKDEX,UPDKR,UPDDB SEE IF INVERT
UPDDB
CBNL GTDUPF(CBIN4),='0',UPD50 IF NEGATIVE DEBET
ADD TTACC(CBIN7,TTDKDEX),GTDUPF(CBIN4) CORRECTION
B UPD50
UPDKR
CBNG GTDUPF(CBIN4),=D'0',UPD50 IF POSITIVE KREDIT,
ADD TTACC(CBIN7,TTDKDEX),GTDUPF(CBIN4) CORRECTION
UPD50
CBG GSWBIN1,CBIN4,UPDRET IF COUNTER 5,6
TBT GTTFLG,UPDRET WHEN CLOSE, NO UPDATE
TBT CWFLAG,UPD55
CBE TTCASHAC,GTDUPF(CBIN1),UPDRET IF KASSEKONTO,NO UPDATE
CBE TVERSUR,GTDUPF(CBIN1),UPDRET IF VERSUR, NO UPDATE
UPD55
CBG GTREGNR,=D'17',UPDRET
SUB TTCASH,GTDUPF(CBIN4)
B UPDRET
UPDRET
RET
PEND
EJECT
UPDA12 PROC
********************
*
* UPDA12 - UPDATE FOR TR12
*
********************
MOVE GSWBIN1,TTCNTNR TAELLER NR
SUB GSWBIN1,=W'100' GET INDEX
ADD GSWBIN1,CTR12(TTASKNR,CBIN1)
ADD C12ACC(GSWBIN1,TTDKDEX),GTDUPF(CBIN4)
ADD TTEJEDB,GTDUPF(CBIN4)
MOVE GSWBCD1,CTR12NR(GSWBIN1) GET TR 12 ACCOUNT
PERF KTPLAN,GSWBCD1,GTKTTYP SEE IF KORT NEEDED
RET
PEND
EJECT
FLDTST PROC
********************
*
* FLDTST - TEST IF FIELDS ARE ENTERED CORRECT
* FELT AFHAENGIGHEDS TEST
*
********************
PERF PACKST CLEAR UNUSED FIELDS
IB GTREGDEX, C
FLDTOK,FLDTOK,FLDT03,FLDT04,FLDTOK, C
FLDTOK,FLDTOK,FLDT08,FLDTOK,FLDT10, C
FLDTOK,FLDTOK,FLDTOK,FLDTOK,FLDT45, C
FLDT45,FLDTOK,FLDTOK,FLDTOK,FLDT50, C
FLDT51,FLDT52,FLDT53,FLDT54
*
FLDT03
CBE GTUSED(CBIN12),CBIN0,FLDT035 FIELD 16?
* YES, RTE/GEB, INSERT TEXT IN TT16TXT
MOVE GSWBCD3,GTDUPF(CBIN12) GET FIELD
CBNE GSWBCD3,=D'0',FLDT031
MOVE TT16TXT,=C'RA' IF = 0
B FLDT035
FLDT031
CBNE GSWBCD3,=D'1',FLDT032
MOVE TT16TXT,=C'RT' IF = 1
B FLDT035
FLDT032
CBNE GSWBCD3,=D'2',FLDT035
MOVE TT16TXT,=C'GB' IF = 2
FLDT035
TEST CFLT48
BZ FLDTOK BRANCH IF FALSE
CMP GTUSED(CBIN15),=W'0'
BNE FLDTOK FIELD 48 USED
CMP GTDUPF(CBIN3),=D'21'
BL FLDT037
CMP GTDUPF(CBIN3),=D'26'
BL FLDTOK BKO = 21-25
FLDT037
CMP GTDUPF(CBIN3),=D'30'
BE FLDTOK BKO=30
CMP GTDUPF(CBIN3),=D'56'
BE FLDTOK BKO=56
CMP GTDUPF(CBIN3),=D'63'
BE FLDTOK BKO 63
MOVE GTUSED(CBIN15),=W'48' SET FIELD 48 USED
MOVE GTDUPF(CBIN15),=D'1' SET FIELD 48 = 1
B FLDTOK
*
FLDT04
TBT BCPR,FLDT041 CIR
CMP GTUSED(CBIN10),=W'0'
BE FLDTOK FIELD 17 (INDEX 10)
B FLDTNOK
FLDT041 CPR
PERF FLDIN,CBIN11,CBIN12,CBIN13,CBIN0 FIELD 18,19,20
CMP GSWBIN1,=W'0'
BNE FLDTNOK
CMP GTUSED(CBIN10),=W'0'
BNE FLDTOK
B FLDTNOK
*
FLDT08
TEST CFLT46
BZ FLDTOK
CMP GTUSED(CBIN17),=W'0'
BNE FLDTOK FIELD 46 USED
MOVE GTUSED(CBIN17),=W'46' ELSE SET FIELD 46 USED
MOVE GTDUPF(CBIN17),=D'1' SET FIELD 46 = 1
B FLDTOK
*
FLDT10
MOVE GSWBIN1,GTKTTYP
IB GSWBIN1, C
FLDT105,FLDT105,FLDT102,FLDT108,FLDT108
FLDT102
B FLDTOK
FLDT105
CMP GTUSED(CBIN2),=W'0'
BNE FLDTOK
B FLDTNOK
FLDT108
CMP GTUSED(CBIN2),=W'0'
BNE FLDTOK
MOVE SPBINW4,=W'26'
PERF SPERR
CMP SPBINW2,CBIN2
BE FLDTOK KOR-KEY
MOVE SPBINW4,=W'0'
B FLDTNOK NOT KOR-KEY
*
FLDT45
PERF FLDIN,CBIN3,CBIN4,CBIN5,CBIN0 FIELD 55,56,57
CBE GSWBIN1,=W'1',FLDTOK
B FLDTNOK
*
FLDT50
PERF FLDIN,CBIN2,CBIN1,CBIN0,CBIN0 FIELD 6,28
CBE GSWBIN1,=W'1',FLDTOK
B FLDTNOK
*
FLDT51 TR 51
PERF FLDIN,CBIN2,CBIN1,CBIN0,CBIN0 FIELD 6 OR 28
CBNE GSWBIN1,=W'1',FLDTNOK
PERF FLDIN,CBIN1,CBIN15,CBIN0,CBIN0 FIELD 28 OR 48
CBG GSWBIN1,=W'1',FLDTNOK
CBNE GTUSED(CBIN5),=W'0',FLDT512 FIELD 14?
MOVE GTUSED(CBIN5),=W'14' INSERT FIELD 14
MOVE GTDUPF(CBIN5),=D'0' EQUAL 0
FLDT512
CBNE GTUSED(CBIN7),=W'0',FLDT513 FIELD 31?
MOVE GTUSED(CBIN7),=W'31' INSERT FIELD 31
MOVE GTDUPF(CBIN7),GTDATO EQUAL POST DATO
FLDT513
CLEAR BDEB
CBE GTUSED(CBIN1),=W'0',FLDT514 NOT FIELD 28
SET BDEB FIELD 28
FLDT514
FLDT518 SET P]L]R
CBNE GTUSED(CBIN11),=W'0',FLDT519 FIELD 15
* SET P]L]R = LAST DIGIT P]LDATO, INDEX 7 (51)
* SET P]L]R = LAST DIGIT [NDR]R, INDEX 7 (53)
MOVE GTUSED(CBIN11),=W'15' SET FIELD 15
MOVE TSWBCD2,GTDUPF(CBIN7) GET LAST DIGIT OF DATE
MOVE GTDUPF(CBIN11),TSWBCD2
FLDT519
CBNE GTUSED(CBIN2),=W'0',FLDT035 CHECK FLD 48, IF FLD 6
B FLDTOK
*
FLDT52
PERF FLDIN,CBIN2,CBIN1,CBIN0,CBIN0 FIELD 6,28
CBNE GSWBIN1,=W'1',FLDTNOK
PERF FLDIN,CBIN12,CBIN7,CBIN0,CBIN0 FIELD 33,40
CBE GSWBIN1,=W'2',FLDT525
PERF FLDIN,CBIN14,CBIN20,CBIN21,CBIN22 FIELD 42,43,44,45
CBNE GSWBIN1,=W'0',FLDTNOK
FLDT525
CBNE GTDUPF(CBIN17),=D'1',FLDT527 FIELD 46
CBE GTUSED(CBIN20),=W'0',FLDTNOK FIELD 43
FLDT527
CBE GTUSED(CBIN1),=W'0',FLDTOK FIELD 28
CBNE GTUSED(CBIN15),=W'0',FLDTNOK FIELD 48
B FLDTOK
*
FLDT53
PERF FLDIN,CBIN2,CBIN1,CBIN0,CBIN0 FIELD 6 OR 28
CBNE GSWBIN1,=W'1',FLDTNOK
PERF FLDIN,CBIN1,CBIN15,CBIN0,CBIN0 FIELD 28 OR 48
CBG GSWBIN1,=W'1',FLDTNOK
CBNE GTUSED(CBIN5),=W'0',FLDT532 FIELD 14?
MOVE GTUSED(CBIN5),=W'14' INSERT FIELD 14
MOVE GTDUPF(CBIN5),=W'0' EQUAL 0
FLDT532
CBNE GTUSED(CBIN7),=W'0',FLDT534 FIELD 40
MOVE GTUSED(CBIN7),=W'40' INSERT FIELD 40
MOVE GTDUPF(CBIN7),GTDATO EQUAL DATO
FLDT534
CLEAR BDEB
CBE GTUSED(CBIN1),=W'0',FLDT535 NOT FIELD 28
SET BDEB FIELD 28
FLDT535
B FLDT518 SEE TR 51
*
FLDT54
CBE GTUSED(CBIN1),=W'0',FLDTOK FIELD 28
CBNE GTUSED(CBIN15),=W'0',FLDTNOK FIELD 48
B FLDTOK
*
FLDTOK
CMP CBIN0,CBIN0 SET CR=0 OK
RET
*
FLDTNOK
CMP CBIN0,CBIN1 SET CR <> 0 NOT OK
RET
PEND
*
*
EJECT
FLDIN PROC FML1,FML2,FML3,FML4
********************
*
* FLDIN- TESTS HOW MANY OF THE GIVEN FIELDS
* (GIVEN BY INDEX) ARE PRESENT
* OUTPUT IN GSWBIN1
*
********************
MOVE GSWBIN1,=W'0'
CBE FML1,=W'0',FLD5
CBE GTUSED(FML1),=W'0',FLD1
ADD GSWBIN1,=W'1'
FLD1
CBE FML2,=W'0',FLD5
CBE GTUSED(FML2),=W'0',FLD2
ADD GSWBIN1,=W'1'
FLD2
CBE FML3,=W'0',FLD5
CBE GTUSED(FML3),=W'0',FLD3
ADD GSWBIN1,=W'1'
FLD3
CBE FML4,=W'0',FLD5
CBE GTUSED(FML4),=W'0',FLD5
ADD GSWBIN1,=W'1'
FLD5
RET
PEND
*
*
END