- ORMLR ; SLC/MKB - Process Lab ORM msgs ;Oct 27, 2023@12:13:39
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,92,153,174,195,243,315,535**;Dec 17, 1997;Build 20
- ;Reference to ^LAB(61,"C" in ICR #2388
- ;Reference to ^VA(200 in ICR #4329
- ;Reference to RR^LR7OR1 in ICR #2503
- ;Reference to $$NOW^XLFDT in ICR #10103
- ;
- 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)
- 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 8599 printed Feb 18, 2025@23:58:33 Page 2
- ORMLR ; SLC/MKB - Process Lab ORM msgs ;Oct 27, 2023@12:13:39
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**3,92,153,174,195,243,315,535**;Dec 17, 1997;Build 20
- +2 ;Reference to ^LAB(61,"C" in ICR #2388
- +3 ;Reference to ^VA(200 in ICR #4329
- +4 ;Reference to RR^LR7OR1 in ICR #2503
- +5 ;Reference to $$NOW^XLFDT in ICR #10103
- +6 ;
- 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 QUIT
- +23 ;
- 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