source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDXA.m@ 861

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

revised back to 6/30/08 version

File size: 9.4 KB
Line 
1ORWDXA ; SLC/KCM/JLI - Utilites for Order Actions; 2/10/03 9:13Am [6/7/05 2:09pm]
2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,141,149,187,213,195,215**;Dec 17, 1997
3 ;
4VALID(VAL,ORID,ACTION,ORNP,ORWNAT) ; Return error message if not valid action for order
5 N ORACT,ORVP,ORVER,ORIFN,PRTID S VAL="",PRTID=0
6 I +ORID=0 S VAL="This order has been deleted." Q
7 I '$D(^OR(100,+ORID,0)) S VAL="This order has been deleted!" Q
8 I ACTION="XFR",'$L($T(XFR^ORCACT01)) S ACTION="RW" ; for pre-POE
9 N ORNSS S ORNSS=1
10 I (ACTION="RN") D VALSCH^ORWNSS(.ORNSS,ORID)
11 I ORNSS=0 S VAL="This order contains an invalid administration schedule." Q
12 S ORIFN=ORID,ORVP=$P(^OR(100,+ORID,0),U,2) ; ORCACT0 expects defined
13 I (ACTION="RN") D Q:$L(VAL) ; ** There's got to be a better way!
14 . N DLG S DLG=$P(^OR(100,+ORID,0),U,5) Q:DLG'[";ORD(101.41,"
15 . I $G(^ORD(101.41,+DLG,3))'["PROVIDER^ORCDPSIV" Q
16 . D AUTH^ORWDPS32(.VAL,ORNP)
17 . I VAL S VAL=$P(VAL,U,2)
18 . E S VAL=""
19 S ORVER=$S(ACTION="CR":"R",$D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:"^")
20 I ACTION="CR" S ACTION="VR"
21 I (ACTION="ES")!(ACTION="OC")!(ACTION="RS") S ORACT=ACTION ; why not defined???
22 I (ACTION="VR"),'($D(^XUSEC("ORELSE",DUZ))!$D(^XUSEC("OREMAS",DUZ))) D Q
23 . S VAL="You are not authorized to verify these orders."
24 I $L(VAL) Q
25 N OIIEN,ISIV,IVOD
26 S (ISIV,OIIEN,IVOD)=0
27 I (ACTION="RW")!(ACTION="XX")!(ACTION="XFR") D Q:$L(VAL)
28 . S ISIV=$P(^OR(100,+ORID,0),U,11)
29 . I ISIV,($P(^ORD(100.98,ISIV,0),U,3)="IV RX") S IVOD=1
30 . D:'IVOD GTORITM^ORWDXR(.OIIEN,+ORID)
31 . D:OIIEN ISACTOI(.VAL,OIIEN) I $L(VAL)>0 Q
32 . N DLG,FRM
33 . S DLG=$P(^OR(100,+ORID,0),U,5),FRM=0
34 . I $P(DLG,";",2)'="ORD(101.41," S DLG=0
35 . I DLG D FORMID^ORWDXM(.FRM,+DLG)
36 . I '(DLG&FRM) D
37 . . S VAL="Copy & Change are not implemented for this order that predates CPRS."
38 N OREBUILD ; sometimes left defined by $$VALID
39 I $$VALID^ORCACT0(ORID,ACTION,.VAL,$G(ORWNAT)) S VAL="" ; VAL=error
40 Q
41HOLD(REC,ORID,ORNP) ; Place an order on hold
42 N ACTDA
43 S ACTDA=$$ACTION^ORCSAVE("HD",+ORID,ORNP)
44 D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
45 Q
46UNHOLD(REC,ORID,ORNP) ; Release an order from hold
47 N ACTDA
48 S ACTDA=$$ACTION^ORCSAVE("RL",+ORID,ORNP)
49 D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
50 Q
51DC(REC,ORID,ORNP,ORL,REASON) ; Discontinue/Cancel/Delete an order
52 N NATURE,CREATE,PRINT,STATUS,ACTDA,SIGSTS
53 N X3,X8,CURRACT
54 Q:'+ORID
55 S CURRACT=0
56 S ORL(2)=ORL_";SC(",ORL=ORL(2),NATURE=""
57 I REASON S NATURE=$P(^ORD(100.02,$P(^ORD(100.03,REASON,0),U,7),0),U,2)
58 S:NATURE="" NATURE="W" ; S:ORNP=DUZ NATURE="E"
59 ;change the way create work to support forcing signature for all DC
60 ;reasons
61 S CREATE=1,PRINT=$$PRINT^ORCACT2(NATURE)
62 ;S CREATE=$$CREATE^ORX1(NATURE)
63 S X3=$G(^OR(100,+ORID,3))
64 S CURRACT=$P(X3,U,7) S:CURRACT<1 CURRACT=+$O(^OR(100,+ORID,8,"?"),-1)
65 I '$D(^OR(100,+ORID,8,+$P(ORID,";",2),0)) D
66 . S X8=$G(^OR(100,+ORID,8,CURRACT,0))
67 . S SIGSTS=$P(X8,U,4)
68 . S $P(ORID,";",2)=CURRACT
69 E D
70 . S X8=^OR(100,+ORID,8,+$P(ORID,";",2),0)
71 . S SIGSTS=$P(X8,U,4)
72 I '$D(SIGSTS) S SIGSTS=1
73 S STATUS=$P($G(^OR(100,+ORID,8,+$P(ORID,";",2),0)),U,15)
74 I (STATUS=10)!(STATUS=11) D Q ; delete/cancel unreleased order
75 . N RPLORD
76 . S RPLORD=$P($G(^OR(100,+ORID,3)),U,5) ; replaced order
77 . D GETBYIFN^ORWORR(.REC,ORID)
78 . I STATUS=10,($P(X8,U,4)'=2) D ; CANCEL signed, delayed, unreleased
79 . . ; taken from CLRDLY^ORCACT2
80 . . I REASON D SET^ORCACT2(+ORID,NATURE,REASON)
81 . . I 'REASON D SET^ORCACT2(+ORID,"M","","Delayed Order Cancelled")
82 . . D STATUS^ORCSAVE2(+ORID,13) S $P(^OR(100,+ORID,8,1,0),U,15)=13
83 . E D ; DELETE unsigned, unreleased
84 . . I $P(X8,U,2)="DC" K ^OR(100,+ORID,6)
85 . . ; delete fwd ptr to order about to be deleted
86 . . I RPLORD,$P(X8,U,2)="NW" S $P(^OR(100,RPLORD,3),U,6)=""
87 . . ; delete ptr to order in Patient Event file #100.2
88 . . N EVT S EVT=$P($G(^OR(100,+ORID,0)),U,17) I EVT,EVT=+$O(^ORE(100.2,"AO",+ORID,0)) S $P(^ORE(100.2,EVT,0),U,4)="" K ^ORE(100.2,"AO",+ORID,EVT)
89 . . D DELETE^ORCSAVE2(ORID)
90 . I RPLORD,'(SIGSTS=1) S ORID=RPLORD ; for Renews & Changes, show replaced order
91 . I '$D(^OR(100,+ORID)) D
92 . . S $P(REC(1),U)="~0",REC(2)="tDELETED: "_$E(REC(2),2,245)
93 . E D
94 . . K REC
95 . . D GETBYIFN^ORWORR(.REC,+ORID_";"_$P($G(^OR(100,+ORID,3)),U,7))
96 . S $P(REC(1),U,14)=2 ; DCType = deletion
97 S ACTDA=$$ACTION^ORCSAVE("DC",+ORID,ORNP)
98 D SET^ORCACT2(+ORID,NATURE,REASON)
99 D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
100 S $P(REC(1),U,14)=$S(CREATE:1,1:3) ;DCType - 1=NewOrder, 3=NewStatus
101 N PKG
102 S PKG=$P($G(^OR(100,+ORID,0)),U,14)
103 S PKG=$$NMSP^ORCD(PKG)
104 I REASON=16&(PKG="PS") D
105 . N XMB
106 . S XMB="OR DRUG ORDER CANCELLED"
107 . S XMB(1)=$P($G(REC(2)),"tDiscontinue",2),XMB(4)=$P($G(^VA(200,DUZ,0)),U)
108 . S XMB(2)=+ORID
109 . S XMB(3)=+$P($G(^OR(100,+ORID,0)),U,2)
110 . S XMB(3)=$P($G(^DPT(XMB(3),0)),U)
111 . D ^XMB
112 Q
113DCREASON(LST) ; Return a list of DC reasons
114 N IEN,ILST,X
115 S ILST=1,LST(ILST)="~DCReason"
116 S IEN=0 F S IEN=$O(^ORD(100.03,IEN)) Q:'IEN S X=^(IEN,0) D
117 . I $P(X,U,4) Q ; inactive
118 . I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q ; not OR pkg
119 . I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q ; nature=auto
120 . S ILST=ILST+1,LST(ILST)="i"_IEN_U_$P(X,U)
121 S IEN=$O(^ORD(100.03,"C","ORREQ",0))
122 I IEN S ILST=ILST+1,LST(ILST)="d"_IEN_U_$P(^ORD(100.03,IEN,0),U)
123 Q
124DCREQIEN(VAL) ; Return the IEN for Requesting Physician Cancelled reason
125 S VAL=$O(^ORD(100.03,"S","REQ",0))
126 Q
127COMPLETE(REC,ORID,ESCODE) ; Complete an order (generic orders)
128 ;N X S X=+$E($$NOW^XLFDT,1,12)
129 ;D DATES^ORCSAVE2(+ORID,,X)
130 ;D STATUS^ORCSAVE2(+ORID,2)
131 ; validate ESCode
132 D COMP^ORCSAVE2(ORID)
133 D GETBYIFN^ORWORR(.REC,ORID)
134 Q
135VERIFY(REC,ORID,ESCODE,ORVER) ; Verify an order
136 ; validate ESCode
137 S ORVER=$G(ORVER,$S($D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:U))
138 I ORVER'=U D
139 . N ORIFN,ORES,ORI
140 . ; to match 56, need to VERIFY any replaced orders:
141 . S ORIFN=ORID,ORES(ORIFN)="" D REPLCD^ORCACT1
142 . S ORI="" F S ORI=$O(ORES(ORI)) Q:ORI="" D EN^ORCSEND(ORI,"VR","",""),UNLK1^ORX2(+ORI):ORI'=ORID ;ORID locked prior
143 D GETBYIFN^ORWORR(.REC,ORID)
144 Q
145ALERT(DUMMY,ORID,ORDUZ) ;send alert to user (ORDUZ) when order (ORID) resulted
146 ;if no user passed from GUI, use ordering provider:
147 I $G(ORDUZ)<1 S ORDUZ=+$$ORDERER^ORQOR2(+ORID)
148 I $L($G(ORDUZ))<1 S ORDUZ=DUZ
149 S DUMMY=1,$P(^OR(100,+ORID,3),U,10)=ORDUZ
150 Q
151FLAG(REC,ORIFN,OREASON,ORNP) ; Flag an order
152 N ORB,ORVP,DA,ORPS
153 D BULLETIN
154 S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2)
155 K ^OR(100,+ORIFN,8,DA,3) S ^(3)="1^"_$G(XMZ)_U_+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON
156 D KILL^XM,MSG^ORCFLAG(ORIFN)
157 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity
158 I +$G(ORNP)<1 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3)
159 S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification
160 D GETBYIFN^ORWORR(.REC,ORIFN)
161 Q
162BULLETIN ; Send flagged order bulletin (USED BY FLAG)
163 N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR
164 S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3))
165 ;CLA - 3/21/96:
166 S ORUSR=+$P(OR0,U,4)
167 S ORSRV=$G(^VA(200,ORUSR,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
168 S ORENT="USR.`"_ORUSR_"^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG"
169 S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q")
170 Q:$G(BULL)'="Y" ;quit if parameter value is not 'Y'es
171 ;
172 S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(+$P(OR0,U,4))=""
173 S XMB(1)=$P(^DPT(+$P(OR0,U,2),0),U),XMB(2)=$P(^(0),U,9),XMB(3)="" ;sb AGE
174 S XMB(4)=$$FMTE^XLFDT($P(OR0,U,7))
175 D TEXT^ORQ12(.ORDTXT,+ORIFN,80)
176 S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3))
177 S XMB(8)=$$FMTE^XLFDT($P(OR0,U,8)),XMB(9)=$$FMTE^XLFDT($P(OR0,U,9)),XMB(10)=OREASON
178 S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U)
179 D EN^XMB
180 Q
181UNFLAG(REC,ORIFN,OREASON) ; Unflag an order
182 N DA,ORB,ORNP,ORVP,ORPS
183 S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2)
184 S $P(^OR(100,+ORIFN,8,DA,3),U)=0,$P(^(3),U,6,8)=+$E($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON D MSG^ORCFLAG(ORIFN)
185 S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity
186 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3)
187 S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification
188 D GETBYIFN^ORWORR(.REC,ORIFN)
189 Q
190FLAGTXT(LST,ORID) ; Return flag reason
191 N FLAG
192 S FLAG=$G(^OR(100,+ORID,8,$P(ORID,";",2),3))
193 S LST(1)="FLAGGED: "_$$FMTE^XLFDT($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U)
194 S LST(2)=$P(FLAG,U,5) ; reason
195 Q
196WCGET(LST,ORID) ; Return ward comments
197 N I,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2)
198 S I=0 F S I=$O(^OR(100,ORIFN,8,ACT,5,I)) Q:'I S LST(I)=$G(^(I,0))
199 Q
200WCPUT(ERR,ORID,WCLST) ; Set ward comments for order
201 N DIERR,ERRLST,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2)
202 D WP^DIE(100.008,ACT_","_ORIFN_",",50,"","WCLST","ERRLST")
203 S ERR="" I $D(DIERR) S ERR="An error occurred while saving comments."
204 Q
205OFCPLX(ORY,ORID,PRTORDER) ;Check if ORID is an child of the PRTORDER
206 N NUMCHDS,NOWID,NOWVAL,X3,ORDA,ISNOW
207 Q:'$D(^OR(100,+ORID,0))
208 S ISNOW=0
209 D ISNOW^ORWDXR(.ISNOW,+ORID)
210 Q:ISNOW
211 N PKG
212 S PKG=$P($G(^OR(100,+ORID,0)),U,14)
213 S PKG=$$NMSP^ORCD(PKG)
214 I PKG'="PS" Q
215 I $L($G(^OR(100,+ORID,3))),('$L($P(^(3),U,9))) Q
216 S (NUMCHDS,NOWID,NOWVAL,X3,ORDA)=0
217 S PRTORDER=+$P(^(3),U,9)
218 S X3=$G(^OR(100,PRTORDER,3)),ORDA=$P(X3,U,7)
219 S PRTORDER=PRTORDER_";"_ORDA
220 S NUMCHDS=$P($G(^OR(100,+PRTORDER,2,0)),U,4)
221 I NUMCHDS>2 S ORY="COMPLEX-PSI"_U_PRTORDER
222 S:$D(^OR(100,+PRTORDER,4.5,"ID","NOW")) NOWID=$O(^("NOW",0))
223 S:NOWID NOWVAL=$G(^OR(100,+PRTORDER,4.5,NOWID,1))
224 I NOWVAL=1 Q
225 E S ORY="COMPLEX-PSI"_U_PRTORDER
226 Q
227ISACTOI(ORY,OI) ;If it's an active orderable item
228 I $G(^ORD(101.43,+OI,.1)),^(.1)'>$$NOW^XLFDT D
229 . S ORY=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore."
230 Q
Note: See TracBrowser for help on using the repository browser.