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 - 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
  1. ;
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; Reference to ^VA(200 in ICR #10060
  1. ; Reference to ^DIE in ICR #2053
  1. ; Reference to ^XUSEC in ICR #10076
  1. ; Reference to ^SDAMA203 in ICR #4133
  1. ; Reference to PARK^PSO52EX in ICR #4902
  1. ; Reference to ^PSS50 in ICR #4533
  1. ; Reference to ^XM in ICR #10064
  1. ; Reference to ^XMB in ICR #10069
  1. ; Reference to ^DPT( in ICR #10035
  1. ; Reference to ^SC( in ICR #10040
  1. ;
  1. VALID(VAL,ORID,ACTION,ORNP,ORWNAT) ; Is action valid for order?
  1. N DG,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
  1. I (ACTION="RN") D Q:$L(VAL)
  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,+DLG)
  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. . N DLG,FRM,A,ORDG,I,TYPE,B
  1. . S A=^OR(100,+ORID,0),DLG=$P(A,U,5),ORDG=$P(A,"^",11),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. . I ACTION="XX" D ;PATLOC is being passed in and not defined in this routine
  1. .. F I="UNIT DOSE MEDICATIONS","INPATIENT MEDICATIONS","IV MEDICATIONS" S A=$O(^ORD(100.98,"B",I,"")) I A S A(A)=""
  1. .. S TYPE="" I $G(PATLOC) S TYPE=$P(^SC(PATLOC,0),"^",3)
  1. .. 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."
  1. S DG=$P(^OR(100,+ORID,0),U,11)
  1. 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
  1. N OREBUILD,ORSTA
  1. I $$VALID^ORCACT0(ORID,ACTION,.VAL,$G(ORWNAT)) S VAL="" ; VAL=error
  1. I ACTION="RN",$$UPCTCHK(ORID) S VAL="Cannot renew this order due to an illegal character ""^"" in the comments or patient instructions."
  1. I ACTION="RW",$$UPCTCHK(ORID) S VAL="Cannot copy this order due to an illegal character ""^"" in the comments or patient instructions."
  1. S ORSTA=$P($G(^OR(100,+ORID,3)),U,3) ;p405
  1. I ACTION="PK" D
  1. . N ORDA,ORDEA,ORDRG,ORIEN
  1. . K ^TMP($J,"ORWDXA")
  1. . I ORSTA'=6,ORSTA'=15 S VAL="Can only park an active order " Q
  1. . S ORDEA="" D I ORDEA["D" S VAL="This drug is not allowed to be parked" Q
  1. .. S ORIEN="",ORIEN=$O(^OR(100,+ORID,4.5,"ID","DRUG",ORIEN)),ORDRG=$G(^OR(100,+ORID,4.5,+ORIEN,1)) ;NEW ARF CODE
  1. .. D ZERO^PSS50(+ORDRG,,,,,"ORWDXA")
  1. .. S ORDEA=$G(^TMP($J,"ORWDXA",+ORDRG,3))
  1. .. K ^TMP($J,"ORWDXA")
  1. I ACTION="UP" D
  1. . I ORSTA'=6,+$$PARK^PSO52EX(+ORID)=0 S VAL="Order is not parked "
  1. Q
  1. ;
  1. HOLD(REC,ORID,ORNP) ; Place order on hold
  1. N ACTDA
  1. S ACTDA=$$ACTION^ORCSAVE("HD",+ORID,ORNP)
  1. D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
  1. Q
  1. UNHOLD(REC,ORID,ORNP) ; Release order from hold
  1. N ACTDA
  1. S ACTDA=$$ACTION^ORCSAVE("RL",+ORID,ORNP)
  1. D GETBYIFN^ORWORR(.REC,+ORID_";"_ACTDA)
  1. Q
  1. DC(REC,ORID,ORNP,ORL,REASON,DCORIG,ISNEWORD) ; Discontinue/Cancel/Delete order
  1. N NATURE,CREATE,PRINT,STATUS,ACTDA,SIGSTS
  1. N X3,X8,CURRACT
  1. Q:'+ORID
  1. D ORCAN^ORNORC(+ORID,"RT") ; ajb add order number to 100.3
  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 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 $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. . . N REATXT S REATXT=$S('REASON:"Requesting Physician Cancelled",1:"") D SET^ORCACT2(+ORID,NATURE,REASON,REATXT,DCORIG),DELETE^ORCSAVE2(ORID) ;*466
  1. . . ;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
  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 IEN for Req Phys Cancelled reason
  1. S VAL=$O(^ORD(100.03,"S","REQ",0))
  1. Q
  1. COMPLETE(REC,ORID,ESCODE) ; Complete order (generic)
  1. ; validate ESCode
  1. D COMP^ORCSAVE2(ORID)
  1. D COMP^ORMBLDOR(ORID)
  1. D GETBYIFN^ORWORR(.REC,ORID)
  1. D COMPLETE^ORUTL5(ORID)
  1. Q
  1. VERIFY(REC,ORID,ESCODE,ORVER) ; Verify 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. . ; 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) ; alert user (ORDUZ) when order (ORID) resulted
  1. ;if no user passed, 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,DA=+ORID,DR="35///`"_(+ORDUZ),DIE="^OR(100," D ^DIE
  1. Q
  1. FLAG(REC,ORIFN,OREASON,ORNP,OREXP,ORLIST) ; Flag order ;p539
  1. ;variable XMZ is not defined by this section, but passed in (if available)
  1. ; need to look at re-ordering this so we don't have to process the ORNP array multiple times
  1. N ORB,ORVP,DA,ORPS,ORNOW,ORFH
  1. N ORFIENS,ORFDA,FDAIEN,ERR,ORUSR,USR,I,IEN
  1. S ORNOW=$$NOW^XLFDT
  1. D BULLETIN
  1. S DA=$P(ORIFN,";",2),ORVP=+$P(^OR(100,+ORIFN,0),U,2)
  1. D FLGHST^ORWDXA1(.ORFH,ORIFN)
  1. I $D(ORFH) D SAVFLG(ORIFN,.ORFH)
  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. K ^OR(100,+ORIFN,8,DA,6),^OR(100,+ORIFN,8,DA,9)
  1. I $G(OREXP)'="" D
  1. . S ORFDA(100.008,DA_","_+ORIFN_",",44)=OREXP
  1. . D UPDATE^DIE("","ORFDA")
  1. . D SCHALRT^ORWDXA1(ORVP,ORIFN,OREXP)
  1. S I=0 F S I=$O(ORLIST(I)) Q:'I S USR=+ORLIST(I) I USR S ORUSR(USR)=""
  1. S ORFIENS="?+1"_","_DA_","_+ORIFN_",",IEN=0
  1. F S IEN=$O(ORUSR(IEN)) Q:'IEN D
  1. . S ORFDA(100.842,ORFIENS,.01)=IEN
  1. . S ORFDA(100.842,ORFIENS,1)=ORNOW
  1. . S ORFDA(100.842,ORFIENS,2)=DUZ
  1. . D UPDATE^DIE("","ORFDA")
  1. D KILL^XM,MSG^ORCFLAG(ORIFN)
  1. S $P(^OR(100,+ORIFN,3),U)=ORNOW ; Last Activity
  1. I '$D(ORUSR),$G(ORNP)="" S ORNP=+$P($G(^OR(100,+ORIFN,8,DA,0)),U,3)
  1. S USR=$S($G(ORNP):ORNP,1:$O(ORUSR(""))) I USR'="" S ORB=+ORVP_U_+ORIFN_U_USR_"^1" D EN^OCXOERR(ORB) ; notification
  1. D GETBYIFN^ORWORR(.REC,ORIFN)
  1. Q
  1. BULLETIN ; flagged order bulletin
  1. ;variables OREASON and ORIFN are assumed to be defined by the calling process and
  1. ;are neither KILLed or NEWed in this section
  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 parm val 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 order ;p539
  1. N DA,ORB,ORNP,ORVP,ORPS,ORNOW,ORUSR,I,IEN,USR,ORFB
  1. S ORNOW=$$NOW^XLFDT
  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)=ORNOW ; Last Activity
  1. ; provider and flagged by user
  1. S ORNP=+$P($G(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),0)),U,3)
  1. S ORB=+ORVP_U_+ORIFN_U_ORNP_"^0" D EN^OCXOERR(ORB) ; notification
  1. D GETBYIFN^ORWORR(.REC,ORIFN)
  1. D CHOREXP^ORWDXA1(+ORIFN) ;check if entry in file #100.97 needs to be deleted
  1. Q
  1. FLAGTXT(LST,ORID) ; flag reason
  1. N FLAG,CNT,I,ORUSR,ORCOM,F
  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. S CNT=2
  1. I $P(FLAG,U,10)'="" S CNT=CNT+1,LST(CNT)="NO ACTION ALERT: "_$$FMTE^XLFDT($P(FLAG,U,10))
  1. D FLAGRCPT^ORWDXA1(.ORUSR,ORID) ; recipients ;p539
  1. S (I,F)=0
  1. F S I=$O(ORUSR(I)) Q:'I I +ORUSR(I) D
  1. . S CNT=CNT+1,LST(CNT)=$S('F:"RECIPIENTS:"_$C(9),1:$C(9)_$C(9))_$P(ORUSR(I),U,2),F=1
  1. D FLGCOM^ORWDXA1(.ORCOM,ORID) ; comments ;p539
  1. S (I,F)=0
  1. F S I=$O(ORCOM(I)) Q:'I I ORCOM(I)="<COMMENT>" S I=$O(ORCOM(I)) D
  1. . 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
  1. . F S I=$O(ORCOM(I)) Q:ORCOM(I)="</COMMENT>" D
  1. . . S CNT=CNT+1,LST(CNT)=$C(9)_ORCOM(I)
  1. Q
  1. WCGET(LST,ORID) ; 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
  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) ; is ORID child of 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) ; Is ord item active?
  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
  1. UPCTCHK(ORID) ;
  1. ;ORID=ORDER NUMBER
  1. ;RETURNS 1 IF THERE IS AN UPCARET IN THE ORDER'S COMMENTS
  1. N RET,COMMID,WPCNT,PIID S RET=0
  1. S COMMID=$O(^OR(100,+ORID,4.5,"ID","COMMENT",0))
  1. I COMMID S WPCNT=0 F S WPCNT=$O(^OR(100,+ORID,4.5,COMMID,2,WPCNT)) Q:'WPCNT!(RET) D
  1. .I $G(^OR(100,+ORID,4.5,COMMID,2,WPCNT,0))["^" S RET=1
  1. S PIID=$O(^OR(100,+ORID,4.5,"ID","PI",0))
  1. I PIID S WPCNT=0 F S WPCNT=$O(^OR(100,+ORID,4.5,PIID,2,WPCNT)) Q:'WPCNT!(RET) D
  1. .I $G(^OR(100,+ORID,4.5,PIID,2,WPCNT,0))["^" S RET=1
  1. Q RET
  1. SAVFLG(ORIFN,ORFH) ;File flag history ;p539
  1. N ORNOW,ORFDA,ORFNM,ORFIENS
  1. S ORNOW=$$NOW^XLFDT
  1. S ORFIENS="?+1"_","_$P(ORIFN,";",2)_","_+ORIFN_","
  1. S ORFDA(100.845,ORFIENS,.01)=ORNOW
  1. S ORFDA(100.845,ORFIENS,2)=DUZ
  1. D UPDATE^DIE("","ORFDA","ORFNM")
  1. ;file comments
  1. K ^TMP($J,"WP")
  1. D WP^DIE(100.845,ORFNM(1)_","_$P(ORIFN,";",2)_","_+ORIFN_",",1,,"ORFH")
  1. K ^TMP($J,"WP"),ORFDA,ORFNM
  1. Q