- 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 Feb 18, 2025@23:12:52 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 ;