|
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: 58930 (0xe632)
Notes: pts_type(SC)
Names: »PLADS.SC«
└─⟦025d39960⟧ Bits:30009672 Philips computer tape "600133"
└─⟦this⟧ »A:DSB/PLADS.SC«
IDENT PLADS 831223 NJ * * DATA DIVISION FOR DSB-PLADS * DDIV * * * KEYBOARD TASK * TERM K0 CWB CB9 CWB CB1 CWB CB2 TWB TB1 TWB TB2 TWB TB3 PDU DSET FC=50,BUFL=300 KEYB DSET FC=20 GTP DSET FC=30,BUFL=300 LAMPS DSET FC=40 DC DSET FC=61 DC2 DSET FC=61 START KBGO EJECT * * DC TASK * TERM D0 CWB CB9 CWB CB1 CWB CB2 DSDC DSET FC=60 START DC1GO CB9 BLK * CPOLL BOOL F TRUE AFTER 1. POLL MF1KBV STRG 64X'404142434445464748494A4B4C4D4E4F C 505152535455565758595A5B5C5D5E5F' MF1CU BIN X'6040' BINWK1 BIN DCBUF STRG 300 EJECT CB1 BLK * W0 BIN '0' W1 BIN '1' W2 BIN '2' W3 BIN '3' W4 BIN '4' W5 BIN '5' W6 BIN '6' W7 BIN '7' W8 BIN '8' W9 BIN '9' W10 BIN '10' W12 BIN '12' W40 BIN '40' LPAT1 BIN X'0010' PAPER OUT PATTERN LPAT2 BIN X'8000' AUDIBLE ALARM PATTERN CB2 BLK * CHOME BIN X'0101' CURSOR HOME CTEST BIN '0' 0 - PRODUCTION VERSION 1 - SIDDEPLADS 2 - FAERGEBILLET 3 - SP-SP-LF-LF CTIMOUT BIN '1450' READ/WRITE TIMEOUT CBUFLEN BIN '300' DC BUFFERLENGTH CINX BINI (35),'0','9','10','11','46','47','48','54','55', C '56','57','58','59','60','61','62', C '65','66','67','68','73','74','75','80', C '81','84','85','86','87','88','90', C '91','92','94','999' * OBS: 'OE'R SKRIVES SOM '@'. * DISSE ERSTATTES I OPSTARTDELEN CTXT STRGI (35),30C'******************************', C 30C'PLADSART/ANTAL? ', C 30C'TOG? ', C 30C'STATION? ', C 30C'KLASSE/KUPE, @NSKE UFORENELIG ', C 30C'KUPE/RYGER, @NSKE UFORENELIG ', C 30C'DATAMATEN OPTAGET, PR@V IGEN ', C 30C'DATO? ', C 30C'KLASSE? ', C 30C'RYGER? ', C 30C'KUPE? ', C 30C'PLACERING? ', C 30C'FRI? ', C 30C'TILSLUTNING? ', C 30C'SATELLIT? ', C 30C'KONTROLNUMMER? ', C 30C'NAT? ', C 30C'BILART/PLADSART? ', C 30C'REST/STR[KNING? ', C 30C'REST? ', C 30C'ACCEPTKODE? ', C 30C'N@GLE? ', C 30C'STANDARDMASKE? ', C 30C'TEKNIK ', C 30C'SKRIV MANUELT ', C 30C'RYGER/ANTAL? ', C 30C'KUPE/ANTAL? ', C 30C'PLACERING/ANTAL? ', C 30C'FORKERT PLADSART? ', C 30C'FORBINDELSESD@R? ', C 30C'TURNUMMER? ', C 30C'BNR-@NSKE? ', C 30C'BNR? ', C 30C'REFNR FEJLAGTIG UDFYLDT ', C 30C'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' * OBS! "!" ER DELIMITER FOR ERSTATNING AF '@' * MED DANSKE OE'ER CERASE STRG X'2B2BAE' "++<CNIL>" CNIL STRG X'AE' CZERO STRG X'00' CSP STRG X'20' * INVALID ENTRIES GENERATE A CALL TO SIDMASK CCODE STRG 58X'003B22090909090930292821252726 C 4209094B09091516200909093132' * EVTL INCLUDES TEST FOR AT FAA EN MASKE OG EN BILLET TB1 BLK * TSID BOOL TLIG BOOL TISID BOOL TILIG BOOL TSOV BOOL TBIL BOOL TAFBEST BOOL TCHNG BOOL TAUTOTAB BOOL F TTID BIN TASKID TBIN1 BIN TBIN2 BIN TBIN3 BIN TBIN4 BIN TBIN5 BIN TBIN6 BIN TBIN7 BIN TBIN8 BIN TBIN9 BIN TBIN10 BIN TSTACKPT BIN '0' STACKPOINTER TCURPOS BIN CURSOR POSITION TP1 BIN PARAMETER 1 TP2 BIN PARAMETER 2 TKBSTAT BIN KEYBOARD STATUS TB2 BLK * TPAPOUT BOOL F TRUE::=PAPEROUT ON GTP TNODEP BOOL TRUE TRUE::= INGEN FELTAFH. TPOWFAIL BOOL FALSE TRUE::=POWERFAILURE TALLFLD BOOL FALSE TRUE::=KI ON ALL FIELDS TBOOL BOOL F TALTBUF BOOL FALSE TRUE::=WRITE FROM ALT. BUFFER TBCD5 BCD 5 TSTRG1 STRG 1 TSTRG2 STRG 2 TSTRG5 STRG 5 TSTRG6 STRG 6 TSTRG10 STRG 10 TSTRG40 STRG 40 TKBBUF STRG 40 TPDUBUF STRG 42 TSTACK STRG 128 STACKAREA. DONT USE IT PLS TKEYS STRG X'40' TDC2BUF STRG 6 ALTERNATIVE DC BUFFER EJECT TB3 BLK * * PARAMETERS FOR THE UNPACK ROUTINE * TSAVE BINI (64) INLEN BIN OUTLEN BIN PRINTFLG BIN 1: TICKET PRINTED -1: DONT PRINT TICKET TDC2LEN BIN SAVTAB BINI (21,4) FLDTAB BINI (21,4) * EL. 1,1: NBR OF ENTRIES IN TABLE * EL. 1,2: NOT USED * EL. 1,3: IF 1, FLASHING FIELDS PRESENT * EL. 1,4: MASK NBR (1->8) * EL. (2->21),1: CURSORPOS (X'0101' -> X'0628') * EL. ,2: OUTBUF POS (FOR XCOPY) * EL. ,3: FIELDLENGTH (1-N) * EL. ,4: FIELDATTRIBUTE * BIT 0 - ERROR IN FIELD * BIT 1 - "MUST-ENTER" * BIT 2 - FIELD MODIFIED * BIT 3 - NOT USED * BIT 4-10 - ERRORMESSAGE INDEX * BIT 11-15 - VALIDATION INDEX TLEN BIN INBUF STRG 300 OUTBUF STRG 64 TBUF STRG 300 PDIV ENTRY KBGO ENTRY DC1GO EXT MASK EXT FLASH EXT BITOFF EXT BITON EXT BITTST EXT UNPACK EXT GMSGIX EXT GFLDIX ************************************************* * * * EQUATES * * * ************************************************* ERASE EQU 2 ERASE DISPLAY TSTAT EQU 7 TEST STATUS STIMO EQU X'0B' SET TIMEOUT FLSH EQU X'0B' FLSH LED'S ON EQU 0 TURN ON LED OFF EQU 1 TURN OFF LED TRPAR EQU 0 TRANSFER PARAMETER POS EQU 6 POSITION CURSUR * * * O B S ! * * !!!!!!! * * THE VALUES OF THE KEYS ARE NOT TO BE * * CHANGED, AS THEY ARE USED AS INDEXES * * IN "IB"'S AND "PERFI"'S * AFBKY EQU X'01' E15 - AFBESTILLING KNTKY EQU X'02' E17 - KONTOOPGORELSE LSKY EQU X'03' E18 - BACKTAB RSKY EQU X'04' E19 - FORWARD TAB SDKY EQU X'05' E20 - SLET DATA SSKY EQU X'06' E21 - SLET SK[RM ETXKY EQU X'07' E22 - END OF TEXT NEJKY EQU X'08' E23 - NEJ SIDKY EQU X'09' D15 - SIDDEPLADS LIGKY EQU X'0A' D16 - LIGGEVOGN BILKY EQU X'0B' D17 - F[RGEBESTILLING ISIDKY EQU X'0C' C15 - INTERNATIONAL SIDDEPLADS ILIGKY EQU X'0D' C16 - INTERNATIONAL LIGGEVOGN SOVKY EQU X'0E' C17 - SOVEVOGN SP1KY EQU X'0F' B15 - SPARE 1 HOMEKY EQU X'10' B16 - CURSOR HOME DOWNKY EQU X'11' B17 - CURSOR DOWN SP2KY EQU X'12' A15 - SPARE 2 LEFTKY EQU X'13' A16 - BACK SPACE RIGHTKY EQU X'14' A17 - FORWARD SPACE CHNGKY EQU X'15' D18 - [NDRINGSMASKE TESTKY EQU X'16' C18 - TESTBILLEDE MRKY EQU X'17' A18 - SPACE RESKY EQU X'18' D22 - RESET (PRINTER STATUS) SP5KY EQU X'19' C22 SENDKY EQU X'1A' A22 JA1KY EQU X'1B' D23 JA2KY EQU X'1C' A23 SP3KY EQU X'1D' A21 NOKY EQU X'FF' NO KEY * OBS: MRKY GENERATES X'20' (CTAB01) * OBS: X'21' RESERVED FOR KBTIMEOUT KTAB02 KTAB AFBKY,KNTKY,LSKY,RSKY,SDKY,SSKY, C ETXKY,NEJKY,SIDKY,LIGKY,BILKY,ISIDKY, C ILIGKY,SOVKY,SP1KY,HOMEKY,DOWNKY,SP2KY, C LEFTKY,RIGHTKY,CHNGKY,TESTKY,MRKY,RESKY, C SP5KY,SENDKY,JA1KY,JA2KY EJECT DC1GO START DC-TASK DSC1 DSDC,TRPAR,MF1CU DC1GO1 MOVE BINWK1,W0 DSC1 DSDC,STIMO,BINWK1 MOVE BINWK1,CBUFLEN READ DSDC,DCBUF,BINWK1 READ ANY UNSOLL. MSG XSTAT DSDC,BINWK1 SUB BINWK1,=X'2000' BNZ DC1GO1 SET CPOLL HURRAY WE'RE BEING POLLED B DC1GO1 THROW AWAY REST EJECT * HOUSEKEEPING FUNCTIONS KBGO START KB-TASK GETID TBIN1 SUB TBIN1,=X'4B41' CONVERT KA,KB,... TO 0,1,... BNZ KBGO4 MOVE TBIN1,W1 MOVE TSTRG2,=X'5C' DANSK OE KBGO1 MOVE TSTRG1,CTXT(TBIN1) CBE TSTRG1,=C'!',KBGO3 MOVE TSTRG1,=C'@' MOVE TBIN2,W0 MOVE TBIN3,=W'30' MATCH CTXT(TBIN1),TBIN2,TBIN3,TSTRG1,W0,W1 BNOK KBGO2 XCOPY CTXT(TBIN1),TBIN2,W1,TSTRG2,W0 B KBGO1 KBGO2 ADD TBIN1,W1 B KBGO1 KBGO3 MOVE TBIN1,W0 KBGO4 TBT CPOLL,KBGO5 BLIVER VI POLLED? DELAY W10 NEJ, VENT OG PROV IGEN B KBGO4 KBGO5 XCOPY TTID,W1,W1,MF1KBV,TBIN1 DSC1 DC,TRPAR,TTID MOVE TBIN1,=X'0023' DSC1 LAMPS,ON,TBIN1 EJECT PERF NOINPT SETUP A DUMMY FLDTAB MOVE SAVTAB(W1,W1),W1 MOVE SAVTAB(W2,W1),CHOME CURSOR POS. MOVE SAVTAB(W2,W2),W1 MOVE SAVTAB(W2,W3),W1 MOVE SAVTAB(W2,W4),=X'2920' FEJL 73 M.M. PERF ERASCR * WAIT FOR ONE OF THE FOLLOWING TWO EVENTS TO OCCUR: * A KEYBOARDINPUT, OR A DCREAD HK20 MOVE TBIN1,W1 KI .NW,KEYB,TKBBUF,KTAB02,TBIN1,TBIN6 DSC1 DC,STIMO,W0 MOVE INLEN,CBUFLEN MOVE INBUF,CZERO READ .NW,DC,INBUF,INLEN MWAIT TBIN3,KEYB,DC CBE TBIN3,W2,HK21A ABORT DC WAIT DC SYNCHRONIZE THE I-O IB TBIN6,HK27,HK27,HK20,HK20,HK20,HK20, C HK20,HK20,HK27,HK27,HK27,HK27, C HK27,HK27,HK20,HK20,HK20,HK20, C HK20,HK20,HK27,HK27 CBG TBIN6,W0,HK20 INVALID KEY, TRY AGAIN MOVE TP2,TBIN6 PERF LCKSET IT WAS A TURNED KEYLOCK B HK20 AND TRY AGAIN HK21A ABORT KEYB WAIT KEYB SYNCHRONIZE THE I-O B EXCH05 UNPACK IT EJECT * MAIN MODULE EXCH PERF DCEXCH BNOK DCERROR EXCH05 MOVE TBIN2,W3 IUT,SEND DSC1 LAMPS,ON,TBIN2 LIT THEM * READY TO PROCESS ANY INCOMING MESSAGE MOVE PRINTFLG,W0 PERF UNPCK UNPACK MESSAGE PERF SETTP1 * FL.F. TICKET RCVD PRINT NOK * 1 0 0 0 MASKE * 2 0 0 1 N/A * 3 0 1 0 BILLET * 4 0 1 1 PAPER OUT * 5 1 0 0 TILBUD * 6 1 0 1 N/A * 7 1 1 0 X-MARKERING * 8 1 1 1 X-MARKING, PAPER OUT IB TP1,HK30,HK30,TP13,TP14, C HK25,HK25,HK25,TP18 TP14 TP18 PERF NOINPT TP13 DSC1 LAMPS,OFF,W1 PERF READDC,CTIMOUT READ NEW MASK OR SP-SP-LF-LF OR 'SKRIV MANUELT' BNOK DCERROR B EXCH05 * HK23 * AFTER FLASH: LS, ETX, <INV>, DOWN,LEFT,RIGHT,SPACE, * STOP FLASHING, WAIT FOR VALID FUNCTION MOVE TBIN1,W1 KI .NE,KEYB,TSTRG1,KTAB02,TBIN1,TBIN6 B HK25B HK25 ** FLASHING; FLASH UNTIL 'KI' ** MOVE TBIN1,W1 KI .NW,.NE,KEYB,TSTRG1,KTAB02,TBIN1,TBIN6 ABORT KEYB BNOK HK25A WAIT KEYB CALL FLASH,TSAVE(W1) B HK25 HK25A WAIT KEYB HK25B IB TBIN6, C HK27,HK27,HK25,HK25,HK26C,HK26A, C HK25,HK28,HK27,HK27,HK27,HK27, C HK27,HK27,HK25,HK26D,HK25,HK25, C HK25,HK25,HK27,HK27,HK25,HK26B, C HK25,HK25,HK28,HK28 CBG TBIN6,W0,HK25 INVALID KEY MOVE TP2,TBIN6 PERF LCKSET TURNED KEYLOCK B HK25 HK26A SLET SK[RM PERF ERASCR B HK23 HK26B RESET PRINTER PERF FUNC24 B HK25 HK26C SLET DATA PERF FUNC05 HK26D CURSOR HOME PERF ERALIN,W3 PERF ERALIN,W4 PERF ERALIN,W5 PERF ERALIN,W6 CBE TP1,W7,HK26F X-MARK PERF READDC,W6 NOTHING EXPECTED B HK26E HK26F PERF READDC,W40 NEW MASK OR SP.SP.LF.LF HK26E BNOK HK26G PERF SSLL BNOK EXCH05 EXPECTED HK26G PERF RESTFT B HK30 HK28 PERF SAVEFT NEJ,JA1,JA2 HK27 PERF READDC,W10 BNOK HK27A PERF SSLL BNOK EXCH05 HK27A PERF FUNC01 ALL BLUE KEYS B EXCH EJECT HK30 SET TALLFLD ** A NORMAL MASK HAS BEEN RECEIVED ** ** OR AN OLD MASK IS RE-USED HK36 CLEAR TPOWFAIL HK40 PERF KBINP PROCESS INPUT TBT TPOWFAIL,EXCH05 UNPACK AFTER POWERFAILURE CLEAR TALLFLD PERF ERRTST BNZ HK40 TBT TNODEP,HK60 NO TESTS NEEDED CLEAR TALLFLD PERF FLDDEP TEST ON INTERRELATION BOK HK60 CLEAR TALLFLD B HK36 HK60 PERF SAVEFT SAVE "MDT"-BIT(S) B EXCH DCERROR ** A TIMEOUT HAS OCCURRED ** MOVE TBIN3,W2 IUT DSC1 LAMPS,OFF,TBIN3 PERF ERASCR MOVE TBIN3,=W'48' PERF PDUWRT,TBIN3,W1 'DATAMATEN OPTAGET' PERF CLRKBQ B HK20 EJECT ERRTST PROC * * THE PROCEDURE TESTS IF ANY FIELD IS FLAGGED * AS BEING WRONG. * IF SO, CR IS SET TO 'NOK' * FIELDS FILLED WITH SPACES OR ZEROES ARE FLAGGED AS ERRORFREE * AND NOT-MODIFIED * PERF PUSH,W2 MOVE TBIN1,W2 FIRST TO TEST MOVE TBIN2,FLDTAB(W1,W1) NBR OF FIELDS ACTIVE ADD TBIN2,W1 ERRT10 CBG TBIN1,TBIN2,ERRT90 FLDTAB EXHAUSTED? MOVE TSTRG10,CSP XCOPY TSTRG10,W0,FLDTAB(TBIN1,W3),OUTBUF,FLDTAB(TBIN1,W2) CBE TSTRG10,=C' ',ERRT10A MOVE TSTRG10,=C'0000000000' XCOPY TSTRG10,W0,FLDTAB(TBIN1,W3),OUTBUF,FLDTAB(TBIN1,W2) CBE TSTRG10,=C'0000000000',ERRT10A B ERRT12 ERRT10A CALL BITOFF,FLDTAB(TBIN1,W4),W0 CALL BITOFF,FLDTAB(TBIN1,W4),W2 CALL BITTST,FLDTAB(TBIN1,W4),W1 COMPULSARY FIELD? BZ ERRT12 NO CALL BITTST,FLDTAB(TBIN1,W4),W2 MODIFIED? BZ ERRT13 SHOULD BE, SO ERROR ERRT11 ADD TBIN1,W1 B ERRT10 ERRT12 CALL BITTST,FLDTAB(TBIN1,W4),W0 ERROR? BZ ERRT11 ERRT13 CALL BITON,FLDTAB(TBIN1,W4),W0 SET ERRORBIT PERF PULL,W2 CMP W0,W1 RET ERRT90 PERF PULL,W2 CMP W0,W0 RET PEND EJECT SETTP1 PROC * * SET TP1, DEPENDING ON THE VALUES OF PRINTFLG, * TSAVE(10) AND TSAVE(12). * PRINTFLG : IF 0, PRINT WAS OK * TSAVE(10): IF 0, NO TICKET WAS RECEIVED * TSAVE(12): IF 0, NO FLASHING FIELDS * MOVE TP1,W0 INITIAL VALUE TBT TPAPOUT,SETT00 CBE PRINTFLG,W0,SETT10 SETT00 ADD TP1,W1 SETT10 CBE TSAVE(W10),W0,SETT20 ADD TP1,W2 SETT20 CBE TSAVE(W12),W0,SETT30 ADD TP1,W4 SETT30 ADD TP1,W1 ADJUST VALUE FROM (0-7) TO (1-8) RET PEND EJECT TSTGTP PROC * * THIS PROCEDURE TESTS THE PRINTER FOR * PAPER OUT. * PERF PUSH,W1 DSC1 LAMPS,OFF,LPAT1 SWITCH OFF PAPER/OUT CLEAR TPAPOUT DSC0 GTP,TSTAT TEST PRINTER STATUS XSTAT GTP,TBIN1 CALL BITTST,TBIN1,W10 PAPER OUT? BZ TSTG10 DSC1 LAMPS,ON,LPAT2 BUZZ DSC1 LAMPS,FLSH,LPAT1 SET TPAPOUT TSTG10 PERF PULL,W1 RET PEND EJECT DCEXCH PROC DSC1 LAMPS,OFF,W1 PERF READDC,W1 ANYTHING WAITING? BOK DCEX95 DSC1 DC,STIMO,CTIMOUT PERF LCKTST * IB CTEST,DCEX91,DCEX92,DCEX93 TBT TALTBUF,DCEX20 XCOPY OUTBUF,W0,W1,TKEYS,W0 MOVE KEYLOCKSTATUS WRITE DC,OUTBUF,OUTLEN BNOK DCEX99 ERROR: EXIT B DCEX30 DCEX20 XCOPY TDC2BUF,W0,W1,TKEYS,W0 WRITE DC,TDC2BUF,TDC2LEN BNOK DCEX99 CLEAR TALTBUF DCEX30 PERF TSTGTP PERF READDC,CTIMOUT BNOK DCEX99 B DCEX95 DCEX91 * MOVE INBUF,MASK * MOVE INLEN,=W'106' * B DCEX95 DCEX92 * MOVE INBUF,TICKET * MOVE INLEN,=W'182' * B DCEX95 DCEX93 * MOVE INBUF,=X'0E20200A0A' * MOVE INLEN,W5 DCEX95 DSC1 LAMPS,ON,W1 CMP W0,W0 DCEX99 RET PEND READDC PROC P MOVE TLEN,CBUFLEN MOVE TBUF,CSP DSC1 DC,STIMO,P CBNE CTEST,W0,RDDC20 READ DC,TBUF,TLEN BNOK RDDC20 MOVE INBUF,TBUF MOVE INLEN,TLEN CMP W0,W0 B RDDC90 RDDC20 CMP W0,W1 RDDC90 RET PEND SSLL PROC * TEST FOR "GENTAG GL. MASKE" MOVE TSTRG5,INBUF CBE TSTRG5,=X'0E20200A0A',SSLL95 MOVE TSTRG6,INBUF CBE TSTRG6,=X'0E20200F0A0A',SSLL95 CMP W0,W1 SSLL95 RET PEND EJECT PDUWRT PROC IX,LIN * THE PROCEDURE WRITES VARIOUS TEXTS ON THE PDU, DEPENDING * ON THE PARAMETER. * IF THE PARAMETER IS ZERO, * THE CONTENTS OF TPDUBUF WILL BE WRITTEN "AS-IS". PERF PUSH,W2 MOVE TCURPOS,LIN CURSORPOS := MUL TCURPOS,=W'256' (LIN SHIFT 16) + 1 ADD TCURPOS,W1 DSC1 PDU,POS,TCURPOS CBE W0,IX,PDUW80 MOVE TBIN2,IX MOVE TBIN1,W2 PDUW10 CBE TBIN2,CINX(TBIN1),PDUW30 ERRORNBR FOUND? CBE CINX(TBIN1),=W'999',PDUW20 OUT OF ARRAY? ADD TBIN1,W1 NO, TRY NEXT B PDUW10 PDUW20 MOVE TBIN1,W1 ALL '*' IF NOT FOUND PDUW30 MOVE TBCD5,IX EDIT TPDUBUF,ERRFMT PDUW80 MOVE TBIN2,=W'42' WRITE PDU,TPDUBUF,TBIN2 PERF PULL,W2 CMP W0,W0 RET PEND ERRFMT FRMT FILLR '+',2 FILLR ' ',2 FMEL '99',TBCD5 FILLR ' ',1 FCOPY CTXT(TBIN1) FILLR ' ',6 FMEND ERALIN PROC P PERF PUSH,W1 MOVE TCURPOS,P MUL TCURPOS,=W'256' ADD TCURPOS,W1 DSC1 PDU,POS,TCURPOS MOVE TBIN1,=W'40' DSC1 PDU,ERASE,TBIN1 DSC1 PDU,POS,TCURPOS PERF PULL,W1 RET PEND EJECT UNPCK PROC MOVE FLDTAB(W1,W1),W0 MOVE FLDTAB(W1,W2),W0 MOVE FLDTAB(W1,W3),W0 MOVE FLDTAB(W1,W4),W0 CALL UNPACK, UNPACK ROUTINE C TSAVE(W1), WORKAREA FOR UNPACKROUTINE C INBUF, DC INPUT BUFFER C INLEN, LENGTH OF BUFFER C OUTBUF, OUTPUT BUFFER TO BE SENT C OUTLEN, LENGTH OF MSG TO BE SENT C FLDTAB(W1,W1), TABLE OVER INPUTFIELDS C PDU, DISPLAYDEVICE C GTP, PRINT DEVICE C PRINTFLG, TICKET PRINTED OR NOT C DC, DC DATASET C TDC2BUF USED FOR ACK/NAK/FUNCTIONS PERF CLRKBQ CLEAR CYCLIC BUFFER PERF SAVEFT SAVE IF > 4 INPUTFIELDS PERF RESTFT RESTORE IF < 5 INPUTFIELDS PERF BOOSET RET PEND EJECT CLRKBQ PROC CLRK10 * CLEAR CYCLIC BUFFER APART FROM KEYLOCK CHARACTERS MOVE TBIN1,W1 MOVE TBIN2,W0 KI .NW,.NE,KEYB,TKBBUF,KTAB02,TBIN1,TBIN2 ABORT KEYB BOK CLRK80 WAIT KEYB CBNL TBIN2,W0,CLRK10 ANYTHING ELSE THEN KEYLOCK MOVE TP2,TBIN2 PERF LCKSET WILL BE REFUSED B CLRK10 CLRK80 WAIT KEYB RET PEND EJECT SAVEFT PROC CBL FLDTAB(W1,W1),W5,SAVE90 PERF PUSH,W2 MOVE TBIN1,=W'21' MOVE TBIN2,W4 SAVE10 MOVE SAVTAB(TBIN1,TBIN2),FLDTAB(TBIN1,TBIN2) SUB TBIN2,W1 CBG TBIN2,W0,SAVE10 MOVE TBIN2,W4 SUB TBIN1,W1 CBG TBIN1,W0,SAVE10 PERF PULL,W2 SAVE90 RET PEND RESTFT PROC CBG FLDTAB(W1,W1),W4,REST90 CBNL SAVTAB(W1,W1),W5,REST00 PERF NOINPT B REST90 REST00 PERF PUSH,W2 MOVE TBIN1,=W'21' MOVE TBIN2,W4 REST10 MOVE FLDTAB(TBIN1,TBIN2),SAVTAB(TBIN1,TBIN2) SUB TBIN2,W1 CBG TBIN2,W0,REST10 MOVE TBIN2,W4 SUB TBIN1,W1 CBG TBIN1,W0,REST10 REST80 PERF PULL,W2 REST90 RET PEND BOOSET PROC MOVE TBIN1,FLDTAB(W1,W4) MASKNBR 1-8 CBL TBIN1,W1,BOO90 CBG TBIN1,W8,BOO90 CLEAR TSID CLEAR TLIG CLEAR TISID CLEAR TILIG CLEAR TSOV CLEAR TBIL CLEAR TAFBEST CLEAR TCHNG SET TNODEP SET TALLFLD IB TBIN1, C BOO11, SID C BOO12, ISID C BOO13, LIG C BOO14, ILIG C BOO15, AFBEST C BOO16, SOV C BOO17, BIL C BOO18 [NDRING BOO11 SET TSID B BOO90 BOO12 SET TISID B BOO90 BOO13 SET TLIG B BOO90 BOO14 SET TILIG B BOO90 BOO15 SET TAFBEST B BOO90 BOO16 SET TSOV B BOO90 BOO17 SET TBIL B BOO90 BOO18 SET TCHNG BOO90 RET PEND EJECT NOINPT PROC * * IN SOME CASES IT IS NECESSARY TO SIMULATE A FLDTAB OF * 1 INPUTFIELD. * MOVE FLDTAB(W1,W1),W1 NBR OF FIELDS = 1 MOVE FLDTAB(W2,W1),CHOME MOVE FLDTAB(W2,W2),W1 MOVE FLDTAB(W2,W3),W1 MOVE FLDTAB(W2,W4),=X'2920' ERROR 73 MOVE TCURPOS,=X'0101' DSC1 PDU,POS,TCURPOS MOVE OUTBUF,CZERO SET TNODEP RET PEND EJECT FLDDEP PROC * * THIS PRECEDURE TESTS THE INTERRELATIONSHIP * OF VARIOUS FIELDS * * IN THIS PART IT IS CHECKED IF THE FIELDS THEM- * SELVES ARE IN ERROR MOVE TBIN1,W2 FLDDS10 CBG TBIN1,FLDTAB(W1,W1),FLDD00 MOVE TBIN3,FLDTAB(TBIN1,W4) ATTRIBUTE CALL BITTST,TBIN3,W0 ERROR IN FIELD? BNZ FLDDS30 YES, WRITE ERRORMSG ADD TBIN1,W1 B FLDDS10 FLDDS30 CALL GMSGIX,TBIN3 ISOLATE ERRORNBR PERF PDUWRT,TBIN3,W4 B FLDD90 EXIT ************************* FLDD00 * CHECK IF ALL 'MUST-ENTER' FIELDS ARE PRESENT * ANY NOT-PRESENT FIELD IS FLAGGED AS BEING IN ERROR PERF MUST ALL COMPULSARY FIELDS PRESENT? BNOK FLDD90 NO, EXT TBF TSID,FLDD10 PERF FLDDSID B FLDD90 ************************* FLDD10 TBF TLIG,FLDD20 PERF FLDDLIG B FLDD90 ************************* FLDD20 TBT TAFBEST,FLDD85 ************************* FLDD30 TBF TCHNG,FLDD40 PERF FLDDCHNG B FLDD90 ************************* FLDD40 TBT TISID,FLDD85 ************************* FLDD50 TBT TILIG,FLDD85 ************************* FLDD70 TBF TSOV,FLDD80 PERF FLDDSOV B FLDD90 ************************* FLDD80 TBT TBIL,FLDD85 ************************* FLDD85 CMP W0,W0 FLDD90 RET PEND EJECT FLDDSID PROC PERF PUSH,W3 * TEST FOR '57 KUPE' CALL BITTST,FLDTAB(W9,W4),W2 BNZ FLDDS11 KUPE MODIFIED CALL BITTST,FLDTAB(W10,W4),W2 BZ FLDDS11 PLAC NOT MODIFIED MOVE TBIN3,=W'57' PERF PDUWRT,TBIN3,W4 B FLDDS90 FLDDS11 * IF ANTAL < 7, NO FURTHER TESTS ARE REQUIRED XCOPY TSTRG2,W0,W2,OUTBUF,FLDTAB(W2,W2) ANTAL MOVE TBCD5,TSTRG2 CBL TBCD5,=D'7',FLDDS14 * TEST FOR '84 RYGER/ANTAL' CALL BITTST,FLDTAB(W8,W4),W2 BZ FLDDS12 RYGER NOT MODIFIED MOVE TBIN3,=W'84' PERF PDUWRT,TBIN3,W4 B FLDDS90 FLDDS12 * TEST FOR '85 KUPE/ANTAL' CALL BITTST,FLDTAB(W9,W4),W2 BZ FLDDS13 KUPE NOT MODIFIED MOVE TBIN3,=W'85' PERF PDUWRT,TBIN3,W4 B FLDDS90 FLDDS13 * TEST FOR '86 PLACERING/ANTAL' CALL BITTST,FLDTAB(W10,W4),W2 BZ FLDDS14 MOVE TBIN3,=W'86' PERF PDUWRT,TBIN3,W4 B FLDDS90 FLDDS14 * 47 KUPE/RYGER, UFORENELIG CALL BITTST,FLDTAB(W9,W4),W2 KUPE BZ FLDDS16 XCOPY TSTRG1,W0,W1,OUTBUF,FLDTAB(W9,W2) CBNE TSTRG1,=C'6',FLDDS16 CALL BITTST,FLDTAB(W8,W4),W2 RYGER MODIFIED BZ FLDDS15 XCOPY TSTRG1,W0,W1,OUTBUF,FLDTAB(W8,W2) CBNE TSTRG1,=C'1',FLDDS15 MOVE TBIN3,=W'47' PERF PDUWRT,TBIN3,W4 B FLDDS90 * FLDDS15 * 46 KLASSE/KUPE UFORENELIG CALL BITTST,FLDTAB(W7,W4),W2 KLASSE BZ FLDDS16 XCOPY TSTRG1,W0,W1,OUTBUF,FLDTAB(W7,W2) CBNE TSTRG1,=C'1',FLDDS16 MOVE TBIN3,=W'46' PERF PDUWRT,TBIN3,W4 B FLDDS90 * FLDDS16 FLDDS40 * NO ERRORS FOUND IN THIS FORMAT PERF PULL,W3 CMP W0,W0 RET FLDDS90 PERF PULL,W3 CMP W0,W1 RET PEND EJECT FLDDLIG PROC PERF PUSH,W3 XCOPY TSTRG2,W0,W2,OUTBUF,FLDTAB(W2,W2) ANTAL MOVE TBCD5,TSTRG2 CBL TBCD5,=D'1',FLDDL20 CBG TBCD5,=D'24',FLDDL20 CBL TBCD5,=D'6',FLDDL30 CALL BITTST,FLDTAB(W7,W4),W2 BZ FLDDL30 PLAC NOT MODIFIED MOVE TBIN3,=W'86' B FLDDL25 FLDDL20 MOVE TBIN3,W9 FLDDL25 PERF PDUWRT,TBIN3,W4 PERF PULL,W3 CMP W0,W1 RET FLDDL30 PERF PULL,W3 CMP W0,W0 RET PEND EJECT FLDDCHNG PROC CMP W0,W0 RET PEND FLDDSOV PROC PERF PUSH,W3 MOVE TBIN2,=W'15' XCOPY TSTRG10,W0,W10,OUTBUF,FLDTAB(TBIN2,W2) REFNR MOVE TBIN1,W9 FLDDS01 XCOPY TSTRG1,W0,W1,TSTRG10,TBIN1 CBE TSTRG1,CZERO,FLDDS03 CBL TSTRG1,=C'0',FLDDS02 CBG TSTRG1,=C'9',FLDDS02 FLDDS03 SUB TBIN1,W1 CBG TBIN1,W0,FLDDS01 PERF PULL,W3 CMP W0,W0 RET FLDDS02 MOVE TBIN3,=W'94' PERF PDUWRT,TBIN3,W4 PERF PULL,W3 CMP W0,W1 RET PEND EJECT MUST PROC * * THIS ROUTINE CHECKS IF ALL 'ME' FIELDS HAVE * BEEN ENTERED, ENVENTUALLY AS A DEFAULT-VALUE * THIS MEANS, THAT IT IS SUFFICIENT TO CHECK * THE MODIFIED-BIT * PERF PUSH,W3 MOVE TBIN1,W2 MOVE TBIN2,FLDTAB(W1,W1) ADD TBIN2,W1 MUST10 CBG TBIN1,TBIN2,MUST90 CALL BITTST,FLDTAB(TBIN1,W4),W1 MUST-ENTER? BZ MUST20 CALL BITTST,FLDTAB(TBIN1,W4),W2 MODIFIED? BNZ MUST20 CALL BITON,FLDTAB(TBIN1,W4),W0 SET ERRORBIT B MUST30 JUMP OUT ON 1 ERROR MUST20 ADD TBIN1,W1 B MUST10 MUST30 PERF PULL,W3 CMP W0,W1 RET MUST90 PERF PULL,W3 CMP W0,W0 RET PEND EJECT * THE TWO PROCEDURES PUSH AND PULL TAKE CARE * OF THE STACKHANDLING. * DEPENDING ON THE PARAMETER, 1-8 OF THE BINARY * DATAITEMS TBIN1,TBIN2,...TBIN8 ARE * PUSHED ON THE STACK, OR PULLED OUT OF THE STACK. * TO KEEP TRACK OF 'WHERE TO PUT IT', A * STACKPOINTER IS MAINTAINED * AS THE DATAITEMS ARE SAVED IN THE SEQUENCE * TBIN8,7,6,.... THE PULL-OFF MUST BE BACKWARD. PUSH PROC B1 IB B1,PUS1,PUS2,PUS3,PUS4,PUS5,PUS6,PUS7,PUS8 PUS8 XCOPY TSTACK,TSTACKPT,W2,TBIN8,W0 ADD TSTACKPT,W2 PUS7 XCOPY TSTACK,TSTACKPT,W2,TBIN7,W0 ADD TSTACKPT,W2 PUS6 XCOPY TSTACK,TSTACKPT,W2,TBIN6,W0 ADD TSTACKPT,W2 PUS5 XCOPY TSTACK,TSTACKPT,W2,TBIN5,W0 ADD TSTACKPT,W2 PUS4 XCOPY TSTACK,TSTACKPT,W2,TBIN4,W0 ADD TSTACKPT,W2 PUS3 XCOPY TSTACK,TSTACKPT,W2,TBIN3,W0 ADD TSTACKPT,W2 PUS2 XCOPY TSTACK,TSTACKPT,W2,TBIN2,W0 ADD TSTACKPT,W2 PUS1 XCOPY TSTACK,TSTACKPT,W2,TBIN1,W0 ADD TSTACKPT,W2 RET PEND PULL PROC B1 SUB TSTACKPT,B1 POINT AT STARTADDRESS SUB TSTACKPT,B1 FOR PREVIOUS PUSH IB B1,PUL1,PUL2,PUL3,PUL4,PUL5,PUL6,PUL7,PUL8 PUL8 XCOPY TBIN8,W0,W2,TSTACK,TSTACKPT ADD TSTACKPT,W2 PUL7 XCOPY TBIN7,W0,W2,TSTACK,TSTACKPT ADD TSTACKPT,W2 PUL6 XCOPY TBIN6,W0,W2,TSTACK,TSTACKPT ADD TSTACKPT,W2 PUL5 XCOPY TBIN5,W0,W2,TSTACK,TSTACKPT ADD TSTACKPT,W2 PUL4 XCOPY TBIN4,W0,W2,TSTACK,TSTACKPT ADD TSTACKPT,W2 PUL3 XCOPY TBIN3,W0,W2,TSTACK,TSTACKPT ADD TSTACKPT,W2 PUL2 XCOPY TBIN2,W0,W2,TSTACK,TSTACKPT ADD TSTACKPT,W2 PUL1 XCOPY TBIN1,W0,W2,TSTACK,TSTACKPT ADD TSTACKPT,W2 ADJUST ONCE MORE, SO SUB TSTACKPT,B1 TSTACKPT NOW POINTS SUB TSTACKPT,B1 AT THE NEW STARTADDRESS RET PEND EJECT ERASCR PROC PERF PUSH,W1 MOVE TPDUBUF,=C'11 ' MOVE TBIN1,W3 WRITE PDU,TPDUBUF,TBIN1 PERF NOINPT PERF PULL,W1 RET PEND ERAIPT PROC * THE ROUTINE ERASES ALL MODIFIED * FIELDS BY OVERWRITING WITH X'AE' * THE MODIFIED BIT IS RESET PERF PUSH,W3 MOVE TBIN1,FLDTAB(W1,W1) NBR OF INPUTFIELDS CBL TBIN1,W1,ERAI050 MOVE TBIN2,W2 MOVE TPDUBUF,CERASE CLEAR TALTBUF MOVE OUTBUF,CZERO ERAI010 CALL BITOFF,FLDTAB(TBIN2,W4),W0 RESET ERRORBIT CALL BITOFF,FLDTAB(TBIN2,W4),W2 RESET MODIFIED BIT MOVE TCURPOS,FLDTAB(TBIN2,W1) CURSORPOS ON PDU DSC1 PDU,POS,TCURPOS POSITION CURSOR MOVE TBIN3,FLDTAB(TBIN2,W3) FIELD LENGTH ADD TBIN3,W2 ADJUST FOR '++' WRITE PDU,TPDUBUF,TBIN3 WRITE PERIODS ON PDU ADD TBIN2,W1 SUB TBIN1,W1 MORE FIELDS LEFT? BNZ ERAI010 YES THERE WERE, TAKE NEXT ERAI050 PERF PULL,W3 RET PEND EJECT LCKTST PROC PERF PUSH,W7 LOCK20 MOVE TBIN1,W0 XCOPY TBIN1,W1,W1,TKEYS,W0 GET KEYLOCKSTATUS CALL GFLDIX,TBIN1 EXTRACT LAST 4 BITS ADD TBIN1,W1 ADJUST FOR NO-KEYLOCKS IB TBIN1,LOCK40,LOCK40,LOCK40,LOCK30, C LOCK40,LOCK30,LOCK30,LOCK30,LOCK40 LOCK30 MOVE TBIN3,=W'74' PERF PDUWRT,TBIN3,W4 MOVE TP1,W1 REQ. LENGTH MOVE TBIN7,W0 PERF READKB READ KEYLOCK PERF ERALIN,W4 B LOCK20 AND TEST AGAIN LOCK40 PERF PULL,W7 RET PEND EJECT FUNC00 PROC CMP W0,W0 RET PEND FUNC01 PROC * A FUNCTION KEY HAS BEEN DEPRESSED. * THE VALUE TO BE SENT CAN BE FOUND IN CCODE, * WITH THE INDEX AS INDEX IN A XCOPY PERF PUSH,W3 MOVE TCURPOS,CHOME DSC1 PDU,POS,TCURPOS CBL TBIN6,W1,FUNC0199 CHECK FOR VALID KEY CBG TBIN6,=W'28',FUNC0199 SET TALTBUF WRITE FORM ALTERNATE BUFFER XCOPY TDC2BUF,W1,W1,CCODE,TBIN6 MOVE ASCII-CODE MOVE TDC2LEN,W2 XCOPY TSTRG1,W0,W1,CCODE,TBIN6 CBE TBIN6,W8,FUNC0199 NEJ CBE TBIN6,=W'27',FUNC0199 JA1 CBE TBIN6,=W'28',FUNC0199 JA2 PERF NOINPT CBE TBIN6,=W'21',FUNC01A [NDR CBE TBIN6,=W'22',FUNC01B TEST * THERE ARE 2 SPECIAL MASKS, NOT ADHERING TO * THE STANDARD. THESE ARE [NDRINGSMASKE AND TESTMASKE. * THEREFORE, A SPECIAL BUFFER HAS TO BE SET UP * WHEN ONE OF THESE KEYS IS PRESSED. B FUNC01C FUNC01A [NDRINGSMASKE WANTED MOVE TDC2BUF,CZERO MOVE TDC2LEN,W1 SEND STX!KEY!ETX B FUNC01C FUNC01B TEST MASKE MOVE TDC2BUF,=X'00303100' MOVE TDC2LEN,W3 FUNC01C MOVE SAVTAB(W1,W1),W1 MOVE SAVTAB(W2,W1),CHOME MOVE SAVTAB(W2,W2),W1 MOVE SAVTAB(W2,W3),W1 MOVE SAVTAB(W2,W4),=X'2920' FUNC0199 PERF PULL,W3 RET PEND FUNC03 PROC * BACKTAB. * IF THE KEY GETS NEGATIVE, A WRAP-AROUND HAS * TO BE PERFORMED (TO THE LAST INPUTFIELD) SUB TBIN2,W1 CBG TBIN2,W1,FUNC0399 MOVE TBIN2,TBIN1 ADD TBIN2,W1 FIND INDEX OF LAST FIELD FUNC0399 RET PEND FUNC04 PROC * FORWARD TAB * A WRAP-AROUND MAY HAVE TO BE PERFORMED PERF PUSH,W3 ADD TBIN2,W1 NEXT FIELD MOVE TBIN3,TBIN1 ADD TBIN3,W1 CBNG TBIN2,TBIN3,FUNC0499 STILL WITHIN LIMITS? MOVE TBIN2,W2 FUNC0499 PERF PULL,W3 RET PEND FUNC05 PROC * ERASE ALL INPUTFIELDS * SEND CURSOR HOME PERF ERAIPT MOVE TBIN2,W2 RET PEND FUNC06 PROC * ERASE SCREEN MOVE OUTBUF,CZERO PERF ERASCR SET TNODEP RET PEND FUNC07 PROC ETX PERF PUSH,W8 MOVE TSTRG10,CZERO XCOPY TSTRG10,W0,TBIN5,TKBBUF,W0 MOVE TKBBUF,TSTRG10 MOVE TBIN3,FLDTAB(TBIN7,W2) STARTPOS + DISPL ADD TBIN3,TBIN5 + 2 GIVES TOTAL LENGTH * CLEAR REST OF BUFFER MOVE TBIN2,=W'300' FUNC0710 CBNL TBIN3,TBIN2,FUNC0720 XCOPY OUTBUF,TBIN3,W1,CZERO,W0 ADD TBIN3,W1 B FUNC0710 FUNC0720 * IDEALLY, THE CURRENT FIELD SHOULD BE TESTED * AGAIN, BUT FOR THE TIME BEING THE ERROR-BIT * IS UNCONDITIONALLY RESET B FUNC0740 * CLEAR THE REST OF THE INPUTFIELDS. * AS THE OUTPUTBUFFER IS ALREADY EMPTIED, * CLEARING THE MODIFIED-BIT WILL DO FUNC0730 ADD TBIN7,W1 NEXT TO CLEAR FUNC0740 CALL BITOFF,FLDTAB(TBIN7,W4),W0 CLEAR ERRORBIT CALL BITOFF,FLDTAB(TBIN7,W4),W2 CLEAR MDT DSC1 PDU,POS,FLDTAB(TBIN7,W1) MOVE TPDUBUF,CERASE MOVE TBIN4,FLDTAB(TBIN7,W3) ADD TBIN4,W2 ADJUST FOR ++ WRITE PDU,TPDUBUF,TBIN4 CBNG TBIN7,TBIN1,FUNC0730 MORE LEFT? PERF PULL,W8 RET PEND FUNC15 PROC * KEY 'B15' HAS BEEN PRESSED. CMP W0,W0 RET PEND FUNC17 PROC * CURSOR DOWN. * GET 1. FIELD ON NEXT LINE. * IF THERE ARE NO 'LOWER' LINES, * POS. ON 1. INPUTFIELD ADD TBIN1,W1 ANTAL INPUTFELTER MOVE TBIN9,W0 MOVE TBIN10,W0 XCOPY TBIN10,W1,W1,TCURPOS,W0 LINENBR FUNC1710 ADD TBIN2,W1 NEXT FIELD XCOPY TBIN9,W1,W1,FLDTAB(TBIN2,W1),W0 CBG TBIN2,TBIN1,FUNC1730 OUT OF TABLE CBG TBIN9,TBIN10,FUNC1799 LOWER LINE FOUND B FUNC1710 FUNC1730 MOVE TBIN2,W2 1. INPUTFIELD FUNC1799 SUB TBIN1,W1 RET PEND FUNC18 PROC * TASTE 'A15' ER TRYKKET NED CMP W0,W0 RET PEND FUNC24 PROC PERF TSTGTP SUB TBIN2,W1 REENTER FIELD RET PEND EJECT * * I TESTXX-PROCEDURERNE BRUGER JEG "IMPLIED SETTING" * AF CONDITIONSREGISTRET. * DETTE REGISTER BLIVER JO SAT IFM EN COMPARE. * HVIS MAN F.X. SIGER CMP 0,0 * VIL REGISTRET BLIVE SAT TIL 0 (EQUAL) TEST01 PROC * ONLY '0' ALLOWED MOVE TBCD5,TKBBUF CMP TBCD5,=D'0' RET PEND TEST02 PROC * 0,1 MOVE TBCD5,TKBBUF CBE TBCD5,=D'0',TEST0299 CBE TBCD5,=D'1',TEST0299 TEST0299 RET PEND TEST03 PROC * 0-2 MOVE TBCD5,TKBBUF CBE TBCD5,=D'0',TEST0399 CBE TBCD5,=D'1',TEST0399 CBE TBCD5,=D'2',TEST0399 TEST0399 RET PEND TEST04 PROC * 0-3 MOVE TBCD5,TKBBUF CBL TBCD5,=D'0',TEST0498 CBG TBCD5,=D'3',TEST0498 CMP W0,W0 B TEST0499 TEST0498 CMP W0,W1 TEST0499 RET PEND TEST05 PROC CMP W0,W0 RET PEND TEST06 PROC * 0-5 MOVE TBCD5,TKBBUF CBL TBCD5,=D'0',TEST0698 CBG TBCD5,=D'5',TEST0698 CMP W0,W0 B TEST0699 TEST0698 CMP W0,W1 TEST0699 RET PEND TEST07 PROC CMP W0,W0 RET PEND TEST08 PROC * 0-7 MOVE TBCD5,TKBBUF CBL TBCD5,=D'0',TEST0798 CBG TBCD5,=D'7',TEST0798 CMP W0,W0 B TEST0799 TEST0798 CMP W0,W1 TEST0799 RET PEND TEST09 PROC * 0-9 CMP W0,W0 RET PEND TEST10 PROC * 0-24 MOVE TBCD5,TKBBUF CBL TBCD5,=D'0',TEST1098 CBG TBCD5,=D'24',TEST1098 CMP W0,W0 B TEST1099 TEST1098 CMP W0,W1 TEST1099 RET PEND TEST11 PROC * 0,1,9 MOVE TBCD5,TKBBUF CBE TBCD5,=D'0',TEST1199 CBE TBCD5,=D'1',TEST1199 CBE TBCD5,=D'9',TEST1199 TEST1199 RET PEND TEST12 PROC * 0,1,2,5 MOVE TBCD5,TKBBUF CBE TBCD5,=D'0',TEST1299 CBE TBCD5,=D'1',TEST1299 CBE TBCD5,=D'2',TEST1299 CBE TBCD5,=D'5',TEST1299 TEST1299 RET PEND TEST13 PROC * 00-99 MOVE TBCD5,TKBBUF CBL TBCD5,=D'0',TEST1399 CBG TBCD5,=D'99',TEST1399 CMP W0,W0 TEST1399 RET PEND TEST14 PROC * 0,2,3,4,5 MOVE TBCD5,TKBBUF CBE TBCD5,=D'0',TEST1499 CBL TBCD5,=D'2',TEST1498 CBG TBCD5,=D'5',TEST1498 CMP W0,W0 B TEST1499 TEST1498 CMP W0,W1 TEST1499 RET PEND TEST15 PROC * 0,2,3,5 MOVE TBCD5,TKBBUF CBE TBCD5,=D'0',TEST1599 CBE TBCD5,=D'2',TEST1599 CBE TBCD5,=D'3',TEST1599 CBE TBCD5,=D'5',TEST1599 TEST1599 RET PEND TEST16 PROC * 0000000000-9999999999 CMP W0,W0 RET PEND TEST17 PROC * 1-6 MOVE TBCD5,TKBBUF CBL TBCD5,=D'1',TEST1798 CBG TBCD5,=D'6',TEST1798 CMP W0,W0 B TEST1799 TEST1798 CMP W0,W1 TEST1799 RET PEND TEST18 PROC * 0-99999 CMP W0,W0 RET PEND TEST19 PROC * 1-20 MOVE TBCD5,TKBBUF CBL TBCD5,=D'1',TEST1998 CBG TBCD5,=D'20',TEST1998 CMP W0,W0 B TEST1999 TEST1998 CMP W0,W1 TEST1999 RET PEND TEST20 PROC * 1-24 MOVE TBCD5,TKBBUF CBL TBCD5,=D'1',TEST2098 CBG TBCD5,=D'24',TEST2098 CMP W0,W0 B TEST2099 TEST2098 CMP W0,W1 TEST2099 RET PEND TEST21 PROC * 1-999 MOVE TBCD5,TKBBUF CBL TBCD5,=D'1',TEST2198 CBG TBCD5,=D'999',TEST2198 CMP W0,W0 B TEST2199 TEST2198 CMP W0,W1 TEST2199 RET PEND TEST22 PROC * 1-99998 MOVE TBCD5,TKBBUF CBL TBCD5,=D'1',TEST2298 CBG TBCD5,=D'99998',TEST2298 CMP W0,W0 B TEST2299 TEST2298 CMP W0,W1 TEST2299 RET PEND TEST23 PROC * 1-99999 MOVE TBCD5,TKBBUF CBL TBCD5,=D'1',TEST2398 CBG TBCD5,=D'99999',TEST2398 CMP W0,W0 B TEST2399 TEST2398 CMP W0,W1 TEST2399 RET PEND TEST24 PROC * ALL FIGS 0-3 MOVE TBIN8,W1 TEST2410 CBG TBIN8,TBIN5,TEST2498 LENGTH EXCEEDED? XCOPY TSTRG1,W0,W1,TKBBUF,TBIN8 CBE TSTRG1,CNIL,TEST2498 MOVE TBCD5,TSTRG1 CBL TBCD5,=D'0',TEST2497 CBG TBCD5,=D'3',TEST2497 ADD TBIN8,W1 B TEST2410 TEST2497 CMP W0,W1 B TEST2499 TEST2498 CMP W0,W0 TEST2499 RET PEND TEST25 PROC * 000000-999999 CMP W0,W0 RET PEND TEST26 PROC * ALL FIGS 0-4 MOVE TBIN8,W1 TEST2610 CBG TBIN8,TBIN5,TEST2698 LENGTH EXCEEDED? XCOPY TSTRG1,W0,W1,TKBBUF,TBIN8 CBE TSTRG1,CNIL,TEST2698 MOVE TBCD5,TSTRG1 CBL TBCD5,=D'0',TEST2697 CBG TBCD5,=D'4',TEST2697 ADD TBIN8,W1 B TEST2610 TEST2697 CMP W0,W1 B TEST2699 TEST2698 CMP W0,W0 TEST2699 RET PEND TEST27 PROC * DATOCHECK DD-MM PERF PUSH,W2 MOVE TSTRG2,TKBBUF MOVE TBCD5,TSTRG2 CBL TBCD5,=D'1',TEST2798 CBG TBCD5,=D'31',TEST2798 MOVE TBIN1,TBCD5 XCOPY TSTRG2,W0,W2,TKBBUF,W2 MOVE TBCD5,TSTRG2 CBL TBCD5,=D'1',TEST2798 CBG TBCD5,=D'12',TEST2798 MOVE TBIN2,TBCD5 CBL TBIN1,=W'29',TEST2799 <29 DAYS ALWAYS OK IB TBIN2,TEST2701,TEST2702,TEST2703,TEST2704, C TEST2705,TEST2706,TEST2707,TEST2708,TEST2709, C TEST2710,TEST2711,TEST2712 TEST2701 TEST2703 TEST2705 TEST2707 TEST2708 TEST2710 TEST2712 B TEST2799 TEST2704 TEST2706 TEST2709 TEST2711 CBE TBIN1,=W'31',TEST2798 ONLY 30 DAYS B TEST2799 TEST2702 CBG TBIN1,=W'29',TEST2798 B TEST2799 TEST2798 PERF PULL,W2 CMP W0,W1 RET TEST2799 PERF PULL,W2 CMP W0,W0 RET PEND TEST28 PROC * 0-9 CMP W0,W0 TEST2899 RET PEND TEST29 PROC MOVE TBCD5,TKBBUF CBE TBCD5,=D'0',TEST2999 CBE TBCD5,=D'1',TEST2999 CBE TBCD5,=D'2',TEST2999 CBE TBCD5,=D'3',TEST2999 CMP TBCD5,=D'6' TEST2999 RET PEND TEST30 PROC CMP W0,W0 RET PEND TEST31 PROC * 0-6 MOVE TBCD5,TKBBUF CBL TBCD5,=D'0',TEST3198 CBG TBCD5,=D'6',TEST3198 CMP W0,W0 RET TEST3198 CMP W0,W1 RET PEND EJECT KBINP PROC * * THIS PROCEDURE SCANS THE FIELD-TABLE AND * EXECUTES A KB-INPUT FOR EVERY ELEMENT IF TALLFLD IS SET, * OTHERWISE, ONLY THE FLAGGED FIELDS ARE TREATED * THE LAYOUT OF THE FIELDTABLE CAN BE FOUND * IN THE DATADIVISION. * * A 'KI' IS TERMINATED AFTER * 1. LENGTH EXCEEDED * 2. TABKEYS PRESSED * 3. FUNCTION KEY PRESSED * 4. KEYLOCK TURNED * 5. POWER OFF/ON * * THE FOLLOWING BITS IN EL.4 MAY BE SET: * 0. DATA ERROR (INVALID DATA) * 1. MUST-ENTER * 2. FIELD MODIFIED * * THE BINARY FIELDS ARE USED FOR THE FOLLOWING PURPOSES: * TBIN1 - LOOP CONTROL (NUMBER OF INPUT FIELDS) * TBIN2 - 'NEW' CURRENT FIELD * TBIN3 - SCRATCH / CURSORPOSITION * TBIN4 - FIELD INDEX * TBIN5 - FIELD LENGTH * TBIN6 - INDEX TO USED END-KEY * TBIN7 - 'OLD' CURRENT FIELD * TBIN8 - RETURN VALUE FROM READKB / SCRATCH KB000 CLEAR TNODEP MOVE TBIN1,FLDTAB(W1,W1) NBR OF FIELDS TO BE READ MOVE TBIN2,W2 FIRST ENTRY IN FLDTAB TBT TALLFLD,KB015 MOVE TBIN3,TBIN1 ADD TBIN3,W1 KB011 CALL BITTST,FLDTAB(TBIN2,W4),W0 ERROR? BNZ KB012 YES, WRITE TEXT ADD TBIN2,W1 NEXT FIELD CBNG TBIN2,TBIN3,KB011 OUT OF TABLE? SET TALLFLD B KB000 KB012 MOVE TBIN3,FLDTAB(TBIN2,W4) ERRORMSG (NUM.PART) CALL GMSGIX,TBIN3 ISOLATE ERRORNBR TBT TCHNG,KB013 PERF PDUWRT,TBIN3,W4 WRITE ON PDU B KB015 KB013 PERF PDUWRT,TBIN3,W6 LINE 6= ERRORLINE KB015 MOVE TBIN7,TBIN2 SAVE INDEX TO CURRENT FIELD MOVE TCURPOS,FLDTAB(TBIN2,W1) START OF FIELD DSC1 PDU,POS,TCURPOS POSITION CURSOR MOVE TBIN4,FLDTAB(TBIN2,W4) CALL GFLDIX,TBIN4 FIELD INDEX MOVE TP1,FLDTAB(TBIN2,W3) FIELD LENGTH PERF READKB READ DATA MOVE TBIN5,TP1 RETURNED LENGTH MOVE TBIN6,TP2 INDEX TOKEYTAB IB TBIN8, C KB060, POWER FAILURE, DO AN UNPACK C KB015, KEYLOCK TURNED, RESTART INPUT C KB020, REQ.LENGTH EXCEEDED C KB030, NORMAL END OF INPUT, C KB000 TIMEOUT ON KEYBOARD KB020 SET TAUTOTAB SIMULATE FTABKEY XCOPY TKBBUF,TBIN5,W1,W4,W1 INSERT FTABKEY ADD TBIN5,W1 ADJUST LENGTH MOVE TBIN6,W4 KB030 PERFI TBIN6, FUNCTIONKEY DEPRESSED C FUNC01,FUNC01,FUNC03,FUNC04,FUNC05,FUNC06, C FUNC07,FUNC01,FUNC01,FUNC01,FUNC01,FUNC01, C FUNC01,FUNC01,FUNC15,FUNC00,FUNC17,FUNC18, C FUNC00,FUNC00,FUNC01,FUNC01,FUNC00,FUNC24, C FUNC00,FUNC00,FUNC01,FUNC01 IB TBIN6, RESTARTPOINT C KB034,KB034,KB034,KB034,KB015,KB000, C KB034,KB034,KB034,KB034,KB034,KB034, C KB034,KB034,KB032,KB033,KB034,KB032, C KB034,KB034,KB034,KB034,KB034,KB034, C KB015,KB034,KB034,KB034 B KB034 KB032 KB033 MOVE TBIN2,W2 KB034 CBE TBIN5,W0,KB051 IF L=0, IT WAS FUNCTION MOVE TBIN8,FLDTAB(TBIN7,W2) XCOPY OUTBUF,TBIN8,TBIN5,TKBBUF,W0 CALL BITON,FLDTAB(TBIN7,W4),W2 SET 'MODIFIED' XCOPY TKBBUF,W0,FLDTAB(TBIN7,W3),OUTBUF,TBIN8 CMP W0,W0 SET COND.REG. TIL 0 PERFI TBIN4, FIELD VALIDATION C TEST01,TEST02,TEST03,TEST04,TEST05, C TEST06,TEST07,TEST08,TEST09,TEST10, C TEST11,TEST12,TEST13,TEST14,TEST15, C TEST16,TEST17,TEST18,TEST19,TEST20, C TEST21,TEST22,TEST23,TEST24,TEST25, C TEST26,TEST27,TEST28,TEST29,TEST30, C TEST31 BOK KB040 NO ERRORS? CALL BITON,FLDTAB(TBIN7,W4),W0 INDICATE ERROR B KB050 KB040 CALL BITOFF,FLDTAB(TBIN7,W4),W0 FIELD OK KB050 KB051 IB TBIN6, C KB090,KB090,KB052,KB052,KB052,KB090, C KB080,KB090,KB090,KB090,KB090,KB090, C KB090,KB090,KB090,KB000,KB015,KB090, C KB090,KB090,KB090,KB090,KB055,KB055, C KB090,KB080,KB090,KB090 KB052 CBNE TBIN2,TBIN7,KB015 IF DIFFERENT, TBIN2 OK KB055 ADD TBIN2,W1 MOVE TBIN7,TBIN1 ADD TBIN7,W1 CBNG TBIN2,TBIN7,KB015 TBF TALLFLD,KB090 ERROR CORRECTION? B KB000 WRAP AROUND IF DATAENTRY KB060 POWER FAILURE DETECTED MOVE PRINTFLG,=W'-1' NO PRINTING SET TPOWFAIL B KB090 KB080 CLEAR TALTBUF ETX/SEND ONLY KB090 RET PEND EJECT READKB PROC * THE PROCEDURE READS A FIELD FROM THE KEYBOARD. * PARAMETERS: * TP1 - FIELD LENGTH * RETURNED BINARIES: * TP1 - EFFECTIVE LENGTH * TP2 - INDEX TO KEYTAB * TBIN8 - 1=POWER FAILURE * 2=KEYLOCK TURNED * 3=OVERFLOW * 4=NORMAL * 5=KEYBOARDTIMEOUT PERF PUSH,W4 CLEAR TAUTOTAB MOVE TBIN3,TP1 SAVE FIELD LENGTH PERF KBREAD BERR RKB010 CMP TP2,W0 BE RKB020 POWER FAILURE BL RKB030 KEYLOCK TURNED CBE TP2,=W'33',RKB060 TIMEOUT B RKB050 RKB010 * NOW ONE OF THREE THINGS HAPPENED: * CASE 2: NEITHER ALPHANUM NOR LISTED IN KEYTAB * CASE 3: OVERFLOW IN DATAITEM (SHOULD BE IMPOSSIBLE) * CASE 5: NBR OF CHARS. REACHED CBE TP2,TBIN3,RKB040 THIS WAS CASE 5 * NOW ONLY CASE 2 IS LEFT * THIS IS CONSIDERED TO BE IMPOSSIBLE, RIGHT NOW B RKB050 RKB020 POWER FAILURE MOVE TBIN8,W1 B RKB090 RKB030 KEYLOCK TURNED PERF LCKSET MOVE TBIN8,W2 B RKB090 RKB040 TOO MANY INPUTCHARS MOVE TBIN8,W3 B RKB090 RKB050 NORMAL MOVE TBIN8,W4 B RKB090 RKB060 MOVE TBIN8,W5 RKB090 PERF PULL,W4 RET PEND EJECT KBREAD PROC * * THE PROCEDURE READS FROM THE KB6272. * PARAMETERS: * TP1 - HOW MANY CHARACTERS TO READ (MAX), ON RETURN THIS ITEM * WILL CONTAIN THE ACTUAL NBR OF CHARS READ * TP2 - ON COMPLETION THIS ITEM WILL POINT AT THE END-OF-ITEM KEY USED * * SPECIAL FEATURES: * BSP - BACKSPACE - NON-DESTRUCTIVE CURSOR MOVE TO LEFT * FSP - FWDSPACE - NON-DESTRUCTIVE CURSORMOVE TO RIGHT * * TBIN1 - LENGTH OF JUST COMPLETE 'KI' * TBIN2 - ORIG. LENGTH, DECREMENTS TO ZERO WHEN ALL POS ARE INPUT * TBIN3 - DISPLACEMENT IN TSTRG40 * TBIN4 - ORIG. LENGTH * TBIN5 - INDEX TO KEYTABLE * TBIN6 - SCRATCH * TBIN7 - SCRATCH * TBIN8 - USED TO SAVE FIELDINDEX * PERF PUSH,W8 MOVE TBIN8,TBIN7 SAVE FIELD INDEX CBG TBIN8,W0,KBR010 MOVE TBIN8,W1 KBR010 CLEAR TBOOL MOVE TBIN3,W0 MOVE TBIN4,TP1 SAVE ORIG.LENGTH MOVE TBIN2,TP1 MOVE TSTRG40,CZERO MOVE TBIN7,TCURPOS TCURPOS MIGHT BE MODIFIED XCOPY TSTRG40,W0,TBIN4,OUTBUF,FLDTAB(TBIN8,W2) KBR016 DSC1 PDU,POS,TBIN7 MOVE TBIN1,TBIN2 RESTLENGTH CBNG TBIN1,W0,KBR030 FTAB IF FILLED UP KI KEYB,TKBBUF,KTAB02,TBIN1,TP2 BOK KBR040 KEYLOCK OR TERM. CHAR. * A CHAR NEITHER ALPHANUM NOR LISTED IN * KEYTABLE IS INPUT * SIZE OF BUFFER IS REACHED * POWER FAILURE * REQ. NBR OF CHARS IS REACHED * ONLY POSSIBILITIES: * POWERFAILURE OR OVERFLOW XSTAT KEYB,TKBSTAT MOVE TBIN6,=X'0040' BIT 9 CALL MASK,TKBSTAT,TBIN6 BZ KBR018 NO TIMEOUT PERF FUNC06 MOVE TP2,=W'33' B KBR025 KBR018 CBNE W0,TP2,KBR030 ********** KBR020 PERF PULL,W8 CMP W0,W1 UNDEF. ERROR OR PWR FAILURE B KBR099 RETURN ********** KBR025 PERF PULL,W8 KEYLOCK TURNED CMP W0,W0 CR=OK B KBR099 ********** KBR030 MOVE TP2,W4 SIMULATE FTABKEY B KBR090 RETURN ********** KBR040 CBG TBIN1,W0,KBR045 IF ANY INPUTCHAR CLEAR TBOOL WE CAN RESET TBOOL KBR045 CBE TP2,W0,KBR020 POWER FAILURE ? BL KBR025 SUB TBIN1,W1 MOVE TBIN5,TP2 SAVE INDEX TO KEYTABLE CBE TBIN5,=W'19',KBR050 BSP CBE TBIN5,=W'20',KBR060 FSP CBE TBIN5,W7,KBR095 ETX B KBR090 ********** KBR050 BACKSPACE KEY PRESSED TBT TBOOL,KBR020 SUB TBIN2,TBIN1 HOW MANY CHARS LEFT ADD TBIN2,W1 CBNL TBIN2,TP1,KBR010 BACKSPACED WE TO START? XCOPY TSTRG40,TBIN3,TBIN1,TKBBUF,W0 ADD TBIN3,TBIN1 FIELD LENGTH SUB TBIN3,W1 MINUS 1 MOVE TBIN7,TCURPOS MOVE CURSOR ONE POS ADD TBIN7,TBIN3 -//- B KBR016 ********** KBR060 FORWARDSPACE KEY SUB TBIN2,TBIN1 HOW MANY CHARS MAY WE READ SUB TBIN2,W1 XCOPY TSTRG40,TBIN3,TBIN1,TKBBUF,W0 ADD TBIN3,TBIN1 FIELD LENGTH ADD TBIN3,W1 PLUS ONE MOVE TBIN7,TCURPOS MOVE CURSOR ONE POS ADD TBIN7,TBIN3 -//- B KBR016 *********** KBR090 XCOPY TSTRG40,TBIN3,TBIN1,TKBBUF,W0 COMPLETE BUFFER MOVE TKBBUF,TSTRG40 MOVE COMPLETED BUFFER TO APPL PERF FIND00,TKBBUF FIND TOTAL FIELDLENGTH KBR095 MOVE TSTRG40,CZERO XCOPY TSTRG40,W0,TBIN1,TKBBUF,W0 MOVE TKBBUF,TSTRG40 CBE TBIN5,W7,KBR097 ETX? PERF FIND00,TKBBUF JA, FIND IKKE L[NGDEN KBR097 MOVE TP1,TBIN1 PERF PULL,W8 CMP W0,W0 KBR099 RET PEND EJECT LCKSET PROC MUL TP2,=W'-1' IB TP2,RKB034,RKB033,RKB032,RKB031, C RKB038,RKB037,RKB036,RKB035 RKB031 CALL BITOFF,TKEYS,W7 B RKB039 RKB032 CALL BITOFF,TKEYS,W6 B RKB039 RKB033 CALL BITOFF,TKEYS,W5 B RKB039 RKB034 CALL BITOFF,TKEYS,W4 B RKB039 RKB035 CALL BITON,TKEYS,W7 B RKB039 RKB036 CALL BITON,TKEYS,W6 B RKB039 RKB037 CALL BITON,TKEYS,W5 B RKB039 RKB038 CALL BITON,TKEYS,W4 RKB039 RET PEND EJECT FIND00 PROC BUF * * FIND THE LENGTH OF THE DATAFIELD IN THE * BUFFER SPECIFIED. * IF THE LAST NON-ZERO CHAR IS BELOW X'20' * (EOI-KEY) THE COUNT WILL BE DECREASED BY 1. * MOVE TSTRG1,CZERO MOVE TBIN1,W0 MOVE TBIN7,=W'40' OBS OBS LENGTH OF TKBBUF MATCH BUF,TBIN1,TBIN7,TSTRG1,W0,W1 CBE TBIN1,W0,FIN010 MOVE TBIN7,TBIN1 SUB TBIN7,W1 XCOPY TSTRG1,W0,W1,TKBBUF,TBIN7 CBNL TSTRG1,CSP,FIN010 < X'20' IS EOI KEY SUB TBIN1,W1 FIN010 RET PEND END