LR7OB1 ;slc/dcm - Build message, backdoor Lab from file 69 ; 5/12/16 4:33pm
;;5.2;LAB SERVICE;**121,187,238,470**;Sep 27, 1994;Build 1
;
NEW(ODT,SN,CONTROL,NAT,TESTS,LRSTATI) ;Set-up order message
;Need ODT & SN of entry in ^LRO(69,ODT,1,SN)
;CONTROL=Order Control (SN=new order)
;NAT=Nature of order
;TESTS=Array of tests to be updated (optional). If this array is not included then all tests for the LRSN entry will be updated/included
;LRSTATI=Status of order (ptr to ^ORD(100.01,IFN))
Q:'$L($T(MSG^XQOR))
Q:'$D(^LRO(69,$G(ODT),1,$G(SN),0)) N LRX0 S LRX0=^(0)
I $$VER^LR7OU1>2.5,'$G(^ORD(100.99,1,"CONV")) N Y,DFN,LRDPF S Y=$G(^LR(+LRX0,0)),DFN=$P(Y,"^",3),LRDPF=$P(Y,"^",2)_$G(^DIC(+$P(Y,"^",2),0,"GL")) D
. Q:'$D(^ORD(100.99,1,"PTCONV",DFN))
. S $P(^LRO(69,ODT,1,SN,0),"^",11)=1 ;Keeps this order from being converted
. D EN^LR7OV2(DFN_";"_$P(LRDPF,"^",2),1)
Q:$P($G(^LR(+LRX0,0)),"^",2)'=2 ;Only allow messages for patients (file 2)
N MSG,ORCHMSG,ORBBMSG,ORAPMSG,I,LRNIFN,LRTMPO
K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J)
D ORD1(ODT,SN,.TESTS)
I '$D(LRTMPO("LRIFN")) D EN1^LR7OB0(ODT,SN,CONTROL,$G(NAT)),CALL(CONTROL) K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J) Q
S LRNIFN=0 F S LRNIFN=$O(LRTMPO("LRIFN",LRNIFN)) Q:LRNIFN<1 S X=LRTMPO("LRIFN",LRNIFN) D
. I $P(X,"^",7)="P" Q ;Test purged from CPRS
. I $L($P(X,"^",14)),'$$TWOORIFN() N ODT,SN D Q
.. S ODT=+$P(X,"^",14),SN=$P($P(X,"^",14),";",2)
.. I $D(^LRO(69,+ODT,1,+SN,0)) S:CONTROL="RE" LRSTATI=2 D EN1^LR7OB0(ODT,SN,CONTROL,$G(NAT)),CALL(CONTROL) K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J)
. D EN1^LR7OB0(ODT,SN,CONTROL,$G(NAT)),CALL(CONTROL) K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J)
Q
CALL(CNTRL) ;Make protocol calls
Q:'$L($T(MSG^XQOR))
S:'$D(CNTRL) CNTRL=""
I $D(^TMP("LRCH",$J)) S ORCHMSG="^TMP(""LRCH"",$J)" D MSG^XQOR("LR7O CH EVSEND OR",.ORCHMSG),RESULTS(ORCHMSG,CNTRL) ;Message from lab
I $D(^TMP("LRBB",$J)) S ORBBMSG="^TMP(""LRBB"",$J)" D MSG^XQOR("LR7O BB EVSEND OR",.ORBBMSG),RESULTS(ORBBMSG,CNTRL) ;New order from Blood bank
I $D(^TMP("LRAP",$J)) S ORAPMSG="^TMP(""LRAP"",$J)" D MSG^XQOR("LR7O AP EVSEND OR",.ORAPMSG),RESULTS(ORAPMSG,CNTRL) ;New order from Anatomic Path
Q
RESULTS(OREMSG,CNTRL) ;Results only protocol
Q:$G(CNTRL)'="RE" Q:'$D(OREMSG)
D MSG^XQOR("LR7O ALL EVSEND RESULTS",.OREMSG)
Q
ACC(AC,ACDT,ACN,CONTROL,NAT) ;Set-up order message for BB,SP,EM,CY,AU accessions
;ACC=Accession area ptr
;ACDT=Accession Date
;ACN=Accession #
Q:'$L($T(MSG^XQOR))
N MSG,CHMSG,BBMSG,APMSG
K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J)
D EN2^LR7OB0(AC,ACDT,ACN,CONTROL,.CHMSG,.BBMSG,.APMSG,$G(NAT))
D CALL(CONTROL)
K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J)
Q
ORD(ORD) ;Set test nodes in LRTMPO("LRIFN" for given Lab #
;ORD=Lab order #
Q:'$G(ORD) I $D(LRTMPO("LRIFN")) K LRTMPO("LRIFN")
N IFN,ODT,SN,X
S (CTR,ODT)=0
F S ODT=$O(^LRO(69,"C",ORD,ODT)) Q:ODT<1 S SN=0 F S SN=$O(^LRO(69,"C",ORD,ODT,SN)) Q:SN<1 S IFN=0 F S IFN=$O(^LRO(69,ODT,1,SN,2,IFN)) Q:IFN<1 S X=$G(^(IFN,0)) I X D
. S CTR=CTR+1,LRTMPO("LRIFN",CTR)=X
Q
ORD1(ODT,SN,TST) ;Set test nodes in LRTMPO("LRIFN" for given LRODT & LRSN (includes combined tests)
;ODT=LRODT
;SN=LRSN
; TST=Array of tests to be included (optional). If TST is not passed, then all tests for a given LRSN will be included
; Screen out orders with ORIFN if CONTROL=SN (new order)
Q:'$G(ODT) Q:'$G(SN) I $D(LRTMPO("LRIFN")) K LRTMPO("LRIFN")
N IFN,X,CTR
S (CTR,IFN)=0
F S IFN=$O(^LRO(69,ODT,1,SN,2,IFN)) Q:IFN<1 S X=$G(^(IFN,0)) I X D
. I CONTROL="SN",$P(X,"^",7) S LRTMPO("LRIFN")="" Q ;Don't send a SN for existing order
. I $S($O(TST(0)):$D(TST(+X)),1:1) S CTR=CTR+1,LRTMPO("LRIFN",CTR)=X D Q
.. I $P(X,"^",14),'$$TWOORIFN() S X=$P(X,"^",14) D
... I $D(^LRO(69,+X,1,+$P(X,";",2),2,+$P(X,";",3),0)) S X=^(0),CTR=CTR+1,LRTMPO("LRIFN",CTR)=X
Q
TWOORIFN() ;
; function to determine if a merged test has 2 different
; file 100 order numbers
;
; returns:
; 0 - test has only 1 file 100 order number
; 1 - test has more than 1 file 100 order numbers
;
N ODT,SN,IFN,LRX
S LRX=$P(X,"^",14),ODT=$P(LRX,";",1),SN=$P(LRX,";",2),IFN=$P(LRX,";",3)
;
I ODT=""!(SN="")!(IFN="") Q 0
;
S LRX=$G(^LRO(69,ODT,1,SN,2,IFN,0))
I LRX="" Q 0
;
I $P(X,"^",7)'="",$P(LRX,"^",7)'="",$P(X,"^",7)'=$P(LRX,"^",7) Q 1
;
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OB1 4445 printed Oct 16, 2024@18:05:31 Page 2
LR7OB1 ;slc/dcm - Build message, backdoor Lab from file 69 ; 5/12/16 4:33pm
+1 ;;5.2;LAB SERVICE;**121,187,238,470**;Sep 27, 1994;Build 1
+2 ;
NEW(ODT,SN,CONTROL,NAT,TESTS,LRSTATI) ;Set-up order message
+1 ;Need ODT & SN of entry in ^LRO(69,ODT,1,SN)
+2 ;CONTROL=Order Control (SN=new order)
+3 ;NAT=Nature of order
+4 ;TESTS=Array of tests to be updated (optional). If this array is not included then all tests for the LRSN entry will be updated/included
+5 ;LRSTATI=Status of order (ptr to ^ORD(100.01,IFN))
+6 if '$LENGTH($TEXT(MSG^XQOR))
QUIT
+7 if '$DATA(^LRO(69,$GET(ODT),1,$GET(SN),0))
QUIT
NEW LRX0
SET LRX0=^(0)
+8 IF $$VER^LR7OU1>2.5
IF '$GET(^ORD(100.99,1,"CONV"))
NEW Y,DFN,LRDPF
SET Y=$GET(^LR(+LRX0,0))
SET DFN=$PIECE(Y,"^",3)
SET LRDPF=$PIECE(Y,"^",2)_$GET(^DIC(+$PIECE(Y,"^",2),0,"GL"))
Begin DoDot:1
+9 if '$DATA(^ORD(100.99,1,"PTCONV",DFN))
QUIT
+10 ;Keeps this order from being converted
SET $PIECE(^LRO(69,ODT,1,SN,0),"^",11)=1
+11 DO EN^LR7OV2(DFN_";"_$PIECE(LRDPF,"^",2),1)
End DoDot:1
+12 ;Only allow messages for patients (file 2)
if $PIECE($GET(^LR(+LRX0,0)),"^",2)'=2
QUIT
+13 NEW MSG,ORCHMSG,ORBBMSG,ORAPMSG,I,LRNIFN,LRTMPO
+14 KILL ^TMP("LRAP",$JOB),^TMP("LRCH",$JOB),^TMP("LRBB",$JOB)
+15 DO ORD1(ODT,SN,.TESTS)
+16 IF '$DATA(LRTMPO("LRIFN"))
DO EN1^LR7OB0(ODT,SN,CONTROL,$GET(NAT))
DO CALL(CONTROL)
KILL ^TMP("LRAP",$JOB),^TMP("LRCH",$JOB),^TMP("LRBB",$JOB)
QUIT
+17 SET LRNIFN=0
FOR
SET LRNIFN=$ORDER(LRTMPO("LRIFN",LRNIFN))
if LRNIFN<1
QUIT
SET X=LRTMPO("LRIFN",LRNIFN)
Begin DoDot:1
+18 ;Test purged from CPRS
IF $PIECE(X,"^",7)="P"
QUIT
+19 IF $LENGTH($PIECE(X,"^",14))
IF '$$TWOORIFN()
NEW ODT,SN
Begin DoDot:2
+20 SET ODT=+$PIECE(X,"^",14)
SET SN=$PIECE($PIECE(X,"^",14),";",2)
+21 IF $DATA(^LRO(69,+ODT,1,+SN,0))
if CONTROL="RE"
SET LRSTATI=2
DO EN1^LR7OB0(ODT,SN,CONTROL,$GET(NAT))
DO CALL(CONTROL)
KILL ^TMP("LRAP",$JOB),^TMP("LRCH",$JOB),^TMP("LRBB",$JOB)
End DoDot:2
QUIT
+22 DO EN1^LR7OB0(ODT,SN,CONTROL,$GET(NAT))
DO CALL(CONTROL)
KILL ^TMP("LRAP",$JOB),^TMP("LRCH",$JOB),^TMP("LRBB",$JOB)
End DoDot:1
+23 QUIT
CALL(CNTRL) ;Make protocol calls
+1 if '$LENGTH($TEXT(MSG^XQOR))
QUIT
+2 if '$DATA(CNTRL)
SET CNTRL=""
+3 ;Message from lab
IF $DATA(^TMP("LRCH",$JOB))
SET ORCHMSG="^TMP(""LRCH"",$J)"
DO MSG^XQOR("LR7O CH EVSEND OR",.ORCHMSG)
DO RESULTS(ORCHMSG,CNTRL)
+4 ;New order from Blood bank
IF $DATA(^TMP("LRBB",$JOB))
SET ORBBMSG="^TMP(""LRBB"",$J)"
DO MSG^XQOR("LR7O BB EVSEND OR",.ORBBMSG)
DO RESULTS(ORBBMSG,CNTRL)
+5 ;New order from Anatomic Path
IF $DATA(^TMP("LRAP",$JOB))
SET ORAPMSG="^TMP(""LRAP"",$J)"
DO MSG^XQOR("LR7O AP EVSEND OR",.ORAPMSG)
DO RESULTS(ORAPMSG,CNTRL)
+6 QUIT
RESULTS(OREMSG,CNTRL) ;Results only protocol
+1 if $GET(CNTRL)'="RE"
QUIT
if '$DATA(OREMSG)
QUIT
+2 DO MSG^XQOR("LR7O ALL EVSEND RESULTS",.OREMSG)
+3 QUIT
ACC(AC,ACDT,ACN,CONTROL,NAT) ;Set-up order message for BB,SP,EM,CY,AU accessions
+1 ;ACC=Accession area ptr
+2 ;ACDT=Accession Date
+3 ;ACN=Accession #
+4 if '$LENGTH($TEXT(MSG^XQOR))
QUIT
+5 NEW MSG,CHMSG,BBMSG,APMSG
+6 KILL ^TMP("LRAP",$JOB),^TMP("LRCH",$JOB),^TMP("LRBB",$JOB)
+7 DO EN2^LR7OB0(AC,ACDT,ACN,CONTROL,.CHMSG,.BBMSG,.APMSG,$GET(NAT))
+8 DO CALL(CONTROL)
+9 KILL ^TMP("LRAP",$JOB),^TMP("LRCH",$JOB),^TMP("LRBB",$JOB)
+10 QUIT
ORD(ORD) ;Set test nodes in LRTMPO("LRIFN" for given Lab #
+1 ;ORD=Lab order #
+2 if '$GET(ORD)
QUIT
IF $DATA(LRTMPO("LRIFN"))
KILL LRTMPO("LRIFN")
+3 NEW IFN,ODT,SN,X
+4 SET (CTR,ODT)=0
+5 FOR
SET ODT=$ORDER(^LRO(69,"C",ORD,ODT))
if ODT<1
QUIT
SET SN=0
FOR
SET SN=$ORDER(^LRO(69,"C",ORD,ODT,SN))
if SN<1
QUIT
SET IFN=0
FOR
SET IFN=$ORDER(^LRO(69,ODT,1,SN,2,IFN))
if IFN<1
QUIT
SET X=$GET(^(IFN,0))
IF X
Begin DoDot:1
+6 SET CTR=CTR+1
SET LRTMPO("LRIFN",CTR)=X
End DoDot:1
+7 QUIT
ORD1(ODT,SN,TST) ;Set test nodes in LRTMPO("LRIFN" for given LRODT & LRSN (includes combined tests)
+1 ;ODT=LRODT
+2 ;SN=LRSN
+3 ; TST=Array of tests to be included (optional). If TST is not passed, then all tests for a given LRSN will be included
+4 ; Screen out orders with ORIFN if CONTROL=SN (new order)
+5 if '$GET(ODT)
QUIT
if '$GET(SN)
QUIT
IF $DATA(LRTMPO("LRIFN"))
KILL LRTMPO("LRIFN")
+6 NEW IFN,X,CTR
+7 SET (CTR,IFN)=0
+8 FOR
SET IFN=$ORDER(^LRO(69,ODT,1,SN,2,IFN))
if IFN<1
QUIT
SET X=$GET(^(IFN,0))
IF X
Begin DoDot:1
+9 ;Don't send a SN for existing order
IF CONTROL="SN"
IF $PIECE(X,"^",7)
SET LRTMPO("LRIFN")=""
QUIT
+10 IF $SELECT($ORDER(TST(0)):$DATA(TST(+X)),1:1)
SET CTR=CTR+1
SET LRTMPO("LRIFN",CTR)=X
Begin DoDot:2
+11 IF $PIECE(X,"^",14)
IF '$$TWOORIFN()
SET X=$PIECE(X,"^",14)
Begin DoDot:3
+12 IF $DATA(^LRO(69,+X,1,+$PIECE(X,";",2),2,+$PIECE(X,";",3),0))
SET X=^(0)
SET CTR=CTR+1
SET LRTMPO("LRIFN",CTR)=X
End DoDot:3
End DoDot:2
QUIT
End DoDot:1
+13 QUIT
TWOORIFN() ;
+1 ; function to determine if a merged test has 2 different
+2 ; file 100 order numbers
+3 ;
+4 ; returns:
+5 ; 0 - test has only 1 file 100 order number
+6 ; 1 - test has more than 1 file 100 order numbers
+7 ;
+8 NEW ODT,SN,IFN,LRX
+9 SET LRX=$PIECE(X,"^",14)
SET ODT=$PIECE(LRX,";",1)
SET SN=$PIECE(LRX,";",2)
SET IFN=$PIECE(LRX,";",3)
+10 ;
+11 IF ODT=""!(SN="")!(IFN="")
QUIT 0
+12 ;
+13 SET LRX=$GET(^LRO(69,ODT,1,SN,2,IFN,0))
+14 IF LRX=""
QUIT 0
+15 ;
+16 IF $PIECE(X,"^",7)'=""
IF $PIECE(LRX,"^",7)'=""
IF $PIECE(X,"^",7)'=$PIECE(LRX,"^",7)
QUIT 1
+17 ;
+18 QUIT 0
