ORCSEND2 ;SLC/MKB - Release cont ;Jan 23, 2019@17:18
;;3.0;ORDER ENTRY/RESULTS REPORTING;**212,332,503**;Dec 17, 1997;Build 6
;
PTR(NAME) ; -- Returns ptr value of prompt in Dialog file
Q +$O(^ORD(101.41,"AB","OR GTX "_NAME,0))
;
EN ; -- Spawn child orders from ORIFN, send to VBECS [from VBEC^ORCSEND1]
N ORPARENT,OR0,ORDIALOG,ORNP,ORDUZ,ORLOG,ORCAT,ORTS,ORDG,ORPKG,ORPRINT
N ORESP,ORTIME,ORSTRT,ORI,ORIT,ORITX,ORFLDS,ORP,P,ORCHLD,ORLAST,X,STS,ORLAB,ORLRIFN
N ORPITEM,ORPRBCM,ORPUNIT,ORPDTW,ORPREAS,ORPMSBS,ORPINFC,ORPURG,ORPTYPE,ORPCOLL,ORPCOMM,ORPRSLT,ORPSPEC,ORPLAB
S ORPARENT=+ORIFN,OR0=$G(^OR(100,ORIFN,0))
S ORDIALOG=+$P(OR0,U,5),ORNP=+$P(OR0,U,4),ORDUZ=+$P(OR0,U,6)
S ORLOG=$P(OR0,U,7),ORCAT=$P(OR0,U,12),ORTS=$P(OR0,U,13)
S ORDG=+$P(OR0,U,11),ORPKG=$P(OR0,U,14),ORPRINT=0
D GETDLG1^ORCD(ORDIALOG),GETORDER^ORCD(ORIFN,"ORESP"),GETIMES^ORCDLR1
M ^TMP($J,"ORVBDLG")=ORDIALOG S ORPITEM=$$PTR("ORDERABLE ITEM")
S ORPRBCM=$$PTR("RBC MODIFIERS"),ORPUNIT=$$PTR("AMOUNT")
S ORPDTW=$$PTR("DATE/TIME"),ORPREAS=$$PTR("REASON")
S ORPMSBS=$$PTR("TEXT"),ORPINFC=$$PTR("YES/NO")
S ORPTYPE=$$PTR("COLLECTION TYPE"),ORPCOLL=$$PTR("START DATE/TIME")
S ORPURG=$$PTR("URGENCY"),ORPCOMM=$$PTR("FREE TEXT 1")
S ORPSPEC=$$PTR("SPECIMEN STATUS"),ORPRSLT=$$PTR("RESULTS")
S ORPLAB=$$PTR("LAB ORDER") D START ;resolve ORSTRT dates
EN1 S ORI=0 F S ORI=$O(ORESP(ORPITEM,ORI)) Q:ORI<1 D Q:$G(ORERR)
. N ORL S ORL=$P(OR0,U,10) ;protect ORL from calling routine
. S ORIT=+$G(ORESP(ORPITEM,ORI)),ORITX=$G(^ORD(101.43,ORIT,"VB"))
. D LABTST I $G(ORERR) D CANCEL(ORPARENT,$P(ORERR,U,2)) Q
. K ORDIALOG M ORDIALOG=^TMP($J,"ORVBDLG") S ORDIALOG(ORPITEM,1)=ORIT
. S ORFLDS=$S(ORITX:"ORPRBCM^ORPUNIT^ORPSPEC^ORPMSBS^ORPINFC",$P(ORITX,U,2)=1:"ORPTYPE^ORPCOLL",$P(ORITX,U,2)=2:"ORPMSBS^ORPINFC^ORPTYPE^ORPCOLL",1:"")_"^ORPDTW^ORPREAS^ORPURG^ORPCOMM"
. F ORP=1:1:$L(ORFLDS,U) S P=$P(ORFLDS,U,ORP) Q:'$L(P) S ORDIALOG(@P,1)=$S($D(ORESP(@P,ORI)):ORESP(@P,ORI),P="ORPRBCM":"",1:$G(ORESP(@P,1))) ;set values
. S:$G(ORLRIFN) ORDIALOG(ORPLAB,1)=ORLRIFN
. K ORIFN,ORIT D EN^ORCSAVE
. I '$G(ORIFN) S ORERR="1^Unable to create order" Q
. S X=ORSTRT($S(ORITX:"DTW",1:"COLL")) D DATES^ORCSAVE2(ORIFN,X)
. D RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$G(NATURE)),LINK
. D NW^ORMBLDVB(ORIFN)
S:$G(ORCHLD) ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD
D RELEASE^ORCSAVE2(ORPARENT,1,ORNOW,DUZ,$G(NATURE))
;D STATUS^ORCSAVE2(ORPARENT,5) ;testing
S ORIFN=ORPARENT,ORQUIT=1,STS=$P(^OR(100,ORIFN,3),U,3)
EN2 I STS'=11,STS'=13 D ;successful
. D RESULTS^ORMBLDVB(ORPARENT)
. Q:'$O(ORPRINT(0)) N PAT,LOC,NATR
. S PAT=$P(OR0,U,2),LOC=$S($G(ORL):ORL,1:$P(OR0,U,10))
. S NATR=$$WORK^ORCSIGN($G(NATURE))
. D PRINT^ORPR02(PAT,.ORPRINT,,LOC,"0^1^1^1^"_NATR) ;labels/req's
I $$UNRL(ORPARENT) S ORERR="1^Unable to release order due to an HL7 network error: queued for delivery to VBECS"
I STS=13 S ORERR="1^This order was rejected by VBECS and will NOT be acted upon: see the Order Details for more information and contact the Blood Bank for assistance!"
K ^TMP($J,"ORVBDLG"),^TMP($J,"ORLRDLG")
Q
;
UNRL(DAD) ; -- ck for any unreleased child orders
N Y,I,STS S Y=0
S I=0 F S I=+$O(^OR(100,+$G(DAD),2,I)) Q:I<1 D Q:Y
. S STS=$P($G(^OR(100,I,3)),U,3)
. I STS=10!(STS=11) S Y=1 Q
Q Y
;
START ; -- Define ORSTRT(), set Start Date in ORPARENT
N X,Y,%DT,STRT S ORSTRT("COLL")="",ORSTRT("DTW")="",%DT="TX",STRT=""
S X=$G(ORESP(ORPDTW,1)) I $L(X) D ^%DT S:Y>0 ORSTRT("DTW")=Y,STRT=Y
S X=$G(ORESP(ORPCOLL,1)) I $L(X) D
. D AM^ORCSAVE2:X="AM",NEXT^ORCSAVE2:X="NEXT" ;return X
. D ^%DT S:Y>0 ORSTRT("COLL")=Y,STRT=Y
I '$P(OR0,U,8) D DATES^ORCSAVE2(+ORIFN,STRT)
Q
;
LINK ; -- set up ORPARENT/ORIFN links, ORLAST in ORCHLD()
; Uses ORVP,ORLOG in xref
S ORCHLD=+$G(ORCHLD)+1,^OR(100,ORPARENT,2,ORIFN,0)=ORIFN,ORLAST=ORIFN
S $P(^OR(100,ORIFN,3),U,8,9)="1^"_ORPARENT
S $P(^OR(100,ORIFN,8,1,0),U,4)=8 K ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1) ;signature on parent only
Q
;
LABTST ; -- Create Lab order for VBECS blood component or test
; Expects var's from above, Returns ORLAB & ORLRIFN
N ORDIALOG,ORDG,ORPKG,ORIFN,X,P,LRT K ORLAB,ORLRIFN
I $G(^TMP($J,"ORLRDLG")) M ORDIALOG=^TMP($J,"ORLRDLG")
E D ;build for now, later reuse
. S ORDIALOG=+$O(^ORD(101.41,"AB","LR OTHER LAB TESTS",0))
. D GETDLG1^ORCD(ORDIALOG) M ^TMP($J,"ORLRDLG")=ORDIALOG
S ORDG=+$O(^ORD(100.98,"B","BB",0)),X=$P($G(^ORD(101.43,ORIT,0)),U,8)
S X=+$$TEST(X) I X<1 S ORERR="1^Missing or invalid Lab workload test" Q
S ORDIALOG(ORPITEM,1)=X,LRT=+$P($G(^ORD(101.43,X,0)),U,2)
S ORDIALOG(ORPTYPE,1)=$S($D(ORESP(ORPTYPE,1)):ORESP(ORPTYPE,1),1:"SP")
S ORDIALOG(ORPCOLL,1)=$S($D(ORESP(ORPCOLL,1)):ORESP(ORPCOLL,1),1:$G(ORESP(ORPDTW,1)))
LT1 ; VALIDATE??
S X=+$O(^LAB(60,LRT,3,0)),X=+$G(^(X,0)) ;default/unique sample
S ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=X
S:'ORITX ORDIALOG($$PTR("SPECIMEN"),1)=$P($G(^LAB(62,X,0)),U,2)
S X=+$G(ORESP(ORPURG,1)),X=$P($G(^ORD(101.42,X,0)),U)
S X=$S($L(X):+$O(^LAB(62.05,"B",X,0)),1:9) S:'X X=9
S ORDIALOG($$PTR("LAB URGENCY"),1)=X D
. N ORIT D EN^ORCSAVE ;Isolate ORIT before creating child orders
I '$G(ORIFN) S ORERR="1^Unable to create lab order" Q
S X=$S($D(ORSTRT("COLL")):ORSTRT("COLL"),1:$G(ORSTRT("DTW")))
D DATES^ORCSAVE2(ORIFN,X),LINK
D RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$G(NATURE)),NEW^ORMBLD(ORIFN)
S ORLAB=$G(^OR(100,ORIFN,4))_";"_$G(LRT),ORLRIFN=ORIFN ;for VBECS msg
I '$G(ORLAB) S ORERR="1^"_$$WHY^ORCSEND(ORIFN,1) Q
S ORPRINT=+$G(ORPRINT)+1,ORPRINT(ORPRINT)=ORIFN_";1"
;D STATUS^ORCSAVE2(ORIFN,5) S ORLAB="ORLAB" ;for testing
;N ORZTEST S ORZTEST=1 D NEW^ORMBLD(ORIFN) ZW ORZTEST
Q
;
TEST(X) ; -- find corresponding Lab test for VBECS item X, in #101.43
N NM,I,Y S NM=X_" - LAB",Y=0
S I=0 F S I=+$O(^ORD(101.43,"B",$E(NM,1,30),I)) Q:I<1 I $P($G(^ORD(101.43,I,0)),U,8)=NM S Y=I Q
Q Y
;
CANCEL(ORDAD,OREASON) ; -- Cancel parent order
Q:'$G(ORDAD) N NATR,NOW,ORCHLD
S ORCHLD=0 F S ORCHLD=+$O(^OR(100,ORDAD,2,ORCHLD)) Q:ORCHLD<1 D
. Q:"^1^2^13^"[(U_$P($G(^OR(100,ORCHLD,3)),U,3)_U) ;already done
. D MSG^ORMBLD(ORCHLD,"CA",OREASON)
S NATR=+$O(^ORD(100.02,"C","X",0)),NOW=+$E($$NOW^XLFDT,1,12)
S ^OR(100,ORDAD,6)=NATR_U_U_NOW_U_U_$G(OREASON),$P(^(8,1,0),U,15)=13 S:$L($G(OREASON)) ^(1)=OREASON
D STATUS^ORCSAVE2(ORDAD,13) ;cancel
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCSEND2 6411 printed Oct 16, 2024@18:29:38 Page 2
ORCSEND2 ;SLC/MKB - Release cont ;Jan 23, 2019@17:18
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**212,332,503**;Dec 17, 1997;Build 6
+2 ;
PTR(NAME) ; -- Returns ptr value of prompt in Dialog file
+1 QUIT +$ORDER(^ORD(101.41,"AB","OR GTX "_NAME,0))
+2 ;
EN ; -- Spawn child orders from ORIFN, send to VBECS [from VBEC^ORCSEND1]
+1 NEW ORPARENT,OR0,ORDIALOG,ORNP,ORDUZ,ORLOG,ORCAT,ORTS,ORDG,ORPKG,ORPRINT
+2 NEW ORESP,ORTIME,ORSTRT,ORI,ORIT,ORITX,ORFLDS,ORP,P,ORCHLD,ORLAST,X,STS,ORLAB,ORLRIFN
+3 NEW ORPITEM,ORPRBCM,ORPUNIT,ORPDTW,ORPREAS,ORPMSBS,ORPINFC,ORPURG,ORPTYPE,ORPCOLL,ORPCOMM,ORPRSLT,ORPSPEC,ORPLAB
+4 SET ORPARENT=+ORIFN
SET OR0=$GET(^OR(100,ORIFN,0))
+5 SET ORDIALOG=+$PIECE(OR0,U,5)
SET ORNP=+$PIECE(OR0,U,4)
SET ORDUZ=+$PIECE(OR0,U,6)
+6 SET ORLOG=$PIECE(OR0,U,7)
SET ORCAT=$PIECE(OR0,U,12)
SET ORTS=$PIECE(OR0,U,13)
+7 SET ORDG=+$PIECE(OR0,U,11)
SET ORPKG=$PIECE(OR0,U,14)
SET ORPRINT=0
+8 DO GETDLG1^ORCD(ORDIALOG)
DO GETORDER^ORCD(ORIFN,"ORESP")
DO GETIMES^ORCDLR1
+9 MERGE ^TMP($JOB,"ORVBDLG")=ORDIALOG
SET ORPITEM=$$PTR("ORDERABLE ITEM")
+10 SET ORPRBCM=$$PTR("RBC MODIFIERS")
SET ORPUNIT=$$PTR("AMOUNT")
+11 SET ORPDTW=$$PTR("DATE/TIME")
SET ORPREAS=$$PTR("REASON")
+12 SET ORPMSBS=$$PTR("TEXT")
SET ORPINFC=$$PTR("YES/NO")
+13 SET ORPTYPE=$$PTR("COLLECTION TYPE")
SET ORPCOLL=$$PTR("START DATE/TIME")
+14 SET ORPURG=$$PTR("URGENCY")
SET ORPCOMM=$$PTR("FREE TEXT 1")
+15 SET ORPSPEC=$$PTR("SPECIMEN STATUS")
SET ORPRSLT=$$PTR("RESULTS")
+16 ;resolve ORSTRT dates
SET ORPLAB=$$PTR("LAB ORDER")
DO START
EN1 SET ORI=0
FOR
SET ORI=$ORDER(ORESP(ORPITEM,ORI))
if ORI<1
QUIT
Begin DoDot:1
+1 ;protect ORL from calling routine
NEW ORL
SET ORL=$PIECE(OR0,U,10)
+2 SET ORIT=+$GET(ORESP(ORPITEM,ORI))
SET ORITX=$GET(^ORD(101.43,ORIT,"VB"))
+3 DO LABTST
IF $GET(ORERR)
DO CANCEL(ORPARENT,$PIECE(ORERR,U,2))
QUIT
+4 KILL ORDIALOG
MERGE ORDIALOG=^TMP($JOB,"ORVBDLG")
SET ORDIALOG(ORPITEM,1)=ORIT
+5 SET ORFLDS=$SELECT(ORITX:"ORPRBCM^ORPUNIT^ORPSPEC^ORPMSBS^ORPINFC",$PIECE(ORITX,U,2)=1:"ORPTYPE^ORPCOLL",$PIECE(ORITX,U,2)=2:"ORPMSBS^ORPINFC^ORPTYPE^ORPCOLL",1:"")_"^ORPDTW^ORPREAS^ORPURG^ORPCOMM"
+6 ;set values
FOR ORP=1:1:$LENGTH(ORFLDS,U)
SET P=$PIECE(ORFLDS,U,ORP)
if '$LENGTH(P)
QUIT
SET ORDIALOG(@P,1)=$SELECT($DATA(ORESP(@P,ORI)):ORESP(@P,ORI),P="ORPRBCM":"",1:$GET(ORESP(@P,1)))
+7 if $GET(ORLRIFN)
SET ORDIALOG(ORPLAB,1)=ORLRIFN
+8 KILL ORIFN,ORIT
DO EN^ORCSAVE
+9 IF '$GET(ORIFN)
SET ORERR="1^Unable to create order"
QUIT
+10 SET X=ORSTRT($SELECT(ORITX:"DTW",1:"COLL"))
DO DATES^ORCSAVE2(ORIFN,X)
+11 DO RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$GET(NATURE))
DO LINK
+12 DO NW^ORMBLDVB(ORIFN)
End DoDot:1
if $GET(ORERR)
QUIT
+13 if $GET(ORCHLD)
SET ^OR(100,ORPARENT,2,0)="^100.002PA^"_ORLAST_U_ORCHLD
+14 DO RELEASE^ORCSAVE2(ORPARENT,1,ORNOW,DUZ,$GET(NATURE))
+15 ;D STATUS^ORCSAVE2(ORPARENT,5) ;testing
+16 SET ORIFN=ORPARENT
SET ORQUIT=1
SET STS=$PIECE(^OR(100,ORIFN,3),U,3)
EN2 ;successful
IF STS'=11
IF STS'=13
Begin DoDot:1
+1 DO RESULTS^ORMBLDVB(ORPARENT)
+2 if '$ORDER(ORPRINT(0))
QUIT
NEW PAT,LOC,NATR
+3 SET PAT=$PIECE(OR0,U,2)
SET LOC=$SELECT($GET(ORL):ORL,1:$PIECE(OR0,U,10))
+4 SET NATR=$$WORK^ORCSIGN($GET(NATURE))
+5 ;labels/req's
DO PRINT^ORPR02(PAT,.ORPRINT,,LOC,"0^1^1^1^"_NATR)
End DoDot:1
+6 IF $$UNRL(ORPARENT)
SET ORERR="1^Unable to release order due to an HL7 network error: queued for delivery to VBECS"
+7 IF STS=13
SET ORERR="1^This order was rejected by VBECS and will NOT be acted upon: see the Order Details for more information and contact the Blood Bank for assistance!"
+8 KILL ^TMP($JOB,"ORVBDLG"),^TMP($JOB,"ORLRDLG")
+9 QUIT
+10 ;
UNRL(DAD) ; -- ck for any unreleased child orders
+1 NEW Y,I,STS
SET Y=0
+2 SET I=0
FOR
SET I=+$ORDER(^OR(100,+$GET(DAD),2,I))
if I<1
QUIT
Begin DoDot:1
+3 SET STS=$PIECE($GET(^OR(100,I,3)),U,3)
+4 IF STS=10!(STS=11)
SET Y=1
QUIT
End DoDot:1
if Y
QUIT
+5 QUIT Y
+6 ;
START ; -- Define ORSTRT(), set Start Date in ORPARENT
+1 NEW X,Y,%DT,STRT
SET ORSTRT("COLL")=""
SET ORSTRT("DTW")=""
SET %DT="TX"
SET STRT=""
+2 SET X=$GET(ORESP(ORPDTW,1))
IF $LENGTH(X)
DO ^%DT
if Y>0
SET ORSTRT("DTW")=Y
SET STRT=Y
+3 SET X=$GET(ORESP(ORPCOLL,1))
IF $LENGTH(X)
Begin DoDot:1
+4 ;return X
if X="AM"
DO AM^ORCSAVE2
if X="NEXT"
DO NEXT^ORCSAVE2
+5 DO ^%DT
if Y>0
SET ORSTRT("COLL")=Y
SET STRT=Y
End DoDot:1
+6 IF '$PIECE(OR0,U,8)
DO DATES^ORCSAVE2(+ORIFN,STRT)
+7 QUIT
+8 ;
LINK ; -- set up ORPARENT/ORIFN links, ORLAST in ORCHLD()
+1 ; Uses ORVP,ORLOG in xref
+2 SET ORCHLD=+$GET(ORCHLD)+1
SET ^OR(100,ORPARENT,2,ORIFN,0)=ORIFN
SET ORLAST=ORIFN
+3 SET $PIECE(^OR(100,ORIFN,3),U,8,9)="1^"_ORPARENT
+4 ;signature on parent only
SET $PIECE(^OR(100,ORIFN,8,1,0),U,4)=8
KILL ^OR(100,"AS",ORVP,9999999-ORLOG,ORIFN,1)
+5 QUIT
+6 ;
LABTST ; -- Create Lab order for VBECS blood component or test
+1 ; Expects var's from above, Returns ORLAB & ORLRIFN
+2 NEW ORDIALOG,ORDG,ORPKG,ORIFN,X,P,LRT
KILL ORLAB,ORLRIFN
+3 IF $GET(^TMP($JOB,"ORLRDLG"))
MERGE ORDIALOG=^TMP($JOB,"ORLRDLG")
+4 ;build for now, later reuse
IF '$TEST
Begin DoDot:1
+5 SET ORDIALOG=+$ORDER(^ORD(101.41,"AB","LR OTHER LAB TESTS",0))
+6 DO GETDLG1^ORCD(ORDIALOG)
MERGE ^TMP($JOB,"ORLRDLG")=ORDIALOG
End DoDot:1
+7 SET ORDG=+$ORDER(^ORD(100.98,"B","BB",0))
SET X=$PIECE($GET(^ORD(101.43,ORIT,0)),U,8)
+8 SET X=+$$TEST(X)
IF X<1
SET ORERR="1^Missing or invalid Lab workload test"
QUIT
+9 SET ORDIALOG(ORPITEM,1)=X
SET LRT=+$PIECE($GET(^ORD(101.43,X,0)),U,2)
+10 SET ORDIALOG(ORPTYPE,1)=$SELECT($DATA(ORESP(ORPTYPE,1)):ORESP(ORPTYPE,1),1:"SP")
+11 SET ORDIALOG(ORPCOLL,1)=$SELECT($DATA(ORESP(ORPCOLL,1)):ORESP(ORPCOLL,1),1:$GET(ORESP(ORPDTW,1)))
LT1 ; VALIDATE??
+1 ;default/unique sample
SET X=+$ORDER(^LAB(60,LRT,3,0))
SET X=+$GET(^(X,0))
+2 SET ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=X
+3 if 'ORITX
SET ORDIALOG($$PTR("SPECIMEN"),1)=$PIECE($GET(^LAB(62,X,0)),U,2)
+4 SET X=+$GET(ORESP(ORPURG,1))
SET X=$PIECE($GET(^ORD(101.42,X,0)),U)
+5 SET X=$SELECT($LENGTH(X):+$ORDER(^LAB(62.05,"B",X,0)),1:9)
if 'X
SET X=9
+6 SET ORDIALOG($$PTR("LAB URGENCY"),1)=X
Begin DoDot:1
+7 ;Isolate ORIT before creating child orders
NEW ORIT
DO EN^ORCSAVE
End DoDot:1
+8 IF '$GET(ORIFN)
SET ORERR="1^Unable to create lab order"
QUIT
+9 SET X=$SELECT($DATA(ORSTRT("COLL")):ORSTRT("COLL"),1:$GET(ORSTRT("DTW")))
+10 DO DATES^ORCSAVE2(ORIFN,X)
DO LINK
+11 DO RELEASE^ORCSAVE2(ORIFN,1,ORNOW,DUZ,$GET(NATURE))
DO NEW^ORMBLD(ORIFN)
+12 ;for VBECS msg
SET ORLAB=$GET(^OR(100,ORIFN,4))_";"_$GET(LRT)
SET ORLRIFN=ORIFN
+13 IF '$GET(ORLAB)
SET ORERR="1^"_$$WHY^ORCSEND(ORIFN,1)
QUIT
+14 SET ORPRINT=+$GET(ORPRINT)+1
SET ORPRINT(ORPRINT)=ORIFN_";1"
+15 ;D STATUS^ORCSAVE2(ORIFN,5) S ORLAB="ORLAB" ;for testing
+16 ;N ORZTEST S ORZTEST=1 D NEW^ORMBLD(ORIFN) ZW ORZTEST
+17 QUIT
+18 ;
TEST(X) ; -- find corresponding Lab test for VBECS item X, in #101.43
+1 NEW NM,I,Y
SET NM=X_" - LAB"
SET Y=0
+2 SET I=0
FOR
SET I=+$ORDER(^ORD(101.43,"B",$EXTRACT(NM,1,30),I))
if I<1
QUIT
IF $PIECE($GET(^ORD(101.43,I,0)),U,8)=NM
SET Y=I
QUIT
+3 QUIT Y
+4 ;
CANCEL(ORDAD,OREASON) ; -- Cancel parent order
+1 if '$GET(ORDAD)
QUIT
NEW NATR,NOW,ORCHLD
+2 SET ORCHLD=0
FOR
SET ORCHLD=+$ORDER(^OR(100,ORDAD,2,ORCHLD))
if ORCHLD<1
QUIT
Begin DoDot:1
+3 ;already done
if "^1^2^13^"[(U_$PIECE($GET(^OR(100,ORCHLD,3)),U,3)_U)
QUIT
+4 DO MSG^ORMBLD(ORCHLD,"CA",OREASON)
End DoDot:1
+5 SET NATR=+$ORDER(^ORD(100.02,"C","X",0))
SET NOW=+$EXTRACT($$NOW^XLFDT,1,12)
+6 SET ^OR(100,ORDAD,6)=NATR_U_U_NOW_U_U_$GET(OREASON)
SET $PIECE(^(8,1,0),U,15)=13
if $LENGTH($GET(OREASON))
SET ^(1)=OREASON
+7 ;cancel
DO STATUS^ORCSAVE2(ORDAD,13)
+8 QUIT
