source: WorldVistAEHR/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m@ 846

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

revised back to 6/30/08 version
File size: 9.1 KB
RevLine 
[623]1PXRMRULE ; SLC/PJH - Build Patient list from Rule Set ;08/11/2006
2 ;;2.0;CLINICAL REMINDERS;**4**;Feb 04, 2005;Build 21
3 ;
4 ; Called from PXRM PATIENT LIST CREATE protocol
5 ;
6ASK(PLIEN,OPT) ;Verify patient list name
7 N X,Y,TEXT
8 K DIROUT,DIRUT,DTOUT,DUOUT
9 S DIR(0)="YA0"
10 S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
11 S DIR("B")="N"
12 S DIR("?")="Enter Y or N. For detailed help type ??"
13 W !
14 D ^DIR K DIR
15 I $D(DIROUT) S DTOUT=1
16 I $D(DTOUT)!($D(DUOUT)) Q
17 I $E(Y(0))="N" S DUOUT=1 Q
18 Q
19 ;
20CLEAR(RULE,NODE) ;Clear workfile entries
21 N SEQ
22 S SEQ=""
23 F S SEQ=$O(^PXRM(810.4,RULE,30,"B",SEQ)) Q:'SEQ D
24 .K ^TMP($J,NODE_SEQ)
25 ;clear FDA array
26 K ^TMP($J,"PXRMFDA")
27 Q
28 ;
29COPY(IENO) ;Copy patient list
30 ;Check if OK to copy
31 D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
32 N FDA,IENN,IND,MSG,NNAME,ODATA,OEPIEN,ONAME,ORULE,PATCREAT,TEXT,X,Y
33 ;Select list to copy to
34 S TEXT="Select PATIENT LIST name to copy to: "
35 D PLIST^PXRMLCR(.IENN,TEXT,IENO) Q:$D(DUOUT)!$D(DTOUT) Q:'IENN
36 S NNAME=$P($G(^PXRMXP(810.5,IENN,0)),U)
37 ;
38 ;Get original Patient List record
39 S ODATA=$G(^PXRMXP(810.5,IENO,0))
40 S ONAME=$P(ODATA,U),OEPIEN=$P(ODATA,U,5),ORULE=$P(ODATA,U,6)
41 ;
42 M ^PXRMXP(810.5,IENN)=^PXRMXP(810.5,IENO)
43 D ASK^PXRMXD(.PATCREAT,"Secure list?: ",2)
44 ;Update header info
45 S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
46 S IND=IENN_","
47 S FDA(810.5,IND,.01)=NNAME
48 S FDA(810.5,IND,.04)=$$NOW^XLFDT
49 S FDA(810.5,IND,.05)=OEPIEN
50 S FDA(810.5,IND,.06)=ORULE
51 S FDA(810.5,IND,.07)=$G(DUZ)
52 S FDA(810.5,IND,.08)=TYPE
53 D UPDATE^DIE("","FDA","","MSG")
54 ;Error
55 I $D(MSG) D ERR
56 ;
57 W !!,"Completed copy of '"_ONAME_"'"
58 W !,"into '"_NNAME_"'",! H 2
59 K ^TMP($J,"PXRMRULE")
60 Q
61 ;
62CRLST(NAME,CLASS) ;Create new patient list
63 N IEN
64 ;Check if name exists
65 S IEN=$O(^PXRMXP(810.5,"B",NAME,"")) I IEN Q IEN
66 ;Otherwise create national entry
67 N FDA,FDAIEN,MSG
68 S FDA(810.5,"+1,",.01)=NAME
69 S FDA(810.5,"+1,",100)=CLASS
70 D UPDATE^DIE("","FDA","FDAIEN","MSG")
71 ;Error
72 I $D(MSG) Q 0
73 ;Otherwise list ien
74 Q FDAIEN(1)
75 ;
76DELETE(LIST) ;Delete Patient list
77 I '$$VEDIT^PXRMUTIL("^PXRMXP(810.5,",LIST) D Q
78 .W !!,?5,"VA- and national class patient lists may not be deleted" H 2
79 .S DUOUT=1
80 ;Check if this is the right list
81 D ASK(LIST,"Delete") Q:$D(DUOUT)!$D(DTOUT)
82 ;
83 N DA,DIK,DUOUT
84 ;Lock patient list
85 D LOCK Q:$D(DUOUT)
86 ;Kill List
87 S DA=LIST,DIK="^PXRMXP(810.5,"
88 D ^DIK
89 ;Unlock patient list
90 D UNLOCK
91 Q
92 ;
93ERR ;Error Handler
94 N ERROR,IC,REF
95 S ERROR(1)="Unable to build patient list : "
96 S ERROR(2)=NAME
97 S ERROR(3)="Error in UPDATE^DIE, needs further investigation"
98 ; Move MSG into Error
99 S REF="MSG"
100 F IC=4:1 S REF=$Q(@REF) Q:REF="" S ERROR(IC)=REF_"="_@REF
101 ;Screen message
102 D EN^DDIOL(.ERROR)
103 Q
104 ;
105INTR ;Input transform for #810.4 fields
106 Q
107 ;
108LOAD(NODE,LIEN) ;Load Patient List
109 N DATA,DFN,SUB
110 S SUB=0
111 F S SUB=$O(^PXRMXP(810.5,LIEN,30,SUB)) Q:'SUB D
112 .S DATA=$G(^PXRMXP(810.5,LIEN,30,SUB,0)),DFN=$P(DATA,U) Q:'DFN
113 .;Store the patient IEN and institution in ^TMP
114 .S ^TMP($J,NODE,DFN)=$P(DATA,U,2)_U_$P($G(DATA),U,3)_U_$P($G(DATA),U,4)
115 Q
116 ;
117LOCK L +^PXRMXP(810.5,LIST):0
118 E W !!?5,"Another user is using this patient list" S DUOUT=1
119 Q
120 ;
121PATS(LIST) ;Process Patient List finding rule
122 ;
123 N LIEN,LUVALUE
124 ;Insert year and period into extract list name
125 I YEAR]"",LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2)
126 I PERIOD]"",LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2)
127 ;
128 S LUVALUE(1)=LIST
129 S LIEN=+$$FIND1^DIC(810.5,"","KUX",.LUVALUE) Q:'LIEN
130 ;
131 ;Add operation Load list
132 I FRACT="A" D LOAD(FROUT,LIEN) Q
133 ;
134 ;Remove, Select or Add Findings operations
135 I FRACT'="A" D Q
136 .;Load List
137 .D LOAD(PNODE,LIEN)
138 .;Check each patient
139 .S DFN=0
140 .F S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN D
141 ..;Delete any ^TMP patient in PLIST if action is remove
142 ..I FRACT="R",$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN) Q
143 ..;Delete any ^TMP patient not in PLIST if action is select
144 ..I FRACT="S",'$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN)
145 Q
146 ;
147START(RULESET,LIST,NODE,LBBDT,LBEDT,PAR,YEAR,PERIOD,INDP,INTP) ;
148 ;Process rule set
149 ;Clear ^TMP
150 D CLEAR(RULESET,NODE)
151 ;
152 N CLASS,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
153 N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE
154 N RBDT,REDT,RRIEN,RSDATA,RSDATES,SEQ,SUB
155 ;Get class from extract parameter
156 I PAR S CLASS=$P($G(^PXRM(810.2,PAR,100)),U)
157 ;Otherwise default to local
158 I $G(CLASS)="" S CLASS="L"
159 ;Get each finding rule in sequence
160 S SEQ="",INC=0
161 F S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ D
162 .;Save first sequence as default
163 .I INC=0 S INC=1,FSEQ=SEQ
164 .S SUB=$O(^PXRM(810.4,RULESET,30,"B",SEQ,"")) Q:'SUB
165 .S RSDATA=$G(^PXRM(810.4,RULESET,30,SUB,0)) Q:RSDATA=""
166 .S RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1))
167 .;Finding rule ien and action
168 .S FRIEN=$P(RSDATA,U,2),FRACT=$P(RSDATA,U,3) Q:'FRIEN Q:FRACT=""
169 .;Check if entry is a finding rule (not a set or reminder rule)
170 .S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3
171 .S FRDATES=$P(FRDATA,U,4,5)
172 .;Get term IEN for finding rule
173 .I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN
174 .;Get Reminder definition IEN for Reminder rule
175 .I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN
176 .;Get Extract Patient List name for patient list rule
177 .I FRTYP=5 S FRLST=$P($G(^PXRM(810.4,FRIEN,1)),U) D Q:FRLST=""
178 ..S FROLST=$P(FRDATA,U,8)
179 ..I +FROLST>0 S FRLST=$P($G(^PXRMXP(810.5,FROLST,0)),U)
180 .;Determine RBDT and REDT
181 .D RDATES^PXRMEUT1(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
182 .S PXRMDATE=LBEDT
183 .;Get start sequence or start patient list
184 .S FRSTRT=$P(RSDATA,U,4),FRPAT=$P(RSDATA,U,5)
185 .;If sequence is defined use it
186 .I FRSTRT S FROUT=NODE_FRSTRT
187 .;If neither exist use first as default
188 .I FRSTRT="",FRPAT="" S FROUT=NODE_FSEQ
189 .;If start is patient list load patient list into workfile
190 .I FRSTRT="",FRPAT]"" S FROUT=NODE_SEQ D LOAD(FROUT,FRPAT)
191 .;Name of permanent list
192 .S FRPERM=$P(RSDATA,U,6)
193 .;
194 .;Build patient list in TMP
195 .N DFN,PNODE,TLIST
196 .S PNODE="PXRMEVAL"
197 .K ^TMP($J,PNODE)
198 .;Term finding rules
199 .I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,RBDT,REDT,PNODE,.INST)
200 .;Reminder Definition List Rule
201 .I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,RBDT,REDT,PNODE)
202 .;Patient list finding rules
203 .I FRTYP=5 D PATS(FRLST)
204 .;Clear results file
205 .K ^TMP($J,PNODE)
206 .;
207 .;Build permanent list if required
208 .I FRPERM]"" D
209 ..N FRPIEN
210 ..;Get patient list IEN or create new patient list
211 ..S FRPIEN=$$CRLST(FRPERM,CLASS) Q:'FRPIEN
212 ..;Update patient list
213 ..D UPDLST(FROUT,FRPIEN,PAR,RULESET,INST)
214 ;
215 ;Save final results to patient list
216 I LIST'="",FROUT'="" D
217 . D RMPAT^PXRMEUT(FROUT,INDP,INTP)
218 . D UPDLST(FROUT,LIST,PAR,RULESET,INST)
219 . D DOCUMENT^PXRMEUT(LIST,RULESET,INDP,INTP,LBBDT,LBEDT)
220 Q
221 ;
222UPDLST(NODE,LIST,EPIEN,RULE,INST) ;Update patient list
223 N CNT,DA,DATA,DCNT,DFN,DNAME,DNAMEL,DUE,DUOUT,FDA,INST,INSTNAM,INSTNUM
224 N LAST,MSG,NAME,ONODE,RCNT,RIEN,RNAMEL,RNCNT,SUB,TEMP,TYPE,VALUE
225 ;Lock patient list
226 D LOCK Q:$D(DUOUT)
227 ;
228 ;Clear existing list.
229 K ^PXRMXP(810.5,LIST,30),^PXRMXP(810.5,LIST,35),^PXRMXP(810.5,LIST,45),^PXRMXP(810.5,LIST,200)
230 S NAME=$P($G(^PXRMXP(810.5,LIST,0)),U)
231 ;
232 ;Merge ^TMP into Patient List
233 S (CNT,DFN,INST)=0
234 F S DFN=$O(^TMP($J,NODE,DFN)) Q:'DFN D
235 .S ONODE=$G(^TMP($J,NODE,DFN,"INST"))
236 .S INSTNUM=$P(ONODE,U,1),INSTNAM=$P(ONODE,U,2)
237 .S CNT=CNT+1,^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM
238 .S ^PXRMXP(810.5,LIST,30,"B",DFN,CNT)=""
239 .;
240 .;Save the reminder evaluation information only from Reports
241 .I $D(^TMP($J,NODE,DFN,"REM"))>0 D
242 ..S (RIEN,RCNT,RNCNT)=0
243 ..F S RIEN=$O(^TMP($J,NODE,DFN,"REM",RIEN)) Q:RIEN'>0 D
244 ...S RNAMEL(RIEN)=""
245 ...S VALUE=^TMP($J,NODE,DFN,"REM",RIEN)
246 ...S RCNT=RCNT+1
247 ...S ^PXRMXP(810.5,LIST,30,CNT,"REM",RCNT,0)=VALUE
248 ...S ^PXRMXP(810.5,LIST,30,CNT,"REM","B",RIEN,RCNT)=""
249 ..S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.532A"_U_RCNT_U_RCNT
250 .;
251 .I '$D(^TMP($J,NODE,DFN,"DATA")) Q
252 .S DCNT=0,DNAME=""
253 .F S DNAME=$O(^TMP($J,NODE,DFN,"DATA",DNAME)) Q:DNAME="" D
254 ..S DNAMEL(DNAME)=""
255 ..S VALUE=^TMP($J,NODE,DFN,"DATA",DNAME)
256 ..S DCNT=DCNT+1
257 ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA",DCNT,0)=DNAME_U_VALUE
258 ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA","B",DNAME,DCNT)=""
259 .S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.531A"_U_DCNT_U_DCNT
260 S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
261 ;
262 ;Save the reminder information
263 S RNCNT=0,RIEN=0
264 F S RIEN=$O(RNAMEL(RIEN)) Q:RIEN'>0 D
265 .S RNCNT=RNCNT+1
266 .S ^PXRMXP(810.5,LIST,45,RCNT,0)=RIEN
267 .S ^PXRMXP(810.5,LIST,45,"B",RIEN,RNCNT)=""
268 I RNCNT>0 S ^PXRMXP(810.5,LIST,45,0)=U_"810.545P"_U_RNCNT_U_RNCNT
269 ;
270 ;Save the data types.
271 S DCNT=0,DNAME=""
272 F S DNAME=$O(DNAMEL(DNAME)) Q:DNAME="" D
273 .S DCNT=DCNT+1
274 .S ^PXRMXP(810.5,LIST,35,DCNT,0)=DNAME
275 .S ^PXRMXP(810.5,LIST,35,"B",DNAME,DCNT)=""
276 I DCNT>0 S ^PXRMXP(810.5,LIST,35,0)=U_"810.535A"_U_DCNT_U_DCNT
277 S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
278 ;
279 ;Update header info
280 S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
281 K PATCREAT
282 S FDA(810.5,"?+1,",.01)=NAME
283 S FDA(810.5,"?+1,",.04)=$$NOW^XLFDT
284 S FDA(810.5,"?+1,",.05)=EPIEN
285 S FDA(810.5,"?+1,",.06)=RULE
286 S FDA(810.5,"?+1,",.07)=$G(DUZ)
287 S FDA(810.5,"?+1,",.08)=TYPE
288 I $G(INST)=1 S FDA(810.5,"?+1,",.1)=1
289 S FDA(810.5,"?+1,",50)=$S($G(PLISTPUG)="Y":1,1:0)
290 D UPDATE^DIE("","FDA","","MSG")
291 ;Error
292 I $D(MSG) D ERR
293 ;Unlock patient list
294 D UNLOCK
295 Q
296 ;
297UNLOCK L -^PXRMXP(810.5,LIST) Q
298 ;
Note: See TracBrowser for help on using the repository browser.