source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORUTL02.m@ 635

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

initial load of FOIAVistA 6/30/08 version
File size: 8.3 KB
Line 
1RORUTL02 ;HCIOFO/SG - UTILITIES ; 8/25/05 10:20am
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 ; This routine uses the following IAs:
5 ;
6 ; #2701 $$GETICN^MPIF001 Gets ICN (supported)
7 ; #3556 $$GCPR^LA7QRY
8 ; #3557 Access to the field .01 and x-ref "B"
9 ; of the file 95.3
10 ; #3646 $$EMPL^DGSEC4
11 ; #10035 Access to the field #.09 of the file #2
12 ;
13 Q
14 ;
15 ;***** REMOVES THE INACTIVE REGISTRIES FROM THE LIST
16 ;
17 ; .REGLST( A list of registry names (as subscripts)
18 ; RegName) Registry IEN (output)
19 ;
20 ; Return values:
21 ; <0 Error code
22 ; 0 Ok
23 ;
24 ; This function removes names of those registries that are
25 ; inactive or cannot be updated for any other reasons from
26 ; the list. It also associates registry IENs with the names
27 ; of registries remaining on the list.
28 ;
29 ; Moreover, it records corresponding messages about skipped
30 ; registries to the current open log.
31 ;
32ARLST(REGLST) ;
33 N INFO,RC,REGIEN,REGNAME,RORBUF,TMP K DSTLST
34 S REGNAME="",RC=0
35 F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D Q:RC<0
36 . S REGIEN=$$REGIEN(REGNAME,"@;11I;21.05I",.RORBUF)
37 . ;--- Cannot find (or load) the registry parameters
38 . I REGIEN'>0 D Q
39 . . D ERROR^RORERR(REGIEN,,REGNAME)
40 . . K REGLST(REGNAME)
41 . ;--- Check if the registry is marked as 'inactive'
42 . I $G(RORBUF("DILIST","ID",1,11)) D Q
43 . . D ERROR^RORERR(-48,,,,REGNAME)
44 . . K REGLST(REGNAME)
45 . ;--- Check if the registry has not been populated
46 . I '$G(RORBUF("DILIST","ID",1,21.05)),'$G(RORPARM("SETUP")) D Q
47 . . D TEXT^RORTXT(7980000.02,.INFO)
48 . . D ERROR^RORERR(-103,,.INFO,,REGNAME)
49 . . K INFO,REGLST(REGNAME)
50 . ;--- Store the registry IEN
51 . S REGLST(REGNAME)=REGIEN
52 Q RC
53 ;
54 ;***** RETURNS A FULL ICN OF THE PATIENT
55 ;
56 ; PTIEN Patient IEN
57 ;
58 ; Return Values:
59 ; <0 Error code
60 ; "" ICN has not been assigned
61 ; >0 Patient ICN
62 ;
63ICN(PTIEN) ;
64 N ICN,L,TMP
65 S ICN=$$GETICN^MPIF001(PTIEN)
66 I ICN'>0 D Q ""
67 . S TMP=$$ERROR^RORERR(-57,,$P(ICN,U,2),PTIEN,+ICN,"$$GETICN^MPIF001")
68 ;--- Validate the checksum (just in case ;-)
69 S L=$L($P(ICN,"V",2))
70 Q $S(L<6:$P(ICN,"V")_"V"_$E("000000",1,6-L)_$P(ICN,"V",2),1:ICN)
71 ;
72 ;***** LOADS THE LAB RESULTS
73 ;
74 ; PTIEN Patient IEN
75 ;
76 ; SDT Start date of the results
77 ; EDT End date of the results
78 ;
79 ; [ROR8DST] Closed root of the destination array
80 ; (the ^TMP("RORTMP",$J) node, by default)
81 ;
82 ; Return values:
83 ; <0 Error code
84 ; 0 Ok
85 ;
86LABRSLTS(PTIEN,SDT,EDT,ROR8DST) ;
87 N H7CH,RC,RORMSG,TMP
88 S:$G(ROR8DST)="" ROR8DST=$NA(^TMP("RORTMP",$J))
89 K @ROR8DST
90 I $D(RORLRC)<10 Q:$G(RORLRC)="" 0
91 ;--- Get the Patient ID (ICN or SSN)
92 S PTID=$$PTID(PTIEN) Q:PTID<0 PTID
93 ;--- Get the Lab data
94 S H7CH=$G(RORHL("FS"))_$G(RORHL("ECH"))
95 S RC=$$GCPR^LA7QRY(PTID,SDT,EDT,.RORLRC,"*",.RORMSG,ROR8DST,H7CH)
96 I RC="",$D(RORMSG)>1 D
97 . N ERR,I,LST
98 . S (ERR,LST)=""
99 . F I=1:1 S ERR=$O(RORMSG(ERR)) Q:ERR="" D
100 . . S LST=LST_","_ERR,TMP=RORMSG(ERR)
101 . . K RORMSG(ERR) S RORMSG(I)=TMP
102 . S LST=$P(LST,",",2,999) Q:(LST=3)!(LST=99)
103 . S RC=$$ERROR^RORERR(-27,,.RORMSG,PTIEN)
104 Q $S(RC<0:RC,1:0)
105 ;
106 ;***** RETURNS THE LOINC CODE WITH THE CONTROL DIGIT
107 ;
108 ; LNCODE LOINC code
109 ;
110 ; Besides adding a control digit to the LOINC code, the function
111 ; checks the code against the LAB LOINC file (#95.3).
112 ;
113 ; Return values:
114 ; <0 Error code
115 ; >0 LOINC code with the control digit
116 ;
117LNCODE(LNCODE) ;
118 N RC,RORBUF,RORMSG
119 D FIND^DIC(95.3,,"@;.01E","X",$P(LNCODE,"-"),2,"B",,,"RORBUF","RORMSG")
120 Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,95.3)
121 I $G(RORBUF("DILIST",0))<1 D Q RC ; Non-existent code
122 . S RC=$$ERROR^RORERR(-29,,,,LNCODE)
123 I $G(RORBUF("DILIST",0))>1 D Q RC ; Duplicate records
124 . S RC=$$ERROR^RORERR(-30,,,,LNCODE)
125 Q RORBUF("DILIST","ID",1,.01)
126 ;
127 ;***** LOCK/UNLOCK REGISTRIES BEING PROCESSED
128 ;
129 ; .REGLST Reference to a local array containing registry names
130 ; as subscripts and optional registry IENs as values
131 ; [MODE] 0 - Unlock (default), 1 - Lock
132 ; [TO] LOCK timeout (3 sec by defualt)
133 ; [NAME] Name of the process/task
134 ;
135 ; Return Values:
136 ; <0 Error code
137 ; 0 Some of the registries has been locked by another job
138 ; 1 Ok
139 ;
140LOCKREG(REGLST,MODE,TO,NAME) ;
141 Q:$D(REGLST)<10 1
142 N LOCKLST,RC,REGIEN,REGNAME
143 S REGNAME=""
144 F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D Q:REGIEN<0
145 . S REGIEN=+$G(REGLST(REGNAME))
146 . I REGIEN'>0 S REGIEN=$$REGIEN^RORUTL02(REGNAME) Q:REGIEN'>0
147 . S LOCKLST(798.1,REGIEN_",")=""
148 Q:$G(REGIEN)<0 REGIEN
149 Q:$D(LOCKLST)<10 1
150 I $G(MODE) D
151 . S RC=$$LOCK^RORLOCK(.LOCKLST,,,+$G(TO,3),$G(NAME))
152 E S RC=$$UNLOCK^RORLOCK(.LOCKLST)
153 Q $S('RC:1,RC<0:RC,1:0)
154 ;
155 ;***** RETURNS A PATIENT ID (ICN OR SSN)
156 ;
157 ; PTIEN Patient IEN
158 ;
159 ; Return Values:
160 ; <0 Error code
161 ; "" Neither ICN nor SSN has been assigned
162 ; >0 Patient ICN (or SSN if ICN is not available)
163 ;
164PTID(PTIEN) ;
165 N L,PTID,RC,RORMSG
166 S PTID=$$GETICN^MPIF001(PTIEN)
167 I PTID>0 D Q PTID
168 . ;--- Validate the checksum (just in case ;-)
169 . S L=$L($P(PTID,"V",2)) Q:L'<6
170 . ;S RC=$$ERROR^RORERR(-59,,,PTIEN)
171 . S $P(PTID,"V",2)=$E("000000",1,6-L)_$P(PTID,"V",2)
172 ;--- Get SSN if ICN is not available
173 S PTID=$$GET1^DIQ(2,PTIEN_",",.09,,,"RORMSG")
174 Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,PTIEN,2)
175 Q PTID
176 ;
177 ;***** RETURNS IEN OF THE REGISTRY PARAMETERS
178 ;
179 ; REGNAME Name of the registry
180 ; [FIELDS] List of fields (separated by semicolons) to load
181 ; [.RORTRGT] Reference to a local variable where field values will
182 ; be stored by the FIND^DIC call
183 ;
184 ; Return Values:
185 ; <0 Error code
186 ; >0 Registry parameters IEN
187 ;
188REGIEN(REGNAME,FIELDS,RORTRGT) ;
189 N RC,REGIEN,RORMSG K RORTRGT
190 D FIND^DIC(798.1,,"@;"_$G(FIELDS),"UX",REGNAME,2,"B",,,"RORTRGT","RORMSG")
191 Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.1)
192 S RC=+$G(RORTRGT("DILIST",0))
193 Q $S(RC<1:-1,RC>1:-2,1:+RORTRGT("DILIST",2,1))
194 ;
195 ;***** RETURNS NUMBER OF RECORDS IN THE REGISTRY
196 ;
197 ; REGIEN Registry IEN
198 ; [.LOWIEN] The smallest IEN will be returned via this parameter
199 ; [.HIGHIEN] The biggest IEN will be returned via this parameter
200 ;
201 ; Return Values:
202 ; <0 Error code
203 ; 0 The registry is empty
204 ; >0 Number of records in the registry
205 ;
206REGSIZE(REGIEN,LOWIEN,HIGHIEN) ;
207 N I,NODE,NRE,RC,RORFDA,RORMSG
208 S NODE=$NA(^RORDATA(798,"AC",REGIEN))
209 S LOWIEN=$O(@NODE@(""))
210 S HIGHIEN=$O(@NODE@(""),-1)
211 ;--- Get number of records from the parameters
212 S NRE=$$GET1^DIQ(798.1,REGIEN_",",19.1,,,"RORMSG")
213 Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.1,REGIEN)
214 Q:NRE>0 NRE
215 ;--- Count the records of the registry
216 S I="",NRE=0
217 F S I=$O(@NODE@(I)) Q:I="" S NRE=NRE+1
218 ;--- Store the value in the parameters
219 S RORFDA(798.1,REGIEN_",",19.1)=NRE
220 D FILE^DIE("K","RORFDA","RORMSG")
221 Q NRE
222 ;
223 ;***** CHECKS IF AN EMPLOYEE SHOULD BE SKIPPED
224 ;
225 ; PTIEN Patient IEN
226 ;
227 ; [.]REGIEN Registry IEN
228 ;
229 ; If you are going to call this function for several
230 ; patients in a row (in a cycle), you can pass the
231 ; second parameter by reference. This will eliminate
232 ; repetitive access to the registry parameters (the
233 ; REGIEN("SE") node will be used as a "cache" for the
234 ; value of the EXCLUDE EMPLOYEES field).
235 ;
236 ; Return Values:
237 ; 0 Patient can be added to the registry
238 ; 1 Patient should be skipped
239 ;
240 ; The function checks if the patient is an employee and if he/she
241 ; can be added to the registry (according to the value of the
242 ; EXCLUDE EMPLOYEES field of the ROR REGISTRY PARAMETERS file).
243 ;
244SKIPEMPL(PTIEN,REGIEN) ;
245 Q:'$$EMPL^DGSEC4(PTIEN,"P") 0
246 S:'$D(REGIEN("SE")) REGIEN("SE")=+$P($G(^ROR(798.1,+REGIEN,0)),U,10)
247 Q +REGIEN("SE")
248 ;
249 ;***** RETURNS IEN OF THE SELECTION RULE
250 ;
251 ; RULENAME Name of the selection rule
252 ; [FIELDS] List of fields (separated by semicolons) to load
253 ; [.RORTRGT] Reference to a local variable where field values will
254 ; be stored by the FIND^DIC call.
255 ;
256 ; Return Values:
257 ; <0 Error code
258 ; >0 Selection rule IEN
259 ;
260SRLIEN(RULENAME,FIELDS,RORTRGT) ;
261 N RC,RULEIEN,RORMSG K RORTRGT
262 D FIND^DIC(798.2,,"@;"_$G(FIELDS),"X",RULENAME,2,"B",,,"RORTRGT","RORMSG")
263 Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.2)
264 S RC=+$G(RORTRGT("DILIST",0))
265 Q $S(RC<1:-3,RC>1:-4,1:+RORTRGT("DILIST",2,1))
Note: See TracBrowser for help on using the repository browser.