- ORCACT0 ;SLC/MKB-Validate order action ;03-Apr-2012 11:51;PLS
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,86,92,94,141,165,177,173,190,1002,1003,1004,1005,1006,215,243,289,1010**;Dec 17, 1997;Build 47
- ;
- ;Reference to REFILL^PSOREF supported by IA #2399
- ;Modified - IHS/MSC/PLS - 08/06/2010 - Line HD+5,VALID+2,VALID+4
- ; 08/09/2010 - Line VR+3, EP CHKVF, RL+5, RW, EV+2
- ; 10/06/2010 - Line HD+7
- ;Modified - IHS/MSC/JDS - 03/12/12 - exclude home med from screening
- VALID(IFN,ACTION,ERROR,NATR) ; -- Determines if action is valid for order IFN
- N OR0,OR3,ORA0,AIFN,PKG,DG,ORDSTS,ACTSTS,VER,X,Y,MEDPARM K ERROR
- N NV ;IHS/MSC/REC/PLS - 08/09/10
- S OR0=$G(^OR(100,+IFN,0)),OR3=$G(^(3)),PKG=$$NMSP^ORCD($P(OR0,U,14))
- ;S DG=$P($G(^ORD(100.98,+$P(OR0,U,11),0)),U,3)
- S DG=$G(^ORD(100.98,+$P(OR0,U,11),0)),NV=$S($P(DG,U,3)="NV RX":$P(DG,U,2),1:""),DG=$P(DG,U,3)
- ;IHS/MSC/REC/PLS - 08/09/2010
- S MEDPARM=$S($G(NATR)="A":2,PKG'="PS":2,'$D(^XUSEC("OREMAS",DUZ)):2,DG="NV RX":$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS"),1:$$GET^XPAR("ALL","OR OREMAS MED ORDERS"))
- S AIFN=$P(IFN,";",2) S:'AIFN AIFN=+$P(OR3,U,7)
- S ORA0=$G(^OR(100,+IFN,8,AIFN,0)),ACTSTS=$P(ORA0,U,15)
- S ORDSTS=$P(OR3,U,3),VER=$S($P(OR0,U,5)["101.41":3,1:2)
- CM I ACTION="CM" S ERROR="This action is no longer available!" G VQ ; ward comments - no restrictions
- FL I ACTION="FL" D G VQ ; flag
- . I +$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is already flagged!" Q
- UF I ACTION="UF" D G VQ ; unflag
- . I '+$G(^OR(100,+IFN,8,AIFN,3)) S ERROR="This order is not flagged!" Q
- DC1 I ACTION="DC",ACTSTS D G VQ ; discontinue/cancel unrel or canc order
- . I (ACTSTS=11)!(ACTSTS=10) D Q ; unreleased
- .. I 'MEDPARM S ERROR="You are not authorized to cancel med orders!" Q
- .. I $G(NATR)="A" S X=$O(^ORE(100.2,"AO",+IFN,0)) I X,'$G(^ORE(100.2,X,1)) S ERROR="Future event orders may not be auto-discontinued!" Q
- . I ACTSTS=12 S ERROR="This order has been dc'd due to edit!" Q
- . I ACTSTS=13 S ERROR="This order has been cancelled!" Q
- ES I (ACTION="ES")!(ACTION="OC")!(ACTION="RS")!(ACTION="DS") D ES^ORCACT01 G VQ ; sign
- VR I ACTION="VR" D G VQ ; verify
- . I $G(ORVER)="N",$P(ORA0,U,9) S ERROR="This order has been verified!" Q
- . I $G(ORVER)="C",$P(ORA0,U,11) S ERROR="This order has been verified!" Q
- . ;IHS/MSC/REC/PLS - 08/09/10
- . ;I $G(ORVER)="R",$P(ORA0,U,19) S ERROR="This order has been reviewed!" Q
- . I $G(ORVER)="R" D CHKVF Q:$L($G(ERROR))
- . I (ACTSTS=11)!(ACTSTS=10) S ERROR="This order has not been released to the service." Q
- . I AIFN=1,ORDSTS=5,PKG="PS" S X=$$DISABLED I X S ERROR=$P(X,U,2) Q
- DIS S X=$$DISABLED I X S ERROR=$P(X,U,2) G VQ
- MN I ACTION="MN" D G VQ ; manually release (delayed)
- . I ACTSTS'=10,ACTSTS'=11 S ERROR="This order has already been released!" Q
- . I $P(OR0,U,12)="I",'$G(^DPT(+ORVP,.105)) S ERROR="This patient is not currently admitted!"
- GMRA I PKG="GMRA" S ERROR="This action is not allowed on an allergy/adverse reaction!" G VQ ; no actions allowed on Allergies
- MEDS I PKG="PS",'MEDPARM S ERROR="You are not authorized to enter med orders!" G VQ
- RW ;IHS/MSC/REC/PLS - 08/09/2010
- ;I ACTION="RW" D RW^ORCACT01 G VQ ; rewrite/copy
- I ACTION="RW",NV=""!(ACTSTS=12) D RW^ORCACT01 G VQ ; rewrite/copy
- XFR I ACTION="XFR" D G VQ
- . N A
- . S A=""
- . F S A=$O(^OR(100,+IFN,4.5,"ID","CONJ",A)) Q:'A I ^OR(100,+IFN,4.5,A,1)="X" S ERROR="Orders with a conjunction of 'EXCEPT' may not be transferred." Q
- . I $G(ERROR)]"" Q
- . D XFR^ORCACT01 ; transfer to in/outpt
- RN I ACTION="RN" D RN^ORCACT01 G VQ ; renew
- TRM I $$DONE G VQ ; ORDSTS=1,2,7,12,13
- EV I ACTION="EV" D G VQ ; change delay event
- . I ORDSTS'=10,ORDSTS'=11 S ERROR="This order has been released!" Q
- . ;IHS/MSC/REC/PLS - 08/09/10
- . ;I DG="NV RX" S ERROR="Outside med orders do not support this action!" Q
- . I $L(NV) S ERROR=NV_" orders do not support this action!" Q
- . I $$EVTORDER^OREVNTX(IFN) S ERROR="The release event for this order may not be changed!" Q
- . S X=$P(ORA0,U,4) I X'=2,X'=3 S ERROR="Signed orders may not be delayed to another event!" Q
- DC2 I ACTION="DC",ACTSTS="" D G VQ ; DC released order
- . I $G(NATR)="A" D Q:$D(ERROR)
- .. S X=$O(^ORE(100.2,"AO",+IFN,0)) I X S:'$G(^ORE(100.2,X,1)) ERROR="Future event orders may not be auto-discontinued!" Q
- .. I $$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO",$G(DGPMT)=1 Q ;177 If admission auto-dc and order is outpt med then no further checking needed
- .. I $G(DGPMT)=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)'="C" S ERROR="Only outpatient orders may be auto-discontinued!" Q
- .. I $G(DGPMT)'=1,$P($G(^SC(+$P(OR0,U,10),0)),U,3)="C",PKG'="PS" S ERROR="Only inpatient orders may be auto-discontinued!" Q
- . I PKG="RA",ORDSTS=6 S ERROR="Active Radiology orders cannot be discontinued!" Q
- . I PKG="VBEC",ORDSTS=6 S ERROR="Active Blood Product orders cannot be discontinued!" Q
- . I PKG="LR" D Q
- .. I $$COLLECTD S ERROR="Lab orders that have been collected may not be discontinued!" Q
- .. I $G(NATR)="A","^12^38^"'[(U_$P($G(DGPMA),U,18)_U),$$VALUE^ORX8(+IFN,"COLLECT")="SP",$P(OR0,U,8)'<DT S ERROR="Future Send Patient orders may not be auto-discontinued!" Q
- . I PKG="GMRC",ORDSTS=9 S ERROR="Consults orders with partial results cannot be discontinued!" Q
- . I DG="DO",$G(DGPMT)'=3,ORDSTS=6,'$$NPO(+IFN) S ERROR="Active Diets cannot be discontinued; please order a new diet!" Q
- RL I ACTION="RL" D G VQ ; release hold
- . I ORDSTS'=3 D Q
- ..I $P(ORA0,U,4)=2 S ERROR="Providers has not yet signed the hold order and therefor it cannot yet be released" Q
- ..S ERROR="Orders not on hold cannot be released!" Q
- . I ACTSTS S ERROR=$$ACTION($P(ORA0,U,2))_" orders cannot be released from hold!" Q
- . N NATR,ACT S ACT=$S($P(ORA0,U,2)="HD":AIFN,1:+$P(OR3,U,7))
- . S NATR=+$P($G(^OR(100,+IFN,8,ACT,0)),U,12),ACT=$P($G(^(0)),U,2)
- . ;IHS/MSC/REC/PLS - 08/09/10
- . ;I PKG="RA"!(ACT'="HD")!($P($G(^ORD(100.02,NATR,0)),U,2)="S") S ERROR="Orders held by a service must be released from hold through the service!" Q
- . I PKG="RA"!(ACT'="HD")!($P($G(^ORD(100.02,NATR,0)),U,2)="S") I $G(NV)="" S ERROR="Orders held by a service must be released from hold through the service!" Q
- AIFN S X=$P(ORA0,U,2) I AIFN>1,ACTSTS S ERROR="This action is not allowed on a "_$$ACTION(X)_" order!" G VQ
- RF I ACTION="RF" D G VQ
- . I DG'="O RX" S ERROR="Only Outpatient Med orders may be refilled!" Q
- . I ORDSTS=5 S ERROR="Pending orders may not be refilled!" Q
- . I ORDSTS=7 S ERROR="Expired orders may not be refilled!" Q
- . N X,PSIFN S PSIFN=$G(^OR(100,+IFN,4))
- . S X=$$REFILL^PSOREF(PSIFN) I X'>0 S ERROR=$P(X,U,2) Q
- . I (DG="NV RX")!($T(SCREEN^APSPMULT)="") Q
- . N DFN,Y S Y=$$VALUE^ORX8(+ORIFN,"DRUG",1,"I"),DFN=+$P($G(^OR(100,+ORIFN,0)),U,2)
- . I '$$SCREEN^APSPMULT(+Y,,1) S ERROR="Invalid Drug for refill on this patient"
- CP I ACTION="CP" D G VQ ; complete
- . I PKG'="OR" S ERROR="Only generic text orders may be completed through this option!" Q
- . I ORDSTS=11!(ORDSTS=10) S ERROR="This order has not been released!" Q
- AL I ACTION="AL" D G VQ
- . I PKG'="LR",PKG'="RA",PKG'="GMRC" S ERROR="This order does not generate results!" Q
- . I $P(OR3,U,10) S ERROR="This order is already flagged to alert the provider when resulted!" Q
- XX I ACTION="XX" D G VQ ; edit/change
- . I ORDSTS=7 S ERROR="Expired orders may not be changed!" Q
- . D XX^ORCACT01
- HD I ACTION="HD" D G VQ ; hold
- . I PKG="FH" S ERROR="Diet orders cannot be held!" Q
- . I PKG="LR" S ERROR="Lab orders cannot be held!" Q
- . I PKG="RA" S ERROR="Radiology orders cannot be held!" Q
- . I PKG="GMRC" S ERROR="Consult orders cannot be held!" Q
- . ;I DG="NV RX" S ERROR="Outside med orders cannot be held!" Q ;IHS/MSC/PLS - 08/06/10 Available for hold
- . I ORDSTS=3 S ERROR="This order is already on hold!" Q
- .;I ORDSTS'=6,PKG="PS" S ERROR="Only active Pharmacy orders may be held!" Q
- .I ORDSTS-6,ORDSTS-21400,ORDSTS-21401,PKG="PS" S ERROR="Only active Pharmacy orders may be held!" Q ;Allow hold for transfer to IP/OP
- . I ORDSTS=6,PKG="PS",$P($G(^PSRX(+$G(^OR(100,+IFN,4)),999999921)),U,3) S ERROR="Outside pharmacy prescriptions can't be placed on hold!" ;IHS/MSC/PLS - 10/17/07
- . I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q
- VQ S Y=$S($D(ERROR):0,1:1)
- Q Y
- ;
- ACTION(X) ; -- Return text of action X
- N Y S Y=$S(X="NW":"New",X="DC":"Discontinue",X="HD":"Hold",X="RL":"Release Hold",X="RN":"Renew",1:X)
- Q Y
- ;
- NPO(ORIFN) ; -- Returns 1 or 0, if order ORIFN is for NPO
- N X,Y S X=$$VALUE^ORX8(+ORIFN,"ORDERABLE",1,"E")
- S Y=$S($E(X,1,3)="NPO":1,1:0)
- Q Y
- ;
- COLLECTD() ; -- Lab order collected/active (incl all children)?
- I (ORDSTS=11)!(ORDSTS=10) Q 0 ; unreleased
- I '$O(^OR(100,+IFN,2,0)) Q (ORDSTS'=5)
- ;I ORDSTS'=6 Q 1 ; Parent -> active instead of pending
- N Y,Z S Y=1,Z=0
- F S Z=$O(^OR(100,+IFN,2,Z)) Q:Z'>0 I $P($G(^OR(100,Z,3)),U,3)=5 S Y=0 Q
- Q Y
- ;
- DONE() ; -- sets ERROR if terminal status
- I ORDSTS=1 S ERROR="This order has been discontinued!" Q 1
- I ORDSTS=2 S ERROR="This order has been completed!" Q 1
- I ORDSTS=7,DG'="O RX" S ERROR="This order has expired!" Q 1
- I ORDSTS=12 S ERROR="This order has been changed!" Q 1
- I ORDSTS=13 S ERROR="This order has been cancelled!" Q 1
- I ORDSTS=14 S ERROR="This order has lapsed!" Q 1
- I ORDSTS=15 S ERROR="This order has been renewed!" Q 1
- Q 0
- ;
- DISABLED() ; -- Order dialog [or protocol] disabled?
- N X,DLG S DLG=$P(OR0,U,5),X=0 I +DLG'>0 Q X
- I VER'<3,DLG?1.N1";ORD(101.41," S X=$$MSG^ORXD(+DLG) Q X
- S DLG=$S(PKG="RA":"RA OERR EXAM",PKG="GMRC":"GMRCOR CONSULT",1:"")
- I $L(DLG) S DLG=+$O(^ORD(101.41,"AB",DLG,0)),X=$$MSG^ORXD(DLG)
- Q X
- ;Check for verified state
- CHKVF ;EP - IHS/MSC/REC/PLS - 08/09/10
- N RD,LST,NOW,DTCMP
- S RD=$P(ORA0,U,19)
- I RD D
- .S LST=$O(^OR(100,+IFN,8,AIFN,"MSC",""),-1) Q:'LST
- .S LST=+$O(^OR(100,+IFN,8,AIFN,"MSC",LST),-1)
- .S RD=$S(LST:$P($G(^(LST,0)),U,2),1:RD)
- .S NOW=$$NOW^XLFDT()
- .S DTCMP=$$FMDIFF^XLFDT(NOW,RD)
- .I $S(DTCMP>1:1,DTCMP=1:$E(NOW,8,99)>$E(RD,8,99),1:0) Q
- .S ERROR="This order cannot be reviewed more than twice within 24 hours!"
- Q
- ORCACT0 ;SLC/MKB-Validate order action ;03-Apr-2012 11:51;PLS
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,27,48,72,86,92,94,141,165,177,173,190,1002,1003,1004,1005,1006,215,243,289,1010**;Dec 17, 1997;Build 47
- +2 ;
- +3 ;Reference to REFILL^PSOREF supported by IA #2399
- +4 ;Modified - IHS/MSC/PLS - 08/06/2010 - Line HD+5,VALID+2,VALID+4
- +5 ; 08/09/2010 - Line VR+3, EP CHKVF, RL+5, RW, EV+2
- +6 ; 10/06/2010 - Line HD+7
- +7 ;Modified - IHS/MSC/JDS - 03/12/12 - exclude home med from screening
- VALID(IFN,ACTION,ERROR,NATR) ; -- Determines if action is valid for order IFN
- +1 NEW OR0,OR3,ORA0,AIFN,PKG,DG,ORDSTS,ACTSTS,VER,X,Y,MEDPARM
- KILL ERROR
- +2 ;IHS/MSC/REC/PLS - 08/09/10
- NEW NV
- +3 SET OR0=$GET(^OR(100,+IFN,0))
- SET OR3=$GET(^(3))
- SET PKG=$$NMSP^ORCD($PIECE(OR0,U,14))
- +4 ;S DG=$P($G(^ORD(100.98,+$P(OR0,U,11),0)),U,3)
- +5 SET DG=$GET(^ORD(100.98,+$PIECE(OR0,U,11),0))
- SET NV=$SELECT($PIECE(DG,U,3)="NV RX":$PIECE(DG,U,2),1:"")
- SET DG=$PIECE(DG,U,3)
- +6 ;IHS/MSC/REC/PLS - 08/09/2010
- +7 SET MEDPARM=$SELECT($GET(NATR)="A":2,PKG'="PS":2,'$DATA(^XUSEC("OREMAS",DUZ)):2,DG="NV RX":$$GET^XPAR("ALL","OR OREMAS NON-VA MED ORDERS"),1:$$GET^XPAR("ALL","OR OREMAS MED ORDERS"))
- +8 SET AIFN=$PIECE(IFN,";",2)
- IF 'AIFN
- SET AIFN=+$PIECE(OR3,U,7)
- +9 SET ORA0=$GET(^OR(100,+IFN,8,AIFN,0))
- SET ACTSTS=$PIECE(ORA0,U,15)
- +10 SET ORDSTS=$PIECE(OR3,U,3)
- SET VER=$SELECT($PIECE(OR0,U,5)["101.41":3,1:2)
- CM ; ward comments - no restrictions
- IF ACTION="CM"
- SET ERROR="This action is no longer available!"
- GOTO VQ
- FL ; flag
- IF ACTION="FL"
- Begin DoDot:1
- +1 IF +$GET(^OR(100,+IFN,8,AIFN,3))
- SET ERROR="This order is already flagged!"
- QUIT
- End DoDot:1
- GOTO VQ
- UF ; unflag
- IF ACTION="UF"
- Begin DoDot:1
- +1 IF '+$GET(^OR(100,+IFN,8,AIFN,3))
- SET ERROR="This order is not flagged!"
- QUIT
- End DoDot:1
- GOTO VQ
- DC1 ; discontinue/cancel unrel or canc order
- IF ACTION="DC"
- IF ACTSTS
- Begin DoDot:1
- +1 ; unreleased
- IF (ACTSTS=11)!(ACTSTS=10)
- Begin DoDot:2
- +2 IF 'MEDPARM
- SET ERROR="You are not authorized to cancel med orders!"
- QUIT
- +3 IF $GET(NATR)="A"
- SET X=$ORDER(^ORE(100.2,"AO",+IFN,0))
- IF X
- IF '$GET(^ORE(100.2,X,1))
- SET ERROR="Future event orders may not be auto-discontinued!"
- QUIT
- End DoDot:2
- QUIT
- +4 IF ACTSTS=12
- SET ERROR="This order has been dc'd due to edit!"
- QUIT
- +5 IF ACTSTS=13
- SET ERROR="This order has been cancelled!"
- QUIT
- End DoDot:1
- GOTO VQ
- ES ; sign
- IF (ACTION="ES")!(ACTION="OC")!(ACTION="RS")!(ACTION="DS")
- DO ES^ORCACT01
- GOTO VQ
- VR ; verify
- IF ACTION="VR"
- Begin DoDot:1
- +1 IF $GET(ORVER)="N"
- IF $PIECE(ORA0,U,9)
- SET ERROR="This order has been verified!"
- QUIT
- +2 IF $GET(ORVER)="C"
- IF $PIECE(ORA0,U,11)
- SET ERROR="This order has been verified!"
- QUIT
- +3 ;IHS/MSC/REC/PLS - 08/09/10
- +4 ;I $G(ORVER)="R",$P(ORA0,U,19) S ERROR="This order has been reviewed!" Q
- +5 IF $GET(ORVER)="R"
- DO CHKVF
- IF $LENGTH($GET(ERROR))
- QUIT
- +6 IF (ACTSTS=11)!(ACTSTS=10)
- SET ERROR="This order has not been released to the service."
- QUIT
- +7 IF AIFN=1
- IF ORDSTS=5
- IF PKG="PS"
- SET X=$$DISABLED
- IF X
- SET ERROR=$PIECE(X,U,2)
- QUIT
- End DoDot:1
- GOTO VQ
- DIS SET X=$$DISABLED
- IF X
- SET ERROR=$PIECE(X,U,2)
- GOTO VQ
- MN ; manually release (delayed)
- IF ACTION="MN"
- Begin DoDot:1
- +1 IF ACTSTS'=10
- IF ACTSTS'=11
- SET ERROR="This order has already been released!"
- QUIT
- +2 IF $PIECE(OR0,U,12)="I"
- IF '$GET(^DPT(+ORVP,.105))
- SET ERROR="This patient is not currently admitted!"
- End DoDot:1
- GOTO VQ
- GMRA ; no actions allowed on Allergies
- IF PKG="GMRA"
- SET ERROR="This action is not allowed on an allergy/adverse reaction!"
- GOTO VQ
- MEDS IF PKG="PS"
- IF 'MEDPARM
- SET ERROR="You are not authorized to enter med orders!"
- GOTO VQ
- RW ;IHS/MSC/REC/PLS - 08/09/2010
- +1 ;I ACTION="RW" D RW^ORCACT01 G VQ ; rewrite/copy
- +2 ; rewrite/copy
- IF ACTION="RW"
- IF NV=""!(ACTSTS=12)
- DO RW^ORCACT01
- GOTO VQ
- XFR IF ACTION="XFR"
- Begin DoDot:1
- +1 NEW A
- +2 SET A=""
- +3 FOR
- SET A=$ORDER(^OR(100,+IFN,4.5,"ID","CONJ",A))
- IF 'A
- QUIT
- IF ^OR(100,+IFN,4.5,A,1)="X"
- SET ERROR="Orders with a conjunction of 'EXCEPT' may not be transferred."
- QUIT
- +4 IF $GET(ERROR)]""
- QUIT
- +5 ; transfer to in/outpt
- DO XFR^ORCACT01
- End DoDot:1
- GOTO VQ
- RN ; renew
- IF ACTION="RN"
- DO RN^ORCACT01
- GOTO VQ
- TRM ; ORDSTS=1,2,7,12,13
- IF $$DONE
- GOTO VQ
- EV ; change delay event
- IF ACTION="EV"
- Begin DoDot:1
- +1 IF ORDSTS'=10
- IF ORDSTS'=11
- SET ERROR="This order has been released!"
- QUIT
- +2 ;IHS/MSC/REC/PLS - 08/09/10
- +3 ;I DG="NV RX" S ERROR="Outside med orders do not support this action!" Q
- +4 IF $LENGTH(NV)
- SET ERROR=NV_" orders do not support this action!"
- QUIT
- +5 IF $$EVTORDER^OREVNTX(IFN)
- SET ERROR="The release event for this order may not be changed!"
- QUIT
- +6 SET X=$PIECE(ORA0,U,4)
- IF X'=2
- IF X'=3
- SET ERROR="Signed orders may not be delayed to another event!"
- QUIT
- End DoDot:1
- GOTO VQ
- DC2 ; DC released order
- IF ACTION="DC"
- IF ACTSTS=""
- Begin DoDot:1
- +1 IF $GET(NATR)="A"
- Begin DoDot:2
- +2 SET X=$ORDER(^ORE(100.2,"AO",+IFN,0))
- IF X
- IF '$GET(^ORE(100.2,X,1))
- SET ERROR="Future event orders may not be auto-discontinued!"
- QUIT
- +3 ;177 If admission auto-dc and order is outpt med then no further checking needed
- IF $$GET1^DIQ(9.4,+$PIECE(OR0,U,14)_",",1)="PSO"
- IF $GET(DGPMT)=1
- QUIT
- +4 IF $GET(DGPMT)=1
- IF $PIECE($GET(^SC(+$PIECE(OR0,U,10),0)),U,3)'="C"
- SET ERROR="Only outpatient orders may be auto-discontinued!"
- QUIT
- +5 IF $GET(DGPMT)'=1
- IF $PIECE($GET(^SC(+$PIECE(OR0,U,10),0)),U,3)="C"
- IF PKG'="PS"
- SET ERROR="Only inpatient orders may be auto-discontinued!"
- QUIT
- End DoDot:2
- IF $DATA(ERROR)
- QUIT
- +6 IF PKG="RA"
- IF ORDSTS=6
- SET ERROR="Active Radiology orders cannot be discontinued!"
- QUIT
- +7 IF PKG="VBEC"
- IF ORDSTS=6
- SET ERROR="Active Blood Product orders cannot be discontinued!"
- QUIT
- +8 IF PKG="LR"
- Begin DoDot:2
- +9 IF $$COLLECTD
- SET ERROR="Lab orders that have been collected may not be discontinued!"
- QUIT
- +10 IF $GET(NATR)="A"
- IF "^12^38^"'[(U_$PIECE($GET(DGPMA),U,18)_U)
- IF $$VALUE^ORX8(+IFN,"COLLECT")="SP"
- IF $PIECE(OR0,U,8)'<DT
- SET ERROR="Future Send Patient orders may not be auto-discontinued!"
- QUIT
- End DoDot:2
- QUIT
- +11 IF PKG="GMRC"
- IF ORDSTS=9
- SET ERROR="Consults orders with partial results cannot be discontinued!"
- QUIT
- +12 IF DG="DO"
- IF $GET(DGPMT)'=3
- IF ORDSTS=6
- IF '$$NPO(+IFN)
- SET ERROR="Active Diets cannot be discontinued; please order a new diet!"
- QUIT
- End DoDot:1
- GOTO VQ
- RL ; release hold
- IF ACTION="RL"
- Begin DoDot:1
- +1 IF ORDSTS'=3
- Begin DoDot:2
- +2 IF $PIECE(ORA0,U,4)=2
- SET ERROR="Providers has not yet signed the hold order and therefor it cannot yet be released"
- QUIT
- +3 SET ERROR="Orders not on hold cannot be released!"
- QUIT
- End DoDot:2
- QUIT
- +4 IF ACTSTS
- SET ERROR=$$ACTION($PIECE(ORA0,U,2))_" orders cannot be released from hold!"
- QUIT
- +5 NEW NATR,ACT
- SET ACT=$SELECT($PIECE(ORA0,U,2)="HD":AIFN,1:+$PIECE(OR3,U,7))
- +6 SET NATR=+$PIECE($GET(^OR(100,+IFN,8,ACT,0)),U,12)
- SET ACT=$PIECE($GET(^(0)),U,2)
- +7 ;IHS/MSC/REC/PLS - 08/09/10
- +8 ;I PKG="RA"!(ACT'="HD")!($P($G(^ORD(100.02,NATR,0)),U,2)="S") S ERROR="Orders held by a service must be released from hold through the service!" Q
- +9 IF PKG="RA"!(ACT'="HD")!($PIECE($GET(^ORD(100.02,NATR,0)),U,2)="S")
- IF $GET(NV)=""
- SET ERROR="Orders held by a service must be released from hold through the service!"
- QUIT
- End DoDot:1
- GOTO VQ
- AIFN SET X=$PIECE(ORA0,U,2)
- IF AIFN>1
- IF ACTSTS
- SET ERROR="This action is not allowed on a "_$$ACTION(X)_" order!"
- GOTO VQ
- RF IF ACTION="RF"
- Begin DoDot:1
- +1 IF DG'="O RX"
- SET ERROR="Only Outpatient Med orders may be refilled!"
- QUIT
- +2 IF ORDSTS=5
- SET ERROR="Pending orders may not be refilled!"
- QUIT
- +3 IF ORDSTS=7
- SET ERROR="Expired orders may not be refilled!"
- QUIT
- +4 NEW X,PSIFN
- SET PSIFN=$GET(^OR(100,+IFN,4))
- +5 SET X=$$REFILL^PSOREF(PSIFN)
- IF X'>0
- SET ERROR=$PIECE(X,U,2)
- QUIT
- +6 IF (DG="NV RX")!($TEXT(SCREEN^APSPMULT)="")
- QUIT
- +7 NEW DFN,Y
- SET Y=$$VALUE^ORX8(+ORIFN,"DRUG",1,"I")
- SET DFN=+$PIECE($GET(^OR(100,+ORIFN,0)),U,2)
- +8 IF '$$SCREEN^APSPMULT(+Y,,1)
- SET ERROR="Invalid Drug for refill on this patient"
- End DoDot:1
- GOTO VQ
- CP ; complete
- IF ACTION="CP"
- Begin DoDot:1
- +1 IF PKG'="OR"
- SET ERROR="Only generic text orders may be completed through this option!"
- QUIT
- +2 IF ORDSTS=11!(ORDSTS=10)
- SET ERROR="This order has not been released!"
- QUIT
- End DoDot:1
- GOTO VQ
- AL IF ACTION="AL"
- Begin DoDot:1
- +1 IF PKG'="LR"
- IF PKG'="RA"
- IF PKG'="GMRC"
- SET ERROR="This order does not generate results!"
- QUIT
- +2 IF $PIECE(OR3,U,10)
- SET ERROR="This order is already flagged to alert the provider when resulted!"
- QUIT
- End DoDot:1
- GOTO VQ
- XX ; edit/change
- IF ACTION="XX"
- Begin DoDot:1
- +1 IF ORDSTS=7
- SET ERROR="Expired orders may not be changed!"
- QUIT
- +2 DO XX^ORCACT01
- End DoDot:1
- GOTO VQ
- HD ; hold
- IF ACTION="HD"
- Begin DoDot:1
- +1 IF PKG="FH"
- SET ERROR="Diet orders cannot be held!"
- QUIT
- +2 IF PKG="LR"
- SET ERROR="Lab orders cannot be held!"
- QUIT
- +3 IF PKG="RA"
- SET ERROR="Radiology orders cannot be held!"
- QUIT
- +4 IF PKG="GMRC"
- SET ERROR="Consult orders cannot be held!"
- QUIT
- +5 ;I DG="NV RX" S ERROR="Outside med orders cannot be held!" Q ;IHS/MSC/PLS - 08/06/10 Available for hold
- +6 IF ORDSTS=3
- SET ERROR="This order is already on hold!"
- QUIT
- +7 ;I ORDSTS'=6,PKG="PS" S ERROR="Only active Pharmacy orders may be held!" Q
- +8 ;Allow hold for transfer to IP/OP
- IF ORDSTS-6
- IF ORDSTS-21400
- IF ORDSTS-21401
- IF PKG="PS"
- SET ERROR="Only active Pharmacy orders may be held!"
- QUIT
- +9 ;IHS/MSC/PLS - 10/17/07
- IF ORDSTS=6
- IF PKG="PS"
- IF $PIECE($GET(^PSRX(+$GET(^OR(100,+IFN,4)),999999921)),U,3)
- SET ERROR="Outside pharmacy prescriptions can't be placed on hold!"
- +10 IF (ORDSTS=11)!(ORDSTS=10)
- SET ERROR="This order has not been released to the service."
- QUIT
- End DoDot:1
- GOTO VQ
- VQ SET Y=$SELECT($DATA(ERROR):0,1:1)
- +1 QUIT Y
- +2 ;
- ACTION(X) ; -- Return text of action X
- +1 NEW Y
- SET Y=$SELECT(X="NW":"New",X="DC":"Discontinue",X="HD":"Hold",X="RL":"Release Hold",X="RN":"Renew",1:X)
- +2 QUIT Y
- +3 ;
- NPO(ORIFN) ; -- Returns 1 or 0, if order ORIFN is for NPO
- +1 NEW X,Y
- SET X=$$VALUE^ORX8(+ORIFN,"ORDERABLE",1,"E")
- +2 SET Y=$SELECT($EXTRACT(X,1,3)="NPO":1,1:0)
- +3 QUIT Y
- +4 ;
- COLLECTD() ; -- Lab order collected/active (incl all children)?
- +1 ; unreleased
- IF (ORDSTS=11)!(ORDSTS=10)
- QUIT 0
- +2 IF '$ORDER(^OR(100,+IFN,2,0))
- QUIT (ORDSTS'=5)
- +3 ;I ORDSTS'=6 Q 1 ; Parent -> active instead of pending
- +4 NEW Y,Z
- SET Y=1
- SET Z=0
- +5 FOR
- SET Z=$ORDER(^OR(100,+IFN,2,Z))
- IF Z'>0
- QUIT
- IF $PIECE($GET(^OR(100,Z,3)),U,3)=5
- SET Y=0
- QUIT
- +6 QUIT Y
- +7 ;
- DONE() ; -- sets ERROR if terminal status
- +1 IF ORDSTS=1
- SET ERROR="This order has been discontinued!"
- QUIT 1
- +2 IF ORDSTS=2
- SET ERROR="This order has been completed!"
- QUIT 1
- +3 IF ORDSTS=7
- IF DG'="O RX"
- SET ERROR="This order has expired!"
- QUIT 1
- +4 IF ORDSTS=12
- SET ERROR="This order has been changed!"
- QUIT 1
- +5 IF ORDSTS=13
- SET ERROR="This order has been cancelled!"
- QUIT 1
- +6 IF ORDSTS=14
- SET ERROR="This order has lapsed!"
- QUIT 1
- +7 IF ORDSTS=15
- SET ERROR="This order has been renewed!"
- QUIT 1
- +8 QUIT 0
- +9 ;
- DISABLED() ; -- Order dialog [or protocol] disabled?
- +1 NEW X,DLG
- SET DLG=$PIECE(OR0,U,5)
- SET X=0
- IF +DLG'>0
- QUIT X
- +2 IF VER'<3
- IF DLG?1.N1";ORD(101.41,"
- SET X=$$MSG^ORXD(+DLG)
- QUIT X
- +3 SET DLG=$SELECT(PKG="RA":"RA OERR EXAM",PKG="GMRC":"GMRCOR CONSULT",1:"")
- +4 IF $LENGTH(DLG)
- SET DLG=+$ORDER(^ORD(101.41,"AB",DLG,0))
- SET X=$$MSG^ORXD(DLG)
- +5 QUIT X
- +6 ;Check for verified state
- CHKVF ;EP - IHS/MSC/REC/PLS - 08/09/10
- +1 NEW RD,LST,NOW,DTCMP
- +2 SET RD=$PIECE(ORA0,U,19)
- +3 IF RD
- Begin DoDot:1
- +4 SET LST=$ORDER(^OR(100,+IFN,8,AIFN,"MSC",""),-1)
- IF 'LST
- QUIT
- +5 SET LST=+$ORDER(^OR(100,+IFN,8,AIFN,"MSC",LST),-1)
- +6 SET RD=$SELECT(LST:$PIECE($GET(^(LST,0)),U,2),1:RD)
- +7 SET NOW=$$NOW^XLFDT()
- +8 SET DTCMP=$$FMDIFF^XLFDT(NOW,RD)
- +9 IF $SELECT(DTCMP>1:1,DTCMP=1:$EXTRACT(NOW,8,99)>$EXTRACT(RD,8,99),1:0)
- QUIT
- +10 SET ERROR="This order cannot be reviewed more than twice within 24 hours!"
- End DoDot:1
- +11 QUIT
