source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORUPR1.m@ 1068

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

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1RORUPR1 ;HCIOFO/SG - SELECTION RULES PREPARATION ; 11/20/05 4:56pm
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 Q
5 ;
6 ;***** MARKS PARENT FILES TO PROCESS
7 ;
8 ; This function analyzes file dependencies defined by the 'ROR
9 ; METADATA' file and guaranties that all necessary files will be
10 ; processed during the registry update.
11 ;
12FILETREE() ;
13 N FILE,PF,RC
14 S FILE="",RC=0
15 F S FILE=$O(RORUPD("SR",FILE)) Q:FILE="" D Q:RC<0
16 . S PF=+FILE,RC=0
17 . ;--- Follow a path that leads from this file to
18 . ; the root of the "file-processing tree".
19 . F D Q:RC
20 . . ;--- Check if metadata for the file is defined
21 . . I '$D(^ROR(799.2,PF)) D Q
22 . . . S RC=$$ERROR^RORERR(-63,,,,PF)
23 . . ;--- Get the number of the parent file
24 . . S PF=+$$GET1^DIQ(799.2,PF_",",1,"I",,"RORMSG")
25 . . I $G(DIERR) D Q
26 . . . S RC=$$DBS^RORERR("RORMSG",-9)
27 . . ;--- Stop if the root of the "file-processing tree" has been
28 . . ; reached or the file is already marked for processing.
29 . . ; Otherwise, mark the file and continue moving up.
30 . . I 'PF!$D(RORUPD("SR",PF)) S RC=1 Q
31 . . S RORUPD("SR",PF)=""
32 Q $S(RC<0:RC,1:0)
33 ;
34 ;***** RETURNS LEVEL OF THE FILE IN 'THE FILE PROCESSING' TREE
35 ;
36 ; FILE File number
37 ;
38FLEVEL(FILE) ;
39 N LEVEL
40 S LEVEL=1
41 F S FILE=+$P($G(^ROR(799.2,FILE,0)),U,2) Q:'FILE S LEVEL=LEVEL+1
42 Q LEVEL
43 ;
44 ;***** LOADS AND PREPARES LAB SEARCH INDICATORS
45 ;
46 ; Return Values:
47 ; 0 Ok
48 ; <0 Error code
49 ;
50LABSRCH() ;
51 N I,IND,IR,LRCODE,LSICNT,LSIEN,RC,RORBUF,RORMSG,TMP,VAL
52 K RORLRC
53 ;--- Browse through the list of Lab searches
54 S LSIEN="",RC=0
55 F S LSIEN=$O(@RORUPDPI@(4,LSIEN)) Q:LSIEN="" D Q:RC<0
56 . K RORBUF S TMP=","_LSIEN_","
57 . D LIST^DIC(798.92,TMP,"@;.01;.02;1I;2",,,,,"B",,,"RORBUF","RORMSG")
58 . S RC=$$DBS^RORERR("RORMSG",-9) Q:RC<0
59 . ;--- Browse through the list of search indicators
60 . S IR="",LSICNT=0
61 . F S IR=$O(RORBUF("DILIST","ID",IR)) Q:IR="" D Q:RC<0
62 . . K LRCODE
63 . . ;--- Check if the indicator should be ignored
64 . . S IND=$G(RORBUF("DILIST","ID",IR,1)) Q:IND'>0
65 . . ;--- Get the result code (LOINC and/or NLT)
66 . . S LRCODE=$G(RORBUF("DILIST","ID",IR,.01))
67 . . I LRCODE>0 D Q:LRCODE<0 S LRCODE(LRCODE_"^LN")=""
68 . . . S LRCODE=$$LNCODE^RORUTL02(LRCODE)
69 . . S LRCODE=$G(RORBUF("DILIST","ID",IR,.02))
70 . . S:LRCODE>0 LRCODE(LRCODE_"^NLT")=""
71 . . ;--- Either LOINC or NLT must be defined
72 . . Q:$D(LRCODE)<10
73 . . M RORLRC("B")=LRCODE
74 . . ;--- Prepare and store the search indicator
75 . . S VAL=$G(RORBUF("DILIST","ID",IR,2))
76 . . I VAL="",IND'=1,IND'=6 Q
77 . . S LSICNT=LSICNT+1
78 . . S LRCODE=""
79 . . F S LRCODE=$O(LRCODE(LRCODE)) Q:LRCODE="" D
80 . . . S I=$O(@RORUPDPI@("LS",LRCODE,LSIEN,""),-1)+1
81 . . . S @RORUPDPI@("LS",LRCODE,LSIEN,I)=IND_U_VAL
82 . Q:(RC<0)!(LSICNT>0)
83 . ;--- Record a warning if no indicators are defined
84 . S TMP=$$GET1^DIQ(798.9,LSIEN_",",.01,,,"RORMSG")
85 . S TMP=$$ERROR^RORERR(-55,,,,TMP)
86 Q:RC<0 RC
87 ;--- Prepare a list of Lab result codes for GCPR^LA7QRY
88 S LRCODE=""
89 F IR=1:1 S LRCODE=$O(RORLRC("B",LRCODE)) Q:LRCODE="" D
90 . S RORLRC(IR)=LRCODE
91 K RORLRC("B")
92 Q 0
93 ;
94 ;***** LOADS SELECTION RULES DATA
95 ;
96 ; .REGLST Reference to a local array containing registry names
97 ; as subscripts and optional registry IENs as values
98 ;
99 ; Return Values:
100 ; 0 Ok
101 ; <0 Error code
102 ;
103LOAD(REGLST) ;
104 N I,IENS,RC,REGIEN,REGNAME,RORBUF,RORMSG,RULENAME
105 K RORUPD("LM1")
106 S REGNAME="",RC=0
107 F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D Q:RC<0
108 . S REGIEN=+$G(REGLST(REGNAME))
109 . I REGIEN'>0 D I REGIEN'>0 S RC=REGIEN Q
110 . . S REGIEN=$$REGIEN^RORUTL02(REGNAME)
111 . S @RORUPDPI@(2,REGIEN)=REGNAME
112 . ;--- Load selection rules
113 . K RORBUF S IENS=","_REGIEN_","
114 . D LIST^DIC(798.13,IENS,"@;.01E","U",,,,"B",,,"RORBUF","RORMSG")
115 . S RC=$$DBS^RORERR("RORMSG",-9) Q:RC<0
116 . S I=""
117 . F S I=$O(RORBUF("DILIST","ID",I)) Q:I="" D Q:RC<0
118 . . S RULENAME=RORBUF("DILIST","ID",I,.01)
119 . . S RC=$$LOADRULE(RULENAME,REGIEN)
120 Q $S(RC<0:RC,1:0)
121 ;
122 ;***** LOADS THE SELECTION RULE
123 ;
124 ; RULENAME Name of the rule
125 ; REGIEN Registry IEN
126 ; [LEVEL] Level of the rule (O for top level rules)
127 ;
128 ; Return Values:
129 ; 0 Ok
130 ; <0 Error code
131 ;
132LOADRULE(RULENAME,REGIEN,LEVEL) ;
133 ;--- Quit if the rule has already been loaded
134 I $D(@RORUPDPI@(3,RULENAME)) D Q 0
135 . S @RORUPDPI@(3,RULENAME,2,REGIEN)=""
136 ;---
137 N DATELMT,DEPRLC,EXPR,FILE,I,IENS,RORBUF,RORMSG,RULIEN,TMP
138 ;--- Load the rule data
139 D FIND^DIC(798.2,,"@;1;2I","X",RULENAME,2,"B",,,"RORBUF","RORMSG")
140 S RC=$$DBS^RORERR("RORMSG",-9) Q:RC<0 RC
141 Q:$G(RORBUF("DILIST",0))<1 $$ERROR^RORERR(-3,,RULENAME)
142 Q:$G(RORBUF("DILIST",0))>1 $$ERROR^RORERR(-4,,RULENAME)
143 S RULIEN=+RORBUF("DILIST",2,1),IENS=","_RULIEN_","
144 S FILE=+RORBUF("DILIST","ID",1,2)
145 ;--- Put the rule data into the temporary global
146 S @RORUPDPI@(1,FILE,"S",RULENAME)=""
147 S @RORUPDPI@(3,RULENAME)=RULIEN_U_FILE_"^^"_'$G(LEVEL)
148 S RC=$$PARSER^RORUPEX(FILE,RORBUF("DILIST","ID",1,1),.EXPR)
149 Q:RC<0 RC
150 S @RORUPDPI@(3,RULENAME,1)=EXPR
151 S @RORUPDPI@(3,RULENAME,2,REGIEN)=""
152 M @RORUPDPI@(1,FILE,"F")=EXPR("F")
153 S:'$G(LEVEL) RORUPD("LM1",RULENAME)=""
154 M @RORUPDPI@(4)=EXPR("L")
155 ;--- Load the rules that this rule depends on
156 S DEPRLC=""
157 F S DEPRLC=$O(EXPR("R",DEPRLC)) Q:DEPRLC="" D Q:RC<0
158 . S RC=$$LOADRULE(DEPRLC,REGIEN,$G(LEVEL)+1)
159 . S:RC'<0 @RORUPDPI@(3,RULENAME,3,DEPRLC)=""
160 Q:RC<0 RC
161 ;--- Load a list of additional data elements
162 K EXPR,RORBUF,RORMSG
163 D LIST^DIC(798.26,IENS,"@;.01I;1I",,,,,"B",,,"RORBUF","RORMSG")
164 S RC=$$DBS^RORERR("RORMSG",-9) Q:RC<0 RC
165 S I=""
166 F S I=$O(RORBUF("DILIST","ID",I)) Q:I="" D
167 . S DATELMT=RORBUF("DILIST","ID",I,.01)
168 . S TMP=$G(RORBUF("DILIST","ID",I,1)) S:TMP="" TMP="EI"
169 . S:TMP["E" @RORUPDPI@(1,FILE,"F",DATELMT,"E")=""
170 . S:TMP["I" @RORUPDPI@(1,FILE,"F",DATELMT,"I")=""
171 Q 0
172 ;
173 ;***** LOADS AND PREPARES THE METADATA
174METADATA() ;
175 N API,DATELMT,DEFL,FILE,I,IENS,IS,PIF,RC,ROOT,RORBUF,RORMSG,TMP,VT
176 S RC=$$FILETREE() Q:RC<0 RC
177 S DEFL="@;.02I;1I;4I;4.1;4.2;6I"
178 ;--- Load and process the metadata
179 S FILE="",RC=0
180 F S FILE=$O(RORUPD("SR",FILE)) Q:FILE="" D Q:RC<0
181 . S IENS=","_FILE_",",PIF=$NA(@RORUPDPI@(1,FILE))
182 . ;--- Global root of the file
183 . S RORUPD("ROOT",FILE)=$$ROOT^DILFD(FILE,,1)
184 . ;--- Associate data elements with APIs
185 . S DATELMT=""
186 . F S DATELMT=$O(@PIF@("F",DATELMT)) Q:DATELMT="" D Q:RC<0
187 . . ;--- Find and load defintion of the data element
188 . . K RORBUF,RORMSG
189 . . D FIND^DIC(799.22,IENS,DEFL,"X",DATELMT,,"C",,,"RORBUF","RORMSG")
190 . . I $G(DIERR) D Q
191 . . . S RC=$$DBS^RORERR("RORMSG",-9,,,799.22,IENS)
192 . . ;--- Check if search on this element is supported
193 . . S API=+$G(RORBUF("DILIST","ID",1,1))
194 . . I 'API D Q
195 . . . S RC=$$ERROR^RORERR(-64,,,,FILE,DATELMT)
196 . . ;--- Store the field number (if necessary)
197 . . I API=1 D S RORUPD("SR",FILE,"F",API,DATELMT)=TMP
198 . . . S TMP=$G(RORBUF("DILIST","ID",1,6))
199 . . ;--- Associate the data element with the API
200 . . S VT=$G(RORBUF("DILIST","ID",1,4)),RC=0
201 . . F I="E","I" I $D(@PIF@("F",DATELMT,I)) D Q:RC<0
202 . . . ;--- Check if type of the requested value is supported
203 . . . I VT'[I D Q
204 . . . . S TMP=$$EXTERNAL^DILFD(799.22,4,,I,"RORMSG")
205 . . . . S RC=$$ERROR^RORERR(-65,,,,FILE,DATELMT,TMP)
206 . . . ;--- Add the API-Element pair to the list
207 . . . S TMP=$G(RORBUF("DILIST","ID",1,$$VTFN(I)))
208 . . . S RORUPD("SR",FILE,"F",API,DATELMT,I)=TMP
209 . Q:RC<0
210 . ;--- Add required elements (if any) to the list
211 . K RORBUF,RORMSG
212 . D FIND^DIC(799.22,IENS,DEFL,"X",1,,"AR",,,"RORBUF","RORMSG")
213 . I $G(DIERR) D Q
214 . . S RC=$$DBS^RORERR("RORMSG",-9,,,799.22,IENS)
215 . S IS=""
216 . F S IS=$O(RORBUF("DILIST","ID",IS)) Q:IS="" D
217 . . S DATELMT=+$G(RORBUF("DILIST","ID",IS,.02)) Q:'DATELMT
218 . . S API=+$G(RORBUF("DILIST","ID",IS,1)) Q:'API
219 . . S VT=$G(RORBUF("DILIST","ID",IS,4))
220 . . F I="E","I" D:VT[I
221 . . . S TMP=$G(RORBUF("DILIST","ID",IS,$$VTFN(I)))
222 . . . S RORUPD("SR",FILE,"F",API,DATELMT,I)=TMP
223 . . ;--- Store the field number (if necessary)
224 . . I API=1 D S RORUPD("SR",FILE,"F",API,DATELMT)=TMP
225 . . . S TMP=$G(RORBUF("DILIST","ID",IS,6))
226 . ;--- Compile a list of fields (separated by ';') for the GETS^DIQ
227 . Q:$D(RORUPD("SR",FILE,"F",1))<10
228 . S (DATELMT,RORBUF)=""
229 . F S DATELMT=$O(RORUPD("SR",FILE,"F",1,DATELMT)) Q:DATELMT="" D
230 . . S TMP=+$G(RORUPD("SR",FILE,"F",1,DATELMT))
231 . . S:TMP>0 RORBUF=RORBUF_";"_TMP
232 . S RORUPD("SR",FILE,"F",1)=$S(RORBUF'="":$P(RORBUF,";",2,999),1:"")
233 Q $S(RC<0:RC,1:0)
234 ;
235 ;***** RETURNS FIELD NUMBER OF ADDITIONAL DATA
236VTFN(VT) ;
237 Q $S(VT="E":4.1,1:4.2)
Note: See TracBrowser for help on using the repository browser.