ORCSEND ;SLC/MKB,ASMR/BL-Release orders ; July 19,2021@10:54
;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,45,79,92,141,165,195,228,243,303,296,390,563,572,538**;Dec 17, 1997;Build 1
;Per VA Directive 6402, this routine should not be modified.
;
EN(ORIFN,ACTION,SIGSTS,RELSTS,NATURE,REASON,ORERR) ; -- Release [actions on] orders
N ORDA,ORNOW,SIGNREQD,SIGNED,SIGNER
S SIGNREQD=+$P($G(^OR(100,+ORIFN,0)),U,16),ORERR=""
S SIGNED=$S(SIGSTS=2:0,1:1),SIGNER=$S(SIGSTS=1:DUZ,SIGSTS=7:DUZ,1:"")
S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN,ORNOW=+$E($$NOW^XLFDT,1,12)
S:"ES"[$G(ACTION) ACTION=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2)
I SIGNREQD,ORDA,"^NW^RW^XX^RN^DC^HD^RL^"[(U_ACTION_U) D ; sign/alert
. I 'SIGNED D NOTIF^ORCSIGN Q
. D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA)
. D:SIGSTS=4 CHART^ORCSIGN ; not used anymore
. ; if SIGNED but already released, post event
. I $P($G(^OR(100,ORIFN,8,ORDA,0)),U,15)="" D MSG^ORMBLDOR(ORIFN,"ZS")
I '$L(ACTION) S ORERR="1^Invalid order action" Q
I $$READY(ORIFN,ORDA) D:$L($T(@ACTION)) @ACTION I 'ORERR,ACTION="NW" D
. N OREVT S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17) Q:OREVT<1
. I '$$EVTORDER^OREVNTX(ORIFN) D SAVE^ORMEVNT1(ORIFN,OREVT,2,"ES")
; If order originated from the back door, send Dx and TxF back to ancil.
I SIGNED,$P($G(^OR(100,+ORIFN,3)),U,11)="P" D BDOEDIT^ORWDBA7
Q
;
EN1(ORDER,ORERR) ; -- Delayed Release [from RELEASE^ORMEVNT]
;
Q:$P($G(^OR(100,+ORDER,3)),U,3)'=10
N ORPKG,ORA0,ORNOW,ORIFN,ORDA,ORNP,ORNATR,ORQUIT,ORDUZ,SIGSTS,RELSTS
S ORPKG=$P($G(^OR(100,+ORDER,0)),U,14),ORA0=$G(^(8,1,0))
S ORNOW=+$E($$NOW^XLFDT,1,12),ORIFN=+ORDER,ORDA=1,ORNP=$P(ORA0,U,3)
S SIGSTS=$P(ORA0,U,4),ORNATR=$P($G(^ORD(100.02,+$P(ORA0,U,12),0)),U,2)
S RELSTS=$S(SIGSTS'=2:1,"^V^P^"[(U_ORNATR_U):1,1:0)
I RELSTS D
. D STARTDT^ORCSAVE2(ORIFN),PKGSTUFF^ORCSEND1(ORPKG) Q:$G(ORQUIT)
. S ORDUZ=$S(SIGSTS=0:$P(ORA0,U,7),SIGSTS=1:$P(ORA0,U,5),SIGSTS=2:$P(ORA0,U,17),SIGSTS=3:$P(ORA0,U,13),1:DUZ)
. D EDO1^ORWPFSS1 ;PFSS Event Delayed Orders
. D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORDUZ),NEW^ORMBLD(ORIFN)
. I "^10^13^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) S ORERR=1 ;error
I 'RELSTS!$G(ORERR),$P($G(^OR(100,ORIFN,3)),U,3)=10 D STATUS^ORCSAVE2(ORIFN,11) S $P(^OR(100,ORIFN,8,1,0),U,15)=11
Q
;
EN2(ORIFN,SIGSTS,NATURE,ORERR) ; -- Manual Release [from OREVNT1,SENDED^ORWDX]
N ORDA,ORNOW,OREVT,ORA0,ORNP,SIGNREQD,SIGNED,RELSTS
S ORDA=+$P(ORIFN,";",2),ORIFN=+ORIFN S:ORDA<1 ORDA=1
S OREVT=+$P($G(^OR(100,ORIFN,0)),U,17),ORA0=$G(^(8,ORDA,0))
S ORNP=$P(ORA0,U,3),SIGNREQD=($P(ORA0,U,4)'=3),(SIGNED,RELSTS)=1
S ORNOW=+$E($$NOW^XLFDT,1,12),ORERR=""
I $P(ORA0,U,4)=2 D ;needs ES
. N SIGNER S SIGNER=$S(SIGSTS=1:DUZ,1:"")
. I SIGSTS=2 D NOTIF^ORCSIGN S SIGNED=0 Q ;still unsigned
. D:SIGSTS'="" SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA)
D EDO2^ORWPFSS1 ;PFSS Event Delayed Orders
D NW I 'ORERR D SAVE^ORMEVNT1(+ORIFN,OREVT,2,"MN")
Q
;
NW ; -- New order ORIFN
RW ; -- Rewritten order ORIFN
XX ; -- Changed order ORIFN
RN ; -- Renewed order ORIFN
N ORQUIT,STS,TYPE,OR0,OR3,CODE,ORIG,ORSAVE
N IVDIEN,IVPKGM,IVDIEN2
S IVPKGM=0
S IVDIEN=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",""))
S IVDIEN2=$O(^ORD(101.41,"B","CLINIC OR PAT FLUID OE","")) ;OR*3.0*563
I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG,OREBUILD=1 Q
S:'ORDA ORDA=1 S ORSAVE=ORIFN
S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)) D STARTDT^ORCSAVE2(ORIFN)
S TYPE=$P(OR3,U,11),ORIG=+$P(OR3,U,5),CODE="NW"
I TYPE=1,ORIG,$D(^OR(100,ORIG,4)) S CODE="XO",^OR(100,ORIG,6)=$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW
I $$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSJ" S IVPKGM=1
; OR*3.0*563
I IVPKGM=1,$P($P(OR0,U,5),";")=IVDIEN!($P($P(OR0,U,5),";")=IVDIEN2) D PSJI^ORCSEND3 Q:$G(ORQUIT)
I IVPKGM=0!($P($P(OR0,U,5),";")'=IVDIEN) D PKGSTUFF^ORCSEND1(+$P(OR0,U,14)) Q:$G(ORQUIT)
D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE))
D NEW^ORMBLD(ORIFN,CODE) S ORIFN=ORSAVE,STS=$P($G(^OR(100,ORIFN,3)),U,3)
I (STS=1)!(STS=13) S ORERR="1^"_$$WHY(ORIFN,1) D:'SIGNED&SIGNREQD NOSIG K:ORIG ^OR(100,ORIG,6)
I STS=11 S ORERR="1^ERROR"
Q
;
DC ; -- DC order ORIFN
N PKG,CODE,ORCHLD,ORCHDA,STS,ORIDA,ORSAVE,OR3,OR6,DCNATURE
I '$G(REASON),$G(NATURE)="D" S REASON=+$O(^ORD(100.03,"C","ORDUP",0))
S:$G(REASON) $P(^OR(100,ORIFN,6),U,1,5)=$S($G(NATURE):NATURE,$L($G(NATURE)):$O(^ORD(100.02,"C",NATURE,0)),1:"")_"^^^"_+REASON_U_$P(^ORD(100.03,+REASON,0),U)
I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q
S $P(^OR(100,ORIFN,6),U,2,3)=$S($G(DGPMT):"",1:DUZ)_U_ORNOW,ORSAVE=ORIFN S:'$G(REASON) REASON=$P(^(6),U,4)
S STS=$P($G(^OR(100,ORIFN,3)),U,3),PKG=$P($G(^(0)),U,14),PKG=$$NMSP^ORCD(PKG),CODE=$S(PKG="LR":"CA",(PKG="PS")&(STS=5):"CA",(PKG="FH")&(STS=8):"CA",1:"DC")
D:ORDA RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE))
DC1 I $O(^OR(100,ORIFN,2,0)) D G DC2 ; DC children
. S ORCHLD=0 F S ORCHLD=$O(^OR(100,ORIFN,2,ORCHLD)) Q:ORCHLD'>0 I $$VALID^ORCACT0(ORCHLD,"DC") D Q:$G(ORERR)
. . S ORCHDA=$S(ORDA:$$ACTION^ORCSAVE("DC",ORCHLD,ORNP),1:0)
. . D:ORCHDA SIGN^ORCSAVE2(ORCHLD,,,8,ORCHDA) ;Sig on Parent only
. . D MSG^ORMBLD((ORCHLD_";"_ORCHDA),CODE,$G(REASON))
. . I "^1^13^"'[(U_$P(^OR(100,ORCHLD,3),U,3)_U) S ORERR="1^"_$$WHY(ORCHLD,ORCHDA)
. ;D:'$G(ORERR) STATUS^ORCSAVE2(ORIFN,1)
. S:$G(ORERR) ^OR(100,ORIFN,8,ORDA,1)=$P(ORERR,U,2)
D MSG^ORMBLD((ORIFN_";"_ORDA),CODE,$G(REASON))
DC2 S ORIFN=ORSAVE,OR3=$G(^OR(100,ORIFN,3)),STS=$P(OR3,U,3)
S OR6=$G(^OR(100,ORIFN,6))
I STS'=1,STS'=13,STS'=2 D Q
. S ORERR="1^"_$S(ORDA:$$WHY(ORIFN,ORDA),1:"Unable to discontinue")
. I ORDA,'SIGNED&SIGNREQD D NOSIG ; sig no longer reqd
. K ^OR(100,ORIFN,6)
S DCNATURE=$S(+OR6:+OR6,1:$G(NATURE))
S $P(^OR(100,ORIFN,3),U,7)=$S('$$ACTV^ORX1($G(DCNATURE)):0,ORDA:ORDA,1:$P(OR3,U,7))
D CANCEL(ORIFN),SETALL^ORDD100(ORIFN)
I $P(OR3,U,11)=2 D ; dc a renewal
. N ORIG,ORIG3,NATR S ORIG=$P(OR3,U,5),ORIG3=$G(^OR(100,ORIG,3)) Q:'ORIG
. ;I CODE="CA",+$P(OR6,U,9)'>0 S $P(^OR(100,ORIG,3),U,6)="" Q ;pend - remove fwd ptr
. I +$P(OR6,U,9)'>0 S $P(^OR(100,ORIG,3),U,6)="" Q ;pend - remove fwd ptr
. Q:"^1^7^12^13^"[(U_$P(ORIG3,U,3)_U) S NATR=$O(^ORD(100.02,"C","A",0))
. S ^OR(100,ORIG,6)=NATR_U_DUZ_U_ORNOW_"^^Renewal cancelled"
. D MSG^ORMBLD(ORIG,"DC") I "^1^13^"'[$P(^OR(100,ORIG,3),U,3) K ^(6) Q
. S:'$$ACTV^ORX1(NATR) $P(^OR(100,ORIG,3),U,7)=0
Q
;
CANCEL(IFN) ; -- Cancel any outstanding actions for order IFN
N I S I=0
F S I=$O(^OR(100,IFN,8,I)) Q:I'>0 I $P(^(I,0),U,15)=11 S $P(^(0),U,15)=13 D:$P(^(0),U,4)=2 SIGN^ORCSAVE2(IFN,"","",5,I) ; cancelled, sig not reqd now
Q
;
HD ; -- Hold order ORIFN
N STS,ORSAVE I 'ORDA S ORERR="1^Unable to hold" Q
I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q
D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE))
S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"HD") S ORIFN=ORSAVE
S STS=$P($G(^OR(100,ORIFN,3)),U,3) I STS=3 S $P(^(3),U,7)=ORDA D SET^ORDD100(ORIFN,ORDA)
I STS'=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG
Q
;
RL ; -- Release hold on order ORIFN
N STS,ORSAVE,ORHD I 'ORDA S ORERR="1^Unable to release hold" Q
I SIGNREQD,'SIGNED,'RELSTS S ORERR=$$NEEDSIG Q
D RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$G(NATURE))
S ORSAVE=ORIFN D MSG^ORMBLD((ORIFN_";"_ORDA),"RL") S ORIFN=ORSAVE
S STS=$P($G(^OR(100,ORIFN,3)),U,3),ORHD=+$P($G(^(3)),U,7)
I STS'=3 S $P(^OR(100,ORIFN,3),U,7)=ORDA,$P(^(8,ORHD,2),U,1,2)=ORNOW_U_DUZ D SET^ORDD100(ORIFN,ORDA)
I STS=3 S ORERR="1^"_$$WHY(ORIFN,ORDA) D:'SIGNED&SIGNREQD NOSIG
Q
;
FL ; -- Flag order ORIFN
Q
;
UF ; -- Unflag order ORIFN
Q
;
CM ; -- Add Ward comments to order ORIFN
Q
;
VR ; -- Verify order ORIFN
I 'ORDA!(SIGSTS=2) S ORERR="1^Unable to verify" Q
I "^N^C^R^"'[(U_$G(ORVER)_U) S ORERR="1^Unable to verify" Q
D VERIFY^ORCSAVE2(ORIFN,ORDA,ORVER,DUZ,ORNOW)
; -- send HL7 msg to Pharmacy if Nurse-Verified, [Sts=pending]
Q:ORVER'="N" N ORSTS,ORPKG,ORX
S ORX=$P($G(^OR(100,ORIFN,8,ORDA,0)),U,2) ;Q:ORX'="NW"&(ORX'="XX") OR*3*572 MOVE BELOW
S ORPKG=+$P($G(^OR(100,ORIFN,0)),U,14),ORSTS=$P($G(^(3)),U,3)
;I ORSTS=5!$L($T(ZV^ORMPS)),$$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN)
I $$NMSP^ORCD(ORPKG)="PS"&(ORX="NW"!(ORX="XX")!(ORX="RL")) D VER^ORMBLDPS(ORIFN) Q ;OR*3*572 Add conditions
Q:ORX'="NW"&(ORX'="XX")
D VER^ORMBLDOR(ORIFN)
Q
;
NEEDSIG() ; -- Msg
Q "1^This order requires a signature."
;
WHY(IFN,DA) ; -- Return reason request was rejected
N X S X=$G(^OR(100,IFN,8,DA,1))
S:'$L(X) X="Unable to "_$S(ACTION="HD":"hold",ACTION="RL":"release hold",ACTION="DC":"discontinue",ACTION="XX":"change",ACTION="RN":"renew",1:"release")
Q X
;
NOSIG ; -- Mark order as Sig not Req'd due to cancel/reject
D SIGN^ORCSAVE2(ORIFN,"","",5,ORDA) S SIGNREQD=0
Q
;
READY(IFN,ACT) ; -- Ready to release?
N X,Y,OR0,OR3,ORA
I ACTION="VR" S Y=1 G RQ ; no action to release
I 'ACT,ACTION="DC" S Y=1 G RQ ; cancel a duplicate
S Y=0,OR0=$G(^OR(100,IFN,0)),OR3=$G(^(3)),ORA=$G(^(8,ACT,0))
I $P(ORA,U,15)=11 S Y=1 G RQ ; unreleased
I $P(ORA,U,15)=10 D G RQ ; delayed
. I $G(^DPT(+ORVP,.105)),$$GET1^DIQ(9.4,+$P(OR0,U,14)_",",1)="PSO" S Y=1 Q
. Q:'RELSTS N ORIG S ORIG=+$P(OR3,U,5)
. I 'SIGNED,$L($G(NATURE)) S $P(ORA,U,17)=DUZ,$P(ORA,U,12)=$S(NATURE:NATURE,1:+$O(^ORD(100.02,"C",NATURE,0))),^OR(100,IFN,8,ACT,0)=ORA
. Q:$P(OR3,U,11)'=1!('ORIG) ;dc original if signed edit
. D STATUS^ORCSAVE2(ORIG,12)
. S ^OR(100,ORIG,6)=+$O(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW
. S $P(^OR(100,ORIG,3),U,7)=0,$P(^(8,1,0),U,15)=12 D:$P($G(^(0)),U,4)=2 SIGN^ORCSAVE2(ORIG,,,5,1)
I $P(OR3,U,3)=11,$P(ORA,U,2)="NW" S Y=1 ; Action Sts = "" (old)
RQ I +$$SWSTAT^IBBAPI() D:Y=1 EN^ORWPFSS4(+IFN) ; Associate PFSS Account Reference with order, Patch OR*3.0*228 IA #4663
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCSEND 9809 printed Sep 23, 2025@20:05:19 Page 2
ORCSEND ;SLC/MKB,ASMR/BL-Release orders ; July 19,2021@10:54
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4,27,45,79,92,141,165,195,228,243,303,296,390,563,572,538**;Dec 17, 1997;Build 1
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN(ORIFN,ACTION,SIGSTS,RELSTS,NATURE,REASON,ORERR) ; -- Release [actions on] orders
+1 NEW ORDA,ORNOW,SIGNREQD,SIGNED,SIGNER
+2 SET SIGNREQD=+$PIECE($GET(^OR(100,+ORIFN,0)),U,16)
SET ORERR=""
+3 SET SIGNED=$SELECT(SIGSTS=2:0,1:1)
SET SIGNER=$SELECT(SIGSTS=1:DUZ,SIGSTS=7:DUZ,1:"")
+4 SET ORDA=+$PIECE(ORIFN,";",2)
SET ORIFN=+ORIFN
SET ORNOW=+$EXTRACT($$NOW^XLFDT,1,12)
+5 if "ES"[$GET(ACTION)
SET ACTION=$PIECE($GET(^OR(100,ORIFN,8,ORDA,0)),U,2)
+6 ; sign/alert
IF SIGNREQD
IF ORDA
IF "^NW^RW^XX^RN^DC^HD^RL^"[(U_ACTION_U)
Begin DoDot:1
+7 IF 'SIGNED
DO NOTIF^ORCSIGN
QUIT
+8 if SIGSTS'=""
DO SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA)
+9 ; not used anymore
if SIGSTS=4
DO CHART^ORCSIGN
+10 ; if SIGNED but already released, post event
+11 IF $PIECE($GET(^OR(100,ORIFN,8,ORDA,0)),U,15)=""
DO MSG^ORMBLDOR(ORIFN,"ZS")
End DoDot:1
+12 IF '$LENGTH(ACTION)
SET ORERR="1^Invalid order action"
QUIT
+13 IF $$READY(ORIFN,ORDA)
if $LENGTH($TEXT(@ACTION))
DO @ACTION
IF 'ORERR
IF ACTION="NW"
Begin DoDot:1
+14 NEW OREVT
SET OREVT=+$PIECE($GET(^OR(100,ORIFN,0)),U,17)
if OREVT<1
QUIT
+15 IF '$$EVTORDER^OREVNTX(ORIFN)
DO SAVE^ORMEVNT1(ORIFN,OREVT,2,"ES")
End DoDot:1
+16 ; If order originated from the back door, send Dx and TxF back to ancil.
+17 IF SIGNED
IF $PIECE($GET(^OR(100,+ORIFN,3)),U,11)="P"
DO BDOEDIT^ORWDBA7
+18 QUIT
+19 ;
EN1(ORDER,ORERR) ; -- Delayed Release [from RELEASE^ORMEVNT]
+1 ;
+2 if $PIECE($GET(^OR(100,+ORDER,3)),U,3)'=10
QUIT
+3 NEW ORPKG,ORA0,ORNOW,ORIFN,ORDA,ORNP,ORNATR,ORQUIT,ORDUZ,SIGSTS,RELSTS
+4 SET ORPKG=$PIECE($GET(^OR(100,+ORDER,0)),U,14)
SET ORA0=$GET(^(8,1,0))
+5 SET ORNOW=+$EXTRACT($$NOW^XLFDT,1,12)
SET ORIFN=+ORDER
SET ORDA=1
SET ORNP=$PIECE(ORA0,U,3)
+6 SET SIGSTS=$PIECE(ORA0,U,4)
SET ORNATR=$PIECE($GET(^ORD(100.02,+$PIECE(ORA0,U,12),0)),U,2)
+7 SET RELSTS=$SELECT(SIGSTS'=2:1,"^V^P^"[(U_ORNATR_U):1,1:0)
+8 IF RELSTS
Begin DoDot:1
+9 DO STARTDT^ORCSAVE2(ORIFN)
DO PKGSTUFF^ORCSEND1(ORPKG)
if $GET(ORQUIT)
QUIT
+10 SET ORDUZ=$SELECT(SIGSTS=0:$PIECE(ORA0,U,7),SIGSTS=1:$PIECE(ORA0,U,5),SIGSTS=2:$PIECE(ORA0,U,17),SIGSTS=3:$PIECE(ORA0,U,13),1:DUZ)
+11 ;PFSS Event Delayed Orders
DO EDO1^ORWPFSS1
+12 DO RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,ORDUZ)
DO NEW^ORMBLD(ORIFN)
+13 ;error
IF "^10^13^"[(U_$PIECE($GET(^OR(100,ORIFN,3)),U,3)_U)
SET ORERR=1
End DoDot:1
+14 IF 'RELSTS!$GET(ORERR)
IF $PIECE($GET(^OR(100,ORIFN,3)),U,3)=10
DO STATUS^ORCSAVE2(ORIFN,11)
SET $PIECE(^OR(100,ORIFN,8,1,0),U,15)=11
+15 QUIT
+16 ;
EN2(ORIFN,SIGSTS,NATURE,ORERR) ; -- Manual Release [from OREVNT1,SENDED^ORWDX]
+1 NEW ORDA,ORNOW,OREVT,ORA0,ORNP,SIGNREQD,SIGNED,RELSTS
+2 SET ORDA=+$PIECE(ORIFN,";",2)
SET ORIFN=+ORIFN
if ORDA<1
SET ORDA=1
+3 SET OREVT=+$PIECE($GET(^OR(100,ORIFN,0)),U,17)
SET ORA0=$GET(^(8,ORDA,0))
+4 SET ORNP=$PIECE(ORA0,U,3)
SET SIGNREQD=($PIECE(ORA0,U,4)'=3)
SET (SIGNED,RELSTS)=1
+5 SET ORNOW=+$EXTRACT($$NOW^XLFDT,1,12)
SET ORERR=""
+6 ;needs ES
IF $PIECE(ORA0,U,4)=2
Begin DoDot:1
+7 NEW SIGNER
SET SIGNER=$SELECT(SIGSTS=1:DUZ,1:"")
+8 ;still unsigned
IF SIGSTS=2
DO NOTIF^ORCSIGN
SET SIGNED=0
QUIT
+9 if SIGSTS'=""
DO SIGN^ORCSAVE2(ORIFN,SIGNER,ORNOW,SIGSTS,ORDA)
End DoDot:1
+10 ;PFSS Event Delayed Orders
DO EDO2^ORWPFSS1
+11 DO NW
IF 'ORERR
DO SAVE^ORMEVNT1(+ORIFN,OREVT,2,"MN")
+12 QUIT
+13 ;
NW ; -- New order ORIFN
RW ; -- Rewritten order ORIFN
XX ; -- Changed order ORIFN
RN ; -- Renewed order ORIFN
+1 NEW ORQUIT,STS,TYPE,OR0,OR3,CODE,ORIG,ORSAVE
+2 NEW IVDIEN,IVPKGM,IVDIEN2
+3 SET IVPKGM=0
+4 SET IVDIEN=$ORDER(^ORD(101.41,"B","PSJI OR PAT FLUID OE",""))
+5 ;OR*3.0*563
SET IVDIEN2=$ORDER(^ORD(101.41,"B","CLINIC OR PAT FLUID OE",""))
+6 IF SIGNREQD
IF 'SIGNED
IF 'RELSTS
SET ORERR=$$NEEDSIG
SET OREBUILD=1
QUIT
+7 if 'ORDA
SET ORDA=1
SET ORSAVE=ORIFN
+8 SET OR0=$GET(^OR(100,ORIFN,0))
SET OR3=$GET(^(3))
DO STARTDT^ORCSAVE2(ORIFN)
+9 SET TYPE=$PIECE(OR3,U,11)
SET ORIG=+$PIECE(OR3,U,5)
SET CODE="NW"
+10 IF TYPE=1
IF ORIG
IF $DATA(^OR(100,ORIG,4))
SET CODE="XO"
SET ^OR(100,ORIG,6)=$ORDER(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW
+11 IF $$GET1^DIQ(9.4,+$PIECE(OR0,U,14)_",",1)="PSJ"
SET IVPKGM=1
+12 ; OR*3.0*563
+13 IF IVPKGM=1
IF $PIECE($PIECE(OR0,U,5),";")=IVDIEN!($PIECE($PIECE(OR0,U,5),";")=IVDIEN2)
DO PSJI^ORCSEND3
if $GET(ORQUIT)
QUIT
+14 IF IVPKGM=0!($PIECE($PIECE(OR0,U,5),";")'=IVDIEN)
DO PKGSTUFF^ORCSEND1(+$PIECE(OR0,U,14))
if $GET(ORQUIT)
QUIT
+15 DO RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$GET(NATURE))
+16 DO NEW^ORMBLD(ORIFN,CODE)
SET ORIFN=ORSAVE
SET STS=$PIECE($GET(^OR(100,ORIFN,3)),U,3)
+17 IF (STS=1)!(STS=13)
SET ORERR="1^"_$$WHY(ORIFN,1)
if 'SIGNED&SIGNREQD
DO NOSIG
if ORIG
KILL ^OR(100,ORIG,6)
+18 IF STS=11
SET ORERR="1^ERROR"
+19 QUIT
+20 ;
DC ; -- DC order ORIFN
+1 NEW PKG,CODE,ORCHLD,ORCHDA,STS,ORIDA,ORSAVE,OR3,OR6,DCNATURE
+2 IF '$GET(REASON)
IF $GET(NATURE)="D"
SET REASON=+$ORDER(^ORD(100.03,"C","ORDUP",0))
+3 if $GET(REASON)
SET $PIECE(^OR(100,ORIFN,6),U,1,5)=$SELECT($GET(NATURE):NATURE,$LENGTH($GET(NATURE)):$ORDER(^ORD(100.02,"C",NATURE,0)),1:"")_"^^^"_+REASON_U_$PIECE(^ORD(100.03,+REASON,0),U)
+4 IF SIGNREQD
IF 'SIGNED
IF 'RELSTS
SET ORERR=$$NEEDSIG
QUIT
+5 SET $PIECE(^OR(100,ORIFN,6),U,2,3)=$SELECT($GET(DGPMT):"",1:DUZ)_U_ORNOW
SET ORSAVE=ORIFN
if '$GET(REASON)
SET REASON=$PIECE(^(6),U,4)
+6 SET STS=$PIECE($GET(^OR(100,ORIFN,3)),U,3)
SET PKG=$PIECE($GET(^(0)),U,14)
SET PKG=$$NMSP^ORCD(PKG)
SET CODE=$SELECT(PKG="LR":"CA",(PKG="PS")&(STS=5):"CA",(PKG="FH")&(STS=8):"CA",1:"DC")
+7 if ORDA
DO RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$GET(NATURE))
DC1 ; DC children
IF $ORDER(^OR(100,ORIFN,2,0))
Begin DoDot:1
+1 SET ORCHLD=0
FOR
SET ORCHLD=$ORDER(^OR(100,ORIFN,2,ORCHLD))
if ORCHLD'>0
QUIT
IF $$VALID^ORCACT0(ORCHLD,"DC")
Begin DoDot:2
+2 SET ORCHDA=$SELECT(ORDA:$$ACTION^ORCSAVE("DC",ORCHLD,ORNP),1:0)
+3 ;Sig on Parent only
if ORCHDA
DO SIGN^ORCSAVE2(ORCHLD,,,8,ORCHDA)
+4 DO MSG^ORMBLD((ORCHLD_";"_ORCHDA),CODE,$GET(REASON))
+5 IF "^1^13^"'[(U_$PIECE(^OR(100,ORCHLD,3),U,3)_U)
SET ORERR="1^"_$$WHY(ORCHLD,ORCHDA)
End DoDot:2
if $GET(ORERR)
QUIT
+6 ;D:'$G(ORERR) STATUS^ORCSAVE2(ORIFN,1)
+7 if $GET(ORERR)
SET ^OR(100,ORIFN,8,ORDA,1)=$PIECE(ORERR,U,2)
End DoDot:1
GOTO DC2
+8 DO MSG^ORMBLD((ORIFN_";"_ORDA),CODE,$GET(REASON))
DC2 SET ORIFN=ORSAVE
SET OR3=$GET(^OR(100,ORIFN,3))
SET STS=$PIECE(OR3,U,3)
+1 SET OR6=$GET(^OR(100,ORIFN,6))
+2 IF STS'=1
IF STS'=13
IF STS'=2
Begin DoDot:1
+3 SET ORERR="1^"_$SELECT(ORDA:$$WHY(ORIFN,ORDA),1:"Unable to discontinue")
+4 ; sig no longer reqd
IF ORDA
IF 'SIGNED&SIGNREQD
DO NOSIG
+5 KILL ^OR(100,ORIFN,6)
End DoDot:1
QUIT
+6 SET DCNATURE=$SELECT(+OR6:+OR6,1:$GET(NATURE))
+7 SET $PIECE(^OR(100,ORIFN,3),U,7)=$SELECT('$$ACTV^ORX1($GET(DCNATURE)):0,ORDA:ORDA,1:$PIECE(OR3,U,7))
+8 DO CANCEL(ORIFN)
DO SETALL^ORDD100(ORIFN)
+9 ; dc a renewal
IF $PIECE(OR3,U,11)=2
Begin DoDot:1
+10 NEW ORIG,ORIG3,NATR
SET ORIG=$PIECE(OR3,U,5)
SET ORIG3=$GET(^OR(100,ORIG,3))
if 'ORIG
QUIT
+11 ;I CODE="CA",+$P(OR6,U,9)'>0 S $P(^OR(100,ORIG,3),U,6)="" Q ;pend - remove fwd ptr
+12 ;pend - remove fwd ptr
IF +$PIECE(OR6,U,9)'>0
SET $PIECE(^OR(100,ORIG,3),U,6)=""
QUIT
+13 if "^1^7^12^13^"[(U_$PIECE(ORIG3,U,3)_U)
QUIT
SET NATR=$ORDER(^ORD(100.02,"C","A",0))
+14 SET ^OR(100,ORIG,6)=NATR_U_DUZ_U_ORNOW_"^^Renewal cancelled"
+15 DO MSG^ORMBLD(ORIG,"DC")
IF "^1^13^"'[$PIECE(^OR(100,ORIG,3),U,3)
KILL ^(6)
QUIT
+16 if '$$ACTV^ORX1(NATR)
SET $PIECE(^OR(100,ORIG,3),U,7)=0
End DoDot:1
+17 QUIT
+18 ;
CANCEL(IFN) ; -- Cancel any outstanding actions for order IFN
+1 NEW I
SET I=0
+2 ; cancelled, sig not reqd now
FOR
SET I=$ORDER(^OR(100,IFN,8,I))
if I'>0
QUIT
IF $PIECE(^(I,0),U,15)=11
SET $PIECE(^(0),U,15)=13
if $PIECE(^(0),U,4)=2
DO SIGN^ORCSAVE2(IFN,"","",5,I)
+3 QUIT
+4 ;
HD ; -- Hold order ORIFN
+1 NEW STS,ORSAVE
IF 'ORDA
SET ORERR="1^Unable to hold"
QUIT
+2 IF SIGNREQD
IF 'SIGNED
IF 'RELSTS
SET ORERR=$$NEEDSIG
QUIT
+3 DO RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$GET(NATURE))
+4 SET ORSAVE=ORIFN
DO MSG^ORMBLD((ORIFN_";"_ORDA),"HD")
SET ORIFN=ORSAVE
+5 SET STS=$PIECE($GET(^OR(100,ORIFN,3)),U,3)
IF STS=3
SET $PIECE(^(3),U,7)=ORDA
DO SET^ORDD100(ORIFN,ORDA)
+6 IF STS'=3
SET ORERR="1^"_$$WHY(ORIFN,ORDA)
if 'SIGNED&SIGNREQD
DO NOSIG
+7 QUIT
+8 ;
RL ; -- Release hold on order ORIFN
+1 NEW STS,ORSAVE,ORHD
IF 'ORDA
SET ORERR="1^Unable to release hold"
QUIT
+2 IF SIGNREQD
IF 'SIGNED
IF 'RELSTS
SET ORERR=$$NEEDSIG
QUIT
+3 DO RELEASE^ORCSAVE2(ORIFN,ORDA,ORNOW,DUZ,$GET(NATURE))
+4 SET ORSAVE=ORIFN
DO MSG^ORMBLD((ORIFN_";"_ORDA),"RL")
SET ORIFN=ORSAVE
+5 SET STS=$PIECE($GET(^OR(100,ORIFN,3)),U,3)
SET ORHD=+$PIECE($GET(^(3)),U,7)
+6 IF STS'=3
SET $PIECE(^OR(100,ORIFN,3),U,7)=ORDA
SET $PIECE(^(8,ORHD,2),U,1,2)=ORNOW_U_DUZ
DO SET^ORDD100(ORIFN,ORDA)
+7 IF STS=3
SET ORERR="1^"_$$WHY(ORIFN,ORDA)
if 'SIGNED&SIGNREQD
DO NOSIG
+8 QUIT
+9 ;
FL ; -- Flag order ORIFN
+1 QUIT
+2 ;
UF ; -- Unflag order ORIFN
+1 QUIT
+2 ;
CM ; -- Add Ward comments to order ORIFN
+1 QUIT
+2 ;
VR ; -- Verify order ORIFN
+1 IF 'ORDA!(SIGSTS=2)
SET ORERR="1^Unable to verify"
QUIT
+2 IF "^N^C^R^"'[(U_$GET(ORVER)_U)
SET ORERR="1^Unable to verify"
QUIT
+3 DO VERIFY^ORCSAVE2(ORIFN,ORDA,ORVER,DUZ,ORNOW)
+4 ; -- send HL7 msg to Pharmacy if Nurse-Verified, [Sts=pending]
+5 if ORVER'="N"
QUIT
NEW ORSTS,ORPKG,ORX
+6 ;Q:ORX'="NW"&(ORX'="XX") OR*3*572 MOVE BELOW
SET ORX=$PIECE($GET(^OR(100,ORIFN,8,ORDA,0)),U,2)
+7 SET ORPKG=+$PIECE($GET(^OR(100,ORIFN,0)),U,14)
SET ORSTS=$PIECE($GET(^(3)),U,3)
+8 ;I ORSTS=5!$L($T(ZV^ORMPS)),$$NMSP^ORCD(ORPKG)="PS" D VER^ORMBLDPS(ORIFN)
+9 ;OR*3*572 Add conditions
IF $$NMSP^ORCD(ORPKG)="PS"&(ORX="NW"!(ORX="XX")!(ORX="RL"))
DO VER^ORMBLDPS(ORIFN)
QUIT
+10 if ORX'="NW"&(ORX'="XX")
QUIT
+11 DO VER^ORMBLDOR(ORIFN)
+12 QUIT
+13 ;
NEEDSIG() ; -- Msg
+1 QUIT "1^This order requires a signature."
+2 ;
WHY(IFN,DA) ; -- Return reason request was rejected
+1 NEW X
SET X=$GET(^OR(100,IFN,8,DA,1))
+2 if '$LENGTH(X)
SET X="Unable to "_$SELECT(ACTION="HD":"hold",ACTION="RL":"release hold",ACTION="DC":"discontinue",ACTION="XX":"change",ACTION="RN":"renew",1:"release")
+3 QUIT X
+4 ;
NOSIG ; -- Mark order as Sig not Req'd due to cancel/reject
+1 DO SIGN^ORCSAVE2(ORIFN,"","",5,ORDA)
SET SIGNREQD=0
+2 QUIT
+3 ;
READY(IFN,ACT) ; -- Ready to release?
+1 NEW X,Y,OR0,OR3,ORA
+2 ; no action to release
IF ACTION="VR"
SET Y=1
GOTO RQ
+3 ; cancel a duplicate
IF 'ACT
IF ACTION="DC"
SET Y=1
GOTO RQ
+4 SET Y=0
SET OR0=$GET(^OR(100,IFN,0))
SET OR3=$GET(^(3))
SET ORA=$GET(^(8,ACT,0))
+5 ; unreleased
IF $PIECE(ORA,U,15)=11
SET Y=1
GOTO RQ
+6 ; delayed
IF $PIECE(ORA,U,15)=10
Begin DoDot:1
+7 IF $GET(^DPT(+ORVP,.105))
IF $$GET1^DIQ(9.4,+$PIECE(OR0,U,14)_",",1)="PSO"
SET Y=1
QUIT
+8 if 'RELSTS
QUIT
NEW ORIG
SET ORIG=+$PIECE(OR3,U,5)
+9 IF 'SIGNED
IF $LENGTH($GET(NATURE))
SET $PIECE(ORA,U,17)=DUZ
SET $PIECE(ORA,U,12)=$SELECT(NATURE:NATURE,1:+$ORDER(^ORD(100.02,"C",NATURE,0)))
SET ^OR(100,IFN,8,ACT,0)=ORA
+10 ;dc original if signed edit
if $PIECE(OR3,U,11)'=1!('ORIG)
QUIT
+11 DO STATUS^ORCSAVE2(ORIG,12)
+12 SET ^OR(100,ORIG,6)=+$ORDER(^ORD(100.02,"C","C",0))_U_DUZ_U_ORNOW
+13 SET $PIECE(^OR(100,ORIG,3),U,7)=0
SET $PIECE(^(8,1,0),U,15)=12
if $PIECE($GET(^(0)),U,4)=2
DO SIGN^ORCSAVE2(ORIG,,,5,1)
End DoDot:1
GOTO RQ
+14 ; Action Sts = "" (old)
IF $PIECE(OR3,U,3)=11
IF $PIECE(ORA,U,2)="NW"
SET Y=1
RQ ; Associate PFSS Account Reference with order, Patch OR*3.0*228 IA #4663
IF +$$SWSTAT^IBBAPI()
if Y=1
DO EN^ORWPFSS4(+IFN)
+1 QUIT Y
