ORCACT01 ;SLC/MKB-Validate order actions cont ;Oct 20, 2020@22:36:08
;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,141,163,187,190,213,243,306,374,350,397,377,498,580,499**;Dec 17, 1997;Build 165
;
;External reference to $$ORCOPY^PSOORCPY supported by DBIA 6719
;
ES ; -- sign [on chart]
I ORDSTS=11,VER<3,PKG'="OR" S ERROR="This order cannot be released and must be discontinued!" Q
N X I ACTSTS=11!(ACTSTS=10) D Q:$L($G(ERROR))
. I $P(ORA0,U,2)="DC",$$DONE^ORCACT0 D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN S OREBUILD=1 Q
. S X=$$DISABLED^ORCACT0 I X S ERROR=$P(X,U,2) Q
I ACTION="OC",$G(DG)="NV RX" S:MEDPARM<2 ERROR="You are not authorized to release non-VA med orders!" Q
S X=$P(ORA0,U,4) I X=3 S:ACTSTS'=11&(ACTSTS'=10) ERROR="This order does not require a signature!" Q
I X=5 S ERROR="This order has been canceled!" Q ;p580
I X'=2 S ERROR="This order has been signed!" Q
N ORCS D CSVALUE^ORDEA(.ORCS,+IFN)
I DG="O RX",ACTION="RS",$G(NATR)="I",ORCS=1 S ERROR="Controlled Substance outpatient meds may not be released without a clinician's signature!" Q
I DG="O RX",ACTION'="ES",ACTION'="DS",$G(NATR)'="I" S ERROR="Outpatient meds may not be released without a clinician's signature!" Q
I (ACTION="ES"!(ACTION="DS")),$D(^XUSEC("ORELSE",DUZ)),$P(OR0,U,16)'<2 S ERROR="You are not privileged to sign this order!" Q
;
I DG="SPLY" D Q:$D(ERROR)
. N ORALLOWED,ORAUTHMEDS,ORHASSUPKEY,ORX
. ; User must have ORSUPPLY or Auth to Write Meds to release supply items
. S ORHASSUPKEY=$D(^XUSEC("ORSUPPLY",DUZ))
. S ORAUTHMEDS=1
. S ORX=$G(^VA(200,DUZ,"PS"))
. I '$P(ORX,U)!($P(ORX,U,4)&(DT>$P(ORX,U,4))) S ORAUTHMEDS=0
. I 'ORHASSUPKEY,'ORAUTHMEDS D Q
. . S ERROR="You are not authorized to release supply orders."
. ; only allow release by policy, signed on chart, or ES
. ; release via verbal or telephone is not allowed
. S ORALLOWED=0
. I ACTION?1(1"ES",1"DS",1"OC") S ORALLOWED=1
. I ACTION="RS",$G(NATR)?1(1"I",1"W") S ORALLOWED=1
. I 'ORALLOWED S ERROR="Supplies may not be released with this action."
;
I ACTION="OC" S:MEDPARM<2 ERROR="You are not authorized to release med orders!" Q
;
; Don't allow DC of lab order to be signed/released if its already been accessioned
I PKG="LR",$P(ORA0,U,2)="DC",$$COLLECTD^ORCACT0 D Q:$D(ERROR)
. S ERROR="This order may not be discontinued. "
. S ERROR=ERROR_"Cancel the discontinue to remove it from the patient's record. "
. S ERROR=ERROR_$$GET^XPAR("ALL","OR LAB CANCEL ERROR MESSAGE",1,"I")
;
I ACTION="RS" D Q:$D(ERROR) Q:$G(NATR)'="I"
. Q:ACTSTS=11 Q:ACTSTS=10 ;unreleased - ok
. S ERROR="This order has already been released!"
ES1 I PKG="PS" D ;authorized to write meds?
. N TYPE,OI,PSOI,DEAFLG,PKI,IVERROR,ORDGNM
. S X=$G(^VA(200,DUZ,"PS"))
. I DG'="SPLY",'$P(X,U) S ERROR="You are not authorized to sign med orders!" Q
. I DG'="SPLY",$P(X,U,4),$$NOW^XLFDT>$P(X,U,4) S ERROR="You are no longer authorized to sign med orders!" Q
. ;Q:DG="IV RX" Q:$P(ORA0,U,2)="DC" ;don't need to ck DEA#
. Q:$P(ORA0,U,2)="DC"
. S ORDGNM=$$GET1^DIQ(100,+IFN_",",2)
. I ORDGNM["FLUID OE" D Q
. .S FAIL=$$IVDEACHK(+IFN) I FAIL'=0 S ERROR=FAIL
. S OI=+$$VALUE^ORX8(+IFN,"ORDERABLE")
. S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) Q:PSOI'>0
. S TYPE=$S($P(DG," ")="O":"O",1:"I"),DEAFLG=$P($$OIDEA^PSSOPKI(PSOI,TYPE),";",2)
. S DETFLAG=$$OIDETOX^PSSOPKI(PSOI,TYPE)
. S DETPRO=$$DETOX^XUSER(+$G(DUZ))
. I DETFLAG,DETPRO="" S ERROR=3 Q
. I DETFLAG,DETPRO>0 S Y=DETPRO X ^DD("DD") S ERROR="5^"_Y Q
. I (DEAFLG>0!($$ISCLOZ^ORALWORD(OI))) D I $G(ERROR)]"" Q
.. N RET
.. I $$ISCLOZ^ORALWORD(OI) D Q
... S RET=$$DEA^XUSER(,DUZ) I RET="" S ERROR=1
.. S RET=$$SDEA^XUSER(,DUZ,DEAFLG)
.. I RET=1 S ERROR=1 Q
.. I RET=2 S ERROR="2^"_$$UP^XLFSTR(DEAFLG) Q
.. I RET?1"4".E S ERROR=RET Q
.. I RET?1N.E S ERROR=RET
.. ; Support multiple DEA's for a provider
.. N ORSLDEA,RET S ORSLDEA=$P($G(^OR(100,+IFN,11)),U) ;*499}
.. I ORSLDEA="" S ORSLDEA=$$DEA^XUSER(,DUZ)
.. I ORSLDEA="" S ERROR=1 Q
.. N RET
.. S RET=$$SDEA^XUSER(,DUZ,DEAFLG,ORSLDEA)
. D PKISITE^ORWOR(.PKI)
. I $G(PKI),ACTION="RS",DEAFLG=1 S ERROR="This order cannot be released without a Digital Signature" Q
Q
;
IVDEACHK(IFN) ; -- Returns value of prompt by ID
I '$G(IFN)!('$D(^OR(100,+$G(IFN),0))) Q ""
N I,DIAL,DIALTYP,FAIL,PATCLASS,RESULT,Y
S PATCLASS=$P(^OR(100,+IFN,0),U,12)
S RESULT=0
;if ORNP is not set then assume this is called from VistA not CPRS
I $G(ORNP)="" S ORNP=DUZ
S I=0,Y="" S:'$G(INST) INST=1
F S I=$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",I)) Q:I'>0!(RESULT=1) D
.S Y=$G(^OR(100,+IFN,4.5,I,1)) Q:Y'>0
.;S PSOI=+$P($G(^ORD(101.43,Y,0)),U,2) Q:PSOI'>0
.I PATCLASS="I" D Q
..D FAILDEA^ORWDPS1(.FAIL,Y,ORNP,"I") I FAIL'=0 S RESULT=FAIL
.S DIAL=+$P(^OR(100,+IFN,4.5,I,0),U,2)
.S DIALTYP=$S($P(^ORD(101.41,DIAL,0),U)["ADDITIVE":"A",1:"S")
.D FDEA1^ORWDPS1(.FAIL,Y,DIALTYP,ORNP)
.I FAIL'=0 S RESULT=FAIL
.;I $$OIDEA^PSSUTLA1(PSOI,"I")>0 S RESULT=1 Q
Q RESULT
;
XFR ; -- transfer to inpt/outpt [IFN=order to be transferred]
N OI,PS I DG="TPN" S ERROR="TPN orders may not be copied!" Q
I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be transferred; please enter a new order!" Q
S OI=+$O(^OR(100,+IFN,.1,"B",0)),ORPS=$G(^ORD(101.43,OI,"PS"))
I DG="UD RX",'$P(ORPS,U,2) S ERROR="This drug may not be ordered for an outpatient!" Q
I DG="O RX" D Q:$L($G(ERROR))
. I '$P(ORPS,U) S ERROR="This drug may not be ordered for an inpatient!" Q
. D:$O(^OR(100,+IFN,4.5,"ID","MISC",0)) DOSES^ORCACT02(+IFN)
;
; Really this check should not be needed, as in BLDQRSP^ORWDXM1 if the urgency is not valid
; it returns a 0, so that the GUI does not auto-accept the order. However, a bug in the GUI
; is preventing that from happening. Once that bug is fixed, this check can be removed.
I PKG="RA" D Q:$D(ERROR)
. N ORURG
. S ORURG=$$VALUE^ORCSAVE2(+IFN,"URGENCY")
. I ORURG,'$$RADURG^ORWDRA32(+ORURG) S ERROR="Invalid urgency. Cannot transfer!"
Q
;
RW ; -- rewrite/copy
N ORISCL D ISCLORD^ORUTL(.ORISCL,+IFN)
I ORISCL S ERROR="Cannot copy Clinic Medication or Clinic Infusion orders!"
I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be copied!" Q
I DG="NV RX" S ERROR="Non-VA Med orders cannot be copied!" Q
I DG="TPN" S ERROR="TPN orders may not be rewritten!" Q
I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be rewritten!" Q
I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be copied; please enter a new order!" Q
I PKG="PS",'$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q
I DG="O RX" D
. N ORX,PSIFN
. I $O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form
. ;
. ;p377 LMT - check with pharmacy that order can be copied
. S PSIFN=$G(^OR(100,+IFN,4))
. I PSIFN="" Q ; If does not have package ref yet (i.e., unsigned order) let it be copied w/o ORCOPY^PSOORCPY check
. S ORX=$$ORCOPY^PSOORCPY(PSIFN) ;ICR #6719
. I ORX<1 S ERROR=$P(ORX,U,2) Q
Q
;
RN ; -- renew
I PKG'="PS",PKG'="OR" S ERROR="This order may not be renewed!" Q
I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q
I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be renewed!" Q
I $P(OR3,U,6) S ERROR="This order has already been "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"changed!",1:"renewed!") Q
I PKG="OR" D Q ;Generic orders
. I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be renewed!" Q
. I DG="ADT" S ERROR="M.A.S. orders may not be renewed!" Q
. I "^1^2^6^7^"[(U_ORDSTS_U) Q ;ok
. S ERROR="This order may not be renewed!"
I PKG="PS" D Q:$L($G(ERROR))
. I $L($G(DG)) I $E(DG)'["O" Q
. N ORZIPOK,OI
. S OI=+$$VALUE^ORX8(+IFN,"ORDERABLE") Q:OI'>0
. D ZIP^ORWDPS11(.ORZIPOK,OI,"O",+ORVP)
. I 'ORZIPOK S ERROR=$P(ORZIPOK,"^",2)
I (PKG="PS"),$$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be renewed!" Q
I '$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q
RN1 N PSIFN,OROI
S PSIFN=$G(^OR(100,+IFN,4))
I PSIFN<1,'$O(^OR(100,+IFN,2,0)) S ERROR="Missing or invalid order number!" Q
S OROI=$G(^OR(100,+IFN,.1,1,0))
I $$ISCLOZ^ORALWORD(OROI) S ERROR="Cannot renew Clozapine orders!" Q
I DG="O RX"!(DG="SPLY") D Q ;Outpt Meds
. N ORZ,ORD
. I $$XCONJ(+IFN) S ERROR="Orders with a conjunction of 'EXCEPT' may not be renewed!" Q
. S ORZ=$L($T(RENEW^PSORENW),",")
. I ORZ>1 S ORD=+$$VALUE^ORX8(+IFN,"DRUG"),X=$$RENEW^PSORENW(PSIFN,ORD)
. S:ORZ'>1 X=$$RENEW^PSORENW(PSIFN) I X<1 S ERROR=$P(X,U,2) Q
. S X=+$P(X,U,2) D:X RESET^ORCACT03(+IFN,X)
. I $O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old format
I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be renewed!" Q
I ORDSTS=7,'$$IV^ORCACT03,$P(OR0,U,9)<$$FMADD^XLFDT(DT,-4) S ERROR="Inpatient med orders may not be renewed more than 4 days after expiration!" Q
I ORDSTS'=6,ORDSTS'=7 S ERROR="This order may not be renewed!" Q
RN2 I $O(^OR(100,+IFN,2,0))!$P(OR3,U,9) D Q:$D(ERROR)!'PSIFN
. I $P(OR3,U,9),$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW" S ERROR="One-time NOW orders may not be renewed!" Q
. N DAD,ORD3,I,Y S DAD=$S($P(OR3,U,9):+$P(OR3,U,9),1:+IFN),Y=0
. S ORD3=$G(^OR(100,DAD,3)) I $P(ORD3,U,6) S ERROR="This complex order has already been renewed!" Q
. I $P(ORD3,U,3)'=6 S ERROR="This complex order is not active and may not be renewed!" Q
. I '$$AND^ORX8(DAD) S ERROR="Complex orders with sequential doses may not be renewed!" Q
. S I=0 F S I=+$O(^OR(100,DAD,2,I)) Q:I<1 D Q:Y
.. I I=+$O(^OR(100,DAD,2,0)),$$VALUE^ORX8(I,"SCHEDULE",1,"E")="NOW",$$VALUE^ORX8(DAD,"NOW") Q ;ignore NOW orders
.. I $P($G(^OR(100,I,3)),U,3)'=6 S Y=1,ERROR="Complex orders with terminated doses may not be renewed!" Q
.. I PSIFN<1 S X=$$ACTIVE^PSJORREN(+ORVP,$G(^OR(100,I,4))) I +X'=1 S ERROR="This order may not be renewed: "_$S(+X>1:"Inactive orderable item",1:$P(X,U,2)) Q
;I DG="TPN" S ERROR="TPN orders may not be renewed!" Q
S X=$$ACTIVE^PSJORREN(+ORVP,PSIFN) Q:+X=1 ;Ok
I +X>1,$P(X,U,2) D RESET^ORCACT03(+IFN,+$P(X,U,2)) Q ;replace OI
S ERROR="This order may not be renewed: "_$P(X,U,2)
Q
;
XX ; -- edit/change--
I PKG="RA",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Radiology cannot be changed!" Q
I PKG="LR",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Lab cannot be changed!" Q
I PKG="FH",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Dietetics cannot be changed!" Q
I PKG="GMRC",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Consults cannot be changed!" Q
I DG="TPN" S ERROR="TPN orders may not be changed!" Q
I ORDSTS=3 S ERROR="Orders on hold may not be changed!" Q
I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be changed!" Q
I $O(^OR(100,+IFN,2,0)) S ERROR="Complex orders may not be changed!" Q
I $P(OR3,U,9) D Q:$D(ERROR)
. Q:$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW" ;NOW ok
. Q:'$O(^OR(100,+$P(OR3,U,9),4.5,"ID","CONJ",0)) ;no conj=1dose/ok
. S ERROR="Complex orders may not be changed!" Q
I $P(OR3,U,6) S ERROR="This order may not be changed - a "_$S($P($G(^OR(100,+$P(OR3,U,6),3)),U,11)=1:"change",1:"renewal")_" order already exists!" Q
I $P(OR3,U,11)=2 D Q:$D(ERROR)
. I (ORDSTS=10!(ORDSTS=11)),DG'="O RX" S ERROR="Unreleased renewals may not be changed!" Q
. I PKG="PS",ORDSTS=5 S ERROR="Pending renewals may not be changed!" Q
I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be changed; please enter a new order!" Q
I PKG="PS",'$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q
I DG="O RX",$$XCONJ(+IFN) S ERROR="Orders with a conjunction of 'EXCEPT' may not be changed!" Q
I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form
Q
;
XCONJ(ORIFN) ; check if Responses multiple has an OR GTX AND/THEN entry with value of X:EXCEPT
N ORI,ORRESULT
S ORRESULT=0
S ORI=""
F S ORI=$O(^OR(100,ORIFN,4.5,"ID","CONJ",ORI)) Q:'ORI D
. I $G(^OR(100,ORIFN,4.5,ORI,1))="X" S ORRESULT=1
Q ORRESULT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCACT01 12405 printed Apr 09, 2024@21:25:19 Page 2
ORCACT01 ;SLC/MKB-Validate order actions cont ;Oct 20, 2020@22:36:08
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**94,116,134,141,163,187,190,213,243,306,374,350,397,377,498,580,499**;Dec 17, 1997;Build 165
+2 ;
+3 ;External reference to $$ORCOPY^PSOORCPY supported by DBIA 6719
+4 ;
ES ; -- sign [on chart]
+1 IF ORDSTS=11
IF VER<3
IF PKG'="OR"
SET ERROR="This order cannot be released and must be discontinued!"
QUIT
+2 NEW X
IF ACTSTS=11!(ACTSTS=10)
Begin DoDot:1
+3 IF $PIECE(ORA0,U,2)="DC"
IF $$DONE^ORCACT0
DO CANCEL^ORCSEND(+IFN)
DO UNOTIF^ORCSIGN
SET OREBUILD=1
QUIT
+4 SET X=$$DISABLED^ORCACT0
IF X
SET ERROR=$PIECE(X,U,2)
QUIT
End DoDot:1
if $LENGTH($GET(ERROR))
QUIT
+5 IF ACTION="OC"
IF $GET(DG)="NV RX"
if MEDPARM<2
SET ERROR="You are not authorized to release non-VA med orders!"
QUIT
+6 SET X=$PIECE(ORA0,U,4)
IF X=3
if ACTSTS'=11&(ACTSTS'=10)
SET ERROR="This order does not require a signature!"
QUIT
+7 ;p580
IF X=5
SET ERROR="This order has been canceled!"
QUIT
+8 IF X'=2
SET ERROR="This order has been signed!"
QUIT
+9 NEW ORCS
DO CSVALUE^ORDEA(.ORCS,+IFN)
+10 IF DG="O RX"
IF ACTION="RS"
IF $GET(NATR)="I"
IF ORCS=1
SET ERROR="Controlled Substance outpatient meds may not be released without a clinician's signature!"
QUIT
+11 IF DG="O RX"
IF ACTION'="ES"
IF ACTION'="DS"
IF $GET(NATR)'="I"
SET ERROR="Outpatient meds may not be released without a clinician's signature!"
QUIT
+12 IF (ACTION="ES"!(ACTION="DS"))
IF $DATA(^XUSEC("ORELSE",DUZ))
IF $PIECE(OR0,U,16)'<2
SET ERROR="You are not privileged to sign this order!"
QUIT
+13 ;
+14 IF DG="SPLY"
Begin DoDot:1
+15 NEW ORALLOWED,ORAUTHMEDS,ORHASSUPKEY,ORX
+16 ; User must have ORSUPPLY or Auth to Write Meds to release supply items
+17 SET ORHASSUPKEY=$DATA(^XUSEC("ORSUPPLY",DUZ))
+18 SET ORAUTHMEDS=1
+19 SET ORX=$GET(^VA(200,DUZ,"PS"))
+20 IF '$PIECE(ORX,U)!($PIECE(ORX,U,4)&(DT>$PIECE(ORX,U,4)))
SET ORAUTHMEDS=0
+21 IF 'ORHASSUPKEY
IF 'ORAUTHMEDS
Begin DoDot:2
+22 SET ERROR="You are not authorized to release supply orders."
End DoDot:2
QUIT
+23 ; only allow release by policy, signed on chart, or ES
+24 ; release via verbal or telephone is not allowed
+25 SET ORALLOWED=0
+26 IF ACTION?1(1"ES",1"DS",1"OC")
SET ORALLOWED=1
+27 IF ACTION="RS"
IF $GET(NATR)?1(1"I",1"W")
SET ORALLOWED=1
+28 IF 'ORALLOWED
SET ERROR="Supplies may not be released with this action."
End DoDot:1
if $DATA(ERROR)
QUIT
+29 ;
+30 IF ACTION="OC"
if MEDPARM<2
SET ERROR="You are not authorized to release med orders!"
QUIT
+31 ;
+32 ; Don't allow DC of lab order to be signed/released if its already been accessioned
+33 IF PKG="LR"
IF $PIECE(ORA0,U,2)="DC"
IF $$COLLECTD^ORCACT0
Begin DoDot:1
+34 SET ERROR="This order may not be discontinued. "
+35 SET ERROR=ERROR_"Cancel the discontinue to remove it from the patient's record. "
+36 SET ERROR=ERROR_$$GET^XPAR("ALL","OR LAB CANCEL ERROR MESSAGE",1,"I")
End DoDot:1
if $DATA(ERROR)
QUIT
+37 ;
+38 IF ACTION="RS"
Begin DoDot:1
+39 ;unreleased - ok
if ACTSTS=11
QUIT
if ACTSTS=10
QUIT
+40 SET ERROR="This order has already been released!"
End DoDot:1
if $DATA(ERROR)
QUIT
if $GET(NATR)'="I"
QUIT
ES1 ;authorized to write meds?
IF PKG="PS"
Begin DoDot:1
+1 NEW TYPE,OI,PSOI,DEAFLG,PKI,IVERROR,ORDGNM
+2 SET X=$GET(^VA(200,DUZ,"PS"))
+3 IF DG'="SPLY"
IF '$PIECE(X,U)
SET ERROR="You are not authorized to sign med orders!"
QUIT
+4 IF DG'="SPLY"
IF $PIECE(X,U,4)
IF $$NOW^XLFDT>$P(X,U,4)
SET ERROR="You are no longer authorized to sign med orders!"
QUIT
+5 ;Q:DG="IV RX" Q:$P(ORA0,U,2)="DC" ;don't need to ck DEA#
+6 if $PIECE(ORA0,U,2)="DC"
QUIT
+7 SET ORDGNM=$$GET1^DIQ(100,+IFN_",",2)
+8 IF ORDGNM["FLUID OE"
Begin DoDot:2
+9 SET FAIL=$$IVDEACHK(+IFN)
IF FAIL'=0
SET ERROR=FAIL
End DoDot:2
QUIT
+10 SET OI=+$$VALUE^ORX8(+IFN,"ORDERABLE")
+11 SET PSOI=+$PIECE($GET(^ORD(101.43,OI,0)),U,2)
if PSOI'>0
QUIT
+12 SET TYPE=$SELECT($PIECE(DG," ")="O":"O",1:"I")
SET DEAFLG=$PIECE($$OIDEA^PSSOPKI(PSOI,TYPE),";",2)
+13 SET DETFLAG=$$OIDETOX^PSSOPKI(PSOI,TYPE)
+14 SET DETPRO=$$DETOX^XUSER(+$GET(DUZ))
+15 IF DETFLAG
IF DETPRO=""
SET ERROR=3
QUIT
+16 IF DETFLAG
IF DETPRO>0
SET Y=DETPRO
XECUTE ^DD("DD")
SET ERROR="5^"_Y
QUIT
+17 IF (DEAFLG>0!($$ISCLOZ^ORALWORD(OI)))
Begin DoDot:2
+18 NEW RET
+19 IF $$ISCLOZ^ORALWORD(OI)
Begin DoDot:3
+20 SET RET=$$DEA^XUSER(,DUZ)
IF RET=""
SET ERROR=1
End DoDot:3
QUIT
+21 SET RET=$$SDEA^XUSER(,DUZ,DEAFLG)
+22 IF RET=1
SET ERROR=1
QUIT
+23 IF RET=2
SET ERROR="2^"_$$UP^XLFSTR(DEAFLG)
QUIT
+24 IF RET?1"4".E
SET ERROR=RET
QUIT
+25 IF RET?1N.E
SET ERROR=RET
+26 ; Support multiple DEA's for a provider
+27 ;*499}
NEW ORSLDEA,RET
SET ORSLDEA=$PIECE($GET(^OR(100,+IFN,11)),U)
+28 IF ORSLDEA=""
SET ORSLDEA=$$DEA^XUSER(,DUZ)
+29 IF ORSLDEA=""
SET ERROR=1
QUIT
+30 NEW RET
+31 SET RET=$$SDEA^XUSER(,DUZ,DEAFLG,ORSLDEA)
End DoDot:2
IF $GET(ERROR)]""
QUIT
+32 DO PKISITE^ORWOR(.PKI)
+33 IF $GET(PKI)
IF ACTION="RS"
IF DEAFLG=1
SET ERROR="This order cannot be released without a Digital Signature"
QUIT
End DoDot:1
+34 QUIT
+35 ;
IVDEACHK(IFN) ; -- Returns value of prompt by ID
+1 IF '$GET(IFN)!('$DATA(^OR(100,+$GET(IFN),0)))
QUIT ""
+2 NEW I,DIAL,DIALTYP,FAIL,PATCLASS,RESULT,Y
+3 SET PATCLASS=$PIECE(^OR(100,+IFN,0),U,12)
+4 SET RESULT=0
+5 ;if ORNP is not set then assume this is called from VistA not CPRS
+6 IF $GET(ORNP)=""
SET ORNP=DUZ
+7 SET I=0
SET Y=""
if '$GET(INST)
SET INST=1
+8 FOR
SET I=$ORDER(^OR(100,+IFN,4.5,"ID","ORDERABLE",I))
if I'>0!(RESULT=1)
QUIT
Begin DoDot:1
+9 SET Y=$GET(^OR(100,+IFN,4.5,I,1))
if Y'>0
QUIT
+10 ;S PSOI=+$P($G(^ORD(101.43,Y,0)),U,2) Q:PSOI'>0
+11 IF PATCLASS="I"
Begin DoDot:2
+12 DO FAILDEA^ORWDPS1(.FAIL,Y,ORNP,"I")
IF FAIL'=0
SET RESULT=FAIL
End DoDot:2
QUIT
+13 SET DIAL=+$PIECE(^OR(100,+IFN,4.5,I,0),U,2)
+14 SET DIALTYP=$SELECT($PIECE(^ORD(101.41,DIAL,0),U)["ADDITIVE":"A",1:"S")
+15 DO FDEA1^ORWDPS1(.FAIL,Y,DIALTYP,ORNP)
+16 IF FAIL'=0
SET RESULT=FAIL
+17 ;I $$OIDEA^PSSUTLA1(PSOI,"I")>0 S RESULT=1 Q
End DoDot:1
+18 QUIT RESULT
+19 ;
XFR ; -- transfer to inpt/outpt [IFN=order to be transferred]
+1 NEW OI,PS
IF DG="TPN"
SET ERROR="TPN orders may not be copied!"
QUIT
+2 IF $$INACTIVE^ORCACT03
SET ERROR="Orders for inactive orderables may not be transferred; please enter a new order!"
QUIT
+3 SET OI=+$ORDER(^OR(100,+IFN,.1,"B",0))
SET ORPS=$GET(^ORD(101.43,OI,"PS"))
+4 IF DG="UD RX"
IF '$PIECE(ORPS,U,2)
SET ERROR="This drug may not be ordered for an outpatient!"
QUIT
+5 IF DG="O RX"
Begin DoDot:1
+6 IF '$PIECE(ORPS,U)
SET ERROR="This drug may not be ordered for an inpatient!"
QUIT
+7 if $ORDER(^OR(100,+IFN,4.5,"ID","MISC",0))
DO DOSES^ORCACT02(+IFN)
End DoDot:1
if $LENGTH($GET(ERROR))
QUIT
+8 ;
+9 ; Really this check should not be needed, as in BLDQRSP^ORWDXM1 if the urgency is not valid
+10 ; it returns a 0, so that the GUI does not auto-accept the order. However, a bug in the GUI
+11 ; is preventing that from happening. Once that bug is fixed, this check can be removed.
+12 IF PKG="RA"
Begin DoDot:1
+13 NEW ORURG
+14 SET ORURG=$$VALUE^ORCSAVE2(+IFN,"URGENCY")
+15 IF ORURG
IF '$$RADURG^ORWDRA32(+ORURG)
SET ERROR="Invalid urgency. Cannot transfer!"
End DoDot:1
if $DATA(ERROR)
QUIT
+16 QUIT
+17 ;
RW ; -- rewrite/copy
+1 NEW ORISCL
DO ISCLORD^ORUTL(.ORISCL,+IFN)
+2 IF ORISCL
SET ERROR="Cannot copy Clinic Medication or Clinic Infusion orders!"
+3 IF ACTSTS=12
SET ERROR="Orders that have been dc'd due to editing may not be copied!"
QUIT
+4 IF DG="NV RX"
SET ERROR="Non-VA Med orders cannot be copied!"
QUIT
+5 IF DG="TPN"
SET ERROR="TPN orders may not be rewritten!"
QUIT
+6 IF DG="UD RX"
IF $$NTBG^ORCACT03(+IFN)
SET ERROR="This order has been marked 'Not to be Given' and may not be rewritten!"
QUIT
+7 IF $$INACTIVE^ORCACT03
SET ERROR="Orders for inactive orderables may not be copied; please enter a new order!"
QUIT
+8 IF PKG="PS"
IF '$$MEDOK^ORCACT03
SET ERROR="This drug may not be ordered!"
QUIT
+9 IF DG="O RX"
Begin DoDot:1
+10 NEW ORX,PSIFN
+11 ;old form
IF $ORDER(^OR(100,+IFN,4.5,"ID","MISC",0))
DO DOSES^ORCACT02(+IFN)
+12 ;
+13 ;p377 LMT - check with pharmacy that order can be copied
+14 SET PSIFN=$GET(^OR(100,+IFN,4))
+15 ; If does not have package ref yet (i.e., unsigned order) let it be copied w/o ORCOPY^PSOORCPY check
IF PSIFN=""
QUIT
+16 ;ICR #6719
SET ORX=$$ORCOPY^PSOORCPY(PSIFN)
+17 IF ORX<1
SET ERROR=$PIECE(ORX,U,2)
QUIT
End DoDot:1
+18 QUIT
+19 ;
RN ; -- renew
+1 IF PKG'="PS"
IF PKG'="OR"
SET ERROR="This order may not be renewed!"
QUIT
+2 IF (ORDSTS=11)!(ORDSTS=10)
SET ERROR="This order has not been released to the service."
QUIT
+3 IF ACTSTS=12
SET ERROR="Orders that have been dc'd due to editing may not be renewed!"
QUIT
+4 IF $PIECE(OR3,U,6)
SET ERROR="This order has already been "_$SELECT($PIECE($GET(^OR(100,+$PIECE(OR3,U,6),3)),U,11)=1:"changed!",1:"renewed!")
QUIT
+5 ;Generic orders
IF PKG="OR"
Begin DoDot:1
+6 IF $$INACTIVE^ORCACT03
SET ERROR="Orders for inactive orderables may not be renewed!"
QUIT
+7 IF DG="ADT"
SET ERROR="M.A.S. orders may not be renewed!"
QUIT
+8 ;ok
IF "^1^2^6^7^"[(U_ORDSTS_U)
QUIT
+9 SET ERROR="This order may not be renewed!"
End DoDot:1
QUIT
+10 IF PKG="PS"
Begin DoDot:1
+11 IF $LENGTH($GET(DG))
IF $EXTRACT(DG)'["O"
QUIT
+12 NEW ORZIPOK,OI
+13 SET OI=+$$VALUE^ORX8(+IFN,"ORDERABLE")
if OI'>0
QUIT
+14 DO ZIP^ORWDPS11(.ORZIPOK,OI,"O",+ORVP)
+15 IF 'ORZIPOK
SET ERROR=$PIECE(ORZIPOK,"^",2)
End DoDot:1
if $LENGTH($GET(ERROR))
QUIT
+16 IF (PKG="PS")
IF $$INACTIVE^ORCACT03
SET ERROR="Orders for inactive orderables may not be renewed!"
QUIT
+17 IF '$$MEDOK^ORCACT03
SET ERROR="This drug may not be ordered!"
QUIT
RN1 NEW PSIFN,OROI
+1 SET PSIFN=$GET(^OR(100,+IFN,4))
+2 IF PSIFN<1
IF '$ORDER(^OR(100,+IFN,2,0))
SET ERROR="Missing or invalid order number!"
QUIT
+3 SET OROI=$GET(^OR(100,+IFN,.1,1,0))
+4 IF $$ISCLOZ^ORALWORD(OROI)
SET ERROR="Cannot renew Clozapine orders!"
QUIT
+5 ;Outpt Meds
IF DG="O RX"!(DG="SPLY")
Begin DoDot:1
+6 NEW ORZ,ORD
+7 IF $$XCONJ(+IFN)
SET ERROR="Orders with a conjunction of 'EXCEPT' may not be renewed!"
QUIT
+8 SET ORZ=$LENGTH($TEXT(RENEW^PSORENW),",")
+9 IF ORZ>1
SET ORD=+$$VALUE^ORX8(+IFN,"DRUG")
SET X=$$RENEW^PSORENW(PSIFN,ORD)
+10 if ORZ'>1
SET X=$$RENEW^PSORENW(PSIFN)
IF X<1
SET ERROR=$PIECE(X,U,2)
QUIT
+11 SET X=+$PIECE(X,U,2)
if X
DO RESET^ORCACT03(+IFN,X)
+12 ;old format
IF $ORDER(^OR(100,+IFN,4.5,"ID","MISC",0))
DO DOSES^ORCACT02(+IFN)
End DoDot:1
QUIT
+13 IF DG="UD RX"
IF $$NTBG^ORCACT03(+IFN)
SET ERROR="This order has been marked 'Not to be Given' and may not be renewed!"
QUIT
+14 IF ORDSTS=7
IF '$$IV^ORCACT03
IF $PIECE(OR0,U,9)<$$FMADD^XLFDT(DT,-4)
SET ERROR="Inpatient med orders may not be renewed more than 4 days after expiration!"
QUIT
+15 IF ORDSTS'=6
IF ORDSTS'=7
SET ERROR="This order may not be renewed!"
QUIT
RN2 IF $ORDER(^OR(100,+IFN,2,0))!$PIECE(OR3,U,9)
Begin DoDot:1
+1 IF $PIECE(OR3,U,9)
IF $$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW"
SET ERROR="One-time NOW orders may not be renewed!"
QUIT
+2 NEW DAD,ORD3,I,Y
SET DAD=$SELECT($PIECE(OR3,U,9):+$PIECE(OR3,U,9),1:+IFN)
SET Y=0
+3 SET ORD3=$GET(^OR(100,DAD,3))
IF $PIECE(ORD3,U,6)
SET ERROR="This complex order has already been renewed!"
QUIT
+4 IF $PIECE(ORD3,U,3)'=6
SET ERROR="This complex order is not active and may not be renewed!"
QUIT
+5 IF '$$AND^ORX8(DAD)
SET ERROR="Complex orders with sequential doses may not be renewed!"
QUIT
+6 SET I=0
FOR
SET I=+$ORDER(^OR(100,DAD,2,I))
if I<1
QUIT
Begin DoDot:2
+7 ;ignore NOW orders
IF I=+$ORDER(^OR(100,DAD,2,0))
IF $$VALUE^ORX8(I,"SCHEDULE",1,"E")="NOW"
IF $$VALUE^ORX8(DAD,"NOW")
QUIT
+8 IF $PIECE($GET(^OR(100,I,3)),U,3)'=6
SET Y=1
SET ERROR="Complex orders with terminated doses may not be renewed!"
QUIT
+9 IF PSIFN<1
SET X=$$ACTIVE^PSJORREN(+ORVP,$GET(^OR(100,I,4)))
IF +X'=1
SET ERROR="This order may not be renewed: "_$SELECT(+X>1:"Inactive orderable item",1:$PIECE(X,U,2))
QUIT
End DoDot:2
if Y
QUIT
End DoDot:1
if $DATA(ERROR)!'PSIFN
QUIT
+10 ;I DG="TPN" S ERROR="TPN orders may not be renewed!" Q
+11 ;Ok
SET X=$$ACTIVE^PSJORREN(+ORVP,PSIFN)
if +X=1
QUIT
+12 ;replace OI
IF +X>1
IF $PIECE(X,U,2)
DO RESET^ORCACT03(+IFN,+$PIECE(X,U,2))
QUIT
+13 SET ERROR="This order may not be renewed: "_$PIECE(X,U,2)
+14 QUIT
+15 ;
XX ; -- edit/change--
+1 IF PKG="RA"
IF ORDSTS'=11
IF ORDSTS'=10
SET ERROR="Orders released to Radiology cannot be changed!"
QUIT
+2 IF PKG="LR"
IF ORDSTS'=11
IF ORDSTS'=10
SET ERROR="Orders released to Lab cannot be changed!"
QUIT
+3 IF PKG="FH"
IF ORDSTS'=11
IF ORDSTS'=10
SET ERROR="Orders released to Dietetics cannot be changed!"
QUIT
+4 IF PKG="GMRC"
IF ORDSTS'=11
IF ORDSTS'=10
SET ERROR="Orders released to Consults cannot be changed!"
QUIT
+5 IF DG="TPN"
SET ERROR="TPN orders may not be changed!"
QUIT
+6 IF ORDSTS=3
SET ERROR="Orders on hold may not be changed!"
QUIT
+7 IF DG="UD RX"
IF $$NTBG^ORCACT03(+IFN)
SET ERROR="This order has been marked 'Not to be Given' and may not be changed!"
QUIT
+8 IF $ORDER(^OR(100,+IFN,2,0))
SET ERROR="Complex orders may not be changed!"
QUIT
+9 IF $PIECE(OR3,U,9)
Begin DoDot:1
+10 ;NOW ok
if $$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW"
QUIT
+11 ;no conj=1dose/ok
if '$ORDER(^OR(100,+$PIECE(OR3,U,9),4.5,"ID","CONJ",0))
QUIT
+12 SET ERROR="Complex orders may not be changed!"
QUIT
End DoDot:1
if $DATA(ERROR)
QUIT
+13 IF $PIECE(OR3,U,6)
SET ERROR="This order may not be changed - a "_$SELECT($PIECE($GET(^OR(100,+$PIECE(OR3,U,6),3)),U,11)=1:"change",1:"renewal")_" order already exists!"
QUIT
+14 IF $PIECE(OR3,U,11)=2
Begin DoDot:1
+15 IF (ORDSTS=10!(ORDSTS=11))
IF DG'="O RX"
SET ERROR="Unreleased renewals may not be changed!"
QUIT
+16 IF PKG="PS"
IF ORDSTS=5
SET ERROR="Pending renewals may not be changed!"
QUIT
End DoDot:1
if $DATA(ERROR)
QUIT
+17 IF $$INACTIVE^ORCACT03
SET ERROR="Orders for inactive orderables may not be changed; please enter a new order!"
QUIT
+18 IF PKG="PS"
IF '$$MEDOK^ORCACT03
SET ERROR="This drug may not be ordered!"
QUIT
+19 IF DG="O RX"
IF $$XCONJ(+IFN)
SET ERROR="Orders with a conjunction of 'EXCEPT' may not be changed!"
QUIT
+20 ;old form
IF DG="O RX"
IF $ORDER(^OR(100,+IFN,4.5,"ID","MISC",0))
DO DOSES^ORCACT02(+IFN)
+21 QUIT
+22 ;
XCONJ(ORIFN) ; check if Responses multiple has an OR GTX AND/THEN entry with value of X:EXCEPT
+1 NEW ORI,ORRESULT
+2 SET ORRESULT=0
+3 SET ORI=""
+4 FOR
SET ORI=$ORDER(^OR(100,ORIFN,4.5,"ID","CONJ",ORI))
if 'ORI
QUIT
Begin DoDot:1
+5 IF $GET(^OR(100,ORIFN,4.5,ORI,1))="X"
SET ORRESULT=1
End DoDot:1
+6 QUIT ORRESULT
