Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORCACT01

ORCACT01.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ;External reference to $$ORCOPY^PSOORCPY supported by DBIA 6719
  1.  ;
  1. ES ; -- sign [on chart]
  1.  I ORDSTS=11,VER<3,PKG'="OR" S ERROR="This order cannot be released and must be discontinued!" Q
  1.  N X I ACTSTS=11!(ACTSTS=10) D  Q:$L($G(ERROR))
  1.  . I $P(ORA0,U,2)="DC",$$DONE^ORCACT0 D CANCEL^ORCSEND(+IFN),UNOTIF^ORCSIGN S OREBUILD=1 Q
  1.  . S X=$$DISABLED^ORCACT0 I X S ERROR=$P(X,U,2) Q
  1.  I ACTION="OC",$G(DG)="NV RX" S:MEDPARM<2 ERROR="You are not authorized to release non-VA med orders!" Q
  1.  S X=$P(ORA0,U,4) I X=3 S:ACTSTS'=11&(ACTSTS'=10) ERROR="This order does not require a signature!" Q
  1.  I X=5 S ERROR="This order has been canceled!" Q  ;p580
  1.  I X'=2 S ERROR="This order has been signed!" Q
  1.  N ORCS D CSVALUE^ORDEA(.ORCS,+IFN)
  1.  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
  1.  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
  1.  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
  1.  ;
  1.  I DG="SPLY" D  Q:$D(ERROR)
  1.  . N ORALLOWED,ORAUTHMEDS,ORHASSUPKEY,ORX
  1.  . ; User must have ORSUPPLY or Auth to Write Meds to release supply items
  1.  . S ORHASSUPKEY=$D(^XUSEC("ORSUPPLY",DUZ))
  1.  . S ORAUTHMEDS=1
  1.  . S ORX=$G(^VA(200,DUZ,"PS"))
  1.  . I '$P(ORX,U)!($P(ORX,U,4)&(DT>$P(ORX,U,4))) S ORAUTHMEDS=0
  1.  . I 'ORHASSUPKEY,'ORAUTHMEDS D  Q
  1.  . . S ERROR="You are not authorized to release supply orders."
  1.  . ; only allow release by policy, signed on chart, or ES
  1.  . ; release via verbal or telephone is not allowed
  1.  . S ORALLOWED=0
  1.  . I ACTION?1(1"ES",1"DS",1"OC") S ORALLOWED=1
  1.  . I ACTION="RS",$G(NATR)?1(1"I",1"W") S ORALLOWED=1
  1.  . I 'ORALLOWED S ERROR="Supplies may not be released with this action."
  1.  ;
  1.  I ACTION="OC" S:MEDPARM<2 ERROR="You are not authorized to release med orders!" Q
  1.  ;
  1.  ; Don't allow DC of lab order to be signed/released if its already been accessioned
  1.  I PKG="LR",$P(ORA0,U,2)="DC",$$COLLECTD^ORCACT0 D  Q:$D(ERROR)
  1.  . S ERROR="This order may not be discontinued.                                                                                "
  1.  . S ERROR=ERROR_"Cancel the discontinue to remove it from the patient's record.                                    "
  1.  . S ERROR=ERROR_$$GET^XPAR("ALL","OR LAB CANCEL ERROR MESSAGE",1,"I")
  1.  ;
  1.  I ACTION="RS" D  Q:$D(ERROR)  Q:$G(NATR)'="I"
  1.  . Q:ACTSTS=11  Q:ACTSTS=10  ;unreleased - ok
  1.  . S ERROR="This order has already been released!"
  1. ES1 I PKG="PS" D  ;authorized to write meds?
  1.  . N TYPE,OI,PSOI,DEAFLG,PKI,IVERROR,ORDGNM
  1.  . S X=$G(^VA(200,DUZ,"PS"))
  1.  . I DG'="SPLY",'$P(X,U) S ERROR="You are not authorized to sign med orders!" Q
  1.  . 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
  1.  . ;Q:DG="IV RX"  Q:$P(ORA0,U,2)="DC"  ;don't need to ck DEA#
  1.  . Q:$P(ORA0,U,2)="DC"
  1.  . S ORDGNM=$$GET1^DIQ(100,+IFN_",",2)
  1.  . I ORDGNM["FLUID OE" D  Q
  1.  . .S FAIL=$$IVDEACHK(+IFN) I FAIL'=0 S ERROR=FAIL
  1.  . S OI=+$$VALUE^ORX8(+IFN,"ORDERABLE")
  1.  . S PSOI=+$P($G(^ORD(101.43,OI,0)),U,2) Q:PSOI'>0
  1.  . S TYPE=$S($P(DG," ")="O":"O",1:"I"),DEAFLG=$P($$OIDEA^PSSOPKI(PSOI,TYPE),";",2)
  1.  . S DETFLAG=$$OIDETOX^PSSOPKI(PSOI,TYPE)
  1.  . S DETPRO=$$DETOX^XUSER(+$G(DUZ))
  1.  . I DETFLAG,DETPRO="" S ERROR=3 Q
  1.  . I DETFLAG,DETPRO>0 S Y=DETPRO X ^DD("DD") S ERROR="5^"_Y Q
  1.  . I (DEAFLG>0!($$ISCLOZ^ORALWORD(OI))) D  I $G(ERROR)]"" Q
  1.  .. N RET
  1.  .. I $$ISCLOZ^ORALWORD(OI) D  Q
  1.  ... S RET=$$DEA^XUSER(,DUZ) I RET="" S ERROR=1
  1.  .. S RET=$$SDEA^XUSER(,DUZ,DEAFLG)
  1.  .. I RET=1 S ERROR=1 Q
  1.  .. I RET=2 S ERROR="2^"_$$UP^XLFSTR(DEAFLG) Q
  1.  .. I RET?1"4".E S ERROR=RET Q
  1.  .. I RET?1N.E S ERROR=RET
  1.  .. ; Support multiple DEA's for a provider
  1.  .. N ORSLDEA,RET S ORSLDEA=$P($G(^OR(100,+IFN,11)),U) ;*499}
  1.  .. I ORSLDEA="" S ORSLDEA=$$DEA^XUSER(,DUZ)
  1.  .. I ORSLDEA="" S ERROR=1 Q
  1.  .. N RET
  1.  .. S RET=$$SDEA^XUSER(,DUZ,DEAFLG,ORSLDEA)
  1.  . D PKISITE^ORWOR(.PKI)
  1.  . I $G(PKI),ACTION="RS",DEAFLG=1 S ERROR="This order cannot be released without a Digital Signature" Q
  1.  Q
  1.  ;
  1. IVDEACHK(IFN) ; -- Returns value of prompt by ID
  1.  I '$G(IFN)!('$D(^OR(100,+$G(IFN),0))) Q ""
  1.  N I,DIAL,DIALTYP,FAIL,PATCLASS,RESULT,Y
  1.  S PATCLASS=$P(^OR(100,+IFN,0),U,12)
  1.  S RESULT=0
  1.  ;if ORNP is not set then assume this is called from VistA not CPRS
  1.  I $G(ORNP)="" S ORNP=DUZ
  1.  S I=0,Y="" S:'$G(INST) INST=1
  1.  F  S I=$O(^OR(100,+IFN,4.5,"ID","ORDERABLE",I)) Q:I'>0!(RESULT=1)  D
  1.  .S Y=$G(^OR(100,+IFN,4.5,I,1)) Q:Y'>0
  1.  .;S PSOI=+$P($G(^ORD(101.43,Y,0)),U,2) Q:PSOI'>0
  1.  .I PATCLASS="I" D  Q
  1.  ..D FAILDEA^ORWDPS1(.FAIL,Y,ORNP,"I") I FAIL'=0 S RESULT=FAIL
  1.  .S DIAL=+$P(^OR(100,+IFN,4.5,I,0),U,2)
  1.  .S DIALTYP=$S($P(^ORD(101.41,DIAL,0),U)["ADDITIVE":"A",1:"S")
  1.  .D FDEA1^ORWDPS1(.FAIL,Y,DIALTYP,ORNP)
  1.  .I FAIL'=0 S RESULT=FAIL
  1.  .;I $$OIDEA^PSSUTLA1(PSOI,"I")>0 S RESULT=1 Q
  1.  Q RESULT
  1.  ;
  1. XFR ; -- transfer to inpt/outpt [IFN=order to be transferred]
  1.  N OI,PS I DG="TPN" S ERROR="TPN orders may not be copied!" Q
  1.  I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be transferred; please enter a new order!" Q
  1.  S OI=+$O(^OR(100,+IFN,.1,"B",0)),ORPS=$G(^ORD(101.43,OI,"PS"))
  1.  I DG="UD RX",'$P(ORPS,U,2) S ERROR="This drug may not be ordered for an outpatient!" Q
  1.  I DG="O RX" D  Q:$L($G(ERROR))
  1.  . I '$P(ORPS,U) S ERROR="This drug may not be ordered for an inpatient!" Q
  1.  . D:$O(^OR(100,+IFN,4.5,"ID","MISC",0)) DOSES^ORCACT02(+IFN)
  1.  ;
  1.  ; Really this check should not be needed, as in BLDQRSP^ORWDXM1 if the urgency is not valid
  1.  ; it returns a 0, so that the GUI does not auto-accept the order. However, a bug in the GUI
  1.  ; is preventing that from happening. Once that bug is fixed, this check can be removed.
  1.  I PKG="RA" D  Q:$D(ERROR)
  1.  . N ORURG
  1.  . S ORURG=$$VALUE^ORCSAVE2(+IFN,"URGENCY")
  1.  . I ORURG,'$$RADURG^ORWDRA32(+ORURG) S ERROR="Invalid urgency. Cannot transfer!"
  1.  Q
  1.  ;
  1. RW ; -- rewrite/copy
  1.  N ORISCL D ISCLORD^ORUTL(.ORISCL,+IFN)
  1.  I ORISCL S ERROR="Cannot copy Clinic Medication or Clinic Infusion orders!"
  1.  I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be copied!" Q
  1.  I DG="NV RX" S ERROR="Non-VA Med orders cannot be copied!" Q
  1.  I DG="TPN" S ERROR="TPN orders may not be rewritten!" Q
  1.  I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be rewritten!" Q
  1.  I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be copied; please enter a new order!" Q
  1.  I PKG="PS",'$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q
  1.  I DG="O RX" D
  1.  . N ORX,PSIFN
  1.  . I $O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form
  1.  . ;
  1.  . ;p377 LMT - check with pharmacy that order can be copied
  1.  . S PSIFN=$G(^OR(100,+IFN,4))
  1.  . I PSIFN="" Q  ; If does not have package ref yet (i.e., unsigned order) let it be copied w/o ORCOPY^PSOORCPY check
  1.  . S ORX=$$ORCOPY^PSOORCPY(PSIFN)  ;ICR #6719
  1.  . I ORX<1 S ERROR=$P(ORX,U,2) Q
  1.  Q
  1.  ;
  1. RN ; -- renew
  1.  I PKG'="PS",PKG'="OR" S ERROR="This order may not be renewed!" Q
  1.  I (ORDSTS=11)!(ORDSTS=10) S ERROR="This order has not been released to the service." Q
  1.  I ACTSTS=12 S ERROR="Orders that have been dc'd due to editing may not be renewed!" Q
  1.  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
  1.  I PKG="OR" D  Q  ;Generic orders
  1.  . I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be renewed!" Q
  1.  . I DG="ADT" S ERROR="M.A.S. orders may not be renewed!" Q
  1.  . I "^1^2^6^7^"[(U_ORDSTS_U) Q  ;ok
  1.  . S ERROR="This order may not be renewed!"
  1.  I PKG="PS" D  Q:$L($G(ERROR))
  1.  . I $L($G(DG)) I $E(DG)'["O" Q
  1.  . N ORZIPOK,OI
  1.  . S OI=+$$VALUE^ORX8(+IFN,"ORDERABLE") Q:OI'>0
  1.  . D ZIP^ORWDPS11(.ORZIPOK,OI,"O",+ORVP)
  1.  . I 'ORZIPOK S ERROR=$P(ORZIPOK,"^",2)
  1.  I (PKG="PS"),$$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be renewed!" Q
  1.  I '$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q
  1. RN1 N PSIFN,OROI
  1.  S PSIFN=$G(^OR(100,+IFN,4))
  1.  I PSIFN<1,'$O(^OR(100,+IFN,2,0)) S ERROR="Missing or invalid order number!" Q
  1.  S OROI=$G(^OR(100,+IFN,.1,1,0))
  1.  I $$ISCLOZ^ORALWORD(OROI) S ERROR="Cannot renew Clozapine orders!" Q
  1.  I DG="O RX"!(DG="SPLY") D  Q  ;Outpt Meds
  1.  . N ORZ,ORD
  1.  . I $$XCONJ(+IFN) S ERROR="Orders with a conjunction of 'EXCEPT' may not be renewed!" Q
  1.  . S ORZ=$L($T(RENEW^PSORENW),",")
  1.  . I ORZ>1 S ORD=+$$VALUE^ORX8(+IFN,"DRUG"),X=$$RENEW^PSORENW(PSIFN,ORD)
  1.  . S:ORZ'>1 X=$$RENEW^PSORENW(PSIFN) I X<1 S ERROR=$P(X,U,2) Q
  1.  . S X=+$P(X,U,2) D:X RESET^ORCACT03(+IFN,X)
  1.  . I $O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old format
  1.  I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be renewed!" Q
  1.  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
  1.  I ORDSTS'=6,ORDSTS'=7 S ERROR="This order may not be renewed!" Q
  1. RN2 I $O(^OR(100,+IFN,2,0))!$P(OR3,U,9) D  Q:$D(ERROR)!'PSIFN
  1.  . I $P(OR3,U,9),$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW" S ERROR="One-time NOW orders may not be renewed!" Q
  1.  . N DAD,ORD3,I,Y S DAD=$S($P(OR3,U,9):+$P(OR3,U,9),1:+IFN),Y=0
  1.  . S ORD3=$G(^OR(100,DAD,3)) I $P(ORD3,U,6) S ERROR="This complex order has already been renewed!" Q
  1.  . I $P(ORD3,U,3)'=6 S ERROR="This complex order is not active and may not be renewed!" Q
  1.  . I '$$AND^ORX8(DAD) S ERROR="Complex orders with sequential doses may not be renewed!" Q
  1.  . S I=0 F  S I=+$O(^OR(100,DAD,2,I)) Q:I<1  D  Q:Y
  1.  .. I I=+$O(^OR(100,DAD,2,0)),$$VALUE^ORX8(I,"SCHEDULE",1,"E")="NOW",$$VALUE^ORX8(DAD,"NOW") Q  ;ignore NOW orders
  1.  .. I $P($G(^OR(100,I,3)),U,3)'=6 S Y=1,ERROR="Complex orders with terminated doses may not be renewed!" Q
  1.  .. 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
  1.  ;I DG="TPN" S ERROR="TPN orders may not be renewed!" Q
  1.  S X=$$ACTIVE^PSJORREN(+ORVP,PSIFN) Q:+X=1  ;Ok
  1.  I +X>1,$P(X,U,2) D RESET^ORCACT03(+IFN,+$P(X,U,2)) Q  ;replace OI
  1.  S ERROR="This order may not be renewed: "_$P(X,U,2)
  1.  Q
  1.  ;
  1. XX ; -- edit/change--
  1.  I PKG="RA",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Radiology cannot be changed!" Q
  1.  I PKG="LR",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Lab cannot be changed!" Q
  1.  I PKG="FH",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Dietetics cannot be changed!" Q
  1.  I PKG="GMRC",ORDSTS'=11,ORDSTS'=10 S ERROR="Orders released to Consults cannot be changed!" Q
  1.  I DG="TPN" S ERROR="TPN orders may not be changed!" Q
  1.  I ORDSTS=3 S ERROR="Orders on hold may not be changed!" Q
  1.  I DG="UD RX",$$NTBG^ORCACT03(+IFN) S ERROR="This order has been marked 'Not to be Given' and may not be changed!" Q
  1.  I $O(^OR(100,+IFN,2,0)) S ERROR="Complex orders may not be changed!" Q
  1.  I $P(OR3,U,9) D  Q:$D(ERROR)
  1.  . Q:$$VALUE^ORX8(+IFN,"SCHEDULE",1,"E")="NOW"  ;NOW ok
  1.  . Q:'$O(^OR(100,+$P(OR3,U,9),4.5,"ID","CONJ",0))  ;no conj=1dose/ok
  1.  . S ERROR="Complex orders may not be changed!" Q
  1.  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
  1.  I $P(OR3,U,11)=2 D  Q:$D(ERROR)
  1.  . I (ORDSTS=10!(ORDSTS=11)),DG'="O RX" S ERROR="Unreleased renewals may not be changed!" Q
  1.  . I PKG="PS",ORDSTS=5 S ERROR="Pending renewals may not be changed!" Q
  1.  I $$INACTIVE^ORCACT03 S ERROR="Orders for inactive orderables may not be changed; please enter a new order!" Q
  1.  I PKG="PS",'$$MEDOK^ORCACT03 S ERROR="This drug may not be ordered!" Q
  1.  I DG="O RX",$$XCONJ(+IFN) S ERROR="Orders with a conjunction of 'EXCEPT' may not be changed!" Q
  1.  I DG="O RX",$O(^OR(100,+IFN,4.5,"ID","MISC",0)) D DOSES^ORCACT02(+IFN) ;old form
  1.  Q
  1.  ;
  1. XCONJ(ORIFN) ; check if Responses multiple has an OR GTX AND/THEN entry with value of X:EXCEPT
  1.  N ORI,ORRESULT
  1.  S ORRESULT=0
  1.  S ORI=""
  1.  F  S ORI=$O(^OR(100,ORIFN,4.5,"ID","CONJ",ORI)) Q:'ORI  D
  1.  . I $G(^OR(100,ORIFN,4.5,ORI,1))="X" S ORRESULT=1
  1.  Q ORRESULT