ORMLR ; SLC/MKB - Process Lab ORM msgs ;11:59 AM 26 Jul 2000
;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,92,153,174,195,243,315**;Dec 17, 1997;Build 0
EN ; -- entry point for LR messages
I '$L($T(@ORDCNTRL)) Q ;S ORERR="Invalid order control code" Q
I ORDCNTRL'="SN",ORDCNTRL'="ZC",ORDCNTRL'="ZP" D Q:$L($G(ORERR))
. I 'ORIFN!('$D(^OR(100,+ORIFN,0))) S ORERR="Invalid OE/RR order number" Q
. S ORDUZ=DUZ,ORLOG=+$E($$NOW^XLFDT,1,12)
S OREASON=$$REASON I 'ORNATR,OREASON S ORNATR=+$P($G(^ORD(100.03,+OREASON,0)),U,7)
D @ORDCNTRL
Q
;
STATUS(X) ; -- Returns Order Status for HL7 code X
N Y S Y=$S(X="DC":1,X="CM":2,X="IP":5,X="SC":6,X="ZS":9,X="CA":13,1:"")
Q Y
;
OK ; -- Order accepted, LR order # assigned [ack]
S ^OR(100,+ORIFN,4)=PKGIFN ; LR identifier
D STATUS^ORCSAVE2(+ORIFN,5) ; pending
Q
;
ZC ; -- Convert existing 2.5 orders to 3.0 format
S ORNATR="" I 'ORIFN!('$D(^OR(100,+ORIFN,0))) D Q ;create
. K ORIFN D SN Q:'$G(ORIFN) S ORDCNTRL="SN"
. I ORSTOP,ORSTOP<$$NOW^XLFDT S $P(^OR(100,+ORIFN,3),U)=ORSTOP
N ORDIALOG,I,X,OBR,NTE S ORIFN=+ORIFN
S I=+ORC F S I=$O(@ORMSG@(I)) Q:'I S SEG=$E(@ORMSG@(I),1,3) Q:SEG="ORC" Q:SEG="MSH" I SEG="OBR" S OBR=I Q
I '$G(OBR) S ORERR="Missing OBR segment" Q
S ORDIALOG=+$O(^ORD(101.41,"AB","LR OTHER LAB TESTS",0))
D GETDLG1^ORCD(ORDIALOG)
S X=$$FIND^ORM(OBR,5),X=$$ORDITEM^ORM(X) I 'X S ORERR="Invalid test" Q
S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=X,X=$$FIND^ORM(OBR,16)
S ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4)
S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):+$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4))
S X=$$FIND^ORM(OBR,28),ORDIALOG($$PTR("LAB URGENCY"),1)=+$P($P(X,U,6),";",2)
S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP")
ZC1 S NTE=$O(@ORMSG@(OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D
. N LCNT,WP S WP=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J)
. S LCNT=1,^TMP("ORWORD",$J,WP,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4)
. S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORWORD",$J,WP,1,LCNT,0)=@ORMSG@(NTE,I)
. S ^TMP("ORWORD",$J,WP,1,0)="^^"_LCNT_U_LCNT_U_DT_U
. S ORDIALOG(WP,1)="^TMP(""ORWORD"","_$J_","_WP_",1)"
S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
S ^OR(100,ORIFN,4)=PKGIFN,$P(^(0),U,5)=+ORDIALOG_";ORD(101.41,"
D RESPONSE^ORCSAVE ; save ORDIALOG() into ^(4.5)
K ^TMP("ORWORD",$J)
Q
;
SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
N X,ORDIALOG,ORDG,OBR,NTE,CMMT,OI,LCNT,I,ORSTS,LRSUB,ORNEW,ORP
I ORDUZ,'$D(^VA(200,+ORDUZ,0)) S ORERR="Invalid entering person" Q
; I '$G(ORL) S ORERR="Missing or invalid patient location" Q
;S LRSUB=$E($P($P(@ORMSG@(+ORC),"|",4),U,2),3,4),ORDG=$$DGRP(LRSUB)
S ORDIALOG="LR OTHER LAB TESTS" ; $S(LRSUB="AP",LRSUB="BB")
S ORDIALOG=$O(^ORD(101.41,"AB",ORDIALOG,0)) D GETDLG1^ORCD(ORDIALOG)
S ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
S CMMT=$$PTR("WORD PROCESSING 1") K ^TMP("ORWORD",$J)
SN1 S OBR=$O(@ORMSG@(+ORC)) I 'OBR!($E($G(@ORMSG@(OBR)),1,3)'="OBR") S ORERR="Missing OBR segment" Q
S X=$$FIND^ORM(OBR,5),OI=$$ORDITEM^ORM(X) I 'OI S ORERR="Invalid test" Q
S LRSUB=$P(^ORD(101.43,OI,"LR"),U,6),ORDG=$$DGRP(LRSUB)
S ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
I LRSUB="BB" S ORDIALOG($$PTR("QUANTITY"),1)=+ORQT G SN2
S X=$$FIND^ORM(OBR,16),ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$P(X,";",4)
S ORDIALOG($$PTR("SPECIMEN"),1)=$S($L($P(X,";")):$O(^LAB(61,"C",$P(X,";"),0)),1:+$P(X,U,4))
S X=+$P($P($$FIND^ORM(OBR,28),U,6),";",2),ORDIALOG($$PTR("LAB URGENCY"),1)=$S(X:X,1:9)
S X=$$FIND^ORM(OBR,12),ORDIALOG($$PTR("COLLECTION TYPE"),1)=$S(X="L":"LC",X="O":"WC",X=2:"I",1:"SP")
SN2 S NTE=$O(@ORMSG@(+OBR)) I NTE,$E(@ORMSG@(NTE),1,3)="NTE" D
. S LCNT=1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=$P(@ORMSG@(NTE),"|",4)
. I $O(@ORMSG@(NTE,0)) S I=0 F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S LCNT=LCNT+1,^TMP("ORWORD",$J,CMMT,1,LCNT,0)=@ORMSG@(NTE,I)
. S ^TMP("ORWORD",$J,CMMT,1,0)="^^"_LCNT_U_LCNT_U_DT_U,ORDIALOG(CMMT,1)="^TMP(""ORWORD"",$J,"_CMMT_",1)"
SNQ D EN^ORCSAVE K ^TMP("ORWORD",$J)
I '$G(ORIFN) S ORERR="Cannot create new order" Q
;Save DG1 and ZCL segments of HL7 message from backdoor orders
D BDOSTR^ORWDBA3
D RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR),SIGSTS^ORCSAVE2(ORIFN,1)
D:ORSTOP DATES^ORCSAVE2(ORIFN,,ORSTOP) ;Start date in order itself
S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(ORIFN,ORSTS)
I ORDCNTRL="SN",$G(ORL) S ORP(1)=ORIFN_";1^1" D PRINTS^ORWD1(.ORP,+ORL)
S ^OR(100,ORIFN,4)=PKGIFN
Q
;
PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41
Q $O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
;
DGRP(DG) ; -- Returns Display Group ptr based on Lab section
N Y S:'$L($G(DG)) DG="CH" S Y=$O(^ORD(100.98,"B",DG,0))
S:'Y Y=$O(^ORD(100.98,"B","LAB",0))
Q Y
;
XX ; -- Changed: NOT IN USE
D XX^ORMLR1
Q
;
XR ; -- Changed [ack]: NOT IN USE
N ORIG
S ^OR(100,+ORIFN,4)=PKGIFN,ORIG=$P(^(3),U,5)
D:ORIG STATUS^ORCSAVE2(ORIG,12)
D STATUS^ORCSAVE2(+ORIFN,5) ; pending
Q
;
ZP ; -- Purged
Q:'ORIFN Q:'$D(^OR(100,+ORIFN,0))
S $P(^OR(100,+ORIFN,4),";",1,3)=";;" I "^5^6^"[(U_$P($G(^(3)),U,3)_U) D STATUS^ORCSAVE2(+ORIFN,$S($P(^(4),";",5):2,1:14)) ; Remove pkg reference, sts=lapsed if still active
Q
;
ZR ; -- Purged as requested [ack]
D DELETE^ORCSAVE2(+ORIFN)
Q
;
ZU ; -- Unable to purge [ack]
S $P(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT ; update Last Activity
Q
;
SC ; -- Status changed (collected)
N ORSTS D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,1,1)=$P(OREASON,U,2)
Q
;
RE ; -- Completed, w/results
N ORSTS,ORX,I,SEG,DONE,X,Y,ORABN,ORFIND,LRSA,LRSB
S ORSTS=$$STATUS(ORDSTS) D:ORSTS STATUS^ORCSAVE2(+ORIFN,ORSTS)
S ^OR(100,+ORIFN,4)=PKGIFN,ORX="" D ;get Results D/T [from OBR]
. N OBR S OBR=+$O(@ORMSG@(+ORC)),X=""
. I OBR,$E($G(@ORMSG@(OBR)),1,3)="OBR" S X=$P(@ORMSG@(OBR),"|",23)
. S X=+$E($$NOW^XLFDT,1,12)
. S $P(^OR(100,+ORIFN,7),U)=X,^OR(100,"ARS",ORVP,9999999-X,+ORIFN)=""
D RR^LR7OR1(DFN,PKGIFN)
S ORABN="",ORFIND=""
I $D(^TMP("LRRR",$J)) D
. N IDT,DNAM,ORSLT
. S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,"CH",IDT)) Q:'IDT D
.. S DNAM=0 F S DNAM=$O(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM)) Q:'DNAM D
... S ORSLT=$G(^TMP("LRRR",$J,DFN,"CH",IDT,DNAM))
... I '$L($P(ORSLT,U,3)) Q
... S ORABN=1,ORFIND=$S($L(ORFIND):(ORFIND_", "),1:"")
... S ORFIND=ORFIND_$P(ORSLT,U,15)_"="_$P(ORSLT,U,2)
. Q
K ^TMP("LRRR",$J),^TMP("LRX",$J)
S $P(^OR(100,+ORIFN,7),U,2,3)=ORABN_U_ORFIND
S:'$G(ORNP) ORNP=+$P($G(^OR(100,+ORIFN,0)),U,4)
I $L($T(ADD^ORRCACK)) D ADD^ORRCACK(+ORIFN,ORNP) ;Ack stub for prov
Q
;
OC ; -- Cancelled
G:ORTYPE="ORR" UA S:ORNATR=+$O(^ORD(100.02,"C","A",0)) ORDUZ=""
S ^OR(100,+ORIFN,6)=ORNATR_U_ORDUZ_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80)
D UPDATE(1,"DC")
Q
;
CR ; -- Cancelled [ack]
D STATUS^ORCSAVE2(+ORIFN,1)
Q
;
UA ; -- Unable to accept [ack]
UX ; -- Unable to change [ack]: NOT IN USE
S:'ORNATR ORNATR=$O(^ORD(100.02,"C","X",0)) ;rejected
S ^OR(100,+ORIFN,6)=ORNATR_U_U_ORLOG_U_$P(OREASON,U)_U_$E($P(OREASON,U,2),1,80)
D STATUS^ORCSAVE2(+ORIFN,13)
UC ; -- Unable to cancel [ack]
DE ; -- Data Error [ack]
N DA S DA=$P(ORIFN,";",2) Q:'DA
S $P(^OR(100,+ORIFN,8,DA,0),U,15)=13 ;request rejected
S:$L($P(OREASON,U,2)) ^OR(100,+ORIFN,8,DA,1)=$E($P(OREASON,U,2),1,240)
Q
;
UPDATE(ORSTS,ORACT) ; -- continue processing
N DA,ORX,ORCMMT,ORP
D DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
D:$G(ORSTS) STATUS^ORCSAVE2(+ORIFN,ORSTS)
S ORCMMT=$E($P(OREASON,U,2),1,240),ORX=$$CREATE^ORX1(ORNATR) D:ORX
. S DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,ORCMMT,ORLOG,ORDUZ)
. I DA'>0 S ORERR="Cannot create new order action" Q
. D RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR)
. D SIGSTS^ORCSAVE2(+ORIFN,DA)
. I $G(ORL) S ORP(1)=+ORIFN_";"_DA_"^1" D PRINTS^ORWD1(.ORP,+ORL)
. S $P(^OR(100,+ORIFN,3),U,7)=DA
I '$$ACTV^ORX1(ORNATR) S $P(^OR(100,+ORIFN,3),U,7)=0
D:ORACT="DC" CANCEL^ORCSEND(+ORIFN)
Q
;
REASON() ; -- Get reason from OREASON or NTE segments
N NTE,CMMT,X,Y,I,L
S NTE=+$O(@ORMSG@(+ORC)),CMMT=$P(OREASON,U,4,5)
G:'NTE RQ G:$E(@ORMSG@(NTE),1,3)'="NTE" RQ ; no add'l comments
S Y=$P(@ORMSG@(NTE),"|",4),I=0
F S I=$O(@ORMSG@(NTE,I)) Q:I'>0 S X=$G(@ORMSG@(NTE,I)),L=$L(Y)+1+$L(X) S:L'>240 Y=Y_" "_X I L>240 S Y=Y_" "_$E(X,1,239-$L(Y)) Q
S $P(CMMT,U,2)=Y
RQ Q CMMT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMLR 8501 printed Sep 23, 2025@20:08:20 Page 2
ORMLR ; SLC/MKB - Process Lab ORM msgs ;11:59 AM 26 Jul 2000
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,92,153,174,195,243,315**;Dec 17, 1997;Build 0
EN ; -- entry point for LR messages
+1 ;S ORERR="Invalid order control code" Q
IF '$LENGTH($TEXT(@ORDCNTRL))
QUIT
+2 IF ORDCNTRL'="SN"
IF ORDCNTRL'="ZC"
IF ORDCNTRL'="ZP"
Begin DoDot:1
+3 IF 'ORIFN!('$DATA(^OR(100,+ORIFN,0)))
SET ORERR="Invalid OE/RR order number"
QUIT
+4 SET ORDUZ=DUZ
SET ORLOG=+$EXTRACT($$NOW^XLFDT,1,12)
End DoDot:1
if $LENGTH($GET(ORERR))
QUIT
+5 SET OREASON=$$REASON
IF 'ORNATR
IF OREASON
SET ORNATR=+$PIECE($GET(^ORD(100.03,+OREASON,0)),U,7)
+6 DO @ORDCNTRL
+7 QUIT
+8 ;
STATUS(X) ; -- Returns Order Status for HL7 code X
+1 NEW Y
SET Y=$SELECT(X="DC":1,X="CM":2,X="IP":5,X="SC":6,X="ZS":9,X="CA":13,1:"")
+2 QUIT Y
+3 ;
OK ; -- Order accepted, LR order # assigned [ack]
+1 ; LR identifier
SET ^OR(100,+ORIFN,4)=PKGIFN
+2 ; pending
DO STATUS^ORCSAVE2(+ORIFN,5)
+3 QUIT
+4 ;
ZC ; -- Convert existing 2.5 orders to 3.0 format
+1 ;create
SET ORNATR=""
IF 'ORIFN!('$DATA(^OR(100,+ORIFN,0)))
Begin DoDot:1
+2 KILL ORIFN
DO SN
if '$GET(ORIFN)
QUIT
SET ORDCNTRL="SN"
+3 IF ORSTOP
IF ORSTOP<$$NOW^XLFDT
SET $PIECE(^OR(100,+ORIFN,3),U)=ORSTOP
End DoDot:1
QUIT
+4 NEW ORDIALOG,I,X,OBR,NTE
SET ORIFN=+ORIFN
+5 SET I=+ORC
FOR
SET I=$ORDER(@ORMSG@(I))
if 'I
QUIT
SET SEG=$EXTRACT(@ORMSG@(I),1,3)
if SEG="ORC"
QUIT
if SEG="MSH"
QUIT
IF SEG="OBR"
SET OBR=I
QUIT
+6 IF '$GET(OBR)
SET ORERR="Missing OBR segment"
QUIT
+7 SET ORDIALOG=+$ORDER(^ORD(101.41,"AB","LR OTHER LAB TESTS",0))
+8 DO GETDLG1^ORCD(ORDIALOG)
+9 SET X=$$FIND^ORM(OBR,5)
SET X=$$ORDITEM^ORM(X)
IF 'X
SET ORERR="Invalid test"
QUIT
+10 SET ORDIALOG($$PTR("ORDERABLE ITEM"),1)=X
SET X=$$FIND^ORM(OBR,16)
+11 SET ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$PIECE(X,";",4)
+12 SET ORDIALOG($$PTR("SPECIMEN"),1)=$SELECT($LENGTH($PIECE(X,";")):+$ORDER(^LAB(61,"C",$PIECE(X,";"),0)),1:+$PIECE(X,U,4))
+13 SET X=$$FIND^ORM(OBR,28)
SET ORDIALOG($$PTR("LAB URGENCY"),1)=+$PIECE($PIECE(X,U,6),";",2)
+14 SET X=$$FIND^ORM(OBR,12)
SET ORDIALOG($$PTR("COLLECTION TYPE"),1)=$SELECT(X="L":"LC",X="O":"WC",X=2:"I",1:"SP")
ZC1 SET NTE=$ORDER(@ORMSG@(OBR))
IF NTE
IF $EXTRACT(@ORMSG@(NTE),1,3)="NTE"
Begin DoDot:1
+1 NEW LCNT,WP
SET WP=$$PTR("WORD PROCESSING 1")
KILL ^TMP("ORWORD",$JOB)
+2 SET LCNT=1
SET ^TMP("ORWORD",$JOB,WP,1,LCNT,0)=$PIECE(@ORMSG@(NTE),"|",4)
+3 SET I=0
FOR
SET I=$ORDER(@ORMSG@(NTE,I))
if I'>0
QUIT
SET LCNT=LCNT+1
SET ^TMP("ORWORD",$JOB,WP,1,LCNT,0)=@ORMSG@(NTE,I)
+4 SET ^TMP("ORWORD",$JOB,WP,1,0)="^^"_LCNT_U_LCNT_U_DT_U
+5 SET ORDIALOG(WP,1)="^TMP(""ORWORD"","_$JOB_","_WP_",1)"
End DoDot:1
+6 SET ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
+7 SET ^OR(100,ORIFN,4)=PKGIFN
SET $PIECE(^(0),U,5)=+ORDIALOG_";ORD(101.41,"
+8 ; save ORDIALOG() into ^(4.5)
DO RESPONSE^ORCSAVE
+9 KILL ^TMP("ORWORD",$JOB)
+10 QUIT
+11 ;
SN ; -- New backdoor order: return NA msg w/ORIFN, or DE msg
+1 NEW X,ORDIALOG,ORDG,OBR,NTE,CMMT,OI,LCNT,I,ORSTS,LRSUB,ORNEW,ORP
+2 IF ORDUZ
IF '$DATA(^VA(200,+ORDUZ,0))
SET ORERR="Invalid entering person"
QUIT
+3 ; I '$G(ORL) S ORERR="Missing or invalid patient location" Q
+4 ;S LRSUB=$E($P($P(@ORMSG@(+ORC),"|",4),U,2),3,4),ORDG=$$DGRP(LRSUB)
+5 ; $S(LRSUB="AP",LRSUB="BB")
SET ORDIALOG="LR OTHER LAB TESTS"
+6 SET ORDIALOG=$ORDER(^ORD(101.41,"AB",ORDIALOG,0))
DO GETDLG1^ORCD(ORDIALOG)
+7 SET ORDIALOG($$PTR("START DATE/TIME"),1)=ORSTRT
+8 SET CMMT=$$PTR("WORD PROCESSING 1")
KILL ^TMP("ORWORD",$JOB)
SN1 SET OBR=$ORDER(@ORMSG@(+ORC))
IF 'OBR!($EXTRACT($GET(@ORMSG@(OBR)),1,3)'="OBR")
SET ORERR="Missing OBR segment"
QUIT
+1 SET X=$$FIND^ORM(OBR,5)
SET OI=$$ORDITEM^ORM(X)
IF 'OI
SET ORERR="Invalid test"
QUIT
+2 SET LRSUB=$PIECE(^ORD(101.43,OI,"LR"),U,6)
SET ORDG=$$DGRP(LRSUB)
+3 SET ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
+4 IF LRSUB="BB"
SET ORDIALOG($$PTR("QUANTITY"),1)=+ORQT
GOTO SN2
+5 SET X=$$FIND^ORM(OBR,16)
SET ORDIALOG($$PTR("COLLECTION SAMPLE"),1)=$PIECE(X,";",4)
+6 SET ORDIALOG($$PTR("SPECIMEN"),1)=$SELECT($LENGTH($PIECE(X,";")):$ORDER(^LAB(61,"C",$PIECE(X,";"),0)),1:+$PIECE(X,U,4))
+7 SET X=+$PIECE($PIECE($$FIND^ORM(OBR,28),U,6),";",2)
SET ORDIALOG($$PTR("LAB URGENCY"),1)=$SELECT(X:X,1:9)
+8 SET X=$$FIND^ORM(OBR,12)
SET ORDIALOG($$PTR("COLLECTION TYPE"),1)=$SELECT(X="L":"LC",X="O":"WC",X=2:"I",1:"SP")
SN2 SET NTE=$ORDER(@ORMSG@(+OBR))
IF NTE
IF $EXTRACT(@ORMSG@(NTE),1,3)="NTE"
Begin DoDot:1
+1 SET LCNT=1
SET ^TMP("ORWORD",$JOB,CMMT,1,LCNT,0)=$PIECE(@ORMSG@(NTE),"|",4)
+2 IF $ORDER(@ORMSG@(NTE,0))
SET I=0
FOR
SET I=$ORDER(@ORMSG@(NTE,I))
if I'>0
QUIT
SET LCNT=LCNT+1
SET ^TMP("ORWORD",$JOB,CMMT,1,LCNT,0)=@ORMSG@(NTE,I)
+3 SET ^TMP("ORWORD",$JOB,CMMT,1,0)="^^"_LCNT_U_LCNT_U_DT_U
SET ORDIALOG(CMMT,1)="^TMP(""ORWORD"",$J,"_CMMT_",1)"
End DoDot:1
SNQ DO EN^ORCSAVE
KILL ^TMP("ORWORD",$JOB)
+1 IF '$GET(ORIFN)
SET ORERR="Cannot create new order"
QUIT
+2 ;Save DG1 and ZCL segments of HL7 message from backdoor orders
+3 DO BDOSTR^ORWDBA3
+4 DO RELEASE^ORCSAVE2(ORIFN,1,ORLOG,ORDUZ,ORNATR)
DO SIGSTS^ORCSAVE2(ORIFN,1)
+5 ;Start date in order itself
if ORSTOP
DO DATES^ORCSAVE2(ORIFN,,ORSTOP)
+6 SET ORSTS=$$STATUS(ORDSTS)
if ORSTS
DO STATUS^ORCSAVE2(ORIFN,ORSTS)
+7 IF ORDCNTRL="SN"
IF $GET(ORL)
SET ORP(1)=ORIFN_";1^1"
DO PRINTS^ORWD1(.ORP,+ORL)
+8 SET ^OR(100,ORIFN,4)=PKGIFN
+9 QUIT
+10 ;
PTR(NAME) ; -- Returns ien of prompt NAME in Order Dialog file #101.41
+1 QUIT $ORDER(^ORD(101.41,"AB",$EXTRACT("OR GTX "_NAME,1,63),0))
+2 ;
DGRP(DG) ; -- Returns Display Group ptr based on Lab section
+1 NEW Y
if '$LENGTH($GET(DG))
SET DG="CH"
SET Y=$ORDER(^ORD(100.98,"B",DG,0))
+2 if 'Y
SET Y=$ORDER(^ORD(100.98,"B","LAB",0))
+3 QUIT Y
+4 ;
XX ; -- Changed: NOT IN USE
+1 DO XX^ORMLR1
+2 QUIT
+3 ;
XR ; -- Changed [ack]: NOT IN USE
+1 NEW ORIG
+2 SET ^OR(100,+ORIFN,4)=PKGIFN
SET ORIG=$PIECE(^(3),U,5)
+3 if ORIG
DO STATUS^ORCSAVE2(ORIG,12)
+4 ; pending
DO STATUS^ORCSAVE2(+ORIFN,5)
+5 QUIT
+6 ;
ZP ; -- Purged
+1 if 'ORIFN
QUIT
if '$DATA(^OR(100,+ORIFN,0))
QUIT
+2 ; Remove pkg reference, sts=lapsed if still active
SET $PIECE(^OR(100,+ORIFN,4),";",1,3)=";;"
IF "^5^6^"[(U_$PIECE($GET(^(3)),U,3)_U)
DO STATUS^ORCSAVE2(+ORIFN,$SELECT($PIECE(^(4),";",5):2,1:14))
+3 QUIT
+4 ;
ZR ; -- Purged as requested [ack]
+1 DO DELETE^ORCSAVE2(+ORIFN)
+2 QUIT
+3 ;
ZU ; -- Unable to purge [ack]
+1 ; update Last Activity
SET $PIECE(^OR(100,+ORIFN,3),U)=$$NOW^XLFDT
+2 QUIT
+3 ;
SC ; -- Status changed (collected)
+1 NEW ORSTS
DO DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
+2 SET ORSTS=$$STATUS(ORDSTS)
if ORSTS
DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
+3 if $LENGTH($PIECE(OREASON,U,2))
SET ^OR(100,+ORIFN,8,1,1)=$PIECE(OREASON,U,2)
+4 QUIT
+5 ;
RE ; -- Completed, w/results
+1 NEW ORSTS,ORX,I,SEG,DONE,X,Y,ORABN,ORFIND,LRSA,LRSB
+2 SET ORSTS=$$STATUS(ORDSTS)
if ORSTS
DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
+3 ;get Results D/T [from OBR]
SET ^OR(100,+ORIFN,4)=PKGIFN
SET ORX=""
Begin DoDot:1
+4 NEW OBR
SET OBR=+$ORDER(@ORMSG@(+ORC))
SET X=""
+5 IF OBR
IF $EXTRACT($GET(@ORMSG@(OBR)),1,3)="OBR"
SET X=$PIECE(@ORMSG@(OBR),"|",23)
+6 SET X=+$EXTRACT($$NOW^XLFDT,1,12)
+7 SET $PIECE(^OR(100,+ORIFN,7),U)=X
SET ^OR(100,"ARS",ORVP,9999999-X,+ORIFN)=""
End DoDot:1
+8 DO RR^LR7OR1(DFN,PKGIFN)
+9 SET ORABN=""
SET ORFIND=""
+10 IF $DATA(^TMP("LRRR",$JOB))
Begin DoDot:1
+11 NEW IDT,DNAM,ORSLT
+12 SET IDT=0
FOR
SET IDT=$ORDER(^TMP("LRRR",$JOB,DFN,"CH",IDT))
if 'IDT
QUIT
Begin DoDot:2
+13 SET DNAM=0
FOR
SET DNAM=$ORDER(^TMP("LRRR",$JOB,DFN,"CH",IDT,DNAM))
if 'DNAM
QUIT
Begin DoDot:3
+14 SET ORSLT=$GET(^TMP("LRRR",$JOB,DFN,"CH",IDT,DNAM))
+15 IF '$LENGTH($PIECE(ORSLT,U,3))
QUIT
+16 SET ORABN=1
SET ORFIND=$SELECT($LENGTH(ORFIND):(ORFIND_", "),1:"")
+17 SET ORFIND=ORFIND_$PIECE(ORSLT,U,15)_"="_$PIECE(ORSLT,U,2)
End DoDot:3
End DoDot:2
+18 QUIT
End DoDot:1
+19 KILL ^TMP("LRRR",$JOB),^TMP("LRX",$JOB)
+20 SET $PIECE(^OR(100,+ORIFN,7),U,2,3)=ORABN_U_ORFIND
+21 if '$GET(ORNP)
SET ORNP=+$PIECE($GET(^OR(100,+ORIFN,0)),U,4)
+22 ;Ack stub for prov
IF $LENGTH($TEXT(ADD^ORRCACK))
DO ADD^ORRCACK(+ORIFN,ORNP)
+23 QUIT
+24 ;
OC ; -- Cancelled
+1 if ORTYPE="ORR"
GOTO UA
if ORNATR=+$ORDER(^ORD(100.02,"C","A",0))
SET ORDUZ=""
+2 SET ^OR(100,+ORIFN,6)=ORNATR_U_ORDUZ_U_ORLOG_U_$PIECE(OREASON,U)_U_$EXTRACT($PIECE(OREASON,U,2),1,80)
+3 DO UPDATE(1,"DC")
+4 QUIT
+5 ;
CR ; -- Cancelled [ack]
+1 DO STATUS^ORCSAVE2(+ORIFN,1)
+2 QUIT
+3 ;
UA ; -- Unable to accept [ack]
UX ; -- Unable to change [ack]: NOT IN USE
+1 ;rejected
if 'ORNATR
SET ORNATR=$ORDER(^ORD(100.02,"C","X",0))
+2 SET ^OR(100,+ORIFN,6)=ORNATR_U_U_ORLOG_U_$PIECE(OREASON,U)_U_$EXTRACT($PIECE(OREASON,U,2),1,80)
+3 DO STATUS^ORCSAVE2(+ORIFN,13)
UC ; -- Unable to cancel [ack]
DE ; -- Data Error [ack]
+1 NEW DA
SET DA=$PIECE(ORIFN,";",2)
if 'DA
QUIT
+2 ;request rejected
SET $PIECE(^OR(100,+ORIFN,8,DA,0),U,15)=13
+3 if $LENGTH($PIECE(OREASON,U,2))
SET ^OR(100,+ORIFN,8,DA,1)=$EXTRACT($PIECE(OREASON,U,2),1,240)
+4 QUIT
+5 ;
UPDATE(ORSTS,ORACT) ; -- continue processing
+1 NEW DA,ORX,ORCMMT,ORP
+2 DO DATES^ORCSAVE2(+ORIFN,ORSTRT,ORSTOP)
+3 if $GET(ORSTS)
DO STATUS^ORCSAVE2(+ORIFN,ORSTS)
+4 SET ORCMMT=$EXTRACT($PIECE(OREASON,U,2),1,240)
SET ORX=$$CREATE^ORX1(ORNATR)
if ORX
Begin DoDot:1
+5 SET DA=$$ACTION^ORCSAVE(ORACT,+ORIFN,ORNP,ORCMMT,ORLOG,ORDUZ)
+6 IF DA'>0
SET ORERR="Cannot create new order action"
QUIT
+7 DO RELEASE^ORCSAVE2(+ORIFN,DA,ORLOG,ORDUZ,ORNATR)
+8 DO SIGSTS^ORCSAVE2(+ORIFN,DA)
+9 IF $GET(ORL)
SET ORP(1)=+ORIFN_";"_DA_"^1"
DO PRINTS^ORWD1(.ORP,+ORL)
+10 SET $PIECE(^OR(100,+ORIFN,3),U,7)=DA
End DoDot:1
+11 IF '$$ACTV^ORX1(ORNATR)
SET $PIECE(^OR(100,+ORIFN,3),U,7)=0
+12 if ORACT="DC"
DO CANCEL^ORCSEND(+ORIFN)
+13 QUIT
+14 ;
REASON() ; -- Get reason from OREASON or NTE segments
+1 NEW NTE,CMMT,X,Y,I,L
+2 SET NTE=+$ORDER(@ORMSG@(+ORC))
SET CMMT=$PIECE(OREASON,U,4,5)
+3 ; no add'l comments
if 'NTE
GOTO RQ
if $EXTRACT(@ORMSG@(NTE),1,3)'="NTE"
GOTO RQ
+4 SET Y=$PIECE(@ORMSG@(NTE),"|",4)
SET I=0
+5 FOR
SET I=$ORDER(@ORMSG@(NTE,I))
if I'>0
QUIT
SET X=$GET(@ORMSG@(NTE,I))
SET L=$LENGTH(Y)+1+$LENGTH(X)
if L'>240
SET Y=Y_" "_X
IF L>240
SET Y=Y_" "_$EXTRACT(X,1,239-$LENGTH(Y))
QUIT
+6 SET $PIECE(CMMT,U,2)=Y
RQ QUIT CMMT
