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