LRRP1 ;DALOI/STAFF - PRINT THE DATA FOR INTERIM REPORTS ;11/18/11 16:33
;;5.2;LAB SERVICE;**153,221,283,286,356,372,350**;Sep 27, 1994;Build 230
;
; from LRRP, LRRP2, LRRP3, LRMIPSU
;
PRINT ;
S:$G(SEX)="" SEX="M" S:$G(DOB)="" DOB="UNKNOWN"
S LRAAO=0 F S LRAAO=$O(^TMP("LR",$J,"TP",LRAAO)) Q:LRAAO<1 D ORDER Q:LRSTOP
K ^TMP("LR",$J,"TP")
Q
;
;
ORDER ;
N LRCAN
S LRCDT=0
F S LRCDT=$O(^TMP("LR",$J,"TP",LRAAO,LRCDT)) Q:LRCDT<1 D
. S LRCAN=0
. I LRSS="CH" D
. . S LRIDT=+^TMP("LR",$J,"TP",LRAAO,LRCDT,-2)
. . F S LRCAN=+$O(^LR(LRDFN,"CH",LRIDT,1,LRCAN)) Q:LRCAN<1 Q:$E($G(^(LRCAN,0)))="*"
. D TEST Q:LRSTOP
Q
;
;
TEST ;
N LRRELDT,LRX
S LRIDT=+^TMP("LR",$J,"TP",LRAAO,LRCDT,-2)
S LRSS=$P(^TMP("LR",$J,"TP",LRAAO),U,2)
S LR0=$S($D(^(LRAAO,LRCDT))#2:^(LRCDT),1:""),LRTC=$P(LR0,U,12)
I LRSS="MI" D Q
. S LRH=1 D:LRFOOT FOOT Q:LRSTOP
. D EN1^LRMIPC
. S LRHF=1,LRFOOT=0
. K A,Z,LRH
. S:LREND LREND=0,LRSTOP=1
;
; Protect against results for AP subscripts being processed from file #69 orders.
I LRSS'="CH" Q
;
Q:'$G(LRCAN)&('$P(LR0,U,3)) D @$S(LRHF:"HDR",1:"CHECK") Q:LRSTOP
S LRSPEC=+$P(LR0,U,5),X=$P(LR0,U,10) D DOC^LRX
;
; Display reporting lab
I $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2 D
. S LRX=+$G(^LR(LRDFN,LRSS,LRIDT,"RF"))
. I LRX D RL(LRX)
;
I LRDOC?1"REF:"1.AN D
. S LRX=$$REFDOC^LRRP1(LRDFN,LRSS,LRIDT)
. I LRX'="" S LRDOC=LRX
W !!,?7,"Provider: ",LRDOC
W !,?7,"Specimen: ",$P($G(^LAB(61,LRSPEC,0),"<no specimen on file>"),U)
D ORU
S LRRELDT=$P(^TMP("LR",$J,"TP",LRAAO,LRCDT),U,3)
W !,"Report Released: ",$$FMTE^XLFDT(LRRELDT,"M")
W !!,?30,"Specimen Collection Date: ",$$FMTE^XLFDT(LRCDT,"M")
W !?5,"Test name",?30,"Result units",?51,"Ref. range",?66,"Site Code"
S LRPO=0
F S LRPO=$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO)) Q:LRPO'>0 S LRDATA=^(LRPO) D DATA Q:LRSTOP
Q:LRSTOP
;
I $D(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C")) D
. W !,"Comment: " S LRCMNT=0
. F S LRCMNT=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) Q:LRCMNT<1 D Q:LRSTOP
. . W ^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)
. . D CONT Q:LRSTOP
. . W:$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) !?9
Q:LRSTOP D EQUALS^LRX
W !?7,"KEY: ""L""=Abnormal low, ""H""=Abnormal high, ""*""=Critical value"
S LRFOOT=1
Q
;
;
DATA ;
N LR63DATA,LRREFS,LRX
;
S LRTSTS=+LRDATA,LRPC=$P(LRDATA,U,5),LRSUB=$P(LRDATA,U,6)
S X=$P(LRDATA,U,7) Q:X=""
S LR63DATA=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,$P(LRDATA,U,10),LRTSTS)
S LRLO=$P(LR63DATA,"^",3),LRHI=$P(LR63DATA,"^",4),LRREFS=$$EN^LRLRRVF(LRLO,LRHI),LRPLS=$P(LR63DATA,"^",6),LRTHER=$P(LR63DATA,"^",7)
I LRPLS S LRPLS(LRPLS)=LRPLS
;
; Find reference lab filler order number
S LREPR=LRDFN_","_LRSS_","_LRIDT_","_$P(LRDATA,"^",10)
S LRX=$O(^LR(LRDFN,"EPR","AD",LREPR,4,""))
I LRX S LREPR(4,LREPR,LRX)=""
;
;W !?5,$S($L($P(LRDATA,U,2))>20:$P(LRDATA,U,3),1:$P(LRDATA,U,2))
; Insure something is printed as test name - either print name or #.01 field
I $L($P(LRDATA,U,2))>25,$P(LRDATA,U,3)'="" W !,$P(LRDATA,U,3)
E W !,$E($P(LRDATA,U,2),1,25)
S X=$P(LR63DATA,"^")
W ?27,@$S(LRPC="":"$J(X,LRCW)",1:LRPC)," ",$P(LR63DATA,"^",2)
I $X>39 W !
W ?40,$P(LR63DATA,U,5)
I $X>50 W !
W ?51,LRREFS
;
I LRPLS'="" D
. I $X>67 W !
. W ?68,"[",LRPLS,"]"
D CONT Q:LRSTOP
;
I $O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,0))>0 D Q:LRSTOP
. S LRINTP=0
. F S LRINTP=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,LRINTP)) Q:LRINTP<1 W !?7,"Eval: ",^(LRINTP) D CONT Q:LRSTOP
;
Q
;
;
CHECK I LRTC+11>(IOSL-$Y) D FOOT Q:LRSTOP D HDR
Q
;
;
CONT I $Y+5>IOSL D FOOT Q:LRSTOP D HDR W !?20,">> CONTINUATION OF ",$P(LR0,U,6)," <<",!
Q
;
;
;
N I
Q:LRSTOP
F I=$Y:1:IOSL-4 W !
;
I $E(IOST,1,2)'="C-" D Q
. W !,PNM,?40," ",SSN," ",$$HTE^XLFDT($H,"1M"),!
;
W !,PNM,?25," ",SSN," ",$$HTE^XLFDT($H,"1M"),?59," PRESS '^' TO STOP "
R X:DTIME S:X="" X=1 S:(".^"[X)!('$T) LRSTOP=1
Q
;
;
HDR ; Add Printed at, page #, change age to dob 7/2002 cka
W:($G(LRJ02))!($G(LRJ0))!($E(IOST,1,2)="C-") @IOF
S LRHF=0,LRJ02=1,LRPG=$G(LRPG)+1
I $E(IOST,1)="P" W !!,$$CJ^XLFSTR("CLINICAL LABORATORY REPORT",IOM),!
;
I $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1 D PFAC(DUZ(2),LRPG)
;
W !!,PNM,?44,"Report date: ",$$HTE^XLFDT($H,"M")
W !?1,"Pat ID: ",SSN," SEX: ",SEX," DOB: ",$$FMTE^XLFDT(DOB)," LOC: ",LROC
Q
;
;
ORU ; Display remote ordering info if available
; Handle calls that don't pass parameters.
D ORUA("",LRDFN,LRSS,LRIDT,0)
Q
;
;
ORUA(LRARRAY,LRDFN,LRSS,LRIDT,LRFLAG) ; Display remote ordering info if available
; Call with LRARRAY = array with name/address info
; LRDFN = file #63 ien
; LRSS = file #63 subscript
; LRIDT = file #63 internal data/time of specimen
; LRFLAG = 0 (print facility info)
; 1 (return facility info in LRARRAY)
;
N A,IENS,LRFILE,LRX,LRY
;
S LRFLAG=$G(LRFLAG,0)
S LRFILE=$S(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,LRSS="BB":63.01,1:0)
S LRX(0)=$G(^LR(LRDFN,LRSS,LRIDT,0))
S LRX("ORU")=$G(^LR(LRDFN,LRSS,LRIDT,"ORU")),IENS=LRIDT_","_LRDFN_","
;
S LRY="Accession [UID]: "_$P(LRX(0),"^",6)_" ["_$P(LRX("ORU"),"^")_"]"
I LRSS="MI",$P(LRX(0),"^",10) S LRY=$$LJ^XLFSTR(LRY,43," ")_" Received: "_$$FMTE^XLFDT($P(LRX(0),"^",10),"M")
I LRFLAG S A(1)=LRY
E D EN^DDIOL(LRY,"","!")
;
I $P(LRX("ORU"),"^",3) D
. S LRY=$$LJ^XLFSTR("Ordering Site: "_$$GET1^DIQ(LRFILE,IENS,.33,""),43," ")_" Ordering Site UID: "_$P(LRX("ORU"),"^",5)
. I LRFLAG S A(2)=LRY
. E D EN^DDIOL(LRY,"","!?2")
;
I $P(LRX("ORU"),"^",2) D
. S LRY="Collecting Site: "_$$GET1^DIQ(LRFILE,IENS,.32,"")
. I LRFLAG=1 S A(3)=LRY
. E D EN^DDIOL(LRY,"","!")
;
I LRFLAG M LRARRAY=A
;
Q
;
;
PFAC(LR4,LRPG,LRFLAG,LRARRAY) ; Display name/address of printing facility
; Call with LR4 = File #4 IEN
; LRPG = current page number to print
; LRFLAG = 0 (print facility info)
; 1 (return facility info in LRARRAY)
; LRARRAY = array with name/address info
;
N A,CLIA,LRX,X
S LRX=$$NAME^XUAF4(LR4),CLIA=$$ID^XUAF4("CLIA",LR4),LRFLAG=$G(LRFLAG,0)
S A(1)="Printed at:"
I $G(LRPG) S A(1)=$$LJ^XLFSTR(A(1),$G(IOM,80)-15)_"page "_LRPG
S A(2)=LRX
I CLIA'="" D
. S X="[CLIA# "_CLIA_"]"
. I $L(A(2))+$L(X)+1>$G(IOM,80) S A(2.5)=X
. E S A(2)=A(2)_" "_X
S LRX=$$PADD^XUAF4(LR4),LRX(1)=$$WHAT^XUAF4(LR4,1.02)
S A(3)=$P(LRX,U)_" "_$S(LRX(1)'="":LRX(1)_" ",1:"")_$P(LRX,U,2)_$S($P(LRX,U,3)'="":", ",1:"")_$P(LRX,U,3)_" "_$P(LRX,U,4)
I 'LRFLAG D
. S A(4)=" "
. S A(1,"F")="?2",A(2,"F")="!?2",A(3,"F")="!?2",A(4,"F")="!"
. I $D(A(2.5)) S A(2.5,"F")="!?2"
. D EN^DDIOL(.A)
I LRFLAG M LRARRAY=A
;
Q
;
;
RL(LR4,LRFLAG,OUT) ; Display name/address of reporting laboratory
; Call with LR4: File #4 IEN
; LRFLAG: <opt> 1=save to OUT array
; OUT: <byref><opt>
;
N A,CLIA,LRX,X,I
S LRFLAG=$G(LRFLAG)
K OUT
S LRX=$$NAME^XUAF4(LR4),CLIA=$$ID^XUAF4("CLIA",LR4)
S A(1)="Reporting Lab:" ;_LRX
S A(2)=LRX
I 'LRFLAG S A(1,"F")="!!?2",A(2,"F")="!?2"
I CLIA'="" D
. S X="[CLIA# "_CLIA_"]"
. I $L(A(2))+$L(X)+1>$G(IOM,80) S A(2.5)=X S:'LRFLAG A(2.5,"F")="!?17"
. E S A(2)=A(2)_" "_X
S LRX=$$PADD^XUAF4(LR4),LRX(1)=$$WHAT^XUAF4(LR4,1.02)
S A(3)=$P(LRX,U)_" "_$P(LRX,U,2)_", "_$P(LRX,U,3)_" "_$P(LRX,U,4)
S A(3)=$P(LRX,U)_" "_$S(LRX(1)'="":LRX(1)_" ",1:"")_$P(LRX,U,2)_$S($P(LRX,U,3)'="":", ",1:"")_$P(LRX,U,3)_" "_$P(LRX,U,4)
I 'LRFLAG D
. S A(4)=" ",A(3,"F")="!?2",A(4,"F")="!"
. I $D(A(2.5)) S A(2.5,"F")="!?2"
. D EN^DDIOL(.A)
I LRFLAG M OUT=A
;
Q
;
;
REFDOC(LRDFN,LRSS,LRIDT) ; Lookup LEDI referral free text provider name in file #63 on "ORUT" subscript
; Call with LRDFN = ien on entry in file #63
; LRSS = file #63 subscript
; LRIDT = inverse specimen date/time
;
; Returns LRY = free text provider found on first test in file #63
;
N LRI,LRX,LRY
S LRI=0,(LRX,LRY)=""
F S LRI=$O(^LR(LRDFN,LRSS,LRIDT,"ORUT",LRI)) Q:'LRI S LRX=$P(^(LRI,0),"^",7) Q:LRX'=""
I LRX'="" S LRY=LRX
Q LRY
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRP1 8321 printed Sep 23, 2025@19:55:30 Page 2
LRRP1 ;DALOI/STAFF - PRINT THE DATA FOR INTERIM REPORTS ;11/18/11 16:33
+1 ;;5.2;LAB SERVICE;**153,221,283,286,356,372,350**;Sep 27, 1994;Build 230
+2 ;
+3 ; from LRRP, LRRP2, LRRP3, LRMIPSU
+4 ;
PRINT ;
+1 if $GET(SEX)=""
SET SEX="M"
if $GET(DOB)=""
SET DOB="UNKNOWN"
+2 SET LRAAO=0
FOR
SET LRAAO=$ORDER(^TMP("LR",$JOB,"TP",LRAAO))
if LRAAO<1
QUIT
DO ORDER
if LRSTOP
QUIT
+3 KILL ^TMP("LR",$JOB,"TP")
+4 QUIT
+5 ;
+6 ;
ORDER ;
+1 NEW LRCAN
+2 SET LRCDT=0
+3 FOR
SET LRCDT=$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT))
if LRCDT<1
QUIT
Begin DoDot:1
+4 SET LRCAN=0
+5 IF LRSS="CH"
Begin DoDot:2
+6 SET LRIDT=+^TMP("LR",$JOB,"TP",LRAAO,LRCDT,-2)
+7 FOR
SET LRCAN=+$ORDER(^LR(LRDFN,"CH",LRIDT,1,LRCAN))
if LRCAN<1
QUIT
if $EXTRACT($GET(^(LRCAN,0)))="*"
QUIT
End DoDot:2
+8 DO TEST
if LRSTOP
QUIT
End DoDot:1
+9 QUIT
+10 ;
+11 ;
TEST ;
+1 NEW LRRELDT,LRX
+2 SET LRIDT=+^TMP("LR",$JOB,"TP",LRAAO,LRCDT,-2)
+3 SET LRSS=$PIECE(^TMP("LR",$JOB,"TP",LRAAO),U,2)
+4 SET LR0=$SELECT($DATA(^(LRAAO,LRCDT))#2:^(LRCDT),1:"")
SET LRTC=$PIECE(LR0,U,12)
+5 IF LRSS="MI"
Begin DoDot:1
+6 SET LRH=1
if LRFOOT
DO FOOT
if LRSTOP
QUIT
+7 DO EN1^LRMIPC
+8 SET LRHF=1
SET LRFOOT=0
+9 KILL A,Z,LRH
+10 if LREND
SET LREND=0
SET LRSTOP=1
End DoDot:1
QUIT
+11 ;
+12 ; Protect against results for AP subscripts being processed from file #69 orders.
+13 IF LRSS'="CH"
QUIT
+14 ;
+15 if '$GET(LRCAN)&('$PIECE(LR0,U,3))
QUIT
DO @$SELECT(LRHF:"HDR",1:"CHECK")
if LRSTOP
QUIT
+16 SET LRSPEC=+$PIECE(LR0,U,5)
SET X=$PIECE(LR0,U,10)
DO DOC^LRX
+17 ;
+18 ; Display reporting lab
+19 IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")#2
Begin DoDot:1
+20 SET LRX=+$GET(^LR(LRDFN,LRSS,LRIDT,"RF"))
+21 IF LRX
DO RL(LRX)
End DoDot:1
+22 ;
+23 IF LRDOC?1"REF:"1.AN
Begin DoDot:1
+24 SET LRX=$$REFDOC^LRRP1(LRDFN,LRSS,LRIDT)
+25 IF LRX'=""
SET LRDOC=LRX
End DoDot:1
+26 WRITE !!,?7,"Provider: ",LRDOC
+27 WRITE !,?7,"Specimen: ",$PIECE($GET(^LAB(61,LRSPEC,0),"<no specimen on file>"),U)
+28 DO ORU
+29 SET LRRELDT=$PIECE(^TMP("LR",$JOB,"TP",LRAAO,LRCDT),U,3)
+30 WRITE !,"Report Released: ",$$FMTE^XLFDT(LRRELDT,"M")
+31 WRITE !!,?30,"Specimen Collection Date: ",$$FMTE^XLFDT(LRCDT,"M")
+32 WRITE !?5,"Test name",?30,"Result units",?51,"Ref. range",?66,"Site Code"
+33 SET LRPO=0
+34 FOR
SET LRPO=$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO))
if LRPO'>0
QUIT
SET LRDATA=^(LRPO)
DO DATA
if LRSTOP
QUIT
+35 if LRSTOP
QUIT
+36 ;
+37 IF $DATA(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C"))
Begin DoDot:1
+38 WRITE !,"Comment: "
SET LRCMNT=0
+39 FOR
SET LRCMNT=+$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT))
if LRCMNT<1
QUIT
Begin DoDot:2
+40 WRITE ^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT)
+41 DO CONT
if LRSTOP
QUIT
+42 if $ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT))
WRITE !?9
End DoDot:2
if LRSTOP
QUIT
End DoDot:1
+43 if LRSTOP
QUIT
DO EQUALS^LRX
+44 WRITE !?7,"KEY: ""L""=Abnormal low, ""H""=Abnormal high, ""*""=Critical value"
+45 SET LRFOOT=1
+46 QUIT
+47 ;
+48 ;
DATA ;
+1 NEW LR63DATA,LRREFS,LRX
+2 ;
+3 SET LRTSTS=+LRDATA
SET LRPC=$PIECE(LRDATA,U,5)
SET LRSUB=$PIECE(LRDATA,U,6)
+4 SET X=$PIECE(LRDATA,U,7)
if X=""
QUIT
+5 SET LR63DATA=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,$PIECE(LRDATA,U,10),LRTSTS)
+6 SET LRLO=$PIECE(LR63DATA,"^",3)
SET LRHI=$PIECE(LR63DATA,"^",4)
SET LRREFS=$$EN^LRLRRVF(LRLO,LRHI)
SET LRPLS=$PIECE(LR63DATA,"^",6)
SET LRTHER=$PIECE(LR63DATA,"^",7)
+7 IF LRPLS
SET LRPLS(LRPLS)=LRPLS
+8 ;
+9 ; Find reference lab filler order number
+10 SET LREPR=LRDFN_","_LRSS_","_LRIDT_","_$PIECE(LRDATA,"^",10)
+11 SET LRX=$ORDER(^LR(LRDFN,"EPR","AD",LREPR,4,""))
+12 IF LRX
SET LREPR(4,LREPR,LRX)=""
+13 ;
+14 ;W !?5,$S($L($P(LRDATA,U,2))>20:$P(LRDATA,U,3),1:$P(LRDATA,U,2))
+15 ; Insure something is printed as test name - either print name or #.01 field
+16 IF $LENGTH($PIECE(LRDATA,U,2))>25
IF $PIECE(LRDATA,U,3)'=""
WRITE !,$PIECE(LRDATA,U,3)
+17 IF '$TEST
WRITE !,$EXTRACT($PIECE(LRDATA,U,2),1,25)
+18 SET X=$PIECE(LR63DATA,"^")
+19 WRITE ?27,@$SELECT(LRPC="":"$J(X,LRCW)",1:LRPC)," ",$PIECE(LR63DATA,"^",2)
+20 IF $X>39
WRITE !
+21 WRITE ?40,$PIECE(LR63DATA,U,5)
+22 IF $X>50
WRITE !
+23 WRITE ?51,LRREFS
+24 ;
+25 IF LRPLS'=""
Begin DoDot:1
+26 IF $X>67
WRITE !
+27 WRITE ?68,"[",LRPLS,"]"
End DoDot:1
+28 DO CONT
if LRSTOP
QUIT
+29 ;
+30 IF $ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,0))>0
Begin DoDot:1
+31 SET LRINTP=0
+32 FOR
SET LRINTP=+$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,LRINTP))
if LRINTP<1
QUIT
WRITE !?7,"Eval: ",^(LRINTP)
DO CONT
if LRSTOP
QUIT
End DoDot:1
if LRSTOP
QUIT
+33 ;
+34 QUIT
+35 ;
+36 ;
CHECK IF LRTC+11>(IOSL-$Y)
DO FOOT
if LRSTOP
QUIT
DO HDR
+1 QUIT
+2 ;
+3 ;
CONT IF $Y+5>IOSL
DO FOOT
if LRSTOP
QUIT
DO HDR
WRITE !?20,">> CONTINUATION OF ",$PIECE(LR0,U,6)," <<",!
+1 QUIT
+2 ;
+3 ;
+1 ;
+2 NEW I
+3 if LRSTOP
QUIT
+4 FOR I=$Y:1:IOSL-4
WRITE !
+5 ;
+6 IF $EXTRACT(IOST,1,2)'="C-"
Begin DoDot:1
+7 WRITE !,PNM,?40," ",SSN," ",$$HTE^XLFDT($HOROLOG,"1M"),!
End DoDot:1
QUIT
+8 ;
+9 WRITE !,PNM,?25," ",SSN," ",$$HTE^XLFDT($HOROLOG,"1M"),?59," PRESS '^' TO STOP "
+10 READ X:DTIME
if X=""
SET X=1
if (".^"[X)!('$TEST)
SET LRSTOP=1
+11 QUIT
+12 ;
+13 ;
HDR ; Add Printed at, page #, change age to dob 7/2002 cka
+1 if ($GET(LRJ02))!($GET(LRJ0))!($EXTRACT(IOST,1,2)="C-")
WRITE @IOF
+2 SET LRHF=0
SET LRJ02=1
SET LRPG=$GET(LRPG)+1
+3 IF $EXTRACT(IOST,1)="P"
WRITE !!,$$CJ^XLFSTR("CLINICAL LABORATORY REPORT",IOM),!
+4 ;
+5 IF $$GET^XPAR("DIV^PKG","LR REPORTS FACILITY PRINT",1,"Q")>1
DO PFAC(DUZ(2),LRPG)
+6 ;
+7 WRITE !!,PNM,?44,"Report date: ",$$HTE^XLFDT($HOROLOG,"M")
+8 WRITE !?1,"Pat ID: ",SSN," SEX: ",SEX," DOB: ",$$FMTE^XLFDT(DOB)," LOC: ",LROC
+9 QUIT
+10 ;
+11 ;
ORU ; Display remote ordering info if available
+1 ; Handle calls that don't pass parameters.
+2 DO ORUA("",LRDFN,LRSS,LRIDT,0)
+3 QUIT
+4 ;
+5 ;
ORUA(LRARRAY,LRDFN,LRSS,LRIDT,LRFLAG) ; Display remote ordering info if available
+1 ; Call with LRARRAY = array with name/address info
+2 ; LRDFN = file #63 ien
+3 ; LRSS = file #63 subscript
+4 ; LRIDT = file #63 internal data/time of specimen
+5 ; LRFLAG = 0 (print facility info)
+6 ; 1 (return facility info in LRARRAY)
+7 ;
+8 NEW A,IENS,LRFILE,LRX,LRY
+9 ;
+10 SET LRFLAG=$GET(LRFLAG,0)
+11 SET LRFILE=$SELECT(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,LRSS="BB":63.01,1:0)
+12 SET LRX(0)=$GET(^LR(LRDFN,LRSS,LRIDT,0))
+13 SET LRX("ORU")=$GET(^LR(LRDFN,LRSS,LRIDT,"ORU"))
SET IENS=LRIDT_","_LRDFN_","
+14 ;
+15 SET LRY="Accession [UID]: "_$PIECE(LRX(0),"^",6)_" ["_$PIECE(LRX("ORU"),"^")_"]"
+16 IF LRSS="MI"
IF $PIECE(LRX(0),"^",10)
SET LRY=$$LJ^XLFSTR(LRY,43," ")_" Received: "_$$FMTE^XLFDT($PIECE(LRX(0),"^",10),"M")
+17 IF LRFLAG
SET A(1)=LRY
+18 IF '$TEST
DO EN^DDIOL(LRY,"","!")
+19 ;
+20 IF $PIECE(LRX("ORU"),"^",3)
Begin DoDot:1
+21 SET LRY=$$LJ^XLFSTR("Ordering Site: "_$$GET1^DIQ(LRFILE,IENS,.33,""),43," ")_" Ordering Site UID: "_$PIECE(LRX("ORU"),"^",5)
+22 IF LRFLAG
SET A(2)=LRY
+23 IF '$TEST
DO EN^DDIOL(LRY,"","!?2")
End DoDot:1
+24 ;
+25 IF $PIECE(LRX("ORU"),"^",2)
Begin DoDot:1
+26 SET LRY="Collecting Site: "_$$GET1^DIQ(LRFILE,IENS,.32,"")
+27 IF LRFLAG=1
SET A(3)=LRY
+28 IF '$TEST
DO EN^DDIOL(LRY,"","!")
End DoDot:1
+29 ;
+30 IF LRFLAG
MERGE LRARRAY=A
+31 ;
+32 QUIT
+33 ;
+34 ;
PFAC(LR4,LRPG,LRFLAG,LRARRAY) ; Display name/address of printing facility
+1 ; Call with LR4 = File #4 IEN
+2 ; LRPG = current page number to print
+3 ; LRFLAG = 0 (print facility info)
+4 ; 1 (return facility info in LRARRAY)
+5 ; LRARRAY = array with name/address info
+6 ;
+7 NEW A,CLIA,LRX,X
+8 SET LRX=$$NAME^XUAF4(LR4)
SET CLIA=$$ID^XUAF4("CLIA",LR4)
SET LRFLAG=$GET(LRFLAG,0)
+9 SET A(1)="Printed at:"
+10 IF $GET(LRPG)
SET A(1)=$$LJ^XLFSTR(A(1),$GET(IOM,80)-15)_"page "_LRPG
+11 SET A(2)=LRX
+12 IF CLIA'=""
Begin DoDot:1
+13 SET X="[CLIA# "_CLIA_"]"
+14 IF $LENGTH(A(2))+$LENGTH(X)+1>$GET(IOM,80)
SET A(2.5)=X
+15 IF '$TEST
SET A(2)=A(2)_" "_X
End DoDot:1
+16 SET LRX=$$PADD^XUAF4(LR4)
SET LRX(1)=$$WHAT^XUAF4(LR4,1.02)
+17 SET A(3)=$PIECE(LRX,U)_" "_$SELECT(LRX(1)'="":LRX(1)_" ",1:"")_$PIECE(LRX,U,2)_$SELECT($PIECE(LRX,U,3)'="":", ",1:"")_$PIECE(LRX,U,3)_" "_$PIECE(LRX,U,4)
+18 IF 'LRFLAG
Begin DoDot:1
+19 SET A(4)=" "
+20 SET A(1,"F")="?2"
SET A(2,"F")="!?2"
SET A(3,"F")="!?2"
SET A(4,"F")="!"
+21 IF $DATA(A(2.5))
SET A(2.5,"F")="!?2"
+22 DO EN^DDIOL(.A)
End DoDot:1
+23 IF LRFLAG
MERGE LRARRAY=A
+24 ;
+25 QUIT
+26 ;
+27 ;
RL(LR4,LRFLAG,OUT) ; Display name/address of reporting laboratory
+1 ; Call with LR4: File #4 IEN
+2 ; LRFLAG: <opt> 1=save to OUT array
+3 ; OUT: <byref><opt>
+4 ;
+5 NEW A,CLIA,LRX,X,I
+6 SET LRFLAG=$GET(LRFLAG)
+7 KILL OUT
+8 SET LRX=$$NAME^XUAF4(LR4)
SET CLIA=$$ID^XUAF4("CLIA",LR4)
+9 ;_LRX
SET A(1)="Reporting Lab:"
+10 SET A(2)=LRX
+11 IF 'LRFLAG
SET A(1,"F")="!!?2"
SET A(2,"F")="!?2"
+12 IF CLIA'=""
Begin DoDot:1
+13 SET X="[CLIA# "_CLIA_"]"
+14 IF $LENGTH(A(2))+$LENGTH(X)+1>$GET(IOM,80)
SET A(2.5)=X
if 'LRFLAG
SET A(2.5,"F")="!?17"
+15 IF '$TEST
SET A(2)=A(2)_" "_X
End DoDot:1
+16 SET LRX=$$PADD^XUAF4(LR4)
SET LRX(1)=$$WHAT^XUAF4(LR4,1.02)
+17 SET A(3)=$PIECE(LRX,U)_" "_$PIECE(LRX,U,2)_", "_$PIECE(LRX,U,3)_" "_$PIECE(LRX,U,4)
+18 SET A(3)=$PIECE(LRX,U)_" "_$SELECT(LRX(1)'="":LRX(1)_" ",1:"")_$PIECE(LRX,U,2)_$SELECT($PIECE(LRX,U,3)'="":", ",1:"")_$PIECE(LRX,U,3)_" "_$PIECE(LRX,U,4)
+19 IF 'LRFLAG
Begin DoDot:1
+20 SET A(4)=" "
SET A(3,"F")="!?2"
SET A(4,"F")="!"
+21 IF $DATA(A(2.5))
SET A(2.5,"F")="!?2"
+22 DO EN^DDIOL(.A)
End DoDot:1
+23 IF LRFLAG
MERGE OUT=A
+24 ;
+25 QUIT
+26 ;
+27 ;
REFDOC(LRDFN,LRSS,LRIDT) ; Lookup LEDI referral free text provider name in file #63 on "ORUT" subscript
+1 ; Call with LRDFN = ien on entry in file #63
+2 ; LRSS = file #63 subscript
+3 ; LRIDT = inverse specimen date/time
+4 ;
+5 ; Returns LRY = free text provider found on first test in file #63
+6 ;
+7 NEW LRI,LRX,LRY
+8 SET LRI=0
SET (LRX,LRY)=""
+9 FOR
SET LRI=$ORDER(^LR(LRDFN,LRSS,LRIDT,"ORUT",LRI))
if 'LRI
QUIT
SET LRX=$PIECE(^(LRI,0),"^",7)
if LRX'=""
QUIT
+10 IF LRX'=""
SET LRY=LRX
+11 QUIT LRY
