source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMDATE.m

PXRMDATE ; SLC/PKR - Clinical Reminders date utilities. ;06/20/2006
 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
 ;
 ;==================================================
CEFD(FDA) ;Called by the Exchange Utility only if the input packed
 ;reminder was packed under v1.5  Move Effective Date to Beginning Date.
 N IND
 S IND=""
 F  S IND=$O(FDA(811.902,IND)) Q:IND=""  D
 . I '$D(FDA(811.902,IND,12)) Q
 .;If the EFFECTIVE PERIOD exists don't do anything.
 . I $D(FDA(811.902,IND,9)) Q
 . S FDA(811.902,IND,9)=FDA(811.902,IND,12)
 . K FDA(811.902,IND,12)
 Q
 ;
 ;==================================================
COMPARE(X) ;Compare beginning and ending dates, give a warning if
 ;Ending Date comes before Beginning Date. Called by ADATE xref in
 ;definitions and terms.
 ;Do not execute as part of exchange.
 I $G(PXRMEXCH) Q
 N BDT,EDT
 S BDT=$S(X(1)'="":$$CTFMD^PXRMDATE(X(1)),1:0)
 S EDT=X(2)
 I EDT="" S EDT="T"
 S EDT=$$CTFMD^PXRMDATE(EDT)
 ;If EDT does not contain a time set it to the end of the day.
 I EDT'["." S EDT=EDT_".235959"
 I EDT<BDT D
 . S BDT=$S(X(1)'="":X(1),1:"")
 . S EDT=$S(X(2)'="":X(2),1:"T@2400")
 . S TEXT="Warning the ending date ("_EDT_") is before the beginning date ("_BDT_")"
 . D EN^DDIOL(TEXT)
 Q
 ;
 ;==================================================
COTN(EFP) ;Convert an Effective Period to the new date/time format.
 ;Possible effective periods are ND, NM, or NY where N is an integer.
 S EFP=$$UP^XLFSTR(EFP)
 I (EFP?1N.N1"D")!(EFP?1N.N1"M")!(EFP?1N.N1"Y") D
 . S NUM=+EFP
 . S EFP=$S(NUM=0:"T",1:"T-"_EFP)
 Q EFP
 ;
 ;==================================================
CTFMD(DATE) ;Convert DATE which may be in any of the FileMan acceptable
 ;forms as well as T-NY to a FileMan date. Also understands LAD for
 ;Last Admission Date.
 N %DT,X,Y
 ;Check for a date FileMan understands.
 S X=DATE,%DT="ST"
 D ^%DT
 ;If it is not a FileMan date check for a symbolic date.
 I Y=-1 S Y=$$SYMDATE(DATE)
 ;If it is not a date that is understood by SYMDATE return -1
 I Y=-1 Q -1
 I $G(PXRMDATE)'="",$$ISVSYMD(DATE) D
 . N DIFFS
 . S DIFFS=-$$FMDIFF^XLFDT(DT,PXRMDATE,2)
 . S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS)
 I DATE["LAD" D
 . I $G(PXRMLAD)="" S Y=0
 . E  D
 .. N DIFFS
 .. S DIFFS=-$$FMDIFF^XLFDT(DT,$G(PXRMLAD),2)
 .. S Y=$$FMADD^XLFDT(Y,0,0,0,DIFFS)
 Q Y
 ;
 ;=================================================
DCHECK(DATE) ;Trap for special characters before calling CTFMD^PXRMDATE.
 ;Used in DIR("PRE") for date inputs.
 I $D(DTOUT) Q DATE
 I DATE="" Q DATE
 I DATE["^" Q DATE
 I DATE["?" Q DATE
 Q $$CTFMD^PXRMDATE(DATE)
 ;
 ;==================================================
DUE(DEFARR,RESDATE,FREQ,DUE,DUEDATE,FIEVAL) ;Compute the due date.
 ;This is the date of the resolution finding + the reminder frequency.
 ;Subtract the due in advance time to see if the reminder should be
 ;marked as due soon.
 ;
 N DATE,DIAT,DIATOK,LDATE,PXRMITEM,TDDUE,TODAY
 S PXRMITEM=DEFARR("IEN")
 ;If the final frequency is 0Y then the reminder is not due.
 I FREQ="0Y" S DUE=0,DUEDATE="" Q
 ;
 S DUEDATE=""
 ;Check for custom date due.
 I DEFARR(45)'="" S DUEDATE=$$CDUEDATE^PXRMCDUE(.DEFARR,.FIEVAL)
 I DUEDATE'="",DUEDATE'=-1 G SETDUE
 ;
 ;No custom date due, do regular date calculation.
 I (FREQ="")!(FREQ=-1) D  Q
 . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","NOFREQ")="No reminder frequency - cannot compute due date!"
 . S (DUE,DUEDATE)="CNBD"
 ;
 S LDATE=$S(RESDATE["X":0,1:+RESDATE)
 I LDATE=0 S (DUE,DUEDATE)="DUE NOW" Q
 S DATE=$$FULLDATE(LDATE),DUEDATE=$$NEWDATE(DATE,FREQ)
 ;
SETDUE ;If the due date is less than or equal to today's date the reminder
 ;is due.
 S TODAY=$$NOW^PXRMDATE
 I +DUEDATE'>TODAY S DUE="DUE NOW"  Q
 ;
 S DIAT="-"_$P(DEFARR(0),U,4)
 I DIAT="-" D
 . S DIATOK=0
 . S ^TMP(PXRMPID,$J,PXRMITEM,"WARNING","DIAT")="Warning no do in advance time"
 E  S DIATOK=1
 ;
 S TDDUE=$S(DIATOK=1:$$NEWDATE(DUEDATE,DIAT),1:DUEDATE)
 S DUE=$S(TDDUE'>TODAY:"DUE SOON",1:"RESOLVED")
 Q
 ;
 ;==================================================
DURATION(START,STOP) ;Return the number days between the Start Date and
 ;Stop Date.
 I +START=0 Q 0
 N PXRMNOW
 S PXRMNOW=$$NOW^PXRMDATE
 I START>PXRMNOW Q 0
 I (STOP="")!(STOP>PXRMNOW) S STOP=PXRMNOW
 Q $$FMDIFF^XLFDT(STOP,START)
 ;
 ;==================================================
EDATE(DATE) ;Check for an historical (event) date, format as appropriate.
 Q $$FMTE^XLFDT(DATE,"5DZ")
 ;
 ;==================================================
FULLDATE(DATE) ;See if DATE is a full date, i.e., it has a month and
 ;a day along with a year. If the month is missing assume Jan. If the
 ;day is missing assume the first. Issue a warning so the user knows
 ;what happened. DATE should be in Fileman format.
 N DAY,MISSING,MONTH,TDATE,YEAR
 S TDATE=DATE
 S MISSING=0
 S DAY=$E(DATE,6,7)
 S MONTH=$E(DATE,4,5)
 S YEAR=$E(DATE,1,3)
 I +DAY=0 D
 . S DAY=1
 . S MISSING=1
 . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO DAY")="Encounter date missing the day, using the first for the date due calculation."
 I +MONTH=0 D
 . S MONTH=1
 . S MISSING=1
 . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NO MONTH")="Encounter date missing the month, using January for the date due calculation."
 I MISSING D
 . S TDATE=(YEAR*1E4)+(MONTH*1E2)+DAY
 . I DATE["E" S TDATE=TDATE_"E"
 Q TDATE
 ;
 ;==================================================
FRQINDAY(FREQ) ;Given a frequency in the form ND, NM, or NY where N is a
 ;number and D stands for days, M for months, and Y for years return
 ;the value in days.
 I FREQ="" Q ""
 N CODE,LEN,MULT,NUM
 S LEN=$L(FREQ)
 S NUM=$E(FREQ,1,LEN-1)
 S CODE=$E(FREQ,LEN,LEN)
 S MULT=1.0
 I CODE="M" S MULT=30.42
 I CODE="Y" S MULT=365.25
 Q +(MULT*NUM)
 ;
 ;==================================================
ISVSYMD(DATE) ;Return true if DATE is a valid symbolic date.
 N P1,P1OK,P2,P2OK,OP,PAT
 S DATE=$P(DATE,"@",1)
 S OP=$S(DATE["+":"+",1:"-")
 S P1=$P(DATE,OP,1),P1OK=0
 F PAT="T","TODAY","N","NOW" I P1=PAT S P1OK=1 Q:P1OK
 I PAT=DATE Q 1
 S P2=$P(DATE,OP,2),P2OK=0
 F PAT="1N.N","1N.N1""D""","1N.N1""M""","1N.N1""Y""" I P2?@PAT S P2OK=1 Q:P2OK
 Q P1OK&P2OK
 ;
 ;==================================================
NEWDATE(FMDATE,OFFSET) ;Given a date in VA Fileman format (FMDATE) and an
 ;offset of the form NY, NM, ND where N is a number and Y stands for
 ;years, M for months, and D for days return the new date in VA Fileman
 ;format. 
 I FMDATE=0 Q 0
 N LEN,NEWDATE,NUM,UNIT
 S LEN=$L(OFFSET)
 S NUM=+$E(OFFSET,1,LEN-1)
 S UNIT=$E(OFFSET,LEN)
 I UNIT="D" G DAY
 I UNIT="M" G MONTH
 I UNIT="Y" G YEAR
 ;Unknown unit just return the original date
 Q FMDATE
DAY ;
 S NEWDATE=+$$FMADD^XLFDT(FMDATE,NUM)
 Q NEWDATE
MONTH ;
 ;Convert the months to days and then add the days using the DAY code.
 ;Multiply the number of months by the average number of days in a month.
 N INT,FRAC
 S NUM=30.42*NUM
 ;Round the number of days, FMADD^XLFDT has problems with non-integer
 ;days.
 S INT=+$P(NUM,".",1)
 S FRAC=NUM-INT
 I FRAC<0.5 S NUM=INT
 E  S NUM=INT+1
 G DAY
 Q
YEAR ;
 Q FMDATE+(10000*NUM)
 ;
 ;==================================================
NOW() ;If the reminder global PXRMDATE is defined return it, otherwise
 ;return the current date and time.
 Q $S(+$G(PXRMDATE)>0:PXRMDATE,1:$$NOW^XLFDT)
 ;
 ;==================================================
SYMDATE(DATE) ;Convert a symbolic date into a FileMan date.
 N %DT,OPER,PFSTACK,SYM,TIME,X,Y
 S TIME=$P(DATE,"@",2),DATE=$P(DATE,"@",1)
 S X=$S(DATE="LAD":$G(PXRMLAD),1:"")
 I X="" D
 . S OPER="+-"
 . D POSTFIX^PXRMSTAC(DATE,OPER,.PFSTACK)
 I PFSTACK(0)=3 D
 . S SYM=PFSTACK(1)
 . S SYM=$S(SYM="LAD":"T",SYM="N":"N",SYM="NOW":"N",SYM="T":"T",SYM="TODAY":"T",1:"")
 . I SYM="" S Y=-1 Q
 .;FileMan only handles D, W, or M so convert Y to months.
 . I PFSTACK(2)["Y" S PFSTACK(2)=+PFSTACK(2)*12_"M"
 . S X=SYM_PFSTACK(3)_PFSTACK(2)
 I PFSTACK(0)=1 S X=PFSTACK(1)
 I TIME'="" S X=X_"@"_TIME
 S %DT="ST"
 D ^%DT
 Q Y
 ;
 ;==================================================
VDATE(VIEN) ;Given a visit ien return the visit date.
 N DATE
 I +VIEN>0 S DATE=$P($G(^AUPNVSIT(VIEN,0)),U,1)
 E  S DATE=0
 I $L(DATE)=0 S DATE=0
 ;Check for historical encounter.
 I $$ISHIST^PXRMVSIT(VIEN) S DATE=DATE_"E"
 Q DATE
 ;