source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORUTL15.m@ 1094

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

initial load of FOIAVistA 6/30/08 version
File size: 7.2 KB
Line 
1RORUTL15 ;HCIOFO/BH,SG - PHARMACY DATA SEARCH (TOOLS) ; 12/21/05 11:11am
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 ; This routine uses the following IAs:
5 ;
6 ; #2400 OCL^PSOORRL and OEL^PSOORRL (controlled)
7 ; #4533 ARWS^PSS50 (supported)
8 ; #4543 IEN^PSN50P65 (supported)
9 ;
10 Q
11 ;
12 ;***** DOUBLE-CHECKS THE OUTPATIENT RX (ORDER, REFILLS AND PARTIALS)
13 ;
14 ; STDT Start Date (FileMan)
15 ; ENDT End Date (FileMan)
16 ;
17 ; [.NREF] Number of refills is returned via this parameter
18 ;
19 ; [.NPAR] Nubmer of partials is returned via this parameter
20 ;
21 ; The ^TMP("PS",$J) node must be populated by the OEL^PSOORRL
22 ; before calling this function.
23 ;
24 ; Return Values:
25 ; 0 Ok
26 ; 1 Skip the order
27 ;
28DTCHECK(STDT,ENDT,NREF,NPAR) ;
29 N IRP,RXDT,SKIP
30 S RXDT=+$P($G(^TMP("PS",$J,"RXN",0)),U,6),(NREF,NPAR)=0
31 S SKIP=(RXDT<STDT)!(RXDT'<ENDT)
32 ;--- Refills
33 S IRP=0
34 F S IRP=$O(^TMP("PS",$J,"REF",IRP)) Q:IRP'>0 D
35 . S RXDT=+$P($G(^TMP("PS",$J,"REF",IRP,0)),U)
36 . I RXDT'<STDT,RXDT<ENDT S SKIP=0,NREF=NREF+1 Q
37 . K ^TMP("PS",$J,"REF",IRP)
38 ;--- Partials
39 S IRP=0
40 F S IRP=$O(^TMP("PS",$J,"PAR",IRP)) Q:IRP'>0 D
41 . S RXDT=+$P($G(^TMP("PS",$J,"PAR",IRP,0)),U)
42 . I RXDT'<STDT,RXDT<ENDT S SKIP=0,NPAR=NPAR+1 Q
43 . K ^TMP("PS",$J,"PAR",IRP)
44 ;---
45 Q SKIP
46 ;
47 ;***** PROCESSES THE LIST OF PRESELECTED PHARMACY ORDERS
48 ;
49 ; PTIEN IEN of the patient (DFN)
50 ;
51 ; RORFLAGS Flags to control processing
52 ;
53 ; ROR8LST Closed root of the list of preselected orders
54 ;
55 ; Return Values:
56 ; <0 Error code
57 ; 0 No orders have been found
58 ; >0 Number of orders
59 ;
60PROCESS(PTIEN,RORFLAGS,ROR8LST) ;
61 N DRUGIEN,IRX,IVM,LOADEXT,ORDDATE,ORDER,ORDIEN,ORDFLG,RC,ROR8SET,RORLST,RORTMP,RORTS,RORXCNT,TMP
62 S LOADEXT=(RORFLAGS["E")
63 S (RC,RORXCNT)=0
64 S RORTMP=$$ALLOC^RORTMP(.RORTS)
65 ;
66 ;=== Determine the storage method (default or callback)
67 I $G(ROR8DST("RORCB"))?2"$"1.8UN1"^"1.8UN D
68 . S ROR8SET="S RC="_ROR8DST("RORCB")_"(.ROR8DST,ORDER"
69 . S ROR8SET=ROR8SET_",ORDFLG,DRUGIEN_U_DRUGNAME,ORDDATE)"
70 . ;---
71 . S ROR8DST("RORDFN")=PTIEN
72 . S ROR8DST("ROREDT")=ROREDT
73 . S ROR8DST("RORFLAGS")=RORFLAGS
74 . S ROR8DST("RORSDT")=RORSDT
75 E S ROR8SET="" K @ROR8DST
76 ;
77 ;=== Process the list of preselected orders
78 S (IRX,RC)=0
79 F S IRX=$O(@ROR8LST@(IRX)) Q:'IRX D Q:RC
80 . S ORDFLG=$P(@ROR8LST@(IRX),U)
81 . S TMP=@ROR8LST@(IRX,0)
82 . S ORDER=$P(TMP,U),ORDDATE=$P(TMP,U,15)
83 . ;--- Get the order details
84 . K ^TMP("PS",$J)
85 . D OEL^PSOORRL(PTIEN,ORDER)
86 . Q:$D(^TMP("PS",$J))<10
87 . ;=== Inpatient and Outpatient Medications
88 . I ORDFLG'["V" D Q
89 . . ;--- Double-check the dates for outpatient orders
90 . . I ORDFLG["O" Q:$$DTCHECK(RORSDT,ROREDT)
91 . . ;--- Get the drug IEN in the DRUG file (#50)
92 . . S TMP=$G(^TMP("PS",$J,"DD",1,0)),DRUGIEN=+$P(TMP,U,3)
93 . . I DRUGIEN'>0 S DRUGIEN=+$P(TMP,U) Q:DRUGIEN'>0
94 . . ;--- Process the order
95 . . S RC=$$PROCMED(ORDER,ORDFLG,DRUGIEN,ORDDATE)
96 . . S:'RC RORXCNT=RORXCNT+1
97 . . S:RC=1 RC=0
98 . ;=== IV Medications
99 . S RORLST=$$ALLOC^RORTMP(.TMP),ORDIEN=+ORDER
100 . D
101 . . N IEN,ORDER ; Workaround for the bug in the API
102 . . D PSS436^PSS55(PTIEN,ORDIEN,TMP)
103 . I $G(@RORLST@(0))'>0 D FREE^RORTMP(RORLST) Q
104 . ;--- Process the additives
105 . S IVM=0
106 . F S IVM=$O(@RORLST@(ORDIEN,"ADD",IVM)) Q:IVM'>0 D Q:RC
107 . . ;--- IEN in the IV ADDITIVES file (#52.6)
108 . . S DRUGIEN=+$P($G(@RORLST@(ORDIEN,"ADD",IVM,.01)),U)
109 . . Q:DRUGIEN'>0
110 . . ;--- IEN in the DRUG file (#50)
111 . . D ZERO^PSS52P6(DRUGIEN,,,RORTS)
112 . . Q:$G(@RORTMP@(0))'>0
113 . . S DRUGIEN=+$P($G(@RORTMP@(DRUGIEN,1)),U)
114 . . Q:DRUGIEN'>0
115 . . ;--- Process the medication
116 . . S RC=$$PROCMED(ORDER,ORDFLG,DRUGIEN,ORDDATE)
117 . . S:'RC RORXCNT=RORXCNT+1
118 . . S:RC=1 RC=0
119 . ;---
120 . D FREE^RORTMP(RORLST)
121 ;
122 ;===
123 D FREE^RORTMP(RORTMP)
124 Q $S(RC<0:RC,1:RORXCNT)
125 ;
126 ;***** PROCESS THE MEDICATION (internal)
127 ;
128 ; DRUGIEN IEN of the medication in the DRUG file (#50)
129 ;
130 ; The ROR8DST, ROR8RXS, ROR8SET, RORTMP, and RORTS variables
131 ; must be defined before calling this function.
132 ;
133 ; Return Values:
134 ; <0 Error code
135 ; 0 Ok
136 ; 1 Skip this medication
137 ; 2 Skip this and all remaining medications
138 ;
139PROCMED(ORDER,ORDFLG,DRUGIEN,ORDDATE) ;
140 N DRUGNAME,RC,ROR8BUF,SKIP,TMP
141 S RC=0
142 ;=== Load some drug data
143 D ARWS^PSS50(DRUGIEN,,RORTS) K ROR8BUF
144 F TMP=2,20,25 S ROR8BUF(TMP)=$G(@RORTMP@(DRUGIEN,TMP))
145 S DRUGNAME=$G(@RORTMP@(DRUGIEN,.01))
146 S:DRUGNAME="" DRUGNAME="Unknown (IEN="_DRUGIEN_")"
147 K @RORTMP
148 ;--- Generic Drug
149 S ROR8DST("RORXGEN")=ROR8BUF(20)
150 I $P(ROR8BUF(20),U,2)="" D S $P(ROR8DST("RORXGEN"),U,2)=TMP
151 . S TMP="Unknown ("_(+ROR8BUF(20))_")"
152 ;--- VA Drug Class
153 S ROR8DST("RORXVCL")=""
154 D:ROR8BUF(2)'=""
155 . ;--- If the "national" drug class is the same, use its IEN
156 . I $P(ROR8BUF(25),U,2)=ROR8BUF(2) D Q
157 . . S ROR8DST("RORXVCL")=$P(ROR8BUF(25),U,1,2)
158 . ;--- Get the Drug Class IEN
159 . D IEN^PSN50P65(,ROR8BUF(2),RORTS)
160 . S TMP=+$G(@RORTMP@(0))
161 . S:TMP=1 ROR8DST("RORXVCL")=+$O(@RORTMP@(0))_U_ROR8BUF(2)
162 . K @RORTMP
163 ;
164 ;=== Check if the drug should be skipped
165 I ROR8RXS'="*" S SKIP=0 D Q:SKIP 1
166 . Q:$D(@ROR8RXS@(DRUGIEN))
167 . I $D(@ROR8RXS@("C"))>1 Q:$D(@ROR8RXS@("C",+ROR8DST("RORXVCL")))
168 . I $D(@ROR8RXS@("G"))>1 Q:$D(@ROR8RXS@("G",+ROR8DST("RORXGEN")))
169 . S SKIP=1
170 ;
171 ;--- Load additional drug data
172 ;D:LOADEXT
173 ;.
174 ;
175 ;=== Default output
176 I ROR8SET="" D Q 0
177 . S RORXCNT=RORXCNT+1
178 . M @ROR8DST@(RORXCNT)=^TMP("PS",$J)
179 . S TMP=ORDER_U_ORDFLG_U_ROR8DST("RORXGEN")
180 . S $P(TMP,U,5,6)=ROR8DST("RORXVCL")
181 . S @ROR8DST@(RORXCNT)=TMP
182 ;=== Callback function
183 X ROR8SET ; (.ROR8DST,ORDER,ORDFLG,DRUGIEN_U_DRUGNAME,ORDDATE)
184 Q RC
185 ;
186 ;***** LOADS AND PRESELECTS PHARMACY ORDERS
187 ;
188 ; PTIEN IEN of the patient (DFN)
189 ;
190 ; FLAGS Flags to control processing
191 ;
192 ; STDT Start date (FileMan)
193 ; ENDT End date (FileMan)
194 ;
195 ; ROR8LST Closed root for the list of preselected orders
196 ;
197 ; @ROR8LST@(
198 ; Seq#, Flags that describe the order (I,O,P, etc.)
199 ; 0) Content of the ^TMP("PS",$J,i,0) node
200 ; returned by the OCL^PSOORRL (see the DBIA
201 ; #2400 for details).
202 ;
203 ; Return Values:
204 ; <0 Error code
205 ; 0 No orders have been found
206 ; >0 Number of orders
207 ;
208QUERY(PTIEN,FLAGS,STDT,ENDT,ROR8LST) ;
209 N IEN,IRX,ORDER,RXCNT,TMP,TYPE
210 K ^TMP("PS",$J),@ROR8LST
211 ;
212 ;--- Prepare the flags
213 I FLAGS["I" D S TYPE("U;I")="I"
214 . S:FLAGS["P" TYPE("P;I")="IP"
215 . S:FLAGS["V" TYPE("V;I")="IV"
216 I FLAGS["O" D S TYPE("R;O")="O"
217 . S:FLAGS["P" TYPE("P;O")="OP"
218 ;
219 ;--- Load the list of pharmacy orders
220 D OCL^PSOORRL(PTIEN,STDT,ENDT)
221 Q:$D(^TMP("PS",$J))<10 0
222 ;
223 ;--- Preselect the orders
224 S (IRX,RXCNT)=0
225 F S IRX=$O(^TMP("PS",$J,IRX)) Q:'IRX D
226 . S ORDER=$P($G(^TMP("PS",$J,IRX,0)),U) Q:ORDER'>0
227 . ;--- Check the type of order
228 . S TMP=$L(ORDER),TYPE=$E(ORDER,TMP-2,TMP)
229 . S TYPE=$G(TYPE(TYPE)) Q:TYPE=""
230 . ;--- Double-check the dates
231 . I TYPE["I" D Q:(TMP<STDT)!(TMP'<ENDT)
232 . . S TMP=+$P($G(^TMP("PS",$J,IRX,0)),U,15)
233 . I TYPE["O" D Q:TMP<STDT
234 . . S TMP=+$P($G(^TMP("PS",$J,IRX,0)),U,10)
235 . ;--- Select the order
236 . S RXCNT=RXCNT+1,@ROR8LST@(RXCNT)=TYPE
237 . S @ROR8LST@(RXCNT,0)=^TMP("PS",$J,IRX,0)
238 ;
239 ;--- Cleanup
240 K ^TMP("PS",$J)
241 Q RXCNT
Note: See TracBrowser for help on using the repository browser.