source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWPS.m@ 613

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

initial load of WorldVistAEHR
File size: 8.4 KB
Line 
1ORWPS ; SLC/KCM/JLI/REV/CLA - Meds Tab; 02/11/2008
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,141,173,203,190,195,265,275,243**;Dec 17, 1997;Build 242
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4COVER(LST,DFN) ; retrieve meds for cover sheet
5 K ^TMP("PS",$J)
6 D OCL^PSOORRL(DFN,"","")
7 N ILST,ITMP,X S ILST=0
8 S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D
9 . S X=^TMP("PS",$J,ITMP,0)
10 . I '$L($P(X,U,2)) S X="??" ; show something if drug empty
11 . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)_U_"C"
12 . E S LST($$NXT)=$P(X,U,1,2)_U_$P(X,U,8,9)
13 K ^TMP("PS",$J)
14 Q
15DT(X) ; -- Returns FM date for X
16 N Y,%DT S %DT="T",Y="" D:X'="" ^%DT
17 Q Y
18 ;
19ACTIVE(LST,DFN,USER,VIEW,UPDATE) ; retrieve active inpatient & outpatient meds
20 K ^TMP("PS",$J)
21 K ^TMP("ORACT",$J)
22 N BEG,END,ERROR,CTX,STVIEW
23 S (BEG,END,CTX)=""
24 S VIEW=+$G(VIEW)
25 S UPDATE=+$G(UPDATE)
26 I VIEW=0,UPDATE=0 S VIEW=1
27 S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
28 I CTX=";" D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT MEDS")
29 S CTX=$$GET^XPAR("ALL","ORCH CONTEXT MEDS")
30 S BEG=$$DT($P(CTX,";")),END=$$DT($P(CTX,";",2))
31 I +$G(USER)=0 S USER=DUZ
32 I UPDATE=1 D
33 .S STVIEW=$$GET^XPAR($G(USER)_";VA(200,","OR MEDS TAB SORT",1,"I")
34 .I VIEW>0,+STVIEW'=VIEW D PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,VIEW,.ERROR) S STVIEW=VIEW
35 .I VIEW=0,+STVIEW=0 D PUT^XPAR(DUZ_";VA(200,","OR MEDS TAB SORT",,"1",.ERROR) S STVIEW=1,VIEW=1
36 .I VIEW=0,+STVIEW'=VIEW S VIEW=+STVIEW
37 .S LST(0)=STVIEW
38 D OCL^PSOORRL(DFN,BEG,END,VIEW)
39 N ITMP,FIELDS,INSTRUCT,COMMENTS,REASON,NVSDT,TYPE,ILST,J S ILST=0
40 S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D
41 . K INSTRUCT,COMMENTS,REASON
42 . K ^TMP("ORACT",$J,"COMMENTS")
43 . S COMMENTS="^TMP(""ORACT"",$J,""COMMENTS"")"
44 . S (INSTRUCT,@COMMENTS)="",FIELDS=^TMP("PS",$J,ITMP,0)
45 . I +$P(FIELDS,"^",8),$D(^OR(100,+$P(FIELDS,"^",8),8,"C","XX")) D
46 . . S $P(^TMP("PS",$J,ITMP,0),"^",2)="*"_$P(^TMP("PS",$J,ITMP,0),"^",2) ;dan testing
47 . S TYPE=$S($P($P(FIELDS,U),";",2)="O":"OP",1:"UD")
48 . I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S TYPE="CP"
49 . N LOC,LOCEX S (LOC,LOCEX)=""
50 . I TYPE="CP" S LOC=$G(^TMP("PS",$J,ITMP,"CLINIC",0))
51 . S:LOC LOCEX=$P($G(^SC(+LOC,0)),U)_":"_+LOC ;IMO NEW
52 . I TYPE="OP",$P(FIELDS,";")["N" S TYPE="NV" ;non-VA med
53 . I $O(^TMP("PS",$J,ITMP,"A",0))>0 S TYPE="IV"
54 . I $O(^TMP("PS",$J,ITMP,"B",0))>0 S TYPE="IV"
55 . I (TYPE="UD")!(TYPE="CP") D UDINST(.INSTRUCT,ITMP)
56 . I TYPE="OP" D OPINST(.INSTRUCT,ITMP)
57 . I TYPE="IV" D IVINST(.INSTRUCT,ITMP)
58 . I TYPE="NV" D NVINST(.INSTRUCT,ITMP),NVREASON(.REASON,.NVSDT,ITMP)
59 . I (TYPE="UD")!(TYPE="IV")!(TYPE="NV")!(TYPE="CP") D SETMULT(COMMENTS,ITMP,"SIO")
60 . M COMMENTS=@COMMENTS
61 . I $D(COMMENTS(1)) S COMMENTS(1)="\"_COMMENTS(1)
62 . S:TYPE="NV" $P(FIELDS,U,4)=$G(NVSDT)
63 . I LOC S LST($$NXT)="~CP:"_LOCEX_U_FIELDS
64 . E S LST($$NXT)="~"_TYPE_U_FIELDS
65 . S J=0 F S J=$O(INSTRUCT(J)) Q:'J S LST($$NXT)=INSTRUCT(J)
66 . S J=0 F S J=$O(COMMENTS(J)) Q:'J S LST($$NXT)="t"_COMMENTS(J)
67 . S J=0 F S J=$O(REASON(J)) Q:'J S LST($$NXT)="t"_REASON(J)
68 K ^TMP("PS",$J)
69 K ^TMP("ORACT",$J)
70 Q
71NXT() ; increment ILST
72 S ILST=ILST+1
73 Q ILST
74 ;
75UDINST(Y,INDEX) ; assembles instructions for a unit dose order
76 N I,X,RST
77 S X=^TMP("PS",$J,INDEX,0)
78 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
79 S @RST@(1)=" "_$P(X,U,2),@RST=1
80 S X=$S($L($P(X,U,6)):$P(X,U,6),1:$P(X,U,7))
81 I $L(X) S @RST=2,@RST@(2)=X
82 E S @RST=1 D SETMULT(.RST,INDEX,"SIG")
83 S @RST@(2)="\Give: "_$G(@RST@(2)),@RST=$G(@RST,2)
84 D SETMULT(RST,INDEX,"MDR"),SETMULT(RST,INDEX,"SCH")
85 F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
86 M Y=@RST K @RST
87 Q
88OPINST(Y,INDEX) ; assembles instructions for an outpatient prescription
89 N I,X,RST
90 S X=^TMP("PS",$J,INDEX,0)
91 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
92 S @RST@(1)=" "_$P(X,U,2),@RST=1
93 I $L($P(X,U,12)) S @RST@(1)=@RST@(1)_" Qty: "_$P(X,U,12)
94 I $L($P(X,U,11)) S @RST@(1)=@RST@(1)_" for "_$P(X,U,11)_" days"
95 D SETMULT(RST,INDEX,"SIG")
96 I @RST=1 D
97 . D SETMULT(RST,INDEX,"SIO")
98 . D SETMULT(RST,INDEX,"MDR")
99 . D SETMULT(RST,INDEX,"SCH")
100 S @RST@(2)="\ Sig: "_$G(@RST@(2))
101 F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
102 M Y=@RST K @RST
103 Q
104IVINST(Y,INDEX) ; assembles instructions for an IV order
105 N SOLN1,I,RST,IVDUR,CNT
106 S IVDUR=""
107 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
108 S @RST=0 D SETMULT(RST,INDEX,"A") S SOLN1=@RST+1
109 D SETMULT(RST,INDEX,"B")
110 I $D(@RST@(SOLN1)),$L($P(FIELDS,U,2)) S @RST@(SOLN1)="in "_@RST@(SOLN1)
111 S SOLN1=@RST+1
112 S CNT=@RST
113 D SETMULT(RST,INDEX,"MDR")
114 I $D(^TMP("PS",$J,INDEX,"SCH",1,0)) S @RST@(@RST)=@RST@(@RST)_" "_^TMP("PS",$J,INDEX,"SCH",1,0)
115 F I=1:1:@RST S @RST@(I)="\"_$TR(@RST@(I),U," ")
116 I $D(@RST@(1)) S @RST@(1)=" "_$E(@RST@(1),2,999)
117 S @RST@(@RST)=@RST@(@RST)_" "_$P(^TMP("PS",$J,INDEX,0),U,3)
118 S:$D(^TMP("PS",$J,INDEX,"IVLIM",0)) IVDUR=$G(^TMP("PS",$J,INDEX,"IVLIM",0))
119 I $L(IVDUR) D
120 . N DURU,DURV S DURU="",DURV=0
121 . I IVDUR["dose" D Q
122 . .S DURV=$P(IVDUR,"doses",2)
123 . .S IVDUR="for a total of "_+DURV_$S(+DURV=1:"dose",+DURV>1:" doses",1:" dose")
124 . .S @RST@(@RST)=@RST@(@RST)_" "_IVDUR
125 . S DURU=$E(IVDUR,1),DURV=$E(IVDUR,2,$L(IVDUR))
126 . I (DURU="D")!(DURU="d") S IVDUR="for "_+DURV_$S(+DURV=1:" day",+DURV>1:" days",1:" day")
127 . I (DURU="H")!(DURU="h") S IVDUR="for "_+DURV_$S(+DURV=1:" hours",+DURV>1:" hours",1:" hour")
128 . I (DURU="M")!(DURU="m") S IVDUR="with total volume "_+DURV_" ml"
129 . I (DURU="L")!(DURU="l") S IVDUR="with total volume "_+DURV_" L"
130 . S @RST@(@RST)=@RST@(@RST)_" "_IVDUR
131 M Y=@RST K @RST
132 Q
133NVINST(Y,INDEX) ; assembles instructions for a non-VA med
134 N I,X,RST
135 S X=^TMP("PS",$J,INDEX,0)
136 S RST="^TMP(""ORACT"",$J,""INSTRUCT"")"
137 S @RST@(1)=" "_$P(X,U,2),@RST=1
138 D SETMULT(RST,INDEX,"SIG")
139 I @RST=1 D
140 . D SETMULT(RST,INDEX,"SIO")
141 . D SETMULT(RST,INDEX,"MDR")
142 . D SETMULT(RST,INDEX,"SCH")
143 S @RST@(2)="\ "_$G(@RST@(2))
144 F I=3:1:@RST S @RST@(I)=" "_@RST@(I)
145 M Y=@RST K @RST
146 Q
147NVREASON(ORR,NVSDT,INDEX) ; assembles start date and reasons for a non-VA med
148 N ORI,J,X,ORN,ORA
149 S ORI=0 K ORR
150 S X=^TMP("PS",$J,INDEX,0)
151 S ORN=+$P(X,U,8)
152 I $D(^OR(100,ORN,0)) D
153 .S NVSDT=$P(^OR(100,ORN,0),U,8)
154 .D WPVAL^ORWDXR(.ORA,ORN,"STATEMENTS") I $D(ORA) D
155 ..S J=0 F S J=$O(ORA(J)) Q:J<1 S ORI=ORI+1,ORR(ORI)=ORA(J)
156 Q
157SETMULT(Y,INDEX,SUB) ; appends the multiple at the subscript to Y
158 N I,X,J
159 S J=$G(@Y)
160 S I=0 F S I=$O(^TMP("PS",$J,INDEX,SUB,I)) Q:'I S X=$G(^(I,0)) D
161 . I SUB="B",$L($P(X,U,3)) S X=$P(X,U)_" "_$P(X,U,3)_"^"_$P(X,U,2)
162 . S J=J+1,@Y@(J)=X
163 S @Y=J
164 Q
165COMPRESS(Y) ; concatenate Y subscripts into smallest possible number
166 N I,J,X S J=1,X(J)=""
167 S I=0 F S I=$O(Y(I)) Q:'I D
168 . I ($L(Y(I))+$L(X(J)))>245 S J=J+1,X(J)=""
169 . S X(J)=X(J)_$S($L(X(J)):" ",1:"")_Y(I)
170 K Y M Y=X
171 Q
172DETAIL(ROOT,DFN,ID) ; -- show details for a med order
173 K ^TMP("ORXPND",$J)
174 N LCNT,ORVP
175 S LCNT=0,ORVP=DFN_";DPT("
176 D MEDS^ORCXPND1
177 S ROOT=$NA(^TMP("ORXPND",$J))
178 Q
179MEDHIST(ORROOT,DFN,ORIFN) ; -- show admin history for a med (RV)
180 N ORPSID,HPIV,ISIV,CKPKG,ORPHMID
181 N CLINDISP,IVDIAL
182 S ORPSID=+$P($$OI^ORX8(ORIFN),U,3),ISIV=0,HPIV=0
183 S ORROOT=$NA(^TMP("ORHIST",$J)) K @ORROOT
184 S ORPHMID=$G(^OR(100,+ORIFN,4)) ;Pharmacy order number
185 S ISIV=$O(^ORD(100.98,"B","IV RX",ISIV))
186 S HPIV=$O(^ORD(100.98,"B","TPN",HPIV))
187 S CLINDISP=$O(^ORD(100.98,"B","C RX",""))
188 S IVDIAL=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",""))
189 S CKPKG=$$PATCH^XPDUTL("PSB*2.0*19")
190 ;if the order is pending or the order has no pharmacy #
191 ;or the order is not in the Display Group IV MEDICATION
192 ; then use the Orderable item number to get the MAH.
193 I (ORPHMID["P")!(ORPHMID="") D Q
194 . I '$L($T(HISTORY^PSBMLHS)) D Q
195 . . S @ORROOT@(0)="This report is only available using BCMA version 2.0."
196 . D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0
197 ; If the order has a Display Group of IV MEDICATION the use the Pharmacy order number to get the MA
198 I ($P($G(^OR(100,+ORIFN,0)),U,11)=ISIV)!($P($G(^OR(100,+ORIFN,0)),U,11)=HPIV)!(($P($G(^OR(100,+ORIFN,0)),U,11)=CLINDISP)&(+$P($G(^OR(100,+ORIFN,0)),U,5)=IVDIAL)) D Q
199 . I 'CKPKG S @ORROOT@(0)="Medication Administration History is not available at this time for IV fluids."
200 . I CKPKG D
201 . . D RPC^PSBO(.ORROOT,"PM",DFN,"","","","","","","","","",ORPHMID) ;DBIA #3955
202 . . I '$D(@ORROOT) S @ORROOT@(0)="No Medication Administration History found for the IV order."
203 I '$L($T(HISTORY^PSBMLHS)) D Q
204 . S @ORROOT@(0)="This report is only available using BCMA version 2.0."
205 D HISTORY^PSBMLHS(.ORROOT,DFN,ORPSID) ; DBIA #3459 for BCMA v2.0
206 Q
207 ;
208REASON(ORY) ; -- Return Non-VA Med Statement/Reasons
209 N ORE
210 D GETLST^XPAR(.ORY,"ALL","ORWD NONVA REASON","E")
211 Q
Note: See TracBrowser for help on using the repository browser.