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

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

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