- ORCACT2 ;SLC/MKB-DC orders ; 03/27/2007
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,48,79,92,108,94,141,149,265,243**;Dec 17, 1997;Build 242
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- DC ; -- start here with:
- ; ORNMBR = #,#,...,# of selected orders
- ;
- ; OREBUILD defined on return if Orders tab needs to be rebuilt
- ;
- N ORACT,ORI,NMBR,ORQUIT,ORIFN,ORDC,OREVT,ORNATR,ORPTLK,ORLK,IDX,ORDITM,ORPRINT,ORERR,ORSTS,ORPRNT,ORCLNUP,ORDA,ORCREATE,OR0,OR3,OREASON,ORXNP,ORX S VALMBCK=""
- S ORPTLK=$$LOCK^ORX2(+ORVP) I 'ORPTLK W !!,$C(7),$P(ORPTLK,U,2) H 2 Q
- I '$G(ORNMBR) S ORNMBR=$$ORDERS^ORCHART("") G:'ORNMBR DCQ
- D FREEZE^ORCMENU S ORACT="DC",VALMBCK="R" K OREBUILD
- DC1 F ORI=1:1:$L(ORNMBR,",") S NMBR=$P(ORNMBR,",",ORI) D:NMBR Q:$D(ORQUIT)
- . S IDX=$G(^TMP("OR",$J,ORTAB,"IDX",NMBR))
- . S ORIFN=$S(ORTAB="MEDS":$P(IDX,U,4),1:$P(IDX,U)) Q:'ORIFN
- . I '$D(^OR(100,+ORIFN,0)) W !,"This order has been deleted!" H 1 Q
- . S:'$P(ORIFN,";",2) ORIFN=+ORIFN_";"_+$P($G(^OR(100,+ORIFN,3)),U,7)
- . S ORDITM=$$ORDITEM(ORIFN) D SUBHDR(ORDITM)
- . I '$$VALID^ORCACT0(ORIFN,ORACT,.ORERR) W !,ORERR H 1 Q
- . S ORLK=$$LOCK1^ORX2(+ORIFN) I 'ORLK W !,$P(ORLK,U,2) H 1 Q
- . S OR0=$G(^OR(100,+ORIFN,0)),OR3=$G(^(3)),ORSTS=$P($G(^(8,+$P(ORIFN,";",2),0)),U,15)
- . S:$P(OR0,U,17) OREVT(+$P(OR0,U,17))="" ;ck event when done
- . I (ORSTS=10)!(ORSTS=11) D UNREL Q ;delete unreleased orders
- . I $P(OR0,U,11)=$O(^ORD(100.98,"B","TF",0)),$P(OR3,U,3)=6 D RESUME(ORIFN) Q:$G(ORQUIT)
- DC2 . S ORDC(ORI)=ORIFN I $$NMSP^ORCD(+$P(OR0,U,14))="PS" S ORX=1 D ;meds
- .. I $P(OR3,U,9),$$VALUE^ORX8(+ORIFN,"SCHEDULE")'="NOW",$$DOSES^ORCACT4($P(OR3,U,9))>1 D
- ... N I,X S ORDC("DAD",+$P(OR3,U,9),+ORIFN)=""
- ... W !,$C(7),"This is part of a complex order, which will be discontinued in its entirety:"
- ... S I=0 F S I=$O(^OR(100,+$P(OR3,U,9),8,1,.1,I)) Q:I<1 S X=$G(^(I,0)) W:$$UP^XLFSTR(X)'=" FIRST DOSE NOW" !,X
- .. N ORY,ORJ,ORV,ORTX,DA,DIK D DELAYED^ORX8(.ORY,+ORIFN) Q:ORY'>0
- .. W !,+ORY_" delayed order(s) for the same medication were found:"
- .. S ORJ=0 F S ORJ=$O(ORY(ORJ)) Q:ORJ'>0 S ORV=ORY(ORJ) D TEXT^ORQ12(.ORTX,ORJ) W !,$E(ORTX(1),1,75)_$S($L(ORTX(1))>75:"...",1:""),!," >> delayed until "_$P(ORV,U,2)
- .. I '$$OK(+ORY) W ! Q
- .. W !,"Orders not signed or released to the service will be deleted.",!
- .. S DIK="^OR(100,",DA=0 F S DA=$O(ORY(DA)) Q:DA'>0 D
- ... N ORJ,ORSIG,STS,ORLKD
- ... S ORLKD=$$LOCK1^ORX2(+DA) I 'ORLKD W !,$P(ORLKD,U,2) H 1 Q
- ... S STS=$P($G(^OR(100,DA,3)),U,3),ORSIG=$S($P($G(^(8,1,0)),U,4)=2:0,1:1)
- ... I STS'=10 S ORDC($$NXT)=DA Q ;released - add to list
- ... D CLRDLY(DA):ORSIG,^DIK:'ORSIG S OREVT(+ORY(DA))=""
- ... I $D(^TMP("ORNEW",$J,DA,1)) K ^(1) D UNLK1^ORX2(DA) ;unlock again
- G:'$O(ORDC(0)) DCQ D:$D(ORDC("DAD")) COMPLX
- DC3 S OREASON=$$DCREASON I OREASON'>0 D UNLOCK G DCQ
- S ORNATR=$P(OREASON,U,3),ORCREATE=1 ; CHGD $$CREATE^ORX1(ORNATR)
- I 'ORCREATE,$G(ORX),$D(^XUSEC("OREMAS",DUZ)),$$GET^XPAR("ALL","OR OREMAS MED ORDERS")<2 W $C(7),!,"You are not authorized to release med orders.",! G DC3
- I ORCREATE D I (ORNP="^")!($G(ORL)="^") D UNLOCK G DCQ
- . S ORNP=$$PROVIDER^ORCMENU1 Q:ORNP="^" ;S:ORNP=DUZ ORNATR="E"
- . I $G(ORX) D PROVIDER^ORCDPSIV I $G(ORQUIT) S ORNP="^" Q
- . S:'$G(ORL) ORL=$$LOCATION^ORCMENU1
- W ! W:'ORCREATE "Discontinuing orders ..."
- S ORPRNT=$$PRINT(ORNATR),ORCLNUP=$S(ORNATR="D":1,ORNATR="M":1,1:0)
- S (ORI,ORPRINT)=0 F S ORI=$O(ORDC(ORI)) Q:ORI'>0 S ORIFN=ORDC(ORI) D
- . I ORCREATE S ORDA=$$ACTION^ORCSAVE("DC",+ORIFN,ORNP) Q:'ORDA D SET(+ORIFN,ORNATR,+OREASON,$P(OREASON,U,2)) S ^TMP("ORNEW",$J,+ORIFN,ORDA)="" W "." Q
- . ; release -> no order or ES req'd
- . D EN^ORCSEND(+ORIFN,ORACT,3,1,ORNATR,+OREASON,.ORERR),UNLK1^ORX2(+ORIFN)
- . I '$G(ORERR) S:$P(ORPRNT,U)!$P(ORPRNT,U,5) ORPRINT=ORPRINT+1,ORPRINT(ORPRINT)=+ORIFN_";" W "." Q
- . W !,$$ORDITEM(+ORIFN)_" not discontinued."
- . W:$L($P($G(ORERR),U,2)) !," >> "_$P(ORERR,U,2) W ! H 1
- W:ORCREATE "... discontinue order(s) placed." H 1
- I $O(ORPRINT(0)) D PRINT^ORPR02(ORVP,.ORPRINT,,ORL,ORPRNT)
- S OREBUILD=1 ; rebuild orders list
- DCQ D:$G(OREBUILD) UNOTIF^ORCSIGN ; undo notif?
- D:'$D(^TMP("ORNEW",$J)) UNLOCK^ORX2(+ORVP) ;unlock if no new orders
- S:$G(ORXNP) ORNP=ORXNP ;reset provider if needed
- D:$D(OREVT) EVENT ;cancel any events?
- Q
- ;
- UNLOCK ; -- Unlock orders in ORDC(ORI)=ORIFN
- N ORI,ORIFN S ORI=0
- F S ORI=$O(ORDC(ORI)) Q:ORI'>0 S ORIFN=+ORDC(ORI) D UNLK1^ORX2(ORIFN)
- Q
- ;
- OK(NUM) ; -- Ok to DC delayed order(s) too?
- N X,Y,DIR S DIR(0)="YA",DIR("B")="NO"
- S DIR("A")="Do you want to discontinue "_$S(NUM>1:"these orders",1:"this order")_" too? "
- S DIR("?")="Enter YES to also cancel the delayed order(s), or NO to allow the order(s) to be activated when the designated event occurs."
- W ! D ^DIR
- Q +Y
- ;
- NXT() ; -- Return next available subscript in ORDC()
- N Y S Y=$L(ORNMBR,",")+1 S:Y'>$O(ORDC(""),-1) Y=$O(ORDC(""),-1)+1
- Q Y
- ;
- PRINT(NATR) ; -- Ok to print order?
- N I,OR1,Y S I=$O(^ORD(100.02,"C",NATR,0)),OR1=$G(^ORD(100.02,I,1))
- S Y=$P(OR1,U,2)_"^^^^"_$P(OR1,U,5)
- Q Y
- ;
- ORDITEM(ID) ; -- Returns order text
- ;N X,I,MORE S X=""
- ;I $P(ID,";",2)>1 S I=$P($G(^OR(100,+ID,8,+$P(ID,";",2),0)),U,2),X=$S(I="DC":"Discontinue ",I="HD":"Hold ",1:"")
- ;S I=$O(^OR(100,+ID,1,0)) Q:'I "" S MORE=$O(^(I)),X=X_$G(^(I,0))
- ;I $L(X)>68 S X=$E(X,1,68),MORE=1
- ;S:MORE X=X_" ..."
- N X,ORX D TEXT^ORQ12(.ORX,ID,68) S X=ORX(1)_$S(ORX>1:" ...",1:"")
- Q X
- ;
- SUBHDR(X) ; -- Display subheader of order being acted on
- W !!,?(36-($L(X)\2)),"-- "_X_" --",!
- Q
- ;
- COMPLX ; -- Ck for other child orders to be dc'd at same time
- N DAD,CHLD
- S DAD=0 F S DAD=$O(ORDC("DAD",DAD)) Q:DAD<1 D
- . S CHLD=0 F S CHLD=$O(^OR(100,DAD,2,CHLD)) Q:CHLD<1 D
- .. Q:"^1^2^7^12^13^14^15^"[(U_$P($G(^OR(100,CHLD,3)),U,3)_U)
- .. Q:$D(ORDC("DAD",DAD,CHLD)) S ORDC($$NXT)=CHLD
- Q
- ;
- DCREASON() ; -- Returns Reason for DC
- N X,Y,DIC
- ;I $D(^XUSEC("ORES",DUZ)) S Y=+$O(^ORD(100.03,"C","ORREQ",0)) I Y S Y(0)=$G(^ORD(100.03,Y,0)),Y=Y_U_$P(Y(0),U) G DCRQ ; silent
- S DIC="^ORD(100.03,",DIC(0)="AEMQZ",DIC("B")=+$O(^ORD(100.03,"C","ORREQ",0)),DIC("W")="W:$L($P(^(0),U))>30 $E($P(^(0),U),31,999)" K:DIC("B")'>0 DIC("B")
- S DIC("S")="I '$P(^(0),U,4),$P(^(0),U,5)="_+$O(^DIC(9.4,"C","OR",0))_",$P(^(0),U,7)'="_+$O(^ORD(100.02,"C","A",0)),DIC("A")="REASON FOR DC: "
- D ^DIC
- DCRQ S:Y>0 Y=Y_U_$S($P(Y(0),U,7):$P($G(^ORD(100.02,+$P(Y(0),U,7),0)),U,2),1:"W") ; ^nature
- Q Y
- ;
- SET(ORDER,NATURE,REASON,TEXT,DCORIG) ; -- Set DC Reason into 6-node
- Q:'$G(ORDER) Q:'$D(^OR(100,+ORDER,0)) S ORDER=+ORDER
- I $L($G(NATURE)),NATURE'>0 S NATURE=$O(^ORD(100.02,"C",NATURE,0))
- S $P(^OR(100,ORDER,6),U,1,5)=$G(NATURE)_U_DUZ_U_$E($$NOW^XLFDT,1,12)_U_$G(REASON)_U_$G(TEXT),$P(^(6),U,9)=$G(DCORIG)
- Q
- ;
- RESUME(ORDER) ; -- Resume tray service when dc'ing tubefeeding ORDER?
- N X,Y,DIR,DIC,DA S X=$$RESUME^FHWORR(+ORVP)
- I '$L(X) W !,"NOTE: NO current diet order exists for this patient!" Q
- Q:'X I X=2 W !,"Note: Patient is on a WITHHOLD SERVICE order!"
- S DIR(0)="YA",DIR("A")="Do you wish to resume tray service? "
- S DIR("?")="Enter YES to resume the previous diet order",DIR("B")="NO"
- D ^DIR I Y'=1 S:$D(DTOUT)!(X["^") ORQUIT=1
- D:Y=1 RESUME^ORCSAVE(+ORDER)
- Q
- ;
- UNREL ; -- Process unreleased/delayed order
- N ORA,ORA0,DA,DR,DIE
- S ORA=+$P(ORIFN,";",2),ORA0=$G(^OR(100,+ORIFN,8,ORA,0))
- ;S ORDEL=$S(ORSTS=11:1,$P(ORA0,U,4)=2:1,1:0)
- ;W !,"This order was not released "_$S(ORDEL:"to the service and will be deleted.",1:"but signed and will be cancelled.")
- K:$P(ORA0,U,2)="DC" ^OR(100,+ORIFN,6) I $P(ORA0,U,2)="NW" D
- . S:$P(OR3,U,5) $P(^OR(100,+$P(OR3,U,5),3),U,6)=""
- . I $P(OR0,U,17) S DA=+$O(^ORE(100.2,"AO",+ORIFN,0)) I DA S DR="4///@",DIE=100.2 D ^DIE
- D UNLK1^ORX2(+ORIFN) S OREBUILD=1
- I $D(^TMP("ORNEW",$J,+ORIFN,ORA)) K ^(ORA) D Q ;new this session
- . W !,"This order will be deleted." H 1
- . D DELETE^ORCSAVE2(ORIFN),UNLK1^ORX2(+ORIFN) ;decrement lock again
- W !,"This order was not released and will be cancelled." H 1
- D CANCEL^ORCSAVE2(ORIFN):ORSTS=11,CLRDLY(+ORIFN):ORSTS=10
- Q
- ;
- CLRDLY(IFN) ; -- [old Clear delayed fields] Cancel delayed [event]order
- N STS,ORX S IFN=+$G(IFN) Q:IFN'>0
- Q:'$D(^OR(100,IFN,0)) S STS=$P($G(^(3)),U,3)
- S ORX="Delayed "_$S(STS=10:"Order",1:"Release Event")_" Cancelled"
- S ^OR(100,IFN,6)=$O(^ORD(100.02,"C","M",0))_U_DUZ_U_+$E($$NOW^XLFDT,1,12)_U_U_ORX
- D STATUS^ORCSAVE2(IFN,13) S $P(^OR(100,IFN,8,1,0),U,15)=13
- Q
- ;
- EVENT ; -- Cancel event too?
- N EVT,X
- S EVT=0 F S EVT=$O(OREVT(EVT)) Q:EVT<1 D Q:$G(ORQUIT)
- . Q:$G(^ORE(100.2,EVT,1)) Q:'$$EMPTY^OREVNTX(EVT) ;done or has orders
- . ;W !!,$P($$NAME^OREVNTX(EVT)," ",2,99)_" has no more delayed orders."
- . ;S DIR(0)="YA",DIR("A")="Do you want to cancel this event? "
- . ;S DIR("?")="Enter NO if you wish to enter new delayed orders for this event, otherwise enter YES to terminate it."
- . ;S DIR("B")="YES" D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q
- . D CANCEL^OREVNTX(EVT) S X=$P($$NAME^OREVNTX(EVT)," ",2,99)
- . W !," ... "_X_" event cancelled." H 1
- . I $G(OREVENT),OREVENT=EVT D EX^OREVNT ;Return to Active Orders
- Q
- ;
- DCD(IFN) ; -- order discontinued already?
- N STS,Y,I S Y=0 I '$G(IFN) Q 1
- S STS=+$P($G(^OR(100,+IFN,3)),U,3)
- I "^1^2^7^12^13^14^"[(U_STS_U) S Y=1 G DQ ;terminal sts
- ;look for existing DC action awaiting ES:
- S I=0 F S I=+$O(^OR(100,+IFN,8,"C","DC",I)) Q:I<1 I $P($G(^OR(100,+IFN,8,I,0)),U,15)=11 S Y=1 Q
- DQ Q Y
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCACT2 9517 printed Feb 18, 2025@23:54:24 Page 2
- ORCACT2 ;SLC/MKB-DC orders ; 03/27/2007
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,48,79,92,108,94,141,149,265,243**;Dec 17, 1997;Build 242
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- DC ; -- start here with:
- +1 ; ORNMBR = #,#,...,# of selected orders
- +2 ;
- +3 ; OREBUILD defined on return if Orders tab needs to be rebuilt
- +4 ;
- +5 NEW ORACT,ORI,NMBR,ORQUIT,ORIFN,ORDC,OREVT,ORNATR,ORPTLK,ORLK,IDX,ORDITM,ORPRINT,ORERR,ORSTS,ORPRNT,ORCLNUP,ORDA,ORCREATE,OR0,OR3,OREASON,ORXNP,ORX
- SET VALMBCK=""
- +6 SET ORPTLK=$$LOCK^ORX2(+ORVP)
- IF 'ORPTLK
- WRITE !!,$CHAR(7),$PIECE(ORPTLK,U,2)
- HANG 2
- QUIT
- +7 IF '$GET(ORNMBR)
- SET ORNMBR=$$ORDERS^ORCHART("")
- if 'ORNMBR
- GOTO DCQ
- +8 DO FREEZE^ORCMENU
- SET ORACT="DC"
- SET VALMBCK="R"
- KILL OREBUILD
- DC1 FOR ORI=1:1:$LENGTH(ORNMBR,",")
- SET NMBR=$PIECE(ORNMBR,",",ORI)
- if NMBR
- Begin DoDot:1
- +1 SET IDX=$GET(^TMP("OR",$JOB,ORTAB,"IDX",NMBR))
- +2 SET ORIFN=$SELECT(ORTAB="MEDS":$PIECE(IDX,U,4),1:$PIECE(IDX,U))
- if 'ORIFN
- QUIT
- +3 IF '$DATA(^OR(100,+ORIFN,0))
- WRITE !,"This order has been deleted!"
- HANG 1
- QUIT
- +4 if '$PIECE(ORIFN,";",2)
- SET ORIFN=+ORIFN_";"_+$PIECE($GET(^OR(100,+ORIFN,3)),U,7)
- +5 SET ORDITM=$$ORDITEM(ORIFN)
- DO SUBHDR(ORDITM)
- +6 IF '$$VALID^ORCACT0(ORIFN,ORACT,.ORERR)
- WRITE !,ORERR
- HANG 1
- QUIT
- +7 SET ORLK=$$LOCK1^ORX2(+ORIFN)
- IF 'ORLK
- WRITE !,$PIECE(ORLK,U,2)
- HANG 1
- QUIT
- +8 SET OR0=$GET(^OR(100,+ORIFN,0))
- SET OR3=$GET(^(3))
- SET ORSTS=$PIECE($GET(^(8,+$PIECE(ORIFN,";",2),0)),U,15)
- +9 ;ck event when done
- if $PIECE(OR0,U,17)
- SET OREVT(+$PIECE(OR0,U,17))=""
- +10 ;delete unreleased orders
- IF (ORSTS=10)!(ORSTS=11)
- DO UNREL
- QUIT
- +11 IF $PIECE(OR0,U,11)=$ORDER(^ORD(100.98,"B","TF",0))
- IF $PIECE(OR3,U,3)=6
- DO RESUME(ORIFN)
- if $GET(ORQUIT)
- QUIT
- DC2 ;meds
- SET ORDC(ORI)=ORIFN
- IF $$NMSP^ORCD(+$PIECE(OR0,U,14))="PS"
- SET ORX=1
- Begin DoDot:2
- +1 IF $PIECE(OR3,U,9)
- IF $$VALUE^ORX8(+ORIFN,"SCHEDULE")'="NOW"
- IF $$DOSES^ORCACT4($PIECE(OR3,U,9))>1
- Begin DoDot:3
- +2 NEW I,X
- SET ORDC("DAD",+$PIECE(OR3,U,9),+ORIFN)=""
- +3 WRITE !,$CHAR(7),"This is part of a complex order, which will be discontinued in its entirety:"
- +4 SET I=0
- FOR
- SET I=$ORDER(^OR(100,+$PIECE(OR3,U,9),8,1,.1,I))
- if I<1
- QUIT
- SET X=$GET(^(I,0))
- if $$UP^XLFSTR(X)'=" FIRST DOSE NOW"
- WRITE !,X
- End DoDot:3
- +5 NEW ORY,ORJ,ORV,ORTX,DA,DIK
- DO DELAYED^ORX8(.ORY,+ORIFN)
- if ORY'>0
- QUIT
- +6 WRITE !,+ORY_" delayed order(s) for the same medication were found:"
- +7 SET ORJ=0
- FOR
- SET ORJ=$ORDER(ORY(ORJ))
- if ORJ'>0
- QUIT
- SET ORV=ORY(ORJ)
- DO TEXT^ORQ12(.ORTX,ORJ)
- WRITE !,$EXTRACT(ORTX(1),1,75)_$SELECT($LENGTH(ORTX(1))>75:"...",1:""),!," >> delayed until "_$PIECE(ORV,U,2)
- +8 IF '$$OK(+ORY)
- WRITE !
- QUIT
- +9 WRITE !,"Orders not signed or released to the service will be deleted.",!
- +10 SET DIK="^OR(100,"
- SET DA=0
- FOR
- SET DA=$ORDER(ORY(DA))
- if DA'>0
- QUIT
- Begin DoDot:3
- +11 NEW ORJ,ORSIG,STS,ORLKD
- +12 SET ORLKD=$$LOCK1^ORX2(+DA)
- IF 'ORLKD
- WRITE !,$PIECE(ORLKD,U,2)
- HANG 1
- QUIT
- +13 SET STS=$PIECE($GET(^OR(100,DA,3)),U,3)
- SET ORSIG=$SELECT($PIECE($GET(^(8,1,0)),U,4)=2:0,1:1)
- +14 ;released - add to list
- IF STS'=10
- SET ORDC($$NXT)=DA
- QUIT
- +15 if ORSIG
- DO CLRDLY(DA)
- if 'ORSIG
- DO ^DIK
- SET OREVT(+ORY(DA))=""
- +16 ;unlock again
- IF $DATA(^TMP("ORNEW",$JOB,DA,1))
- KILL ^(1)
- DO UNLK1^ORX2(DA)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- if $DATA(ORQUIT)
- QUIT
- +17 if '$ORDER(ORDC(0))
- GOTO DCQ
- if $DATA(ORDC("DAD"))
- DO COMPLX
- DC3 SET OREASON=$$DCREASON
- IF OREASON'>0
- DO UNLOCK
- GOTO DCQ
- +1 ; CHGD $$CREATE^ORX1(ORNATR)
- SET ORNATR=$PIECE(OREASON,U,3)
- SET ORCREATE=1
- +2 IF 'ORCREATE
- IF $GET(ORX)
- IF $DATA(^XUSEC("OREMAS",DUZ))
- IF $$GET^XPAR("ALL","OR OREMAS MED ORDERS")<2
- WRITE $CHAR(7),!,"You are not authorized to release med orders.",!
- GOTO DC3
- +3 IF ORCREATE
- Begin DoDot:1
- +4 ;S:ORNP=DUZ ORNATR="E"
- SET ORNP=$$PROVIDER^ORCMENU1
- if ORNP="^"
- QUIT
- +5 IF $GET(ORX)
- DO PROVIDER^ORCDPSIV
- IF $GET(ORQUIT)
- SET ORNP="^"
- QUIT
- +6 if '$GET(ORL)
- SET ORL=$$LOCATION^ORCMENU1
- End DoDot:1
- IF (ORNP="^")!($GET(ORL)="^")
- DO UNLOCK
- GOTO DCQ
- +7 WRITE !
- if 'ORCREATE
- WRITE "Discontinuing orders ..."
- +8 SET ORPRNT=$$PRINT(ORNATR)
- SET ORCLNUP=$SELECT(ORNATR="D":1,ORNATR="M":1,1:0)
- +9 SET (ORI,ORPRINT)=0
- FOR
- SET ORI=$ORDER(ORDC(ORI))
- if ORI'>0
- QUIT
- SET ORIFN=ORDC(ORI)
- Begin DoDot:1
- +10 IF ORCREATE
- SET ORDA=$$ACTION^ORCSAVE("DC",+ORIFN,ORNP)
- if 'ORDA
- QUIT
- DO SET(+ORIFN,ORNATR,+OREASON,$PIECE(OREASON,U,2))
- SET ^TMP("ORNEW",$JOB,+ORIFN,ORDA)=""
- WRITE "."
- QUIT
- +11 ; release -> no order or ES req'd
- +12 DO EN^ORCSEND(+ORIFN,ORACT,3,1,ORNATR,+OREASON,.ORERR)
- DO UNLK1^ORX2(+ORIFN)
- +13 IF '$GET(ORERR)
- if $PIECE(ORPRNT,U)!$PIECE(ORPRNT,U,5)
- SET ORPRINT=ORPRINT+1
- SET ORPRINT(ORPRINT)=+ORIFN_";"
- WRITE "."
- QUIT
- +14 WRITE !,$$ORDITEM(+ORIFN)_" not discontinued."
- +15 if $LENGTH($PIECE($GET(ORERR),U,2))
- WRITE !," >> "_$PIECE(ORERR,U,2)
- WRITE !
- HANG 1
- End DoDot:1
- +16 if ORCREATE
- WRITE "... discontinue order(s) placed."
- HANG 1
- +17 IF $ORDER(ORPRINT(0))
- DO PRINT^ORPR02(ORVP,.ORPRINT,,ORL,ORPRNT)
- +18 ; rebuild orders list
- SET OREBUILD=1
- DCQ ; undo notif?
- if $GET(OREBUILD)
- DO UNOTIF^ORCSIGN
- +1 ;unlock if no new orders
- if '$DATA(^TMP("ORNEW",$JOB))
- DO UNLOCK^ORX2(+ORVP)
- +2 ;reset provider if needed
- if $GET(ORXNP)
- SET ORNP=ORXNP
- +3 ;cancel any events?
- if $DATA(OREVT)
- DO EVENT
- +4 QUIT
- +5 ;
- UNLOCK ; -- Unlock orders in ORDC(ORI)=ORIFN
- +1 NEW ORI,ORIFN
- SET ORI=0
- +2 FOR
- SET ORI=$ORDER(ORDC(ORI))
- if ORI'>0
- QUIT
- SET ORIFN=+ORDC(ORI)
- DO UNLK1^ORX2(ORIFN)
- +3 QUIT
- +4 ;
- OK(NUM) ; -- Ok to DC delayed order(s) too?
- +1 NEW X,Y,DIR
- SET DIR(0)="YA"
- SET DIR("B")="NO"
- +2 SET DIR("A")="Do you want to discontinue "_$SELECT(NUM>1:"these orders",1:"this order")_" too? "
- +3 SET DIR("?")="Enter YES to also cancel the delayed order(s), or NO to allow the order(s) to be activated when the designated event occurs."
- +4 WRITE !
- DO ^DIR
- +5 QUIT +Y
- +6 ;
- NXT() ; -- Return next available subscript in ORDC()
- +1 NEW Y
- SET Y=$LENGTH(ORNMBR,",")+1
- if Y'>$ORDER(ORDC(""),-1)
- SET Y=$ORDER(ORDC(""),-1)+1
- +2 QUIT Y
- +3 ;
- PRINT(NATR) ; -- Ok to print order?
- +1 NEW I,OR1,Y
- SET I=$ORDER(^ORD(100.02,"C",NATR,0))
- SET OR1=$GET(^ORD(100.02,I,1))
- +2 SET Y=$PIECE(OR1,U,2)_"^^^^"_$PIECE(OR1,U,5)
- +3 QUIT Y
- +4 ;
- ORDITEM(ID) ; -- Returns order text
- +1 ;N X,I,MORE S X=""
- +2 ;I $P(ID,";",2)>1 S I=$P($G(^OR(100,+ID,8,+$P(ID,";",2),0)),U,2),X=$S(I="DC":"Discontinue ",I="HD":"Hold ",1:"")
- +3 ;S I=$O(^OR(100,+ID,1,0)) Q:'I "" S MORE=$O(^(I)),X=X_$G(^(I,0))
- +4 ;I $L(X)>68 S X=$E(X,1,68),MORE=1
- +5 ;S:MORE X=X_" ..."
- +6 NEW X,ORX
- DO TEXT^ORQ12(.ORX,ID,68)
- SET X=ORX(1)_$SELECT(ORX>1:" ...",1:"")
- +7 QUIT X
- +8 ;
- SUBHDR(X) ; -- Display subheader of order being acted on
- +1 WRITE !!,?(36-($LENGTH(X)\2)),"-- "_X_" --",!
- +2 QUIT
- +3 ;
- COMPLX ; -- Ck for other child orders to be dc'd at same time
- +1 NEW DAD,CHLD
- +2 SET DAD=0
- FOR
- SET DAD=$ORDER(ORDC("DAD",DAD))
- if DAD<1
- QUIT
- Begin DoDot:1
- +3 SET CHLD=0
- FOR
- SET CHLD=$ORDER(^OR(100,DAD,2,CHLD))
- if CHLD<1
- QUIT
- Begin DoDot:2
- +4 if "^1^2^7^12^13^14^15^"[(U_$PIECE($GET(^OR(100,CHLD,3)),U,3)_U)
- QUIT
- +5 if $DATA(ORDC("DAD",DAD,CHLD))
- QUIT
- SET ORDC($$NXT)=CHLD
- End DoDot:2
- End DoDot:1
- +6 QUIT
- +7 ;
- DCREASON() ; -- Returns Reason for DC
- +1 NEW X,Y,DIC
- +2 ;I $D(^XUSEC("ORES",DUZ)) S Y=+$O(^ORD(100.03,"C","ORREQ",0)) I Y S Y(0)=$G(^ORD(100.03,Y,0)),Y=Y_U_$P(Y(0),U) G DCRQ ; silent
- +3 SET DIC="^ORD(100.03,"
- SET DIC(0)="AEMQZ"
- SET DIC("B")=+$ORDER(^ORD(100.03,"C","ORREQ",0))
- SET DIC("W")="W:$L($P(^(0),U))>30 $E($P(^(0),U),31,999)"
- if DIC("B")'>0
- KILL DIC("B")
- +4 SET DIC("S")="I '$P(^(0),U,4),$P(^(0),U,5)="_+$ORDER(^DIC(9.4,"C","OR",0))_",$P(^(0),U,7)'="_+$ORDER(^ORD(100.02,"C","A",0))
- SET DIC("A")="REASON FOR DC: "
- +5 DO ^DIC
- DCRQ ; ^nature
- if Y>0
- SET Y=Y_U_$SELECT($PIECE(Y(0),U,7):$PIECE($GET(^ORD(100.02,+$PIECE(Y(0),U,7),0)),U,2),1:"W")
- +1 QUIT Y
- +2 ;
- SET(ORDER,NATURE,REASON,TEXT,DCORIG) ; -- Set DC Reason into 6-node
- +1 if '$GET(ORDER)
- QUIT
- if '$DATA(^OR(100,+ORDER,0))
- QUIT
- SET ORDER=+ORDER
- +2 IF $LENGTH($GET(NATURE))
- IF NATURE'>0
- SET NATURE=$ORDER(^ORD(100.02,"C",NATURE,0))
- +3 SET $PIECE(^OR(100,ORDER,6),U,1,5)=$GET(NATURE)_U_DUZ_U_$EXTRACT($$NOW^XLFDT,1,12)_U_$GET(REASON)_U_$GET(TEXT)
- SET $PIECE(^(6),U,9)=$GET(DCORIG)
- +4 QUIT
- +5 ;
- RESUME(ORDER) ; -- Resume tray service when dc'ing tubefeeding ORDER?
- +1 NEW X,Y,DIR,DIC,DA
- SET X=$$RESUME^FHWORR(+ORVP)
- +2 IF '$LENGTH(X)
- WRITE !,"NOTE: NO current diet order exists for this patient!"
- QUIT
- +3 if 'X
- QUIT
- IF X=2
- WRITE !,"Note: Patient is on a WITHHOLD SERVICE order!"
- +4 SET DIR(0)="YA"
- SET DIR("A")="Do you wish to resume tray service? "
- +5 SET DIR("?")="Enter YES to resume the previous diet order"
- SET DIR("B")="NO"
- +6 DO ^DIR
- IF Y'=1
- if $DATA(DTOUT)!(X["^")
- SET ORQUIT=1
- +7 if Y=1
- DO RESUME^ORCSAVE(+ORDER)
- +8 QUIT
- +9 ;
- UNREL ; -- Process unreleased/delayed order
- +1 NEW ORA,ORA0,DA,DR,DIE
- +2 SET ORA=+$PIECE(ORIFN,";",2)
- SET ORA0=$GET(^OR(100,+ORIFN,8,ORA,0))
- +3 ;S ORDEL=$S(ORSTS=11:1,$P(ORA0,U,4)=2:1,1:0)
- +4 ;W !,"This order was not released "_$S(ORDEL:"to the service and will be deleted.",1:"but signed and will be cancelled.")
- +5 if $PIECE(ORA0,U,2)="DC"
- KILL ^OR(100,+ORIFN,6)
- IF $PIECE(ORA0,U,2)="NW"
- Begin DoDot:1
- +6 if $PIECE(OR3,U,5)
- SET $PIECE(^OR(100,+$PIECE(OR3,U,5),3),U,6)=""
- +7 IF $PIECE(OR0,U,17)
- SET DA=+$ORDER(^ORE(100.2,"AO",+ORIFN,0))
- IF DA
- SET DR="4///@"
- SET DIE=100.2
- DO ^DIE
- End DoDot:1
- +8 DO UNLK1^ORX2(+ORIFN)
- SET OREBUILD=1
- +9 ;new this session
- IF $DATA(^TMP("ORNEW",$JOB,+ORIFN,ORA))
- KILL ^(ORA)
- Begin DoDot:1
- +10 WRITE !,"This order will be deleted."
- HANG 1
- +11 ;decrement lock again
- DO DELETE^ORCSAVE2(ORIFN)
- DO UNLK1^ORX2(+ORIFN)
- End DoDot:1
- QUIT
- +12 WRITE !,"This order was not released and will be cancelled."
- HANG 1
- +13 if ORSTS=11
- DO CANCEL^ORCSAVE2(ORIFN)
- if ORSTS=10
- DO CLRDLY(+ORIFN)
- +14 QUIT
- +15 ;
- CLRDLY(IFN) ; -- [old Clear delayed fields] Cancel delayed [event]order
- +1 NEW STS,ORX
- SET IFN=+$GET(IFN)
- if IFN'>0
- QUIT
- +2 if '$DATA(^OR(100,IFN,0))
- QUIT
- SET STS=$PIECE($GET(^(3)),U,3)
- +3 SET ORX="Delayed "_$SELECT(STS=10:"Order",1:"Release Event")_" Cancelled"
- +4 SET ^OR(100,IFN,6)=$ORDER(^ORD(100.02,"C","M",0))_U_DUZ_U_+$EXTRACT($$NOW^XLFDT,1,12)_U_U_ORX
- +5 DO STATUS^ORCSAVE2(IFN,13)
- SET $PIECE(^OR(100,IFN,8,1,0),U,15)=13
- +6 QUIT
- +7 ;
- EVENT ; -- Cancel event too?
- +1 NEW EVT,X
- +2 SET EVT=0
- FOR
- SET EVT=$ORDER(OREVT(EVT))
- if EVT<1
- QUIT
- Begin DoDot:1
- +3 ;done or has orders
- if $GET(^ORE(100.2,EVT,1))
- QUIT
- if '$$EMPTY^OREVNTX(EVT)
- QUIT
- +4 ;W !!,$P($$NAME^OREVNTX(EVT)," ",2,99)_" has no more delayed orders."
- +5 ;S DIR(0)="YA",DIR("A")="Do you want to cancel this event? "
- +6 ;S DIR("?")="Enter NO if you wish to enter new delayed orders for this event, otherwise enter YES to terminate it."
- +7 ;S DIR("B")="YES" D ^DIR I $D(DTOUT)!$D(DUOUT) S ORQUIT=1 Q
- +8 DO CANCEL^OREVNTX(EVT)
- SET X=$PIECE($$NAME^OREVNTX(EVT)," ",2,99)
- +9 WRITE !," ... "_X_" event cancelled."
- HANG 1
- +10 ;Return to Active Orders
- IF $GET(OREVENT)
- IF OREVENT=EVT
- DO EX^OREVNT
- End DoDot:1
- if $GET(ORQUIT)
- QUIT
- +11 QUIT
- +12 ;
- DCD(IFN) ; -- order discontinued already?
- +1 NEW STS,Y,I
- SET Y=0
- IF '$GET(IFN)
- QUIT 1
- +2 SET STS=+$PIECE($GET(^OR(100,+IFN,3)),U,3)
- +3 ;terminal sts
- IF "^1^2^7^12^13^14^"[(U_STS_U)
- SET Y=1
- GOTO DQ
- +4 ;look for existing DC action awaiting ES:
- +5 SET I=0
- FOR
- SET I=+$ORDER(^OR(100,+IFN,8,"C","DC",I))
- if I<1
- QUIT
- IF $PIECE($GET(^OR(100,+IFN,8,I,0)),U,15)=11
- SET Y=1
- QUIT
- DQ QUIT Y