source: FOIAVistA/tag/r/CLINICAL_REMINDERS-PXRM/PXRMPLST.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 8.5 KB
Line 
1PXRMPLST ; SLC/PKR - Build a patient list from a reminder definition. ;06/09/2006
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4 ;Input : RIEN - Reminder IEN
5 ; PLIST - List returned in ^TMP($J,PLIST,DFN)
6 ; DFNONLY - If true list contains only DFN information
7 ; PXRMDATE - Evaluation date
8 ;===================================================
9BLDPLST(RIEN,PLIST,DFNONLY,PXRMDATE) ;
10 N DEFARR,DFN,DOBE,DOBS,ELE,ERROR,ERRSTR,IND,FNUM
11 N LIST1,LIST2,LNAME,LSP,LSTACK
12 N NDR,NOT,OPER,PCLOG,PFSTACK,SEX,TYPE
13 ;
14 D DEF^PXRMLDR(RIEN,.DEFARR)
15 ;Get the cohort logic string. This has passed a validation before
16 ;it can be selected for building patient lists so we don't need to
17 ;check it here.
18 S PCLOG=DEFARR(31)
19 I PCLOG="" Q
20 S OPER="!&~"
21 ;Get the sex field, if PCLOG does not contain SEX set it to null.
22 S SEX=$S(PCLOG["SEX":$P(DEFARR(0),U,9),1:"")
23 ;If PCLOG contains age build the corresponding date of birth range(s).
24 I PCLOG["AGE" D DOBR(.DEFARR,.NDR,.DOBS,.DOBE)
25 ;Replace &' with ~ so the stack will be built properly.
26 S PCLOG=$$STRREP^PXRMUTIL(PCLOG,"&'","~")
27 D POSTFIX^PXRMSTAC(PCLOG,OPER,.PFSTACK)
28 ;Process the logic.
29 D CFSAA(.PFSTACK)
30 S (IND,ERROR,LSP,LSTACK(0),NOT)=0
31 F Q:(IND'<PFSTACK(0))!(ERROR) D
32 . S IND=IND+1,ELE=PFSTACK(IND)
33 . I ELE["'" S NOT=1
34 . S TYPE=$S(ELE="'":"NOT",ELE["AGE":"A",ELE["FI":"FI",ELE["FF":"FF",ELE="SAA":"SAA",ELE["SEX":"S",OPER[ELE:"OP",1:"")
35 .;
36 . I TYPE="A" D Q
37 .. S LNAME="LIST"_IND
38 .. D LSA("",NDR,.DOBS,.DOBE,LNAME)
39 .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
40 .. D AGEFI(.DEFARR,LNAME,SEX,"")
41 .;
42 . I TYPE="FI" D Q
43 .. S IND=IND+1,FNUM=PFSTACK(IND)
44 .. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a finding not followed by a number" Q
45 .. S LNAME="LIST"_IND
46 .. D EVALPL^PXRMEVFI(.DEFARR,FNUM,LNAME)
47 .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
48 .;
49 . I TYPE="FF" D Q
50 .. S IND=IND+1,FNUM=PFSTACK(IND)
51 .. I +FNUM'=FNUM S ERROR=1,ERRSTR="Error - having a function finding not followed by a number"
52 .. S LNAME="LIST"_IND
53 .. D EVALPL^PXRMFF(.DEFARR,"FF"_FNUM,LNAME)
54 .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
55 .;
56 . I TYPE="NOT" S NOT=1 Q
57 .;
58 . I TYPE="OP" D Q
59 .. S LIST2=$$POP^PXRMSTAC(.LSTACK)
60 .. S LIST1=$$POP^PXRMSTAC(.LSTACK)
61 .. I NOT S ELE=ELE_"'",NOT=0
62 .. D LOGOP(LIST1,LIST2,ELE)
63 .. D PUSH^PXRMSTAC(.LSTACK,LIST1)
64 .. K ^TMP($J,LIST2)
65 .;
66 . I TYPE="S" D Q
67 .. S LNAME="LIST"_IND
68 .. D LSEX(SEX,LNAME,.LSTACK)
69 .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
70 .;
71 . I TYPE="SAA" D Q
72 .. S LNAME="LIST"_IND
73 .. D LSA(SEX,NDR,.DOBS,.DOBE,LNAME)
74 .. D PUSH^PXRMSTAC(.LSTACK,LNAME)
75 .. D AGEFI(.DEFARR,LNAME,SEX,"")
76 .;
77 S LIST1=$$POP^PXRMSTAC(.LSTACK)
78 ;If AGE is not in the cohort logic look for any findings that set the
79 ;frequency to 0Y and therefore remove the patient from the cohort.
80 I PCLOG'["AGE" D AGEFI(.DEFARR,LIST1,"","0Y")
81 ;
82 I $G(DFNONLY) D
83 . S DFN=0
84 . F S DFN=$O(^TMP($J,LIST1,1,DFN)) Q:DFN="" D
85 .. S ^TMP($J,PLIST,DFN)=""
86 E M ^TMP($J,PLIST)=^TMP($J,LIST1)
87 K ^TMP($J,LIST1)
88 Q
89 ;
90 ;==================================================
91AGEFI(DEFARR,LNAME,SEX,ONLYFREQ) ;Check for patients that need to be
92 ;added or removed because of a finding that changes the age range.
93 N DEL,DFN,DOB,DOBE,DOBS,FILIST,FINUM,FREQ,IND,JND,LOGOP
94 N MINAGE,MAXAGE,NUMAFI,PSEX,RANK,RANKARR,RF,TEMP,TGLIST
95 S NUMAFI=$P(DEFARR(40),U,1)
96 I NUMAFI=0 Q
97 S FILIST=$P(DEFARR(40),U,2)
98 F IND=1:1:NUMAFI D
99 . S FINUM=$P(FILIST,";",IND)
100 . S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0))
101 . S RANK=+$P(TEMP,U,5)
102 . I RANK=0 S RANK=9999
103 . S FREQ=$$FRQINDAY^PXRMDATE($P(TEMP,U,4))
104 .;If there is no frequency with this rank ignore it.
105 . I FREQ]"" S RANKARR(RANK,FREQ,FINUM)=""
106 S IND=0,RANK=""
107 F S RANK=$O(RANKARR(RANK)) Q:RANK="" D
108 . S FREQ=""
109 . F S FREQ=$O(RANKARR(RANK,FREQ)) Q:FREQ="" D
110 .. S FINUM=0
111 .. F S FINUM=$O(RANKARR(RANK,FREQ,FINUM)) Q:FINUM="" D
112 ... S IND=IND+1,RF(IND)=FINUM
113 I IND'=NUMAFI W !,"Error in AGEFI^PXRMPLST - Ranking failed!"
114 ;Build a list for each age finding.
115 F IND=1:1:NUMAFI D
116 . S FINUM=RF(IND)
117 . S TGLIST="AGEFI"_FINUM
118 . S TEMP=$S(FINUM["FF":DEFARR(25,FINUM,0),1:DEFARR(20,FINUM,0))
119 . S FREQ=$P(TEMP,U,4)
120 . I ONLYFREQ="0Y",FREQ'="0Y" S LOGOP(IND)="~" Q
121 . S LOGOP(IND)=$S(FREQ="0Y":"~",FREQ="":"~",1:"!")
122 . S MINAGE=$P(TEMP,U,2)
123 . S MAXAGE=$P(TEMP,U,3)
124 . S DOBE=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN"))
125 . S DOBS=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX"))
126 . K ^TMP($J,TGLIST)
127 . I FINUM=+FINUM D EVALPL^PXRMEVFI(.DEFARR,FINUM,TGLIST)
128 . I FINUM["FF" D EVALPL^PXRMFF(.DEFARR,FINUM,TGLIST)
129 .;Filter TGLIST based on the age range.
130 . S DFN=$S(FREQ="0Y":$O(^TMP($J,TGLIST,1,""),-1),1:0)
131 . F S DFN=$O(^TMP($J,TGLIST,1,DFN)) Q:DFN="" D
132 .. S DEL=0
133 ..;Reference to ^DPT DBIA #10035
134 .. S PSEX=$P(^DPT(DFN,0),U,2),DOB=$P(^DPT(DFN,0),U,3)
135 .. I SEX'="",PSEX'=SEX S DEL=1
136 .. I (DOB<DOBS)!(DOB>DOBE) S DEL=1
137 .. I DEL K ^TMP($J,TGLIST,0,DFN),^TMP($J,TGLIST,1,DFN)
138 ;Remove patients on a list with a higher rank from all lists with
139 ;a lower rank.
140 F IND=1:1:NUMAFI D
141 . F JND=IND+1:1:NUMAFI D LOGOP("AGEFI"_RF(JND),"AGEFI"_RF(IND),"~")
142 F IND=1:1:NUMAFI D
143 . D LOGOP(LNAME,"AGEFI"_RF(IND),LOGOP(IND))
144 . K ^TMP($J,"AGEFI"_RF(IND))
145 Q
146 ;
147 ;==================================================
148CFSAA(STACK) ;Check for the first three elements on the stack being
149 ;SEX, AGE, and &. If that is the case replace the with the "special"
150 ;finding SAA.
151 N EL1,EL2,EL3,SAA
152 S SAA=0
153 S EL1=$G(STACK(1)),EL2=$G(STACK(2)),EL3=$G(STACK(3))
154 I EL1="SEX",EL2="AGE",EL3="&" S SAA=1
155 I EL1="AGE",EL2="SEX",EL3="&" S SAA=1
156 I 'SAA Q
157 ;Create a new pseudo-element for SEX&AGE.
158 S EL1=$$POP^PXRMSTAC(.STACK)
159 S EL1=$$POP^PXRMSTAC(.STACK)
160 S EL1=$$POP^PXRMSTAC(.STACK)
161 D PUSH^PXRMSTAC(.STACK,"SAA")
162 Q
163 ;
164 ;==================================================
165DOBR(DEFARR,NDR,DOBS,DOBE) ;Build the date of birth range.
166 N IND,FREQ,MINAGE,MAXAGE,TEMP
167 S (IND,NDR)=0
168 F S IND=+$O(DEFARR(7,IND)) Q:IND=0 D
169 . S TEMP=DEFARR(7,IND,0)
170 . S FREQ=$P(TEMP,U,1)
171 . I (FREQ="0Y")!(FREQ="") Q
172 . S MINAGE=$P(TEMP,U,2)
173 . S MAXAGE=$P(TEMP,U,3)
174 . S NDR=NDR+1
175 . S DOBE(NDR)=$S(MINAGE="":$$NOW^PXRMDATE,1:$$GETDOB(MINAGE,"MIN"))
176 . S DOBS(NDR)=$S(MAXAGE="":0,1:$$GETDOB(MAXAGE,"MAX"))
177 Q
178 ;
179 ;==================================================
180GENTERM(FINDING,FINUM,TERMARR) ;Given a reminder finding generate a term
181 ;for patient list evaluation.
182 N IEN,IND,TEMP,TYPE
183 S TEMP=$P(FINDING,U,1)
184 S IEN=$P(TEMP,";",1)
185 S TYPE=$P(TEMP,";",2)
186 ;If the finding is a term just load the term.
187 I TYPE="PXRMD(811.5," D TERM^PXRMLDR(IEN,.TERMARR) Q
188 S TERMARR(0)="GENERATED"
189 S TERMARR("IEN")=0
190 M TERMARR(20,1)=DEFARR(20,FINUM)
191 S TERMARR("E",TYPE,IEN,1)=""
192 Q
193 ;
194 ;==================================================
195GETDOB(AGE,TYPE) ;Given an age in years return the corresponding date of
196 ;birth. If TYPE is MIN then find the date of birth that will make them
197 ;that age. If TYPE is MAX find the last day that will make them
198 ;that age, i.e., the next day is their birthday.
199 N DATE,DOB
200 S DATE=$$NOW^PXRMDATE
201 I TYPE="MIN" S DOB=DATE-(10000*AGE)
202 I TYPE="MAX" S DOB=DATE-(10000*(AGE+1)),DOB=$$FMADD^XLFDT(DOB,1)
203 Q DOB
204 ;
205 ;==================================================
206LOGOP(LIST1,LIST2,LOGOP) ;Given LIST1 and LIST2 apply the logical
207 ;operator LOGOP to generate a new list and return it in LIST1
208 N DFN1,DFN2
209 I LOGOP="&" D Q
210 . S DFN1=""
211 . F S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1="" D
212 .. I $D(^TMP($J,LIST2,1,DFN1)) M ^TMP($J,LIST1,1,DFN1)=^TMP($J,LIST2,1,DFN1) Q
213 .. K ^TMP($J,LIST1,1,DFN1)
214 ;
215 ;"~" represents "&'".
216 I LOGOP="~" D Q
217 . S DFN1=""
218 . F S DFN1=$O(^TMP($J,LIST1,1,DFN1)) Q:DFN1="" D
219 .. I $D(^TMP($J,LIST2,1,DFN1)) K ^TMP($J,LIST1,1,DFN1)
220 ;
221 I LOGOP="!" D
222 . S DFN2=""
223 . F S DFN2=$O(^TMP($J,LIST2,1,DFN2)) Q:DFN2="" D
224 .. M ^TMP($J,LIST1,1,DFN2)=^TMP($J,LIST2,1,DFN2)
225 Q
226 ;
227 ;==================================================
228LSA(SEX,NDR,DOBS,DOBE,LNAME) ;Build a list from a SEX & AGE finding.
229 ;Reference to ^DPT DBIA #10035
230 N DFN,DS,IND,SEXOK
231 F IND=1:1:NDR D
232 . S DS=DOBS(IND)-.1
233 . F S DS=$O(^DPT("ADOB",DS)) Q:(DS>DOBE(IND))!(DS="") D
234 .. S DFN=""
235 .. F S DFN=$O(^DPT("ADOB",DS,DFN)) Q:DFN="" D
236 ... S SEXOK=$S(SEX="":1,$D(^DPT("ASX",SEX,DFN)):1,1:0)
237 ... I SEXOK S ^TMP($J,LNAME,1,DFN,1,"SAA")=""
238 Q
239 ;
240 ;==================================================
241LSEX(SEX,LNAME,LSTACK) ;Build a list from a SEX finding.
242 ;Reference to ^DPT DBIA #10035
243 N ELIST
244 ;Start with the existing list to build a list based on sex.
245 S ELIST=$$POP^PXRMSTAC(.LSTACK)
246 D PUSH^PXRMSTAC(.LSTACK,ELIST)
247 S DFN=0
248 F S DFN=$O(^TMP($J,ELIST,1,DFN)) Q:DFN="" D
249 . I $D(^DPT("ASX",SEX,DFN)) S ^TMP($J,LNAME,1,DFN,SEX,1)=""
250 Q
251 ;
Note: See TracBrowser for help on using the repository browser.