- 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 Dec 13, 2024@02:04:45 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