; Dates operations
;
; (C)1989 By MEDA COMP, INC.
;
;-All commercial rights reserved, etc.
;-No warranties and/or guarranties of any kind, etc.
;-Not responsible for damages resulting from the use of this program, etc.
;
; I can be reached at:
;		Meda Comp Computer Systems
;		18587 Sigma Rd. #220
;		San Antonio Tx 78258
;		(210) 490-9008
;		8am-5pm
;
;

	VEDIT=3

	SYM
	OBJNAM	.SBR

	SEARCH	SYS
	SEARCH	SYSSYM
	SEARCH	MACLIB
	SEARCH	DATES.UNV

	RADIX	10

	DEFAULT	VEDIT,2
	DEFAULT	$$MFLG,PV$RSM
	DEFAULT	$$SFLG,PH$REE!PH$REU

	PHDR	-1,$$MFLG,$$SFLG

	EXTERN	$IDTIM,$DSTOI,$ODTIM,$FLSET
;
;
	.OFINI
	.OFDEF	ASCIIB,12	;ascii work area
	.OFSIZ	IMPSIZ

	XCMEM	IMPSIZ		; Check for enough memory

	CLEAR	@A4,IMPSIZ

	CNTURY	= 2415021		; CONVERT  IDATE<-->CDATE

; SOME BASIC XCALL INTERFACING MACROS
;
; Move the type field from the Nth parameter block off the
; BASIC XCALL parameters list into DEST
;
	DEFINE	BTYPE REG,DEST
1$$	=	2+^D10*<REG-1>
	CLR	DEST
	MOVW	1$$(A3),DEST
	ANDW	#^H000F,1$$(A3)		;mask off all but last 4 bits
	ENDM
;
; Move the address field from the Nth parameter block off the
; BASIC XCALL parameters list into DEST
;
	DEFINE	BADRS REG,DEST
1$$	=	4+^D10*<REG-1>
	MOVL	1$$(A3),DEST
	ENDM
;
;
; Move the size field from the Nth parameter block off the
; BASIC XCALL parameters list into DEST
;
	DEFINE	BSIZE REG,DEST
1$$	=	8+^D10*<REG-1>
	MOVL	1$$(A3),DEST
	ENDM
;
DATES:
	MOV	SP,A5	; Save the stack pointer
	CALL	GETFUN	; Get function in to D0
	CMP	D0,#1
	JEQ	CONVRT	; Convert DATE1 to DATE2
	CMP	D0,#2
	JEQ	COMPDT	; COMPUTE DATE2 = DATE1+ DAYS
	CMP	D0,#3
	JEQ	DIFFDT	; COMPUTE DAYS  = DATE1- DATE2
	CMP	D0,#4
	JEQ	COMPYW	; COMPUTE DATE = YEAR,YWEEK,DOW
	CMP	D0,#5
	JEQ	COMPMW	; COMPUTE DATE = YEAR,MONTH,MWEEK,DOW
	CMP	D0,#6
	JEQ	COMPEM	; COMPUTE DATE = END OF MONTH
	CMP	D0,#7
	JEQ	IODTIM	; $ODTIM INTERFACE
	CMP	D0,#8.
	JEQ	IIDTIM	; $IDTIM INTERFACE
	JMP	FUNERR

EXIT:	;return to caller
	BADRS	2,A2
	MOVW	D5,@A2		;set return flag
	MOV	A5,SP		;restore stack pointer
	RTN			;return to caller

CONVRT:	; Convert from any format to any format
	CMPW	@A3,#4		;4 args?
	JNE	ARGERR		; no	
	CALL	GETID1		; convert DATE1 to internal format D2
	CALL	PUTIDT		; convert INTERNAL D2 to DATE2
	BR	EXIT		; return to caller

COMPDT:	; Function 2. DATE2 = DATE1+DAYS
	CMPW	@A3,#5		;5 vars passed?
	JNE	ARGERR		; no
	CALL	GETID1		;DATE1 to internal in D2
	MOV	#5,D0
	CALL	SETXC
	CALL	XVALUE		;days to add in D1
	ADD	D1,D2		; D2=D2+D1
	CALL	PUTIDT
	BR	EXIT

DIFFDT: ; Function 3. DAYS = DATE2-DATE1
	CMPW	@A3,#5		;5 args?
	JNE	ARGERR		; no
	CALL	GETID1		;date1 to internal D2
	MOV	D2,D3		;save date1
	CALL	GETID2		;date2 to internal D2
	SUB	D3,D2		;get diff
	MOV	#5,D0		;xc.var #
	CALL	SETXC		;get param
	CMPW	D6,#X.Flt	;arg float?
	JNE	TYPERR		; no
	FLTOF	D2,@A2		;Put floating point arg
	BR	EXIT

COMPYW: ; Compute Date from YEAR,YWEEK,DOW
	CMPW	@A3,#4		;4 vars sent?
	JNE	ARGERR		; no
	MOV	#3,D5
	BTYPE	3,D0
	TST	D0		;is DATE1 unformated?
	JNE	EXIT		; no
	BSIZE	3,D0
	CMP	D0,#5		;is DATE1 at least 5 bytes?
	JLT	EXIT		; no
	BADRS	3,A2
	MOV	#257.,D7	;mask D7 to 0101 MMDD
	MOVB	2(A2),D7	;move in year
	CALL	$DSTOI		;D7 = Julian for 01/01/19 cur year
	MOV	D7,D2		; move it to D2
	CALL	DOW		;D1 has DOW of 01/01/19 cur year
	SUB	D1,D2		; sub DOW for 01/01/19 cur year
	CLR	D7		; D7=0
	MOVB	4(A2),D7	; D7=YWEEK
	DECW	D7		; D7=YWEEK-1
	MUL	D7,#7		; D7=(YWEEK-1)*7
	ADD	D7,D2		; D2=START'I'JUL+(YWEEK-1)*7
	ADDB	3(A2),D2
	CALL	PUTIDT
	CLR	D5
	JMP	EXIT

COMPMW:	; Compute Date from YEAR,MONTH,MWEEK,DOW
	CMPW	@A3,#4
	JNE	ARGERR	
	BTYPE	3,D0
	TST	D0
	JNE	EXIT
	BSIZE	3,D0
	CMP	D0,#6
	JLT	EXIT
	BADRS	3,A2
	MOV	#256.,D7	;day 1 to D7
	MOVB	@A2,D7		;month to D7
	SWAP	D7		;shift them to high order bytes
	MOVB	2(A2),D7	;year to D7 (D7 now in alpha sep format )
	CALL	$DSTOI		;D7 has julian day 1 of month, year
	MOV	D7,D2		; move it to D2
	CALL	DOW		;D1 has DOW of 01/month/year
	SUB	D1,D2		; sub DOW
	CLR	D7		; D7=0
	MOVB	5(A2),D7	; D7=MWEEK
	DECW	D7		; D7=MWEEK-1
	MUL	D7,#7		; D7=(MWEEK-1)*7
	ADD	D7,D2		; D2=START'I'JUL+(MWEEK-1)*7
	ADDB	3(A2),D2
	CALL	PUTIDT
	JMP	EXIT

COMPEM:	;DATE2 = DATE1 changed to last day of the month
	CMPW	@A3,#4
	JNE	ARGERR	
	CALL	GETID1		;convert DATE1 to internal format (D2)
	MOV	D2,D7
	CALL	DITOS		;convert to separate format and get last day
	ROL	D7,#8
	MOVB	D6,D7
	ROR	D7,#8
	CALL	$DSTOI		
	MOV	D7,D2
	CALL	PUTIDT		;convert seperated to DATE2
	JMP	EXIT

IODTIM:
;	XCALL DATES, 7, FLAGS, [STR'DATE or FILE CHAN], IDATE, ITIME
;	(interface) $ODTIM:  Output Date and Time (Time last)
;	Entry: D3=Date, D4=time (0=use sys)(separated), D5=format flags,A2->out
;	Return: A2->nxt char (if used)
;
	CMPW	@A3,#5		;5 args?
	JNE	ARGERR		; no	

	MOV	#4,D0		;xc var# ( IDATE )
	CALL	SETXC
	CALL	XVALUE
	MOV	D1,D3		;IDATE to D3

	MOV	#5,D0		;xc var# ( IDATE )
	CALL	SETXC
	CALL	XVALUE
	MOV	D1,D4		;IDATE to D4

	CALL	FLGIN		;get flags D5

	MOV	#3,D0
	CALL	SETXC
	CMPW	X.Typ(A3)[D0],#X.Str	;is return var a string?
	JNE	TYPERR
	CMP	X.Siz(A3)[D0],#46
	JLO	SIZERR		; no

BR	20$	;TEMP SKIP OF FILESET

	BTST	#15.,D3		;OUTPUT TO FILE?
	BEQ	20$		;NO
	BTYPE	5,D0
	BSIZE	5,D5
;	CALL	GETNUM		;GET FILE CHANNEL NUMBER
	MOV	D3,D5
	CALL	$FLSET		;FIND FILE'S DDB
	BEQ	20$		;EVERYTHING'S OK, PROCEED
	MOV	#6,D5		;ERROR #6 BAD CHANNEL NUMBER
	JMP	EXIT		;ABORT WITH ERROR

20$:	CALL	$ODTIM
	CLR	D5		;$ODTIM has no error conditions
	JMP	EXIT		;return to caller
;
;various calls
;
FLGIN:	MOV	#2,D0			;xcall var# ( FLAGS )
	CALL	SETXC
	CALL	XVALUE
	MOV	D1,D5
	RTN			;back to call

BIN4OU:	CMPW	D6,#X.Bin	;binary?
	JNE	TYPERR		; no
	CMP	D7,#4		;4 bytes long?
	JNE	SIZERR		; no
	MOV	D1,@A2		;mov it to @A2
	RTN

SETXC:	CLR	D6
	DEC	D0
	MUL	D0,#X.Off
	MOVW	X.Typ(A3)[D0],D6
	ANDW	#^H000F,D6	;mask off all but last 4 bits
	MOV	X.Siz(A3)[D0],D7
	MOV	X.Adr(A3)[D0],A2
	RTN

ADJDAY:
	ROR	D1,#8
	ADDB	#2,D1		;MON=2 SUNDAY = 8
	CMPB	D1,#8
	BLO	1$
	MOVB	#1,D1
1$:	ROL	D1,#8		;SUN=1 SAT = 7
	RTN
;
;
IIDTIM:
; XCALL DATES, 8, FLAGS, ADATE, output IDATE, output ITIME
; (interface) $IDTIM:  Input Date and/or Time (if both, time must be first)
; Entry: A2->Input string, D5(bit 0)=1:no date,(bit 1)=1:no time
; Return: D3=date (separated), D4=time (separated), A2->nxt chr
; N set:error
;
	CMPW	@A3,#5		;5 arguments?
	JNE	ARGERR		; no
	CALL	FLGIN		;FLAGS to D5
	BADRS	3,A2		;index input
	CALL	$IDTIM		;call subroutine
	BNE	1$		;branch on error
	MOV	#4,D0		;var #
	CALL	SETXC		;get param
	MOV	D3,D1
	CALL	ADJDAY		;0=MON 6=SUN to 1=MON 7=SAT
	CALL	BIN4OU		;IDATE out
	MOV	#5,D0		;var #
	CALL	SETXC		;get param
	MOV	D4,D1
	CALL	BIN4OU		;ITIME out
	CLR	D5		;clr return flags
	JMP	EXIT		;RETURN TO CALLER
1$:	MOV	#2,D5
	JMP	EXIT

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;						;
;  gets	DATE1 and DATE2 in internal format	;
;_______________________________________________;
;						;	
GETID1:	;get first date in internal format	;
	SAVE	A2,D0,D3,D4,D7			;
	MOV	#3,D0				;
	BR	GETIDT				;
GETID2:	;get second date in internal format	;
	SAVE	A2,D0,D3,D4,D7			;
	MOV	#4,D0				;
GETIDT:	;convert a date to internal format	;
	CALL	GETDAT				;
	REST	A2,D0,D3,D4,D7			;	
	RTN					;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;						;
;  put inernal format date into DATE2     	;
;_______________________________________________;
;						;	
PUTIDT:
	SAVE	A2,D5,D4
	MOV	#4,D0		;xc.var# ( DATE2 )
	CALL	SETXC
PUTDAT:	TJMP	D6
	OFFSET	PUTBX		;seperated format date
	OFFSET	PUTASC		;string mm/dd/yy or mm/dd/yyyy
	OFFSET	PUTFLT		;julian
	OFFSET	PUTBIN		;4 byte yyyymmdd format
	;assume unform or binary
PUTBX:
	CMPW	D7,#3		;at least 3 bytes?
	JLO	SIZERR		; no
;Unformated (X) or binary, 1st 3 bytes are always: MONTH,DAY,YEAR
	MOV	D7,D0		;save size of var
	MOV	D2,D7		;
	CALL	DITOS		
	CMPW	D0,#7		;do we want days in month?
	BLO	1$		; no
	PUSHB	D6		;save days in month
1$:	MOV	D7,D3
	MOVB	D7,2(A2)	; SET YEAR
	SWAP	D7
	MOVB	D7,@A2		; SET MONTH
	RORW	D7,#8
	MOVB	D7,1(A2)	; SET DAY
	CMPW	D0,#4		;need more than MONTH,DAY,YEAR?
	JLO	PUTEXT		; no
	MOV	D2,D7
	CALL	DOW		;DOW to D1
	MOVB	D1,3(A2)	;move in DOW
	CMPW	D0,#5		;do we want the week of the year
	JLO	PUTEXT		;no
;YWEEK=INT((NOW-START+START'DOW)/7)+1
	MOV	#257.,D7	;day 1 mon 1 to D7
	SWAP	D7		; shift to high order	
	MOVB	D3,D7		;year to low order
	CALL	$DSTOI		; D7=START julian days for jan 1 present year
	MOV	D2,D5		; D5=NOW   julian days for present date
	SUB	D7,D5		; 
	CALL	DOW 		;get DOW into D1
	ADDW	D1,D5		;add in the day of the week
	DEC	D5		;adjust
	DIV	D5,#7
	INCB	D5
	MOVB	D5,4(A2)	;
	CMP	D0,#6
	BLO	PUTEXT
;MWEEK=INT((NOW-START+START'DOW)/7)+1
	MOV	D3,D7
	AND	#16777215.,D7
	OR	#16777216.,D7	; SET DAY=01
	CALL	$DSTOI		; D7=START cur month
	CALL	DOW		; D1 has day of the week cur month
	ADDB	1(A2),D1	; add in the day of the month
	SUB	#2,D1
	DIV	D1,#7
	INCB	D1
	MOVB	D1,5(A2)
	CMP	D0,#7
	BLO	PUTEXT
MDAYS:
	POPB	D6
	MOVB	D6,6(A2)

PUTEXT:
	REST	A2,D5,D4
	RTN
PUTASC:
;INTERNAL date in D2 to ASCII date in DATE2
	CMP	D7,#8		;is string at least 8 bytes
	JLO	SIZERR		; no
	MOV	D2,D7		;internal to reg
	CALL	DITOS		;D7 has date seperated
	MOV	D7,D3		;IDATE for $ODTIM
	MOV	#840.,D5	;flags for $ODTIM
	CALL	$ODTIM		;
	JMP	PUTEXT

PUTFLT:
;INTERNAL to FLOAT is just Long Word to Float
	FLTOF	D2,@A2
	JMP	PUTEXT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
PUTBIN: ;special format bin4 yyyymmdd
	CMPW	D7,#4		;4 bytes?
	JNE	SIZERR		; no
	MOV	#4,D0		;set counter
	MOV	D2,D7		;internal to reg
	CALL	DITOS		;D7 has date seperated
	CLR	D0		;clear work reg
	CLR	D1		;clear accumulator
	MOVB	D7,D0		;year to D0
	ADDW	#1900,D0	;assume 20th century
	MUL	D0,#10000	;adjust 4 left
	MOV	D0,D1		;move to accumulator
	SWAP	D7		;month to first byte
	CLR	D0		;clear work reg
	MOVB	D7,D0		;month to D0
	MUL	D0,#100		;adjust 2 left
	ADDW	D0,D1		;month to accumlator
	RORW	D7,#8		;day to first byte
	CLR	D0
	MOVB	D7,D0
	ADD	D0,D1		;add day
	MOV	#4,D0		;set counter
1$:	MOVB	D1,(A2)+	;move a byte
	ROR	D1,#8		;shift right a byte
	SOB	D0,1$		;do it again
	BR	PUTEXT		;return to caller


GETFUN:
; Get function number D0
	CLR	D0
	CALL	XVALUE
	MOV	D1,D0
	RTN

XVALUE:	XCVALU	D0
	JNE	TYPERR
	RTN
;
DITOS:
; CONVERT INTERNAL DATE (D7) TO SEPERATED DATE (D7),
; SET D6 TO NUMBER OF DAYS IN MONTH
; D2=MONTH
; D3=DAY
; D4=YEAR
;
	SAVE	D2,D3,D4,A2,A3
	SUB	#CNTURY,D7
	DIV	D7,#1461.
	CLR	D3
	MOVW	D7,D3
	ADDW	D3,D3
	ADDW	D3,D3
	CLRW	D7
	SWAP	D7
	DIV	D7,#365.
	ADDW	D7,D3
	CLR	D4
	MOVW	D3,D4
	TSTW	D7		;Leap year?
	BEQ	1$		; Yes
	LEA	A2,NORMYR	;Index normal year and day tables
	LEA	A3,NORMDS	;^^^^^
	SWAP	D7
	BR	2$
1$:	LEA	A2,LEAPYR
	LEA	A3,LEAPDS
	SWAP	D7
	INCW	D7
2$:	MOVW	#-1,D3
3$:	INCW	D3
	CMPW	D7,(A2)+
	BCC	3$
	CLR	D2
	MOVW	D3,D2
	SUB	#4,A2
	SUBW	@A2,D7
	CLR	D3
	MOVW	D7,D3
	INC	D3
				;    DY MN DW YR
	CLR	D7		; D7=00 00 00 00
	MOVB	D3,D7		; D7=00 00 00 D3
	RORW	D7,#8		; D7=00 00 D3 00
	MOVB	D2,D7		; D7=00 00 D3 D2
	SWAP	D7		; D7=D3 D2 00 00
	MOVB	D4,D7		; D7=D3 D2 00 D4
	MOVB	-1(A3)[D2],D6	; Days in month to D6
5$:	REST	D2,D3,D4,A2,A3
	RTN

NORMYR:	WORD	0,31,59,90,120,151,181,212,243,273,304,334,365
LEAPYR:	WORD	0,31,60,91,121,152,182,213,244,274,305,335,366
NORMDS:	BYTE	31,28,31,30,31,30,31,31,30,31,30,31
LEAPDS:	BYTE	31,29,31,30,31,30,31,31,30,31,30,31
;
GETDAT:
	CALL	SETXC
	TJMP	D6
	OFFSET	GTDBX		;seperated format date
	OFFSET	GTDASC		;string mm/dd/yy or mm/dd/yyyy
	OFFSET	GTDFLT		;julian
	OFFSET	GTDBIN		;4 byte yyyymmdd format
GTDBX:
; Unformatted 1st 3 bytes are always MONTH,DAY,YEAR
; Basic stores em backwards
	CLR	D7		;clear storage
	MOVB	1(A2),D7	;day to D7
	RORW	D7,#8		;shift right 8 bytes
	MOVB	@A2,D7		;month to D7
	SWAP	D7		;mov to high order bytes of Lwrd
	MOVB	2(A2),D7	;year to D7
	TST	D7		;was date 0?
	BNE	GTDEXT		; no
GDATEI:	GDATEI	D2		;today in internal format
	RTN			; use todays date
	;D7 now in ALPHA seperated format but DOW is invalid.
	;Don't need it.
GTDEXT:	CALL	$DSTOI		;call for ALPHA internal format. ( Julian )
	MOV	D7,D2		;D2 has date in ALPHA internal format
	RTN

GTDASC:
;ASCII to ALPHA INTERNAL
	CMP	D7,#8		;string at least 8 bytes?
	JLO	SIZERR		; no
	MOVB	8(A2),D1	;save byte after string
	CLRB	8(A2)		;make sure null byte for termination
	MOV	#2,D5		;don't scan for time
	PUSH	A2
	CALL	$IDTIM
	SETNE	D2	
	POP	A2
	MOVB	D1,8(A2)
	MOVW	#1,D5
	TSTB	D2
	JNE	EXIT		;error
	CLRW	D5		;clear error
	MOV	D3,D7
	BR	GTDEXT
	;end of ASCII to ALPHA INTERNAL

GTDFLT:	FFTOL	@A2,D2
	TST	D2		;date 0?
	BEQ	GDATEI		; yes - use today
	RTN

GTDBIN:	;special format bin4 yyyymmdd
	;we know type is binary
	CMP	X.Siz(A3)[D0],#4
	JNE	SIZERR		; no
	CALL	XVALUE
	PUSH
	CLR	@SP
	PUSH
	CLR	@SP
	PUSH			;get storage
	CLR	@SP
	MOV	SP,A2		;index storage with A2
	DCVT	0,OT$MEM	;ASCII rep of bin4 date to ASCIIB
	SUB	#2,A2		;index day
	GTDEC			;day to D1
	CLR	D0
	MOVB	D1,D0		;day to D7
	ROLW	D0,#8		;shift day left
	SUB	#4,A2		;index month
	CLRB	2(A2)
	GTDEC			;month to D1
	MOVB	D1,D0		;month to D7
	SWAP	D0		;shift to high word
	SUB	#6,A2		;index year
	CLRB	4(A2)	
	GTDEC			;year to D1 yyyy
	SUBW	#1900,D1	;assume this century
	MOVB	D1,D0		;date is now in alpha seperated format
	MOV	D0,D7
	POP
	POP
	POP			;restore stack pointer
	JMP	GTDEXT		;
;
DOW:	;Convert true julian in D7 to day of the week ( 1=sun  7=sat )
	;assuming 20th century and return it in D1
	MOV	D7,D1
	SUB	#CNTURY,D1
	ADD	#2,D1		;adjust so DOW will divide
	DIV	D1,#7		;DOW is in high order of D1
	CLRW	D1		;clear all but DOW
	SWAP	D1		;DOW is low order of D1
				;DOW ( 0 - 6 ) ( sat - sun )
	TSTB	D1		;is sat
	BNE	1$		; no
	MOVB	#7,D1		; DOW is 1 - 7 ( sun - sat )
1$:	RTN

;
; Abort routine for improper arguments passed to SBR
;
	DEFINE	ERROR	TEXT
		TYPE	<? 'TEXT'>
		JMP	ABORT
		ENDM

ADRERR:	ERROR	Odd address given as WORD or LONG
ARGERR:	ERROR	improper number of arguments
TYPERR:	ERROR	argument type error
SIZERR:	ERROR	argument size error
FUNERR: ERROR	function out of range (1..8)
CHNERR: ERROR	error locating file channel

ABORT:	TYPECR	< in DATES.SBR>
	MOV	JOBCUR,A6
	ORW	#J.CCC,JOBSTS(A6)
	EXIT

	END