- LR7OR2 ;DALOI/dcm - Get Lab results (cont.) ; 3/29/19 8:12am
- ;;5.2;LAB SERVICE;**121,187,219,285,286,372,350,453,519**;Sep 27, 1994;Build 16
- ;
- ;
- CH(SDATE,EDATE,TEST,COUNT,SPEC,UNVER) ;Get CH subscript data
- ;
- Q:'$D(SDATE) Q:'$D(EDATE) Q:'$D(COUNT) Q:'$D(CT1)
- N GOTIT,I,IVDT,ITST,IST,TSTY,X,X0,ORD,Y6,Y12,Y16,Y19
- I '($D(^TMP("LRORID",$J))>10) F I="LRPLS","LRPLS-ADDR" K ^TMP(I,$J)
- ;
- I $G(TEST) Q:'$D(^LAB(60,TEST,0)) S X=^(0) Q:$P(X,"^",4)'="CH" D
- . I $P(X,"^",5)'="" S TSTY($P($P(X,"^",5),";",2))=TEST
- . I $P(X,"^",5)="" D EN^LR7OU1(TEST)
- ;
- S IVDT=SDATE I $D(^LR(LRDFN,"CH",SDATE)) S IVDT=SDATE-.000001
- F S IVDT=$O(^LR(LRDFN,"CH",IVDT)) Q:IVDT<1!(IVDT>EDATE)!(CT1>COUNT) D
- . S X0=^LR(LRDFN,"CH",IVDT,0),Y6=$S($P(X0,"^",3):"F",1:"P"),Y12=$P(X0,"^",4),Y19=$P(X0,"^",5),Y16=$P(X0,"^",6),ORD=$$ORD(LRDFN,IVDT)
- . S GOTIT=0
- . I '$G(UNVER),Y6="P" Q ;Unverified data not requested
- . I $G(SPEC),Y19'=SPEC Q ;Specimen specified
- . I '$D(TSTY) S ITST=1 F S ITST=$O(^LR(LRDFN,"CH",IVDT,ITST)) Q:ITST<1 S X=^(ITST) D SETTST(ITST,X)
- . S IST=0 F S IST=$O(TSTY(IST)) Q:IST<1 I $D(^LR(LRDFN,"CH",IVDT,IST)) S X=^(IST) D SETTST(IST,X)
- . I $O(^TMP("LRRR",$J,DFN,"CH",IVDT,0)) D NOTE(LRDFN,IVDT)
- . Q:'GOTIT
- . S CT1=CT1+1
- . ; Display ordering provider
- . D ORDP($P($G(^LR(LRDFN,"CH",IVDT,0)),"^",10))
- . ; Display report released date/time
- . D RRDT($P(X0,"^",3))
- . ; List performing laboratories
- . D PLS
- ;
- I '($D(^TMP("LRORID",$J))>10) F I="LRPLS","LRPLS-ADDR" K ^TMP(I,$J)
- Q
- ;
- ;
- SETTST(ISUB,ZERO) ;Set test data in ^TMP
- ; ISUB= test subscript
- ; ZERO= 0th node at ^LR(LRDFN,"CH",IVDT,TST)
- N LRX,PORDER,X,Y,Y1,Y2,Y3,Y4,Y5,Y9,Y10,Y11,Y14
- S X=ZERO,Y1=ISUB,Y1=$O(^LAB(60,"C","CH;"_Y1_";1",0)),Y2=$P(X,"^"),Y3=$P(X,"^",2)
- Q:'Y1 Q:"IN"[$P(^LAB(60,Y1,0),"^",3) S Y15=$P($G(^LAB(60,Y1,.1)),"^")
- S (Y9,Y10,Y11,Y14)=""
- I $P($G(^LAB(60,Y1,64)),"^") S Y9=$P(^(64),"^"),Y9=$P(^LAM(Y9,0),"^",2),Y10=$P(^(0),"^"),Y11="99NLT"
- ;
- S LRX=$$TSTRES^LRRPU(LRDFN,"CH",IVDT,ISUB,Y1)
- S Y2=$P(LRX,"^"),Y3=$P(LRX,"^",2),Y4=$P(LRX,"^",5),Y5=$$EN^LRLRRVF($P(LRX,"^",3),$P(LRX,"^",4))
- I $P(LRX,"^",7) S Y14="T"
- S Y2=$$TRIM^XLFSTR($$RESULT^LR7OB63(Y1,Y2),"RL"," ")
- ;
- ; Determine print order and adjust if duplicate
- S PORDER=$P($G(^LAB(60,Y1,.1)),"^",6),PORDER=$S(PORDER:PORDER,1:998+(ISUB/10000000))
- I $D(^TMP("LRRR",$J,DFN,"CH",IVDT,PORDER)) F PORDER=PORDER:.00000001 I '$D(^TMP("LRRR",$J,DFN,"CH",IVDT,PORDER)) Q
- ;
- S ^TMP("LRRR",$J,DFN,"CH",IVDT,PORDER)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^^^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12_"^^"_Y14_"^"_Y15_"^"_Y16_"^"_$G(ORD)_"^^"_Y19
- I $P(LRX,"^",6) S ^TMP("LRPLS",$J,$P(LRX,"^",6),$P(^LAB(60,Y1,0),"^"))=""
- S GOTIT=1
- Q
- ;
- ;
- NOTE(LRDFN,IVDT) ;Get comments
- N IFN
- S IFN=0
- F S IFN=$O(^LR(LRDFN,"CH",IVDT,1,IFN)) Q:IFN<1 S X=^(IFN,0),^TMP("LRRR",$J,DFN,"CH",IVDT,"N",IFN)=X
- Q
- ;
- ;
- TEST(Y,DFN,ORD,SDATE,EDATE,SUB,TEST,FLAG,COUNT) ;Test network calls
- ; Called from TIU
- ; COUNT = count of results to send, results with the same date/time count as 1
- N IVDT,SSUB,SEQ,CTR
- Q:'$G(DFN)
- D RR^LR7OR1(DFN,$G(ORD),$G(SDATE),$G(EDATE),$G(SUB),$G(TEST),$G(FLAG),$G(COUNT))
- I '$D(^TMP("LRRR",$J)) S Y(1)="No Lab Data" Q
- S CTR=0,SSUB="",COUNT=$S($G(COUNT):COUNT,1:9999999)
- F S SSUB=$O(^TMP("LRRR",$J,DFN,SSUB)) Q:SSUB="" S IVDT=0 F S IVDT=$O(^TMP("LRRR",$J,DFN,SSUB,IVDT)) Q:IVDT<1 S SEQ=0 F S SEQ=$O(^TMP("LRRR",$J,DFN,SSUB,IVDT,SEQ)) Q:SEQ<1 D
- . S CTR=CTR+1,^TMP("LRAPI",$J,CTR)=9999999-IVDT_"^"_SSUB_"^"_^TMP("LRRR",$J,DFN,SSUB,IVDT,SEQ)
- S Y=$NA(^TMP("LRAPI",$J))
- Q
- ;
- ;
- T60(Y,IFN) ;Get tests from file 60
- ; If IFN is not passed then the whole file is sent.
- N CTR S CTR=0
- I $D(IFN) Q:'$D(^LAB(60,IFN,0)) S Y(1)=IFN_"^"_$P(^LAB(60,IFN,0),"^") Q
- S NAME="" F S NAME=$O(^LAB(60,"B",NAME)) Q:NAME="" S IFN=0 F S IFN=$O(^LAB(60,"B",NAME,IFN)) Q:IFN<1 I $D(^LAB(60,IFN,0)) S CTR=CTR+1,Y(CTR)=IFN_"^"_NAME
- Q
- ;
- ;
- T64(Y,IFN) ;Get tests from file 64
- ; If IFN is not passed then the whole file is sent, if entry has a link to file 60
- N CTR S CTR=0
- I $D(IFN) Q:'$D(^LAM(IFN,0)) Q:'$D(^LAB(60,"AC",IFN)) S Y(1)=IFN_"^"_$P(^LAM(IFN,0),"^") Q
- S NAME="" F S NAME=$O(^LAM("B",NAME)) Q:NAME="" S IFN=0 F S IFN=$O(^LAM("B",NAME,IFN)) Q:IFN<1 I $D(^LAM(IFN,0)),$D(^LAB(60,"AC",IFN)) S CTR=CTR+1,Y(CTR)=IFN_"^"_NAME
- Q
- ;
- ;
- ORD(LRDFN,IVDT) ;Get order # for entry in file 63
- ; LRDFN=Lab Patient #
- ; IVDT=Inverse Date/time in 63 (^LR(LRDFN,"CH",IVDT))
- Q:'$G(LRDFN) Q:'$G(IVDT)
- N X0,X6,X,AC,ACD,ACN
- S X0=$G(^LR(LRDFN,"CH",IVDT,0)),X6=$P(X0,"^",6) I X6="" Q ""
- S X=$P(X6," "),X=$O(^LRO(68,"B",X,0)) I 'X Q ""
- S AC=X,ACD=+$P(X0,"."),ACN=$P(X6," ",3) I '$D(^LRO(68,AC,1,ACD,1,ACN,0)) Q ""
- S X=$P($G(^LRO(68,AC,1,ACD,1,ACN,.1)),"^")
- Q X
- ;
- ;
- ORDP(LRPROV) ; Display ordering provider in comment
- N LRY,CNT
- S LRY=$$NAME^XUSER(LRPROV,"G")
- S CNT=$O(^TMP("LRRR",$J,DFN,"CH",IVDT,"N",""),-1)+1
- S ^TMP("LRRR",$J,DFN,"CH",IVDT,"N",CNT)="Ordering Provider: "_LRY
- Q
- ;
- ;
- RRDT(LRDT) ; Display report released date/time
- N LRY,CNT
- I LRDT S LRY=$$FMTE^XLFDT(LRDT,"M")
- E S LRY=""
- S CNT=$O(^TMP("LRRR",$J,DFN,"CH",IVDT,"N",""),-1)+1
- S ^TMP("LRRR",$J,DFN,"CH",IVDT,"N",CNT)="Report Released Date/Time: "_LRY,CNT=CNT+1
- Q
- ;
- ;
- PLS ; List reporting and performing laboratories
- ; If multiple performing labs then list tests associated with each lab.
- ;
- N CNT,LINE,LLEN,LRPLS,LRX,MPLS,PLS,TESTNAME,X
- ;
- S CNT=$O(^TMP("LRRR",$J,DFN,"CH",IVDT,"N",""),-1)+1
- ;
- ; Reporting Laboratory
- I $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2 D
- . S LRX=+$G(^LR(LRDFN,"CH",IVDT,"RF"))
- . I LRX<1 Q
- . S LINE=$$PLSADDR^LR7OSUM2(LRX)
- . S ^TMP("LRRR",$J,DFN,"CH",IVDT,"N",CNT)=" ",CNT=CNT+1
- . S ^TMP("LRRR",$J,DFN,"CH",IVDT,"N",CNT)="Reporting Lab: "_$P(LINE,"^"),CNT=CNT+1
- . S ^TMP("LRRR",$J,DFN,"CH",IVDT,"N",CNT)=" "_$P(LINE,"^",2),CNT=CNT+1
- ;
- S PLS=$O(^TMP("LRPLS",$J,0)),MPLS=0
- I $O(^TMP("LRPLS",$J,PLS)) S MPLS=1 ; multiple performing labs
- S LRPLS=0
- F S LRPLS=$O(^TMP("LRPLS",$J,LRPLS)) Q:LRPLS<1 D
- . S ^TMP("LRRR",$J,DFN,"CH",IVDT,"N",CNT)=" ",CNT=CNT+1
- . I MPLS D
- . . S TESTNAME="",LINE="For test(s): ",LLEN=13
- . . F S TESTNAME=$O(^TMP("LRPLS",$J,LRPLS,TESTNAME)) Q:TESTNAME="" D
- . . . S X=$L(TESTNAME)
- . . . I (LLEN+X)>240 S ^TMP("LRRR",$J,DFN,"CH",IVDT,"N",CNT)=LINE,CNT=CNT+1,LINE="",LLEN=0
- . . . S LINE=LINE_$S(LLEN>13:", ",1:"")_TESTNAME,LLEN=LLEN+X+$S(LLEN>13:2,1:0)
- . . I LINE'="" S ^TMP("LRRR",$J,DFN,"CH",IVDT,"N",CNT)=LINE,CNT=CNT+1
- . S LINE=$$PLSADDR^LR7OSUM2(LRPLS)
- . S ^TMP("LRRR",$J,DFN,"CH",IVDT,"N",CNT)="Performing Lab: "_$P(LINE,"^"),CNT=CNT+1
- . S ^TMP("LRRR",$J,DFN,"CH",IVDT,"N",CNT)=" "_$P(LINE,"^",2),CNT=CNT+1
- ;
- S ^TMP("LRRR",$J,DFN,"CH",IVDT,"N",CNT)=" "
- ;
- K ^TMP("LRPLS",$J)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OR2 6885 printed Jan 18, 2025@03:06:03 Page 2
- LR7OR2 ;DALOI/dcm - Get Lab results (cont.) ; 3/29/19 8:12am
- +1 ;;5.2;LAB SERVICE;**121,187,219,285,286,372,350,453,519**;Sep 27, 1994;Build 16
- +2 ;
- +3 ;
- CH(SDATE,EDATE,TEST,COUNT,SPEC,UNVER) ;Get CH subscript data
- +1 ;
- +2 if '$DATA(SDATE)
- QUIT
- if '$DATA(EDATE)
- QUIT
- if '$DATA(COUNT)
- QUIT
- if '$DATA(CT1)
- QUIT
- +3 NEW GOTIT,I,IVDT,ITST,IST,TSTY,X,X0,ORD,Y6,Y12,Y16,Y19
- +4 IF '($DATA(^TMP("LRORID",$JOB))>10)
- FOR I="LRPLS","LRPLS-ADDR"
- KILL ^TMP(I,$JOB)
- +5 ;
- +6 IF $GET(TEST)
- if '$DATA(^LAB(60,TEST,0))
- QUIT
- SET X=^(0)
- if $PIECE(X,"^",4)'="CH"
- QUIT
- Begin DoDot:1
- +7 IF $PIECE(X,"^",5)'=""
- SET TSTY($PIECE($PIECE(X,"^",5),";",2))=TEST
- +8 IF $PIECE(X,"^",5)=""
- DO EN^LR7OU1(TEST)
- End DoDot:1
- +9 ;
- +10 SET IVDT=SDATE
- IF $DATA(^LR(LRDFN,"CH",SDATE))
- SET IVDT=SDATE-.000001
- +11 FOR
- SET IVDT=$ORDER(^LR(LRDFN,"CH",IVDT))
- if IVDT<1!(IVDT>EDATE)!(CT1>COUNT)
- QUIT
- Begin DoDot:1
- +12 SET X0=^LR(LRDFN,"CH",IVDT,0)
- SET Y6=$SELECT($PIECE(X0,"^",3):"F",1:"P")
- SET Y12=$PIECE(X0,"^",4)
- SET Y19=$PIECE(X0,"^",5)
- SET Y16=$PIECE(X0,"^",6)
- SET ORD=$$ORD(LRDFN,IVDT)
- +13 SET GOTIT=0
- +14 ;Unverified data not requested
- IF '$GET(UNVER)
- IF Y6="P"
- QUIT
- +15 ;Specimen specified
- IF $GET(SPEC)
- IF Y19'=SPEC
- QUIT
- +16 IF '$DATA(TSTY)
- SET ITST=1
- FOR
- SET ITST=$ORDER(^LR(LRDFN,"CH",IVDT,ITST))
- if ITST<1
- QUIT
- SET X=^(ITST)
- DO SETTST(ITST,X)
- +17 SET IST=0
- FOR
- SET IST=$ORDER(TSTY(IST))
- if IST<1
- QUIT
- IF $DATA(^LR(LRDFN,"CH",IVDT,IST))
- SET X=^(IST)
- DO SETTST(IST,X)
- +18 IF $ORDER(^TMP("LRRR",$JOB,DFN,"CH",IVDT,0))
- DO NOTE(LRDFN,IVDT)
- +19 if 'GOTIT
- QUIT
- +20 SET CT1=CT1+1
- +21 ; Display ordering provider
- +22 DO ORDP($PIECE($GET(^LR(LRDFN,"CH",IVDT,0)),"^",10))
- +23 ; Display report released date/time
- +24 DO RRDT($PIECE(X0,"^",3))
- +25 ; List performing laboratories
- +26 DO PLS
- End DoDot:1
- +27 ;
- +28 IF '($DATA(^TMP("LRORID",$JOB))>10)
- FOR I="LRPLS","LRPLS-ADDR"
- KILL ^TMP(I,$JOB)
- +29 QUIT
- +30 ;
- +31 ;
- SETTST(ISUB,ZERO) ;Set test data in ^TMP
- +1 ; ISUB= test subscript
- +2 ; ZERO= 0th node at ^LR(LRDFN,"CH",IVDT,TST)
- +3 NEW LRX,PORDER,X,Y,Y1,Y2,Y3,Y4,Y5,Y9,Y10,Y11,Y14
- +4 SET X=ZERO
- SET Y1=ISUB
- SET Y1=$ORDER(^LAB(60,"C","CH;"_Y1_";1",0))
- SET Y2=$PIECE(X,"^")
- SET Y3=$PIECE(X,"^",2)
- +5 if 'Y1
- QUIT
- if "IN"[$PIECE(^LAB(60,Y1,0),"^",3)
- QUIT
- SET Y15=$PIECE($GET(^LAB(60,Y1,.1)),"^")
- +6 SET (Y9,Y10,Y11,Y14)=""
- +7 IF $PIECE($GET(^LAB(60,Y1,64)),"^")
- SET Y9=$PIECE(^(64),"^")
- SET Y9=$PIECE(^LAM(Y9,0),"^",2)
- SET Y10=$PIECE(^(0),"^")
- SET Y11="99NLT"
- +8 ;
- +9 SET LRX=$$TSTRES^LRRPU(LRDFN,"CH",IVDT,ISUB,Y1)
- +10 SET Y2=$PIECE(LRX,"^")
- SET Y3=$PIECE(LRX,"^",2)
- SET Y4=$PIECE(LRX,"^",5)
- SET Y5=$$EN^LRLRRVF($PIECE(LRX,"^",3),$PIECE(LRX,"^",4))
- +11 IF $PIECE(LRX,"^",7)
- SET Y14="T"
- +12 SET Y2=$$TRIM^XLFSTR($$RESULT^LR7OB63(Y1,Y2),"RL"," ")
- +13 ;
- +14 ; Determine print order and adjust if duplicate
- +15 SET PORDER=$PIECE($GET(^LAB(60,Y1,.1)),"^",6)
- SET PORDER=$SELECT(PORDER:PORDER,1:998+(ISUB/10000000))
- +16 IF $DATA(^TMP("LRRR",$JOB,DFN,"CH",IVDT,PORDER))
- FOR PORDER=PORDER:.00000001
- IF '$DATA(^TMP("LRRR",$JOB,DFN,"CH",IVDT,PORDER))
- QUIT
- +17 ;
- +18 SET ^TMP("LRRR",$JOB,DFN,"CH",IVDT,PORDER)=Y1_"^"_Y2_"^"_Y3_"^"_Y4_"^"_Y5_"^"_Y6_"^^^"_Y9_"^"_Y10_"^"_Y11_"^"_Y12_"^^"_Y14_"^"_Y15_"^"_Y16_"^"_$GET(ORD)_"^^"_Y19
- +19 IF $PIECE(LRX,"^",6)
- SET ^TMP("LRPLS",$JOB,$PIECE(LRX,"^",6),$PIECE(^LAB(60,Y1,0),"^"))=""
- +20 SET GOTIT=1
- +21 QUIT
- +22 ;
- +23 ;
- NOTE(LRDFN,IVDT) ;Get comments
- +1 NEW IFN
- +2 SET IFN=0
- +3 FOR
- SET IFN=$ORDER(^LR(LRDFN,"CH",IVDT,1,IFN))
- if IFN<1
- QUIT
- SET X=^(IFN,0)
- SET ^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",IFN)=X
- +4 QUIT
- +5 ;
- +6 ;
- TEST(Y,DFN,ORD,SDATE,EDATE,SUB,TEST,FLAG,COUNT) ;Test network calls
- +1 ; Called from TIU
- +2 ; COUNT = count of results to send, results with the same date/time count as 1
- +3 NEW IVDT,SSUB,SEQ,CTR
- +4 if '$GET(DFN)
- QUIT
- +5 DO RR^LR7OR1(DFN,$GET(ORD),$GET(SDATE),$GET(EDATE),$GET(SUB),$GET(TEST),$GET(FLAG),$GET(COUNT))
- +6 IF '$DATA(^TMP("LRRR",$JOB))
- SET Y(1)="No Lab Data"
- QUIT
- +7 SET CTR=0
- SET SSUB=""
- SET COUNT=$SELECT($GET(COUNT):COUNT,1:9999999)
- +8 FOR
- SET SSUB=$ORDER(^TMP("LRRR",$JOB,DFN,SSUB))
- if SSUB=""
- QUIT
- SET IVDT=0
- FOR
- SET IVDT=$ORDER(^TMP("LRRR",$JOB,DFN,SSUB,IVDT))
- if IVDT<1
- QUIT
- SET SEQ=0
- FOR
- SET SEQ=$ORDER(^TMP("LRRR",$JOB,DFN,SSUB,IVDT,SEQ))
- if SEQ<1
- QUIT
- Begin DoDot:1
- +9 SET CTR=CTR+1
- SET ^TMP("LRAPI",$JOB,CTR)=9999999-IVDT_"^"_SSUB_"^"_^TMP("LRRR",$JOB,DFN,SSUB,IVDT,SEQ)
- End DoDot:1
- +10 SET Y=$NAME(^TMP("LRAPI",$JOB))
- +11 QUIT
- +12 ;
- +13 ;
- T60(Y,IFN) ;Get tests from file 60
- +1 ; If IFN is not passed then the whole file is sent.
- +2 NEW CTR
- SET CTR=0
- +3 IF $DATA(IFN)
- if '$DATA(^LAB(60,IFN,0))
- QUIT
- SET Y(1)=IFN_"^"_$PIECE(^LAB(60,IFN,0),"^")
- QUIT
- +4 SET NAME=""
- FOR
- SET NAME=$ORDER(^LAB(60,"B",NAME))
- if NAME=""
- QUIT
- SET IFN=0
- FOR
- SET IFN=$ORDER(^LAB(60,"B",NAME,IFN))
- if IFN<1
- QUIT
- IF $DATA(^LAB(60,IFN,0))
- SET CTR=CTR+1
- SET Y(CTR)=IFN_"^"_NAME
- +5 QUIT
- +6 ;
- +7 ;
- T64(Y,IFN) ;Get tests from file 64
- +1 ; If IFN is not passed then the whole file is sent, if entry has a link to file 60
- +2 NEW CTR
- SET CTR=0
- +3 IF $DATA(IFN)
- if '$DATA(^LAM(IFN,0))
- QUIT
- if '$DATA(^LAB(60,"AC",IFN))
- QUIT
- SET Y(1)=IFN_"^"_$PIECE(^LAM(IFN,0),"^")
- QUIT
- +4 SET NAME=""
- FOR
- SET NAME=$ORDER(^LAM("B",NAME))
- if NAME=""
- QUIT
- SET IFN=0
- FOR
- SET IFN=$ORDER(^LAM("B",NAME,IFN))
- if IFN<1
- QUIT
- IF $DATA(^LAM(IFN,0))
- IF $DATA(^LAB(60,"AC",IFN))
- SET CTR=CTR+1
- SET Y(CTR)=IFN_"^"_NAME
- +5 QUIT
- +6 ;
- +7 ;
- ORD(LRDFN,IVDT) ;Get order # for entry in file 63
- +1 ; LRDFN=Lab Patient #
- +2 ; IVDT=Inverse Date/time in 63 (^LR(LRDFN,"CH",IVDT))
- +3 if '$GET(LRDFN)
- QUIT
- if '$GET(IVDT)
- QUIT
- +4 NEW X0,X6,X,AC,ACD,ACN
- +5 SET X0=$GET(^LR(LRDFN,"CH",IVDT,0))
- SET X6=$PIECE(X0,"^",6)
- IF X6=""
- QUIT ""
- +6 SET X=$PIECE(X6," ")
- SET X=$ORDER(^LRO(68,"B",X,0))
- IF 'X
- QUIT ""
- +7 SET AC=X
- SET ACD=+$PIECE(X0,".")
- SET ACN=$PIECE(X6," ",3)
- IF '$DATA(^LRO(68,AC,1,ACD,1,ACN,0))
- QUIT ""
- +8 SET X=$PIECE($GET(^LRO(68,AC,1,ACD,1,ACN,.1)),"^")
- +9 QUIT X
- +10 ;
- +11 ;
- ORDP(LRPROV) ; Display ordering provider in comment
- +1 NEW LRY,CNT
- +2 SET LRY=$$NAME^XUSER(LRPROV,"G")
- +3 SET CNT=$ORDER(^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",""),-1)+1
- +4 SET ^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",CNT)="Ordering Provider: "_LRY
- +5 QUIT
- +6 ;
- +7 ;
- RRDT(LRDT) ; Display report released date/time
- +1 NEW LRY,CNT
- +2 IF LRDT
- SET LRY=$$FMTE^XLFDT(LRDT,"M")
- +3 IF '$TEST
- SET LRY=""
- +4 SET CNT=$ORDER(^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",""),-1)+1
- +5 SET ^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",CNT)="Report Released Date/Time: "_LRY
- SET CNT=CNT+1
- +6 QUIT
- +7 ;
- +8 ;
- PLS ; List reporting and performing laboratories
- +1 ; If multiple performing labs then list tests associated with each lab.
- +2 ;
- +3 NEW CNT,LINE,LLEN,LRPLS,LRX,MPLS,PLS,TESTNAME,X
- +4 ;
- +5 SET CNT=$ORDER(^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",""),-1)+1
- +6 ;
- +7 ; Reporting Laboratory
- +8 IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2
- Begin DoDot:1
- +9 SET LRX=+$GET(^LR(LRDFN,"CH",IVDT,"RF"))
- +10 IF LRX<1
- QUIT
- +11 SET LINE=$$PLSADDR^LR7OSUM2(LRX)
- +12 SET ^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",CNT)=" "
- SET CNT=CNT+1
- +13 SET ^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",CNT)="Reporting Lab: "_$PIECE(LINE,"^")
- SET CNT=CNT+1
- +14 SET ^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",CNT)=" "_$PIECE(LINE,"^",2)
- SET CNT=CNT+1
- End DoDot:1
- +15 ;
- +16 SET PLS=$ORDER(^TMP("LRPLS",$JOB,0))
- SET MPLS=0
- +17 ; multiple performing labs
- IF $ORDER(^TMP("LRPLS",$JOB,PLS))
- SET MPLS=1
- +18 SET LRPLS=0
- +19 FOR
- SET LRPLS=$ORDER(^TMP("LRPLS",$JOB,LRPLS))
- if LRPLS<1
- QUIT
- Begin DoDot:1
- +20 SET ^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",CNT)=" "
- SET CNT=CNT+1
- +21 IF MPLS
- Begin DoDot:2
- +22 SET TESTNAME=""
- SET LINE="For test(s): "
- SET LLEN=13
- +23 FOR
- SET TESTNAME=$ORDER(^TMP("LRPLS",$JOB,LRPLS,TESTNAME))
- if TESTNAME=""
- QUIT
- Begin DoDot:3
- +24 SET X=$LENGTH(TESTNAME)
- +25 IF (LLEN+X)>240
- SET ^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",CNT)=LINE
- SET CNT=CNT+1
- SET LINE=""
- SET LLEN=0
- +26 SET LINE=LINE_$SELECT(LLEN>13:", ",1:"")_TESTNAME
- SET LLEN=LLEN+X+$SELECT(LLEN>13:2,1:0)
- End DoDot:3
- +27 IF LINE'=""
- SET ^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",CNT)=LINE
- SET CNT=CNT+1
- End DoDot:2
- +28 SET LINE=$$PLSADDR^LR7OSUM2(LRPLS)
- +29 SET ^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",CNT)="Performing Lab: "_$PIECE(LINE,"^")
- SET CNT=CNT+1
- +30 SET ^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",CNT)=" "_$PIECE(LINE,"^",2)
- SET CNT=CNT+1
- End DoDot:1
- +31 ;
- +32 SET ^TMP("LRRR",$JOB,DFN,"CH",IVDT,"N",CNT)=" "
- +33 ;
- +34 KILL ^TMP("LRPLS",$JOB)
- +35 QUIT