PXRMDATE ;SLC/PKR - Clinical Reminders date utilities. ;06/28/2022
;;2.0;CLINICAL REMINDERS;**4,6,12,17,18,24,26,47,42,65**;Feb 04, 2005;Build 438
;
;====================
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,TEXT
;Dates that are only defined during evaluation, i.e., FIEVAL(2,"DATE")
;cannot be checked here.
S BDT=$S(X(1)'="":$$CTFMD^PXRMDATE(X(1)),1:0)
I BDT=-1 Q
S EDT=X(2)
I EDT="" S EDT="T"
S EDT=$$CTFMD^PXRMDATE(EDT)
I EDT=-1 Q
;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
;
;====================
CRDUEDATE(CRSTATUS,CRDUEDATE,DEFARR,FIEVAL) ;Determine the C/R due date. If the C/R
;status is CONTRA, order the contraindicated warn until dates from oldest to newest.
;Starting at the oldest warn until date, one at a time, remove each non-permanent contraindicated
;occurrence and evaluate the contraindicated logic. If it is now false, the C/R due
;date is the corresponding warn until date plus one day. If the contraindicated logic
;never becomes true, the contraindication is permanent and the C/R due date is NULL.
;If the C/R status is REFUSED, use the same algorithm for the refusals.
N CRFIEVAL,DONE,FI,FIND,FINDING,FF,FLIST,IND,LOGIC,LOGICTEST,NUM,OCC,TEMP,WUDT,WUDTC,WUDTR
I CRSTATUS="REFUSED" G REFUSED
;CONTRAINDICATED
;If there is no CONTRAINDICATED LOGIC go to REFUSED section.
I DEFARR(80)="" G REFUSED
;Build the list of contraindicated Warn Until Dates.
S FIND=0
F S FIND=+$O(FIEVAL("CONTRA",FIND)) Q:FIND=0 D
. S OCC=0
. F S OCC=+$O(FIEVAL("CONTRA",FIND,OCC)) Q:OCC=0 D
.. S WUDT=FIEVAL("CONTRA",FIND,OCC,"WUDT")
.. S WUDTC(WUDT,FIND,OCC)=""
M CRFIEVAL=FIEVAL
S LOGIC=DEFARR(80)
S NUM=$P(DEFARR(81),U,1)
S FLIST=$P(DEFARR(81),U,2)
S CRDUEDATE="",WUDT=0
F S WUDT=$O(WUDTC(WUDT)) Q:(CRDUEDATE'="")!(WUDT="") D
. S FIND=0
. F S FIND=$O(WUDTC(WUDT,FIND)) Q:(CRDUEDATE'="")!(FIND="") D
.. S (DONE,OCC)=0
.. F S OCC=$O(WUDTC(WUDT,FIND,OCC)) Q:(CRDUEDATE'="")!(DONE=1) D
...;If the CONTRAINDICATION is not permanent remove it.
... I WUDT=0 Q
...;If all the occurrences have been deleted, delete the top level.
... I OCC="" K CRFIEVAL("CONTRA",FIND) S DONE=1
... I OCC'="" K CRFIEVAL("CONTRA",FIND,OCC)
...;Evaluate function findings.
... D EVAL^PXRMFF(.DEFARR,.CRFIEVAL)
...;Evaluate CONTRAINDICATED LOGIC to determine if it is still true.
... F IND=1:1:NUM D
.... S FINDING=$P(FLIST,";",IND)
.... I FINDING["FF" S TEMP=$P(FINDING,"FF",2),FF(TEMP)=CRFIEVAL(FINDING)
.... E S FI(FINDING)=CRFIEVAL(FINDING)
... S LOGICTEST=0 I @LOGIC S LOGICTEST=1
... I 'LOGICTEST S CRDUEDATE=$$FMADD^XLFDT(WUDT,1,0,0,0)
I CRSTATUS="CONTRA" Q
I CRDUEDATE'="" Q
;
;REFUSED
REFUSED I DEFARR(90)="" Q
;Build the list of refused Warn Until Dates.
S FIND=0
F S FIND=+$O(FIEVAL("REFUSED",FIND)) Q:FIND=0 D
. S OCC=0
. F S OCC=+$O(FIEVAL("REFUSED",FIND,OCC)) Q:OCC=0 D
.. S WUDT=FIEVAL("REFUSED",FIND,OCC,"WUDT")
.. S WUDTR(WUDT,FIND,OCC)=""
I '$D(CRFIEVAL) M CRFIEVAL=FIEVAL
S LOGIC=DEFARR(90)
S NUM=$P(DEFARR(91),U,1)
S FLIST=$P(DEFARR(91),U,2)
S CRDUEDATE="",WUDT=0
F S WUDT=$O(WUDTR(WUDT)) Q:(CRDUEDATE'="")!(WUDT="") D
. S FIND=0
. F S FIND=$O(WUDTR(WUDT,FIND)) Q:(CRDUEDATE'="")!(FIND="") D
.. S (DONE,OCC)=0
.. F S OCC=$O(WUDTR(WUDT,FIND,OCC)) Q:(CRDUEDATE'="")!(DONE=1) D
...;If the REFUSAL is not permanent remove it.
... I WUDT=0 Q
...;If all the occurrences have been deleted, delete the top level.
... I OCC="" K CRFIEVAL("REFUSED",FIND) S DONE=1
... I OCC'="" K CRFIEVAL("REFUSED",FIND,OCC)
...;Evaluate function findings.
... D EVAL^PXRMFF(.DEFARR,.CRFIEVAL)
...;Evaluate REFUSED LOGIC to determine if it is still true.
... F IND=1:1:NUM D
.... S FINDING=$P(FLIST,";",IND)
.... I FINDING["FF" S TEMP=$P(FINDING,"FF",2),FF(TEMP)=CRFIEVAL(FINDING)
.... E S FI(FINDING)=CRFIEVAL(FINDING)
... S LOGICTEST=0 I @LOGIC S LOGICTEST=1
... I 'LOGICTEST S CRDUEDATE=$$FMADD^XLFDT(WUDT,1,0,0,0)
Q
;
;====================
CTD(MULT,NUM) ;Convert months or years to days.
N DAYS,INTDAYS,FRAC
S DAYS=MULT*NUM
;Round the number of days.
S INTDAYS=+$P(DAYS,".",1)
S FRAC=DAYS-INTDAYS
S DAYS=$S(FRAC<0.5:INTDAYS,1:INTDAYS+1)
Q DAYS
;
;====================
CTFMD(DATE) ;Convert DATE which may be in any of the FileMan acceptable
;forms with additional CR extensions to an internal FileMan date.
N FMDATE,OFFSET,OP,SYM,SYMV,TDATE,TIME
;Already in internal FileMan date format?
I DATE?7N Q DATE
I DATE?7N1"."1.6N Q DATE
S TDATE=$TR(DATE," ",""),TDATE=$$UP^XLFSTR(TDATE)
;Check for T or TODAY with a time.
I $E(TDATE,1)="T" S TIME=$P(TDATE,"@",2),TDATE=$P(TDATE,"@",1)
;Check for dates in the form SYMBOL+IU,or SYMBOL-IU, where I is
;an integer and U is a unit.
S OP=$S(TDATE["+":"+",TDATE["-":"-",1:"")
S SYM=$S(OP'="":$P(TDATE,OP,1),1:TDATE)
S OFFSET=$S(OP'="":$P(TDATE,OP,2),1:"")
;If the symbolic part is not on the list of valid symbols try FileMan.
I '$$VSYM(SYM) D DT^DILF("ST",DATE,.FMDATE) Q FMDATE
;Check for a valid offset.
I OFFSET'="",'$$VOFFSET(OFFSET) Q -1
I ((SYM="T")!(SYM="TODAY")),(OFFSET["H") D Q -1
. I $G(PXRMINTR)=1 D EN^DDIOL("Cannot use "_SYM_" with "_OFFSET)
;If this is being called by the input transform VDT^PXRMINTR we
;are done.
I $G(PXRMINTR)=1 Q 1
;If the symbol is not one of the standard FM symbols then it is
;one of the Clinical Reminder symbols.
S SYMV=$S(SYM="T":$$TODAY,SYM="TODAY":$$TODAY,SYM="N":$$NOW,SYM="NOW":$$NOW,SYM="NOON":$$NOON,SYM="MID":$$MID,1:+$G(@SYM))
I $G(TIME)'="" D
. S SYMV=SYMV_"@"_TIME
. D DT^DILF("ST",SYMV,.FMDATE)
. S SYMV=FMDATE
;If the symbol does not equate to an internal FM date return -1
I '(SYMV?7N0.1"."0.6N) Q -1
Q $$NEWDATE(SYMV,OP,OFFSET)
;
;====================
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)
;
;====================
DDATE(DATE,FMT) ;Check for an historical (event) date, format as appropriate.
I DATE=0 Q "00/00/0000"
Q $$FMTE^XLFDT(DATE,FMT)
;
;====================
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,NOW,PXRMITEM,TDDUE
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
;
;If there is no resolution logic then frequency is not required.
I (FREQ="")!(FREQ=-1)&(DEFARR(35)'="") 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 now date the
;reminder is due.
S NOW=$$NOW^PXRMDATE
I +DUEDATE'>NOW S DUE="DUE NOW" Q
;
S DIAT=$P(DEFARR(0),U,4)
I DIAT="" S DIATOK=0
E S DIATOK=1
;
S TDDUE=$S(DIATOK=1:$$NEWDATE(DUEDATE,"-",DIAT),1:DUEDATE)
S DUE=$S(TDDUE'>NOW:"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,
;include time.
I DATE=0 Q "00/00/0000"
I DATE=-1 Q "None"
Q $$FMTE^XLFDT(DATE,"5Z")
;
;====================
FMDATE(DFN,TEST,DATE,VALUE,TEXT) ;FileMan date computed finding.
I TEST="" S TEST=0 Q
I $E(TEST,1,4)="PXRM" D Q
. N TDATE
. S TDATE=+$G(@TEST)
. I TDATE=0 S TEST=0 Q
. S (DATE,VALUE)=$$CTFMD^PXRMDATE(TDATE),TEST=1
S (DATE,VALUE)=$$CTFMD^PXRMDATE(TEST),TEST=1
Q
;
;====================
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. Used for ranking only.
I FREQ="" Q 0
N LEN,NUM,UNIT
S NUM=+FREQ
S LEN=$L(FREQ)
S UNIT=$E(FREQ,LEN)
;30.42 is average number of days in a month, 365.24 is average number
;of days in a year. Unknown unit return 0.
S NUM=$S(UNIT="D":NUM,UNIT="M":$$CTD(30.42,NUM),UNIT="Y":$$CTD(365.24,NUM),1:0)
Q NUM
;
;====================
ISFULDTE(DATE) ; Function to check for full FileMan date.
N DAY,MONTH,YEAR
S DAY=$E(DATE,6,7) I +DAY=0 Q 0
S MONTH=$E(DATE,4,5) I +MONTH=0 Q 0
S YEAR=$E(DATE,1,3) I +YEAR=0 Q 0
Q 1
;
;====================
ISLEAP(YEAR) ;Given a 3 digit FileMan year return 1 if it is a leap year,
;0 otherwise.
S YEAR=YEAR+1700
Q (YEAR#4=0)&'(YEAR#100=0)!(YEAR#400=0)
;
;====================
MCALC(FMDATE,OP,NUM) ;Add or subtract NUM months to FMDATE.
N DAY,DIM,MONTH,TIME,YEAR
S YEAR=$E(FMDATE,1,3),MONTH=$E(FMDATE,4,5),DAY=$E(FMDATE,6,7)
S TIME=$P(FMDATE,".",2)
I TIME'="" S TIME="."_TIME
I OP="+" F Q:'NUM S NUM=NUM-1,MONTH=MONTH+1 I MONTH=13 S YEAR=YEAR+1,MONTH=1
I OP="-" F Q:'NUM S NUM=NUM-1,MONTH=MONTH-1 I MONTH=0 S YEAR=YEAR-1,MONTH=12
S DIM="31^"_($$ISLEAP(YEAR)+28)_"^31^30^31^30^31^31^30^31^30^31"
I DAY>$P(DIM,"^",MONTH) S DAY=$P(DIM,"^",MONTH)
Q YEAR_"00"+MONTH_"00"+DAY_TIME
;
;====================
MID() ;If the reminder global PXRMDATE is defined return midnight on that day,
;otherwise return the current date at midnight.
Q $S(+$G(PXRMDATE)>0:$E(PXRMDATE,1,7),1:$$DT^XLFDT)_".24"
;
;====================
NEWDATE(FMDATE,OP,OFFSET) ;Given an internal FileMan date, an operator of
;that is + or - ,and an offset of the form I, ID, IW, IM, IY
;where I is a positive integer and H is hours, D is days, W is weeks,
;M is months, and Y is years calculate and return the new FM date.
N DAYS,HOURS,NUM,UNIT
I FMDATE=0 Q 0
S NUM=+OFFSET
I NUM<0 Q -1
S UNIT=$E(OFFSET,$L(NUM)+1)
I UNIT="" S UNIT="D"
I UNIT="H" S HOURS=OP_NUM Q $$FMADD^XLFDT(FMDATE,0,HOURS,0,0)
I UNIT="D" S DAYS=OP_NUM Q $$FMADD^XLFDT(FMDATE,DAYS,0,0,0)
I UNIT="W" S DAYS=OP_(NUM*7) Q $$FMADD^XLFDT(FMDATE,DAYS,0,0,0)
I UNIT="M" Q $$MCALC(FMDATE,OP,NUM)
I UNIT="Y" Q $$YCALC(FMDATE,OP,NUM)
Q -1
;
;====================
NOON() ;If the reminder global PXRMDATE is defined return noon on that day,
;otherwise return the current date at noon.
Q $S(+$G(PXRMDATE)>0:$E(PXRMDATE,1,7),1:$$DT^XLFDT)_".12"
;
;====================
NOW() ;If the reminder global PXRMDATE is defined return it, otherwise
;return the current date and time.
I +$G(PXRMDATE)=0 Q $$NOW^XLFDT
N NOW,TIME
S TIME=$P(PXRMDATE,".",2)
I TIME="" S TIME=$P($$NOW^XLFDT,".",2),NOW=PXRMDATE_"."_TIME
E S NOW=PXRMDATE
Q NOW
;
;====================
TODAY() ;If the reminder global PXRMDATE is defined return it, otherwise
;return the current date.
Q $S(+$G(PXRMDATE)>0:$P(PXRMDATE,".",1),1:$$DT^XLFDT)
;
;====================
VDATE(VIEN) ;Given a visit ien return the visit date.
N DATE
S DATE=$S(+VIEN>0:$P($G(^AUPNVSIT(VIEN,0)),U,1),1:0)
I $L(DATE)=0 S DATE=0
;Check for historical encounter.
I $$ISHIST^PXRMVSIT(VIEN) S DATE=DATE_"E"
Q DATE
;
;====================
VOFFSET(OFFSET) ;Make sure the offset part of a date is valid. It has to
;have the form I or IU where I is an integer and U is one of the
;following units: H, D, W, M, Y.
I OFFSET?1.N0.1"H"0.1"D"0.1"W"0.1"M"0.1"Y" Q 1
Q 0
;
;====================
VSYM(SYM) ;Make sure the symbolic part of a date is valid.
;Already in FileMan internal form.
I SYM?7N Q 1
I SYM?7N1"."1.6N Q 1
;Check for FileMan symbols.
I (SYM="T")!(SYM="TODAY") Q 1
I (SYM="N")!(SYM="NOW") Q 1
I (SYM="NOON") Q 1
I (SYM="MID") Q 1
;Check for Clinical Reminder symbols.
I SYM="PXRMLAD" Q 1
I SYM="PXRMDOB" Q 1
I SYM="PXRMDOD" Q 1
I SYM?1"FIEVAL("1.N1","0.1(1.N1",")1"""DATE"")" Q 1
Q 0
;
;====================
YCALC(FMDATE,OP,NUM) ;Add or subtract NUM years to FMDATE.
N DAY,MONTH,TIME,YEAR
S YEAR=$E(FMDATE,1,3),MONTH=$E(FMDATE,4,5),DAY=$E(FMDATE,6,7)
S TIME=$P(FMDATE,".",2)
I TIME'="" S TIME="."_TIME
I OP="+" F Q:'NUM S NUM=NUM-1,YEAR=YEAR+1
I OP="-" F Q:'NUM S NUM=NUM-1,YEAR=YEAR-1
;Handle leap year.
I MONTH="02",DAY>27,'$$ISLEAP(YEAR) S DAY=28
Q YEAR_"00"+MONTH_"00"+DAY_TIME
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMDATE 14811 printed Oct 16, 2024@17:44:21 Page 2
PXRMDATE ;SLC/PKR - Clinical Reminders date utilities. ;06/28/2022
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12,17,18,24,26,47,42,65**;Feb 04, 2005;Build 438
+2 ;
+3 ;====================
CEFD(FDA) ;Called by the Exchange Utility only if the input packed
+1 ;reminder was packed under v1.5. Move Effective Date to Beginning Date.
+2 NEW IND
+3 SET IND=""
+4 FOR
SET IND=$ORDER(FDA(811.902,IND))
if IND=""
QUIT
Begin DoDot:1
+5 IF '$DATA(FDA(811.902,IND,12))
QUIT
+6 ;If the EFFECTIVE PERIOD exists don't do anything.
+7 IF $DATA(FDA(811.902,IND,9))
QUIT
+8 SET FDA(811.902,IND,9)=FDA(811.902,IND,12)
+9 KILL FDA(811.902,IND,12)
End DoDot:1
+10 QUIT
+11 ;
+12 ;====================
COMPARE(X) ;Compare beginning and ending dates, give a warning if
+1 ;Ending Date comes before Beginning Date. Called by ADATE xref in
+2 ;definitions and terms.
+3 ;Do not execute as part of exchange.
+4 IF $GET(PXRMEXCH)
QUIT
+5 NEW BDT,EDT,TEXT
+6 ;Dates that are only defined during evaluation, i.e., FIEVAL(2,"DATE")
+7 ;cannot be checked here.
+8 SET BDT=$SELECT(X(1)'="":$$CTFMD^PXRMDATE(X(1)),1:0)
+9 IF BDT=-1
QUIT
+10 SET EDT=X(2)
+11 IF EDT=""
SET EDT="T"
+12 SET EDT=$$CTFMD^PXRMDATE(EDT)
+13 IF EDT=-1
QUIT
+14 ;If EDT does not contain a time set it to the end of the day.
+15 IF EDT'["."
SET EDT=EDT_".235959"
+16 IF EDT<BDT
Begin DoDot:1
+17 SET BDT=$SELECT(X(1)'="":X(1),1:"")
+18 SET EDT=$SELECT(X(2)'="":X(2),1:"T@2400")
+19 SET TEXT="Warning the ending date ("_EDT_") is before the beginning date ("_BDT_")"
+20 DO EN^DDIOL(TEXT)
End DoDot:1
+21 QUIT
+22 ;
+23 ;====================
COTN(EFP) ;Convert an Effective Period to the new date/time format.
+1 ;Possible effective periods are ND, NM, or NY where N is an integer.
+2 SET EFP=$$UP^XLFSTR(EFP)
+3 IF (EFP?1N.N1"D")!(EFP?1N.N1"M")!(EFP?1N.N1"Y")
Begin DoDot:1
+4 SET NUM=+EFP
+5 SET EFP=$SELECT(NUM=0:"T",1:"T-"_EFP)
End DoDot:1
+6 QUIT EFP
+7 ;
+8 ;====================
CRDUEDATE(CRSTATUS,CRDUEDATE,DEFARR,FIEVAL) ;Determine the C/R due date. If the C/R
+1 ;status is CONTRA, order the contraindicated warn until dates from oldest to newest.
+2 ;Starting at the oldest warn until date, one at a time, remove each non-permanent contraindicated
+3 ;occurrence and evaluate the contraindicated logic. If it is now false, the C/R due
+4 ;date is the corresponding warn until date plus one day. If the contraindicated logic
+5 ;never becomes true, the contraindication is permanent and the C/R due date is NULL.
+6 ;If the C/R status is REFUSED, use the same algorithm for the refusals.
+7 NEW CRFIEVAL,DONE,FI,FIND,FINDING,FF,FLIST,IND,LOGIC,LOGICTEST,NUM,OCC,TEMP,WUDT,WUDTC,WUDTR
+8 IF CRSTATUS="REFUSED"
GOTO REFUSED
+9 ;CONTRAINDICATED
+10 ;If there is no CONTRAINDICATED LOGIC go to REFUSED section.
+11 IF DEFARR(80)=""
GOTO REFUSED
+12 ;Build the list of contraindicated Warn Until Dates.
+13 SET FIND=0
+14 FOR
SET FIND=+$ORDER(FIEVAL("CONTRA",FIND))
if FIND=0
QUIT
Begin DoDot:1
+15 SET OCC=0
+16 FOR
SET OCC=+$ORDER(FIEVAL("CONTRA",FIND,OCC))
if OCC=0
QUIT
Begin DoDot:2
+17 SET WUDT=FIEVAL("CONTRA",FIND,OCC,"WUDT")
+18 SET WUDTC(WUDT,FIND,OCC)=""
End DoDot:2
End DoDot:1
+19 MERGE CRFIEVAL=FIEVAL
+20 SET LOGIC=DEFARR(80)
+21 SET NUM=$PIECE(DEFARR(81),U,1)
+22 SET FLIST=$PIECE(DEFARR(81),U,2)
+23 SET CRDUEDATE=""
SET WUDT=0
+24 FOR
SET WUDT=$ORDER(WUDTC(WUDT))
if (CRDUEDATE'="")!(WUDT="")
QUIT
Begin DoDot:1
+25 SET FIND=0
+26 FOR
SET FIND=$ORDER(WUDTC(WUDT,FIND))
if (CRDUEDATE'="")!(FIND="")
QUIT
Begin DoDot:2
+27 SET (DONE,OCC)=0
+28 FOR
SET OCC=$ORDER(WUDTC(WUDT,FIND,OCC))
if (CRDUEDATE'="")!(DONE=1)
QUIT
Begin DoDot:3
+29 ;If the CONTRAINDICATION is not permanent remove it.
+30 IF WUDT=0
QUIT
+31 ;If all the occurrences have been deleted, delete the top level.
+32 IF OCC=""
KILL CRFIEVAL("CONTRA",FIND)
SET DONE=1
+33 IF OCC'=""
KILL CRFIEVAL("CONTRA",FIND,OCC)
+34 ;Evaluate function findings.
+35 DO EVAL^PXRMFF(.DEFARR,.CRFIEVAL)
+36 ;Evaluate CONTRAINDICATED LOGIC to determine if it is still true.
+37 FOR IND=1:1:NUM
Begin DoDot:4
+38 SET FINDING=$PIECE(FLIST,";",IND)
+39 IF FINDING["FF"
SET TEMP=$PIECE(FINDING,"FF",2)
SET FF(TEMP)=CRFIEVAL(FINDING)
+40 IF '$TEST
SET FI(FINDING)=CRFIEVAL(FINDING)
End DoDot:4
+41 SET LOGICTEST=0
IF @LOGIC
SET LOGICTEST=1
+42 IF 'LOGICTEST
SET CRDUEDATE=$$FMADD^XLFDT(WUDT,1,0,0,0)
End DoDot:3
End DoDot:2
End DoDot:1
+43 IF CRSTATUS="CONTRA"
QUIT
+44 IF CRDUEDATE'=""
QUIT
+45 ;
+46 ;REFUSED
REFUSED IF DEFARR(90)=""
QUIT
+1 ;Build the list of refused Warn Until Dates.
+2 SET FIND=0
+3 FOR
SET FIND=+$ORDER(FIEVAL("REFUSED",FIND))
if FIND=0
QUIT
Begin DoDot:1
+4 SET OCC=0
+5 FOR
SET OCC=+$ORDER(FIEVAL("REFUSED",FIND,OCC))
if OCC=0
QUIT
Begin DoDot:2
+6 SET WUDT=FIEVAL("REFUSED",FIND,OCC,"WUDT")
+7 SET WUDTR(WUDT,FIND,OCC)=""
End DoDot:2
End DoDot:1
+8 IF '$DATA(CRFIEVAL)
MERGE CRFIEVAL=FIEVAL
+9 SET LOGIC=DEFARR(90)
+10 SET NUM=$PIECE(DEFARR(91),U,1)
+11 SET FLIST=$PIECE(DEFARR(91),U,2)
+12 SET CRDUEDATE=""
SET WUDT=0
+13 FOR
SET WUDT=$ORDER(WUDTR(WUDT))
if (CRDUEDATE'="")!(WUDT="")
QUIT
Begin DoDot:1
+14 SET FIND=0
+15 FOR
SET FIND=$ORDER(WUDTR(WUDT,FIND))
if (CRDUEDATE'="")!(FIND="")
QUIT
Begin DoDot:2
+16 SET (DONE,OCC)=0
+17 FOR
SET OCC=$ORDER(WUDTR(WUDT,FIND,OCC))
if (CRDUEDATE'="")!(DONE=1)
QUIT
Begin DoDot:3
+18 ;If the REFUSAL is not permanent remove it.
+19 IF WUDT=0
QUIT
+20 ;If all the occurrences have been deleted, delete the top level.
+21 IF OCC=""
KILL CRFIEVAL("REFUSED",FIND)
SET DONE=1
+22 IF OCC'=""
KILL CRFIEVAL("REFUSED",FIND,OCC)
+23 ;Evaluate function findings.
+24 DO EVAL^PXRMFF(.DEFARR,.CRFIEVAL)
+25 ;Evaluate REFUSED LOGIC to determine if it is still true.
+26 FOR IND=1:1:NUM
Begin DoDot:4
+27 SET FINDING=$PIECE(FLIST,";",IND)
+28 IF FINDING["FF"
SET TEMP=$PIECE(FINDING,"FF",2)
SET FF(TEMP)=CRFIEVAL(FINDING)
+29 IF '$TEST
SET FI(FINDING)=CRFIEVAL(FINDING)
End DoDot:4
+30 SET LOGICTEST=0
IF @LOGIC
SET LOGICTEST=1
+31 IF 'LOGICTEST
SET CRDUEDATE=$$FMADD^XLFDT(WUDT,1,0,0,0)
End DoDot:3
End DoDot:2
End DoDot:1
+32 QUIT
+33 ;
+34 ;====================
CTD(MULT,NUM) ;Convert months or years to days.
+1 NEW DAYS,INTDAYS,FRAC
+2 SET DAYS=MULT*NUM
+3 ;Round the number of days.
+4 SET INTDAYS=+$PIECE(DAYS,".",1)
+5 SET FRAC=DAYS-INTDAYS
+6 SET DAYS=$SELECT(FRAC<0.5:INTDAYS,1:INTDAYS+1)
+7 QUIT DAYS
+8 ;
+9 ;====================
CTFMD(DATE) ;Convert DATE which may be in any of the FileMan acceptable
+1 ;forms with additional CR extensions to an internal FileMan date.
+2 NEW FMDATE,OFFSET,OP,SYM,SYMV,TDATE,TIME
+3 ;Already in internal FileMan date format?
+4 IF DATE?7N
QUIT DATE
+5 IF DATE?7N1"."1.6N
QUIT DATE
+6 SET TDATE=$TRANSLATE(DATE," ","")
SET TDATE=$$UP^XLFSTR(TDATE)
+7 ;Check for T or TODAY with a time.
+8 IF $EXTRACT(TDATE,1)="T"
SET TIME=$PIECE(TDATE,"@",2)
SET TDATE=$PIECE(TDATE,"@",1)
+9 ;Check for dates in the form SYMBOL+IU,or SYMBOL-IU, where I is
+10 ;an integer and U is a unit.
+11 SET OP=$SELECT(TDATE["+":"+",TDATE["-":"-",1:"")
+12 SET SYM=$SELECT(OP'="":$PIECE(TDATE,OP,1),1:TDATE)
+13 SET OFFSET=$SELECT(OP'="":$PIECE(TDATE,OP,2),1:"")
+14 ;If the symbolic part is not on the list of valid symbols try FileMan.
+15 IF '$$VSYM(SYM)
DO DT^DILF("ST",DATE,.FMDATE)
QUIT FMDATE
+16 ;Check for a valid offset.
+17 IF OFFSET'=""
IF '$$VOFFSET(OFFSET)
QUIT -1
+18 IF ((SYM="T")!(SYM="TODAY"))
IF (OFFSET["H")
Begin DoDot:1
+19 IF $GET(PXRMINTR)=1
DO EN^DDIOL("Cannot use "_SYM_" with "_OFFSET)
End DoDot:1
QUIT -1
+20 ;If this is being called by the input transform VDT^PXRMINTR we
+21 ;are done.
+22 IF $GET(PXRMINTR)=1
QUIT 1
+23 ;If the symbol is not one of the standard FM symbols then it is
+24 ;one of the Clinical Reminder symbols.
+25 SET SYMV=$SELECT(SYM="T":$$TODAY,SYM="TODAY":$$TODAY,SYM="N":$$NOW,SYM="NOW":$$NOW,SYM="NOON":$$NOON,SYM="MID":$$MID,1:+$GET(@SYM))
+26 IF $GET(TIME)'=""
Begin DoDot:1
+27 SET SYMV=SYMV_"@"_TIME
+28 DO DT^DILF("ST",SYMV,.FMDATE)
+29 SET SYMV=FMDATE
End DoDot:1
+30 ;If the symbol does not equate to an internal FM date return -1
+31 IF '(SYMV?7N0.1"."0.6N)
QUIT -1
+32 QUIT $$NEWDATE(SYMV,OP,OFFSET)
+33 ;
+34 ;====================
DCHECK(DATE) ;Trap for special characters before calling CTFMD^PXRMDATE.
+1 ;Used in DIR("PRE") for date inputs.
+2 IF $DATA(DTOUT)
QUIT DATE
+3 IF DATE=""
QUIT DATE
+4 IF DATE["^"
QUIT DATE
+5 IF DATE["?"
QUIT DATE
+6 QUIT $$CTFMD^PXRMDATE(DATE)
+7 ;
+8 ;====================
DDATE(DATE,FMT) ;Check for an historical (event) date, format as appropriate.
+1 IF DATE=0
QUIT "00/00/0000"
+2 QUIT $$FMTE^XLFDT(DATE,FMT)
+3 ;
+4 ;====================
DUE(DEFARR,RESDATE,FREQ,DUE,DUEDATE,FIEVAL) ;Compute the due date.
+1 ;This is the date of the resolution finding + the reminder frequency.
+2 ;Subtract the due in advance time to see if the reminder should be
+3 ;marked as due soon.
+4 ;
+5 NEW DATE,DIAT,DIATOK,LDATE,NOW,PXRMITEM,TDDUE
+6 SET PXRMITEM=DEFARR("IEN")
+7 ;If the final frequency is 0Y then the reminder is not due.
+8 IF FREQ="0Y"
SET DUE=0
SET DUEDATE=""
QUIT
+9 ;
+10 SET DUEDATE=""
+11 ;Check for custom date due.
+12 IF DEFARR(45)'=""
SET DUEDATE=$$CDUEDATE^PXRMCDUE(.DEFARR,.FIEVAL)
+13 IF DUEDATE'=""
IF DUEDATE'=-1
GOTO SETDUE
+14 ;
+15 ;If there is no resolution logic then frequency is not required.
+16 IF (FREQ="")!(FREQ=-1)&(DEFARR(35)'="")
Begin DoDot:1
+17 SET ^TMP(PXRMPID,$JOB,PXRMITEM,"WARNING","NOFREQ")="No reminder frequency - cannot compute due date!"
+18 SET (DUE,DUEDATE)="CNBD"
End DoDot:1
QUIT
+19 ;
+20 SET LDATE=$SELECT(RESDATE["X":0,1:+RESDATE)
+21 IF LDATE=0
SET (DUE,DUEDATE)="DUE NOW"
QUIT
+22 SET DATE=$$FULLDATE(LDATE)
SET DUEDATE=$$NEWDATE(DATE,"+",FREQ)
+23 ;
SETDUE ;If the due date is less than or equal to now date the
+1 ;reminder is due.
+2 SET NOW=$$NOW^PXRMDATE
+3 IF +DUEDATE'>NOW
SET DUE="DUE NOW"
QUIT
+4 ;
+5 SET DIAT=$PIECE(DEFARR(0),U,4)
+6 IF DIAT=""
SET DIATOK=0
+7 IF '$TEST
SET DIATOK=1
+8 ;
+9 SET TDDUE=$SELECT(DIATOK=1:$$NEWDATE(DUEDATE,"-",DIAT),1:DUEDATE)
+10 SET DUE=$SELECT(TDDUE'>NOW:"DUE SOON",1:"RESOLVED")
+11 QUIT
+12 ;
+13 ;====================
DURATION(START,STOP) ;Return the number days between the Start Date and
+1 ;Stop Date.
+2 IF +START=0
QUIT 0
+3 NEW PXRMNOW
+4 SET PXRMNOW=$$NOW^PXRMDATE
+5 IF START>PXRMNOW
QUIT 0
+6 IF (STOP="")!(STOP>PXRMNOW)
SET STOP=PXRMNOW
+7 QUIT $$FMDIFF^XLFDT(STOP,START)
+8 ;
+9 ;====================
EDATE(DATE) ;Check for an historical (event) date, format as appropriate,
+1 ;include time.
+2 IF DATE=0
QUIT "00/00/0000"
+3 IF DATE=-1
QUIT "None"
+4 QUIT $$FMTE^XLFDT(DATE,"5Z")
+5 ;
+6 ;====================
FMDATE(DFN,TEST,DATE,VALUE,TEXT) ;FileMan date computed finding.
+1 IF TEST=""
SET TEST=0
QUIT
+2 IF $EXTRACT(TEST,1,4)="PXRM"
Begin DoDot:1
+3 NEW TDATE
+4 SET TDATE=+$GET(@TEST)
+5 IF TDATE=0
SET TEST=0
QUIT
+6 SET (DATE,VALUE)=$$CTFMD^PXRMDATE(TDATE)
SET TEST=1
End DoDot:1
QUIT
+7 SET (DATE,VALUE)=$$CTFMD^PXRMDATE(TEST)
SET TEST=1
+8 QUIT
+9 ;
+10 ;====================
FULLDATE(DATE) ;See if DATE is a full date, i.e., it has a month and
+1 ;a day along with a year. If the month is missing assume Jan. If the
+2 ;day is missing assume the first. Issue a warning so the user knows
+3 ;what happened. DATE should be in Fileman format.
+4 NEW DAY,MISSING,MONTH,TDATE,YEAR
+5 SET TDATE=DATE
+6 SET MISSING=0
+7 SET DAY=$EXTRACT(DATE,6,7)
+8 SET MONTH=$EXTRACT(DATE,4,5)
+9 SET YEAR=$EXTRACT(DATE,1,3)
+10 IF +DAY=0
Begin DoDot:1
+11 SET DAY=1
+12 SET MISSING=1
+13 SET ^TMP(PXRMPID,$JOB,PXRMITEM,"INFO","NO DAY")="Encounter date missing the day, using the first for the date due calculation."
End DoDot:1
+14 IF +MONTH=0
Begin DoDot:1
+15 SET MONTH=1
+16 SET MISSING=1
+17 SET ^TMP(PXRMPID,$JOB,PXRMITEM,"INFO","NO MONTH")="Encounter date missing the month, using January for the date due calculation."
End DoDot:1
+18 IF MISSING
Begin DoDot:1
+19 SET TDATE=(YEAR*1E4)+(MONTH*1E2)+DAY
+20 IF DATE["E"
SET TDATE=TDATE_"E"
End DoDot:1
+21 QUIT TDATE
+22 ;
+23 ;====================
FRQINDAY(FREQ) ;Given a frequency in the form ND, NM, or NY where N is a
+1 ;number and D stands for days, M for months, and Y for years return
+2 ;the value in days. Used for ranking only.
+3 IF FREQ=""
QUIT 0
+4 NEW LEN,NUM,UNIT
+5 SET NUM=+FREQ
+6 SET LEN=$LENGTH(FREQ)
+7 SET UNIT=$EXTRACT(FREQ,LEN)
+8 ;30.42 is average number of days in a month, 365.24 is average number
+9 ;of days in a year. Unknown unit return 0.
+10 SET NUM=$SELECT(UNIT="D":NUM,UNIT="M":$$CTD(30.42,NUM),UNIT="Y":$$CTD(365.24,NUM),1:0)
+11 QUIT NUM
+12 ;
+13 ;====================
ISFULDTE(DATE) ; Function to check for full FileMan date.
+1 NEW DAY,MONTH,YEAR
+2 SET DAY=$EXTRACT(DATE,6,7)
IF +DAY=0
QUIT 0
+3 SET MONTH=$EXTRACT(DATE,4,5)
IF +MONTH=0
QUIT 0
+4 SET YEAR=$EXTRACT(DATE,1,3)
IF +YEAR=0
QUIT 0
+5 QUIT 1
+6 ;
+7 ;====================
ISLEAP(YEAR) ;Given a 3 digit FileMan year return 1 if it is a leap year,
+1 ;0 otherwise.
+2 SET YEAR=YEAR+1700
+3 QUIT (YEAR#4=0)&'(YEAR#100=0)!(YEAR#400=0)
+4 ;
+5 ;====================
MCALC(FMDATE,OP,NUM) ;Add or subtract NUM months to FMDATE.
+1 NEW DAY,DIM,MONTH,TIME,YEAR
+2 SET YEAR=$EXTRACT(FMDATE,1,3)
SET MONTH=$EXTRACT(FMDATE,4,5)
SET DAY=$EXTRACT(FMDATE,6,7)
+3 SET TIME=$PIECE(FMDATE,".",2)
+4 IF TIME'=""
SET TIME="."_TIME
+5 IF OP="+"
FOR
if 'NUM
QUIT
SET NUM=NUM-1
SET MONTH=MONTH+1
IF MONTH=13
SET YEAR=YEAR+1
SET MONTH=1
+6 IF OP="-"
FOR
if 'NUM
QUIT
SET NUM=NUM-1
SET MONTH=MONTH-1
IF MONTH=0
SET YEAR=YEAR-1
SET MONTH=12
+7 SET DIM="31^"_($$ISLEAP(YEAR)+28)_"^31^30^31^30^31^31^30^31^30^31"
+8 IF DAY>$PIECE(DIM,"^",MONTH)
SET DAY=$PIECE(DIM,"^",MONTH)
+9 QUIT YEAR_"00"+MONTH_"00"+DAY_TIME
+10 ;
+11 ;====================
MID() ;If the reminder global PXRMDATE is defined return midnight on that day,
+1 ;otherwise return the current date at midnight.
+2 QUIT $SELECT(+$GET(PXRMDATE)>0:$EXTRACT(PXRMDATE,1,7),1:$$DT^XLFDT)_".24"
+3 ;
+4 ;====================
NEWDATE(FMDATE,OP,OFFSET) ;Given an internal FileMan date, an operator of
+1 ;that is + or - ,and an offset of the form I, ID, IW, IM, IY
+2 ;where I is a positive integer and H is hours, D is days, W is weeks,
+3 ;M is months, and Y is years calculate and return the new FM date.
+4 NEW DAYS,HOURS,NUM,UNIT
+5 IF FMDATE=0
QUIT 0
+6 SET NUM=+OFFSET
+7 IF NUM<0
QUIT -1
+8 SET UNIT=$EXTRACT(OFFSET,$LENGTH(NUM)+1)
+9 IF UNIT=""
SET UNIT="D"
+10 IF UNIT="H"
SET HOURS=OP_NUM
QUIT $$FMADD^XLFDT(FMDATE,0,HOURS,0,0)
+11 IF UNIT="D"
SET DAYS=OP_NUM
QUIT $$FMADD^XLFDT(FMDATE,DAYS,0,0,0)
+12 IF UNIT="W"
SET DAYS=OP_(NUM*7)
QUIT $$FMADD^XLFDT(FMDATE,DAYS,0,0,0)
+13 IF UNIT="M"
QUIT $$MCALC(FMDATE,OP,NUM)
+14 IF UNIT="Y"
QUIT $$YCALC(FMDATE,OP,NUM)
+15 QUIT -1
+16 ;
+17 ;====================
NOON() ;If the reminder global PXRMDATE is defined return noon on that day,
+1 ;otherwise return the current date at noon.
+2 QUIT $SELECT(+$GET(PXRMDATE)>0:$EXTRACT(PXRMDATE,1,7),1:$$DT^XLFDT)_".12"
+3 ;
+4 ;====================
NOW() ;If the reminder global PXRMDATE is defined return it, otherwise
+1 ;return the current date and time.
+2 IF +$GET(PXRMDATE)=0
QUIT $$NOW^XLFDT
+3 NEW NOW,TIME
+4 SET TIME=$PIECE(PXRMDATE,".",2)
+5 IF TIME=""
SET TIME=$PIECE($$NOW^XLFDT,".",2)
SET NOW=PXRMDATE_"."_TIME
+6 IF '$TEST
SET NOW=PXRMDATE
+7 QUIT NOW
+8 ;
+9 ;====================
TODAY() ;If the reminder global PXRMDATE is defined return it, otherwise
+1 ;return the current date.
+2 QUIT $SELECT(+$GET(PXRMDATE)>0:$PIECE(PXRMDATE,".",1),1:$$DT^XLFDT)
+3 ;
+4 ;====================
VDATE(VIEN) ;Given a visit ien return the visit date.
+1 NEW DATE
+2 SET DATE=$SELECT(+VIEN>0:$PIECE($GET(^AUPNVSIT(VIEN,0)),U,1),1:0)
+3 IF $LENGTH(DATE)=0
SET DATE=0
+4 ;Check for historical encounter.
+5 IF $$ISHIST^PXRMVSIT(VIEN)
SET DATE=DATE_"E"
+6 QUIT DATE
+7 ;
+8 ;====================
VOFFSET(OFFSET) ;Make sure the offset part of a date is valid. It has to
+1 ;have the form I or IU where I is an integer and U is one of the
+2 ;following units: H, D, W, M, Y.
+3 IF OFFSET?1.N0.1"H"0.1"D"0.1"W"0.1"M"0.1"Y"
QUIT 1
+4 QUIT 0
+5 ;
+6 ;====================
VSYM(SYM) ;Make sure the symbolic part of a date is valid.
+1 ;Already in FileMan internal form.
+2 IF SYM?7N
QUIT 1
+3 IF SYM?7N1"."1.6N
QUIT 1
+4 ;Check for FileMan symbols.
+5 IF (SYM="T")!(SYM="TODAY")
QUIT 1
+6 IF (SYM="N")!(SYM="NOW")
QUIT 1
+7 IF (SYM="NOON")
QUIT 1
+8 IF (SYM="MID")
QUIT 1
+9 ;Check for Clinical Reminder symbols.
+10 IF SYM="PXRMLAD"
QUIT 1
+11 IF SYM="PXRMDOB"
QUIT 1
+12 IF SYM="PXRMDOD"
QUIT 1
+13 IF SYM?1"FIEVAL("1.N1","0.1(1.N1",")1"""DATE"")"
QUIT 1
+14 QUIT 0
+15 ;
+16 ;====================
YCALC(FMDATE,OP,NUM) ;Add or subtract NUM years to FMDATE.
+1 NEW DAY,MONTH,TIME,YEAR
+2 SET YEAR=$EXTRACT(FMDATE,1,3)
SET MONTH=$EXTRACT(FMDATE,4,5)
SET DAY=$EXTRACT(FMDATE,6,7)
+3 SET TIME=$PIECE(FMDATE,".",2)
+4 IF TIME'=""
SET TIME="."_TIME
+5 IF OP="+"
FOR
if 'NUM
QUIT
SET NUM=NUM-1
SET YEAR=YEAR+1
+6 IF OP="-"
FOR
if 'NUM
QUIT
SET NUM=NUM-1
SET YEAR=YEAR-1
+7 ;Handle leap year.
+8 IF MONTH="02"
IF DAY>27
IF '$$ISLEAP(YEAR)
SET DAY=28
+9 QUIT YEAR_"00"+MONTH_"00"+DAY_TIME
+10 ;
