Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORWDXA

ORWDXA.m

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