Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LR7OB1

LR7OB1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. NEW(ODT,SN,CONTROL,NAT,TESTS,LRSTATI) ;Set-up order message
  1. ;Need ODT & SN of entry in ^LRO(69,ODT,1,SN)
  1. ;CONTROL=Order Control (SN=new order)
  1. ;NAT=Nature of order
  1. ;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
  1. ;LRSTATI=Status of order (ptr to ^ORD(100.01,IFN))
  1. Q:'$L($T(MSG^XQOR))
  1. Q:'$D(^LRO(69,$G(ODT),1,$G(SN),0)) N LRX0 S LRX0=^(0)
  1. 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
  1. . Q:'$D(^ORD(100.99,1,"PTCONV",DFN))
  1. . S $P(^LRO(69,ODT,1,SN,0),"^",11)=1 ;Keeps this order from being converted
  1. . D EN^LR7OV2(DFN_";"_$P(LRDPF,"^",2),1)
  1. Q:$P($G(^LR(+LRX0,0)),"^",2)'=2 ;Only allow messages for patients (file 2)
  1. N MSG,ORCHMSG,ORBBMSG,ORAPMSG,I,LRNIFN,LRTMPO
  1. K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J)
  1. D ORD1(ODT,SN,.TESTS)
  1. 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
  1. S LRNIFN=0 F S LRNIFN=$O(LRTMPO("LRIFN",LRNIFN)) Q:LRNIFN<1 S X=LRTMPO("LRIFN",LRNIFN) D
  1. . I $P(X,"^",7)="P" Q ;Test purged from CPRS
  1. . I $L($P(X,"^",14)),'$$TWOORIFN() N ODT,SN D Q
  1. .. S ODT=+$P(X,"^",14),SN=$P($P(X,"^",14),";",2)
  1. .. 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)
  1. . D EN1^LR7OB0(ODT,SN,CONTROL,$G(NAT)),CALL(CONTROL) K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J)
  1. Q
  1. CALL(CNTRL) ;Make protocol calls
  1. Q:'$L($T(MSG^XQOR))
  1. S:'$D(CNTRL) CNTRL=""
  1. I $D(^TMP("LRCH",$J)) S ORCHMSG="^TMP(""LRCH"",$J)" D MSG^XQOR("LR7O CH EVSEND OR",.ORCHMSG),RESULTS(ORCHMSG,CNTRL) ;Message from lab
  1. 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
  1. 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
  1. Q
  1. RESULTS(OREMSG,CNTRL) ;Results only protocol
  1. Q:$G(CNTRL)'="RE" Q:'$D(OREMSG)
  1. D MSG^XQOR("LR7O ALL EVSEND RESULTS",.OREMSG)
  1. Q
  1. ACC(AC,ACDT,ACN,CONTROL,NAT) ;Set-up order message for BB,SP,EM,CY,AU accessions
  1. ;ACC=Accession area ptr
  1. ;ACDT=Accession Date
  1. ;ACN=Accession #
  1. Q:'$L($T(MSG^XQOR))
  1. N MSG,CHMSG,BBMSG,APMSG
  1. K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J)
  1. D EN2^LR7OB0(AC,ACDT,ACN,CONTROL,.CHMSG,.BBMSG,.APMSG,$G(NAT))
  1. D CALL(CONTROL)
  1. K ^TMP("LRAP",$J),^TMP("LRCH",$J),^TMP("LRBB",$J)
  1. Q
  1. ORD(ORD) ;Set test nodes in LRTMPO("LRIFN" for given Lab #
  1. ;ORD=Lab order #
  1. Q:'$G(ORD) I $D(LRTMPO("LRIFN")) K LRTMPO("LRIFN")
  1. N IFN,ODT,SN,X
  1. S (CTR,ODT)=0
  1. 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
  1. . S CTR=CTR+1,LRTMPO("LRIFN",CTR)=X
  1. Q
  1. ORD1(ODT,SN,TST) ;Set test nodes in LRTMPO("LRIFN" for given LRODT & LRSN (includes combined tests)
  1. ;ODT=LRODT
  1. ;SN=LRSN
  1. ; TST=Array of tests to be included (optional). If TST is not passed, then all tests for a given LRSN will be included
  1. ; Screen out orders with ORIFN if CONTROL=SN (new order)
  1. Q:'$G(ODT) Q:'$G(SN) I $D(LRTMPO("LRIFN")) K LRTMPO("LRIFN")
  1. N IFN,X,CTR
  1. S (CTR,IFN)=0
  1. F S IFN=$O(^LRO(69,ODT,1,SN,2,IFN)) Q:IFN<1 S X=$G(^(IFN,0)) I X D
  1. . I CONTROL="SN",$P(X,"^",7) S LRTMPO("LRIFN")="" Q ;Don't send a SN for existing order
  1. . I $S($O(TST(0)):$D(TST(+X)),1:1) S CTR=CTR+1,LRTMPO("LRIFN",CTR)=X D Q
  1. .. I $P(X,"^",14),'$$TWOORIFN() S X=$P(X,"^",14) D
  1. ... I $D(^LRO(69,+X,1,+$P(X,";",2),2,+$P(X,";",3),0)) S X=^(0),CTR=CTR+1,LRTMPO("LRIFN",CTR)=X
  1. Q
  1. TWOORIFN() ;
  1. ; function to determine if a merged test has 2 different
  1. ; file 100 order numbers
  1. ;
  1. ; returns:
  1. ; 0 - test has only 1 file 100 order number
  1. ; 1 - test has more than 1 file 100 order numbers
  1. ;
  1. N ODT,SN,IFN,LRX
  1. S LRX=$P(X,"^",14),ODT=$P(LRX,";",1),SN=$P(LRX,";",2),IFN=$P(LRX,";",3)
  1. ;
  1. I ODT=""!(SN="")!(IFN="") Q 0
  1. ;
  1. S LRX=$G(^LRO(69,ODT,1,SN,2,IFN,0))
  1. I LRX="" Q 0
  1. ;
  1. I $P(X,"^",7)'="",$P(LRX,"^",7)'="",$P(X,"^",7)'=$P(LRX,"^",7) Q 1
  1. ;
  1. Q 0