ORWDXA ; SLC/KCM/JLI - Utilites for Order Actions;22-Aug-2013 11:04;mgh
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,141,149,187,1004,1005,1006,1007,213,195,215,243,1010,1011**;Dec 17, 1997;Build 34
; Modified - IHS/MSC/PLS - 09/21/08 - Line DC+30
; 08/09/10 - VALID+1, HOLD+3, UNHOLD+3
; 02/05/13 - VALID+36
; 08/14/13 - VALID+9
VALID(VAL,ORID,ACTION,ORNP,ORWNAT) ; Return error message if not valid action for order
;IHS/MSC/JDS/PLS - 08/09/10 - Track home med transfer
S VAL=""
I $E($G(ACTION),1,3)="XFR" D
.K ^TMP("BEHPSHMX",$J)
.N XFRIO,DRUG,C,Z,ATYPE
.S Z=0
.S XFRIO=$E(ACTION,4),ATYPE=$E(ACTION,4),ACTION=$E(ACTION,1,3)
.I $P($G(^DIC(9.4,+$P($G(^OR(100,+ORID,0)),U,14),0)),U,2)="PSH" D
..;IHS/MSC/MGH Patch 1011 check to see if narcotic being transferred
..S C=$$GET^XPAR("ALL","APSP AUTO RX CII PRESCRIBING")
..I C=0 D
...S DRUG=$$VALUE^ORCSAVE2(+ORID,"DRUG")
...S Z=$$ISSCH^APSPFNC2(DRUG,2)
..I (Z=1)&(ATYPE="O") S VAL="CII drugs cannot be transferred to outpt meds"
..E S ^TMP("BEHPSHMX",$J)=ORID_U_XFRIO
Q:VAL'=""
N ORACT,ORVP,ORVER,ORIFN,PRTID S VAL="",PRTID=0
I +ORID=0 S VAL="This order has been deleted." Q
I '$D(^OR(100,+ORID,0)) S VAL="This order has been deleted!" Q
I ACTION="XFR",'$L($T(XFR^ORCACT01)) S ACTION="RW" ; for pre-POE
N ORNSS S ORNSS=1
I (ACTION="RN") D VALSCH^ORWNSS(.ORNSS,ORID)
I ORNSS=0 S VAL="This order contains an invalid administration schedule." Q
I (ACTION="RN") D ISVALIV^ORWDPS33(.VAL,ORID,ACTION) I $L(VAL)>0 Q
S ORIFN=ORID,ORVP=$P(^OR(100,+ORID,0),U,2) ; ORCACT0 expects defined
I (ACTION="RN") D Q:$L(VAL) ; ** There's got to be a better way!
. N DLG S DLG=$P(^OR(100,+ORID,0),U,5) Q:DLG'[";ORD(101.41,"
. I $G(^ORD(101.41,+DLG,3))'["PROVIDER^ORCDPSIV" Q
. D AUTH^ORWDPS32(.VAL,ORNP)
. I VAL S VAL=$P(VAL,U,2)
. E S VAL=""
S ORVER=$S(ACTION="CR":"R",$D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:"^")
I ACTION="CR" S ACTION="VR"
I (ACTION="ES")!(ACTION="OC")!(ACTION="RS") S ORACT=ACTION ; why not defined???
I (ACTION="VR"),'($D(^XUSEC("ORELSE",DUZ))!$D(^XUSEC("OREMAS",DUZ))) D Q
. S VAL="You are not authorized to verify these orders."
I $L(VAL) Q
N OIIEN,ISIV,IVOD
S (ISIV,OIIEN,IVOD)=0
I (ACTION="RW")!(ACTION="XX")!(ACTION="XFR") D Q:$L(VAL)
. S ISIV=$P(^OR(100,+ORID,0),U,11)
. I ISIV,($P(^ORD(100.98,ISIV,0),U,3)="IV RX") S IVOD=1
. D:'IVOD GTORITM^ORWDXR(.OIIEN,+ORID)
. D:OIIEN ISACTOI(.VAL,OIIEN) I $L(VAL)>0 Q
. ;IHS/MSC/MGH Patch 1011 change for eRX
. N OSTAT,RRIEN
. S OSTAT=$P(^OR(100,+ORID,3),U,3)
. S RRIEN=$$VALUE^ORCSAVE2(+ORID,"SSRREQIEN")
. I OSTAT=11&(+RRIEN) S VAL="Copy or Change cannot be used on an order created by a Surescript refill request." Q
. ;IHS/MSC/MGH end modification
. N DLG,FRM
. S DLG=$P(^OR(100,+ORID,0),U,5),FRM=0
. I $P(DLG,";",2)'="ORD(101.41," S DLG=0
. I DLG D FORMID^ORWDXM(.FRM,+DLG)
. I '(DLG&FRM) D
. . S VAL="Copy & Change are not implemented for this order that predates CPRS."
N OREBUILD ; sometimes left defined by $$VALID
;I (ACTION="RW")!(ACTION="XFR")!(ACTION="RN") D ISVALIV^ORWDPS33(.VAL,ORID,ACTION) I $L(VAL)>0 Q
I $$VALID^ORCACT0(ORID,ACTION,.VAL,$G(ORWNAT)) S VAL="" ; VAL=error
Q
; IHS/CIA/DKM - Modified next 3 lines to add ORRSN to parameters
HOLD(REC,ORID,ORNP,ORRSN) ; Place an order on hold
N ACTDA
S ACTDA=$$ACTION^ORCSAVE("HD",+ORID,ORNP,.ORRSN)
;IHS/MSC/PLS - Added next 5 lines
I $P($G(^DIC(9.4,+$P($G(^OR(100,+ORID,0)),U,14),0)),U,2)="PSH" D
.D STATUS^ORCSAVE2(+ORID,3)
.N LST
.S LST=$O(^OR(100,+ORID,8,"??"),-1) Q:'LST
.I $P($G(^OR(100,+ORID,8,+LST,0)),U,15) S $P(^(0),U,15)="",$P(^(0),U,4)=""
D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
Q
UNHOLD(REC,ORID,ORNP) ; Release an order from hold
N ACTDA
S ACTDA=$$ACTION^ORCSAVE("RL",+ORID,ORNP)
;IHS/MSC/PLS - Added next 5 lines
I $P($G(^DIC(9.4,+$P($G(^OR(100,+ORID,0)),U,14),0)),U,2)="PSH" D
.D STATUS^ORCSAVE2(+ORID,6)
.N LST
.S LST=$O(^OR(100,+ORID,8,"??"),-1) Q:'LST
.I $P($G(^OR(100,+ORID,8,+LST,0)),U,15) S $P(^(0),U,15)="",$P(^(0),U,4)=""
D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
Q
DC(REC,ORID,ORNP,ORL,REASON,DCORIG,ISNEWORD) ; Discontinue/Cancel/Delete an order
N NATURE,CREATE,PRINT,STATUS,ACTDA,SIGSTS
N X3,X8,CURRACT
Q:'+ORID
I $G(DCORIG)="" S DCORIG=0
S CURRACT=0
S ORL(2)=ORL_";SC(",ORL=ORL(2),NATURE=""
I REASON S NATURE=$P(^ORD(100.02,$P(^ORD(100.03,REASON,0),U,7),0),U,2)
S:NATURE="" NATURE="W" ; S:ORNP=DUZ NATURE="E"
;change the way create work to support forcing signature for all DC
;reasons
S CREATE=1,PRINT=$$PRINT^ORCACT2(NATURE)
;S CREATE=$$CREATE^ORX1(NATURE)
S X3=$G(^OR(100,+ORID,3))
S CURRACT=$P(X3,U,7) S:CURRACT<1 CURRACT=+$O(^OR(100,+ORID,8,"?"),-1)
I '$D(^OR(100,+ORID,8,+$P(ORID,";",2),0)) D
. S X8=$G(^OR(100,+ORID,8,CURRACT,0))
. S SIGSTS=$P(X8,U,4)
. S $P(ORID,";",2)=CURRACT
E D
. S X8=^OR(100,+ORID,8,+$P(ORID,";",2),0)
. S SIGSTS=$P(X8,U,4)
I '$D(SIGSTS) S SIGSTS=1
S STATUS=$P($G(^OR(100,+ORID,8,+$P(ORID,";",2),0)),U,15)
I (STATUS=10)!(STATUS=11) D Q ; delete/cancel unreleased order
. N RPLORD
. S RPLORD=$P($G(^OR(100,+ORID,3)),U,5) ; replaced order
. D GETBYIFN^ORWORR(.REC,ORID)
. I STATUS=10,($P(X8,U,4)'=2) D ; CANCEL signed, delayed, unreleased
. . ; taken from CLRDLY^ORCACT2
. . I REASON D SET^ORCACT2(+ORID,NATURE,REASON,,DCORIG)
. . I 'REASON D SET^ORCACT2(+ORID,"M","","Delayed Order Cancelled",DCORIG)
. . D STATUS^ORCSAVE2(+ORID,13) S $P(^OR(100,+ORID,8,1,0),U,15)=13
. E D ; CANCEL OR DELETE unsigned, unreleased
. . I $L($T(DC^APSPELRX)) D DC^APSPELRX(ORID) ; Call e-Prescribing API to deny REFREQ
. . I $P(X8,U,2)="DC" K ^OR(100,+ORID,6)
. . ; delete fwd ptr to order about to be deleted
. . I RPLORD,$P(X8,U,2)="NW" S $P(^OR(100,RPLORD,3),U,6)=""
. . ; delete ptr to order in Patient Event file #100.2
. . 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)
. . I $G(ISNEWORD) D DELETE^ORCSAVE2(ORID)
. . I '$G(ISNEWORD) D CANCEL^ORCSAVE2(ORID)
. I RPLORD,'(SIGSTS=1) S ORID=RPLORD ; for Renews & Changes, show replaced order
. I '$D(^OR(100,+ORID)) D
. . S $P(REC(1),U)="~0",REC(2)="tDELETED: "_$E(REC(2),2,245)
. E D
. . K REC
. . D GETBYIFN^ORWORR(.REC,+ORID_";"_$P($G(^OR(100,+ORID,3)),U,7))
. S $P(REC(1),U,14)=2 ; DCType = deletion
S ACTDA=$$ACTION^ORCSAVE("DC",+ORID,ORNP)
D SET^ORCACT2(+ORID,NATURE,REASON,,DCORIG)
D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
S $P(REC(1),U,14)=$S(CREATE:1,1:3) ;DCType - 1=NewOrder, 3=NewStatus
N PKG
S PKG=$P($G(^OR(100,+ORID,0)),U,14)
S PKG=$$NMSP^ORCD(PKG)
I REASON=16&(PKG="PS") D
. N XMB
. S XMB="OR DRUG ORDER CANCELLED"
. S XMB(1)=$P($G(REC(2)),"tDiscontinue",2),XMB(4)=$P($G(^VA(200,DUZ,0)),U)
. S XMB(2)=+ORID
. S XMB(3)=+$P($G(^OR(100,+ORID,0)),U,2)
. S XMB(3)=$P($G(^DPT(XMB(3),0)),U)
. D ^XMB
Q
DCREQIEN(VAL) ; Return the IEN for Requesting Physician Cancelled reason
S VAL=$O(^ORD(100.03,"S","REQ",0))
Q
COMPLETE(REC,ORID,ESCODE) ; Complete an order (generic orders)
;N X S X=+$E($$NOW^XLFDT,1,12)
;D DATES^ORCSAVE2(+ORID,,X)
;D STATUS^ORCSAVE2(+ORID,2)
; validate ESCode
D COMP^ORCSAVE2(ORID)
D GETBYIFN^ORWORR(.REC,ORID)
Q
VERIFY(REC,ORID,ESCODE,ORVER) ; Verify an order
; validate ESCode
S ORVER=$G(ORVER,$S($D(^XUSEC("ORELSE",DUZ)):"N",$D(^XUSEC("OREMAS",DUZ)):"C",1:U))
I ORVER'=U D
. N ORIFN,ORES,ORI
. ; to match 56, need to VERIFY any replaced orders:
. S ORIFN=ORID,ORES(ORIFN)="" D REPLCD^ORCACT1
. S ORI="" F S ORI=$O(ORES(ORI)) Q:ORI="" D EN^ORCSEND(ORI,"VR","",""),UNLK1^ORX2(+ORI):ORI'=ORID ;ORID locked prior
D GETBYIFN^ORWORR(.REC,ORID)
Q
ALERT(DUMMY,ORID,ORDUZ) ;send alert to user (ORDUZ) when order (ORID) resulted
;if no user passed from GUI, use ordering provider:
I $G(ORDUZ)<1 S ORDUZ=+$$ORDERER^ORQOR2(+ORID)
I $L($G(ORDUZ))<1 S ORDUZ=DUZ
S DUMMY=1,$P(^OR(100,+ORID,3),U,10)=ORDUZ
Q
FLAG(REC,ORIFN,OREASON,ORNP) ; Flag an order
N ORB,ORVP,DA,ORPS
D BULLETIN
S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2)
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:"")
D KILL^XM,MSG^ORCFLAG(ORIFN)
S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity
I +$G(ORNP)<1 S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3)
S ORB=+ORVP_U_+ORIFN_U_ORNP_"^1" D EN^OCXOERR(ORB) ; notification
D GETBYIFN^ORWORR(.REC,ORIFN)
Q
BULLETIN ; Send flagged order bulletin (USED BY FLAG)
N OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR
S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3))
;CLA - 3/21/96:
S ORUSR=+$P(OR0,U,4)
S ORSRV=$G(^VA(200,ORUSR,5)) I +ORSRV>0 S ORSRV=$P(ORSRV,U)
S ORENT="USR.`"_ORUSR_"^SRV.`"_$G(ORSRV)_"^DIV^SYS^PKG"
S BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q")
Q:$G(BULL)'="Y" ;quit if parameter value is not 'Y'es
;
S XMB="OR FLAGGED ORDER",XMDUZ=DUZ,XMY(+$P(OR0,U,4))=""
S XMB(1)=$P(^DPT(+$P(OR0,U,2),0),U),XMB(2)=$P(^(0),U,9),XMB(3)="" ;sb AGE
S XMB(4)=$$FMTE^XLFDT($P(OR0,U,7))
D TEXT^ORQ12(.ORDTXT,+ORIFN,80)
S XMB(5)=$G(ORDTXT(1)),XMB(6)=$G(ORDTXT(2)),XMB(7)=$G(ORDTXT(3))
S XMB(8)=$$FMTE^XLFDT($P(OR0,U,8)),XMB(9)=$$FMTE^XLFDT($P(OR0,U,9)),XMB(10)=OREASON
S XMB(11)=$P($G(^ORD(100.01,+$P(OR3,U,3),0)),U)
D EN^XMB
Q
UNFLAG(REC,ORIFN,OREASON) ; Unflag an order
N DA,ORB,ORNP,ORVP,ORPS
S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2)
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)
S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; Last Activity
S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3)
S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification
D GETBYIFN^ORWORR(.REC,ORIFN)
Q
FLAGTXT(LST,ORID) ; Return flag reason
N FLAG
S FLAG=$G(^OR(100,+ORID,8,$P(ORID,";",2),3))
S LST(1)="FLAGGED: "_$$FMTE^XLFDT($P(FLAG,U,3))_" by "_$P($G(^VA(200,+$P(FLAG,U,4),0)),U)
S LST(2)=$P(FLAG,U,5) ; reason
Q
WCGET(LST,ORID) ; Return ward comments
N I,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2)
S I=0 F S I=$O(^OR(100,ORIFN,8,ACT,5,I)) Q:'I S LST(I)=$G(^(I,0))
Q
WCPUT(ERR,ORID,WCLST) ; Set ward comments for order
N DIERR,ERRLST,ORIFN,ACT S ORIFN=+ORID,ACT=+$P(ORID,";",2)
D WP^DIE(100.008,ACT_","_ORIFN_",",50,"","WCLST","ERRLST")
S ERR="" I $D(DIERR) S ERR="An error occurred while saving comments."
Q
OFCPLX(ORY,ORID,PRTORDER) ;Check if ORID is an child of the PRTORDER
N NUMCHDS,NOWID,NOWVAL,X3,ORDA,ISNOW
Q:'$D(^OR(100,+ORID,0))
S ISNOW=0
D ISNOW^ORWDXR(.ISNOW,+ORID)
Q:ISNOW
N PKG
S PKG=$P($G(^OR(100,+ORID,0)),U,14)
S PKG=$$NMSP^ORCD(PKG)
I PKG'="PS" Q
I $L($G(^OR(100,+ORID,3))),('$L($P(^(3),U,9))) Q
S (NUMCHDS,NOWID,NOWVAL,X3,ORDA)=0
S PRTORDER=+$P(^(3),U,9)
S X3=$G(^OR(100,PRTORDER,3)),ORDA=$P(X3,U,7)
S PRTORDER=PRTORDER_";"_ORDA
S NUMCHDS=$P($G(^OR(100,+PRTORDER,2,0)),U,4)
I NUMCHDS>2 S ORY="COMPLEX-PSI"_U_PRTORDER
S:$D(^OR(100,+PRTORDER,4.5,"ID","NOW")) NOWID=$O(^("NOW",0))
S:NOWID NOWVAL=$G(^OR(100,+PRTORDER,4.5,NOWID,1))
I NOWVAL=1 Q
E S ORY="COMPLEX-PSI"_U_PRTORDER
Q
ISACTOI(ORY,OI) ;If it's an active orderable item
I $G(^ORD(101.43,+OI,.1)),^(.1)'>$$NOW^XLFDT D
. S ORY=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore."
Q
ORWDXA ; SLC/KCM/JLI - Utilites for Order Actions;22-Aug-2013 11:04;mgh
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,141,149,187,1004,1005,1006,1007,213,195,215,243,1010,1011**;Dec 17, 1997;Build 34
+2 ; Modified - IHS/MSC/PLS - 09/21/08 - Line DC+30
+3 ; 08/09/10 - VALID+1, HOLD+3, UNHOLD+3
+4 ; 02/05/13 - VALID+36
+5 ; 08/14/13 - VALID+9
VALID(VAL,ORID,ACTION,ORNP,ORWNAT) ; Return error message if not valid action for order
+1 ;IHS/MSC/JDS/PLS - 08/09/10 - Track home med transfer
+2 SET VAL=""
+3 IF $EXTRACT($GET(ACTION),1,3)="XFR"
Begin DoDot:1
+4 KILL ^TMP("BEHPSHMX",$JOB)
+5 NEW XFRIO,DRUG,C,Z,ATYPE
+6 SET Z=0
+7 SET XFRIO=$EXTRACT(ACTION,4)
SET ATYPE=$EXTRACT(ACTION,4)
SET ACTION=$EXTRACT(ACTION,1,3)
+8 IF $PIECE($GET(^DIC(9.4,+$PIECE($GET(^OR(100,+ORID,0)),U,14),0)),U,2)="PSH"
Begin DoDot:2
+9 ;IHS/MSC/MGH Patch 1011 check to see if narcotic being transferred
+10 SET C=$$GET^XPAR("ALL","APSP AUTO RX CII PRESCRIBING")
+11 IF C=0
Begin DoDot:3
+12 SET DRUG=$$VALUE^ORCSAVE2(+ORID,"DRUG")
+13 SET Z=$$ISSCH^APSPFNC2(DRUG,2)
End DoDot:3
+14 IF (Z=1)&(ATYPE="O")
SET VAL="CII drugs cannot be transferred to outpt meds"
+15 IF '$TEST
SET ^TMP("BEHPSHMX",$JOB)=ORID_U_XFRIO
End DoDot:2
End DoDot:1
+16 IF VAL'=""
QUIT
+17 NEW ORACT,ORVP,ORVER,ORIFN,PRTID
SET VAL=""
SET PRTID=0
+18 IF +ORID=0
SET VAL="This order has been deleted."
QUIT
+19 IF '$DATA(^OR(100,+ORID,0))
SET VAL="This order has been deleted!"
QUIT
+20 ; for pre-POE
IF ACTION="XFR"
IF '$LENGTH($TEXT(XFR^ORCACT01))
SET ACTION="RW"
+21 NEW ORNSS
SET ORNSS=1
+22 IF (ACTION="RN")
DO VALSCH^ORWNSS(.ORNSS,ORID)
+23 IF ORNSS=0
SET VAL="This order contains an invalid administration schedule."
QUIT
+24 IF (ACTION="RN")
DO ISVALIV^ORWDPS33(.VAL,ORID,ACTION)
IF $LENGTH(VAL)>0
QUIT
+25 ; ORCACT0 expects defined
SET ORIFN=ORID
SET ORVP=$PIECE(^OR(100,+ORID,0),U,2)
+26 ; ** There's got to be a better way!
IF (ACTION="RN")
Begin DoDot:1
+27 NEW DLG
SET DLG=$PIECE(^OR(100,+ORID,0),U,5)
IF DLG'[";ORD(101.41,"
QUIT
+28 IF $GET(^ORD(101.41,+DLG,3))'["PROVIDER^ORCDPSIV"
QUIT
+29 DO AUTH^ORWDPS32(.VAL,ORNP)
+30 IF VAL
SET VAL=$PIECE(VAL,U,2)
+31 IF '$TEST
SET VAL=""
End DoDot:1
IF $LENGTH(VAL)
QUIT
+32 SET ORVER=$SELECT(ACTION="CR":"R",$DATA(^XUSEC("ORELSE",DUZ)):"N",$DATA(^XUSEC("OREMAS",DUZ)):"C",1:"^")
+33 IF ACTION="CR"
SET ACTION="VR"
+34 ; why not defined???
IF (ACTION="ES")!(ACTION="OC")!(ACTION="RS")
SET ORACT=ACTION
+35 IF (ACTION="VR")
IF '($DATA(^XUSEC("ORELSE",DUZ))!$DATA(^XUSEC("OREMAS",DUZ)))
Begin DoDot:1
+36 SET VAL="You are not authorized to verify these orders."
End DoDot:1
QUIT
+37 IF $LENGTH(VAL)
QUIT
+38 NEW OIIEN,ISIV,IVOD
+39 SET (ISIV,OIIEN,IVOD)=0
+40 IF (ACTION="RW")!(ACTION="XX")!(ACTION="XFR")
Begin DoDot:1
+41 SET ISIV=$PIECE(^OR(100,+ORID,0),U,11)
+42 IF ISIV
IF ($PIECE(^ORD(100.98,ISIV,0),U,3)="IV RX")
SET IVOD=1
+43 IF 'IVOD
DO GTORITM^ORWDXR(.OIIEN,+ORID)
+44 IF OIIEN
DO ISACTOI(.VAL,OIIEN)
IF $LENGTH(VAL)>0
QUIT
+45 ;IHS/MSC/MGH Patch 1011 change for eRX
+46 NEW OSTAT,RRIEN
+47 SET OSTAT=$PIECE(^OR(100,+ORID,3),U,3)
+48 SET RRIEN=$$VALUE^ORCSAVE2(+ORID,"SSRREQIEN")
+49 IF OSTAT=11&(+RRIEN)
SET VAL="Copy or Change cannot be used on an order created by a Surescript refill request."
QUIT
+50 ;IHS/MSC/MGH end modification
+51 NEW DLG,FRM
+52 SET DLG=$PIECE(^OR(100,+ORID,0),U,5)
SET FRM=0
+53 IF $PIECE(DLG,";",2)'="ORD(101.41,"
SET DLG=0
+54 IF DLG
DO FORMID^ORWDXM(.FRM,+DLG)
+55 IF '(DLG&FRM)
Begin DoDot:2
+56 SET VAL="Copy & Change are not implemented for this order that predates CPRS."
End DoDot:2
End DoDot:1
IF $LENGTH(VAL)
QUIT
+57 ; sometimes left defined by $$VALID
NEW OREBUILD
+58 ;I (ACTION="RW")!(ACTION="XFR")!(ACTION="RN") D ISVALIV^ORWDPS33(.VAL,ORID,ACTION) I $L(VAL)>0 Q
+59 ; VAL=error
IF $$VALID^ORCACT0(ORID,ACTION,.VAL,$GET(ORWNAT))
SET VAL=""
+60 QUIT
+61 ; IHS/CIA/DKM - Modified next 3 lines to add ORRSN to parameters
HOLD(REC,ORID,ORNP,ORRSN) ; Place an order on hold
+1 NEW ACTDA
+2 SET ACTDA=$$ACTION^ORCSAVE("HD",+ORID,ORNP,.ORRSN)
+3 ;IHS/MSC/PLS - Added next 5 lines
+4 IF $PIECE($GET(^DIC(9.4,+$PIECE($GET(^OR(100,+ORID,0)),U,14),0)),U,2)="PSH"
Begin DoDot:1
+5 DO STATUS^ORCSAVE2(+ORID,3)
+6 NEW LST
+7 SET LST=$ORDER(^OR(100,+ORID,8,"??"),-1)
IF 'LST
QUIT
+8 IF $PIECE($GET(^OR(100,+ORID,8,+LST,0)),U,15)
SET $PIECE(^(0),U,15)=""
SET $PIECE(^(0),U,4)=""
End DoDot:1
+9 DO GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
+10 QUIT
UNHOLD(REC,ORID,ORNP) ; Release an order from hold
+1 NEW ACTDA
+2 SET ACTDA=$$ACTION^ORCSAVE("RL",+ORID,ORNP)
+3 ;IHS/MSC/PLS - Added next 5 lines
+4 IF $PIECE($GET(^DIC(9.4,+$PIECE($GET(^OR(100,+ORID,0)),U,14),0)),U,2)="PSH"
Begin DoDot:1
+5 DO STATUS^ORCSAVE2(+ORID,6)
+6 NEW LST
+7 SET LST=$ORDER(^OR(100,+ORID,8,"??"),-1)
IF 'LST
QUIT
+8 IF $PIECE($GET(^OR(100,+ORID,8,+LST,0)),U,15)
SET $PIECE(^(0),U,15)=""
SET $PIECE(^(0),U,4)=""
End DoDot:1
+9 DO GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
+10 QUIT
DC(REC,ORID,ORNP,ORL,REASON,DCORIG,ISNEWORD) ; Discontinue/Cancel/Delete an order
+1 NEW NATURE,CREATE,PRINT,STATUS,ACTDA,SIGSTS
+2 NEW X3,X8,CURRACT
+3 IF '+ORID
QUIT
+4 IF $GET(DCORIG)=""
SET DCORIG=0
+5 SET CURRACT=0
+6 SET ORL(2)=ORL_";SC("
SET ORL=ORL(2)
SET NATURE=""
+7 IF REASON
SET NATURE=$PIECE(^ORD(100.02,$PIECE(^ORD(100.03,REASON,0),U,7),0),U,2)
+8 ; S:ORNP=DUZ NATURE="E"
IF NATURE=""
SET NATURE="W"
+9 ;change the way create work to support forcing signature for all DC
+10 ;reasons
+11 SET CREATE=1
SET PRINT=$$PRINT^ORCACT2(NATURE)
+12 ;S CREATE=$$CREATE^ORX1(NATURE)
+13 SET X3=$GET(^OR(100,+ORID,3))
+14 SET CURRACT=$PIECE(X3,U,7)
IF CURRACT<1
SET CURRACT=+$ORDER(^OR(100,+ORID,8,"?"),-1)
+15 IF '$DATA(^OR(100,+ORID,8,+$PIECE(ORID,";",2),0))
Begin DoDot:1
+16 SET X8=$GET(^OR(100,+ORID,8,CURRACT,0))
+17 SET SIGSTS=$PIECE(X8,U,4)
+18 SET $PIECE(ORID,";",2)=CURRACT
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 SET X8=^OR(100,+ORID,8,+$PIECE(ORID,";",2),0)
+21 SET SIGSTS=$PIECE(X8,U,4)
End DoDot:1
+22 IF '$DATA(SIGSTS)
SET SIGSTS=1
+23 SET STATUS=$PIECE($GET(^OR(100,+ORID,8,+$PIECE(ORID,";",2),0)),U,15)
+24 ; delete/cancel unreleased order
IF (STATUS=10)!(STATUS=11)
Begin DoDot:1
+25 NEW RPLORD
+26 ; replaced order
SET RPLORD=$PIECE($GET(^OR(100,+ORID,3)),U,5)
+27 DO GETBYIFN^ORWORR(.REC,ORID)
+28 ; CANCEL signed, delayed, unreleased
IF STATUS=10
IF ($PIECE(X8,U,4)'=2)
Begin DoDot:2
+29 ; taken from CLRDLY^ORCACT2
+30 IF REASON
DO SET^ORCACT2(+ORID,NATURE,REASON,,DCORIG)
+31 IF 'REASON
DO SET^ORCACT2(+ORID,"M","","Delayed Order Cancelled",DCORIG)
+32 DO STATUS^ORCSAVE2(+ORID,13)
SET $PIECE(^OR(100,+ORID,8,1,0),U,15)=13
End DoDot:2
+33 ; CANCEL OR DELETE unsigned, unreleased
IF '$TEST
Begin DoDot:2
+34 ; Call e-Prescribing API to deny REFREQ
IF $LENGTH($TEXT(DC^APSPELRX))
DO DC^APSPELRX(ORID)
+35 IF $PIECE(X8,U,2)="DC"
KILL ^OR(100,+ORID,6)
+36 ; delete fwd ptr to order about to be deleted
+37 IF RPLORD
IF $PIECE(X8,U,2)="NW"
SET $PIECE(^OR(100,RPLORD,3),U,6)=""
+38 ; delete ptr to order in Patient Event file #100.2
+39 NEW EVT
SET EVT=$PIECE($GET(^OR(100,+ORID,0)),U,17)
IF EVT
IF EVT=+$ORDER(^ORE(100.2,"AO",+ORID,0))
SET $PIECE(^ORE(100.2,EVT,0),U,4)=""
KILL ^ORE(100.2,"AO",+ORID,EVT)
+40 IF $GET(ISNEWORD)
DO DELETE^ORCSAVE2(ORID)
+41 IF '$GET(ISNEWORD)
DO CANCEL^ORCSAVE2(ORID)
End DoDot:2
+42 ; for Renews & Changes, show replaced order
IF RPLORD
IF '(SIGSTS=1)
SET ORID=RPLORD
+43 IF '$DATA(^OR(100,+ORID))
Begin DoDot:2
+44 SET $PIECE(REC(1),U)="~0"
SET REC(2)="tDELETED: "_$EXTRACT(REC(2),2,245)
End DoDot:2
+45 IF '$TEST
Begin DoDot:2
+46 KILL REC
+47 DO GETBYIFN^ORWORR(.REC,+ORID_";"_$PIECE($GET(^OR(100,+ORID,3)),U,7))
End DoDot:2
+48 ; DCType = deletion
SET $PIECE(REC(1),U,14)=2
End DoDot:1
QUIT
+49 SET ACTDA=$$ACTION^ORCSAVE("DC",+ORID,ORNP)
+50 DO SET^ORCACT2(+ORID,NATURE,REASON,,DCORIG)
+51 DO GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
+52 ;DCType - 1=NewOrder, 3=NewStatus
SET $PIECE(REC(1),U,14)=$SELECT(CREATE:1,1:3)
+53 NEW PKG
+54 SET PKG=$PIECE($GET(^OR(100,+ORID,0)),U,14)
+55 SET PKG=$$NMSP^ORCD(PKG)
+56 IF REASON=16&(PKG="PS")
Begin DoDot:1
+57 NEW XMB
+58 SET XMB="OR DRUG ORDER CANCELLED"
+59 SET XMB(1)=$PIECE($GET(REC(2)),"tDiscontinue",2)
SET XMB(4)=$PIECE($GET(^VA(200,DUZ,0)),U)
+60 SET XMB(2)=+ORID
+61 SET XMB(3)=+$PIECE($GET(^OR(100,+ORID,0)),U,2)
+62 SET XMB(3)=$PIECE($GET(^DPT(XMB(3),0)),U)
+63 DO ^XMB
End DoDot:1
+64 QUIT
DCREQIEN(VAL) ; Return the IEN for Requesting Physician Cancelled reason
+1 SET VAL=$ORDER(^ORD(100.03,"S","REQ",0))
+2 QUIT
COMPLETE(REC,ORID,ESCODE) ; Complete an order (generic orders)
+1 ;N X S X=+$E($$NOW^XLFDT,1,12)
+2 ;D DATES^ORCSAVE2(+ORID,,X)
+3 ;D STATUS^ORCSAVE2(+ORID,2)
+4 ; validate ESCode
+5 DO COMP^ORCSAVE2(ORID)
+6 DO GETBYIFN^ORWORR(.REC,ORID)
+7 QUIT
VERIFY(REC,ORID,ESCODE,ORVER) ; Verify an order
+1 ; validate ESCode
+2 SET ORVER=$GET(ORVER,$SELECT($DATA(^XUSEC("ORELSE",DUZ)):"N",$DATA(^XUSEC("OREMAS",DUZ)):"C",1:U))
+3 IF ORVER'=U
Begin DoDot:1
+4 NEW ORIFN,ORES,ORI
+5 ; to match 56, need to VERIFY any replaced orders:
+6 SET ORIFN=ORID
SET ORES(ORIFN)=""
DO REPLCD^ORCACT1
+7 ;ORID locked prior
SET ORI=""
FOR
SET ORI=$ORDER(ORES(ORI))
IF ORI=""
QUIT
DO EN^ORCSEND(ORI,"VR","","")
IF ORI'=ORID
DO UNLK1^ORX2(+ORI)
End DoDot:1
+8 DO GETBYIFN^ORWORR(.REC,ORID)
+9 QUIT
ALERT(DUMMY,ORID,ORDUZ) ;send alert to user (ORDUZ) when order (ORID) resulted
+1 ;if no user passed from GUI, use ordering provider:
+2 IF $GET(ORDUZ)<1
SET ORDUZ=+$$ORDERER^ORQOR2(+ORID)
+3 IF $LENGTH($GET(ORDUZ))<1
SET ORDUZ=DUZ
+4 SET DUMMY=1
SET $PIECE(^OR(100,+ORID,3),U,10)=ORDUZ
+5 QUIT
FLAG(REC,ORIFN,OREASON,ORNP) ; Flag an order
+1 NEW ORB,ORVP,DA,ORPS
+2 DO BULLETIN
+3 SET DA=$PIECE(ORIFN,";",2)
SET ORVP=+$PIECE(^OR(100,+ORIFN,0),U,2)
+4 KILL ^OR(100,+ORIFN,8,DA,3)
SET ^(3)="1^"_$GET(XMZ)_U_+$EXTRACT($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON_$SELECT($GET(ORNP):"^^^^"_+ORNP,1:"")
+5 DO KILL^XM
DO MSG^ORCFLAG(ORIFN)
+6 ; Last Activity
SET $PIECE(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT
+7 IF +$GET(ORNP)<1
SET ORNP=+$PIECE($GET(^OR(100,+ORIFN,8,DA,0)),U,3)
+8 ; notification
SET ORB=+ORVP_U_+ORIFN_U_ORNP_"^1"
DO EN^OCXOERR(ORB)
+9 DO GETBYIFN^ORWORR(.REC,ORIFN)
+10 QUIT
BULLETIN ; Send flagged order bulletin (USED BY FLAG)
+1 NEW OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR
+2 SET OR0=$GET(^OR(100,+ORIFN,0))
SET OR3=$GET(^(3))
+3 ;CLA - 3/21/96:
+4 SET ORUSR=+$PIECE(OR0,U,4)
+5 SET ORSRV=$GET(^VA(200,ORUSR,5))
IF +ORSRV>0
SET ORSRV=$PIECE(ORSRV,U)
+6 SET ORENT="USR.`"_ORUSR_"^SRV.`"_$GET(ORSRV)_"^DIV^SYS^PKG"
+7 SET BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q")
+8 ;quit if parameter value is not 'Y'es
IF $GET(BULL)'="Y"
QUIT
+9 ;
+10 SET XMB="OR FLAGGED ORDER"
SET XMDUZ=DUZ
SET XMY(+$PIECE(OR0,U,4))=""
+11 ;sb AGE
SET XMB(1)=$PIECE(^DPT(+$PIECE(OR0,U,2),0),U)
SET XMB(2)=$PIECE(^(0),U,9)
SET XMB(3)=""
+12 SET XMB(4)=$$FMTE^XLFDT($PIECE(OR0,U,7))
+13 DO TEXT^ORQ12(.ORDTXT,+ORIFN,80)
+14 SET XMB(5)=$GET(ORDTXT(1))
SET XMB(6)=$GET(ORDTXT(2))
SET XMB(7)=$GET(ORDTXT(3))
+15 SET XMB(8)=$$FMTE^XLFDT($PIECE(OR0,U,8))
SET XMB(9)=$$FMTE^XLFDT($PIECE(OR0,U,9))
SET XMB(10)=OREASON
+16 SET XMB(11)=$PIECE($GET(^ORD(100.01,+$PIECE(OR3,U,3),0)),U)
+17 DO EN^XMB
+18 QUIT
UNFLAG(REC,ORIFN,OREASON) ; Unflag an order
+1 NEW DA,ORB,ORNP,ORVP,ORPS
+2 SET DA=$PIECE(ORIFN,";",2)
SET ORVP=+$PIECE(^OR(100,+ORIFN,0),U,2)
+3 SET $PIECE(^OR(100,+ORIFN,8,DA,3),U)=0
SET $PIECE(^(3),U,6,8)=+$EXTRACT($$NOW^XLFDT,1,12)_U_DUZ_U_OREASON
DO MSG^ORCFLAG(ORIFN)
+4 ; Last Activity
SET $PIECE(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT
+5 SET ORNP=+$PIECE($GET(^OR(100,+ORIFN,8,DA,0)),U,3)
+6 ; notification
SET ORB=+ORVP_U_+ORIFN_U_ORNP_"^0"
DO EN^OCXOERR(ORB)
+7 DO GETBYIFN^ORWORR(.REC,ORIFN)
+8 QUIT
FLAGTXT(LST,ORID) ; Return flag reason
+1 NEW FLAG
+2 SET FLAG=$GET(^OR(100,+ORID,8,$PIECE(ORID,";",2),3))
+3 SET LST(1)="FLAGGED: "_$$FMTE^XLFDT($PIECE(FLAG,U,3))_" by "_$PIECE($GET(^VA(200,+$PIECE(FLAG,U,4),0)),U)
+4 ; reason
SET LST(2)=$PIECE(FLAG,U,5)
+5 QUIT
WCGET(LST,ORID) ; Return ward comments
+1 NEW I,ORIFN,ACT
SET ORIFN=+ORID
SET ACT=+$PIECE(ORID,";",2)
+2 SET I=0
FOR
SET I=$ORDER(^OR(100,ORIFN,8,ACT,5,I))
IF 'I
QUIT
SET LST(I)=$GET(^(I,0))
+3 QUIT
WCPUT(ERR,ORID,WCLST) ; Set ward comments for order
+1 NEW DIERR,ERRLST,ORIFN,ACT
SET ORIFN=+ORID
SET ACT=+$PIECE(ORID,";",2)
+2 DO WP^DIE(100.008,ACT_","_ORIFN_",",50,"","WCLST","ERRLST")
+3 SET ERR=""
IF $DATA(DIERR)
SET ERR="An error occurred while saving comments."
+4 QUIT
OFCPLX(ORY,ORID,PRTORDER) ;Check if ORID is an child of the PRTORDER
+1 NEW NUMCHDS,NOWID,NOWVAL,X3,ORDA,ISNOW
+2 IF '$DATA(^OR(100,+ORID,0))
QUIT
+3 SET ISNOW=0
+4 DO ISNOW^ORWDXR(.ISNOW,+ORID)
+5 IF ISNOW
QUIT
+6 NEW PKG
+7 SET PKG=$PIECE($GET(^OR(100,+ORID,0)),U,14)
+8 SET PKG=$$NMSP^ORCD(PKG)
+9 IF PKG'="PS"
QUIT
+10 IF $LENGTH($GET(^OR(100,+ORID,3)))
IF ('$LENGTH($PIECE(^(3),U,9)))
QUIT
+11 SET (NUMCHDS,NOWID,NOWVAL,X3,ORDA)=0
+12 SET PRTORDER=+$PIECE(^(3),U,9)
+13 SET X3=$GET(^OR(100,PRTORDER,3))
SET ORDA=$PIECE(X3,U,7)
+14 SET PRTORDER=PRTORDER_";"_ORDA
+15 SET NUMCHDS=$PIECE($GET(^OR(100,+PRTORDER,2,0)),U,4)
+16 IF NUMCHDS>2
SET ORY="COMPLEX-PSI"_U_PRTORDER
+17 IF $DATA(^OR(100,+PRTORDER,4.5,"ID","NOW"))
SET NOWID=$ORDER(^("NOW",0))
+18 IF NOWID
SET NOWVAL=$GET(^OR(100,+PRTORDER,4.5,NOWID,1))
+19 IF NOWVAL=1
QUIT
+20 IF '$TEST
SET ORY="COMPLEX-PSI"_U_PRTORDER
+21 QUIT
ISACTOI(ORY,OI) ;If it's an active orderable item
+1 IF $GET(^ORD(101.43,+OI,.1))
IF ^(.1)'>$$NOW^XLFDT
Begin DoDot:1
+2 SET ORY=$PIECE($GET(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore."
End DoDot:1
+3 QUIT
