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

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

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