|
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: 39850 (0x9baa)
Notes: pts_type(SC)
Names: »NYCONV.SC«
└─⟦bf903a231⟧ Bits:30009665 Philips computer tape "600109"
└─⟦this⟧ »DEN10/NYCONV.SC«
IDENT NYCONV REL=1.0,VER=1 820420/NJ UPD 82-02-22/EV UPD 81-08-27/EV UPD 80-12-12/SHB UPD 80-07-14/JAER DDUM DEDDIV PDIV ENTRY DECONV EXT DEPOOL EXT TESTB EXT EMPTYT EXT DERROR EXT ATTDEV ATTACH DEVICE EXT ATTPRT EXT DETPRT EXT MASK EXT GETFWD EXT ADJUST EXT FDIO EJECT * * KEYTABLE * CLR EQU X'8F' CLEAR CAN EQU X'91' CANCEL RET EQU X'98' RETURN ENT EQU X'8C' ENTER * KEYTAB KTAB CLR,CAN,RET,ENT * * STIMO EQU X'0B' ATTACH EQU X'0E' DETACH EQU X'0F' TRPAR EQU X'00' EJECT * THIS MODULE TAKE CARES OF THE DIFFERENT CONVERTIONS- * -METHODS * ONE OF THEM IS ALREADY PREPAIRED FOR YOUR PRINTOUT). * THE OTHER YOU HAVE TO CODE YOURSELVES. * FORMAL PARAMETERS: FC = FUNCTION-CODE (DEVICE-CLASS) * = 1 DATACOMMUNICATION OUT * = 2 DATACOMMUNICATION IN * = 3 CASETTE OUTPUT * = 4 PRINTOUT LP/GP * = 5 DISCFILE * = 6 FLOPPYDISC FILE * = 7 DELETE BATCHES ON USERFILE * = 8 FREEZE BATCHES ON USER FILE * = 9 LISTING LP/GP * TYPE = TYPE OF HANDLING * = 1 OPEN * = 2 BATCHHEAD-RECORD * = 3 DATA RECORD * = 4 BALANCE RECORD * = 5 CLOSE * RETCON = RETURN-CODE * = 0 OK * /= 0 ERROR MESSAGE-NUMBER * =-1 SKIP CURR BATCH, GO TO NEXT * =-2 SKIP TO BALANCE * =-3 RESTART CURRENT BATCH (CANCEL) * =-4 ABORT CONVERSION (RETURN) * =-5 DELETE THIS BATCH * =-6 GET CURRENT RECORD * INPUT VARIABLE: BIN4 = FC-CODE FOR DEVICE EJECT DECONV PROC FC,TYPE,RETCON IB FC,TRANSM,RECEIV,CASSET JUMP ON DEVICE-CLASS C PRINTA,DISCFD,FLOPPY,DELETE,FREEZE,LISTE RECEIV DISCFD CASSET ERROR MOVE RETCON,W4 'FUNCTION NOT ALLOWED? B RETURN * * THIS IS THE PRINTOUT FUNCTION * PRINTA IB TYPE,PR100,PR200,PR200 JUMP ON TYPE 0F HANDLING C PR200,PR500 B ERROR * * OPEN DEVICE = ATTACH PRINTER * PR100 PERF ATTDEV,BIN6 ATTACH DEVICE BOK DECOOK B RETURN EJECT * * * PRINTOUT OF THE DIFFERENT RECORD TYPES * PR200 EDWRT DEDSPRT,FCOUNT BNOK PR298 MOVE DEBINW3,W1 PRINT DEDSPRT,DEBINW3,W0 BNOK PR298 B DECOOK PR298 MOVE RETCON,=W'35' OUTPUT DEVICE NOT OP....' B RETURN GO AND CLOSE * * CLOSE DEVICE = DETACH PRINTER * PR500 PERF DETPRT DETACH DEVICE B RETURN EJECT * * THIS ROUTINE DELETE BATCHES ON THE USERFILE * DELETE IB TYPE,DECOOK,DEL100 B DECOOK DEL100 MOVE RETCON,=W'-5' CBNE WORK(W8),W0,DEL110 NOT THE WHOLE FILE MOVE DATE,HEX00 RESET DATE DEL110 B RETURN EJECT * * THIS ROUTINE FREEZE BATCHES ON USER FILE * FREEZE IB TYPE,FRE100,FRE200,FRE300 OPEN BATCHHEAD DATA C FRE400,FRE500 BALANCE CLOSE * OPEN FRE100 B DECOOK FRE200 B DECOOK FRE300 B DECOOK * BALANCE RECORD FRE400 B DECOOK * CLOSE FRE500 B DECOOK EJECT * * OK * DECOOK MOVE RETCON,W0 RETURN RET EJECT TRANSM IB TYPE,DC100,DC200,DC300 OPEN,BATCHHEAD,DATA C DC300,DC500 BALANCE, CLOSE * * SEND SOF * SEND '001'+DATE * DC100 * * BATCHHEAD RECORD * DC200 DC300 * * TRANSM BLOCKS * * * SEND '999' * SEND EOF * DC500 B DECOOK EJECT * * LISTING * LISTE MOVE BTYPE,TYPE IB TYPE,LS100,LS200,LS300, OPEN,BATCHHEAD,DATA, C LS400,LS500 BALANCE,CLOSE LS100 TBT LSBAB,LS170 PERF GETBUF GET 3 CONSECUTIVE BUFFERS B LS110 OK B LSERR ERROR LS110 MOVE BCDI21(W5),=D'0' RECORD COUNT MOVE WORK(W15),W0 LENGTH HEADER MOVE WORK(W17),W0 LENGTH RECORD NO MOVE WORK(W19),W0 LENGTH SEQUENCE NO CLEAR BCONT CONTINUATION MARK CLEAR BSUPR CLEAR SPLITFL NNO SPLIT MOVE BIN6,=X'0036' FILE CODE PRINTER PERF ATTDEV,BIN6 ATTACH DEVICE BNOK LSERR MOVE STRG10A,HEX00 GETTIME STRG10A MOVE TIME,STRG10A EDWRT DEDSPRT,FLSHDR MOVE RECLGD,=W'112' * ENT B DECOOK OK LS170 MOVE RETCON,=W'-4' ABORT CONVERSION B LSERRT LSERR MOVE RETCON,=W'35' OUTPUT DEV NOT OPERABLE LSERRT SET LSBAB B RETURN * * BATCHEAD RECORD * LS200 TBT LSBAB,LS170 TBF BDAFOR,LS250 ANY FORCED FIELDS? * CONVERT HEADER TO SET CONVERSION INDICATIONS MOVE BIN10,WORK(W13) GET BUFFER INDEX MOVE BIN9,BIN10 GET BPOOL INDEX ADD BIN9,W1 MOVE BIN8,W0 RESET FIELD NO MOVE BIN4,W0 LS210 PERF CONV,BIN4,FC B DECOOK ALL DONE B LS210 NOT ALL DONE B LS315 COMP FIELD EMPTY B LS320 BCD FIELD OVERFLOW B LS320 EDIT BUFFER OVERFLOW EDWRT DEDSPRT,FBATC3 PRINT ERROR REPORT SET LSBAB MOVE RETCON,=W'-1' GET NEXT BATCH B RETURN LS250 BATCHHEAD OR BALANCE TBT LSBAB,LS170 MOVE DEBINW3,W1 PRINT DEDSPRT,DEBINW3,W0 BNOK LSERR B DECOOK LS300 TBT FDBAB,LS170 MOVE BIN10,WORK(W13) GET BUFFER INDEX MOVE BIN9,BIN10 GET BPOOL INDEX ADD BIN9,W1 MOVE BIN8,W0 RESET FIELD NUMBER LS310 MOVE BIN4,W0 LS311 PERF CONV,BIN4,FC B DECOOK ALL DONE B LS340 WRITE BLOCKS B LS315 CUMP FIELD EMPTY B LS320 BCD FIELD OVERFLOW B LS320 EDIT BUFFER OVERFLOW LS315 MOVE RETCON,W5 B LSERRT LS320 MOVE RETCON,=W'54' B LSERRT * WRITE BLOCKS LS340 PERF LSWRIT B LS310 OK B LS310 DUMMY B LS310 DUMMY MOVE BIN4,W1 CONTINUE IN SAME BUFFER B LS311 LS400 * BALANCE FORMAT B LS250 LS500 MOVE BIN10,WORK(W13) GET BUFFER INDEX TBT FDBAB,LS560 ABORT B LS570 LS550 CLEAR LSBAB MOVE BIN4,W0 PERF DETPRT * RELEAS BUFFERS PERF DEPOOL,W6,BIN10,BIN4,STRG10A B DECOOK LS560 MOVE STRG10A,HEX00 GETTIME STRG10A MOVE TIME,STRG10A EDWRT DEDSPRT,FLSERR B LS550 LS570 MOVE STRG10A,HEX00 GETTIME STRG10A MOVE TIME,STRG10A EDWRT DEDSPRT,FLSEND B LS550 EJECT * * FLOPPY DUMPING * FLOPPY MOVE BTYPE,TYPE IB TYPE,FD100,FD200,FD300 OPEN,BATCHHEAD,DATA C FD400,FD500 BALANCE,CLOSE * * SEND SOF * SEND '001'+DATE * FD100 TBT FDBAB,FD170 PERF GETBUF GET 3 CONSECUTIVE BUFFERS B FD110 OK B FDERR ERROR FD110 MOVE CWFD,W7 HDR RECORD MOVE REQFD,=W'128' CALL FDIO,DSFD,X'A1',BPOOL(BIN10),REQFD,CWFD OPEN MOVE BIN4,W20 DSC1 DSFD,ATTACH,BIN4 ATTACH DEVICE FD BNOK FDERR PERF FDLOAD B FD140 OK B FDERR ERROR FD140 MOVE BCDI21(W5),=D'0' RECORD COUNT MOVE WORK(W15),W0 LENGTH HEADER MOVE WORK(W17),W0 LENGTH RECORD NO MOVE WORK(W19),W0 LENGTH SEQUENCE NO CLEAR BCONT CONTINUATION MARK CLEAR BSUPR SET SPLITFL NORMAL SPLIT MOVE BIN6,=X'0036' FILE CODE PRINTER PERF ATTDEV,BIN6 ATTACH DEVICE BNOK FDERR MOVE STRG10A,HEX00 GETTIME STRG10A MOVE TIME,STRG10A EDWRT DEDSPRT,FFDHDR PERF FDRVOL READ VOLUME LABEL B FD150 OK B FDERR ERR FD150 IB DEBINW2,FD160,FD180,FD170 CLR,CAN,RET * ENT FD160 MOVE STR8A,STR8B SAVE FILE NAME MOVE FDCNT,W1 RESET FD COUNTER PERF FDWVOL WRITE VOLUME LABEL B FD165 OK B FDERR ERROR FD165 B DECOOK OK FD170 MOVE RETCON,=W'-4' ABORT CONVERSION B FDERRT FDERR MOVE RETCON,=W'35' OUTP. DEV. NOT OPERABLE FDERRT SET FDBAB B RETURN FD180 MOVE CWFD,W7 MOVE REQFD,=W'128' CALL FDIO,DSFD,X'B8',BPOOL(BIN10),REQFD,CWFD *UNLOAD HDR1 MOVE RETCON,=W'55' CHANGE FD B RETURN EJECT * * BATCHEAD RECORD * FD200 TBT FDBAB,FD170 TBF BDAFOR,FD300 ANY FORCED FIELDS? EDWRT DEDSPRT,FBATC3 PRINT ERROR REPORT SET FDBAB MOVE RETCON,=W'-1' GET NEXT BATCH B RETURN FD300 TBT FDBAB,FD170 TBT FDEOF,FDEOF10 CBE TYPE,W4,FD305 PRINTING CBE TYPE,W2,FD305 PRINTING B FD308 NO PRINTING FD305 * PRINT BATCH HEAD AND BALANCE RECORD MOVE DEBINW3,W1 PRINT DEDSPRT,DEBINW3,W0 BNOK FDERR FD308 MOVE BIN10,WORK(W13) GET BUFFER INDEX MOVE BIN9,BIN10 GET BPOOL INDEX ADD BIN9,W1 MOVE BIN8,W0 RESET FIELD NUMBER FD310 MOVE BIN4,W0 FD311 PERF CONV,BIN4,FC B DECOOK ALL DONE B FD340 WRITE BLOCKS B FD315 CUMP FIELD EMPTHY B FD320 BCD FIELD OVERFLOW B FD320 EDIT BUFFER OVERFLOW FD315 MOVE RETCON,W5 B FDERRT FD320 MOVE RETCON,=W'54' EDIT ERROR B FDERRT * * WRITE BLOCKS * FD340 PERF FDWRIT B FD310 OK B FD360 ERROR B FDEOF05 EOE MOVE BIN4,W1 CONTINUE IN SAME BUFFER B FD311 FD350 PERF FDLOAD B FD370 OK B FD360 ERROR FD360 MOVE REQFD,=W'128' MOVE CWFD,W7 CALL FDIO,DSFD,X'B8',BPOOL(BIN10),REQFD,CWFD UNLOAD FD365 MOVE DEBINW4,=W'55' CHANGE FLOPPYDISK PERF DERROR,KEYTAB IB DEBINW2,FD350,FD360,FD170 CLR,CAN,RET B FD350 ENT FD370 PERF FDRVOL READ VOLUME LABEL B FD375 OK B FD360 ERROR FD375 IB DEBINW2,FD380,FD360,FD170 CLR,CAN,RET * ENT FD380 PERF FDWVOL WRITE VOLUME LABEL B FD382 OK B FD360 ERROE FD382 TBF FDEOF,FD340 NOT EOF MOVE RETCON,=W'-6' GET CURRENT RECORD B RETURN FDEOF05 SET FDEOF INDICATE EOF MOVE WORK(W14),BIN8 SAVE FIELD NO B FD360 FDEOF10 CLEAR FDEOF MOVE BIN10,WORK(W13) GET BUFFER INDEX MOVE BIN9,BIN10 GET BPOOL INDEX ADD BIN9,W1 MOVE BIN8,WORK(W14) GET FIELD NO MOVE REQFD,=W'128' MOVE CWFD,W0 CALL FDIO,DSFD,X'06',BPOOL(BIN10),REQFD,CWFD WRITE BLOCKS B FD340 EJECT FD400 * BALANCE FORMAT B FD300 FD500 MOVE BIN10,WORK(W13) GET BUFFER INDEX TBT FDBAB,FD560 ABORT MOVE BIN9,BIN10 GET BPOOL INDEX ADD BIN9,W1 EDIT BPOOL(BIN9),FFD999 END OF FILE FD505 ***PERF FDWRIT B FD570 OK B FDERR ERR B FD510 EOE FD510 MOVE REQFD,=W'128' MOVE CWFD,W7 CALL FDIO,DSFD,X'B8',BPOOL(BIN10),REQFD,CWFD UNLOAD FD515 MOVE DEBINW4,=W'55' CHANGE FLOPPYDISK PERF DERROR,KEYTAB IB DEBINW2,FD520,FD510,FD170 CLR,CAN,RET FD520 PERF FDLOAD B FD525 OK B FD510 ERROR FD525 PERF FDRVOL READ VOLUME LABEL B FD530 OK B FD510 ERROR FD530 IB DEBINW2,FD535,FD510,FD170 CLR,CAN,RET * ENT FD535 PERF FDWVOL WRITE VOLUME LABEL B FD540 OK B FD510 ERROR FD540 MOVE REQFD,=W'128' MOVE CWFD,W0 CALL FDIO,DSFD,X'06',BPOOL(BIN10),REQFD,CWFD WRITE BLOCKS B FD505 FD550 WAIT DSFD CLEAR FDBAB MOVE CWFD,W7 HDR SECTOR MOVE REQFD,=W'128' CALL FDIO,DSFD,X'B8',BPOOL(BIN10),REQFD,CWFD UNLOAD CLEAR FDEOF RESET EOF MOVE CWFD,W7 MOVE REQFD,=W'128' CALL FDIO,DSFD,X'A2',BPOOL(BIN10),REQFD,CWFD CLOSE MOVE BIN4,W0 DSC1 DSFD,DETACH,BIN4 PERF DETPRT * RELEAS BUFFERS PERF DEPOOL,W6,BIN10,BIN4,STRG10A B DECOOK FD560 MOVE STRG10A,HEX00 GETTIME STRG10A MOVE TIME,STRG10A EDWRT DEDSPRT,FFDERR B FD550 FD570 MOVE STRG10A,HEX00 GETTIME STRG10A MOVE TIME,STRG10A EDWRT DEDSPRT,FFDEND B FD550 PEND EJECT * * GETBUF GET TWO CONSECUTIVE BUFFERS * * BUFFER INDEX IN WORK(W13) * GETBUF PROC MOVE BIN10,W3 TOTAL NUMBER OF BUFFERS MOVE BIN4,W3 NO. OF COSECUTIVE BUFFERS PERF DEPOOL,W2,BIN10,BIN4,STRG10A GET 3 COSECUTIVE BUFFERS BNOK GETBU2 NO BUFFERS AVAIBLE MOVE WORK(W13),BIN10 SAVE BUFFER INDEX MOVE BIN9,BIN10 LOAD WORKING BUFFER INDEX ADD BIN9,W1 INDEX EDIT BUFFER MOVE BPOOL(BIN10),=X'00' RESET TRANSMIT BUFFER RET GETBU2 RET 2 PEND EJECT * * FDRVOL READ VOLUME LABEL AND DISPLAY * FDRVOL PROC MOVE REQFD,=W'128' MOVE BIN13,BIN10 GET BUFFER INDEX ADD BIN13,W2 ADJUST FOR READ BUFFER MOVE CWFD,W7 CALL FDIO,DSFD,X'91',BPOOL(BIN13),REQFD,CWFD READ (HDR1) XSTAT DSFD,BIN4 MOVE BIN7,=X'086F' CALL MASK,BIN4,BIN7 BNOK FDRV02 MOVE BIN7,=W'66' XCOPY STR6A,W0,W6,BPOOL(BIN13),BIN7 EXPIRATION DATE XCOPY STR8A,W0,W8,BPOOL(BIN13),W5 GET FILE NAME MOVE BIN7,W22 GET RECORD LENGTH XCOPY STR6B,W1,W5,BPOOL(BIN13),BIN7 MOVE RECLGD,STR6B MOVE BIN7,=W'45' XCOPY STR2A,W0,W2,BPOOL(BIN13),BIN7 GET FD NUMBER ATTFMT FCAS02 SET DEPROMPT DISPLAY 0,W1,W0 THOME MOVE DEBINW3,W1 REQUESTED LENGTH NKI .NE,DEDSDYKB,STR1A,KEYTAB,DEBINW3,DEBINW2 RET FDRV02 RET 2 PEND EJECT * * FDWVOL WRITE VOLUME LABEL * FDWVOL PROC MOVE BIN7,=W'66' MOVE BIN13,BIN10 GET BUFFER INDEX ADD BIN13,W2 ADJUST FOR READ BUFFER EDSUB BPOOL(BIN13),BIN7,FRMVOL2 DATE MOVE BIN7,W5 EDSUB BPOOL(BIN13),BIN7,FRMVOL1 VOLUME NAME MOVE BIN7,=W'45' EDSUB BPOOL(BIN13),BIN7,FRMVOL3 FD NUMBER MOVE REQFD,=W'128' REQUESTED LENGTH MOVE CWFD,W7 CALL FDIO,DSFD,X'95',BPOOL(BIN13),REQFD,CWFD WRITE (HDR1) XSTAT DSFD,BIN4 MOVE BIN7,=X'024F' CALL MASK,BIN4,BIN7 BNOK FDWVO2 ADD FDCNT,=D'1' UPDATE FD NUMBER MOVE CWFD,=W'26' HDR RECORD MOVE REQFD,=W'128' REQUESTED LENGTH CALL FDIO,DSFD,X'B1',BPOOL(BIN13),REQFD,CWFD REWIND RET FDWVO2 RET 2 PEND EJECT * * LSWRIT WRITE BLOCKS * LSWRIT PROC LSWR00 * BIN16 NO OF CHARS TO SEND * BIN4 AVAILABLE SPACE IN OUTPUT BUFFER * DEBIN3 LENGTH OF HEADER * BIN15 ACTUAL LENGTH OF INPUT DATA USED CMP BIN16,W0 BE LSWRRET NODATA=NOWRITE MOVE BIN4,RECLGD SET RECORD LENGTH ADD BCDI21(W5),=D'1' ADD 1 TO RECORD NO ADD BCDI21(W4),=D'1' ADD 1 TO SEQUENCE NO CBE BCDI21(W4),=D'1',LSWR50 * NOT FIRST TIME (SEQUENCE NO > 1) * COPY HEADER PART, LENGTH IN WORK(W15) SUB BIN4,WORK(W15) MAKE ROOM FOR HEADER MOVE DEBIN3,WORK(W15) START POINT B LSWR55 LSWR50 * FIRST OUTPUT RECORD FOR THIS INPUT RECORD MOVE DEBIN3,W0 START POINT * LSWR55 CBL BIN16,BIN4,LSWR58 ROOM FOR EVERYTING? NO ROOM TBT SPLITFL,LSWR57 NORMAL SPLIT FIND PRECEDING & MOVE DEBIN1,BIN4 START AT END OF RECORD MOVE STR2A,=C'&&' LOOK FOR & LSWR56 SUB DEBIN1,W1 CBNG DEBIN1,W0,LSWR57 NO & MOVE DEBIN2,DEBIN1 MATCH BPOOL(BIN9),DEBIN2,W1,STR2A,W0,W1 BNOK LSWR56 NOT FOUND MOVE BIN15,DEBIN2 B LSWR59 *NORMAL SPLIT LSWR57 MOVE BIN15,BIN4 B LSWR59 * NO OF CHARS, FIT IN AVAILABLE ROOM LSWR58 MOVE BIN15,BIN16 SEND ALL CHARS * LSWR59 XCOPY BPOOL(BIN10),DEBIN3,BIN15,BPOOL(BIN9),W0 COPY FIRST * MOVE BLANKS INTO REMAINING PART OF OUTPUT BUFFER * BIN4 = NO OF CHARS IN OUTPUT BUFFER MOVE BIN4,BIN15 ADD BIN4,DEBIN3 ADD HEADER * MOVE DEBIN1,RECLGD SUB DEBIN1,BIN4 NO OF BLANKS XCOPY BPOOL(BIN10),BIN4,DEBIN1,BPOOL(BIN9),BIN16 MOVE BLANKS * LSWR60 * INSERT RECORD NO - BCDI21(W5) CBE WORK(W17),W0,LSWR70 SKIP IF LENGTH ZERO MOVE STRG10A,BCDI21(W5) CONVERT RECORD NO MOVE DEBIN1,W10 LENGTH FIELD SUB DEBIN1,WORK(W17) FIND START OF NO XCOPY BPOOL(BIN10),WORK(W16),WORK(W17),STRG10A,DEBIN1 * LSWR70 * INSERT SEQUENCE NO - BCDI21(W4) CBE WORK(W19),W0,LSWR80 SKIPIF LENGTH ZERO MOVE STRG10A,BCDI21(W4) CONVERT SEQUENCE NO MOVE DEBIN1,W10 LENGTH FIELD SUB DEBIN1,WORK(W19) FIELD START OF NO XCOPY BPOOL(BIN10),WORK(W18),WORK(W19),STRG10A,DEBIN1 * LSWR80 * HANDLE END OF RECORD CBG BIN16,BIN15,LSWR100 NO ROOM, CONT * INSERT EOR B LSWRSEND * LSWR100 WRITE DEDSPRT,BPOOL(BIN10) MOVE CWFD,W0 DELETE BPOOL(BIN9),CWFD,BIN15 DELETE WHAT IS SEND SUB BIN16,BIN15 MOVE BIN13,BIN16 CMP VSEIND,W1 BE LSWR00 WRITE RESET OF BUFFER RET 6 * LSWRSEND WRITE DEDSPRT,BPOOL(BIN10) LSWRRET RET PEND EJECT * * FDWRIT WRITE BLOCKS * FDWRIT PROC FDWR00 WAIT DSFD XSTAT DSFD,BIN4 CALL TESTB,BIN4,W2 EOE BZ FDWR10 RET 4 END OF EXTENT FDWR10 MOVE BIN7,=X'024F' CALL MASK,BIN4,BIN7 BERR FDWR20 IB BTYPE,FDWROP,FDWRHD,FDWRDATA,FDWRBAL,FDWRCL FDWROP FDWRCL B FDWR20 FDWRHD BATCH HEADER MOVE BPOOL(BIN10),=X'00' INITIATE OUTPUT BUFFER MOVE BIN4,RECLGD XCOPY BPOOL(BIN10),W0,BIN4,BPOOL(BIN9),W0 B FDWRSEND * FDWRDATA * BIN16 NO OF CHARS TO SEND * BIN4 AVAILABLE SPACE IN OUTPUT BUFFER * DEBIN3 LENGTH OF HEADER * BIN15 ACTUAL LENGTH OF INPUT DATA USED CMP BIN16,W0 BE FDWRRET NO DATA= NO WRITE MOVE BIN4,RECLGD SET RECORD LENGTH ADD BCDI21(W5),=D'1' ADD 1 TO RECORD NO ADD BCDI21(W4),=D'1' ADD 1 TO SEQUENCE NO CBE BCDI21(W4),=D'1',FDWR50 * NOT FIRST TIME (SEQUENCE NO > 1) * COPY HEADER PART, LENGTH IN WORK(W15) SUB BIN4,WORK(W15) MAKE ROOM FOR HEADER MOVE DEBIN3,WORK(W15) START POINT B FDWR55 * FDWR50 * FIRST OUTPUT RECORD FOR THIS INPUT RECORD MOVE DEBIN3,W0 START POINT * FDWR55 CBL BIN16,BIN4,FDWR58 ROOM FOR EVERYTHING? NO ROOM TBT SPLITFL,FDWR57 NORMAL SPLIT FIND PRECEDING & MOVE DEBIN1,BIN4 START AT END OF RECORD MOVE STR2A,=C'&&' LOOK FOR & FDWR56 SUB DEBIN1,W1 CBNG DEBIN1,W0,FDWR57 NO & MOVE DEBIN2,DEBIN1 MATCH BPOOL(BIN9),DEBIN2,W1,STR2A,W0,W1 BNOK FDWR56 NOT FOUND MOVE BIN15,DEBIN2 B FDWR59 * NORMAL SPLIT, USE COMPLETE AVAILABLE ROOM FDWR57 MOVE BIN15,BIN4 B FDWR59 * NO OF CHARS, FIT IN AVAILABLE ROOM FDWR58 MOVE BIN15,BIN16 SEND ALL CHARS * FDWR59 XCOPY BPOOL(BIN10),DEBIN3,BIN15,BPOOL(BIN9),W0 COPY FIRST * MOVE BLANKS INTO REMAINING PART OF OUTPUT BUFFER * BIN4 = NO OF CHARS IN OUTPUT BUFFER MOVE BIN4,BIN15 ADD BIN4,DEBIN3 ADD HEADER * MOVE DEBIN1,RECLGD SUB DEBIN1,BIN4 NO OF BLANKS XCOPY BPOOL(BIN10),BIN4,DEBIN1,BPOOL(BIN9),BIN16 MOVE BLANKS * FDWR60 * INSERT RECORD NO - BCDI21(W5) CBE WORK(W17),W0,FDWR70 SKIP IF LENGTH ZERO MOVE STRG10A,BCDI21(W5) CONVERT RECORD NO MOVE DEBIN1,W10 LENGTH FIELD SUB DEBIN1,WORK(W17) FIND START OF NO XCOPY BPOOL(BIN10),WORK(W16),WORK(W17),STRG10A,DEBIN1 * FDWR70 * INSERT SEQUENCE NO - BCDI21(W4) CBE WORK(W19),W0,FDWR80 SKIP IF LENGTH ZERO MOVE STRG10A,BCDI21(W4) CONVERT SEQUENCE NO MOVE DEBIN1,W10 LENGTH FIELD SUB DEBIN1,WORK(W19) FIELD START OF NO XCOPY BPOOL(BIN10),WORK(W18),WORK(W19),STRG10A,DEBIN1 * FDWR80 * HANDLE END OF RECORD CBG BIN16,BIN15,FDWR100 NO ROOM, CONTINUATION * INSERT EOR MOVE STR2A,=X'7F' EOR CHAR XCOPY BPOOL(BIN10),BIN4,W1,STR2A,W1 INSERT EOR B FDWRSEND * FDWR100 * CHECK IF CONTINUATION CHAR NEEDED TBF BCONT,FDWR150 * CONTINUATION MOVE DEBIN1,RECLGD CBNE BIN4,DEBIN1,FDWR140 SUB BIN4,W1 SUB BIN15,W1 FDWR140 MOVE STR2A,=X'21' CONTINUATION MARK XCOPY BPOOL(BIN10),BIN4,W1,STR2A,W1 FDWR150 MOVE REQFD,=W'128' MOVE CWFD,W0 CALL FDIO,DSFD,X'06',BPOOL(BIN10),REQFD,CWFD MOVE CWFD,W0 DELETE BPOOL(BIN9),CWFD,BIN15 DELETE WHAT IS SEND SUB BIN16,BIN15 MOVE BIN13,BIN16 CMP VSEIND,W1 BE FDWR00 WRITE REST OF BUFFER RET 6 * FDWRBAL MOVE BPOOL(BIN10),=X'00' INITIATE OUTPUT BUFFER EDIT BPOOL(BIN9),FFD999 MOVE BIN4,RECLGD XCOPY BPOOL(BIN10),W0,BIN4,BPOOL(BIN9),W0 B FDWRSEND * * FDWRSEND MOVE REQFD,=W'128' MOVE CWFD,W0 CALL FDIO,DSFD,X'06',BPOOL(BIN10),REQFD,CWFD WRITE BLOCKS FDWRRET RET FDWR20 RET 2 PEND EJECT * * FDLOAD LOAD FD PROCEDURE * FDLOAD PROC MOVE CWFD,W7 HDR RECORD MOVE REQFD,=W'128' CALL FDIO,DSFD,X'B7',BPOOL(BIN10),REQFD,CWFD LOAD XSTAT DSFD,BIN4 CALL TESTB,BIN4,W5 IBM BZ FDLOA2 MOVE BIN7,=X'000F' CALL MASK,BIN4,BIN7 BNOK FDLOA2 RET FDLOA2 MOVE CWFD,W7 HDR RECORD MOVE REQFD,=W'128' CALL FDIO,DSFD,X'B8',BPOOL(BIN10),REQFD,CWFD UNLOAD RET 2 PEND EJECT * * CONVERSI0N OF DATA ENTRY RECORDS TO BPOOL BUFFER * RET =RECORD CONVERTED * RET 2 =TRANSMIT * RET 4 =CUMPULSORY FIELD EMPTHY * RET 6 =BCD-FIELD OVERFLOW * RET 8 =EDIT BUFFER OVERFLOW * * APPL = FIELD INTO BUFFER * APPL = 1 FIELD INTO BUFFER, TRANSMIT BLOCK * APPL = 2 NO TRANSMIT FIELD * APPL = 3 SUPPRESS LEADING ZEROES (IF HEADER:SETR GENEREL) * APPL = 4 LENGTH OF FIELD=MAXL (IF HEADER: SET GENERAL) * LISTE: ALWAYS SET * FOLLOWING APPL ONLY USED IN BATCHHEADER * APPL = 13 EOR-CHAR AS END OF EACH RECORD * LISTE: ALWAYS CLEAR * APPL = 14 CONT-CHAR IN END OF EACH DATA RECORD WHICH IS CONTINUED * LISTE: ALWAYS CLEAR * APPL = 15 INSERT BACHNAME IN THIS FIELD * APPL = 16 FIELDS (STARTING WITH &) ARE NOT SPLIT * LSTE: ALWAYS CLEAR * * APPL = 1XXX XXX=LENGTH OF RECORD HEADER * APPL = 2XXX THIS FIELD IS THE RECORD NUMBER FIELD * APPL = 3XXX THIS FIELD IS THE CONTINUATION SEQUENCE NUMBER FIELD * * BIN4 = WORK ITEM * BIN7 = MAX LENGTH * BIN8 = FIELD NUMBER * BIN9 = INDEX TO EDIT BUFFER * BIN13= DELETE START POINTER * BIN16= EDIT POINTER * * BIN15 = NO OF CHAR INSERTED IN OUTPUT RECORD * STRG10A = WORK STRING FOR DATE/TIME/CONVERTED BCD * WORK(W15) = LENGTH OF HEADER * WORK(W16) = RECORD NUMBER POSITION * WORK(W17) = RECORD NUMBER LENGTH * WORK(W18) = CONTINUATION SEQUENCE POSITION * WORD(W19) = CONTINUATION SEQUENCE LENGTH * BCDI21(W4) = CONTINUATION SEQUENCE NUMBER * BCDI21(W5) = RECORD NUMBER * CONV PROC CONT CBG CONT,W0,CON100 CON090 MOVE BPOOL(BIN9),=X'20' MOVE BCDI21(W4),=D'0' RESET SEQUENCE NO MOVE BIN13,W0 RESET DELETE POINTER MOVE BIN16,BIN13 LOAD EDIT POINTER CON100 CLEAR FSUPR TBF BSUPR,CON105 SET FSUPR CON105 ADD BIN8,W1 UPDATE FIELD NUMBER CALL GETFWD,BIN7,2,BIN8,BIN4 CALL ADJUST,BIN7 BOK CON130 BN CONRET ALL FIELD DONE B CONER1 COMPULSORY FIELD EMPTHY CON130 GETCTL 0,VSEIND GET APPL * CBL VSEIND,=W'1000',CON131 NORMAL APPL VALUE CBL VSEIND,=W'2000',APL1000 HANDLE RECORD HEADER CBL VSEIND,=W'3000',APL2000 HANDLE RECORD NO CBL VSEIND,=W'4000',APL3000 HANDLE SEQUENCE NO MOVE VSEIND,W2 CLEAR ERROR APPL B CON131 * * HANDLE RECORD HEADER: * APPL=1000, WHERE XXX=LENGTH OF RECORD HEADER APL1000 SUB VSEIND,=W'1000' MOVE WORK(W15),VSEIND WORK(W15) = LENGTH OF HEADER B CON100 * * HANDLE POSITION AND LENGTH OF RECORD NO APL2000 MOVE WORK(W16),BIN16 SET START POS OF RECORD NO GETCTL 1,BIN7 GET MAXL OF FIELD MOVE WORK(W17),BIN7 SET LENGTH OF RECORD NO SUB VSEIND,=W'2000' ADJUST APPL VALUE B CON131 FURTHER HANDLING * * HANDLE POSITION AND LENGTH OF SEQUENCE NO APL3000 MOVE WORK(W18),BIN16 SET START POSITION OF SEQUENCE NO GETCTL 1,BIN7 GET MAXL OF FIELD MOVE WORK(W19),BIN7 SET LENGTH OF SEQUENCE NO SUB VSEIND,=W'3000' ADJUST APPL VALUE B CON131 FURTHER HANDLING * * CON131 * CBNE BTYPE,W3,CON150 * DATA RECORD IB VSEIND,CON132,CON100,CON135,CON140 CON132 B CON190 * CON135 * SUPPRESS LEADING ZEROES SET FSUPR B CON190 * CON140 * NO SUPPRESSION CLEAR FSUPR B CON190 * * CON150 * IN HEADER, SET GENERAL CONDITIONS IB VSEIND,CON152,CON100,CON155,CON160,CON152, C CON152,CON152,CON152,CON152,CON152, C CON152,CON152,CON165,CON170,CON175,CON180 CON152 B CON190 * CON155 * GENERAL SUPPRESS LEADING ZEROES SET BSUPR B CON100 * CON160 * GENERAL NO SUPPRESSION CBE FC,W9,CON100 LISTE: ALWAYS SET CLEAR BSUPR B CON100 * CON165 * EOR CHARACTER B CON100 * CON170 * CONTINUATION CHARACTER CBE FC,W9,CON100 LISTE: ALWAYS CLEAR SET BCONT INDICATE CONT. CHAR NEEDED B CON100 * CON175 * INSERT BATCH NAME MOVE BIN7,W6 MOVE BIN4,W188 SUB BIN4,BIN7 LENGTH FIELD SUB BIN4,BIN16 EDSUB BPOOL(BIN9),BIN16,FMTBATCH INSERT BATCHNAME B CON260 * CON180 * FIELDS (STARTING WITH &) ARE NOT SPLIT CLEAR SPLITFL NOT NORMAL SPLIT B CON100 * * CON190 CBE FC,W9,CON195 LISTE: ALL FIELDS INCLUDED TBF FSUPR,CON195 CALL EMPTYT,:FMTITEM TEST IF EMPTY BNZ CON280 EMPTY, IGNORE FIELD CON195 GETCTL 1,BIN7 GET MAXL TSTCTL 0 TEST - ALPHA BZ CON200 BCD * ALPHA MOVE BIN4,W188 GET EDIT BUFFER LENGTH SUB BIN4,BIN7 ADJUST WITH MAX LENGTH SUB BIN4,BIN16 ADJUST WITH EDIT POINTER BN CONER3 EDSUB BPOOL(BIN9),BIN16,FRMALP B CON260 EJECT * BCD CON200 CBG BIN7,W21,CONER2 BCD-OVERFLOW MOVE BIN4,W188 GET EDIT BUFFER LENGTH SUB BIN4,BIN7 ADJUST WITH MAX LENGTH SUB BIN4,BIN16 ADJUST WITH EDIT POINTER BN CONER3 GETCTL 3,BIN4 GET SCHK CALL TESTB,BIN4,W15 SIGN BZ CON220 NO TBF FSUPR,CON210 CBE FC,W9,CON205 EDSUB BPOOL(BIN9),BIN16,FRMTCS MOVE BIN13,BIN16 B CON280 CON205 IF LISTE EDSUB BPOOL(BIN9),BIN16,FRMZCD EDIT 21 DIGITS B CON215 CON210 EDSUB BPOOL(BIN9),BIN16,FRMBCS EDIT 21 DIGITS CON215 MOVE BIN4,W22 SET PICTURE LENGTH ADD BIN7,W1 ADJUST POINTER FOR SIGN B CON250 CON220 TBF FSUPR,CON230 CBE FC,W9,CON225 EDSUB BPOOL(BIN9),BIN16,FRMTCD MOVE BIN13,BIN16 B CON280 CON225 IF LISTE EDSUB BPOOL(BIN9),BIN16,FRMZCD B CON235 CON230 EDSUB BPOOL(BIN9),BIN16,FRMBCS CON235 MOVE BIN4,W21 SET PICUTR LENGTH CON250 SUB BIN4,BIN7 SET DELETE LENGTH DELETE BPOOL(BIN9),BIN13,BIN4 DELETE ADDED ZEROES CON260 ADD BIN13,BIN7 ADJUST DELETE/EDIT POINTER MOVE BIN16,BIN13 LOAD EDIT POINTER CON280 CBNE FC,W9,CON290 EDSUB BPOOL(BIN9),BIN16,FRMFILL LISTE: INSERT FILLER MOVE BIN13,BIN16 CON290 CBE VSEIND,W1,CONTRM APPL =1 TRANSM MOVE BIN4,RECLGD CBG BIN16,BIN4,CONTRM B CON100 EJECT CONRET RET ALL DONE CONTRM RET 2 WRITE/TRANSMIT BLOCK CONER1 RET 4 CUMPULSORY FIELD EMPTHY CONER2 RET 6 BCD FIELD OVERFLOW CONER3 RET 8 EDIT BUFFER OVERFLOW PEND EJECT * * FORMATS * FRMFILL FRMT FILLR ' ',1 FMEND FCOUNT FRMT FTEXT ' 1' FEOR NEW PAGE FILLR ' ',2 FILLR '*',10 FTEXT 'NUMBER: ' FMEL '9999',NUMBER FEOR FILLR ' ',2 FEOR FMEND FRMSOF FRMT FSL FCOPY =X'1D' FILLR ' ',62 FILLR ' ',62 FMEND FRMEOF FRMT FSL FCOPY =X'19' FILLR ' ',62 FILLR ' ',62 FMEND FRMC01 FRMT FSL FLINK FFD001 FMEND FRMVOL1 FRMT FCOPY STR8A FMEND FRMVOL2 FRMT FMEL '999999',DATE FMEND FRMVOL3 FRMT FMEL '99',FDCNT FMEND FBATC1 FRMT FLINK FBATCH FTEXT 'EJ AVST[MD' FEOR FNL FMEND FBATC2 FRMT FLINK FBATCH FTEXT 'NUMBER: ' FMEL '9999',BCD13A FILLR ' ',4 FTEXT 'MISST[MMER' FEOR FNL FMEND FBATC3 FRMT FLINK FBATCH FTEXT 'EJ GODKENDT' FEOR FMEND FBATCH FRMT FNL FEOR FNL FTEXT 'JOBNAME: ' FCOPY JOBNAME FILLR ' ',4 FTEXT 'BATCHNAME: ' FCOPY BATCH FILLR ' ',4 FMEND FMTBATCH FRMT FCOPY BATCH FMEND FDCHDR FRMT FNL FEOR FNL FTEXT 'S[NDNING' FLINK HDR FMEND FDCEND FRMT FNL FEOR FNL FTEXT 'S[NDNING' FTEXT ' KLAR' FLINK HDR FEOR FNL FMEND FDCERR FRMT FNL FEOR FNL FTEXT 'S[NDNING' FTEXT ' AVBRYTS' FLINK HDR FEOR FNL FMEND FFDHDR FRMT FNL FEOR FNL FTEXT 'FLOPPY DISC SKRIVNING' FLINK HDR FMEND FFDEND FRMT FNL FEOR FNL FTEXT 'FLOPPY DISC SKRIVNING' FTEXT ' KLAR' FLINK HDR FEOR FNL FMEND FFDERR FRMT FNL FEOR FNL FTEXT 'FLOPPY DISC SKRIVNING' FTEXT ' AFBRYDES' FLINK HDR FEOR FNL FMEND FLSHDR FRMT FNL FEOR FNL FTEXT 'LISTNING" FLINK HDR FMEND FLSEND FRMT FNL FEOR FNL FTEXT 'LISTNING KLAR' FLINK HDR FEOR FNL FMEND FLSERR FRMT FNL FEOR FNL FTEXT 'LISTNING AFBRYDES' FLINK HDR FEOR FNL FMEND HDR FRMT FILLR ' ',4 FTEXT 'DATO: ' FMEL '99-99-99',DATE FILLR ' ',4 FTEXT 'TID: ' FMEL '99-99-99',TIME FEOR FNL FTEXT 'IND: ' FMEL '99999',NUMBER FTEXT ' UD: ' FMEL '99999',BCDI21(W5) FEOR FNL FMEND EJECT FCAS02 FRMT FSL FCOPY =C'DEVICE' FILLR ':',1 FINP 9 FCOPY STSAVE(W3) FTAB 20 FCOPY =C'FILE' FILLR '-',1 FCOPY =C'NAME' FILLR ':',1 FINP 32 FCOPY STR8B FNL FCOPY =C'EXPIRATION DATE:' FINP 32 FCOPY STR6A FNL FCOPY =C'OLD DATA SET IDENTIFIER:' FINP 32 FCOPY STR8A FNL FCOPY =C'OLD VOLUME SEQUENCE NO:' FINP 32 FCOPY STR2A FNL FKI 1 FCOPY HEX00 FMEND EJECT FRMC99 FRMT FSL FLINK FFD999 FMEND FFD001 FRMT FCOPY =C'001' FMEL '999999',DATE FILLR ' ',60 FILLR ' ',56 FMEND FFD999 FRMT FTEXT =C'SLUTD' FMEL '99999',BCDI21(W5) FILLR ' ',60 FILLR ' ',62 FMEND EJECT FRMALP FRMT FCOPY :FMTITEM FMEND FRMBCD FRMT FMEL '999999999999999999999',:FMTITEM FMEND FRMTCD FRMT FMEL 'TTTTTTTTTTTTTTTTTTTT9',:FMTITEM FMEND FRMTCS FRMT FMEL 'TTTTTTTTTTTTTTTTTTTT9-',:FMTITEM FMEND FRMZCD FRMT FMEL 'BBBBBBBBBBBBBBBBBBBB9-',:FMTITEM FRMBCS FRMT FMEL '999999999999999999999-',:FMTITEM FMEND FRMTID FRMT FMEL '999',BCD13A FMEND END