- 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 Jan 18, 2025@03:30:11 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