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 Dec 13, 2024@02:35:54 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
