source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMLOG.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 8.9 KB
Line 
1PXRMLOG ; SLC/PKR - Clinical Reminders logic routines. ;06/12/2006
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;==========================================================
4EVALPCL(DEFARR,PXRMPDEM,FREQ,PCLOGIC,FIEVAL) ;Evaluate the Patient Cohort
5 ;Logic.
6 ;Determine the applicable frequency age range set; get the baseline.
7 N AGEFI,IND,FINDING,FLIST,FREQDAY,MAXAGE,MINAGE,NODE,NUMAFI
8 N PCLOG,PCLSTR,RANKAR,RANK,RANKFI,TEMP,TEST
9 D MMF^PXRMAGE(.DEFARR,.PXRMPDEM,.MINAGE,.MAXAGE,.FREQ,.FIEVAL)
10 ;If there is no match with any of the baseline values FREQ=-1.
11 ;If there was no frequency in the definition then FREQ="".
12 ;See if any findings override the baseline.
13 S TEMP=DEFARR(40)
14 S NUMAFI=+$P(TEMP,U,1)
15 ;If there are no age findings use the baseline.
16 I NUMAFI=0 G ACHK
17 S FLIST=$P(TEMP,U,2)
18 F IND=1:1:NUMAFI D
19 . S FINDING=$P(FLIST,";",IND)
20 . I FIEVAL(FINDING) D
21 .. S NODE=$S(FINDING["FF":25,1:20)
22 .. S TEMP=DEFARR(NODE,FINDING,0)
23 .. S RANK=+$P(TEMP,U,5)
24 .. I RANK=0 S RANK=9999
25 .. S FREQDAY=$$FRQINDAY^PXRMDATE($P(TEMP,U,4))
26 ..;If there is no frequency with this rank ignore it.
27 .. I FREQDAY]"" S RANKAR(RANK,FREQDAY,FINDING)=""
28 ;If there was a ranking use it otherwise use the greatest frequency.
29 I '$D(RANKAR) G ACHK
30 S RANK=0
31 S RANK=+$O(RANKAR(RANK))
32 S FREQDAY=+$O(RANKAR(RANK,""))
33 S FINDING=$O(RANKAR(RANK,FREQDAY,""))
34 I FINDING'="" D
35 . S NODE=$S(FINDING["FF":25,1:20)
36 . S TEMP=DEFARR(NODE,FINDING,0)
37 . S FREQ=$P(TEMP,U,4)
38 . S MINAGE=$P(TEMP,U,2)
39 . S MAXAGE=$P(TEMP,U,3)
40 .;Remove the baseline age findings since they have been overridden.
41 . K FIEVAL("AGE")
42ACHK ;
43 I FREQ="" D
44 . S AGEFI=0
45 . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","NOFREQ")="There is no reminder frequency!"
46 E D
47 .;Save the final frequency and age range for display.
48 .;Use the z so this will be the last of the info text.
49 . S ^TMP(PXRMPID,$J,PXRMITEM,"zFREQARNG")=FREQ_U_MINAGE_U_MAXAGE
50 . S AGEFI=$S(FREQ=-1:0,1:$$AGECHECK^PXRMAGE(PXRMPDEM("AGE"),MINAGE,MAXAGE))
51 S FIEVAL("AGE")=AGEFI
52 ;
53 ;Evaluate the patient cohort logic
54EVAL ;
55 N AGE,DPCLOG,FI,FF,FUN,FUNCTION,FUNLIST,NUM,SEX,VAR
56 S TEMP=DEFARR(32)
57 S NUM=+$P(TEMP,U,1)
58 S (PCLOG,PCLSTR)=DEFARR(31)
59 S FLIST=$P(TEMP,U,2)
60 F IND=1:1:NUM D
61 . S FINDING=$P(FLIST,";",IND)
62 . I FINDING="AGE" S AGE=+$G(FIEVAL("AGE"))
63 . I FINDING="SEX" S SEX=+$G(FIEVAL("SEX"))
64 . I FINDING["FF" S TEMP=$P(FINDING,"FF",2),FF(TEMP)=FIEVAL(FINDING)
65 . E S FI(FINDING)=FIEVAL(FINDING)
66 I @PCLOG
67 S TEST=$T
68 I 'AGEFI,PCLSTR["AGE" D
69 . S ^TMP(PXRMPID,$J,PXRMITEM,"N/A","AGE")=""
70 . S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","AGE")="Patient does not meet any age criteria!"
71 ;Reminders are always N/A for dead patients unless PXRMIDOD is true in which case
72 ;the regular cohort logic applies.
73 I '$G(PXRMIDOD),PXRMPDEM("DOD")'="" S TEST=0
74 S PCLOGIC=TEST_U_PCLSTR
75 I 'TEST S ^TMP(PXRMPID,$J,PXRMITEM,"N/A","COHORT")=""
76 I $G(PXRMDEBG) D
77 . S DPCLOG=PCLOG
78 . F IND=1:1:NUM D
79 .. S FINDING=$P(FLIST,";",IND)
80 .. I FINDING="AGE" S DPCLOG=$$STRREP^PXRMUTIL(DPCLOG,"AGE",+$G(FIEVAL(FINDING))) Q
81 .. I FINDING="SEX" S DPCLOG=$$STRREP^PXRMUTIL(DPCLOG,"SEX",+$G(FIEVAL(FINDING))) Q
82 .. S TEMP=$S(FINDING["FF":"FF("_$P(FINDING,"FF",2)_")",1:"FI("_FINDING_")")
83 .. S DPCLOG=$$STRREP^PXRMUTIL(DPCLOG,TEMP,FIEVAL(FINDING))
84 S PCLOGIC=PCLOGIC_U_$G(DPCLOG)
85 I $G(PXRMDEBG) S ^TMP(PXRMPID,$J,PXRMITEM,"PATIENT COHORT LOGIC")=PCLOGIC
86 Q
87 ;
88 ;==========================================================
89EVALRESL(DEFARR,RESDATE,RESLOGIC,FIEVAL) ;Evaluate the
90 ;Resolution Logic.
91 N DRESLOG,IND,FF,FI,FINDING,FLIST,NUM,RESLOG,RESLSTR,TEMP,TEST
92 S TEMP=DEFARR(36)
93 S NUM=+$P(TEMP,U,1)
94 I NUM=0 Q
95 S (RESLOG,RESLSTR)=DEFARR(35)
96 S FLIST=$P(TEMP,U,2)
97 F IND=1:1:NUM D
98 . S FINDING=$P(FLIST,";",IND)
99 .;Check for contraindicated in a resolution finding
100 . I $G(FIEVAL(FINDING,"CONTRAINDICATED")) S FIEVAL("CONTRAINDICATED")=1
101 . I FINDING["FF" S TEMP=$P(FINDING,"FF",2),FF(TEMP)=FIEVAL(FINDING)
102 . E S FI(FINDING)=FIEVAL(FINDING)
103 I @RESLOG
104 S TEST=$T
105 I $G(PXRMDEBG) D
106 . S DRESLOG=RESLOG
107 . F IND=1:1:NUM D
108 .. S FINDING=$P(FLIST,";",IND)
109 .. S TEMP=$S(FINDING["FF":"FF("_$P(FINDING,"FF",2)_")",1:"FI("_FINDING_")")
110 .. S DRESLOG=$$STRREP^PXRMUTIL(DRESLOG,TEMP,FIEVAL(FINDING))
111 S RESLOGIC=TEST_U_RESLSTR_U_$G(DRESLOG)
112 I $G(PXRMDEBG) S ^TMP(PXRMPID,$J,PXRMITEM,"RESOLUTION LOGIC")=RESLOGIC
113 S RESDATE=$S(TEST=1:$$RESDATE(RESLSTR,.FIEVAL),1:0)
114 Q
115 ;
116 ;==========================================================
117LOGOP(DT1,DT2,LOP) ;Given two dates return the most recent if the logical
118 ;operator is ! and the oldest if it is &. True FFs which don't have
119 ;a date are flagged with date of -1.
120 I DT1=0,DT2=0 Q 0
121 I DT1=-1,DT2=-1 Q -1
122 N VALUE
123 I LOP="&" D Q VALUE
124 . I DT1=-1 S VALUE=DT2 Q
125 . I DT2=-1 S VALUE=DT1 Q
126 . I DT1=0 S VALUE=DT2 Q
127 . I DT2=0 S VALUE=DT1 Q
128 . S VALUE=$S(DT1>DT2:DT2,1:DT1)
129 I LOP'="!" Q 0
130 I DT1=-1 Q $S(DT2>0:DT2,1:-1)
131 I DT2=-1 Q $S(DT1>0:DT1,1:-1)
132 Q $S(DT1>DT2:DT1,1:DT2)
133 ;
134 ;==========================================================
135RESDATE(RESLSTR,FIEVAL) ;Return the resolution date based on the following
136 ;rules:
137 ; Dates that are ORed use the most recent.
138 ; Dates that are ANDed use the oldest.
139 ;This is only evaluated if the resolution logic is true.
140 N DATE,DSTRING,DT1,DT2,DT3,FFI,IND,INDEX,JND
141 N OPER,PFSTACK,STACK,TEMP
142 ;Remove leading (n) entries.
143 I ($E(RESLSTR,1,4)="(0)!")!($E(RESLSTR,1,4)="(1)&") S $E(RESLSTR,1,4)=""
144 ;The NOT operator is not relevant for the date calculation so remove
145 ;any NOTs.
146 S DSTRING=$TR(RESLSTR,"'","")
147 ;Replace true findings with their dates. This includes false findings
148 ;that are notted in the logic.
149 S OPER="!&"
150 D POSTFIX^PXRMSTAC(DSTRING,OPER,.PFSTACK)
151 S JND=0
152 F IND=1:1:PFSTACK(0) D
153 . S TEMP=PFSTACK(IND)
154 . I TEMP="FI" D Q
155 .. S IND=IND+1,INDEX=PFSTACK(IND)
156 .. S DATE=$S(FIEVAL(INDEX)=1:FIEVAL(INDEX,"DATE"),1:0)
157 .. S JND=JND+1,STACK(JND)=DATE
158 . I TEMP="FF" D Q
159 .. S IND=IND+1,INDEX=PFSTACK(IND)
160 .. S FFI="FF"_INDEX
161 ..;FFs do not have dates, flag with -1.
162 .. S DATE=-1
163 .. S JND=JND+1,STACK(JND)=DATE
164 . I OPER[TEMP S JND=JND+1,STACK(JND)=TEMP
165 S STACK(0)=JND
166 K PFSTACK
167 S PFSTACK(0)=0
168 F IND=1:1:STACK(0) D
169 . S TEMP=STACK(IND)
170 . I OPER[TEMP D
171 ..;Pop the top two elements on the stack and do the operation.
172 .. S DT1=$$POP^PXRMSTAC(.PFSTACK)
173 .. S DT2=$$POP^PXRMSTAC(.PFSTACK)
174 .. S DT3=$$LOGOP(DT1,DT2,TEMP)
175 ..;Save the result back on the stack
176 .. D PUSH^PXRMSTAC(.PFSTACK,DT3)
177 . E D PUSH^PXRMSTAC(.PFSTACK,TEMP)
178 ;The result is the only thing left on the stack.
179 Q $$POP^PXRMSTAC(.PFSTACK)
180 ;
181 ;==========================================================
182SEX(DEFARR,SEX) ;Return FALSE (0) if the patient is the wrong sex for
183 ; the reminder, TRUE (1) is the patient is the right sex.
184 N REMSEX
185 S REMSEX=$P(DEFARR(0),U,9)
186 I REMSEX="" Q 1
187 I SEX=REMSEX Q 1
188 S ^TMP(PXRMPID,$J,PXRMITEM,"N/A","SEX")=""
189 S ^TMP(PXRMPID,$J,PXRMITEM,"INFO","SEX")="Patient is the wrong sex!"
190 Q 0
191 ;
192 ;==========================================================
193VALID(LOGSTR,DA,MINLEN,MAXLEN) ;Make sure that LOGSTR is a valid logic string.
194 ;This is called by the input transform for PATIENT COHORT LOGIC and
195 ;RESOLUTION LOGIC. Return 1 if LOGSTR is ok.
196 ;Don't do this if this is being called as a result of an install
197 ;through the Exchange Utility.
198 I $G(PXRMEXCH) Q 1
199 I LOGSTR="" Q 0
200 ;
201 ;Check the length.
202 N LEN
203 S LEN=$L(LOGSTR)
204 I (LEN<MINLEN)!(LEN>MAXLEN) Q 0
205 ;
206 ;Use the FileMan code validator to check the code.
207 N TEST,X
208 S X="S Y="_$TR(LOGSTR,";","")
209 D ^DIM
210 I $D(X)=0 D Q 0
211 . S TEXT(1)="LOGIC string: "_LOGSTR
212 . S TEXT(2)="contains invalid MUMPS code!"
213 . D EN^DDIOL(.TEXT)
214 ;
215 N ELE1,ELE2,MNUM,SEP,STACK,TEXT,TSTSTR,VALID
216 ;Make sure the entries in LOGSTR are valid elements or functions.
217 S TSTSTR=LOGSTR
218 S TSTSTR=$TR(TSTSTR,"'","")
219 S TSTSTR=$TR(TSTSTR,"&",U)
220 S TSTSTR=$TR(TSTSTR,"!",U)
221 ;Set the allowable logic separators.
222 S SEP="^,<>="
223 ;Convert the string to postfix form for evaluation.
224 D POSTFIX^PXRMSTAC(TSTSTR,SEP,.STACK)
225 S (ELE1,VALID)=1
226 F Q:(ELE1="")!(VALID=0) D
227 . S ELE1=$$POP^PXRMSTAC(.STACK)
228 . I SEP[ELE1 Q
229 .;If the element is FI or FF then the next element should be a number.
230 . S MNUM=$S(ELE1="FI":20,ELE1="FF":25,1:"")
231 . I MNUM'="" D
232 .. S ELE2=$$POP^PXRMSTAC(.STACK)
233 .. I ELE2'=+ELE2 S VALID=0
234 .. I VALID S VALID=$D(^PXD(811.9,DA,MNUM,ELE2))
235 .. I 'VALID D
236 ... S TEXT=ELE1_"("_ELE2_") is not in this definition!"
237 ... D EN^DDIOL(TEXT)
238 Q VALID
239 ;
240 ;==========================================================
241VALIDR(LOGSTR,DA,MINLEN,MAXLEN) ;Make sure that LOGSTR is a valid resolution
242 ;logic string. This is called by the input transform for RESOLUTION
243 ;LOGIC. Return 1 if LOGSTR is ok.
244 ;Don't do this if this is being called as a result of an install
245 ;through the Exchange Utility.
246 I $G(PXRMEXCH) Q 1
247 I LOGSTR="" Q 0
248 N TEXT
249 ;The resolution logic cannot contain SEX or AGE.
250 I LOGSTR["AGE" D Q 0
251 . S TEXT="The resolution logic cannot contain AGE!"
252 . D EN^DDIOL(TEXT)
253 I LOGSTR["SEX" D Q 0
254 . S TEXT="The resolution logic cannot contain SEX!"
255 . D EN^DDIOL(TEXT)
256 ;Now call the regular logic string validator.
257 Q $$VALID(LOGSTR,DA,MINLEN,MAXLEN)
258 ;
Note: See TracBrowser for help on using the repository browser.