source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS32.m@ 621

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

initial load of WorldVistAEHR
File size: 8.5 KB
Line 
1ORWDPS32 ; SLC/KCM - Pharmacy Calls for GUI Dialog ; 02/11/2008
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,94,190,195,243**;Dec 17, 1997;Build 242
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4NXT() ; -- ret next available index in data array
5 S ILST=ILST+1
6 Q ILST
7 ;
8DLGSLCT(LST,PSTYPE,DFN,LOCIEN) ; return def lists for dialog
9 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpt)
10 N ILST S ILST=0
11 I PSTYPE="F" D Q ; IV Fluids
12 . S LST($$NXT)="~ShortList" D SHORT
13 . S LST($$NXT)="~Priorities" D PRIOR
14 . ;S LST($$NXT)="~Schedules" D SCHED(LOCIEN)
15 . S LST($$NXT)="~Route" D IVROUTE
16 ;
17 S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpt
18 ;S LST($$NXT)="~Schedules" D SCHED(LOCIEN)
19 S LST($$NXT)="~Priorities" D PRIOR
20 I PSTYPE="O" D ; Outpt
21 . S LST($$NXT)="~Pickup" D PICKUP
22 . S LST($$NXT)="~SCStatus" D SCLIST
23 Q
24SHORT ; from DLGSLCT, get short list of med quick orders
25 ; !!! change this so that it uses the ORWDXQ call!!!
26 N I,X,TMP
27 I PSTYPE="U" S X="UD RX"
28 I PSTYPE="F" S X="IV RX"
29 I PSTYPE="O" S X="O RX"
30 D GETQLST^ORWDXQ(.TMP,X,"iQ")
31 S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I)
32 Q
33SCHEDA ; (similar to SCHED, but also rtns admin times)
34 N X,IEN,SCH,TIME
35 K ^TMP($J,"ORWDPS32 SCHEDA")
36 D AP^PSS51P1("PSJ",,,,"ORWDPS32 SCHEDA")
37 S SCH="" F S SCH=$O(^TMP($J,"ORWDPS32 SCHEDA","APPSJ",SCH)) Q:SCH="" D
38 .S IEN="" F S IEN=$O(^TMP($J,"ORWDPS32 SCHEDA","APPSJ",SCH,IEN)) Q:IEN'>0 D
39 ..S TIME=$G(^TMP($J,"ORWDPS32 SCHEDA",IEN,1))
40 ..S X=$S($L(TIME):" ("_TIME_")",1:"")
41 ..S LST($$NXT)="i"_IEN_U_SCH_U_X
42 K ^TMP($J,"ORWDPS32 SCHEDA")
43 Q
44 ;
45IVROUTE ;
46 N ABB,EXP,IEN,RTE
47 K ^TMP($J,"ORWDPS32 IVROUTE")
48 D ALL^PSS51P2(,"??",,1,"ORWDPS32 IVROUTE")
49 S RTE="" F S RTE=$O(^TMP($J,"ORWDPS32 IVROUTE","B",RTE)) Q:RTE="" D
50 .S IEN=$O(^TMP($J,"ORWDPS32 IVROUTE","IV",RTE,"")) Q:IEN'>0
51 .S ABB=$G(^TMP($J,"ORWDPS32 IVROUTE",IEN,1))
52 .S EXP=$G(^TMP($J,"ORWDPS32 IVROUTE",IEN,4))
53 .S LST($$NXT)="i"_IEN_U_RTE_U_ABB_U_EXP
54 K ^TMP($J,"ORWDPS32 IVROUTE")
55 Q
56 ;
57ALLIVRTE(LST) ;
58 N ABB,CNT,EXP,IEN,RTE
59 K ^TMP($J,"ORWDPS32 ALLIVRTE")
60 S CNT=0
61 D ALL^PSS51P2(,"??",,1,"ORWDPS32 ALLIVRTE")
62 S RTE="" F S RTE=$O(^TMP($J,"ORWDPS32 ALLIVRTE","B",RTE)) Q:RTE="" D
63 .S IEN=$O(^TMP($J,"ORWDPS32 ALLIVRTE","IV",RTE,"")) Q:IEN'>0
64 .S ABB=$G(^TMP($J,"ORWDPS32 ALLIVRTE",IEN,1))
65 .S EXP=$G(^TMP($J,"ORWDPS32 ALLIVRTE",IEN,4))
66 .S CNT=CNT+1,LST(CNT)=IEN_U_RTE_U_ABB_U_U_U_U
67 K ^TMP($J,"ORWDPS32 IVROUTE")
68 Q
69 ;
70ROUTE ; from OISLCT^ORWDPS32, get list of routes for the drug form
71 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX
72 N I,CNT,ABBR,IEN,ROUT,X
73 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D
74 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
75 . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR
76 . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default
77 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D
78 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
79 . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR
80 Q
81 ;similar to SCHED^ORWDPS32, also returns Admin Time for Patient ward location
82 ;AGP CPRS 27.72 THIS CODE IS NOT NEEDED ANYMORE
83SCHED(LOCIEN) ;
84 N CNT,ORARRAY,SCH,IEN,EXP,TIME,TYP,X0,WIEN
85 ;K ^TMP($J,"ORWDPS32 SCHED1")
86 S WIEN=$$WARDIEN(+LOCIEN)
87 D SCHED^PSS51P1(WIEN,.ORARRAY)
88 S CNT=0 F S CNT=$O(ORARRAY(CNT)) Q:CNT'>0 D
89 .S LST($$NXT)="i"_$P(ORARRAY(CNT),U,2,5)
90 Q
91 ;
92WARDIEN(LOCIEN) ;
93 N RESULT
94 S RESULT=0
95 I LOCIEN=0 Q RESULT
96 I $P($G(^SC(LOCIEN,42)),U)="" Q RESULT
97 S RESULT=+$P($G(^SC(LOCIEN,42)),U)
98 Q RESULT
99PRIOR ; from DLGSLCT, get list of allowed priorities
100 N X,XREF
101 S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ")
102 S X="" F S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X) D
103 . S LST($$NXT)="i"_$O(^ORD(101.42,XREF,X,0))_U_X
104 S LST($$NXT)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE"
105 Q
106PICKUP ; from DLGSLCT, get prescription routing
107 N X,EDITONLY
108 F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X
109 S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X
110 Q
111DEFPICK() ; ret def routing
112 N X,DLG,PRMT
113 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X=""
114 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0))
115 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1)
116 I X'="" S EDITONLY=1 Q X ; EDITONLY used by def action
117 ;
118 S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I")
119 I X="C" S X="C^in Clinic" G XPICK
120 I X="M" S X="M^by Mail" G XPICK
121 I X="W" S X="W^at Window" G XPICK
122 I X="N" S X="" G XPICK
123 I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window")
124XPICK Q X
125 ;
126SCLIST ; from DLGSLCT, get options for service connected
127 F X="0^No","1^Yes" S LST($$NXT)="i"_X
128 Q
129 ;
130OISLCT(LST,OI,PSTYPE,ORVP) ; rtn for defaults for pharm OI
131 N ILST S ILST=0
132 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
133 S LST($$NXT)="~Dispense" D DISPDRG
134 S LST($$NXT)="~Instruct" D INSTRCT
135 S LST($$NXT)="~Route" D ROUTE
136 S LST($$NXT)="~Message" D MESSAGE
137 I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J)
138 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
139 Q
140 ;
141DISPDRUG(LST,OI) ; list dispense drugs for an OI
142 N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG
143 Q
144 ;
145DISPDRG ; from OISLCT, get disp drugs for this pharm OI
146 N I,ORTMP,ORX
147 S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",")
148 I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP)
149 I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
150 S I="" F S I=$O(ORTMP(I)) Q:I="" D
151 . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF"
152 . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5)
153 . S LST($$NXT)="i"_ORTMP(I)
154 Q
155INSTRCT ; from OISLCT, get list of potential instructs (based on drug form)
156 N INOUN,NOUN,IINS,INS,VERB,INSREC
157 D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2))
158 I PSTYPE="U" Q ; don't use the instructions list for inpatients
159 S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D
160 . S INSREC=$G(^TMP("PSJINS",$J,IINS))
161 . I '$D(VERB) S VERB=$P(INSREC,U)
162 . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2)
163 S LST($$NXT)="~Nouns"
164 S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D
165 . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U)
166 I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB
167 ;
168 Q
169MIXED(X) ; Return mixed case
170 Q X
171 ;
172MESSAGE ; message
173 S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0)
174 Q
175ALLROUTE(LST) ; returns a list of all available med routes
176 N I,X,ILST
177 S ILST=0
178 K ^TMP($J,"ORWDPS32 ALLROUTE")
179 D ALL^PSS51P2(,"??",,,"ORWDPS32 ALLROUTE")
180 S I=0 F S I=$O(^TMP($J,"ORWDPS32 ALLROUTE",I)) Q:'I D
181 . I +$P(^TMP($J,"ORWDPS32 ALLROUTE",I,3),U)>0 S LST($$NXT)=I_U_^TMP($J,"ORWDPS32 ALLROUTE",I,.01)_U_^TMP($J,"ORWDPS32 ALLROUTE",I,1)
182 K ^TMP($J,"ORWDPS32 ALLROUTE")
183 Q
184VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation
185 N ABBR,NAME,IEN
186 K ^TMP($J,"ORWDPS32 VALROUTE")
187 S X=$$UPPER(X)
188 D ALL^PSS51P2(,X,,1,"ORWDPS32 VALROUTE")
189 I $P(^TMP($J,"ORWDPS32 VALROUTE",0),U)=-1 K ^TMP($J,"ORWDPS32 VALROUTE") S REC=0 Q
190 S IEN=$O(^TMP($J,"ORWDPS32 VALROUTE","B",X,""))
191 I IEN'>0 S IEN=$O(^TMP($J,"ORWDPS32 VALROUTE","C",X,""))
192 I IEN'>0 S REC=0 Q
193 S NAME=$G(^TMP($J,"ORWDPS32 VALROUTE",IEN,.01))
194 S ABBR=$G(^TMP($J,"ORWDPS32 VALROUTE",IEN,1))
195 I '$L(ABBR) S ABBR=NAME
196 I ($$UPPER(NAME)'=X),($$UPPER(ABBR)'=X) S REC=0 K ^TMP($J,"ORWDPS32 VALROUTE") Q
197 S REC=IEN_U_ABBR
198 K ^TMP($J,"ORWDPS32 VALROUTE")
199 Q
200AUTH(VAL,PRV) ; For inpatient meds, check restrictions
201 N NAME,AUTH,INACT,X S VAL=0
202 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U)
203 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4)
204 I 'AUTH!(INACT&(DT>INACT)) D Q
205 . S VAL="1^"_NAME_" is not authorized to write medication orders."
206 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q
207 . S VAL="1^OREMAS key holders may not enter medication orders."
208 Q
209AUTHNVA(VAL,PRV) ; For Non-VA meds, check restrictions
210 N NAME,AUTH,INACT,X S VAL=0
211 I $D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS")=2 Q
212 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS") D Q
213 . S VAL="1^OREMAS key holders may not enter non-VA medication orders."
214 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U)
215 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4)
216 I 'AUTH!(INACT&(DT>INACT)) D Q
217 . S VAL="1^"_NAME_" is not authorized to write medication orders."
218 Q
219 ;
220UPPER(X) ; return uppercase
221 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
222 ;
223TRIM(X) ; trim leading and trailing spaces
224 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail
225 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead
226 Q X
227 ;
Note: See TracBrowser for help on using the repository browser.