|
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: 33516 (0x82ec)
Notes: pts_type(SC)
Names: »SUBAPL.SC«
└─⟦22f4dea89⟧ Bits:30009702 Philips computer tape "DOS_PTS_4.2_M_FL"
└─⟦this⟧ »NJ-AMT/SUBAPL.SC«
└─⟦dab19bdd7⟧ Bits:30009677 Philips computer tape "600218"
└─⟦this⟧ »NJ-AMT/SUBAPL.SC«
IDENT SUBAPL 830907 EV
DDUM KMD08
PDIV
ENTRY SPAPPL
ENTRY SETKRE
ENTRY SETDEB
ENTRY CLRSW
ENTRY SELTR
ENTRY CHDATO
ENTRY XCOP
ENTRY YYMMDD
EXT PACKCL
EXT CRKJ
EXT KKCH
EXT KTPLAN
ENTRY REPL00
INCLUDE EQUATE
EJECT
SPAPPL PROC
********************
*
* SPAPPL - PROCEDURE ACTIVATED BY SCREEN PACKAGE IF APPL-VALUE
* IS NOT ZERO, WHICH IS THE CASE FOR ALL FIELDS.
*
* APPL-VALUE IS EQUAL TO FIELD-NAME (KMD FELT-KODE)
* A BRANCH IS MADE TO A PIECE OF CODE FOR RELEVANT
* TESTING AND BRANCH TO PACKING ROUTINE
*
********************
*
* SPBINW3 IS CURRENT APPL NUMBER
ART - RETURN
APK - PACK FIELD
APF - PACK FIELD WITH SIGN
AA01 - TEST FOR FIELD TO BE
---- - AUTODUPPED
AA02 - TEST FOR AUTODUP KEY
AA03 - IF LENGTH ZERO,
---- - DELETE FIELS
AA05 - TEST FIELD 5
AA06 - TEST FIELD 6
AA11 - TEST VALOERDATE
AA17 - TEST FORFALDSAAR
AA65 - IF AA05, AA06 THERE
---- - MIGHT BE A CHOICE
---- - OF NEW TRANSTYPE
A64 - TEST FIELD 64
A65 - TEST FIELD 65
AA70 - KONTONR WITHOUT CHECK
AA71 - 'ANTAL' IN TRANSTYPE
---- - 51, 53
A76 - COUNTER, TRANS 12
A77 - TR 4, INSERT BKO 51,52
A78 - ACCOUNT NO, TRANS 12
A79 - - - - - - (COPY)
A80-A87 - CHECK OF CONTROL
---- - INFORMATION FOR
---- - TRANSTYPES
A88 - AUTODUP BKO, TR 4
A89 - STORE IN FIELD 6
A90 - SPECIAL SLUT-FIELD
A91 - ENTER TO SLUT-KEY
A100 - CHECK TR 12
A101 - CHECK BEHL. COUNT.
A102 - REL. DAY
A103 - SET BEHL. COUNT
A104 - SET TRANS 12
A105 - CTRL.DIGIT CALC.
A106 - CHECK VALUE 0-3
A107 - AS A102
A108 - SPG -REGKONTONR
A109 - SPG-CPR/CIR/NR
A110 - SPG-BELOB
A111 - SPG-OTHER FIELD
A112 - CHECK TASKNR, START
*
CBG SPBINW3,=W'89',AAA SLUT FIELD OR DIV. CHECKS
*
*
AA01
IN FORMATS
CBNE SPBINW1,CBIN0,AAA IF LENGTH IS ZERO
MOVE GSWBIN4,CFLTDEX(SPBINW3) GET INDEX VALUE TO GSWBIN4
MOVE GTUSED(GSWBIN4),CBIN0 DELETE FIELD
B ART
*
AAA IB SPBINW3, C
ART,ART,ART,ART,A05,A06,A07,APF,ART, FIELDS 1-9 C
APK, C
A11, C
A12, C
APK, C
APK, C
APK, C
APK, C
A17, C
APK, C
APK, C
APK, C
APK, C
A22, C
A23, C
A24, C
A25, C
A26, C
A27, C
APK, C
APK, C
APK, C
APK, C
APK, C
APF, C
APK, C
APK, C
APK, C
A37, C
A38, C
APF, C
APK, C
APK, C
APK, C
APK, C
APK, C
APK, C
A46, C
APF, C
APK, C
APK, C
APK,APK,APF,APF,A54,APF,APF,APF,APF,APF, FIELDS 50-59 C
APF,APF,APF,APK,A64,A65,APK,ART,ART,ART, FIELDS 60-69 C
A70,A71,ART,ART,ART,ART,A76,A77,A78,A79, FIELDS 70,79 C
A80,A81,A82,A83,A84,A85,A86,A87,A88,A89, FIELDS 80-89 C
A90,A91,A92,A93,A94,ART,ART,ART,ART,ART, FIELDS 90,99 C
A100,A101,A102,A103,A104, FIELDS 100,104 C
A105,A106,A107,A108,A109, FIELDS 105,109 C
A110,A111,A112,ART,ART, FIELDS 110,114 C
ART,ART,ART,ART,ART,ART, C EMPTY
A121, C
A122, C
APK, C
APK, C
APK, C
ART, C
ART, C
ART, C
ART, C
A130, C
A131, C
A132, C
A133, C
A134, C
A135, C
A136, C
A137, C
A138
**********
A05 CHECK REGISTRERINGSKONTONUMMER
MOVE GSWBIN1,SPBINW1 GET LENGTH
CBE GSWBIN1,CBIN4,A059 LENGTH = 4?
CBL GSWBIN1,CBIN3,A065 TRANSTYPE HANDLING IN A065
CMP GSWBIN1,CBIN10 LENGTH MUST BE 10
BNE A058
MOVE GSWBCD1,SPINPUT
PERF KTPLAN,GSWBCD1,GTKTTYP
MOVE GSWBIN1,GTKTTYP
IB GSWBIN1, C
A053,A053,A051,A053,A053,A052,A0570,A0575
A051
B APK CPR NOT NECESSARY
A052 REMIT. NOT ALLOWED
IB GTREGDEX, C
A0520,A0520,A0520,A0520,A0520, TR 1,2,3,4,5 C
A0520,A0520,A0525,A0525,A0520, TR 6,7,8,9,10 C
A0520,A0525,A0525,A0525,A0525 TR 12,18,19,28,29
A0520
B APK
A0525
MOVE SPBINW4,CBIN20 ERROR
B ART
A053 CPR NECESSARY
IB GTREGDEX, C
A054,A055,A054,A054,A055, TR 1,2,3,4,5 C
A054,A055,A055,A054,A054, TR 6,7,8,9,10 C
A054,A055,A054,A055,A054 TR 12,18,19,28,29
A054
B APK
A055
CBL GSWBIN1,CBIN3,A056 ERROR
SET SPWARNFL WARNING
B A054
A056
MOVE SPBINW4,CBIN19
B ART
*
A0570 7: KNT.NO. NOT ALLOWED
MOVE SPBINW4,=W'23'
B ART
*
A0575 8:KNT.NO. NOT ALLOWED IN SUPL
CBE GTREGDEX,CBIN10,A0577 TR 10
TBT TTSUPFLG,A0577 SUPL
B APK OK
A0577 NOT OK
MOVE SPBINW4,CBIN22
B ART
*
A059
CBL GTREGNR,=D'48',A058 ONLY ALLOWED WHEN
CBG GTREGNR,=D'49',A058 IN BUDGET TR.48/49
B APK
*
A058
MOVE SPBINW4,CBIN3 SET ERRORCODE
B ART
**********
A06 CHECK CPR/CIR NUMBER
MOVE GSWBIN1,SPBINW1 GET LENGTH
CBL GSWBIN1,CBIN3,A065 TRANSTYPE HANDLING IN A065
PERF TESTAD
SET BCPR SET CPR-SWITCH (CPR-NO)
MOVE GSWBCD1,SPINPUT
CMP GSWBCD1,=D'10000000'
BL A061
SET BLEV LEVERAND.
CMP GSWBCD1,=D'3200000000'
BG APK
CLEAR BLEV CPR.
B APK
A061
CLEAR BCPR CLEAR CPR-SWITCH (CIR-NO)
B APK
******
A065
MOVE SPBINW1,CBIN0 SET LENGTH TO ZERO (FUNCTION)
MOVE GSWBCD3,SPINPUT GET NEW TRANSTYPE
*
CMP SPBINW2,=W'30' ADM ROUTINE
BE ART
CMP SPBINW2,=W'31' CYCLE
BE ART
*
* CHECK FOR VALID TRANSTYPE
*
* ADJUST REGDEX
A0655
*
MOVE GSWBIN1,CBIN1
* TEST FOR CORRECT TRANSACTIONS IN THIS CONNECTION
TBT GTKASSE,A0672
CBG GSWBCD3,=D'30',A067 CORRECT FOR NOT IN KASSE
B A0675
A0672
CBL GSWBCD3,=D'30',A067 CORRECT IN KASSE
B A0675
*
A067
CBE GSWBCD3,CREGTAB(GSWBIN1,GTCLASS),A068 SEARCH REGNR
ADD GSWBIN1,CBIN1 ADD 1 TO INDEX
CBNE CREGTAB(GSWBIN1,GTCLASS),=D'-1',A067 END OF TABLE?
*
A0675
MOVE SPBINW4,CBIN9 INVALID TRANSTYPE
B ART
A068
TBF TTCY5FLG,A069 IN CYK 5?
CBL GSWBCD3,=D'8',A0675 IF SO, ONLY TRANS
CBG GSWBCD3,=D'9',A0675 8/9 ALLOWED
A069
TAKE CARE OF NEW TRANSTYPE
CBE SPBINW2,CBIN18,A06KRE HANDLING OF KREDIT KEY
CBE SPBINW2,CBIN17,A06DEB SLUT/DEB KEY
CBE SPBINW2,CBIN3,A06DEB HANDLING OF DEBIT KEY
MOVE SPBINW4,CBIN4 HANDLING OF WRONG KEY
B ART
A06KRE
PERF SETKRE
B A066
A06DEB
PERF SETDEB
A066
MOVE GTREGNR,GSWBCD3
MOVE GTREGDEX,GSWBIN1
SET GTREGFLG VALID TRANSTYPE FOUND
SET TTEORFLG START NEW TRANS
*
MOVE SPBINW2,=W'36' SIMULATE TRANSACTION SELECTED
B ART
**********
A07 BKO FIELD
INSERT TEXT IN TT07TXT
CLEAR TTASKAT
MOVE GSWBCD3,SPINPUT
CBNE GSWBCD3,=D'51',A070
SET TTASKAT
A070
CBNE GTREGDEX,CBIN3,A0705
CBE GSWBCD3,=D'51',A076 TRANS 3
CBE GSWBCD3,=D'52',A076
A0705
MOVE GSWBIN1,CBIN0 GET LENGTH OF STRING
COPY TT07TXT,CBIN0,CBIN5,CTTXT07,GSWBIN1
MOVE GSWBCD3,TT07TXT
MOVE GSWBIN2,GSWBCD3
MOVE TT07TXT,CBLANKS
MOVE GSWBIN1,CBIN5 FIRST CHAR, POINTER
MOVE GSWBIN3,CBIN0
CBNG SPBINW1,CBIN2,A071
MOVE GSWBIN3,CBIN1 ADJUST DUPPED FIELD INDEX
A071
SUB GSWBIN1,CBIN7
A0708
ADD GSWBIN1,CBIN7
CBG GSWBIN1,GSWBIN2,A075
MATCH CTTXT07,GSWBIN1,CBIN2,SPINPUT,GSWBIN3,CBIN2
BNOK A0708
* NEXT 5 CHARS CONTAIN TEXT
ADD GSWBIN1,CBIN2
COPY TT07TXT,CBIN0,CBIN5,CTTXT07,GSWBIN1
* SEE IF ALLOWED
CBNE GTREGDEX,CBIN3,A077 ONLY CHECK IF TRANSTYPE 3
ADD GSWBIN1,CBIN5
MOVE GSWSTR2,CBLANKS
COPY GSWSTR2,CBIN1,CBIN1,CTTXT07,GSWBIN1 GET TYPE
MOVE GSWBCD3,GSWSTR2
CBE GSWBCD3,=D'0',A077 OK
CBL GTREGF(CBIN2),=D'10000000',A072
CBE GSWBCD3,=D'1',A077 CPR - BKO ALLOWED
B A076
A072
CBE GSWBCD3,=D'2',A077 CIR - BKO ALLOWED
B A076
A075
TBT CBKOFLG,A077
A076
MOVE SPBINW4,CBIN11
B ART
A077
PERF TESTAD
B APK
**********
A11 CHECK VAL DATE NOT GREATER
THAN POST DATE
CBE GTREGDEX,CBIN3,A0110 TRANS 3
CBE GTREGDEX,CBIN4,A0110 TRANS 4
PERF TESTAD
B APK
A0110
* GET AND CHANGE VALOERDATE
MOVE GSWBCD6,SPINPUT
COPY GSWBCD3,CBIN4,CBIN2,GSWBCD6,CBIN12
COPY GSWBCD6,CBIN12,CBIN2,GSWBCD6,CBIN8
COPY GSWBCD6,CBIN8,CBIN2,GSWBCD3,CBIN4
* GET AND CHANGE POSTDATE
MOVE GSWBCD1,GTDATO
COPY GSWBCD3,CBIN4,CBIN2,GSWBCD1,CBIN12
COPY GSWBCD1,CBIN12,CBIN2,GSWBCD1,CBIN8
COPY GSWBCD1,CBIN8,CBIN2,GSWBCD3,CBIN4
* COMPARE
CMP GSWBCD6,GSWBCD1
BNG APK
MOVE SPBINW4,CBIN7
B ART
**********
A12
A22
A23
A24
A25
A26
A27
A37
A38
A46
PERF TESTAD
B APK
**********
A17 CHECK 'FORFALDSAAR' FAAR
FAAR >= 70
FAAR <= YY+2
MOVE GSWBCD6,SPINPUT GET FAAR
CBL GSWBCD6,=D'70',A17ERR LESS THAN 70: ERROR
MOVE GSWBCD1,GTDATO GET POSTDATO
MOVE GSWBCD3,=D'2'
COPY GSWBCD3,CBIN4,CBIN2,GSWBCD1,CBIN12 GET YEAR
ADD GSWBCD3,=D'2' ADD 2
CBG GSWBCD6,GSWBCD3,A17ERR MORE THAN YY+2
B APK
A17ERR
MOVE SPBINW4,CBIN11 INVALID NUMBER
B ART
**********
A54 FIELD 54 HAS BEEN ENTERED
MOVE GSSWITCH(CBIN2),CBIN1 AND SHOULD BE AUTODUPPED
B APK
**********
A64
MOVE GSWBCD3,SPINPUT GET 'PRISREGULERINGSKODE'
CBG GSWBCD3,=D'5',A649
CBL GSWBCD3,=D'0',A649
FIELD 64 HAS BEEN ENTERED AND
MOVE GSSWITCH(CBIN12),CBIN1 SHOULD BE GTAUTODPPED
B APK
A649
MOVE SPBINW4,CBIN10
B ART
**********
A65 CHECK VALUE 1000-3999
MOVE GSWBCD4,SPINPUT GET VALUE
CBG GSWBCD4,=D'3999',A659
CBL GSWBCD4,=D'1000',A659
B APK
A659
MOVE SPBINW4,CBIN11
B ART
**********
A70 KONTONR WITHOUT CHECK
MOVE SPBINW3,CBIN5
CMP SPBINW1,CBIN3
BL A065 IF LENGTH < 3
B APK NEW TRANSTYPE
**********
A71
MOVE GSSWITCH(CBIN1),CBIN1 SET AUTODUP
MOVE GTSUM,SPINPUT
SUB GTSUM,=D'1' SUB 1 FROM ANTAL
MOVE SPINPUT,GTSUM
CBL GTSUM,=D'0',A715
CMP GTSUM,=D'12' IF > 12
BL ART
A715
MOVE SPINPUT,=C'51' SIMULATE NEW
MOVE SPBINW2,CBIN3 TRANSTYPE
MOVE GSSWITCH(CBIN1),CBIN0 DELETE AUTODUP
B A065
**********
A76 COUNTER NO, TRANS 12
CMP SPBINW1,CBIN3
BL A065 TRANSTYPE HANDLING
MOVE GSWBCD3,SPINPUT GET VALUE
MOVE TTCNTNR,SPINPUT
SUB GSWBCD3,=D'100' GET INDEX
MOVE GSWBIN1,GSWBCD3
CBG GSWBIN1,CTR12(GTUWB,CBIN2),A76NOK
CBL GSWBCD3,=D'1',A76NOK MIN COUNTER NO
ADD GSWBIN1,CTR12(GTUWB,CBIN1)
CBE CTR12NR(GSWBIN1),=D'0',A76NOK
MUST BE > 0
B ART TO WRITE ON SCREEN
A76NOK
MOVE SPBINW4,CBIN18
B ART
**********
A77 INSERT 51,52 IN TR 4
MOVE SPBINW3,CBIN7 FIELD 7
MOVE SPBINW1,CBIN2 LENGTH
TBT BCPR,A775
MOVE SPINPUT,=X'35310000' 51 IF CIR
B A07
A775
MOVE SPINPUT,=X'35320000' 52 IF CPR
B A07
**********
A78 INSERT ACCOUNT NO
11-15
MOVE SPBINW3,CBIN5 SIMULATE FIELD 5
B APK
********
A79 AUTODUP ACCOUNT NO
MOVE SPBINW3,CBIN5 IN FIELD 5
MOVE GSWBIN1,TTCNTNR GET COUNTER NO
SUB GSWBIN1,=W'100'
ADD GSWBIN1,CTR12(GTUWB,CBIN1)
MOVE SPINPUT,CTR12NR(GSWBIN1)
MOVE SPBINW1,CBIN10 LENGTH
B APK
**********
A80 CHECK HOVEDBOG, KONTONR
MOVE SPBINW3,CBIN5 FIELD 5
MOVE SPBINW5,CBIN2 MIGHT BE TRANSTYPE 2
CBL SPBINW1,CBIN3,A805 CHECK LENGTH
CBE SPBINW1,CBIN10,A801 MUST BE 10
MOVE SPBINW4,CBIN3 ERROR LENGTH
B ART
A801
MOVE GSWBCD1,SPINPUT
PERF KTPLAN,GSWBCD1,GTKTTYP
PERF SELTR TRANS SELECTED
BNOK ART INVALID KEY
B APK OK
A805 CHECK FUNCTION KEYS
MOVE SPBINW1,CBIN0
CMP SPBINW2,=W'30' ADM KEY
BE ART
CMP SPBINW2,=W'31' CYCLE KEY
BE ART
MOVE SPBINW4,CBIN4 INVALID KEY
B ART
**********
A81 CHECK HOVEDBOG, CPR/CIR/NR
MOVE SPBINW3,CBIN6 FIELD 6
MOVE SPBINW5,CBIN1 MIGHT BE TRANS TYPE 1
CBG SPBINW1,CBIN2,A811 CHECK LENGTH
MOVE SPBINW4,CBIN3 ERROR LENGTH
B ART
A811 CPR OR CIR ?
SET BCPR SET CPR NO
MOVE GSWBCD1,SPINPUT
CBL GSWBCD1,=D'10000000',A814
SET BLEV
CBG GSWBCD1,=D'3200000000',A812
CLEAR BLEV
B A812
A814
CLEAR BCPR SET CIR NO
A812
PERF SELTR TRANS SELECTED
BNOK ART INVALID KEY
B APK OK
**********
A82 CHECK HOVEDBOG, YD.MODT.
MOVE SPBINW3,CBIN21 FIELD 21
MOVE SPBINW5,CBIN6 MIGHT BE TRANSTYPE 6
A821
CBNE SPBINW2,CBIN3,A822 IF ENTER KEY,
MOVE SPBINW2,CBIN17 SIMULATE DEBET KEY
A822
PERF SELTR TRANS SELECTED
BNOK ART INVALID KEY
B APK OK
**********
A83 CHECK DEBITOR, DEBITOR NR
MOVE SPBINW3,CBIN6 FIELD 6
CBL SPBINW1,CBIN3,A805 FUNCTION?
CBL SPBINW1,CBIN7,A833
MOVE SPBINW5,CBIN4 MIGHT BE TRANSTYPE 4
SET BCPR SET CPR
MOVE GSWBCD1,SPINPUT
CBL GSWBCD1,=D'10000000',A831
SET BLEV
CBG GSWBCD1,=D'3200000000',A832
CLEAR BLEV
B A832
A831
CLEAR BCPR SET CIR
A832
PERF SELTR
BNOK ART
MOVE SPBINW2,CBIN3
B APK
A833
MOVE SPBINW4,CBIN3 ERROR LENGTH
B ART
**********
A84 CHECK DEBITOR, BKO
MOVE SPBINW3,CBIN7 FIELD 7
MOVE SPBINW5,CBIN3 MIGHT BE TRANSTYPE 3
CBNE SPBINW2,CBIN3,A842
MOVE SPBINW2,CBIN17
A842
MOVE GSWBCD1,SPINPUT
CBE GSWBCD1,=D'+51',A845
CBE GSWBCD1,=D'+52',A845
A843
PERF SELTR
BNOK ART
B A07
A845
MOVE SPBINW5,CBIN4
B A843
**********
A85 CHECK REMITTERING, KONTONR
MOVE SPBINW3,CBIN5 FIELD 5
CBL SPBINW1,CBIN3,A805 CHECK LENGTH
CBE SPBINW1,CBIN10,A850 MUST BE 10
MOVE SPBINW4,CBIN3 ERROR LENGTH
B ART
A850
CMP SPBINW2,CBIN3 ONLY ENTER-KEY ALLOWED
BNE A855
MOVE GSWBCD1,SPINPUT
PERF KTPLAN,GSWBCD1,GTKTTYP
B APK
A855
MOVE SPBINW4,CBIN4 INVALID KEY
B ART
**********
A86 CHECK REMITTERING, LEV.NR.
MOVE SPBINW3,CBIN6 FIELD 6
MOVE SPBINW5,CBIN8 MIGHT BE TRANSTYPE 8
CBG SPBINW1,CBIN2,A811 CHECK LENGTH + CPR/CIR
MOVE SPBINW4,CBIN3 ERROR LENGTH
B ART
**********
A87 CHECK REMITTERING, YD.MODT.
MOVE SPBINW3,CBIN21 FIELD 21
MOVE SPBINW5,CBIN9 MIGHT BE TRANSTYPE 9
B A821 CHECK FOR INVALID KEY
**********
A88
MOVE SPBINW3,CBIN7 FIELD 7
MOVE SPBINW2,=W'36'
MOVE SPBINW1,='2'
TBT BCPR,A885
MOVE SPINPUT,=X'35310000' 51 IF CIR
B A07
A885
MOVE SPINPUT,=X'35320000' 52 IF CPR
B A07
**********
A89
MOVE SPBINW3,CBIN6 STORE IN FIELD 6
B APK
**********
A90
PERF SPACES
MOVE GTFELT90(CBIN1),SPINPUT
PERF TESTAD
B APK
***
A91
PERF SPACES
MOVE GTFELT90(CBIN2),SPINPUT
PERF TESTAD
B APK
***
A92
PERF SPACES
MOVE GTFELT90(CBIN3),SPINPUT
PERF TESTAD
B APK
***
A93
PERF SPACES
MOVE GTFELT90(CBIN4),SPINPUT
PERF TESTAD
B APK
***
A94
PERF SPACES
MOVE GTFELT90(CBIN5),SPINPUT
PERF TESTAD
B APK
**********
A100 CHECK TR 12 COUNTERS
MOVE GSWBCD1,SPINPUT
SUB GSWBCD1,=D'100'
MOVE GSWBIN6,GSWBCD1
CBL GSWBIN6,CBIN1,A1009 TOO SMALL
CBG GSWBIN6,CTR12(GTUWB,CBIN2),A1009 TOO HIGH
ADD GSWBIN6,CTR12(GTUWB,CBIN1)
B ART
A1009
MOVE SPBINW4,CBIN11
B ART
**********
A101 CHECK BEHL. COUNTERS
MOVE GSWBCD1,SPINPUT
CBL GSWBCD1,=D'1',A101ER
MOVE GSWBIN6,GSWBCD1
CBG GSWBIN6,CBEH(GTUWB,CBIN2),A101ER
ADD GSWBIN6,CBEH(GTUWB,CBIN1)
B ART
A101ER
MOVE SPBINW4,CBIN11
B ART
**********
A102 CHECK RELATIVE DAY
MOVE GSWBCD7,CMASKDAT
A102A
MOVE GSWBCD5,=D'2' INITIATE REL DAY NO.
MOVE GSWBCD3,=D'1' BLANK GSWBCD3
MOVE GSWBIN2,CBIN8 SET POINTER TO DAY
COPY GSWBCD3,CBIN4,CBIN2,GSWBCD7,GSWBIN2 GET DAY
ADD GSWBCD5,GSWBCD3 ADD DAY TO REL. DAY
ADD GSWBIN2,CBIN2 SET POINTER TO MONTH
COPY GSWBCD3,CBIN4,CBIN2,GSWBCD7,GSWBIN2 GET MONTH
SUB GSWBCD3,=D'1' GET WHOLE NO. OF MONTHS
MUL GSWBCD3,=D'30' EQUAL IN DAYS
ADD GSWBCD5,GSWBCD3
MOVE GSWBCD3,SPINPUT GET KEYED REL. DAY
SUB GSWBCD5,=D'5'
CBL GSWBCD3,GSWBCD5,A102ER TOO SMALL
ADD GSWBCD5,=D'10'
CBG GSWBCD3,GSWBCD5,A102ER TOO LARGE
B A102END
A102ER
MOVE SPBINW4,CBIN11 INVALID VALUE
A102END
MOVE GSWBCD3,=X'FF'
B ART
**********
A103 SET BEHL. COUNTERS
MOVE GSWBCD3,SPINPUT
MOVE GSWBIN6,GSWBCD3
ADD GSWBIN6,CBEH(GSWBIN1,CBIN1)
CBG GSWBIN6,=W'60',A103ER TOO MANY
CBE GSWBIN1,CBIN12,A1035
ADD GSWBIN1,CBIN1
MOVE CBEH(GSWBIN1,CBIN1),GSWBIN6
SUB GSWBIN1,CBIN1
A1035
MOVE GSWBIN6,GSWBCD3
MOVE CBEH(GSWBIN1,CBIN2),GSWBIN6
B ART
A103ER
MOVE SPBINW4,CBIN11
B ART
**********
A104 SET TR 12 COUNTERS
MOVE GSWBCD4,SPINPUT
MOVE GSWBIN6,GSWBCD4
ADD GSWBIN6,CTR12(GSWBIN1,CBIN1)
CBG GSWBIN6,=W'60',A104ER TOO MANY
CBE GSWBIN1,CBIN12,A1045
ADD GSWBIN1,CBIN1
MOVE CTR12(GSWBIN1,CBIN1),GSWBIN6
SUB GSWBIN1,CBIN1
A1045
MOVE GSWBIN6,GSWBCD4
MOVE CTR12(GSWBIN1,CBIN2),GSWBIN6
B ART
A104ER
MOVE SPBINW4,CBIN11
B ART
**********
A105 CONRTL.DIGITCALC.
MOVE GSWBCD6,SPINPUT
CBE SPBINW2,CBIN3,CALCD01
CMP SPBINW2,CBIN17
BNE ART
CALCD01
MOVE GSWBIN1,SPBINW1 GET LENGTH
MOVE GSWBIN2,CBIN13
MOVE GSWBCD5,=D'0'
CALCD02
MOVE GSWBCD3,=D'0'
COPY GSWBCD3,CBIN5,CBIN1,GSWBCD6,GSWBIN2 GET NEXT DIGIT
MUL GSWBCD3,WEIGTH(GSWBIN2) MULTIPLY BY WEIGHT
ADD GSWBCD5,GSWBCD3 ADD TO OLD SUM
SUB GSWBIN1,CBIN1 ADJUST LENGTH
SUB GSWBIN2,CBIN1 ADJUST WEIGHT-INDEX
CBG GSWBIN1,=W'0',CALCD02
MOVE GSWBCD4,GSWBCD5
DIV GSWBCD5,=D'11'
MUL GSWBCD5,=D'11'
SUB GSWBCD4,GSWBCD5 GET REMAINDER MOD 11
CBNE GSWBCD4,=D'0',CALCD05
MOVE GSWBCD4,=D'11'
CALCD05
MOVE GSWBCD5,=D'11'
SUB GSWBCD5,GSWBCD4 CALCULATE CONTROLDIGIT
B ART
**********
A106 CHECK VALUE 0-3
MOVE GSWBCD3,SPINPUT GET VALUE
CBNL GSWBCD3,=D'6',A106A
B ART
A106A
MOVE SPBINW4,CBIN11 ERROR 'OUT OF RANGE'
B ART
**********
A107 REL DAY, 'POSTERINGSDATO'
MOVE GSWBCD7,GTDATO
B A102A
**********
A108 SPG-REGKONTONR
MOVE GSWBCD6,=D'5'
B ART
**********
A109 SPG-CPR/CIR/NR
MOVE GSWBCD6,=D'6'
B ART
**********
A110 SPG-BELOB
MOVE GSWBCD6,=D'8'
B ART
**********
A111 SPG-OTHER FIELD
MOVE GSWBCD6,SPINPUT
CBG GSWBCD6,=D'90',A111ERR
MOVE GSWBCD7,=D'0'
B ART
A111ERR
MOVE SPBINW4,CBIN11
B ART
**********
A112
* CHECK TASKNR IN SYSTEMSTART
MOVE GSWBCD6,SPINPUT
MOVE GSWBIN2,GSWBCD6
CBG GSWBIN2,CMAXTASK,A112ERR
CBL GSWBIN2,CBIN1,A112ERR
CBNE GSWBCD5,=D'1',A112OK
CBNE GSWBCD6,=D'1',A112ERR
A112OK
B ART
A112ERR
MOVE SPBINW4,CBIN11
B ART
**********
A121 SIMULATE SLUT KEY
CLEAR GTSLUTFL
CLEAR GTADUPFL
MOVE SPBINW2,CBIN17 SLUT KEY
MOVE SPBINW1,=W'0' LENGTH ZERO
B ART
**********
A122 ENTER TO SLUT KEY
CMP SPBINW2,CBIN3
BNE ART
MOVE SPBINW2,CBIN17
B ART
**********
A130
MOVE GSWBCD3,SPINPUT
MOVE GSWBIN1,GSWBCD3
IB GSWBIN1,A1301,A1302,A1303
MOVE SPBINW4,CBIN11
B ART
A1301
MOVE GTSTRFMT,=C'SYSSTART '
B A1305
A1302
MOVE GTSTRFMT,=C' RESTART '
B A1305
A1303
MOVE GTSTRFMT,=C' RESTORE '
A1305
MOVE GSWBIN1,=X'0516'
DSC1 SCREEN,POS,GSWBIN1
EDWRT SCREEN,STRTFRM
B ART
**********
A131
MOVE GSWBCD3,SPINPUT
MOVE GSWBIN1,GSWBCD3
IB GSWBIN1,A1311,A1312,A1313
MOVE SPBINW4,CBIN11
B ART
A1311
MOVE GTSTRFMT,=C'SYSVOL '
B A1315
A1312
MOVE GTSTRFMT,=C'REGVOL '
B A1315
A1313
MOVE GTSTRFMT,=C'AFBRYD '
A1315
MOVE GSWBIN1,=X'0711'
DSC1 SCREEN,POS,GSWBIN1
EDWRT SCREEN,STRTFRM
B ART
**********
STRTFRM FRMT
FILLR '+',2
FCOPY GTSTRFMT
FMEND
**********
A132
MOVE GSWBCD1,SPINPUT
MOVE GSWBIN1,=X'0301'
DSC1 SCREEN,POS,GSWBIN1
EDIT CVOL(CBIN2),A132FMT2
EDIT CVOL(CBIN3),A132FMT3
EDIT CVOL(CBIN4),A132FMT4
EDWRT SCREEN,A132FMT1
B ART
A132FMT1 FRMT
FILLR '+',2
FCOPY CVOL(CBIN2)
FILLR ' ',1
FCOPY CVOL(CBIN3)
FILLR ' ',1
FCOPY CVOL(CBIN4)
FMEND
A132FMT2 FRMT
FMEL '999',GSWBCD1
FTEXT '002'
FMEND
A132FMT3 FRMT
FMEL '999',GSWBCD1
FTEXT '003'
FMEND
A132FMT4 FRMT
FMEL '999',GSWBCD1
FTEXT '004'
FMEND
**********
A133
MOVE GSWBIN1,=W'40'
PERF REPL00,SPINPUT,GSWBIN1
PERF XCOP,CDUM0,=W'0',=W'40',SPINPUT,=W'0'
B ART
A134
MOVE GSWBIN1,=W'40'
PERF REPL00,SPINPUT,GSWBIN1
PERF XCOP,CDUM0,=W'40',=W'40',SPINPUT,=W'0'
B ART
A135
MOVE GSWBIN1,=W'40'
PERF REPL00,SPINPUT,GSWBIN1
PERF XCOP,CDUM0,=W'80',=W'40',SPINPUT,=W'0'
B ART
A136
MOVE GSWBIN1,=W'40'
PERF REPL00,SPINPUT,GSWBIN1
PERF XCOP,CDUM0,=W'120',=W'40',SPINPUT,=W'0'
B ART
A137
MOVE GSWBIN1,=W'40'
PERF REPL00,SPINPUT,GSWBIN1
PERF XCOP,CDUM0,=W'160',=W'40',SPINPUT,=W'0'
B ART
*****
A138 DEFAULT DAYNBR
MOVE GSWBCD6,SPINPUT DDMM]]
DIV GSWBCD6,=D'100' DDMM
MOVE GSWBCD7,GSWBCD6 DDMM
DIV GSWBCD7,=D'100' DD
MOVE GSWBCD1,GSWBCD7 DD
MUL GSWBCD7,=D'100' DD00
SUB GSWBCD6,GSWBCD7 MM
MOVE GSWBIN1,GSWBCD6 MM
IB GSWBIN1,A13801,A13802,A13803,A13804, C
A13805,A13806,A13807,A13808, C
A13809,A13810,A13811,A13812
A13812 ADD GSWBCD1,=D'30'
A13811 ADD GSWBCD1,=D'31'
A13810 ADD GSWBCD1,=D'30'
A13809 ADD GSWBCD1,=D'31'
A13808 ADD GSWBCD1,=D'31'
A13807 ADD GSWBCD1,=D'30'
A13806 ADD GSWBCD1,=D'31'
A13805 ADD GSWBCD1,=D'30'
A13804 ADD GSWBCD1,=D'31'
A13803 ADD GSWBCD1,=D'28'
A13802 ADD GSWBCD1,=D'31'
A13801
A13813
MOVE GSWBCD6,SPINPUT DDMM]]
DIV GSWBCD6,=D'100' DDMM
MUL GSWBCD6,=D'100' DDMM]]
MOVE GSWBCD7,SPINPUT DDMM]]
SUB GSWBCD7,GSWBCD6 AA
MOVE GSWBCD6,GSWBCD7 ]]
DIV GSWBCD6,=D'4' ]]//4
MUL GSWBCD6,=D'4' ]]-(]] MOD 4)
CBNE GSWBCD6,GSWBCD7,A13814 NOT LEAPYEAR
CBL GSWBIN1,CBIN3,A13814
ADD GSWBCD1,=D'1'
A13814
MOVE GSWBIN1,=X'040D'
DSC1 SCREEN,POS,GSWBIN1
MOVE CRELDAY,GSWBCD1
EDWRT SCREEN,DAYFRM
B ART
DAYFRM FRMT
FILLR '+',2
FMEL '999',CRELDAY
FMEND
**********
APK KEEP INFORMATION
TBF TTEORFLG,APK00 FIRST FIELD?
CBE SPBINW3,CBIN5,APK10
MOVE GTKTTYP,=D'0' NOT KONTONR.
APK10
PERF PACKCL YES, CLEAR GTUSED
SET SPME CHECK FOR ME FIELDS
TBF TSPOOL,APK20
TBT CSPOOL,APK00
APK20
PERF CRKJ
APK00
MOVE GSWBIN1,CFLTDEX(SPBINW3) GET INDEX OF FIELD
MOVE GTUSED(GSWBIN1),SPBINW3 STORE FIELDNUMBER
B ART
**********
APF
TBF TTEORFLG,APF00 FIRST FIELD?
MOVE GTKTTYP,=D'0'
PERF PACKCL YES, CLEAR GTUSED
SET SPME CHECK FOR ME FIELDS
TBF TSPOOL,APF20
TBT CSPOOL,APF00
APF20
PERF CRKJ
APF00
TBT SPDUPL,APF10
MOVE GSWBCD6,SPINPUT GET VALUE
MUL GSWBCD6,GTDBKRS
MOVE SPINPUT,GSWBCD6
APF10
MOVE GSWBIN1,CFLTDEX(SPBINW3) GET INDEX OF CURRENT FIELD
* MULTIPLY WITH -1 IF KREDIT
* STORE NEGATIVE FIELD NUMBER (NUMBER WITH SIGN)
MOVE GTUSED(GSWBIN1),SPBINW3
MUL GTUSED(GSWBIN1),=W'-1'
B ART
**********
ART
MOVE SPBINW3,CBIN1
CBL SPBINW4,CBIN3,ARET
MOVE SPBINW3,CBIN3
ARET
RET
PEND
SPACES PROC
MOVE GSWBIN1,=W'41'
PERF REPL00,SPINPUT,GSWBIN1
RET
PEND
EJECT
SETKRE PROC
********************
*
* SETKRE - SET KREDIT INFORMATION
*
********************
MOVE GTDBKRC,=C' KRE'
MOVE GTDBKRS,=D'-1'
MOVE TTDKBCD,=D'1'
MOVE TTDKDEX,CBIN1
RET
PEND
*
SETDEB PROC
********************
*
* SETDEB - SET DEBET INFORMATION
*
********************
MOVE GTDBKRC,=C' DEB'
MOVE GTDBKRS,=D'+1'
MOVE TTDKBCD,=D'2'
MOVE TTDKDEX,CBIN2
RET
PEND
*
CLRSW PROC
********************
*
* CLRSW - CLEAR ALL AUTODUP FLAGS
*
********************
MOVE GSWBIN1,CBIN1
CLRSW1
MOVE GSSWITCH(GSWBIN1),CBIN0
ADD GSWBIN1,CBIN1
CBL GSWBIN1,CBINMAX,CLRSW1
RET
PEND
*
SELTR PROC
********************
*
* SELTR - PROCEDURE TO SEE IF TRANSTYPE HAS BEEN
* SELECTED.
* SELECTED TRANSTYPE IS IN SPBINW5
*
********************
CBE SPBINW2,CBIN3,SELOK ENTER KEY
CBE SPBINW2,CBIN18,SEL10 KREDIT KEY
CBE SPBINW2,CBIN17,SEL20 DEBET KEY
MOVE SPBINW4,CBIN4 INVALID KEY
CMP CBIN1,CBIN0 NOK, SET CR<>0
RET
SEL10 KREDIT
PERF SETKRE
B SEL30
SEL20 DEBET
PERF SETDEB
SEL30 TRANSTYPE SELECTED
MOVE GSWBIN1,GTKTTYP
IB GSWBIN1, C
SEL40,SEL40,SEL90,SEL40,SEL40
B SEL90
SEL40
IB SPBINW5, C
SEL90,SEL45,SEL90,SEL90,SEL90,SEL90,SEL90,SEL45,SEL90
SEL45
CBL GSWBIN1,CBIN3,SEL50
SET SPWARNFL WARNING
B SEL90
SEL50
MOVE SPBINW4,CBIN19 ERROR
CMP CBIN1,CBIN0
RET
SEL90
MOVE GTREGNR,SPBINW5 TYPE
MOVE GTREGDEX,SPBINW5 TYPE INDEX. OK FOR <11
MOVE SPBINW2,=W'36' SIMULATE TRANS SELECTED
SET GTTRSEL
SELOK
CMP CBIN0,CBIN0 OK, SET CR=0
RET
PEND
*
YYMMDD PROC P
**********
* YYMMDD CHECKS THAT THE DATE IS IN FOR FORMAT YYMMDD.
* IF NOT, IT WILL BE INVERTED
* OUTPUT IN GSWBCD7
**********
MOVE GSWBCD7,P
CBG P,=D'800000',YYMM90
MOVE GSWBCD6,P
XCOPY GSWBCD7,CBIN6,CBIN1,GSWBCD6,CBIN4
XCOPY GSWBCD7,CBIN4,CBIN1,GSWBCD6,CBIN6
YYMM90
RET
PEND
CHDATO PROC
**********
* CHANGES GSWBCD6 (DDMMYY) TO
* GSWBCD7 (YYMMDD)
**********
MOVE GSWBCD7,GSWBCD6
XCOPY GSWBCD7,CBIN6,CBIN1,GSWBCD6,CBIN4
XCOPY GSWBCD7,CBIN4,CBIN1,GSWBCD6,CBIN6
RET
PEND
*
XCOP PROC TO,$TOPNT,$SIZE,FROM,$FROMPNT
PLIT $TOPNT
PLIT $SIZE
PLIT $FROMPNT
MOVE GSWBIN1,$TOPNT START OF RECEIVING FIELD
MOVE GSWBIN4,$SIZE LENGTH
MOVE GSWBIN5,$FROMPNT START OF SENDING FIELD
XCOPY TO,GSWBIN1,GSWBIN4,FROM,GSWBIN5
RET
PEND
*
REPL00 PROC STRG,LEN
MOVE GSWBIN7,LEN
MOVE GSWBIN1,CBIN0
MOVE GSWSTR1,=X'00'
MATCH STRG,GSWBIN1,GSWBIN7,GSWSTR1,CBIN0,CBIN1
BNE REPL10
SUB GSWBIN7,GSWBIN1
DLETE STRG,GSWBIN1,GSWBIN7
CMP CBIN0,CBIN0
RET
REPL10
CMP CBIN1,CBIN0
RET
PEND
TESTAD PROC
* TEST FOR AUTODUP FIELDS (TANS 8/9)
TBF TTCY5FLG,TESTAD1 CYK 5 IN PROGRESS?
MOVE GSWBIN1,CFLTDEX(SPBINW3)
MOVE GSSWITCH(GSWBIN1),SPBINW3
TESTAD1
RET
PEND
END