source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORUPDUT.m@ 1383

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1RORUPDUT ;HCIOFO/SG - REGISTRY UPDATE UTILITIES ; 8/2/05 9:17am
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 ; RORVALS ------------- CALCULATED VALUES
5 ;
6 ; RORVALS("DV", VALUES OF THE DATA ELEMENTS
7 ; File#,DataCode,"E") External value
8 ; File#,DataCode,"I") Internal value
9 ;
10 ; RORVALS("LS", LIST OF TRIGGERED LAB SEARCHES
11 ; LabSearch#) Observation descriptor
12 ; ^01: Date/time of the observation
13 ; ^02: Institution IEN
14 ;
15 ; RORVALS("SV", VALUES OF THE SELECTION RULES
16 ; Rule Name, Current value
17 ; "AVG") Average value
18 ; "CNT") Counter
19 ; "DTF") Used by the {SDF} and {SDL} macros to store
20 ; "DTL") the earliest and the latest trigger dates
21 ; "MAX") Maximum value
22 ; "MIN") Minimum value
23 ; "SUM") Total value
24 ;
25 ; PREDEFINED NAME ----- VALUE AND DESCRIPTION
26 ;
27 ; "ROR DFN" IEN of the patient being processed
28 ; "ROR SRDT" Date when the current selection rule was
29 ; triggered (it is set by APLRULES^RORUPDUT
30 ; but could be changed by selection rules).
31 ; The {GDF} and {GDL} macros modify this
32 ; value as well.
33 ; "ROR SRLOC" Institution IEN where the selection rule
34 ; was triggered
35 ;
36 Q
37 ;
38 ;***** APPLIES SELECTION RULES TO THE RECORD
39 ;
40 ; FILE File/Subfile number
41 ; IENS IENS of the current record
42 ; MODE "B" (process before subfiles) or
43 ; "A" (process after subfiles)
44 ; [DATE] Trigger date (TODAY by default)
45 ; [LOCATION] Institution IEN (empty by default)
46 ;
47 ; Return values:
48 ; <0 Error code
49 ; 0 Continue processing of the current patient
50 ; 1 Stop looping
51 ;
52APLRULES(FILE,IENS,MODE,DATE,LOCATION) ;
53 N EXPR,HDR,LM,PATIEN,RC,REGIEN,RI,RULENAME,RULENODE,TMP
54 S:'$G(DATE) DATE=$$DT^XLFDT
55 ;--- Loop through the selection rules
56 S RI="",RC=0
57 F S RI=$O(RORUPD("SR",FILE,MODE,RI)) Q:RI="" D Q:RC<0
58 . S RULENODE=$NA(RORUPD("SR",FILE,MODE,RI))
59 . S RORVALS("SV","ROR SRDT")=$P(DATE,".")
60 . S RORVALS("SV","ROR SRLOC")=$G(LOCATION)
61 . S HDR=$G(@RULENODE),RULENAME=$P(HDR,U)
62 . ;--- If a top level rule does not exist in the control list, this
63 . ; rule has been already triggered for the patient. So, there is
64 . ; no need to check it again.
65 . I $P(HDR,U,3) Q:'$D(RORUPD("LM",1,RULENAME))
66 . ;--- Compute the expression of the selection rule
67 . X "S RC="_@RULENODE@(1)
68 . I $P(HDR,U,3) Q:'RC D ; TOP LEVEL RULE
69 . . S PATIEN=$$GETVAL("ROR DFN"),REGIEN=""
70 . . F S REGIEN=$O(@RULENODE@(2,REGIEN)) Q:REGIEN="" D
71 . . . ;--- Check if the patient is already in the registry
72 . . . Q:'$G(RORUPD("LM2",REGIEN))
73 . . . ;--- Save the rule reference for the registry and new patient
74 . . . S TMP=$$GETVAL("ROR SRDT")_U_$$GETVAL("ROR SRLOC")
75 . . . S @RORUPDPI@("U",PATIEN,2,REGIEN,+$P(HDR,U,2))=TMP
76 . . . ;--- Remove the registry from the control list
77 . . . K RORUPD("LM",2,REGIEN)
78 . . ;--- Remove the rule from the control list
79 . . K RORUPD("LM",1,RULENAME)
80 . E D SETVAL(RULENAME,RC) ; LOWER LEVEL RULE
81 . S RC=0
82 S LM=+$G(RORUPD("LM")) ; Loop mode
83 ;--- If the loop mode equals 0, continue processing of the patient
84 ; in any case. Otherwise, stop processing if the corresponding
85 ; control list is empty.
86 Q $S(RC<0:RC,LM:$D(RORUPD("LM",LM))<10,1:0)
87 ;
88 ;***** CLEARS DATA ELEMENT VALUES
89 ;
90 ; FILE File/Subfile number
91 ;
92CLRDES(FILE) ;
93 K RORVALS("DV",FILE)
94 Q
95 ;
96 ;***** CLEARS VALUE OF THE ERROR COUNTER
97CLREC ;
98 K RORUPD("ERRCNT")
99 Q
100 ;
101 ;***** CLEARS VALUES OF THE SELECTION RULES ASSOCIATED WITH THE FILE
102 ;
103 ; FILE File/Subfile number
104 ;
105CLRVALS(FILE) ;
106 N MODE,RI,RULENAME
107 F MODE="B","A" D
108 . S RI=""
109 . F S RI=$O(RORUPD("SR",FILE,MODE,RI)) Q:RI="" D
110 . . S RULENAME=$P($G(RORUPD("SR",FILE,MODE,RI)),U)
111 . . K:RULENAME'="" RORVALS("SV",RULENAME)
112 Q
113 ;
114 ;***** RETURNS A CODE OF THE DATA ELEMENT
115 ;
116 ; FILE File number
117 ; NAME Name of the data element
118 ;
119 ; Return values:
120 ; <0 Error code
121 ; >0 Code of the data element
122 ;
123DATACODE(FILE,NAME) ;
124 N IENS,RC,RORBUF,RORMSG
125 S IENS=","_FILE_","
126 D FIND^DIC(799.22,IENS,"@;.02I","X",NAME,,"B",,,"RORBUF","RORMSG")
127 I $G(DIERR) D Q RC
128 . S RC=$$DBS^RORERR("RORMSG",-9,,,799.22,IENS)
129 S RC=+$G(RORBUF("DILIST",0))
130 Q:RC<1 $$ERROR^RORERR(-69,,NAME)
131 Q:RC>1 $$ERROR^RORERR(-70,,NAME)
132 Q +$G(RORBUF("DILIST","ID",1,.02))
133 ;
134 ;***** PRINTS SOME DEBUG INFORMATION
135DEBUG ;
136 N I
137 D ZW^RORUTL01($NA(RORUPD("FLAGS")),"Control Flags")
138 D ZW^RORUTL01($NA(RORUPD("SR")),"Selection Rules")
139 D ZW^RORUTL01($NA(RORUPD("UPD")),"Call-back Entry Points")
140 W !,"Control Lists",!!
141 F I="LM1","LM2" D ZW^RORUTL01($NA(RORUPD(I)))
142 D ZW^RORUTL01("RORLRC","Lab Results to check")
143 W !,"Job number: ",$J,!
144 Q
145 ;
146 ;***** GETS A VALUE OF THE DATA ELEMENT
147 ;
148 ; FILE File number
149 ; DATELMT Code of the data element
150 ; [TYPE] Type of the value
151 ; "E" External
152 ; "I" Internal (default)
153 ;
154GETDE(FILE,DATELMT,TYPE) ;
155 Q $G(RORVALS("DV",FILE,DATELMT,$G(TYPE,"I")))
156 ;
157 ;***** RETURNS VALUE OF THE ERROR COUNTER
158GETEC() ;
159 Q +$G(RORUPD("ERRCNT"))
160 ;
161 ;***** GETS VALUE OF THE SELECTION RULE
162 ;
163 ; RULENAME Name of the rule
164 ; [PFX] Prefix of the value
165 ; "" Value itself (default)
166 ; "AVG" Average value
167 ; "CNT" Counter
168 ; "MAX" Maximum value
169 ; "MIN" Minimum value
170 ; "SUM" Total sum
171 ;
172GETVAL(RULENAME,PFX) ;
173 Q $S($G(PFX)="":$G(RORVALS("SV",RULENAME)),1:$G(RORVALS("SV",RULENAME,PFX)))
174 ;
175 ;***** INCREMENTS VALUE OF THE ERROR COUNTER
176 ;
177 ; [RC] Reference to a variable containing the error code
178 ;
179INCEC(RC) ;
180 S:$G(RC,-1)<0 RORUPD("ERRCNT")=$G(RORUPD("ERRCNT"))+1,RC=0
181 Q
182 ;
183 ;***** LOADS DATA ELEMENT VALUES FROM CORRESPONDING FIELDS
184 ;
185 ; FILE File/Subfile number
186 ; IENS IENS of the current record
187 ;
188 ; Return values:
189 ; <0 Error code
190 ; 0 Ok
191 ;
192LOADFLDS(FILE,IENS) ;
193 N DE,FLD,RC,RORFDA,RORMSG,VT K RORVALS("DV",FILE)
194 S FLD=$G(RORUPD("SR",FILE,"F",1)) Q:FLD="" 0
195 ;--- Load the field values
196 D GETS^DIQ(FILE,IENS,FLD,"EIN","RORFDA","RORMSG")
197 I $G(DIERR) D Q RC
198 . S RC=$$DBS^RORERR("RORMSG",-9,,,FILE,IENS)
199 ;--- Copy the field values from the FDA
200 S DE=""
201 F S DE=$O(RORUPD("SR",FILE,"F",1,DE)) Q:DE="" D
202 . S FLD=+$G(RORUPD("SR",FILE,"F",1,DE)) Q:'FLD
203 . S VT=""
204 . F S VT=$O(RORUPD("SR",FILE,"F",1,DE,VT)) Q:VT="" D
205 . . S RORVALS("DV",FILE,DE,VT)=$G(RORFDA(FILE,IENS,FLD,VT))
206 Q 0
207 ;
208 ;***** SETS THE EARLIEST DATE FOR THE RULE
209 ;
210 ; NAME Name of the selection rule
211 ; COND Result value of the logical condition
212 ;
213 ; Return values:
214 ; 0 COND equals to zero
215 ; 1 COND is not zero
216 ;
217SDF(NAME,COND) ;
218 Q:'$G(COND) 0
219 N DATE
220 S DATE=$G(RORVALS("SV","ROR SRDT"))
221 D:DATE>0
222 . I $G(RORVALS("SV",NAME,"DTF"))'>0 D Q
223 . . S RORVALS("SV",NAME,"DTF")=DATE
224 . S:DATE<RORVALS("SV",NAME,"DTF") RORVALS("SV",NAME,"DTF")=DATE
225 Q 1
226 ;
227 ;***** SETS THE LATEST DATE FOR THE RULE
228 ;
229 ; NAME Name of the selection rule
230 ; COND Result value of the logical condition
231 ;
232 ; Return values:
233 ; 0 COND equals to zero
234 ; 1 COND is not zero
235 ;
236SDL(NAME,COND) ;
237 Q:'$G(COND) 0
238 N DATE
239 S DATE=$G(RORVALS("SV","ROR SRDT"))
240 D:DATE>0
241 . S:DATE>$G(RORVALS("SV",NAME,"DTL")) RORVALS("SV",NAME,"DTL")=DATE
242 Q 1
243 ;
244 ;***** SETS VALUE OF THE SELECTION RULE
245 ;
246 ; RULENAME Name of the rule
247 ; VALUE New value
248 ;
249SETVAL(RULENAME,VALUE) ;
250 S RORVALS("SV",RULENAME)=VALUE
251 S RORVALS("SV",RULENAME,"CNT")=$G(RORVALS("SV",RULENAME,"CNT"))+1
252 S RORVALS("SV",RULENAME,"SUM")=$G(RORVALS("SV",RULENAME,"SUM"))+VALUE
253 S RORVALS("SV",RULENAME,"AVG")=RORVALS("SV",RULENAME,"SUM")/RORVALS("SV",RULENAME,"CNT")
254 ;
255 I $G(RORVALS("SV",RULENAME,"MIN"))="" S RORVALS("SV",RULENAME,"MIN")=VALUE
256 E S:VALUE<RORVALS("SV",RULENAME,"MIN") RORVALS("SV",RULENAME,"MIN")=VALUE
257 ;
258 I $G(RORVALS("SV",RULENAME,"MAX"))="" S RORVALS("SV",RULENAME,"MAX")=VALUE
259 E S:VALUE>RORVALS("SV",RULENAME,"MAX") RORVALS("SV",RULENAME,"MAX")=VALUE
260 Q
261 ;
262 ;***** GETS THE TRIGGER DATE OF THE RULE
263 ;
264 ; NAME Name of the selection rule
265 ; PFX Prefix of the value ("GDF" or "GDL")
266 ; COND Result value of the logical condition
267 ;
268 ; Return values:
269 ; 0 COND equals to zero
270 ; 1 COND is not zero
271 ;
272SRDT(NAME,PFX,COND) ;
273 Q:'$G(COND) 0
274 N DATE
275 S DATE=$G(RORVALS("SV",NAME,$S(PFX="GDL":"DTL",1:"DTF")))
276 I DATE S:DATE<$G(RORVALS("SV","ROR SRDT")) RORVALS("SV","ROR SRDT")=DATE
277 Q 1
Note: See TracBrowser for help on using the repository browser.