source: FOIAVistA/tag/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORKPS.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 7.3 KB
Line 
1ORKPS ; slc/CLA - Order checking support procedures for medications ;12/15/97 [8/10/05 3:20pm]
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,74,94,123,141,190,232**;Dec 17, 1997;Build 19
3 Q
4CHECK(YY,DFN,MED,OI,ORKDG) ; return drug order checks
5 ;YY: returned array of data
6 ;DFN: patient id
7 ;MED: drug ien [file #50]
8 ;OI: orderable item ien [file #101.43
9 ;ORKDG: display group (should be PSI, PSIV, PSO or PSH)
10 ; returned info: varies for ^TMP($J x-ref - refer to listings below
11 K ^TMP($J,"DI"),^TMP($J,"DD"),^TMP($J,"DC")
12 N ORDFN S ORDFN=DFN
13 D EN^PSOORDRG(DFN,MED)
14 D PROCESS^ORKPS1(OI,ORDFN,ORKDG)
15 K ^TMP($J,"DI"),^TMP($J,"DD"),^TMP($J,"DC")
16 Q
17CHKSESS(YY,DFN,MED,OI,ORKPDATA,ORKDG) ; return drug order checks for session
18 N ORKDGI,ORKDRUG,ORKDRUGA,ORKORN,HOR,SEQ,CNT,CNTX,ORKOI
19 N ORKFLG,ORSESS,ORPSPKG,ORPSA,ORKDD,ORSNUM,ORNUM,DUPX,DUPORN
20 N ORDFN S ORDFN=DFN
21 S ORKFLG=0
22 S ORNUM=$P(ORKA,"|",5)
23 ;
24 ;get other session med orders:
25 I $D(^TMP("ORKA",$J)) D
26 .S CNT=^TMP("ORKA",$J) F CNTX=1:1:CNT D
27 ..S ORSESS=$G(^TMP("ORKA",$J,CNTX))
28 ..Q:'$L(ORSESS)
29 ..S ORPSPKG=$P(ORSESS,"|",2)
30 ..Q:'$L(ORPSPKG)
31 ..Q:$E(ORPSPKG,1,2)'="PS"
32 ..S ORSNUM=$P(ORSESS,"|",5)
33 ..S ORKOI=$P(ORSESS,"|")
34 ..;quit if same order/oi:
35 ..Q:((+$G(ORNUM)=+$G(ORSNUM))&(+$G(OI)=+$G(ORKOI)))
36 ..S:ORPSPKG="PSJ" ORPSPKG="PSI"
37 ..S ORKDRUG=$P($P(ORSESS,"|",3),U,4)
38 ..;
39 ..;if no disp drug selected get disp drug(s) from OI:
40 ..I +$G(ORKDRUG)<1,$L(ORKOI) D
41 ...I "IOH"[$E(ORPSPKG,3) D OI2DD(.ORPSA,ORKOI,$E(ORPSPKG,3)) D
42 ....S ORKDD=0 F S ORKDD=$O(ORPSA(ORKDD)) Q:'ORKDD D
43 .....S ORKDRUG=+ORKDD
44 .....S:+$G(ORKDRUG)>0 ORKDRUGA(ORKDRUG_";"_ORPSPKG_";"_ORSNUM)=ORSNUM
45 ...K ORPSA ;need to clean out between calls to OI2DD
46 ..;
47 ..Q:+$G(ORKDRUG)<1
48 ..;if dispense drug selected add to array:
49 ..S ORKDRUGA(ORKDRUG_";"_ORPSPKG_";"_ORSNUM)=ORSNUM
50 ;
51 ;get unsigned medication orders:
52 S HOR=0,SEQ=0
53 S HOR=$O(^TMP("ORR",$J,HOR)) I +$G(HOR)>0 D
54 .F S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1 D
55 ..S ORKORN=+$P(^TMP("ORR",$J,HOR,SEQ),U),DUPORN=0
56 ..Q:+$G(ORKORN)<1
57 ..Q:+ORKORN=+ORNUM
58 ..Q:$P(^OR(100,+ORKORN,8,$P(^OR(100,+ORKORN,8,0),U,3),0),U,2)="DC"
59 ..Q:$P(^ORD(100.01,$P(^OR(100,+ORKORN,3),U,3),0),U)="DISCONTINUED"
60 ..S ORKDRUG=$$VALUE^ORCSAVE2(+ORKORN,"DRUG") ;get disp drug for order
61 ..;only process vs. unsigned med order if disp drug is assoc w/order:
62 ..Q:+$G(ORKDRUG)<1
63 ..S ORPSPKG=$$DGRX^ORQOR2(+ORKORN)
64 ..S ORPSPKG=$S(ORPSPKG="UNIT DOSE MEDICATIONS":"PSI",ORPSPKG="OUTPATIENT MEDICATIONS":"PSO",ORPSPKG="IV MEDICATIONS":"PSIV",ORPSPKG="NON-VA MEDICATIONS":"PSH",1:"")
65 ..S DUPX="" F S DUPX=$O(ORKDRUGA(DUPX)) Q:'DUPX!(DUPORN=1) D
66 ...S:ORKORN=ORKDRUGA(DUPX) DUPORN=1
67 ..Q:DUPORN=1 ;quit if already processed drug order
68 ..S ORKDRUGA(+ORKDRUG_";"_ORPSPKG_";"_ORKORN)=ORKORN
69 ;
70 K ^TMP($J,"DI"),^TMP($J,"DD"),^TMP($J,"DC")
71 I $D(ORKDRUGA) D DRGCHK^PSOORDRG(DFN,MED,.ORKDRUGA)
72 ;I '$D(ORKDRUGA) D EN^PSOORDRG(DFN,MED)
73 D PROCESS^ORKPS1(OI,ORDFN,ORKDG)
74 K ^TMP($J,"DI"),^TMP($J,"DD"),^TMP($J,"DC")
75 Q
76TAKEMED(ORKDFN,ORKMED) ;extrinsic function returns med orderable item if any
77 ;active med patient is taking contains any piece of ORKMED
78 ;ORKDFN patient DFN
79 ;ORKMED meds to check vs. active med list in format MED1^MED2^MED3...
80 Q:'$L($G(ORKDFN)) "0^Patient not identified."
81 Q:'$L($G(ORKMED)) "0^Medication not identified."
82 N ORKARX,ORKY,ORI,ORJ,ORCNT,ORKMEDP,ORKRSLT
83 D LIST^ORQQPS(.ORKY,ORKDFN,"","")
84 Q:$P(ORKY(1),U)="" "0^No active meds found."
85 S ORKRSLT="0^No matching meds found."
86 S ORCNT=$L(ORKMED,U)
87 S ORI=0 F S ORI=$O(ORKY(ORI)) Q:ORI<1 D
88 .S ORKARX=$P(ORKY(ORI),U,2)
89 .F ORJ=1:1:ORCNT S ORKMEDP=$P(ORKMED,U,ORJ) D
90 ..I $L(ORKMEDP),(ORKARX[ORKMEDP) S ORKRSLT="1^"_ORKARX
91 Q ORKRSLT
92SOLUT(OI) ;extrinsic function returns 1 (true) if the orderable item is
93 ; a solution (IV Base)
94 Q:+$G(OI)<1 ""
95 N OITEXT
96 S OITEXT=$G(^ORD(101.43,OI,0))
97 Q:'$L(OITEXT) ""
98 S OITEXT=$P(OITEXT,U)
99 Q:$D(^ORD(101.43,"S.IVB RX",OITEXT)) 1
100 Q ""
101POLYRX(DFN) ;extrins funct rtns 1 if patient exceeds polypharmacy, 0 if not
102 N ORSLT,ORENT,ORLOC,ORPAR,ORMEDS
103 S ORSLT=0
104 Q:'$L(DFN) ORSLT
105 S VA200="" D OERR^VADPT
106 S ORLOC=+$G(^DIC(42,+VAIN(4),44))
107 K VA200,VAIN
108 S ORENT=+$G(ORLOC)_";SC(^DIV^SYS^PKG"
109 S ORPAR=$$GET^XPAR(ORENT,"ORK POLYPHARMACY",1,"I")
110 S ORMEDS=$$NUMRX(DFN)
111 I $G(ORMEDS)>$G(ORPAR) S ORSLT=1
112 Q ORSLT
113GLCREAT(DFN) ;extrinsic function returns patient's (DFN) most recent serum
114 ; creatinine within # of days from parameter ORK GLUCOPHAGE CREATININE
115 ; results format: test id^result units flag ref range collect d/t^result
116 ; used by order check GLUCOPHAGE-LAB RESULTS
117 N ORLOC,ORPAR,ORDAYS
118 N BDT,CDT,ORY,ORX,ORZ,TEST,ORI,ORJ,CREARSLT,LABFILE,SPECFILE,SPECIMEN
119 Q:'$L(DFN) "0^"
120 S ORDAYS=$$GCDAYS(DFN)
121 Q:'$L(ORDAYS) "0^"
122 D NOW^%DTC
123 S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","")
124 K %
125 Q:'$L($G(BDT)) "0^"
126 S LABFILE=$$TERMLKUP^ORB31(.ORY,"SERUM CREATININE")
127 Q:'$D(ORY) "0^" ;no link between SERUM CREATININE and local lab test
128 Q:$G(LABFILE)'=60 "0^"
129 S SPECFILE=$$TERMLKUP^ORB31(.ORX,"SERUM SPECIMEN")
130 Q:'$D(ORX) "0^" ;no link between SERUM SPECIMEN and local specimen
131 Q:$G(SPECFILE)'=61 "0^"
132 F ORI=1:1:ORY I +$G(CREARSLT)<1 D
133 .S TEST=$P(ORY(ORI),U)
134 .Q:+$G(TEST)<1
135 .F ORJ=1:1:ORX I +$G(CREARSLT)<1 D
136 ..S SPECIMEN=$P(ORX(ORJ),U)
137 ..Q:+$G(SPECIMEN)<1
138 ..S ORZ=$$LOCL^ORQQLR1(DFN,TEST,SPECIMEN)
139 ..Q:'$L($G(ORZ))
140 ..S CDT=$P(ORZ,U,7)
141 ..I CDT'<BDT S CREARSLT=1
142 Q:+$G(CREARSLT)<1 "0^"
143 Q $P(ORZ,U)_U_$P(ORZ,U,3)_" "_$P(ORZ,U,4)_" "_$P(ORZ,U,5)_" ("_$P(ORZ,U,6)_") "_$$FMTE^XLFDT(CDT,"2P")_U_$P(ORZ,U,3)
144GCDAYS(DFN) ;extrinsic function to return number of days to look for
145 ; glucophage serum creatinine result
146 Q:'$L(DFN) ""
147 N ORLOC,ORENT,ORDAYS
148 ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
149 ;reliably determined, and many simultaneous outpt locations can occur):
150 S VA200="" D OERR^VADPT
151 S ORLOC=+$G(^DIC(42,+VAIN(4),44))
152 K VA200,VAIN
153 S ORENT=+$G(ORLOC)_";SC(^DIV^SYS^PKG"
154 S ORDAYS=$$GET^XPAR(ORENT,"ORK GLUCOPHAGE CREATININE",1,"I")
155 Q:$L(ORDAYS) ORDAYS
156 Q ""
157SUPPLY(OI) ;extrinsic function returns 1 (true) if the orderable item is
158 ; a supply
159 Q:+$G(OI)<1 ""
160 N OITEXT
161 S OITEXT=$G(^ORD(101.43,OI,0))
162 Q:'$L(OITEXT) ""
163 S OITEXT=$P(OITEXT,U)
164 Q:$D(^ORD(101.43,"S.SPLY",OITEXT)) 1
165 Q ""
166NUMRX(DFN) ;extrinsic funct returns number of active meds patient is taking
167 N NUMRX,ORPTYPE,ORX,ORY,ORS,ORNUM,ORPRENEW
168 S NUMRX=0
169 Q:+$G(DFN)<1 NUMRX
170 ;
171 ;check to determine if inpatient or outpatient:
172 D ADM^VADPT2
173 S ORPTYPE=$S(+$G(VADMVT)>0:"I",1:"O")
174 ;
175 K ^TMP("PS",$J)
176 D OCL^PSOORRL(DFN,"","") ;if no date range, returns active meds for pt
177 N X
178 S X=0
179 F S X=$O(^TMP("PS",$J,X)) Q:X<1 D
180 .S ORX=$G(^TMP("PS",$J,X,0))
181 .S ORY=$P(ORX,U)
182 .S ORNUM=$P(ORX,U,8) ;order entry order number
183 .S ORS=$P(ORX,U,9) ;medication status from pharmacy
184 .S ORPRENEW=$P(ORX,U,14) ;pending renewal flag (1: pending renewal)
185 .Q:+ORX<1
186 .Q:$P(ORY,";",2)'=ORPTYPE ;quit if med is not pt type (inpt/outpt)
187 .;quit if status is a non-active type:
188 .Q:$G(ORS)="EXPIRED"
189 .Q:$G(ORS)["DISCONTINUE"
190 .Q:$G(ORS)="DELETED"
191 .Q:+$G(ORPRENEW)>0
192 .Q:$$SUPPLY($$OI^ORQOR2(ORNUM))=1 ;quit if a supply
193 .S NUMRX=NUMRX+1
194 K ^TMP("PS",$J)
195 Q NUMRX
196OI2DD(ORPSA,OROI,ORPSPKG) ;rtn dispense drugs for a PS OI
197 N PSOI
198 Q:'$D(^ORD(101.43,OROI,0))
199 S PSOI=$P($P(^ORD(101.43,OROI,0),U,2),";")
200 Q:+$G(PSOI)<1
201 S:ORPSPKG="H" ORPSPKG="X" ;if non-va med need to pass api "X"
202 D DRG^PSSUTIL1(.ORPSA,PSOI,ORPSPKG)
203 Q
Note: See TracBrowser for help on using the repository browser.