source: FOIAVistA/tag/r/CLINICAL_CASE_REGISTRIES-ROR/RORUTL10.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1RORUTL10 ;HCIOFO/SG - LAB DATA SEARCH ; 10/14/05 3:29pm
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 ; This routine uses the following IAs:
5 ;
6 ; #91 Read access to the file #60
7 ; #554 Read access to the file #63
8 ; #998 Laboratory reference from file #2
9 ;
10 Q
11 ;
12 ;***** LOADS THE LIST OF TESTS FROM THE REGISTRY PARAMETERS
13 ;
14 ; ROR8LTST Closed root of a variable, which will contain
15 ; a list of lab tests of interest:
16 ;
17 ; @ROR8LTST@(ResultNode,TestIEN)
18 ; ^01: Test IEN (in file #60)
19 ; ^02: Test name
20 ; ^03: Code of the group
21 ; ^04: Group name
22 ; ^05: Location subscript
23 ; ^06: Result node
24 ;
25 ; REGIEN Registry IEN
26 ;
27 ; [GROUPS] List of codes (separated by commas) of Lab Groups
28 ; to load (1 - CD4, 2 - CD4 %, 3 - Viral Load).
29 ; If this parameter is undefined or empty then all
30 ; tests will be loaded.
31 ;
32 ; Return Values:
33 ; <0 Error code
34 ; 0 No tests are defined
35 ; >0 Number of the tests
36 ;
37LOADTSTS(ROR8LTST,REGIEN,GROUPS) ;
38 N BUF,CNT,GRIEN,I,IEN,IENS,LTIEN,LTNODE,NAME,NODE,RC,RGIENS,RORBUF,RORMSG,TMP
39 S RC=0,RGIENS=","_(+REGIEN)_"," K @ROR8LTST
40 S NODE=$$ROOT^DILFD(798.128,RGIENS,1)
41 ;--- List of Group IEN's
42 S GROUPS=$TR($G(GROUPS)," ")
43 D:GROUPS'=""
44 . F I=1:1 S TMP=$P(GROUPS,",",I) Q:TMP'>0 D
45 . . S TMP=$$ITEMIEN^RORUTL09(3,REGIEN,TMP)
46 . . S:TMP>0 GRIEN(TMP)=""
47 ;---
48 S (CNT,IEN)=0
49 F S IEN=$O(@NODE@(IEN)) Q:IEN'>0 D Q:RC<0
50 . K RORBUF S BUF=""
51 . ;--- Load the local test reference
52 . S IENS=IEN_RGIENS
53 . D GETS^DIQ(798.128,IENS,".01;.02","I","RORBUF","RORMSG")
54 . I $G(DIERR) D Q
55 . . S RC=$$DBS^RORERR("RORMSG",-9,,,798.128,IENS)
56 . S (BUF,LTIEN)=+$G(RORBUF(798.128,IENS,.01,"I"))
57 . Q:LTIEN'>0
58 . ;--- Check the Lab Group
59 . S GRIEN=+$G(RORBUF(798.128,IENS,.02,"I"))
60 . I $D(GRIEN)>1 Q:'$D(GRIEN(GRIEN))
61 . I GRIEN>0 D Q:RC<0
62 . . S TMP=$$ITEMCODE^RORUTL09(GRIEN,.NAME)
63 . . I TMP'>0 S:TMP<0 RC=+TMP Q
64 . . S $P(BUF,U,3,4)=TMP_U_NAME ; Code and name of the group
65 . ;--- Load the lab test parameters
66 . S IENS=LTIEN_","
67 . D GETS^DIQ(60,IENS,".01;5","EI","RORBUF","RORMSG")
68 . I $G(DIERR) D Q
69 . . S RC=$$DBS^RORERR("RORMSG",-9,,,60,IENS)
70 . S LTNODE=$P($G(RORBUF(60,IENS,5,"I")),";",2)
71 . Q:LTNODE=""
72 . S TMP=$G(RORBUF(60,IENS,.01,"E")) ; Name of the test
73 . S $P(BUF,U,2)=$S(TMP'="":TMP,1:"Unknown ("_LTIEN_")")
74 . S $P(BUF,U,5)=$P(RORBUF(60,IENS,5,"I"),";",1) ; Subscript
75 . S $P(BUF,U,6)=$P(RORBUF(60,IENS,5,"I"),";",2) ; Result node
76 . ;--- Create the reference
77 . S @ROR8LTST@(LTNODE,LTIEN)=BUF,CNT=CNT+1
78 ;---
79 Q $S(RC<0:RC,1:CNT)
80 ;
81 ;***** SEARCHES THE LAB DATA FOR REGISTRY SPECIFIC RESULTS
82 ;
83 ; PATIEN IEN of the patient (DFN)
84 ;
85 ; ROR8LT Closed root of a variable, which contains a list
86 ; of lab tests of interest (in the same format as
87 ; the list returned by the $$LOADTSTS^RORUTL10).
88 ;
89 ; If the "*" is passed via this parameter then all
90 ; lab tests are considered.
91 ;
92 ; If this parameter has a pure numeric value then
93 ; it is considered as registry IEN and the default
94 ; list of registry specific tests is automatically
95 ; compiled by the $$LOADTSTS^RORUTL10 function.
96 ;
97 ; [[.]ROR8DST] Closed root of an array where the results will be
98 ; returned (the ^TMP("RORUTL10",$J), by default).
99 ; The results will be stored into the destination
100 ; array in following format:
101 ;
102 ; @ROR8DST@(i,
103 ; 1) Result Descriptor
104 ; ^01: IEN in the file #63 (inverted date)
105 ; ^02: Date of the test (FileMan)
106 ; ^03: Result
107 ; 2) Test Descriptor
108 ; ^01: Test IEN (in the file #60)
109 ; ^02: Test name
110 ; ^03: Code of the group
111 ; ^04: Group name
112 ; ^05: Location subscript
113 ; ^06: Result node
114 ;
115 ; Example:
116 ; S RC=$$LTSEARCH^RORUTL10(DFN,REGIEN,"RORBUF")
117 ;
118 ; If this parameter is passed by reference, you can
119 ; provide a full name ($$TAG^ROUTINE) of the callback
120 ; function, which will process and store the results,
121 ; as the value of the "RORCB" node.
122 ;
123 ; Any additional nodes created in this variable will
124 ; be accessible in the callback function. Several
125 ; nodes are created automatically:
126 ;
127 ; "RORDFN" IEN of the registry patient (DFN)
128 ;
129 ; "ROREDT" End date
130 ;
131 ; "RORFLAGS" Value of parameter of the same name
132 ;
133 ; "RORSDT" Start date
134 ;
135 ; The callback function must accept 3 parameters:
136 ;
137 ; .ROR8DST Reference to the ROR8DST parameter.
138 ;
139 ; INVDT IEN of the Lab test (inverted date)
140 ;
141 ; .RESULT Reference to a local variable,
142 ; which contains the result in the
143 ; same format as it is stored into
144 ; the destination array by default.
145 ;
146 ; The function should return the following values:
147 ;
148 ; <0 Error code (the search will be aborted)
149 ; 0 Ok
150 ; 1 Skip this result
151 ; 2 Skip this and all remaining results
152 ;
153 ; Example:
154 ; S RORDST=$NA(^TMP("RORBUF",$J))
155 ; S RORDST("RORPTR")=+$O(@RORDST@(""),-1)
156 ; S RORDST("RORCB")="$$LTCB^RORUT999"
157 ; S RC=$$LTSEARCH^RORUTL10(DFN,REGIEN,.RORDST)
158 ;
159 ; [RORFLAGS] Flags to control processing (reserved)
160 ;
161 ; [STDT] Start date (FileMan)
162 ; [ENDT] End date (FileMan)
163 ;
164 ; The search is performed exactly between provided
165 ; boundaries (the time parts are considered).
166 ;
167 ; The ^TMP("RORUTL10",$J) global node is used by this function.
168 ;
169 ; Return Values:
170 ; <0 Error code
171 ; 0 No results have been found
172 ; >0 Number of results
173 ;
174LTSEARCH(PATIEN,ROR8LT,ROR8DST,RORFLAGS,STDT,ENDT) ;
175 N BUF,CNT,EXIT,GRC,ILDT,LTDT,LTFREE,LTIEN,LTLOC,LTNODE,LTRES,RC,ROR8SET,RORLR,RORMSG,TMP
176 S:$G(ROR8DST)="" ROR8DST=$NA(^TMP("RORUTL10",$J))
177 Q:$G(ROR8LT)="" 0 ; No Lab tests to search for
178 S RORFLAGS=$G(RORFLAGS),(LTFREE,RC)=0
179 ;
180 ;--- Determine the storage method (default or callback)
181 I $G(ROR8DST("RORCB"))?2"$"1.8UN1"^"1.8UN D Q:RC<0 RC
182 . S ROR8SET="S RC="_ROR8DST("RORCB")_"(.ROR8DST,ILDT,.BUF)"
183 . S ROR8DST("RORDFN")=PATIEN
184 . S ROR8DST("ROREDT")=$G(ENDT)
185 . S ROR8DST("RORFLAGS")=RORFLAGS
186 . S ROR8DST("RORSDT")=$G(STDT)
187 E S ROR8SET="" K @ROR8DST
188 ;
189 ;--- Get the Lab reference
190 S RORLR=$P($G(^DPT(PATIEN,"LR")),U) Q:RORLR'>0 0
191 ;
192 ;--- Prepare the list of tests of interest
193 I (+ROR8LT)=ROR8LT D Q:RC'>0 RC
194 . S TMP=+ROR8LT,ROR8LT=$$ALLOC^RORTMP(),LTFREE=1
195 . S RC=$$LOADTSTS(ROR8LT,TMP)
196 I ROR8LT'="*",$D(@ROR8LT)<10 Q 0
197 ;
198 ;--- Search the Lab data
199 S STDT=$$INVDATE^RORUTL01($S($G(STDT)>0:STDT,1:0))
200 S ILDT=$S($G(ENDT)>0:$$INVDATE^RORUTL01(ENDT),1:0)
201 S (CNT,RC)=0
202 F S ILDT=$O(^LR(RORLR,"CH",ILDT)) Q:(ILDT'>0)!(ILDT>STDT) D Q:RC
203 . S LTNODE=1
204 . F S LTNODE=$O(^LR(RORLR,"CH",ILDT,LTNODE)) Q:LTNODE="" D Q:RC
205 . . S LTRES=$P($G(^LR(RORLR,"CH",ILDT,LTNODE)),U)
206 . . Q:LTRES="" ; Skip empty results
207 . . S TMP=$$UP^XLFSTR(LTRES)
208 . . Q:TMP["CANC" ; Skip cancelled tests
209 . . S LTDT=$P($G(^LR(RORLR,"CH",ILDT,0)),U)
210 . . ;--- Only selected tests
211 . . I ROR8LT'="*" D Q
212 . . . S LTIEN=""
213 . . . F S LTIEN=$O(@ROR8LT@(LTNODE,LTIEN)) Q:LTIEN="" D Q:RC
214 . . . . S GRC=$P(@ROR8LT@(LTNODE,LTIEN),U,3) Q:GRC'>0
215 . . . . K BUF
216 . . . . S BUF(1)=ILDT_U_LTDT_U_LTRES
217 . . . . S BUF(2)=@ROR8LT@(LTNODE,LTIEN)
218 . . . . ;--- Default output
219 . . . . I ROR8SET="" S CNT=CNT+1 M @ROR8DST@(CNT)=BUF Q
220 . . . . ;--- Callback function
221 . . . . X ROR8SET
222 . . . . I RC S:RC=1 RC=0 Q
223 . . . . S CNT=CNT+1
224 . . ;--- Consider all tests
225 . . S LTLOC="CH;"_LTNODE_";1",LTIEN=""
226 . . F S LTIEN=$O(^LAB(60,"C",LTLOC,LTIEN)) Q:LTIEN="" D Q:RC
227 . . . K BUF
228 . . . S BUF(1)=ILDT_U_LTDT_U_LTRES
229 . . . S TMP=$$GET1^DIQ(60,LTIEN,.01,,,"RORMSG")
230 . . . S BUF(2)=LTIEN_U_$S(TMP'="":TMP,1:"Unknown ("_LTIEN_")")
231 . . . S $P(BUF(2),U,5,6)="CH"_U_LTNODE
232 . . . ;--- Default output
233 . . . I ROR8SET="" S CNT=CNT+1 M @ROR8DST@(CNT)=BUF Q
234 . . . ;--- Callback function
235 . . . X ROR8SET
236 . . . I RC S:RC=1 RC=0 Q
237 . . . S CNT=CNT+1
238 ;
239 ;--- Cleanup
240 D:LTFREE FREE^RORTMP(ROR8LT)
241 Q $S(RC<0:RC,1:CNT)
Note: See TracBrowser for help on using the repository browser.