source: FOIAVistA/trunk/r/CLINICAL_REMINDERS-PXRM/PXRMRULE.m@ 1801

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

initial load of FOIAVistA 6/30/08 version
File size: 7.3 KB
Line 
1PXRMRULE ; SLC/PJH - Build Patient list from Rule Set ;03/27/2007
2 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
3 ;
4 ; Called from PXRM PATIENT LIST CREATE protocol
5 ;
6CLEAR(RULE,NODE) ;Clear workfile entries
7 N SEQ
8 S SEQ=""
9 F S SEQ=$O(^PXRM(810.4,RULE,30,"B",SEQ)) Q:'SEQ D
10 .K ^TMP($J,NODE_SEQ)
11 ;clear FDA array
12 K ^TMP($J,"PXRMFDA")
13 Q
14 ;
15INTR ;Input transform for #810.4 fields
16 Q
17 ;
18LOAD(NODE,LIEN) ;Load Patient List
19 N DATA,DFN,SUB
20 S SUB=0
21 F S SUB=$O(^PXRMXP(810.5,LIEN,30,SUB)) Q:'SUB D
22 .S DATA=$G(^PXRMXP(810.5,LIEN,30,SUB,0)),DFN=$P(DATA,U) Q:'DFN
23 .;Store the patient IEN and institution in ^TMP
24 .S ^TMP($J,NODE,DFN)=$P(DATA,U,2)_U_$P($G(DATA),U,3)_U_$P($G(DATA),U,4)
25 Q
26 ;
27PATS(FRACT,FROUT,PNODE,LIST) ;Process Patient List finding rule
28 ;
29 N LIEN,LUVALUE
30 ;Insert year and period into extract list name
31 I YEAR]"",LIST["yyyy" S LIST=$P(LIST,"yyyy")_YEAR_$P(LIST,"yyyy",2)
32 I PERIOD]"",LIST["nn" S LIST=$P(LIST,"nn")_$E(PERIOD,2,10)_$P(LIST,"nn",2)
33 ;
34 S LUVALUE(1)=LIST
35 S LIEN=+$$FIND1^DIC(810.5,"","KUX",.LUVALUE) Q:'LIEN
36 ;
37 ;Add operation Load list
38 I FRACT="A" D LOAD(FROUT,LIEN) Q
39 ;
40 ;Remove or Select operations
41 ;Load List
42 D LOAD(PNODE,LIEN)
43 ;Check each patient
44 S DFN=0
45 F S DFN=$O(^TMP($J,FROUT,DFN)) Q:'DFN D
46 .;Delete any ^TMP patient in PLIST if action is remove
47 .I FRACT="R",$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN) Q
48 .;Delete any ^TMP patient not in PLIST if action is select
49 .I FRACT="S",'$D(^TMP($J,PNODE,DFN)) K ^TMP($J,FROUT,DFN)
50 Q
51 ;
52START(RULESET,LIST,NODE,LBBDT,LBEDT,PAR,YEAR,PERIOD,INDP,INTP,EXTITR) ;
53 ;Process rule set
54 ;Clear ^TMP
55 D CLEAR(RULESET,NODE)
56 ;
57 N CLASS,FRACT,FRDATA,FRDATES,FRIEN,FRLST,FRLIEN,FROLST,FROUT,FRPAT
58 N FRPERM,FRSTRT,FRTIEN,FRTYP,FSEQ,INC,INST,PXRMDATE,PXRMDDOC
59 N RBDT,REDT,RRIEN,RSDATA,RSDATES,SEQ,SUB
60 ;Get class from extract parameter
61 I PAR S CLASS=$P($G(^PXRM(810.2,PAR,100)),U)
62 ;Otherwise default to local
63 I $G(CLASS)="" S CLASS="L"
64 ;PXRMDDOC=1 save list rule evaluation dates in ^TMP("PXRMDDOC",$J)
65 S PXRMDDOC=1
66 K ^TMP("PXRMDDOC",$J)
67 ;Get each finding rule in sequence
68 S SEQ="",INC=0,INST=0
69 F S SEQ=$O(^PXRM(810.4,RULESET,30,"B",SEQ)) Q:'SEQ D
70 .;Save first sequence as default
71 .I INC=0 S INC=1,FSEQ=SEQ
72 .S SUB=$O(^PXRM(810.4,RULESET,30,"B",SEQ,"")) Q:'SUB
73 .S RSDATA=$G(^PXRM(810.4,RULESET,30,SUB,0)) Q:RSDATA=""
74 .S RSDATES=$G(^PXRM(810.4,RULESET,30,SUB,1))
75 .;Finding rule ien and action
76 .S FRIEN=$P(RSDATA,U,2),FRACT=$P(RSDATA,U,3) Q:'FRIEN Q:FRACT=""
77 .;Check if entry is a finding rule (not a set or reminder rule)
78 .S FRDATA=$G(^PXRM(810.4,FRIEN,0)),FRTYP=$P(FRDATA,U,3) Q:FRTYP=3
79 .S FRDATES=$P(FRDATA,U,4,5)
80 .;Get term IEN for finding rule
81 .I FRTYP=1 S FRTIEN=$P(FRDATA,U,7) Q:'FRTIEN
82 .;Get Reminder definition IEN for Reminder rule
83 .I FRTYP=2 S RRIEN=$P(FRDATA,U,10) Q:'RRIEN
84 .;Get Extract Patient List name for patient list rule
85 .I FRTYP=5 S FRLST=$P($G(^PXRM(810.4,FRIEN,1)),U) D Q:FRLST=""
86 ..I +EXTITR>0 S FRLST=FRLST_"/"_EXTITR
87 ..S FROLST=$P(FRDATA,U,8)
88 ..I +FROLST>0 S FRLST=$P($G(^PXRMXP(810.5,FROLST,0)),U)
89 .;Determine RBDT and REDT
90 .D RDATES^PXRMEUT1(RSDATES,FRDATES,LBBDT,LBEDT,.RBDT,.REDT)
91 .S PXRMDATE=LBEDT
92 .;Get start sequence or start patient list
93 .S FRSTRT=$P(RSDATA,U,4),FRPAT=$P(RSDATA,U,5)
94 .;If sequence is defined use it
95 .I FRSTRT S FROUT=NODE_FRSTRT
96 .;If neither exist use first as default
97 .I FRSTRT="",FRPAT="" S FROUT=NODE_FSEQ
98 .;If start is patient list load patient list into workfile
99 .I FRSTRT="",FRPAT]"" S FROUT=NODE_SEQ D LOAD(FROUT,FRPAT)
100 .;Name of permanent list
101 .S FRPERM=$P(RSDATA,U,6)
102 .;
103 .;Build patient list in TMP
104 .N DFN,PNODE,TLIST
105 .S PNODE="PXRMEVAL"
106 .K ^TMP($J,PNODE)
107 .;Term finding rules
108 .I FRTYP=1 D TERM^PXRMRUL1(FRACT,FRTIEN,LBBDT,LBEDT,RBDT,REDT,PNODE,.INST)
109 .;Reminder Definition List Rule
110 .I FRTYP=2 D REM^PXRMRUL1(FRACT,RRIEN,LBBDT,LBEDT,RBDT,REDT,PNODE)
111 .;Patient list finding rules
112 .I FRTYP=5 D PATS(FRACT,FROUT,PNODE,FRLST)
113 .;Clear results file
114 .K ^TMP($J,PNODE)
115 .;
116 .;Build permanent list if required
117 .I FRPERM]"" D
118 ..N FRPIEN
119 ..;Get patient list IEN or create new patient list
120 ..S FRPIEN=$$CRLST^PXRMRUL1(FRPERM,CLASS) Q:'FRPIEN
121 ..;Update patient list
122 ..D UPDLST(FROUT,FRPIEN,PAR,RULESET,INST,INDP,INTP)
123 ;
124 ;Save final results to patient list
125 I LIST'="",FROUT'="" D
126 . D RMPAT^PXRMEUT(FROUT,INDP,INTP)
127 . D UPDLST(FROUT,LIST,PAR,RULESET,INST,INDP,INTP)
128 .;PXRMDDOC=2 compare saved dates with those generated in
129 .;DOCUMENT^PXRMEUT.
130 . S PXRMDDOC=2
131 . D DOCUMENT^PXRMEUT(LIST,RULESET,INDP,INTP,LBBDT,LBEDT)
132 K ^TMP("PXRMDDOC",$J)
133 Q
134 ;
135UPDLST(NODE,LIST,EPIEN,RULE,INST,INDP,INTP) ;Update patient list
136 N CNT,DA,DATA,DCNT,DECEASED,DFN,DNAME,DNAMEL,DOD,DUE,DUOUT,FDA
137 N INSTNAM,INSTNUM,LAST,MSG,NAME,ONODE
138 N RCNT,RIEN,RNAMEL,RNCNT,SUB,TEMP,TEST,TYPE,VALUE
139 ;Lock patient list
140 D LOCK^PXRMRUL1 Q:$D(DUOUT)
141 S TEMP=^PXRMXP(810.5,LIST,0)
142 S NAME=$P(TEMP,U,1)
143 S $P(^PXRMXP(810.5,LIST,0),U,11)=INDP
144 S $P(^PXRMXP(810.5,LIST,0),U,12)=INTP
145 ;
146 ;Clear existing list.
147 K ^PXRMXP(810.5,LIST,30),^PXRMXP(810.5,LIST,35),^PXRMXP(810.5,LIST,45),^PXRMXP(810.5,LIST,200)
148 ;
149 ;Merge ^TMP into Patient List
150 S (DECEASED,TESTP)=""
151 S (CNT,DFN)=0
152 F S DFN=$O(^TMP($J,NODE,DFN)) Q:'DFN D
153 .S ONODE=$G(^TMP($J,NODE,DFN,"INST"))
154 .S INSTNUM=$P(ONODE,U,1),INSTNAM=$P(ONODE,U,2)
155 .S TEMP=DFN_U_INSTNUM_U_INSTNAM
156 .I INDP D
157 ..;DBIA #10035
158 ..S DOD=+$P($G(^DPT(DFN,.35)),U,1)
159 ..S DECEASED=$S(DOD=0:0,1:1)
160 .;DBIA #3744
161 .I INTP S TESTP=$$TESTPAT^VADPT(DFN)
162 .S CNT=CNT+1,^PXRMXP(810.5,LIST,30,CNT,0)=DFN_U_INSTNUM_U_INSTNAM_U_DECEASED_U_TESTP
163 .S ^PXRMXP(810.5,LIST,30,"B",DFN,CNT)=""
164 .;
165 .;Save the reminder evaluation information only from Reports
166 .I $D(^TMP($J,NODE,DFN,"REM"))>0 D
167 ..S (RIEN,RCNT,RNCNT)=0
168 ..F S RIEN=$O(^TMP($J,NODE,DFN,"REM",RIEN)) Q:RIEN'>0 D
169 ...S RNAMEL(RIEN)=""
170 ...S VALUE=^TMP($J,NODE,DFN,"REM",RIEN)
171 ...S RCNT=RCNT+1
172 ...S ^PXRMXP(810.5,LIST,30,CNT,"REM",RCNT,0)=VALUE
173 ...S ^PXRMXP(810.5,LIST,30,CNT,"REM","B",RIEN,RCNT)=""
174 ..S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.532A"_U_RCNT_U_RCNT
175 .;
176 .I '$D(^TMP($J,NODE,DFN,"DATA")) Q
177 .S DCNT=0,DNAME=""
178 .F S DNAME=$O(^TMP($J,NODE,DFN,"DATA",DNAME)) Q:DNAME="" D
179 ..S DNAMEL(DNAME)=""
180 ..S VALUE=^TMP($J,NODE,DFN,"DATA",DNAME)
181 ..S DCNT=DCNT+1
182 ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA",DCNT,0)=DNAME_U_VALUE
183 ..S ^PXRMXP(810.5,LIST,30,CNT,"DATA","B",DNAME,DCNT)=""
184 .S ^PXRMXP(810.5,LIST,30,CNT,1,0)=U_"810.531A"_U_DCNT_U_DCNT
185 S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
186 ;
187 ;Save the reminder information
188 S RNCNT=0,RIEN=0
189 F S RIEN=$O(RNAMEL(RIEN)) Q:RIEN'>0 D
190 .S RNCNT=RNCNT+1
191 .S ^PXRMXP(810.5,LIST,45,RCNT,0)=RIEN
192 .S ^PXRMXP(810.5,LIST,45,"B",RIEN,RNCNT)=""
193 I RNCNT>0 S ^PXRMXP(810.5,LIST,45,0)=U_"810.545P"_U_RNCNT_U_RNCNT
194 ;
195 ;Save the data types.
196 S DCNT=0,DNAME=""
197 F S DNAME=$O(DNAMEL(DNAME)) Q:DNAME="" D
198 .S DCNT=DCNT+1
199 .S ^PXRMXP(810.5,LIST,35,DCNT,0)=DNAME
200 .S ^PXRMXP(810.5,LIST,35,"B",DNAME,DCNT)=""
201 I DCNT>0 S ^PXRMXP(810.5,LIST,35,0)=U_"810.535A"_U_DCNT_U_DCNT
202 S ^PXRMXP(810.5,LIST,30,0)=U_"810.53P"_U_CNT_U_CNT
203 ;
204 ;Update header info
205 S TYPE=$S($G(PATCREAT)="Y":"PVT",1:"PUB")
206 K PATCREAT
207 S FDA(810.5,"?+1,",.01)=NAME
208 S FDA(810.5,"?+1,",.04)=$$NOW^XLFDT
209 S FDA(810.5,"?+1,",.05)=EPIEN
210 S FDA(810.5,"?+1,",.06)=RULE
211 S FDA(810.5,"?+1,",.07)=$G(DUZ)
212 S FDA(810.5,"?+1,",.08)=TYPE
213 I $G(INST)=1 S FDA(810.5,"?+1,",.1)=1
214 S FDA(810.5,"?+1,",50)=$S($G(PLISTPUG)="Y":1,1:0)
215 D UPDATE^DIE("","FDA","","MSG")
216 ;Error
217 I $D(MSG) D ERR^PXRMRUL1
218 ;Unlock patient list
219 D UNLOCK^PXRMRUL1
220 Q
221 ;
Note: See TracBrowser for help on using the repository browser.