- ORWDXA ; SLC/KCM/JLI - Utilities for Order Actions ; May 20, 2024@11:05
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,141,149,187,213,195,215,243,280,306,390,421,436,434,397,377,539,405,577,466**;Dec 17, 1997;Build 5
- ;
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- ; Reference to ^VA(200 in ICR #10060
- ; Reference to ^DIE in ICR #2053
- ; Reference to ^XUSEC in ICR #10076
- ; Reference to ^SDAMA203 in ICR #4133
- ; Reference to PARK^PSO52EX in ICR #4902
- ; Reference to ^PSS50 in ICR #4533
- ; Reference to ^XM in ICR #10064
- ; Reference to ^XMB in ICR #10069
- ; Reference to ^DPT( in ICR #10035
- ; Reference to ^SC( in ICR #10040
- ;
- VALID(VAL,ORID,ACTION,ORNP,ORWNAT) ; Is action valid for order?
- N DG,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
- I (ACTION="RN") D Q:$L(VAL)
- . 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,+DLG)
- . 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
- . N DLG,FRM,A,ORDG,I,TYPE,B
- . S A=^OR(100,+ORID,0),DLG=$P(A,U,5),ORDG=$P(A,"^",11),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."
- . I ACTION="XX" D ;PATLOC is being passed in and not defined in this routine
- .. F I="UNIT DOSE MEDICATIONS","INPATIENT MEDICATIONS","IV MEDICATIONS" S A=$O(^ORD(100.98,"B",I,"")) I A S A(A)=""
- .. S TYPE="" I $G(PATLOC) S TYPE=$P(^SC(PATLOC,0),"^",3)
- .. I $D(A(ORDG)),TYPE="C" S B=1 D SDAUTHCL^SDAMA203(PATLOC,.B) I B=1 S VAL="Cannot use a Clinic Location for this change. Please check your encounter location."
- S DG=$P(^OR(100,+ORID,0),U,11)
- I DG,($P(^ORD(100.98,DG,0),U,3)="CSDAM"),$P($G(^OR(100,+ORID,3)),U,3)=9 S VAL="Partial Return to Clinic Orders cannot be discontinued." Q
- N OREBUILD,ORSTA
- I $$VALID^ORCACT0(ORID,ACTION,.VAL,$G(ORWNAT)) S VAL="" ; VAL=error
- I ACTION="RN",$$UPCTCHK(ORID) S VAL="Cannot renew this order due to an illegal character ""^"" in the comments or patient instructions."
- I ACTION="RW",$$UPCTCHK(ORID) S VAL="Cannot copy this order due to an illegal character ""^"" in the comments or patient instructions."
- S ORSTA=$P($G(^OR(100,+ORID,3)),U,3) ;p405
- I ACTION="PK" D
- . N ORDA,ORDEA,ORDRG,ORIEN
- . K ^TMP($J,"ORWDXA")
- . I ORSTA'=6,ORSTA'=15 S VAL="Can only park an active order " Q
- . S ORDEA="" D I ORDEA["D" S VAL="This drug is not allowed to be parked" Q
- .. S ORIEN="",ORIEN=$O(^OR(100,+ORID,4.5,"ID","DRUG",ORIEN)),ORDRG=$G(^OR(100,+ORID,4.5,+ORIEN,1)) ;NEW ARF CODE
- .. D ZERO^PSS50(+ORDRG,,,,,"ORWDXA")
- .. S ORDEA=$G(^TMP($J,"ORWDXA",+ORDRG,3))
- .. K ^TMP($J,"ORWDXA")
- I ACTION="UP" D
- . I ORSTA'=6,+$$PARK^PSO52EX(+ORID)=0 S VAL="Order is not parked "
- Q
- ;
- HOLD(REC,ORID,ORNP) ; Place order on hold
- N ACTDA
- S ACTDA=$$ACTION^ORCSAVE("HD",+ORID,ORNP)
- D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
- Q
- UNHOLD(REC,ORID,ORNP) ; Release order from hold
- N ACTDA
- S ACTDA=$$ACTION^ORCSAVE("RL",+ORID,ORNP)
- D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
- Q
- DC(REC,ORID,ORNP,ORL,REASON,DCORIG,ISNEWORD) ; Discontinue/Cancel/Delete order
- N NATURE,CREATE,PRINT,STATUS,ACTDA,SIGSTS
- N X3,X8,CURRACT
- Q:'+ORID
- D ORCAN^ORNORC(+ORID,"RT") ; ajb add order number to 100.3
- 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 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 $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)
- . . N REATXT S REATXT=$S('REASON:"Requesting Physician Cancelled",1:"") D SET^ORCACT2(+ORID,NATURE,REASON,REATXT,DCORIG),DELETE^ORCSAVE2(ORID) ;*466
- . . ;I $G(ISNEWORD) N REATXT S REATXT=$S('REASON:"Requesting Physician Cancelled",1:"") D SET^ORCACT2(+ORID,NATURE,REASON,REATXT,DCORIG),DELETE^ORCSAVE2(ORID) ;*466
- . . ;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 IEN for Req Phys Cancelled reason
- S VAL=$O(^ORD(100.03,"S","REQ",0))
- Q
- COMPLETE(REC,ORID,ESCODE) ; Complete order (generic)
- ; validate ESCode
- D COMP^ORCSAVE2(ORID)
- D COMP^ORMBLDOR(ORID)
- D GETBYIFN^ORWORR(.REC,ORID)
- D COMPLETE^ORUTL5(ORID)
- Q
- VERIFY(REC,ORID,ESCODE,ORVER) ; Verify 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
- . ; 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) ; alert user (ORDUZ) when order (ORID) resulted
- ;if no user passed, use ordering provider:
- I $G(ORDUZ)<1 S ORDUZ=+$$ORDERER^ORQOR2(+ORID)
- I $L($G(ORDUZ))<1 S ORDUZ=DUZ
- S DUMMY=1,DA=+ORID,DR="35///`"_(+ORDUZ),DIE="^OR(100," D ^DIE
- Q
- FLAG(REC,ORIFN,OREASON,ORNP,OREXP,ORLIST) ; Flag order ;p539
- ;variable XMZ is not defined by this section, but passed in (if available)
- ; need to look at re-ordering this so we don't have to process the ORNP array multiple times
- N ORB,ORVP,DA,ORPS,ORNOW,ORFH
- N ORFIENS,ORFDA,FDAIEN,ERR,ORUSR,USR,I,IEN
- S ORNOW=$$NOW^XLFDT
- D BULLETIN
- S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2)
- D FLGHST^ORWDXA1(.ORFH,ORIFN)
- I $D(ORFH) D SAVFLG(ORIFN,.ORFH)
- 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:"")
- K ^OR(100,+ORIFN,8,DA,6),^OR(100,+ORIFN,8,DA,9)
- I $G(OREXP)'="" D
- . S ORFDA(100.008,DA_","_+ORIFN_",",44)=OREXP
- . D UPDATE^DIE("","ORFDA")
- . D SCHALRT^ORWDXA1(ORVP,ORIFN,OREXP)
- S I=0 F S I=$O(ORLIST(I)) Q:'I S USR=+ORLIST(I) I USR S ORUSR(USR)=""
- S ORFIENS="?+1"_","_DA_","_+ORIFN_",",IEN=0
- F S IEN=$O(ORUSR(IEN)) Q:'IEN D
- . S ORFDA(100.842,ORFIENS,.01)=IEN
- . S ORFDA(100.842,ORFIENS,1)=ORNOW
- . S ORFDA(100.842,ORFIENS,2)=DUZ
- . D UPDATE^DIE("","ORFDA")
- D KILL^XM,MSG^ORCFLAG(ORIFN)
- S $P(^OR(100,+ORIFN,3),U)=ORNOW ; Last Activity
- I '$D(ORUSR),$G(ORNP)="" S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3)
- S USR=$S($G(ORNP):ORNP,1:$O(ORUSR(""))) I USR'="" S ORB=+ORVP_U_+ORIFN_U_USR_"^1" D EN^OCXOERR(ORB) ; notification
- D GETBYIFN^ORWORR(.REC,ORIFN)
- Q
- BULLETIN ; flagged order bulletin
- ;variables OREASON and ORIFN are assumed to be defined by the calling process and
- ;are neither KILLed or NEWed in this section
- 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 parm val 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 order ;p539
- N DA,ORB,ORNP,ORVP,ORPS,ORNOW,ORUSR,I,IEN,USR,ORFB
- S ORNOW=$$NOW^XLFDT
- 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)=ORNOW ; Last Activity
- ; provider and flagged by user
- S ORNP=+$P($G(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),0)),U,3)
- S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification
- D GETBYIFN^ORWORR(.REC,ORIFN)
- D CHOREXP^ORWDXA1(+ORIFN) ;check if entry in file #100.97 needs to be deleted
- Q
- FLAGTXT(LST,ORID) ; flag reason
- N FLAG,CNT,I,ORUSR,ORCOM,F
- 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
- S CNT=2
- I $P(FLAG,U,10)'="" S CNT=CNT+1,LST(CNT)="NO ACTION ALERT: "_$$FMTE^XLFDT($P(FLAG,U,10))
- D FLAGRCPT^ORWDXA1(.ORUSR,ORID) ; recipients ;p539
- S (I,F)=0
- F S I=$O(ORUSR(I)) Q:'I I +ORUSR(I) D
- . S CNT=CNT+1,LST(CNT)=$S('F:"RECIPIENTS:"_$C(9),1:$C(9)_$C(9))_$P(ORUSR(I),U,2),F=1
- D FLGCOM^ORWDXA1(.ORCOM,ORID) ; comments ;p539
- S (I,F)=0
- F S I=$O(ORCOM(I)) Q:'I I ORCOM(I)="<COMMENT>" S I=$O(ORCOM(I)) D
- . S CNT=CNT+1,LST(CNT)=$S('F:"COMMENTS:"_$C(9),1:$C(9)_$C(9))_$P($P(ORCOM(I),U,2),";",2)_" on "_$P($P(ORCOM(I),U),";",2),F=1
- . F S I=$O(ORCOM(I)) Q:ORCOM(I)="</COMMENT>" D
- . . S CNT=CNT+1,LST(CNT)=$C(9)_ORCOM(I)
- Q
- WCGET(LST,ORID) ; 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
- 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) ; is ORID child of 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) ; Is ord item active?
- 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
- UPCTCHK(ORID) ;
- ;ORID=ORDER NUMBER
- ;RETURNS 1 IF THERE IS AN UPCARET IN THE ORDER'S COMMENTS
- N RET,COMMID,WPCNT,PIID S RET=0
- S COMMID=$O(^OR(100,+ORID,4.5,"ID","COMMENT",0))
- I COMMID S WPCNT=0 F S WPCNT=$O(^OR(100,+ORID,4.5,COMMID,2,WPCNT)) Q:'WPCNT!(RET) D
- .I $G(^OR(100,+ORID,4.5,COMMID,2,WPCNT,0))["^" S RET=1
- S PIID=$O(^OR(100,+ORID,4.5,"ID","PI",0))
- I PIID S WPCNT=0 F S WPCNT=$O(^OR(100,+ORID,4.5,PIID,2,WPCNT)) Q:'WPCNT!(RET) D
- .I $G(^OR(100,+ORID,4.5,PIID,2,WPCNT,0))["^" S RET=1
- Q RET
- SAVFLG(ORIFN,ORFH) ;File flag history ;p539
- N ORNOW,ORFDA,ORFNM,ORFIENS
- S ORNOW=$$NOW^XLFDT
- S ORFIENS="?+1"_","_$P(ORIFN,";",2)_","_+ORIFN_","
- S ORFDA(100.845,ORFIENS,.01)=ORNOW
- S ORFDA(100.845,ORFIENS,2)=DUZ
- D UPDATE^DIE("","ORFDA","ORFNM")
- ;file comments
- K ^TMP($J,"WP")
- D WP^DIE(100.845,ORFNM(1)_","_$P(ORIFN,";",2)_","_+ORIFN_",",1,,"ORFH")
- K ^TMP($J,"WP"),ORFDA,ORFNM
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDXA 14342 printed Feb 19, 2025@00:02:27 Page 2
- ORWDXA ; SLC/KCM/JLI - Utilities for Order Actions ; May 20, 2024@11:05
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,116,132,148,141,149,187,213,195,215,243,280,306,390,421,436,434,397,377,539,405,577,466**;Dec 17, 1997;Build 5
- +2 ;
- +3 ;Per VA Directive 6402, this routine should not be modified.
- +4 ;
- +5 ; Reference to ^VA(200 in ICR #10060
- +6 ; Reference to ^DIE in ICR #2053
- +7 ; Reference to ^XUSEC in ICR #10076
- +8 ; Reference to ^SDAMA203 in ICR #4133
- +9 ; Reference to PARK^PSO52EX in ICR #4902
- +10 ; Reference to ^PSS50 in ICR #4533
- +11 ; Reference to ^XM in ICR #10064
- +12 ; Reference to ^XMB in ICR #10069
- +13 ; Reference to ^DPT( in ICR #10035
- +14 ; Reference to ^SC( in ICR #10040
- +15 ;
- VALID(VAL,ORID,ACTION,ORNP,ORWNAT) ; Is action valid for order?
- +1 NEW DG,ORACT,ORVP,ORVER,ORIFN,PRTID
- SET VAL=""
- SET PRTID=0
- +2 IF +ORID=0
- SET VAL="This order has been deleted."
- QUIT
- +3 IF '$DATA(^OR(100,+ORID,0))
- SET VAL="This order has been deleted!"
- QUIT
- +4 ; for pre-POE
- IF ACTION="XFR"
- IF '$LENGTH($TEXT(XFR^ORCACT01))
- SET ACTION="RW"
- +5 NEW ORNSS
- SET ORNSS=1
- +6 IF (ACTION="RN")
- DO VALSCH^ORWNSS(.ORNSS,ORID)
- +7 IF ORNSS=0
- SET VAL="This order contains an invalid administration schedule."
- QUIT
- +8 IF (ACTION="RN")
- DO ISVALIV^ORWDPS33(.VAL,ORID,ACTION)
- IF $LENGTH(VAL)>0
- QUIT
- +9 ; ORCACT0 expects
- SET ORIFN=ORID
- SET ORVP=$PIECE(^OR(100,+ORID,0),U,2)
- +10 IF (ACTION="RN")
- Begin DoDot:1
- +11 NEW DLG
- SET DLG=$PIECE(^OR(100,+ORID,0),U,5)
- if DLG'[";ORD(101.41,"
- QUIT
- +12 IF $GET(^ORD(101.41,+DLG,3))'["PROVIDER^ORCDPSIV"
- QUIT
- +13 DO AUTH^ORWDPS32(.VAL,ORNP,+DLG)
- +14 IF VAL
- SET VAL=$PIECE(VAL,U,2)
- +15 IF '$TEST
- SET VAL=""
- End DoDot:1
- if $LENGTH(VAL)
- QUIT
- +16 SET ORVER=$SELECT(ACTION="CR":"R",$DATA(^XUSEC("ORELSE",DUZ)):"N",$DATA(^XUSEC("OREMAS",DUZ)):"C",1:"^")
- +17 IF ACTION="CR"
- SET ACTION="VR"
- +18 ; why not defined???
- IF (ACTION="ES")!(ACTION="OC")!(ACTION="RS")
- SET ORACT=ACTION
- +19 IF (ACTION="VR")
- IF '($DATA(^XUSEC("ORELSE",DUZ))!$DATA(^XUSEC("OREMAS",DUZ)))
- Begin DoDot:1
- +20 SET VAL="You are not authorized to verify these orders."
- End DoDot:1
- QUIT
- +21 IF $LENGTH(VAL)
- QUIT
- +22 NEW OIIEN,ISIV,IVOD
- +23 SET (ISIV,OIIEN,IVOD)=0
- +24 IF (ACTION="RW")!(ACTION="XX")!(ACTION="XFR")
- Begin DoDot:1
- +25 SET ISIV=$PIECE(^OR(100,+ORID,0),U,11)
- +26 IF ISIV
- IF ($PIECE(^ORD(100.98,ISIV,0),U,3)="IV RX")
- SET IVOD=1
- +27 if 'IVOD
- DO GTORITM^ORWDXR(.OIIEN,+ORID)
- +28 if OIIEN
- DO ISACTOI(.VAL,OIIEN)
- IF $LENGTH(VAL)>0
- QUIT
- +29 NEW DLG,FRM,A,ORDG,I,TYPE,B
- +30 SET A=^OR(100,+ORID,0)
- SET DLG=$PIECE(A,U,5)
- SET ORDG=$PIECE(A,"^",11)
- SET FRM=0
- +31 IF $PIECE(DLG,";",2)'="ORD(101.41,"
- SET DLG=0
- +32 IF DLG
- DO FORMID^ORWDXM(.FRM,+DLG)
- +33 IF '(DLG&FRM)
- Begin DoDot:2
- +34 SET VAL="Copy & Change are not implemented for this order that predates CPRS."
- End DoDot:2
- +35 ;PATLOC is being passed in and not defined in this routine
- IF ACTION="XX"
- Begin DoDot:2
- +36 FOR I="UNIT DOSE MEDICATIONS","INPATIENT MEDICATIONS","IV MEDICATIONS"
- SET A=$ORDER(^ORD(100.98,"B",I,""))
- IF A
- SET A(A)=""
- +37 SET TYPE=""
- IF $GET(PATLOC)
- SET TYPE=$PIECE(^SC(PATLOC,0),"^",3)
- +38 IF $DATA(A(ORDG))
- IF TYPE="C"
- SET B=1
- DO SDAUTHCL^SDAMA203(PATLOC,.B)
- IF B=1
- SET VAL="Cannot use a Clinic Location for this change. Please check your encounter location."
- End DoDot:2
- End DoDot:1
- if $LENGTH(VAL)
- QUIT
- +39 SET DG=$PIECE(^OR(100,+ORID,0),U,11)
- +40 IF DG
- IF ($PIECE(^ORD(100.98,DG,0),U,3)="CSDAM")
- IF $PIECE($GET(^OR(100,+ORID,3)),U,3)=9
- SET VAL="Partial Return to Clinic Orders cannot be discontinued."
- QUIT
- +41 NEW OREBUILD,ORSTA
- +42 ; VAL=error
- IF $$VALID^ORCACT0(ORID,ACTION,.VAL,$GET(ORWNAT))
- SET VAL=""
- +43 IF ACTION="RN"
- IF $$UPCTCHK(ORID)
- SET VAL="Cannot renew this order due to an illegal character ""^"" in the comments or patient instructions."
- +44 IF ACTION="RW"
- IF $$UPCTCHK(ORID)
- SET VAL="Cannot copy this order due to an illegal character ""^"" in the comments or patient instructions."
- +45 ;p405
- SET ORSTA=$PIECE($GET(^OR(100,+ORID,3)),U,3)
- +46 IF ACTION="PK"
- Begin DoDot:1
- +47 NEW ORDA,ORDEA,ORDRG,ORIEN
- +48 KILL ^TMP($JOB,"ORWDXA")
- +49 IF ORSTA'=6
- IF ORSTA'=15
- SET VAL="Can only park an active order "
- QUIT
- +50 SET ORDEA=""
- Begin DoDot:2
- +51 ;NEW ARF CODE
- SET ORIEN=""
- SET ORIEN=$ORDER(^OR(100,+ORID,4.5,"ID","DRUG",ORIEN))
- SET ORDRG=$GET(^OR(100,+ORID,4.5,+ORIEN,1))
- +52 DO ZERO^PSS50(+ORDRG,,,,,"ORWDXA")
- +53 SET ORDEA=$GET(^TMP($JOB,"ORWDXA",+ORDRG,3))
- +54 KILL ^TMP($JOB,"ORWDXA")
- End DoDot:2
- IF ORDEA["D"
- SET VAL="This drug is not allowed to be parked"
- QUIT
- End DoDot:1
- +55 IF ACTION="UP"
- Begin DoDot:1
- +56 IF ORSTA'=6
- IF +$$PARK^PSO52EX(+ORID)=0
- SET VAL="Order is not parked "
- End DoDot:1
- +57 QUIT
- +58 ;
- HOLD(REC,ORID,ORNP) ; Place order on hold
- +1 NEW ACTDA
- +2 SET ACTDA=$$ACTION^ORCSAVE("HD",+ORID,ORNP)
- +3 DO GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
- +4 QUIT
- UNHOLD(REC,ORID,ORNP) ; Release order from hold
- +1 NEW ACTDA
- +2 SET ACTDA=$$ACTION^ORCSAVE("RL",+ORID,ORNP)
- +3 DO GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
- +4 QUIT
- DC(REC,ORID,ORNP,ORL,REASON,DCORIG,ISNEWORD) ; Discontinue/Cancel/Delete order
- +1 NEW NATURE,CREATE,PRINT,STATUS,ACTDA,SIGSTS
- +2 NEW X3,X8,CURRACT
- +3 if '+ORID
- QUIT
- +4 ; ajb add order number to 100.3
- DO ORCAN^ORNORC(+ORID,"RT")
- +5 IF $GET(DCORIG)=""
- SET DCORIG=0
- +6 SET CURRACT=0
- +7 SET ORL(2)=ORL_";SC("
- SET ORL=ORL(2)
- SET NATURE=""
- +8 IF REASON
- SET NATURE=$PIECE(^ORD(100.02,$PIECE(^ORD(100.03,REASON,0),U,7),0),U,2)
- +9 ; S:ORNP=DUZ NATURE="E"
- if NATURE=""
- SET NATURE="W"
- +10 ;change the way create work to support forcing signature for all DC
- +11 ;reasons
- +12 SET CREATE=1
- SET PRINT=$$PRINT^ORCACT2(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 IF $PIECE(X8,U,2)="DC"
- KILL ^OR(100,+ORID,6)
- +35 ; delete fwd ptr to order about to be deleted
- +36 IF RPLORD
- IF $PIECE(X8,U,2)="NW"
- SET $PIECE(^OR(100,RPLORD,3),U,6)=""
- +37 ; delete ptr to order in Patient Event file #100.2
- +38 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)
- +39 ;*466
- NEW REATXT
- SET REATXT=$SELECT('REASON:"Requesting Physician Cancelled",1:"")
- DO SET^ORCACT2(+ORID,NATURE,REASON,REATXT,DCORIG)
- DO DELETE^ORCSAVE2(ORID)
- +40 ;I $G(ISNEWORD) N REATXT S REATXT=$S('REASON:"Requesting Physician Cancelled",1:"") D SET^ORCACT2(+ORID,NATURE,REASON,REATXT,DCORIG),DELETE^ORCSAVE2(ORID) ;*466
- +41 ;I '$G(ISNEWORD) D 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 IEN for Req Phys Cancelled reason
- +1 SET VAL=$ORDER(^ORD(100.03,"S","REQ",0))
- +2 QUIT
- COMPLETE(REC,ORID,ESCODE) ; Complete order (generic)
- +1 ; validate ESCode
- +2 DO COMP^ORCSAVE2(ORID)
- +3 DO COMP^ORMBLDOR(ORID)
- +4 DO GETBYIFN^ORWORR(.REC,ORID)
- +5 DO COMPLETE^ORUTL5(ORID)
- +6 QUIT
- VERIFY(REC,ORID,ESCODE,ORVER) ; Verify 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 ; 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) ; alert user (ORDUZ) when order (ORID) resulted
- +1 ;if no user passed, 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 DA=+ORID
- SET DR="35///`"_(+ORDUZ)
- SET DIE="^OR(100,"
- DO ^DIE
- +5 QUIT
- FLAG(REC,ORIFN,OREASON,ORNP,OREXP,ORLIST) ; Flag order ;p539
- +1 ;variable XMZ is not defined by this section, but passed in (if available)
- +2 ; need to look at re-ordering this so we don't have to process the ORNP array multiple times
- +3 NEW ORB,ORVP,DA,ORPS,ORNOW,ORFH
- +4 NEW ORFIENS,ORFDA,FDAIEN,ERR,ORUSR,USR,I,IEN
- +5 SET ORNOW=$$NOW^XLFDT
- +6 DO BULLETIN
- +7 SET DA=$PIECE(ORIFN,";",2)
- SET ORVP=+$PIECE(^OR(100,+ORIFN,0),U,2)
- +8 DO FLGHST^ORWDXA1(.ORFH,ORIFN)
- +9 IF $DATA(ORFH)
- DO SAVFLG(ORIFN,.ORFH)
- +10 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:"")
- +11 KILL ^OR(100,+ORIFN,8,DA,6),^OR(100,+ORIFN,8,DA,9)
- +12 IF $GET(OREXP)'=""
- Begin DoDot:1
- +13 SET ORFDA(100.008,DA_","_+ORIFN_",",44)=OREXP
- +14 DO UPDATE^DIE("","ORFDA")
- +15 DO SCHALRT^ORWDXA1(ORVP,ORIFN,OREXP)
- End DoDot:1
- +16 SET I=0
- FOR
- SET I=$ORDER(ORLIST(I))
- if 'I
- QUIT
- SET USR=+ORLIST(I)
- IF USR
- SET ORUSR(USR)=""
- +17 SET ORFIENS="?+1"_","_DA_","_+ORIFN_","
- SET IEN=0
- +18 FOR
- SET IEN=$ORDER(ORUSR(IEN))
- if 'IEN
- QUIT
- Begin DoDot:1
- +19 SET ORFDA(100.842,ORFIENS,.01)=IEN
- +20 SET ORFDA(100.842,ORFIENS,1)=ORNOW
- +21 SET ORFDA(100.842,ORFIENS,2)=DUZ
- +22 DO UPDATE^DIE("","ORFDA")
- End DoDot:1
- +23 DO KILL^XM
- DO MSG^ORCFLAG(ORIFN)
- +24 ; Last Activity
- SET $PIECE(^OR(100,+ORIFN,3),U)=ORNOW
- +25 IF '$DATA(ORUSR)
- IF $GET(ORNP)=""
- SET ORNP=+$PIECE($GET(^OR(100,+ORIFN,8,DA,0)),U,3)
- +26 ; notification
- SET USR=$SELECT($GET(ORNP):ORNP,1:$ORDER(ORUSR("")))
- IF USR'=""
- SET ORB=+ORVP_U_+ORIFN_U_USR_"^1"
- DO EN^OCXOERR(ORB)
- +27 DO GETBYIFN^ORWORR(.REC,ORIFN)
- +28 QUIT
- BULLETIN ; flagged order bulletin
- +1 ;variables OREASON and ORIFN are assumed to be defined by the calling process and
- +2 ;are neither KILLed or NEWed in this section
- +3 NEW OR0,OR3,ORDTXT,XMB,XMY,XMDUZ,ORENT,BULL,ORSRV,ORUSR
- +4 SET OR0=$GET(^OR(100,+ORIFN,0))
- SET OR3=$GET(^(3))
- +5 ;CLA - 3/21/96:
- +6 SET ORUSR=+$PIECE(OR0,U,4)
- +7 SET ORSRV=$GET(^VA(200,ORUSR,5))
- IF +ORSRV>0
- SET ORSRV=$PIECE(ORSRV,U)
- +8 SET ORENT="USR.`"_ORUSR_"^SRV.`"_$GET(ORSRV)_"^DIV^SYS^PKG"
- +9 SET BULL=$$GET^XPAR(ORENT,"ORB FLAGGED ORDERS BULLETIN",1,"Q")
- +10 ;quit if parm val not 'Y'es
- if $GET(BULL)'="Y"
- QUIT
- +11 ;
- +12 SET XMB="OR FLAGGED ORDER"
- SET XMDUZ=DUZ
- SET XMY(+$PIECE(OR0,U,4))=""
- +13 ;sb AGE
- SET XMB(1)=$PIECE(^DPT(+$PIECE(OR0,U,2),0),U)
- SET XMB(2)=$PIECE(^(0),U,9)
- SET XMB(3)=""
- +14 SET XMB(4)=$$FMTE^XLFDT($PIECE(OR0,U,7))
- +15 DO TEXT^ORQ12(.ORDTXT,+ORIFN,80)
- +16 SET XMB(5)=$GET(ORDTXT(1))
- SET XMB(6)=$GET(ORDTXT(2))
- SET XMB(7)=$GET(ORDTXT(3))
- +17 SET XMB(8)=$$FMTE^XLFDT($PIECE(OR0,U,8))
- SET XMB(9)=$$FMTE^XLFDT($PIECE(OR0,U,9))
- SET XMB(10)=OREASON
- +18 SET XMB(11)=$PIECE($GET(^ORD(100.01,+$PIECE(OR3,U,3),0)),U)
- +19 DO EN^XMB
- +20 QUIT
- UNFLAG(REC,ORIFN,OREASON) ; Unflag order ;p539
- +1 NEW DA,ORB,ORNP,ORVP,ORPS,ORNOW,ORUSR,I,IEN,USR,ORFB
- +2 SET ORNOW=$$NOW^XLFDT
- +3 SET DA=$PIECE(ORIFN,";",2)
- SET ORVP=+$PIECE(^OR(100,+ORIFN,0),U,2)
- +4 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)
- +5 ; Last Activity
- SET $PIECE(^OR(100,+ORIFN,3),U)=ORNOW
- +6 ; provider and flagged by user
- +7 SET ORNP=+$PIECE($GET(^OR(100,+ORIFN,8,+$PIECE(ORIFN,";",2),0)),U,3)
- +8 ; notification
- SET ORB=+ORVP_U_+ORIFN_U_ORNP_"^0"
- DO EN^OCXOERR(ORB)
- +9 DO GETBYIFN^ORWORR(.REC,ORIFN)
- +10 ;check if entry in file #100.97 needs to be deleted
- DO CHOREXP^ORWDXA1(+ORIFN)
- +11 QUIT
- FLAGTXT(LST,ORID) ; flag reason
- +1 NEW FLAG,CNT,I,ORUSR,ORCOM,F
- +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 SET CNT=2
- +6 IF $PIECE(FLAG,U,10)'=""
- SET CNT=CNT+1
- SET LST(CNT)="NO ACTION ALERT: "_$$FMTE^XLFDT($PIECE(FLAG,U,10))
- +7 ; recipients ;p539
- DO FLAGRCPT^ORWDXA1(.ORUSR,ORID)
- +8 SET (I,F)=0
- +9 FOR
- SET I=$ORDER(ORUSR(I))
- if 'I
- QUIT
- IF +ORUSR(I)
- Begin DoDot:1
- +10 SET CNT=CNT+1
- SET LST(CNT)=$SELECT('F:"RECIPIENTS:"_$CHAR(9),1:$CHAR(9)_$CHAR(9))_$PIECE(ORUSR(I),U,2)
- SET F=1
- End DoDot:1
- +11 ; comments ;p539
- DO FLGCOM^ORWDXA1(.ORCOM,ORID)
- +12 SET (I,F)=0
- +13 FOR
- SET I=$ORDER(ORCOM(I))
- if 'I
- QUIT
- IF ORCOM(I)="<COMMENT>"
- SET I=$ORDER(ORCOM(I))
- Begin DoDot:1
- +14 SET CNT=CNT+1
- SET LST(CNT)=$SELECT('F:"COMMENTS:"_$CHAR(9),1:$CHAR(9)_$CHAR(9))_$PIECE($PIECE(ORCOM(I),U,2),";",2)_" on "_$PIECE($PIECE(ORCOM(I),U),";",2)
- SET F=1
- +15 FOR
- SET I=$ORDER(ORCOM(I))
- if ORCOM(I)="</COMMENT>"
- QUIT
- Begin DoDot:2
- +16 SET CNT=CNT+1
- SET LST(CNT)=$CHAR(9)_ORCOM(I)
- End DoDot:2
- End DoDot:1
- +17 QUIT
- WCGET(LST,ORID) ; 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
- +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) ; is ORID child of 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) ; Is ord item active?
- +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
- UPCTCHK(ORID) ;
- +1 ;ORID=ORDER NUMBER
- +2 ;RETURNS 1 IF THERE IS AN UPCARET IN THE ORDER'S COMMENTS
- +3 NEW RET,COMMID,WPCNT,PIID
- SET RET=0
- +4 SET COMMID=$ORDER(^OR(100,+ORID,4.5,"ID","COMMENT",0))
- +5 IF COMMID
- SET WPCNT=0
- FOR
- SET WPCNT=$ORDER(^OR(100,+ORID,4.5,COMMID,2,WPCNT))
- if 'WPCNT!(RET)
- QUIT
- Begin DoDot:1
- +6 IF $GET(^OR(100,+ORID,4.5,COMMID,2,WPCNT,0))["^"
- SET RET=1
- End DoDot:1
- +7 SET PIID=$ORDER(^OR(100,+ORID,4.5,"ID","PI",0))
- +8 IF PIID
- SET WPCNT=0
- FOR
- SET WPCNT=$ORDER(^OR(100,+ORID,4.5,PIID,2,WPCNT))
- if 'WPCNT!(RET)
- QUIT
- Begin DoDot:1
- +9 IF $GET(^OR(100,+ORID,4.5,PIID,2,WPCNT,0))["^"
- SET RET=1
- End DoDot:1
- +10 QUIT RET
- SAVFLG(ORIFN,ORFH) ;File flag history ;p539
- +1 NEW ORNOW,ORFDA,ORFNM,ORFIENS
- +2 SET ORNOW=$$NOW^XLFDT
- +3 SET ORFIENS="?+1"_","_$PIECE(ORIFN,";",2)_","_+ORIFN_","
- +4 SET ORFDA(100.845,ORFIENS,.01)=ORNOW
- +5 SET ORFDA(100.845,ORFIENS,2)=DUZ
- +6 DO UPDATE^DIE("","ORFDA","ORFNM")
- +7 ;file comments
- +8 KILL ^TMP($JOB,"WP")
- +9 DO WP^DIE(100.845,ORFNM(1)_","_$PIECE(ORIFN,";",2)_","_+ORIFN_",",1,,"ORFH")
- +10 KILL ^TMP($JOB,"WP"),ORFDA,ORFNM
- +11 QUIT