PXRMLOG ;SLC/PKR - Clinical Reminders logic routines. ;03/31/2022
;;2.0;CLINICAL REMINDERS;**4,6,12,17,18,26,47,42,65**;Feb 04, 2005;Build 438
;==========================================================
CRSTATUS(DEFARR,FIEVAL) ;Determine the contraindicated/refused status.
N CONTRALOGIC,CONTRASTRING,CRSTATUS,DCONTRALOGIC,IND,FF,FI,FINDING,FLIST,NUM,TEMP,TEST
;If there is contraindicated logic, evaluate it.
S CRSTATUS=""
S TEMP=DEFARR(81)
S NUM=+$P(TEMP,U,1)
I NUM>0 D
. S (CONTRALOGIC,CONTRASTRING)=DEFARR(80)
. S FLIST=$P(TEMP,U,2)
. F IND=1:1:NUM D
.. S FINDING=$P(FLIST,";",IND)
.. I FINDING["FF" S TEMP=$P(FINDING,"FF",2),FF(TEMP)=FIEVAL(FINDING)
.. E S FI(FINDING)=FIEVAL(FINDING)
. I @CONTRALOGIC S CRSTATUS="CONTRA"
. S TEST=$T
. I $G(PXRMDEBG) D
.. S DCONTRALOGIC=CONTRALOGIC
.. F IND=1:1:NUM D
... S FINDING=$P(FLIST,";",IND)
... S TEMP=$S(FINDING["FF":"FF("_$P(FINDING,"FF",2)_")",1:"FI("_FINDING_")")
... S DCONTRALOGIC=$$STRREP^PXRMUTIL(DCONTRALOGIC,TEMP,FIEVAL(FINDING))
. S ^TMP(PXRMPID,$J,PXRMITEM,"CONTRAINDICATED LOGIC")=TEST_U_CONTRASTRING_U_$G(DCONTRALOGIC)
I CRSTATUS="CONTRA" Q CRSTATUS
;
;If CRSTATUS is not "CONTRA" and there is resolution logic evaluate it.
N DREFUSEDLOGIC,REFUSEDLOGIC,REFUSEDSTRING
S TEMP=DEFARR(91)
S NUM=+$P(TEMP,U,1)
I NUM>0 D
. S (REFUSEDLOGIC,REFUSEDSTRING)=DEFARR(90)
. S FLIST=$P(TEMP,U,2)
. F IND=1:1:NUM D
.. S FINDING=$P(FLIST,";",IND)
.. I FINDING["FF" S TEMP=$P(FINDING,"FF",2),FF(TEMP)=FIEVAL(FINDING)
.. E S FI(FINDING)=FIEVAL(FINDING)
. I @REFUSEDLOGIC S CRSTATUS="REFUSED"
. S TEST=$T
. I $G(PXRMDEBG) D
.. S DREFUSEDLOGIC=REFUSEDLOGIC
.. F IND=1:1:NUM D
... S FINDING=$P(FLIST,";",IND)
... S TEMP=$S(FINDING["FF":"FF("_$P(FINDING,"FF",2)_")",1:"FI("_FINDING_")")
... S DREFUSEDLOGIC=$$STRREP^PXRMUTIL(DREFUSEDLOGIC,TEMP,FIEVAL(FINDING))
. S ^TMP(PXRMPID,$J,PXRMITEM,"REFUSED LOGIC")=TEST_U_REFUSEDSTRING_U_$G(DREFUSEDLOGIC)
Q CRSTATUS
;
;==========================================================
EVALPCL(DEFARR,PXRMPDEM,FREQ,PCLOGIC,FIEVAL) ;Evaluate the Patient Cohort
;Logic.
;Determine the applicable frequency age range set; get the baseline.
N AGEFI,IND,FINDING,FIFREQ,FLIST,FREQDAY,MAXAGE,MINAGE,NODE,NUMAFI
N PCLOG,PCLSTR,RANKAR,RANK,RANKFI,TEMP,TEST
D MMF^PXRMAGE(.DEFARR,.PXRMPDEM,.MINAGE,.MAXAGE,.FREQ,.FIEVAL)
S FIFREQ="Baseline"
;If there is no match with any of the baseline values FREQ=-1.
;If there was no frequency in the definition then FREQ="".
;See if any findings override the baseline.
S TEMP=DEFARR(40)
S NUMAFI=+$P(TEMP,U,1)
;If there are no age findings use the baseline.
I NUMAFI=0 G ACHK
S FLIST=$P(TEMP,U,2)
F IND=1:1:NUMAFI D
. S FINDING=$P(FLIST,";",IND)
. I FIEVAL(FINDING) D
.. S NODE=$S(FINDING["FF":25,1:20)
.. S TEMP=DEFARR(NODE,FINDING,0)
.. S RANK=+$P(TEMP,U,5)
.. I RANK=0 S RANK=9999
.. S FREQDAY=$$FRQINDAY^PXRMDATE($P(TEMP,U,4))
..;If there is no frequency with this rank ignore it.
.. I FREQDAY]"" S RANKAR(RANK,FREQDAY,FINDING)=""
;If there was a ranking use it otherwise use the greatest frequency.
I '$D(RANKAR) G ACHK
S RANK=0
S RANK=+$O(RANKAR(RANK))
S FREQDAY=+$O(RANKAR(RANK,""))
S FINDING=$O(RANKAR(RANK,FREQDAY,""))
I FINDING'="" D
. S NODE=$S(FINDING["FF":25,1:20)
. S TEMP=DEFARR(NODE,FINDING,0)
. S FREQ=$P(TEMP,U,4)
. S MINAGE=$P(TEMP,U,2)
. S MAXAGE=$P(TEMP,U,3)
. S FIFREQ="Finding "_FINDING
.;Remove the baseline age findings since they have been overridden.
. K FIEVAL("AGE")
ACHK ;
I FREQ="" D
. S AGEFI=0
.;If there is no resolution logic then frequency is not required.
. I DEFARR(35)="" S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NOFREQ")="There is no reminder frequency!"
. I DEFARR(35)'="" S ^TMP(PXRMPID,$J,PXRMITEM,"FERROR","NOFREQ")="There is resolution logic but no reminder frequency!"
E D
.;Save the final frequency and age range for display.
.;Use the z so this will be the last of the info text.
. S ^TMP(PXRMPID,$J,PXRMITEM,"zFREQARNG")=FREQ_U_MINAGE_U_MAXAGE_U_FIFREQ
. S ^TMP("PXRHM",$J,PXRMITEM,PXRMRNAM,"FREQ")=FREQ
. S AGEFI=$S(FREQ=-1:0,1:$$AGECHECK^PXRMAGE(PXRMPDEM("AGE"),MINAGE,MAXAGE))
S FIEVAL("AGE")=AGEFI
;
EVAL ;Evaluate the patient cohort logic.
N AGE,DPCLOG,FI,FF,FUN,FUNCTION,FUNLIST,NUM,SEX,VAR
S TEMP=DEFARR(32)
S NUM=+$P(TEMP,U,1)
S (PCLOG,PCLSTR)=DEFARR(31)
S FLIST=$P(TEMP,U,2)
F IND=1:1:NUM D
. S FINDING=$P(FLIST,";",IND)
. I FINDING="AGE" S AGE=+$G(FIEVAL("AGE"))
. I FINDING="SEX" S SEX=+$G(FIEVAL("SEX"))
. I FINDING["FF" S TEMP=$P(FINDING,"FF",2),FF(TEMP)=FIEVAL(FINDING)
. E S FI(FINDING)=FIEVAL(FINDING)
I @PCLOG
S TEST=$T
I 'AGEFI,PCLSTR["AGE" D
. S ^TMP(PXRMPID,$J,PXRMITEM,"N/A","AGE")=""
. S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","AGE")="Patient does not meet any age criteria!"
;Reminders are always N/A for dead patients unless PXRMIDOD is true in which case
;the regular cohort logic applies.
I '$G(PXRMIDOD),PXRMPDEM("DOD")'="" S TEST=0
S PCLOGIC=TEST_U_PCLSTR
I 'TEST S ^TMP(PXRMPID,$J,PXRMITEM,"N/A","COHORT")=""
I $G(PXRMDEBG) D
. S DPCLOG=PCLOG
. F IND=1:1:NUM D
.. S FINDING=$P(FLIST,";",IND)
.. I FINDING="AGE" S DPCLOG=$$STRREP^PXRMUTIL(DPCLOG,"AGE",+$G(FIEVAL(FINDING))) Q
.. I FINDING="SEX" S DPCLOG=$$STRREP^PXRMUTIL(DPCLOG,"SEX",+$G(FIEVAL(FINDING))) Q
.. S TEMP=$S(FINDING["FF":"FF("_$P(FINDING,"FF",2)_")",1:"FI("_FINDING_")")
.. S DPCLOG=$$STRREP^PXRMUTIL(DPCLOG,TEMP,FIEVAL(FINDING))
S PCLOGIC=PCLOGIC_U_$G(DPCLOG)
I $G(PXRMDEBG) S ^TMP(PXRMPID,$J,PXRMITEM,"PATIENT COHORT LOGIC")=PCLOGIC
Q
;
;==========================================================
EVALRESL(DEFARR,RESDATE,RESLOGIC,FIEVAL) ;Evaluate the
;Resolution Logic.
N DRESLOG,IND,FF,FI,FINDING,FLIST,NUM,RESLOG,RESLSTR,TEMP,TEST
S TEMP=DEFARR(36)
S NUM=+$P(TEMP,U,1)
I NUM=0 Q
S (RESLOG,RESLSTR)=DEFARR(35)
S FLIST=$P(TEMP,U,2)
F IND=1:1:NUM D
. S FINDING=$P(FLIST,";",IND)
. I FINDING["FF" S TEMP=$P(FINDING,"FF",2),FF(TEMP)=FIEVAL(FINDING)
. E S FI(FINDING)=FIEVAL(FINDING)
I @RESLOG
S TEST=$T
I $G(PXRMDEBG) D
. S DRESLOG=RESLOG
. F IND=1:1:NUM D
.. S FINDING=$P(FLIST,";",IND)
.. S TEMP=$S(FINDING["FF":"FF("_$P(FINDING,"FF",2)_")",1:"FI("_FINDING_")")
.. S DRESLOG=$$STRREP^PXRMUTIL(DRESLOG,TEMP,FIEVAL(FINDING))
S RESLOGIC=TEST_U_RESLSTR_U_$G(DRESLOG)
I $G(PXRMDEBG) S ^TMP(PXRMPID,$J,PXRMITEM,"RESOLUTION LOGIC")=RESLOGIC
S RESDATE=$S(TEST=1:$$RESDATE(RESLSTR,.FIEVAL),1:0)
Q
;
;==========================================================
LOGOP(DT1,DT2,LOP) ;Given two dates return the most recent if the logical
;operator is ! and the oldest if it is &. 'FIs and FFs which don't
;have a date are flagged with date of -1.
I DT1=0,DT2=0 Q 0
I DT1=-1,DT2=-1 Q -1
N VALUE
I LOP="&" D Q VALUE
. I (DT1=0)!(DT2=0) S VALUE=0 Q
. I (DT1=-1) S VALUE=DT2 Q
. I (DT2=-1) S VALUE=DT1 Q
. S VALUE=$S(DT1>DT2:DT2,1:DT1)
I LOP'="!" Q 0
I DT1=-1 Q $S(DT2>0:DT2,1:-1)
I DT2=-1 Q $S(DT1>0:DT1,1:-1)
Q $S(DT1>DT2:DT1,1:DT2)
;
;==========================================================
RESDATE(RESLSTR,FIEVAL) ;Return the resolution date based on the following
;rules:
;Dates that are ORed use the most recent.
;Dates that are ANDed use the oldest.
;This is routine is called only if the resolution logic is true.
N DATE,DT1,DT2,DT3,FINUM,IND,JND,OPER,PFSTACK,STACK,T1,T2
;Remove leading (n) entries.
I ($E(RESLSTR,1,4)="(0)!")!($E(RESLSTR,1,4)="(1)&") S $E(RESLSTR,1,4)=""
S OPER="!&'U"
D POSTFIX^PXRMSTAC(RESLSTR,OPER,.PFSTACK)
S (IND,JND)=0
F D Q:(IND'<PFSTACK(0))
. S IND=IND+1,T1=PFSTACK(IND)
. I T1="FI" D Q
.. S IND=IND+1,FINUM=PFSTACK(IND)
..;Replace true findings with their dates.
.. S DATE=$S(FIEVAL(FINUM)=1:FIEVAL(FINUM,"DATE"),1:0)
.. S JND=JND+1,STACK(JND)=DATE
. I T1="FF" D Q
..;FFs do not have dates, flag them all with -1.
.. S IND=IND+1,JND=JND+1,STACK(JND)=-1
. I OPER[T1 S JND=JND+1,STACK(JND)=T1
S STACK(0)=JND
K PFSTACK
S PFSTACK(0)=0
F IND=1:1:STACK(0) D
. S T1=STACK(IND)
. I OPER'[T1 D PUSH^PXRMSTAC(.PFSTACK,T1) Q
.;For unary NOT replace the top of the stack with -1.
. I T1="'U" S DT1=$$POP^PXRMSTAC(.PFSTACK) D PUSH^PXRMSTAC(.PFSTACK,-1) Q
.;Pop the top two elements on the stack and do the operation.
. S DT1=$$POP^PXRMSTAC(.PFSTACK)
. S DT2=$$POP^PXRMSTAC(.PFSTACK)
. S DT3=$$LOGOP(DT1,DT2,T1)
.;Save the result back on the stack
. D PUSH^PXRMSTAC(.PFSTACK,DT3)
;The result is the only thing left on the stack.
Q $$POP^PXRMSTAC(.PFSTACK)
;
;==========================================================
SEX(DEFARR,SEX) ;Return FALSE (0) if the patient is the wrong sex for
; the reminder, TRUE (1) is the patient is the right sex.
N REMSEX
S REMSEX=$P(DEFARR(0),U,9)
I REMSEX="" Q 1
I SEX=REMSEX Q 1
S ^TMP(PXRMPID,$J,PXRMITEM,"N/A","SEX")=""
S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","SEX")="Patient is the wrong sex!"
Q 0
;
;==========================================================
VALID(LOGSTR,DA,MINLEN,MAXLEN) ;Make sure that LOGSTR is a valid logic string.
;This is called by the input transform for PATIENT COHORT LOGIC and
;RESOLUTION LOGIC. Return 1 if LOGSTR is ok.
;Don't do this if this is being called as a result of an install
;through the Exchange Utility.
I $G(PXRMEXCH) Q 1
I LOGSTR="" Q 0
;
;Check the length.
N LEN
S LEN=$L(LOGSTR)
I LEN<MINLEN D Q 0
. D EN^DDIOL("Logic string is too short")
I LEN>MAXLEN D Q 0
. D EN^DDIOL("Logic string is too long")
;
;Use the FileMan code validator to check the code.
N X
S X="S Y="_$TR(LOGSTR,";","")
D ^DIM
I $D(X)=0 D Q 0
. N TEXT
. S TEXT(1)="LOGIC string: "_LOGSTR
. S TEXT(2)="contains invalid MUMPS code!"
. D EN^DDIOL(.TEXT)
;
N ELE1,ELE2,MNUM,SEP,STACK,TEXT,TSTSTR,VALID
;Make sure the entries in LOGSTR are valid elements or functions.
S TSTSTR=LOGSTR
S TSTSTR=$TR(TSTSTR,"'","")
S TSTSTR=$TR(TSTSTR,"&",U)
S TSTSTR=$TR(TSTSTR,"!",U)
;Set the allowable logic separators.
S SEP="^,<>="
;Convert the string to postfix form for evaluation.
D POSTFIX^PXRMSTAC(TSTSTR,SEP,.STACK)
S (ELE1,VALID)=1
F Q:(ELE1="")!(VALID=0) D
. S ELE1=$$POP^PXRMSTAC(.STACK)
. I '$$VELEM(ELE1) S VALID=0 Q
. I SEP[ELE1 Q
.;If the element is FI or FF then the next element should be a number.
. S MNUM=$S(ELE1="FI":20,ELE1="FF":25,1:"")
. I MNUM'="" D
.. S ELE2=$$POP^PXRMSTAC(.STACK)
.. I ELE2'=+ELE2 S VALID=0
.. I VALID S VALID=$D(^PXD(811.9,DA,MNUM,ELE2))
.. I 'VALID D
... S TEXT=ELE1_"("_ELE2_") is not in this definition!"
... D EN^DDIOL(TEXT)
Q VALID
;
;==========================================================
VALIDR(LOGSTR,DA,MINLEN,MAXLEN) ;Make sure that LOGSTR is a valid resolution
;logic string. This is called by the input transform for RESOLUTION
;LOGIC. Return 1 if LOGSTR is ok.
;Don't do this if this is being called as a result of an install
;through the Exchange Utility.
I $G(PXRMEXCH) Q 1
I LOGSTR="" Q 0
N TEXT
;The resolution logic cannot contain SEX or AGE.
I LOGSTR["AGE" D Q 0
. S TEXT="The resolution logic cannot contain AGE!"
. D EN^DDIOL(TEXT)
I LOGSTR["SEX" D Q 0
. S TEXT="The resolution logic cannot contain SEX!"
. D EN^DDIOL(TEXT)
;Now call the regular logic string validator.
Q $$VALID(LOGSTR,DA,MINLEN,MAXLEN)
;
;==========================================================
VELEM(ELEMENT) ;Make sure that the element is valid.
I ELEMENT="AGE" Q 1
I ELEMENT="FI" Q 1
I ELEMENT="FF" Q 1
I ELEMENT="SEX" Q 1
I ELEMENT="^" Q 1
I ELEMENT?.N Q 1
D EN^DDIOL(ELEMENT_" is not a valid logic element.")
Q 0
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMLOG 11765 printed Apr 09, 2024@20:49:51 Page 2
PXRMLOG ;SLC/PKR - Clinical Reminders logic routines. ;03/31/2022
+1 ;;2.0;CLINICAL REMINDERS;**4,6,12,17,18,26,47,42,65**;Feb 04, 2005;Build 438
+2 ;==========================================================
CRSTATUS(DEFARR,FIEVAL) ;Determine the contraindicated/refused status.
+1 NEW CONTRALOGIC,CONTRASTRING,CRSTATUS,DCONTRALOGIC,IND,FF,FI,FINDING,FLIST,NUM,TEMP,TEST
+2 ;If there is contraindicated logic, evaluate it.
+3 SET CRSTATUS=""
+4 SET TEMP=DEFARR(81)
+5 SET NUM=+$PIECE(TEMP,U,1)
+6 IF NUM>0
Begin DoDot:1
+7 SET (CONTRALOGIC,CONTRASTRING)=DEFARR(80)
+8 SET FLIST=$PIECE(TEMP,U,2)
+9 FOR IND=1:1:NUM
Begin DoDot:2
+10 SET FINDING=$PIECE(FLIST,";",IND)
+11 IF FINDING["FF"
SET TEMP=$PIECE(FINDING,"FF",2)
SET FF(TEMP)=FIEVAL(FINDING)
+12 IF '$TEST
SET FI(FINDING)=FIEVAL(FINDING)
End DoDot:2
+13 IF @CONTRALOGIC
SET CRSTATUS="CONTRA"
+14 SET TEST=$TEST
+15 IF $GET(PXRMDEBG)
Begin DoDot:2
+16 SET DCONTRALOGIC=CONTRALOGIC
+17 FOR IND=1:1:NUM
Begin DoDot:3
+18 SET FINDING=$PIECE(FLIST,";",IND)
+19 SET TEMP=$SELECT(FINDING["FF":"FF("_$PIECE(FINDING,"FF",2)_")",1:"FI("_FINDING_")")
+20 SET DCONTRALOGIC=$$STRREP^PXRMUTIL(DCONTRALOGIC,TEMP,FIEVAL(FINDING))
End DoDot:3
End DoDot:2
+21 SET ^TMP(PXRMPID,$JOB,PXRMITEM,"CONTRAINDICATED LOGIC")=TEST_U_CONTRASTRING_U_$GET(DCONTRALOGIC)
End DoDot:1
+22 IF CRSTATUS="CONTRA"
QUIT CRSTATUS
+23 ;
+24 ;If CRSTATUS is not "CONTRA" and there is resolution logic evaluate it.
+25 NEW DREFUSEDLOGIC,REFUSEDLOGIC,REFUSEDSTRING
+26 SET TEMP=DEFARR(91)
+27 SET NUM=+$PIECE(TEMP,U,1)
+28 IF NUM>0
Begin DoDot:1
+29 SET (REFUSEDLOGIC,REFUSEDSTRING)=DEFARR(90)
+30 SET FLIST=$PIECE(TEMP,U,2)
+31 FOR IND=1:1:NUM
Begin DoDot:2
+32 SET FINDING=$PIECE(FLIST,";",IND)
+33 IF FINDING["FF"
SET TEMP=$PIECE(FINDING,"FF",2)
SET FF(TEMP)=FIEVAL(FINDING)
+34 IF '$TEST
SET FI(FINDING)=FIEVAL(FINDING)
End DoDot:2
+35 IF @REFUSEDLOGIC
SET CRSTATUS="REFUSED"
+36 SET TEST=$TEST
+37 IF $GET(PXRMDEBG)
Begin DoDot:2
+38 SET DREFUSEDLOGIC=REFUSEDLOGIC
+39 FOR IND=1:1:NUM
Begin DoDot:3
+40 SET FINDING=$PIECE(FLIST,";",IND)
+41 SET TEMP=$SELECT(FINDING["FF":"FF("_$PIECE(FINDING,"FF",2)_")",1:"FI("_FINDING_")")
+42 SET DREFUSEDLOGIC=$$STRREP^PXRMUTIL(DREFUSEDLOGIC,TEMP,FIEVAL(FINDING))
End DoDot:3
End DoDot:2
+43 SET ^TMP(PXRMPID,$JOB,PXRMITEM,"REFUSED LOGIC")=TEST_U_REFUSEDSTRING_U_$GET(DREFUSEDLOGIC)
End DoDot:1
+44 QUIT CRSTATUS
+45 ;
+46 ;==========================================================
EVALPCL(DEFARR,PXRMPDEM,FREQ,PCLOGIC,FIEVAL) ;Evaluate the Patient Cohort
+1 ;Logic.
+2 ;Determine the applicable frequency age range set; get the baseline.
+3 NEW AGEFI,IND,FINDING,FIFREQ,FLIST,FREQDAY,MAXAGE,MINAGE,NODE,NUMAFI
+4 NEW PCLOG,PCLSTR,RANKAR,RANK,RANKFI,TEMP,TEST
+5 DO MMF^PXRMAGE(.DEFARR,.PXRMPDEM,.MINAGE,.MAXAGE,.FREQ,.FIEVAL)
+6 SET FIFREQ="Baseline"
+7 ;If there is no match with any of the baseline values FREQ=-1.
+8 ;If there was no frequency in the definition then FREQ="".
+9 ;See if any findings override the baseline.
+10 SET TEMP=DEFARR(40)
+11 SET NUMAFI=+$PIECE(TEMP,U,1)
+12 ;If there are no age findings use the baseline.
+13 IF NUMAFI=0
GOTO ACHK
+14 SET FLIST=$PIECE(TEMP,U,2)
+15 FOR IND=1:1:NUMAFI
Begin DoDot:1
+16 SET FINDING=$PIECE(FLIST,";",IND)
+17 IF FIEVAL(FINDING)
Begin DoDot:2
+18 SET NODE=$SELECT(FINDING["FF":25,1:20)
+19 SET TEMP=DEFARR(NODE,FINDING,0)
+20 SET RANK=+$PIECE(TEMP,U,5)
+21 IF RANK=0
SET RANK=9999
+22 SET FREQDAY=$$FRQINDAY^PXRMDATE($PIECE(TEMP,U,4))
+23 ;If there is no frequency with this rank ignore it.
+24 IF FREQDAY]""
SET RANKAR(RANK,FREQDAY,FINDING)=""
End DoDot:2
End DoDot:1
+25 ;If there was a ranking use it otherwise use the greatest frequency.
+26 IF '$DATA(RANKAR)
GOTO ACHK
+27 SET RANK=0
+28 SET RANK=+$ORDER(RANKAR(RANK))
+29 SET FREQDAY=+$ORDER(RANKAR(RANK,""))
+30 SET FINDING=$ORDER(RANKAR(RANK,FREQDAY,""))
+31 IF FINDING'=""
Begin DoDot:1
+32 SET NODE=$SELECT(FINDING["FF":25,1:20)
+33 SET TEMP=DEFARR(NODE,FINDING,0)
+34 SET FREQ=$PIECE(TEMP,U,4)
+35 SET MINAGE=$PIECE(TEMP,U,2)
+36 SET MAXAGE=$PIECE(TEMP,U,3)
+37 SET FIFREQ="Finding "_FINDING
+38 ;Remove the baseline age findings since they have been overridden.
+39 KILL FIEVAL("AGE")
End DoDot:1
ACHK ;
+1 IF FREQ=""
Begin DoDot:1
+2 SET AGEFI=0
+3 ;If there is no resolution logic then frequency is not required.
+4 IF DEFARR(35)=""
SET ^TMP(PXRMPID,$JOB,PXRMITEM,"INFO","NOFREQ")="There is no reminder frequency!"
+5 IF DEFARR(35)'=""
SET ^TMP(PXRMPID,$JOB,PXRMITEM,"FERROR","NOFREQ")="There is resolution logic but no reminder frequency!"
End DoDot:1
+6 IF '$TEST
Begin DoDot:1
+7 ;Save the final frequency and age range for display.
+8 ;Use the z so this will be the last of the info text.
+9 SET ^TMP(PXRMPID,$JOB,PXRMITEM,"zFREQARNG")=FREQ_U_MINAGE_U_MAXAGE_U_FIFREQ
+10 SET ^TMP("PXRHM",$JOB,PXRMITEM,PXRMRNAM,"FREQ")=FREQ
+11 SET AGEFI=$SELECT(FREQ=-1:0,1:$$AGECHECK^PXRMAGE(PXRMPDEM("AGE"),MINAGE,MAXAGE))
End DoDot:1
+12 SET FIEVAL("AGE")=AGEFI
+13 ;
EVAL ;Evaluate the patient cohort logic.
+1 NEW AGE,DPCLOG,FI,FF,FUN,FUNCTION,FUNLIST,NUM,SEX,VAR
+2 SET TEMP=DEFARR(32)
+3 SET NUM=+$PIECE(TEMP,U,1)
+4 SET (PCLOG,PCLSTR)=DEFARR(31)
+5 SET FLIST=$PIECE(TEMP,U,2)
+6 FOR IND=1:1:NUM
Begin DoDot:1
+7 SET FINDING=$PIECE(FLIST,";",IND)
+8 IF FINDING="AGE"
SET AGE=+$GET(FIEVAL("AGE"))
+9 IF FINDING="SEX"
SET SEX=+$GET(FIEVAL("SEX"))
+10 IF FINDING["FF"
SET TEMP=$PIECE(FINDING,"FF",2)
SET FF(TEMP)=FIEVAL(FINDING)
+11 IF '$TEST
SET FI(FINDING)=FIEVAL(FINDING)
End DoDot:1
+12 IF @PCLOG
+13 SET TEST=$TEST
+14 IF 'AGEFI
IF PCLSTR["AGE"
Begin DoDot:1
+15 SET ^TMP(PXRMPID,$JOB,PXRMITEM,"N/A","AGE")=""
+16 SET ^TMP(PXRMPID,$JOB,PXRMITEM,"INFO","AGE")="Patient does not meet any age criteria!"
End DoDot:1
+17 ;Reminders are always N/A for dead patients unless PXRMIDOD is true in which case
+18 ;the regular cohort logic applies.
+19 IF '$GET(PXRMIDOD)
IF PXRMPDEM("DOD")'=""
SET TEST=0
+20 SET PCLOGIC=TEST_U_PCLSTR
+21 IF 'TEST
SET ^TMP(PXRMPID,$JOB,PXRMITEM,"N/A","COHORT")=""
+22 IF $GET(PXRMDEBG)
Begin DoDot:1
+23 SET DPCLOG=PCLOG
+24 FOR IND=1:1:NUM
Begin DoDot:2
+25 SET FINDING=$PIECE(FLIST,";",IND)
+26 IF FINDING="AGE"
SET DPCLOG=$$STRREP^PXRMUTIL(DPCLOG,"AGE",+$GET(FIEVAL(FINDING)))
QUIT
+27 IF FINDING="SEX"
SET DPCLOG=$$STRREP^PXRMUTIL(DPCLOG,"SEX",+$GET(FIEVAL(FINDING)))
QUIT
+28 SET TEMP=$SELECT(FINDING["FF":"FF("_$PIECE(FINDING,"FF",2)_")",1:"FI("_FINDING_")")
+29 SET DPCLOG=$$STRREP^PXRMUTIL(DPCLOG,TEMP,FIEVAL(FINDING))
End DoDot:2
End DoDot:1
+30 SET PCLOGIC=PCLOGIC_U_$GET(DPCLOG)
+31 IF $GET(PXRMDEBG)
SET ^TMP(PXRMPID,$JOB,PXRMITEM,"PATIENT COHORT LOGIC")=PCLOGIC
+32 QUIT
+33 ;
+34 ;==========================================================
EVALRESL(DEFARR,RESDATE,RESLOGIC,FIEVAL) ;Evaluate the
+1 ;Resolution Logic.
+2 NEW DRESLOG,IND,FF,FI,FINDING,FLIST,NUM,RESLOG,RESLSTR,TEMP,TEST
+3 SET TEMP=DEFARR(36)
+4 SET NUM=+$PIECE(TEMP,U,1)
+5 IF NUM=0
QUIT
+6 SET (RESLOG,RESLSTR)=DEFARR(35)
+7 SET FLIST=$PIECE(TEMP,U,2)
+8 FOR IND=1:1:NUM
Begin DoDot:1
+9 SET FINDING=$PIECE(FLIST,";",IND)
+10 IF FINDING["FF"
SET TEMP=$PIECE(FINDING,"FF",2)
SET FF(TEMP)=FIEVAL(FINDING)
+11 IF '$TEST
SET FI(FINDING)=FIEVAL(FINDING)
End DoDot:1
+12 IF @RESLOG
+13 SET TEST=$TEST
+14 IF $GET(PXRMDEBG)
Begin DoDot:1
+15 SET DRESLOG=RESLOG
+16 FOR IND=1:1:NUM
Begin DoDot:2
+17 SET FINDING=$PIECE(FLIST,";",IND)
+18 SET TEMP=$SELECT(FINDING["FF":"FF("_$PIECE(FINDING,"FF",2)_")",1:"FI("_FINDING_")")
+19 SET DRESLOG=$$STRREP^PXRMUTIL(DRESLOG,TEMP,FIEVAL(FINDING))
End DoDot:2
End DoDot:1
+20 SET RESLOGIC=TEST_U_RESLSTR_U_$GET(DRESLOG)
+21 IF $GET(PXRMDEBG)
SET ^TMP(PXRMPID,$JOB,PXRMITEM,"RESOLUTION LOGIC")=RESLOGIC
+22 SET RESDATE=$SELECT(TEST=1:$$RESDATE(RESLSTR,.FIEVAL),1:0)
+23 QUIT
+24 ;
+25 ;==========================================================
LOGOP(DT1,DT2,LOP) ;Given two dates return the most recent if the logical
+1 ;operator is ! and the oldest if it is &. 'FIs and FFs which don't
+2 ;have a date are flagged with date of -1.
+3 IF DT1=0
IF DT2=0
QUIT 0
+4 IF DT1=-1
IF DT2=-1
QUIT -1
+5 NEW VALUE
+6 IF LOP="&"
Begin DoDot:1
+7 IF (DT1=0)!(DT2=0)
SET VALUE=0
QUIT
+8 IF (DT1=-1)
SET VALUE=DT2
QUIT
+9 IF (DT2=-1)
SET VALUE=DT1
QUIT
+10 SET VALUE=$SELECT(DT1>DT2:DT2,1:DT1)
End DoDot:1
QUIT VALUE
+11 IF LOP'="!"
QUIT 0
+12 IF DT1=-1
QUIT $SELECT(DT2>0:DT2,1:-1)
+13 IF DT2=-1
QUIT $SELECT(DT1>0:DT1,1:-1)
+14 QUIT $SELECT(DT1>DT2:DT1,1:DT2)
+15 ;
+16 ;==========================================================
RESDATE(RESLSTR,FIEVAL) ;Return the resolution date based on the following
+1 ;rules:
+2 ;Dates that are ORed use the most recent.
+3 ;Dates that are ANDed use the oldest.
+4 ;This is routine is called only if the resolution logic is true.
+5 NEW DATE,DT1,DT2,DT3,FINUM,IND,JND,OPER,PFSTACK,STACK,T1,T2
+6 ;Remove leading (n) entries.
+7 IF ($EXTRACT(RESLSTR,1,4)="(0)!")!($EXTRACT(RESLSTR,1,4)="(1)&")
SET $EXTRACT(RESLSTR,1,4)=""
+8 SET OPER="!&'U"
+9 DO POSTFIX^PXRMSTAC(RESLSTR,OPER,.PFSTACK)
+10 SET (IND,JND)=0
+11 FOR
Begin DoDot:1
+12 SET IND=IND+1
SET T1=PFSTACK(IND)
+13 IF T1="FI"
Begin DoDot:2
+14 SET IND=IND+1
SET FINUM=PFSTACK(IND)
+15 ;Replace true findings with their dates.
+16 SET DATE=$SELECT(FIEVAL(FINUM)=1:FIEVAL(FINUM,"DATE"),1:0)
+17 SET JND=JND+1
SET STACK(JND)=DATE
End DoDot:2
QUIT
+18 IF T1="FF"
Begin DoDot:2
+19 ;FFs do not have dates, flag them all with -1.
+20 SET IND=IND+1
SET JND=JND+1
SET STACK(JND)=-1
End DoDot:2
QUIT
+21 IF OPER[T1
SET JND=JND+1
SET STACK(JND)=T1
End DoDot:1
if (IND'<PFSTACK(0))
QUIT
+22 SET STACK(0)=JND
+23 KILL PFSTACK
+24 SET PFSTACK(0)=0
+25 FOR IND=1:1:STACK(0)
Begin DoDot:1
+26 SET T1=STACK(IND)
+27 IF OPER'[T1
DO PUSH^PXRMSTAC(.PFSTACK,T1)
QUIT
+28 ;For unary NOT replace the top of the stack with -1.
+29 IF T1="'U"
SET DT1=$$POP^PXRMSTAC(.PFSTACK)
DO PUSH^PXRMSTAC(.PFSTACK,-1)
QUIT
+30 ;Pop the top two elements on the stack and do the operation.
+31 SET DT1=$$POP^PXRMSTAC(.PFSTACK)
+32 SET DT2=$$POP^PXRMSTAC(.PFSTACK)
+33 SET DT3=$$LOGOP(DT1,DT2,T1)
+34 ;Save the result back on the stack
+35 DO PUSH^PXRMSTAC(.PFSTACK,DT3)
End DoDot:1
+36 ;The result is the only thing left on the stack.
+37 QUIT $$POP^PXRMSTAC(.PFSTACK)
+38 ;
+39 ;==========================================================
SEX(DEFARR,SEX) ;Return FALSE (0) if the patient is the wrong sex for
+1 ; the reminder, TRUE (1) is the patient is the right sex.
+2 NEW REMSEX
+3 SET REMSEX=$PIECE(DEFARR(0),U,9)
+4 IF REMSEX=""
QUIT 1
+5 IF SEX=REMSEX
QUIT 1
+6 SET ^TMP(PXRMPID,$JOB,PXRMITEM,"N/A","SEX")=""
+7 SET ^TMP(PXRMPID,$JOB,PXRMITEM,"INFO","SEX")="Patient is the wrong sex!"
+8 QUIT 0
+9 ;
+10 ;==========================================================
VALID(LOGSTR,DA,MINLEN,MAXLEN) ;Make sure that LOGSTR is a valid logic string.
+1 ;This is called by the input transform for PATIENT COHORT LOGIC and
+2 ;RESOLUTION LOGIC. Return 1 if LOGSTR is ok.
+3 ;Don't do this if this is being called as a result of an install
+4 ;through the Exchange Utility.
+5 IF $GET(PXRMEXCH)
QUIT 1
+6 IF LOGSTR=""
QUIT 0
+7 ;
+8 ;Check the length.
+9 NEW LEN
+10 SET LEN=$LENGTH(LOGSTR)
+11 IF LEN<MINLEN
Begin DoDot:1
+12 DO EN^DDIOL("Logic string is too short")
End DoDot:1
QUIT 0
+13 IF LEN>MAXLEN
Begin DoDot:1
+14 DO EN^DDIOL("Logic string is too long")
End DoDot:1
QUIT 0
+15 ;
+16 ;Use the FileMan code validator to check the code.
+17 NEW X
+18 SET X="S Y="_$TRANSLATE(LOGSTR,";","")
+19 DO ^DIM
+20 IF $DATA(X)=0
Begin DoDot:1
+21 NEW TEXT
+22 SET TEXT(1)="LOGIC string: "_LOGSTR
+23 SET TEXT(2)="contains invalid MUMPS code!"
+24 DO EN^DDIOL(.TEXT)
End DoDot:1
QUIT 0
+25 ;
+26 NEW ELE1,ELE2,MNUM,SEP,STACK,TEXT,TSTSTR,VALID
+27 ;Make sure the entries in LOGSTR are valid elements or functions.
+28 SET TSTSTR=LOGSTR
+29 SET TSTSTR=$TRANSLATE(TSTSTR,"'","")
+30 SET TSTSTR=$TRANSLATE(TSTSTR,"&",U)
+31 SET TSTSTR=$TRANSLATE(TSTSTR,"!",U)
+32 ;Set the allowable logic separators.
+33 SET SEP="^,<>="
+34 ;Convert the string to postfix form for evaluation.
+35 DO POSTFIX^PXRMSTAC(TSTSTR,SEP,.STACK)
+36 SET (ELE1,VALID)=1
+37 FOR
if (ELE1="")!(VALID=0)
QUIT
Begin DoDot:1
+38 SET ELE1=$$POP^PXRMSTAC(.STACK)
+39 IF '$$VELEM(ELE1)
SET VALID=0
QUIT
+40 IF SEP[ELE1
QUIT
+41 ;If the element is FI or FF then the next element should be a number.
+42 SET MNUM=$SELECT(ELE1="FI":20,ELE1="FF":25,1:"")
+43 IF MNUM'=""
Begin DoDot:2
+44 SET ELE2=$$POP^PXRMSTAC(.STACK)
+45 IF ELE2'=+ELE2
SET VALID=0
+46 IF VALID
SET VALID=$DATA(^PXD(811.9,DA,MNUM,ELE2))
+47 IF 'VALID
Begin DoDot:3
+48 SET TEXT=ELE1_"("_ELE2_") is not in this definition!"
+49 DO EN^DDIOL(TEXT)
End DoDot:3
End DoDot:2
End DoDot:1
+50 QUIT VALID
+51 ;
+52 ;==========================================================
VALIDR(LOGSTR,DA,MINLEN,MAXLEN) ;Make sure that LOGSTR is a valid resolution
+1 ;logic string. This is called by the input transform for RESOLUTION
+2 ;LOGIC. Return 1 if LOGSTR is ok.
+3 ;Don't do this if this is being called as a result of an install
+4 ;through the Exchange Utility.
+5 IF $GET(PXRMEXCH)
QUIT 1
+6 IF LOGSTR=""
QUIT 0
+7 NEW TEXT
+8 ;The resolution logic cannot contain SEX or AGE.
+9 IF LOGSTR["AGE"
Begin DoDot:1
+10 SET TEXT="The resolution logic cannot contain AGE!"
+11 DO EN^DDIOL(TEXT)
End DoDot:1
QUIT 0
+12 IF LOGSTR["SEX"
Begin DoDot:1
+13 SET TEXT="The resolution logic cannot contain SEX!"
+14 DO EN^DDIOL(TEXT)
End DoDot:1
QUIT 0
+15 ;Now call the regular logic string validator.
+16 QUIT $$VALID(LOGSTR,DA,MINLEN,MAXLEN)
+17 ;
+18 ;==========================================================
VELEM(ELEMENT) ;Make sure that the element is valid.
+1 IF ELEMENT="AGE"
QUIT 1
+2 IF ELEMENT="FI"
QUIT 1
+3 IF ELEMENT="FF"
QUIT 1
+4 IF ELEMENT="SEX"
QUIT 1
+5 IF ELEMENT="^"
QUIT 1
+6 IF ELEMENT?.N
QUIT 1
+7 DO EN^DDIOL(ELEMENT_" is not a valid logic element.")
+8 QUIT 0
+9 ;
