source: FOIAVistA/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA32.m@ 1071

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

initial load of FOIAVistA 6/30/08 version
File size: 8.8 KB
Line 
1ORBCMA32 ; SLC/JLI - Pharmacy Calls for GUI Dialog ;01/17/02
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,237**;Dec 17, 1997
3 ;;BCMA ORDER V1.0 ;**133,237**;Jan 17, 2002
4 ;
5NXT() ; -- returns next available index in return data array
6 S ILST=ILST+1
7 Q ILST
8 ;
9DLGSLCT(LST,PSTYPE) ; return default lists for dialog
10 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient)
11 N ILST S ILST=0
12 I PSTYPE="F" D Q ; IV Fluids
13 . S LST($$NXT)="~ShortList" D SHORT
14 . S LST($$NXT)="~Priorities" D PRIOR
15 ;
16 S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpatient
17 S LST($$NXT)="~Schedules" D SCHED
18 S LST($$NXT)="~Priorities" D PRIOR
19 I PSTYPE="O" D ; Outpatient
20 . S LST($$NXT)="~Pickup" D PICKUP
21 . S LST($$NXT)="~SCStatus" D SCLIST
22 Q
23SHORT ; from DLGSLCT, get short list of med quick orders
24 ; !!! change this so that it uses the ORWDXQ call!!!
25 N I,X,TMP
26 I PSTYPE="U" S X="UD RX"
27 I PSTYPE="F" S X="IV RX"
28 I PSTYPE="O" S X="O RX"
29 D GETQLST^ORWDXQ(.TMP,X,"iQ")
30 S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I)
31 Q
32SCHED ; from DLGSLCT, get all pharmacy administration schedules
33 N X
34 S X="" F S X=$O(^PS(51.1,"APPSJ",X)) Q:X="" S LST($$NXT)="i"_X
35 Q
36SCHEDA ; (similar to SCHED, but also returns administration times)
37 N X,IEN,SCH
38 S SCH="" F S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH="" D
39 . S IEN=0 F S IEN=$O(^PS(51.1,"APPSJ",SCH,IEN)) Q:IEN'>0 D
40 . . S X=^PS(51.1,IEN,0) S X=$S($L($P(X,U,2)):" ("_$P(X,U,2)_")",1:"")
41 . . S LST($$NXT)="i"_IEN_U_SCH_X
42 Q
43PRIOR ; from DLGSLCT, get list of allowed priorities
44 N X,XREF
45 S X=0
46 S X=$O(^ORD(101.42,"B","DONE",X))
47 S LST($$NXT)="i"_X_U_$P(^ORD(101.42,X,0),U,2)
48 Q
49PICKUP ; from DLGSLCT, get prescription routing
50 N X,EDITONLY
51 F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X
52 S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X
53 Q
54DEFPICK() ; return default routing
55 N X,DLG,PRMT
56 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X=""
57 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0))
58 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1)
59 I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action
60 ;
61 S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I")
62 I X="C" S X="C^in Clinic" G XPICK
63 I X="M" S X="M^by Mail" G XPICK
64 I X="W" S X="W^at Window" G XPICK
65 I X="N" S X="" G XPICK
66 I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window")
67XPICK Q X
68 ;
69SCLIST ; from DLGSLCT, get options for service connected
70 F X="0^No","1^Yes" S LST($$NXT)="i"_X
71 Q
72 ;
73OISLCT(LST,OI,PSTYPE,ORVP) ; return for defaults for pharmacy orderable item
74 N ILST S ILST=0
75 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
76 S LST($$NXT)="~Dispense" D DISPDRG
77 S LST($$NXT)="~Instruct" D INSTRCT
78 S LST($$NXT)="~Route" D ROUTE
79 S LST($$NXT)="~Message" D MESSAGE
80 I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J)
81 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
82 Q
83 ;
84DISPDRUG(LST,OI) ; list dispense drugs for an orderable item
85 N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG
86 Q
87 ;
88DISPDRG ; from OISLCT, get dispense drugs for this pharmacy orderable item
89 N I,ORTMP,ORX
90 S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",")
91 I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP)
92 I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
93 S I="" F S I=$O(ORTMP(I)) Q:I="" D
94 . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF"
95 . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5)
96 . S LST($$NXT)="i"_ORTMP(I)
97 Q
98INSTRCT ; from OISLCT, get list of potential instructions (based on drug form)
99 N INOUN,NOUN,IINS,INS,VERB,INSREC
100 D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2))
101 I PSTYPE="U" Q ; don't use the instructions list for inpatients
102 S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D
103 . S INSREC=$G(^TMP("PSJINS",$J,IINS))
104 . I '$D(VERB) S VERB=$P(INSREC,U)
105 . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2)
106 S LST($$NXT)="~Nouns"
107 S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D
108 . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U)
109 I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB
110 ;
111 Q
112MIXED(X) ; Return mixed case
113 Q X ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
114 ;
115ROUTE ; from OISLCT, get list of routes for the drug form
116 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX
117 N I,CNT,ABBR,IEN,ROUT,X
118 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D
119 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
120 . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR
121 . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default
122 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D
123 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
124 . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR
125 Q
126MESSAGE ; message
127 S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0)
128 Q
129ALLROUTE(LST) ; returns a list of all available med routes
130 N I,X,ILST S ILST=0
131 S I=0 F S I=$O(^PS(51.2,I)) Q:'I S X=^(I,0) D
132 . I $P(X,U,4) S LST($$NXT)=I_U_$P(X,U)_U_$P(X,U,3)
133 Q
134VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation
135 N ORLST,ABBR
136 D FIND^DIC(51.2,"",1,"MO",X,1,,"I $P(^(0),U,4)=1",,"ORLST")
137 I 'ORLST("DILIST",0) S REC=0 Q
138 S X=$$UPPER(X),ABBR=ORLST("DILIST","ID",1,1)
139 I '$L(ABBR) S ABBR=ORLST("DILIST",1,1)
140 I ($$UPPER(ORLST("DILIST",1,1))'=X),($$UPPER(ABBR)'=X) S REC=0 Q
141 S REC=ORLST("DILIST",2,1)_U_ABBR
142 Q
143AUTH(VAL,PRV) ; For inpatient meds, check restrictions
144 N NAME,AUTH,INACT,X S VAL=0
145 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U)
146 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4)
147 I 'AUTH!(INACT&(DT>INACT)) D Q
148 . S VAL="1^"_NAME_" is not authorized to write medication orders."
149 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q
150 . S VAL="1^OREMAS key holders may not enter medication orders."
151 Q
152DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug
153 N X S X=$$ENDCM^PSJORUTL(IEN)
154 S VAL=$P(X,U,2)_U_$P(X,U,4)
155 Q
156MEDISIV(VAL,IEN) ; return true if orderable item is IV medication
157 S VAL=0
158 I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1
159 Q
160ISSPLY(VAL,IEN) ; return true if orderable item is a supply
161 S VAL=0
162 I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1
163 Q
164IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln
165 N I,PSOI,ORWY,AMT,IVFLAG
166 S IVFLAG=$P(OI,U,2)
167 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)_ORWTYP,VAL=""
168 I IVFLAG="NF" D ENVOL2^PSJORUT2(PSOI,.ORWY)
169 I IVFLAG="" D ENVOL^PSJORUT2(PSOI,.ORWY)
170 I ORWTYP="B" D
171 . S I=0 F S I=$O(ORWY(I)) Q:I'>0 S AMT(+ORWY(I))=""
172 . S AMT=0,VAL="ML" F S AMT=$O(AMT(AMT)) Q:AMT'>0 S VAL=VAL_U_AMT
173 I ORWTYP="A" D
174 . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2)
175 . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM"
176 Q
177VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid
178 I $E($RE($$UPPER(X)),1,5)="RH/LM" S X=$E(X,1,$L(X)-5)
179 S X=$$TRIM(X)
180 D ORINF^PSIVSP S VAL=$G(X) ;S OK=$S($D(X):1,1:0)
181 Q
182UPPER(X) ; return uppercase
183 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
184 ;
185TRIM(X) ; trim leading and trailing spaces
186 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail
187 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead
188 Q X
189SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient
190 N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0
191 I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS
192 I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS
193 S VAL=1
194XSCSTS Q
195FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives
196 D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST)
197 S I=0 F S I=$O(ORLST(I)) Q:'I D
198 . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0))
199 . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U)
200 Q
201VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not
202 I '$L($T(EN^PSSGSGUI)) S OK=-1 Q
203 I $E($T(EN^PSSGSGUI),1,4)="EN(X" D
204 . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I"))
205 . K X S:$D(ORX) X=ORX
206 E D
207 . D EN^PSSGSGUI
208 S OK=$S($D(X):1,1:0)
209 Q
210VALQTY(OK,X) ; validate a quantity, return 1 if valid, 0 if not
211 ; to be compatible with LM, make sure X is integer from 1 to 240
212 ; this is based on the input transform from 52,7
213 K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X
214 S OK=$S($D(X):1,1:0)
215 Q
216DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY
217 N ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE S PSTYPE="O"
218 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
219 S ORI=0 F S ORI=$O(ORTMP(ORI)) Q:'ORI S ORWDRG=+ORTMP(ORI) D
220 . S NDF=$G(^PSDRUG(+ORWDRG,"ND")),VAPN=$P(NDF,U,3),NDF=+NDF
221 . S X=$$DFSU^PSNAPIS(NDF,VAPN)
222 . S LSTA($P(X,U,4),$P(X,U,6))=""
223 . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))=""
224 S ORI="",ILST=0 F S ORI=$O(LSTA(ORI)) Q:ORI="" D
225 . S ORJ="" F S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ="" D
226 . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ
227 Q
Note: See TracBrowser for help on using the repository browser.