source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXM2.m@ 617

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

initial load of WorldVistAEHR
File size: 9.3 KB
RevLine 
[613]1ORWDXM2 ; SLC/KCM - Quick Orders ;04/25/2007
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,132,158,187,195,215,243**;Dec 17, 1997;Build 242
3 ;
4ADMTIME(ORDLOC,PATLOC,ENCLOC,DELAY,ISIMO) ;
5 N ADMLOC,INST,SCHLOC,SCHTYPE
6 S ADMLOC=+$P($G(ORDIALOG("B","ADMINISTRATION TIMES")),U,2)
7 I ADMLOC>0,ORDLOC>0,PATLOC'=ORDLOC D Q
8 .S INST=0 F S INST=$O(ORDIALOG(ADMLOC,INST)) Q:+INST'>0 D
9 ..S ORDIALOG(ADMLOC,INST)=""
10 I ADMLOC>0,$S(ENCLOC'=PATLOC:1,ISIMO:1,DELAY:1,1:0) D Q
11 .S INST=0 F S INST=$O(ORDIALOG(ADMLOC,INST)) Q:+INST'>0 D
12 ..S ORDIALOG(ADMLOC,INST)=""
13 S SCHLOC=+$P($G(ORDIALOG("B","SCHEDULE TYPE")),U,2) Q:SCHLOC'>0
14 S INST=0 F S INST=$O(ORDIALOG(SCHLOC,INST)) Q:+INST'>0 D
15 .S SCHTYP=$G(ORDIALOG(SCHLOC,INST)) Q:SCHTYP=""
16 .I $S(SCHTYP="P":1,SCHTYP="O":1,SCHTYP="OC":1,1:0),ADMLOC>0 S ORDIALOG(ADMLOC,INST)=""
17 Q
18 ;
19CLRRCL(OK) ; clear ORECALL
20 S OK=1
21 K ^TMP("ORECALL",$J),^TMP("ORWDXMQ",$J)
22 Q
23VERTXT ; set verify text for order
24 N SEQ,DA,X,PROMPT,MULT,CHILD,INST,TITLE,TEMP,ILST,SPACES
25 N ISADMIN
26 S ILST=0,$P(SPACES," ",31)=""
27 S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0 D
28 . S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D
29 . . S X0=$G(^ORD(101.41,+ORDIALOG,10,DA,0))
30 . . S ISADMIN=$S(+OREVENT>0:0,ISIMO=1:0,$P($G(^ORD(101.41,$P(X0,U,2),0)),U)="OR GTX ADMIN TIMES":1,1:0)
31 . . I ISADMIN=1,ORDLOC>0,ORDLOC'=PATLOC Q
32 . . I $P(X0,U,9)["*",ISADMIN=0 Q
33 . . S PROMPT=$P(X0,U,2),MULT=$P(X0,U,7),CHILD=$P(X0,U,11) I CHILD,ISADMIN=0 Q
34 . . Q:'PROMPT S INST=$O(ORDIALOG(PROMPT,0)) Q:'INST ; no values
35 . . S TITLE=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A"))
36 . . I $E(ORDIALOG(PROMPT,0))="W" D
37 . . . N IWP,WP,CNT
38 . . . S IWP=0,CNT=0
39 . . . F S IWP=$O(^TMP("ORWORD",$J,PROMPT,INST,IWP)) Q:'IWP D
40 . . . . S CNT=CNT+1,WP(CNT)=^TMP("ORWORD",$J,PROMPT,INST,IWP,0)
41 . . . I CNT=1 S ILST=ILST+1,LST(ILST)=$J(TITLE,30)_WP(1)
42 . . . I CNT>1 D
43 . . . . S ILST=ILST+1,LST(ILST)=TITLE,IWP=0
44 . . . . F S IWP=$O(WP(IWP)) Q:'IWP S ILST=ILST+1,LST(ILST)=WP(IWP)
45 . . E D
46 . . . S TEMP=$$ITEM^ORCDLG(PROMPT,INST) I TEMP="" Q
47 . . . S ILST=ILST+1,LST(ILST)=$J(TITLE,30)
48 . . . ;S LST(ILST)=LST(ILST)_$$ITEM^ORCDLG(PROMPT,INST)
49 . . . S LST(ILST)=LST(ILST)_TEMP
50 . . Q:'MULT Q:'$O(ORDIALOG(PROMPT,INST)) ; done
51 . . F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 S ILST=ILST+1,LST(ILST)=SPACES_$$ITEM^ORCDLG(PROMPT,INST)
52 D DISPLAY^ORWDBA3 ;for display of Billing Aware data from orig order
53 Q
54RA ; setup environment for radiology
55 ; -- get imaging types based on display group of quick order and
56 ; setup list of imaging locations based on imaging type
57 N ORY,ITYPE,IFN,CNT,ORIMLOC,PROMPT
58 S ORDIV=$$DIV^ORCDRA1,ITYPE=$P($G(^ORD(100.98,+ORDG,0)),U,3)
59 S ORIMTYPE=$O(^RA(79.2,"C",ITYPE,0))
60 D EN4^RAO7PC1(ITYPE,"ORY")
61 S (IFN,CNT)=0 F S IFN=$O(ORY(IFN)) Q:IFN'>0 D
62 . S CNT=CNT+1,ORIMLOC(CNT)=ORY(IFN),ORIMLOC("B",$P(ORY(IFN),U,2))=IFN
63 I '$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q"),CNT>1 K ORIMLOC
64 E S ORIMLOC=CNT_"^1"
65 S PROMPT=$O(^ORD(101.41,"B","OR GTX IMAGING LOCATION",0))
66 I $G(ORIMLOC) M ORDIALOG(PROMPT,"LIST")=ORIMLOC
67 Q
68LR ; setup environment for lab
69 ; -- setup ORTIME, ORIMTIME & ORTEST arrays
70 ; setup ORMAX, ORDG, & ORCOLLCT variables
71 N PROMPT,INST,EDITONLY
72 D GETIMES^ORCDLR1 ; sets up ORTIME and ORIMTIME arrays
73 S ORMAX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q")
74 S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)),INST=1
75 D LRTEST ; sets up ORTEST array and ORDG
76 S PROMPT=$O(^ORD(101.41,"B","OR GTX COLLECTION TYPE",0))
77 I $D(ORDIALOG(PROMPT,1)) S ORCOLLCT=ORDIALOG(PROMPT,1) I 1
78 E S EDITONLY=0,ORCOLLCT=$$COLLTYPE^ORCDLR1
79 I ORCOLLCT="I" D
80 . S PROMPT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
81 . D LRICTMOK
82 S PROMPT=$O(^ORD(101.41,"B","OR GTX ADMIN SCHEDULE",0))
83 I $D(ORDIALOG(PROMPT,1)) S ORSCH=ORDIALOG(PROMPT,1)
84 Q
85LRTEST ; -- Setup ORTEST() array of ordering parameters (copied from ORCDLR)
86 N OI,TST,DG
87 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI
88 I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST
89 S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB"
90 S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG
91 Q
92LRRQCM() ; return true if lab test has required comments
93 I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 1 ; edit via WP
94 N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM,OI,TST
95 S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN")
96 S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI 0
97 I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST
98 S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0))
99 S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6)
100 S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19)
101 Q REQDCOMM
102LRASMP() ; return true to ask collection sample (from ASKSAMP^ORCDLR)
103 N DEFSAMP,SAMP0
104 S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0))
105 I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) Q 0
106 I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask
107 I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask
108 I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice
109 Q 1
110LRICTMOK ;
111 Q:'$D(ORDIALOG(PROMPT,1))
112 N ORY
113 D VALDT^ORWU(.ORY,ORDIALOG(PROMPT,1))
114 I +$$VALID^LR7OV4(DUZ(2),ORY)=0 S ORDIALOG(PROMPT,1)=""
115 Q
116DO ; setup environment for diet order
117 ; partially copied from EN^ORCDFH
118 I ORCAT'="I" D Q
119 . S ORQUIT=1
120 . S LST(0)="8^0"
121 . S LST(.5)="This type of diet may be entered for inpatients only."
122 D EN^FHWOR8(+ORVP,.ORPARAM) ; set FH ordering parameters
123 S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now
124 N PROMPT,OI ; set NPO flag if NPO diet
125 S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
126 S OI=+$G(ORDIALOG(PROMPT,1))
127 S ORNPO=($P($G(^ORD(101.43,OI,0)),U)="NPO")
128 S PROMPT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
129 S X=$G(ORDIALOG(PROMPT,1)) I $L(X) D CNV^ORCDFH1 S ORDIALOG(PROMPT,1)=$G(X)
130 Q
131EL ; setup environment for early/late tray
132 D EN^FHWOR8(+ORVP,.ORPARAM) ; set FH ordering parameters
133 S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now
134 D EN2^ORCDFH ; setup ORTIME array
135 N PROMPT ; set ORMEAL,ORTRAY
136 S PROMPT=$O(^ORD(101.41,"B","OR GTX MEAL",0))
137 I $D(ORDIALOG(PROMPT,1)) S ORMEAL=ORDIALOG(PROMPT,1)
138 S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
139 I $D(ORDIALOG(PROMPT,1)) S ORTRAY=ORDIALOG(PROMPT,1)
140 Q
141UD ; setup environment for unit dose med
142 I $G(ORWP94) G PS^ORWDPS3 ; if patch 94 installed
143 ;
144 D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds
145 N PROMPT,OI
146 S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
147 I $D(ORDIALOG(PROMPT,1)) S OI=ORDIALOG(PROMPT,1) D MEDACTV(1) Q:$G(ORQUIT)
148 D INSTR^ORCDPS(OI) ; sets up instructions, routes, etc.
149 D CHOICES^ORCDPS("U") ; gets list of dispense drugs
150 Q
151IV ; setup environment for IV fluid
152 D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds
153 ; sets up list of volumes if only one solution
154 ; otherwise, let the dialog go interactive
155 N PROMPT,INST,CNT,OI
156 S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
157 S (CNT,INST)=0
158 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D Q:$G(ORQUIT)
159 . S CNT=CNT+1
160 . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(3) ; check active solutions
161 I CNT=1 S INST=1 D VOLUME^ORCDPSIV
162 S PROMPT=$O(^ORD(101.41,"B","OR GTX ADDITIVE",0))
163 S INST=0
164 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D Q:$G(ORQUIT)
165 . S OI=ORDIALOG(PROMPT,INST) D MEDACTV(4) ; check active additives
166 Q
167OP ; setup environment for outpatient pharmacy
168 I $G(ORWP94) G PS^ORWDPS3 ; if patch 94 installed
169 ;
170 D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds
171 N PROMPT,INST,CNT,OI
172 S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)),OI=0
173 I $D(ORDIALOG(PROMPT,1)) S OI=$G(ORDIALOG(PROMPT,1)) D MEDACTV(2) Q:$G(ORQUIT)
174 D:+OI INSTR^ORCDPS(OI) ; sets up instructions, routes, etc.
175 D CHOICES^ORCDPS("O") ; gets list of dispense drugs
176 ; get defaults for drug, refills if only one dispense drug
177 S PROMPT=$O(^ORD(101.41,"B","OR GTX DISPENSE DRUG",0))
178 S (CNT,INST)=0
179 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST S CNT=CNT+1
180 I CNT=1 D
181 . S ORDRUG=+$G(ORDIALOG(PROMPT,1)),ORCOMPLX=0
182 . S OREFILLS=$P($G(ORDIALOG(PROMPT,"LIST","D",ORDRUG)),U,3)
183 . S:'$L(OREFILLS) OREFILLS=11
184 E S ORCOMPLX=1,OREFILLS=11 ; force interactive on complex order
185 S ORCOPAY=1 ; ask SC if can't determine copay
186 I $G(ORDRUG),$L($T(ASKSC^ORCDPS)) S ORCOPAY=$$ASKSC^ORCDPS
187 Q
188AUTHMED ; sets ORQUIT if not authorized to write meds
189 N NOAUTH,NAME
190 D AUTH^ORWDPS32(.NOAUTH,ORNP)
191 I +NOAUTH D
192 . S ORQUIT=1
193 . S LST(0)="8^0"
194 . S NAME=$P($G(^VA(200,+ORNP,20)),U,2)
195 . I '$L(NAME) S NAME=$P($G(^VA(200,+ORNP,0)),U,1)
196 . S LST(.5)=NAME_" is not authorized to write med orders."
197 Q
198MEDACTV(USAGE) ; sets ORQUIT if the orderable item is not active for a med
199 Q:'$G(OI) S USAGE=+$G(USAGE)
200 I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D Q
201 . S ORQUIT=1,LST(0)="8^0"
202 . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore."
203 I USAGE,'$P($G(^ORD(101.43,OI,"PS")),U,USAGE) D Q
204 . S ORQUIT=1,LST(0)="8^0"
205 . S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" may not be ordered as an "_$S(USAGE=1:"inpatient medication",USAGE=2:"outpatient medication",USAGE=3:"IV solution",1:"IV additive")_" anymore."
206 Q
207SCHEDULD() ; Is patient scheduled for PREOP (Imaging)
208 I $G(ORDIALOG(PROMPT,1)) Q 1 ; don't ask - already have date
209 E Q 0
210 Q
Note: See TracBrowser for help on using the repository browser.