/	WPCRE - CREATE A FILE
/	021	EMcD	12-Apr-85	Allow dead seq in file name create
/	020	WCE	11-JUL-83	PROVIDE FOR DOCUMENT NAMES ABOVE 999
/	019	WCE	23-JUN-83	ADD GET-DENSITY CHECK TO CUPCSZ ROUTINE
/	018	HLP	18-APR-83	MOVE CUBS TO END OF MODULE FOR WPCUT
/	017	HLP	15-DEC-82	CONDITIONALIZE SO QUBLK FOR WPCUT
/	016	GJP	14-DEC-82	CHANGE CHECK FOR BAD HOME BLOCK
/					TO CHECK FOR ALLOC  BLOCK INSTEAD
/					OF COS 310 COUNT
/	015	GJP	11-NOV-82	REMOVED FIX #9, MAINTAIN INDEX ORDER
/	014	GJP	08-OCT-82	FIX CREATE 201 DOCS BUG
/	013	GJP	04-OCT-82	ADDED CHECK FOR BAD HOME BLOCK
/	0012	SBB	22-JUN-82	KEEP ANGLE BRACKETS OUT OF FILENAMES
/	011	GDH	30-MAR-82	(ANOTHER) BUG FIX FOR 0009. ALLOW >
/					4096 CHARS IN INDEX FILE.
/	0010	GDH	10-MAR-82	BUG FIX FOR 0009 (DONT CNT NULLS).
/	0009	GDH	23-FEB-82	ADDED CODE TO MAINTAIN INDEX ORDER
/					(AT LEAST FOR LISTING PURPOSES)
/					FOR CPYFIL.
/	0008	GDH	08-FEB-82	ADDED "READ ERROR DETECTION".
/	0007	GDH	13-OCT-81	REMOVED INDEX UNLOCK (CAUSE IT'S
/					NOW NEVER LOCKED!)
/	0006	AJF	06-OCT-81	REMOVE DOC LOCK ON CREATE
/	0005	GDH	26-AUG-81	WPFILS CALLING SEQ CHANGES.
/	0004	TT	07-JUL-81	REMOVED SUPERFLUOUS CONDITIONALS
/	0003	AJF	02-FEB-81	CONDITIONALIZED FOR WPSTPR, SORT/PARSR
/	0002	DM,JM	15-SEPT-80	MERGED SCANDI AND EUROPE/ENGLISH
/	0001	DSS	09-JUL-80	MODIFIED FOR ENGLISH/FRENCH-CANADIAN
/	3XX	EPS	14-AUG-79	CHANGES FOR FOREIGN LANGUAGES
/	III.D	KEE	29-MAR-78	CHANGES FOR WT78 FILE NUMBER
/					REPRESENTATION IN PARTICULAR,
/					HAVE MENU DO ANY CREATE

/ADRCRT - THIS SUBROUTINE OVERSEES THE CREATION OF A DOCUMENT,
/INCLUDING ANY ENTRY INTO THE INDEX DOCUMENT.

/TO CALL FROM ANOTHER FIELD -
/CDFMYF
/CDFBUF		(MUST BE RUN IN BUFFER FIELD)
/JMS I	(ADRCRT	(SHOULD BE A LOCATION WITH THE ADDRESS OF THIS CREATE
/IN THE FIELD THAT THE CALL IS MADE FROM)
/ERROR	(IN CASE OR ERROR, CONTROL RETURNS HERE)
/NORMAL

/TO CALL FROM BUFFER FIELD -
/JMS	ADRCRT
/ERROR	(ERROR RETURN)
/NORMAL

/UPON ENTRY -
/AC	IRRELEVANT

/MENU AREA ARRAY 'FNAMSP' CONTAINS THE ASCII DOCUMENT NAME OR NUMBER,
/ONE CHARACTER PER WORD, ENDING WITH A ZERO
/MENU AREA 'MNDRV' CONTAINS THE DRIVE NUMBER

/FOR MULTI-TERMINAL 8 SYSTEMS, THE DRIVE INDEX DOCUMENT HAS BEEN
/LOCKED (EVEN IF NO DOCUMENT 1, IT HAS BEEN LOCKED ANYWAY -
/THIS ENSURES THAT ONLY ONE CREATE AT A TIME HAPPENS ON A GIVEN DRIVE)

/** THERE IS NO CURRENT 'RDFIL' ACTIVITY **

/NORMAL RETURN -
/THE DOCUMENT HAS BEEN CREATED AND ANY INDEX ENTRY MADE
/AC, 'CUPFNO' = FILE NUMBER OF CREATED DOCUMENT (WITH DRIVE NUMBER IN
/BITS 0-3)

/ERROR RETURN -
/AC = 0, 'CUPFNO' = 0
/WHEN ASSEMBLED WITH 'ADRASM' DEFINED, ERROR MESSAGES HAVE DISPLAYED
/OTHERWISE, NO USER DISPLAYS HAVE BEEN DONE

/IN EITHER CASE -
/T1, T2 HAVE BEEN CLOBBERED
/FOR MULTI TERMINAL 8 SYSTEMS, ALL DOCUMENTS HAVE BEEN UNLOCKED
/THE 'RDFIL' BUFFER HAS BEEN CLOBBERED



/TO ACCOMPLISH THIS, THE FOLLOWING STEPS ARE TAKEN -

/IF A FLOPPY CREATE, ENSURE THAT THERE IS ENOUGH ROOM.
/IF CREATE BY NUMBER, VALIDATE THE NUMBER AND CREATE THE DOCUMENT
/IF BY NAME, FIND THE FIRST UNUSED DOCUMENT NUMBER, CREATE A DOCUMENT
/WITH THAT NUMBER, IF NECESSARY, CREATE DOCUMENT 1 (THE INDEX DOCUMENT),
/AND THEN ADD THE NAME TO THE INDEX DOCUMENT.
/THE DOCUMENT NUMBER THAT WAS CREATED IS RETURNED IN THE AC

/**** NOTES TO THOSE WHO CHANGE THIS CODE:
/AN ATTEMPT WAS MADE TO KEEP THE BULK OF THE UNUSED SPACE ON THE FIRST
/PAGE SO THAT IT CAN BE USED BY THE MAIN ROUTINE.  OTHER PROGRAMS
/USE THIS SPACE.

/THERE IS 1 FUNNY ASSEMBLY OPTION SPECIFIC TO THIS ROUTINE
/(AS OPPOSED TO SYSTEM-WIDE)

/ADRASM	WHEN DEFINED, NO ERROR MESSAGES ARE DISPLAYED AFTER AN ERROR.

	CIFSCR=	CIFMNU		/FIELD WHERE THE VERSION OF SCROLL USED
				/BY CREATE LIVES
	CUPFNM=	7400		/USE RDFIL  BUFFER FOR THIS SCRATCH AREA
	CUPBF0=	CUPFNM+STRLEN	/START OF SCRATCH AREA FOR NUMBER CONVERSION
				/FIRST WORD CONTAINS NEG LENGTH OF THE AREA
	CUPBUF=	CUPBF0+1	/THE REST.
				/MUST BE STRLEN AVAILABLE WORDS AFTER THIS
	CUPEND=	CUPBUF+STRLEN	/THE LAST LOCATION OF THE SCRATCH AREA

ADRCRT,	XX
	CLA
	RDF
	TAD	CIDF0		/MAKE CROSS FIELD CALLABLE
	DCA	ADRCX2
	CDFMNU			/GET THE MENU CONSTANTS FOR THE CREATE
	TAD I	(FNAMSP) 	/LOCATION OF NAME
	DCA	CUPFNS
	AC7777			/ADR WILL BE USED BY INDEX REGISTER	/A012
	TAD	CUPFNS		/GET POINTER AGAIN			/A012
	JMS	BRKTST		/TEST FOR ANGLE BRACKETS IN FILENAME	/A012
	TAD I	(MUBUF+MNDRV)
	CDFMYF
	DCA	CUPDRV
	TAD	CUPDRV
	BSW
	RTL CLL			/BUILD DRIVE NUMBER WITH INDEX DOC NUMBER
	IAC
	DCA	CUPD1
	JMS	CUPCSZ		/SEE IF ROOM
	JMS	CUPERR							/M020

	JMS	CUCOPY

CUPFNS,	0
	CDFMNU
	CUPFNM
	CDFMYF
	STRLEN
	TAD	(CUPFNM) 	/INITALIZE THE POINTER
	DCA	T1
	TAD	(-STRLEN)	/SET UP LENGTH OF NUMBER SCRATCH AREA	/M020
	DCA	CUPBF0
	CIFMNU
	JMS I	NXACAL
	T1
	CUPBUF-1
	JMS	CUPERR							/M020
	CIFMNU
	JMS I	CVDCAL		/SEE IF THE TOKEN IS A FILE NUMBER
	CUPBUF
	JMP	CUPNAM		/IF NOT TRY A NAME
	DCA	CUPFNO		/ELSE IT IS A DOCUMENT NUMBER
	TAD	CUPFNO
	SNA			/ZERO FILE NUMBER?
	JMP	CUPOOR		/YES, ERROR.
	CLL			/MAKE SURE THAT LINK IS CLEAR		/A020
	TAD	(-1750)		/CHECK FOR A NUMBER LARGER THAN 999	/A020
	SZL CLA			/LINK WILL BE CLEAR IF NUMBER IN RANGE	/A020
	JMP	CUPNAM		/USE LARGE NUMBER AS DOCUMENT NAME	/A020
	TAD	CUPFNO		/NOW CHECK FOR 201-999 RANGE		/A020
	TAD	(-MAXDOC)
	SMA CLA			/GREATER THAN MAX?
	JMP	CUPOOR		/YES, ERROR.

ADRCNT,	JMS	CUPMFN		/PLACE FILE NUMBER IN AC AND 'CUPFNO'.	/A020
	JMS	CUPCRF		/CREATE THE FILE			/A020
	JMS	CUPERR		/ERROR					/A020

/NORMAL RETURN.								/A020

ADRCRX,	ISZ	ADRCRT							/A020
ADRCR2,									/A020
ADRXXX,	CLA								/A020
	TAD	CUPFNO		/PICK UP RETURN PARAMETER		/A020
ADRCX2,	XX								/A020
	JMP I	ADRCRT							/A020

/ERROR ENCOUNTERED - ISSUE MESSAGE AND RETURN

CUPERR,	XX			/SAVE WHERE ERROR DETECTED		/A020
	AC7776			/GENERAL UNABLE TO CREATE MESSAGE	/M020
CUPOON,	IAC			/TOO MANY DOCUMENTS
CUPOOR,	IAC			/CREATE BY NUMBER OUT OF RANGE

	IFNDEF ADRASM <

	CDFMNU
	DCA I	(MUBUF+MNTMP1)
	CDFMYF

	CIFMNU
	JMS I	MNUCAL
	DLMPP2

	>			/END IFNDEF ADRASM

	IFDEF ADRASM <							/A003
	IFZERO ADRASM <							/A003
	CDFMYF								/A012
	DCA	ERSTAT		/STORE ERROR TYPE IN VARIABLE FOR WPSTP	/A003
	JMP	ADRCR2		/EXIT					/A003

	>>	/END IFDEF ADRSAM ZERO DEFINED BY WPSTPR		/A003

	CLA
	DCA	CUPFNO
	JMP	ADRCR2


CUPDRV,	0
CUPFNO,	0			/FILE NUMBER FOR DOCUMENT (W/DRIVE NUMBER SET)
CUPD1,	0			/FILE NUMBER FOR INDEX DOCUMENT (W/DRIVE NUMBER)

/CUPMFN - MAKE FILE NAME FROM DOCUMENT NUMBER AND DRIVE NUMBER

/UPON ENTRY -
/AC	ZERO
/CUPFNO	CONTAINS DOCUMENT NUMBER
/CUPDRV	CONTAINS DRIVE NUMBER

/TO CALL -
/JMS	CUPMFN

/WHEN DONE -
/AC	CONTAINS FILE NUMBER
/CURFNO	CONTAINS FILE NUMBER

CUPMFN,	XX
	TAD	CUPDRV		/MAKE CORRECT SIGN
	BSW
	RTL CLL
	TAD	CUPFNO
	DCA	CUPFNO
	TAD	CUPFNO
	JMP I	CUPMFN

IFDEF	GERSTLE	<							/A015
IFDEF	CPYFIL	<							/A011
CUPCPY,	XX			/ROUTINE TO INDEX INTO INDEX FILE	/A011
	DCA	CUPSC2		/USE THIS TEMP.				/A009
CUPSH3,	JMS	CUPSHG		/GET A CHARACTER.			/A009
	SNA			/SKIP IF NOT E-O-F.			/A009
	JMP	CUPSH4		/WE SHOULDN'T EVER GET HERE, BUT...	/A009
	CIFFIO
	FILEIO
	XPUTST			/COPY CHAR BACK OUT.			/A009
	ISZ	CUPSC2		/1 LESS CHAR TO COPY OUT.		/A009
	JMP	CUPSH3		/DO ANOTHER ONE (UNLESS DONE).		/A009
	CLA			/RETURN CLEAN AC.			/A011
	JMP I	CUPCPY		/RETURN TO CALLER.			/A011

CUPSC2,	0			/TEMP					/A011
		>		/END IFDEF CPYFIL			/A011
		>  	/END IFDEF GERSTLE				/A015
	IFDEF	GERSTLE	<						/A015
	IFDEF	CPYFIL	<	/**** WARNING **** BRKTST IS DUPLICATED HERE
				/AND AFTER CUCOPY BECAUSE CPYFIL HAS ROOM
				/HERE AND OTHER MODULES HAVE ROOM THERE	/A012

BRKTST,	XX			/TEST FOR ANGLE BRACKETS		/A012
	DCA	X0		/ENTERED WITH ADR IN AC			/A012
BRKRPT,	TAD I	X0		/GET A CHAR FROM FILENAME		/A012
	SNA			/A ZERO WORD TERMINATES STRNG		/A012
	JMP I	BRKTST		/EXIT					/A012
	TAD	(-76		/COMPLIMENT OF RIGHT ANGLE		/A012
	SNA			/SKIP IF IT'S NOT AN ANGLE		/A012
	JMS	CUPERR		/GENERAL ERROR EXIT			/M020
	IAC			/TEST FOR LEFT ANGLE BRACKET ALSO	/A012
	IAC								/A012
	SNA CLA			/SKIP IF IT'S NOT AN ANGLE		/A012
	JMS	CUPERR		/GENERAL ERROR EXIT			/M020
	JMP	BRKRPT		/KEEP LOOKING TILL DONE			/A012
		>		/END IFDEF CPYFIL			/A012
		>		/END IFDEF GERSTLE			/A015

/A020 - QUEUE BLOCK MOVED HERE FOR SPACE REASONS

IFNDEF WPCUT <								/A017
QUBLK,	DSKQUE
	0
	0
QUQBLK,	0
	0
	0
	0
	0
	0
	0
	0
	0
	0
	0
	0
	0
	0
	0			/RXSEC SECTOR
	>			/END IFNDEF WPCUT

	X=.			/FIRST FREE LOCATION ON THIS PAGE	/A019
/--------------------
	PAGE

CUPNAM,	CLA			/GET A FREE NUMBER
	TAD	(RXBDIR)	/DIR BLOCK
	DCA	QUQBLK+RXQBLK
	TAD	(RXERD+4000
	DCA	QUQBLK+RXQFNC
	TAD	(CUB1
	DCA	QUQBLK+RXQBAD
	JMS	QURX		/GET DIR BLOCK INTO MEMORY
				/(BUF FIELD AND ADDRESS ALREADY IN
				/Q-BLK FROM 'CUPCSZ')

	SPA CLA
	JMS	CUPERR		/ERROR IN DISK				/M020
	TAD	CUB1+6		/GET ALLOC FROM BLOCK JUST READ		/C016
	JMS	CKHMBL		/GO MAKE SURE THE BLOCK IS A HOME BLOCK	/A013
	TAD	CUB1+11 	/GET MAX NUMBER OF FILES
	DCA	T2		/SAVE AS NEGATIVE MAX
	TAD	(CUB1+13 	/GET ADDR OF FIRST ONE
	DCA	T1		/SAVE
	DCA	CUPFNO		/INIT COUNT WHICH WILL GIVE US NUMBER
	ISZ	T2		/START WITH SECOND DOC (NOT INDEX DOC)	/A014
CUPGF1,	ISZ	CUPFNO		/INCR COUNT
	TAD I	T1		/GET FIRST BLOCK PTR
	SNA CLA
	JMP	CUPGTN		/ZERO - GOT A FREE ONE
	ISZ	T1		/NEXT WORD
	ISZ	T2		/ANY MORE?
	JMP	CUPGF1		/YES

	JMP	CUPOON		/OUT OF NUMBERS

CUPGTN,	ISZ	CUPFNO

	JMS	CUPMFN		/MAKE FILE NAME, LEAVE IT IN AC
	JMS	CUPCRF		/CREATE THE FILE
	JMS	CUPERR		/COULDN'T				/M020

CUPL1A,	TAD	CUPD1		/OPEN INDEX (AC ZERO AT THIS POINT)
	MQL
	CIFFIO
	FILEIO
	XDSKIN			/OPEN FOR UPDATE

	SNA CLA
	JMP	CUPSH1		/GOT IT - SKIP OVER HEADER, RULER, STUFF
	TAD	CUPD1

	JMS	CUPCRF
	JMS	CUPERR							/M020
	JMP	CUPL1A

CUPSH1,	JMS	CUPSH2		/GET OVER THE RULERS AND OTHER JUNK

	IFDEF	GERSTLE	<						/A015
	IFDEF	CPYFIL	<						/A011
	TAD	CUPCHI		/SEE IF ANY HI PRECISION COPY TO BE DON	/A011
	SNA
	JMP	CUPSH6		/JMP IF NO. CHECK LO PRECISION PART.	/A011
	CIA
	DCA	CUPSC1		/SAVE TEMP COUNTER.			/A011
CUPSH5,	JMS	CUPCPY		/DO 4096 COPIES.			/A011
	ISZ	CUPSC1		/SEE IF DONE YET.			/A011
	JMP	CUPSH5		/JMP IF NOT YET.			/A011
CUPSH6,	TAD	CUPCLO		/GET # OF CHARS TO BE BOPPED OVER.	/A009
	SNA			/SKIP IF WE'VE GOT SOME TO DO.		/A009
	JMP	CUPSH4		/JMP IF THIS IS THE 1ST TIME THRU.	/A009
	CIA			/MAKE A NEGATIVE COUNT.			/A009
	JMS	CUPCPY		/INDEX INTO INDEX FILE.			/M011
CUPSH4,				/HERE WHEN POSITIONED TO AFTER LAST	/A009
				/ENTERED FILE NAME.			/A009
			>	/LIFYPC FEDFI				/A011
			> 	/END IFDEF GERSTLE			/A015
	TAD	CUPFNO		/ISOLATE DRIVE AND FILE NUMBERS FOR MESSAGE
	AND	P377
	DCA	CUPSC1
	CIFMNU
	JMS I	IOACAL		/OUTPUT NUMBER AND STUFF
	CUPOTD			/TO DOCUMENT
	CUPOST
	CUPOS1
	CUPFNM
	CUPOS3
CUPSC1,	0
	CUPOS3

CUPCL1,				/COPY REST OF FILE
	JMS	CUPSHG		/GET CHAR (& CHECK FOR ERR)		/M0009
	SNA
	JMP	CUPCLS		/DONE
	CIFFIO
	FILEIO
	XPUTST
	JMP	CUPCL1

CUPCLS,	CIFFIO
	FILEIO
	XDSKCL			/CLOSE INDEX
	JMP	ADRCRX

	IFDEF	GERSTLE	<						/A015
	IFDEF	CPYFIL	<						/A011
CUPCHI,	0			/DOUBLE PRECISION COUNT (HI WORD) OF #	/A011
				/OF CHARS INTO INDEX OF LAST ENTERED	/A011
				/FILENAME.				/A011
CUPCLO,	0			/COUNT OF CHARS INTO INDEX OF LAST ENTERED
				/FILE NAME (LO WORD).			/A009
			>	/LIFYPC FEDFI				/A011
			>	/END IFDEF GERSTLE			/A015

/CUCOPY - ROUTINE TO COPY BLOCK OF MEMORY

/JMS	CUCOPY
/ADDR OF FROM
/CDF FROM FIELD
/ADDR OF TO
/CDF TO FIELD
/NUMBER OF WORDS TO COPY
/RETURN, AC = 0

CUCOPY,	XX
	AC7777			/GET FIRST ADDR - 1 FOR INDEX REGISTER
	TAD I	CUCOPY
	ISZ	CUCOPY
	DCA	X0
	TAD I	CUCOPY		/AND FIELD
	ISZ	CUCOPY
	DCA	CUCPY0		/SAVE FOR LATER USE
	AC7777			/DO SAME FOR TO VALUES
	TAD I	CUCOPY
	ISZ	CUCOPY
	DCA	X1
	TAD I	CUCOPY
	ISZ	CUCOPY
	DCA	CUCPY1
	TAD I	CUCOPY
	ISZ	CUCOPY		/GET COUNT
	CIA			/MAKE ISZ COUNT
	DCA	CUCPYC		/AND SAVE FOR USE

CUCPYL,
CUCPY0,	.-.			/A CDF FOR FIRST FIELD
	TAD I	X0		/GET WORD
CUCPY1,	.-.			/A CDF FOR THE RECEIVING FIELD
	DCA I	X1		/STORE WORD
	ISZ	CUCPYC		/DONE?
	JMP	CUCPYL		/NO - DO NEXT WORD

	CDFMYF			/YES - BACK TO OUR FIELD
	JMP I	CUCOPY		/RETURN TO CALLER

CUCPYC,	0

IFNDEF	CPYFIL	< /****WARNING** WOULD OVERFLOW PAGE. SEE CUPSC2+1	/A012
				/TO DUPLICATE ANY CHANGES HERE		/A012
BRKTST,	XX			/TEST FOR ANGLE BRACKETS		/A012
	DCA	X0		/ENTERED WITH ADR IN AC			/A012
BRKRPT,	TAD I	X0		/GET A CHAR FROM FILENAME		/A012
	SNA			/A ZERO WORD TERMINATES STRNG		/A012
	JMP I	BRKTST		/EXIT					/A012
	TAD	(-76		/COMPLIMENT OF RIGHT ANGLE		/A012
	SNA			/SKIP IF IT'S NOT AN ANGLE		/A012
	JMS	CUPERR		/GENERAL ERROR EXIT			/M020
	IAC			/TEST FOR LEFT ANGLE BRACKET ALSO	/A012
	IAC								/A012
	SNA CLA			/SKIP IF IT'S NOT AN ANGLE		/A012
	JMS	CUPERR		/GENERAL ERROR EXIT			/M020
	JMP	BRKRPT		/KEEP LOOKING TILL DONE			/A012
		>		/END IFNDEF CPYFIL			/A012

	IFNDEF	GERSTLE	<						/A015
	IFDEF CPYFIL <							/A015
BRKTST,	XX			/TEST FOR ANGLE BRACKETS		/A012
	DCA	X0		/ENTERED WITH ADR IN AC			/A012
BRKRPT,	TAD I	X0		/GET A CHAR FROM FILENAME		/A012
	SNA			/A ZERO WORD TERMINATES STRNG		/A012
	JMP I	BRKTST		/EXIT					/A012
	TAD	(-76		/COMPLIMENT OF RIGHT ANGLE		/A012
	SNA			/SKIP IF IT'S NOT AN ANGLE		/A012
	JMS	CUPERR		/GENERAL ERROR EXIT			/M020
	IAC			/TEST FOR LEFT ANGLE BRACKET ALSO	/A012
	IAC								/A012
	SNA CLA			/SKIP IF IT'S NOT AN ANGLE		/A012
	JMS	CUPERR		/GENERAL ERROR EXIT			/M020
	JMP	BRKRPT		/KEEP LOOKING TILL DONE			/A012
		>	/END IFDEF CPYFIL				/A015
		>	/END IFNDEF GERSTLE				/A015

	X=.			/FIRST FREE LOCATION ON THIS PAGE	/A019
/--------------------
	PAGE


CUPCSZ,	XX			/CHECK DRIVE DENSITY & FREE SPACE ROUTINE
	CLA
	TAD	CUPDRV
	JMS	CUPDRS		/SET THE DRIVE

	TAD	(4000+RXEDN)	/GET DENSITY OF DISKETTE		/A019
	DCA	QUQBLK+RXQFNC	/STORE COMMAND IN Q-BLOCK		/A019
	JMS	QURX		/GO DO THE COMMAND			/A019
	SPA CLA			/AC WILL BE NEGATIVE ON ERROR		/A019
	JMP	CUPCSE		/GO REPORT "UNABLE TO CREATE" ERROR	/A019

	TAD	(4000+RXESP)	/GET SPACE LEFT ON DISKETTE
	DCA	QUQBLK+RXQFNC
	JMS	QURX

	SPA CLA
	JMP	CUPCSE		/ERROR

	TAD	(-10		/NEED AT LEAST 8
	TAD	QUQBLK+RXQSPC
	SMA CLA			/ENOUGH ROOM?
	ISZ	CUPCSZ		/YES, SKIP ERROR RETURN FROM SUBROUTINE.
CUPCSE,	JMP I	CUPCSZ		/DONE - ALL OKAY

/CUPDRS -- SET CORRECT DRIVE FOR RXHAN

CUPDRS,	XX
	AND	(17)
	DCA	QUQBLK+RXQDRV
	RDF
	TAD	CDF0
	DCA	QUQBLK+RXQBFD
	JMP I	CUPDRS

CUPOTD,	XX
	MQL
	RDF
	TAD	CIDF0
	DCA	CUPODR
	MQA
	CDFMYF
	SNA			/SKIP IF LEGIMATE CHAR.			/A010
	JMP	CUPODR		/IF NULL THEN DON'T OUTPUT IT.		/A010
	CIFFIO
	FILEIO
	XPUTST

	IFDEF	GERSTLE	<						/A015
	IFDEF	CPYFIL	<	/ENABLE INDEX ORDER ONLY FOR CPYFIL	/A009
	ISZ	CUPCLO		/KEEP TRACK WHERE END OF FILENAME IS	/A009
	SKP			/SKIP IF NO OVERFLOW.			/A011
	ISZ	CUPCHI		/ACCOUNT FOR IDIOTS WHO DO MORE THAN	/A011
				/4096 CHARS OF FILE NAMES		/A011
	NOP			/(SHOULDN'T NEED THIS BUT IT'S HERE	/A011
				/FOR SAFTEY'S SAKE).			/A011
			>	/LIFYPC FEDFI				/A009
			>	/END IFDEF GERSTLE			/A015

CUPODR,	0
	JMP I	CUPOTD

/A020 - CKHMBL ROUTINE MOVED HERE FOR SPACE REASONS
/***********************************************************************
/THIS CODE WILL CHECK TO SEE IF THE BLOCK AT CUB1 JUST READ IS		/A013
/A HOME BLOCK. IF NOT A HOME BLOCK, IT RETURNS AND ERROR.		/A013
/***********************************************************************

CKHMBL,	XX								/A013
	TAD	(7401)		/CHECK FOR ALLOC BLOCK		/C01	/A013
	SZA CLA			/IF COSCNT, THEN ITS OK			/A013
	JMS	CUPERR		/NOT A HOME BLOCK			/M020
	TAD	CUB1+1		/GET HOME BLOCK ID			/A013
	AND	(6077)		/STRIP OFF VERSION NBR			/A013
	CIA			/SET FOR COMPARE			/A013
	TAD	(30)		/HOME BLOCK CODE			/A013
	SZA CLA								/A013
	JMS	CUPERR		/NOT A HOME BLOCK			/M020
	JMP I	CKHMBL		/ITS A HOME BLOCK (I HOPE!!!!!!)	/A013

/CUPCRF - CREATE FILE SUBROUTINE

/TAD	FILENO (WITH DRIVE NUMBER IN BITS 0-3)
/JMS	CUPCRF
/ERROR RETURN
/NORMAL RETURN

/UPON RETURN, AC IS ZERO.

CUPCRF,	XX
	DCA	CUPCRN		/SAVE FILENO
	TAD	CUPCRN
	AND	P377
	DCA	QUQBLK+RXQFNO	/SAVE IN QUEUE BLOCK
	TAD	CUPCRN
	BSW
	RTR
	JMS	CUPDRS		/SET DRIVE
	TAD	(RXEAL		/ALLOC A BLOCK FOR THE HEADER
	DCA	QUQBLK+RXQFNC
	JMS	QURX

	CLA
	CDFSYS			/GET TIME INFO
	TAD I	(PAKDAT)
	CDFMYF
	DCA	CUPCRB+6
	CDFSYS
	TAD I	(YEAR)
	CDFMYF
	DCA	CUPCRB+7

	TAD	QUQBLK+RXQFNO	/SET FILE NUMBER INFO
	DCA	CUPCRB+13
	TAD	(RXEWT+2000	/WRITE OUT HEADER BLOCK
	DCA	QUQBLK+RXQFNC
	TAD	(CUPCRB)
	DCA	QUQBLK+RXQBAD
	JMS	QURX
	CLA
	TAD	(RXESF		/SET AS FIRST BLOCK OF FILE
	DCA	QUQBLK+RXQFNC
	JMS	QURX
	CLA
	ISZ	CUPCRF
	JMP I	CUPCRF		/RETURN OK

CUPCRN,	0

/QURX - QUEUE TO RXHAN

QURX,	XX
	CIFSYS
	ENQUE
	QUBLK

QURX1,	CIFSYS
	JWAIT
	CLA
	TAD	QUQBLK+RXQCOD
	SNA
	JMP	QURX1
	JMP I	QURX
	X=.			/FIRST FREE LOCATION ON THIS PAG	/A019
/--------------------
	PAGE

CUPSH2,	XX			/SKIP OVER INITIALIZATION STUFF
				/IN INDEX DOCUMENT (LIKE INITIAL RULER,
				/ANY PRINT CONTROLS, ETC.)
CUPSHD,	JMS	CUPSHG		/GET CHAR				/M008
	TAD	(-16		/RULER START?
	SNA
	JMP	CUPSRL		/YES
	TAD	(16-1014 	/PRINTER COMMAND?
	SNA
	JMP	CUPSPC		/YES
	TAD	(1014		/GET IT BACK
	CIFFIO
	FILEIO
	XPUTET			/PUT IT BACK
	JMP I	CUPSH2		/DONE

CUPSR1,	IAC
CUPSRL,	TAD	(16		/SKIP RULER - OUTPUT TO STX
	CIFFIO
	FILEIO
	XPUTST
	JMS	CUPSHG		/GET ANOTHER CHARACTER.			/M008
	SNA
	JMP	CUPDRL		/DONE (EOF)
	TAD	(-17
	SZA
	JMP	CUPSR1		/END OF RULER

CUPDRL,	TAD	(17)
	CIFFIO
	FILEIO
	XPUTST
	JMP	CUPSHD		/TRY SOME MORE

CUPSP1,	TAD	(400
CUPSPC,	TAD	(1014		/SKIP OVER PRINTER CONTROL
	CIFFIO
	FILEIO
	XPUTST
	JMS	CUPSHG		/GET ANOTHER CHARACTER			/M008
	SNA
	JMP	CUPDPC
	TAD	(-1414
	SZA
	JMP	CUPSP1

CUPDPC,	TAD	(1414
	CIFFIO
	FILEIO
	XPUTST
	JMP	CUPSHD

CUPSHG,	XX			/RETURN ADDRESS.			/A008
	CIFFIO
	FILEIO
	XGETET			/GET A CHARACTER.			/A008
	SMA			/SKIP IF "READ ERROR".			/A008
	JMP I	CUPSHG		/RETURN CHAR TO CALLER.			/A008
CUPER1,	CIFFIO
	FILEIO
	XDSKCL			/CLOSE FILE				/M012
	JMS	CUPERR		/REPORT "READ ERROR" TO CALLER.		/M020


CUPCRB,	COSCNT
	0010			/FLAGS
	0
	0			/HEADER EXTENTIONS
	50			/COUNT OF INFO WORDS
	0			/COUNT OF BLOCKS IN FILE
	0
	0			/CREATE DAY,,MONTH;YEAR
	0
	0			/MODIFIED DAY,,MONTH;YEAR
	0			/TIMES EDITED
	0			/FILE NUMBER
	ZBLOCK 40		/OTHER INFO
	0			/ZERO'TH PTR
	0			/LAST PTR

	TMPA=.
	*CUPCRB+21
	IFDEF FRENCH <0101>
	IFDEF DUTCH <0201>
	IFDEF ENGCAN <0301>
	IFDEF CANADA <0301>
	IFDEF GERMAN <0401>
	IFDEF NORWAY <0501>
	IFDEF SWEDSH <0601>
	IFDEF DANISH <0701>
	*TMPA

/STRINGS FOR INDEX DOCUMENT ENTRIES

CUPOST,	TEXT '^AN>^B^A#>^D^A>'		/ Use ^B to output dead string	/M021

/BRACKETS - IT SERVES NO OTHER FUNCTION

CUPOS1,	12
	7
	74
	0
CUPOS3,	74
	0
	X=.			/FIRST FREE LOCATION ON THIS PAGE	/A019
/--------------------
	PAGE


	IFDEF WPCUT <							/A018
	CUB1=.			/THIS BUFFER DOES NOT CLOBBER SCROLL	/A018
	CUB2=.+400		/BUT THIS BUFFER CANNOT BE USED AT	/A018
				/THE SAME TIME AS SCROLL		/A018
			>						/A018

	X=.			/REMEMBER ASSEMBLY POINTER		/A020
	*CUPFNM			/USE RDFIL BUFFER FOR SCRATCH AREA	/A020
CUPFNM,	ZBLOCK STRLEN		/BUFFER TO HOLD THE FILE NAME STRING	/A020
CUPBF0,	-STRLEN			/SCRATCH AREA FOR NUMBER CONVERSION -	/A020
				/FIRST WORD HAS NEG LENGTH OF THE AREA	/A020
CUPBUF,	ZBLOCK STRLEN		/AVAILABLE SPACE MUST BE STRLEN WORDS	/A020
CUPEND,	0			/THE LAST LOCATION OF SCRATCH AREA	/A020
	*X			/RESET POINTER FOR OTHER MODULES	/A020




