TITLE	TAPACT - U OF O DECTAPE ACCOUNTING - 4(11)-2
	SUBTTL	D. THOMSON - 2 FEB 73
	VWHO==2		;WHO LAST MODIFIED THIS CUSP
	VTAPAC==4	;MAJOR VERSION #
	VMINOR==0	;MINOR VERSION #
	VEDIT==11	;EDIT #

	.JBVER==137
	LOC	.JBVER
	BYTE	(3)VWHO(9)VTAPAC(6)VMINOR(18)VEDIT
	RELOC
	;AC DEFINITIONS
	F=0
		LNGMOD==400000
	A=1
	B=2
	C=3
	D=4
	CH=6
	T=7
	N1=11
	N2=12
	W=13
	WORD0=14
	WORD2=15
	P=17
	;DEFINITIONS FROM TAPE.MAC
	SYSTOP==^D500		;LIMIT OF SYSTEMS BLOCK
	RENTOP==^D5000		;LIMIT OF RENTAL BLOCK
	;MISC DEFINITIONS
	IN==1			;I/O CHANNEL FOR INPUT
	OUT==2			;I/O CHANNEL FOR OUTPUT
	DTACOD==500		;ACCOUNTING CODE FOR DTA ENTRIES
	DTALEN==4		;LENGTH OF DTA RECORDS IN ACCT.SYS
	L.CTY==200000		;CTY FLAG IN GETLCH WORD
	C.CR==15		;ASCII CARRIAGE RETURN

	.JBREN==124		;SET UP REENTER ADDRESS TO ALLOW
	LOC	.JBREN		;  LONG DIALOG
	EXP	DIALOG
	RELOC
	;INITIALIZATION

DIALOG:	TLOA	F,LNGMOD	;SET DIALOG MODE FLAG
TAPACT:	TLZ	F,LNGMOD	;CLEAR DIALOG MODE FLAG
	RESET			;RESET THE WORLD
	MOVE	P,[IOWD 20,PDL]	;SET UP PDL
	PUSHJ	P,TTYNUM	;GET BINARY TTY # IN RH OF N1
	MOVE	W,[DTACOD_11,,DTALEN];GET SKELETON HEADER WORD
	DPB	N1,[POINT 12,W,29];STORE TTY #
	PJOB	A,		;GET OUR JOB NUMBER
	DPB	A,[POINT 9,W,17];PUT IN BITS 6-17 OF HEADER
	MOVEM	W,WORD0		;STORE HEADER WORD
	DATE	W,		;GET TODAY'S DATE
	MOVEM	W,D		;SAVE DATE
	ROT	W,-^D12		;ROTATE INTO BITS 0-11
	TIMER	B,		;GET CURRENT TIME IN TICKS
	IOR	W,B		;PUT IN BITS 12-35
	MOVEM	W,WORD2		;STORE DATE AND TIME IN PERMANENT AC
	TLNN	F,LNGMOD	;SKIP IF IN DIALOG MODE
	JRST	MAKFIL	;ELSE GO MAKE UP FILE NAME
	OUTSTR	[ASCIZ /OUTPUT FILE NAME: /]
	PUSHJ	P,SIXIN	;GET USER SUPPLIED FILE NAME
	JRST	A,MAKFL2	;GO ENTER GIVEN FILE
				;USE DATE TO DETERMINE CORRECT FILENAME
MAKFIL:	MOVE	A,D		;RESTORE DATE TO A
	IDIVI	A,^D<12*31>	;CONVERT DATE
	IDIVI	B,^D31		;MONTH-1 IN B;DAY-1 IN C
	CAIN	C,^D24		;SKIP IF NOT THE 25TH
	JRST	MAKFL1		;ELSE USE FILENAME 'FACT  '
	CAIG	C,^D24		;SKIP IF PAST THE 25TH
	SOS	B		;ELSE BACK UP A MONTH
	SKIPA	A,MONTAB(B)	;PICK UP CORRECT FILENAME AND SKIP
MAKFL1:	MOVE	A,['FACT  ']	;PICK UP FILENAME
MAKFL2:	PUSHJ	P,ENTER		;GO ENTER OUTPUT FILE (NAME IN A)
	PUSHJ	P,LOOKUP	;GO LOOKUP INPUT FILE SYS:TAPE.SYS
	;FILE PROCESSING

READ:	PUSHJ	P,GETBUF	;GET A BUFFER
	  JRST	FINISH		;EOF - GO FINISH UP
NEXT:	HRRZ	T,(A)		;GET TAPE #
	JUMPE	T,FINISH	;JUMP IF PAST LAST TAPE
	SKIPGE	(A)		;SKIP IF NOT IN USE
	CAIG	T,SYSTOP	;SKIP IF ABOVE START #
	JRST	SKIPS		;ELSE SKIP THIS TAPE
	CAIL	T,RENTOP	;SKIP UNLESS PAST RENTAL BLOCK
	JRST	FINISH		;ALL DONE
	MOVE	W,WORD0		;PICK UP HEADER WORD FOR ENTRY
	PUSHJ	P,WRDOUT	;WRITE IT OUT
	MOVE	W,1(A)		;PICK UP OWNER'S PPN
	PUSHJ	P,WRDOUT	;WRITE IT OUT
	MOVE	W,WORD2		;PICK UP CURRENT DATE
	PUSHJ	P,WRDOUT	;WRITE IT OUT
	HRRZ	W,T		;PICK UP TAPE # IN RIGHT HALF
	HLL	W,2(A)		;CREATION DATE IN LH
	PUSHJ	P,WRDOUT	;WRITE IT OUT(NOTE THAT BIT 0 IS THE
				;  RELEASE FLAG AND MUST BE ZERO)
SKIPS:	ADD	A,[1,,3]	;INCREMENT INPUT BUFFER POINTER
	JUMPL	A,NEXT		;JUMP IF MORE IN BUFFER
	JRST	READ		;ELSE GO READ ANOTHER BUFFER


	;HERE ON INPUT FILE EOF
FINISH:	SETO	W,		;LOAD FACT FILE EOF WORD
	PUSHJ	P,WRDOUT	;PUT IN FILE
	CLOSE	OUT,		;CLOSE OUTPUT FILE
	CLOSE	IN,		;CLOSE INPUT FILE
	OUTSTR	[ASCIZ /
--DONE--/]
	EXIT	1,		;THEN CALL IT QUITS
	;DISK I/O SUBROUTINES

	;SUBROUTINE TO INIT AND LOOKUP INPUT FILE
	;USES AC'S A-D
LOOKUP:	INIT	IN,13		;INIT DISK FOR IMAGE BINARY INPUT
	SIXBIT	/SYS/
	XWD	0,IBUF		;INPUT ONLY
	  JRST	IOERR1		;ERROR RETURN.
	MOVE	A,['TAPE  ']	;SET TO LOOKUP
	MOVSI	B,'SYS'		;  INPUT FILE
	SETZB	C,D
	LOOKUP	IN,A		;LOOKUP INPUT
	  JRST	IOERR3		;ERROR RETURN
	POPJ	P,		;O.K. RETURN

	;ROUTINE TO INIT AND ENTER OUTPUT FILE
	;ENTER WITH FILENAME IN A - USES A-D
ENTER:	INIT	OUT,13		;INIT DISK, BINARY WORD MODE
	'SYS   '
	OBUF,,0
	  JRST	IOERR1		;?CAN'T GET DISK
	MOVSI	B,'DTA'		;FILENAME ALREADY IN A
	SETZB	C,D
	ENTER	OUT,A		;ENTER OUTPUT FILE
	  JRST	IOERR4		;?CAN'T ENTER FILE
	OUTPUT	OUT,		;SET UP BUFFER RING
	POPJ	P,		;AND RETURN
	;SUBROUTINE TO READ FROM INPUT FILE
	;USES AC'S A,B
	;NO RETURN ON ERROR
GETBUF:	IN	IN,		;READ A BLOCK
	JRST	SETBUF		;GOT IT
	STATZ	IN,740000	;IS IT EOF?
	JRST	IOERR2		;NO SUCH LUCK.
	  POPJ	P,		;GIVE NON-SKIP(EOF) RETURN
SETBUF:	MOVE	A,IBUF+1	;GET ADR OF BUFFER IN A
	AOS	A		;INCREMENT TO POINT TO FIRST WORD
	HRLI	A,-^D<128/3>	;PUT -# OF ENTRIES IN BUFFER IN LH
	AOS	(P)		;SET FOR SKIP RETURN
	POPJ	P,		;RETURN

	;SUBROUTINE TO WRITE A WORD FROM AC W TO DISK
	;USES NO AC'S; W IS PRESERVED
WRDOUT:	SOSL	OBUF+2		;SKIP IF BUFFER FULL
	JRST	WRD1		;ELSE CONTINUE BELOW
	OUT	OUT,		;WRITE OUT BUFFER
	  JRST	WRDOUT		;GO TRY AGAIN
	JRST	IOERR5		;ERROR RETURN
WRD1:	IDPB	W,OBUF+1	;STORE WORD IN OUTPUT BUFFER
	POPJ	P,		;RETURN
	;TTY I/O AND MISC. ROUTINES

	;ROUTINE TO INPUT A DECIMAL # FROM THE TTY
	;RETURNS # IN N1, USES CH,N1
DECIN:	SETZ	N1,		;STANDARD TTY INPUT ROUTINE
	INCHWL	CH
	CAIN	CH,15
	JRST	DECIN1
	IMULI	N1,12
	ADDI	N1,-"0"(CH)
	JRST	DECIN+1
DECIN1:	INCHRW	CH		;PICK UP LEFT OVER <LF>
	POPJ	P,		; AND RETURN

	;SUBROUTINE TO READ SIXBIT FILENAME FROM TTY TO A
	;USES CH,N1,B - RETURNS VALUE IN A
SIXIN:	MOVEI	N1,6		;MAX OF 6 CHARS
	MOVE	B,[POINT 6,A]	;POINTER TO RESULT
	SETZ	A,		;ZERO OUT RESULT
SIX1:	INCHWL	CH		;GET CHAR
	CAIN	CH,C.CR		;SKIP UNLESS CARRIAGE RETURN
	JRST	SIX2		;IN WHICH CASE GO FINISH UP
	SUBI	CH," "		;CONVERT TO SIXBIT
	IDPB	CH,B		;STORE CHAR IN A
	SOJGE	N1,SIX1		;LOOP UNLESS TOO MANY CHARS
SIXERR:	OUTSTR	[ASCIZ /?BAD FILENAME - TRY AGAIN: /]
	CLRBFI			;DELETE GARBAGE TYPED AHEAD
	JRST	SIXIN		;GO TRY AGAIN
SIX2:	INCHWL	CH		;PICK UP EXTRA <LF>
	JUMPE	A,SIXERR	;DON'T ALLOW NULL FILENAME
	POPJ	P,		;RETURN
	;ROUTINE TO PRINT A DECIMAL NUMBER IN AC N1
	;USES N1,N2,CH
DECPRT:	IDIVI	N1,^D10		;STANDARD DECIMAL PRINT ROUTINE
	HRLM	N2,(P)
	SKIPE	N1
	PUSHJ	P,DECPRT
	HLRZ	CH,(P)
	ADDI	CH,"0"
	OUTCHR	CH
	POPJ	P,
	;SUBROUTINE TO RETURN BINARY TTY # IN N1
	;USES ONLY AC N1
TTYNUM:	GETLIN	N1,		;GET SIXBIT TTY NAME
	JUMPE	N1,TTYN1	;JUMP IF DETACHED
	SETO	N1,		;SET FOR GETLCH ON THIS TTY LINE
	GETLCH	N1		;RETURNS FLAGS IN LH, TTY # IN RH
	TLNE	N1,L.CTY	;IS THIS THE CTY?
	HRRI	N1,-1		;YES-MAKE IT -1
	POPJ	P,		;RETURN WITH TTY # IN RH
TTYN1:	HRRI	N1,-2		;DETACHED BECOMES -1
	POPJ	P,		;RETURN
	;ERROR ROUTINES
IOERR1:	OUTSTR	[ASCIZ /?DEVICE DSK NOT AVAILABLE/]
	EXIT
IOERR2:	OUTSTR	[ASCIZ /?ERROR READING TAPE.SYS/]
	EXIT
IOERR3:	OUTSTR	[ASCIZ /?INPUT FILE SYS:TAPE.SYS NOT FOUND/]
	EXIT			;AND QUIT

IOERR4:	OUTSTR	[ASCIZ /?ENTER FAILED FOR OUTPUT FILE/]
	EXIT			;QUIT

IOERR5:	OUTSTR	[ASCIZ /?ERROR WRITING OUTPUT FILE/]
	EXIT
	;STORAGE AREAS AND CONSTANTS

MONTAB:	'JAN025'		;OUTPUT FILENAMES
	'FEB025'
	'MAR025'
	'APR025'
	'MAY025'
	'JUN025'
	'JUL025'
	'AUG025'
	'SEP025'
	'OCT025'
	'NOV025'
	'DEC025'
IBUF:	BLOCK	3		;BUFFER HEADER FOR INPUT FILE
OBUF:	BLOCK	3		;BUFFER HEADER FOR DISK OUTPUT FILE

PDL:	BLOCK	20		;PUSH DOWN LIST

	END	TAPACT