BLRALBA ;VA/DALOI/RWF/BA-PRINT THE DATA FOR INTERIM REPORTS ;JUL 06, 2010 3:14 PM
;;5.2;IHS LABORATORY;**1013,1015,1022,1025,1027**;NOV 01, 1997
;
;**Program Description**
; This program is copied from program, LRRP1 and
; modified to set the data into a temporary global
; instead of displaying on a report or to the screen.
;
PRINT S BLRADSP=0,$P(BLRABLKS," ",80)=""
S:'$L($G(SEX)) SEX="M" S:'$L($G(AGE)) AGE=99
S LRTC=$P(LR0,U,12)
S LRSPEC=+$P(LR0,U,5),X=$P(LR0,U,10) D DOC^LRX
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)="Ordering Provider: "_LRDOC
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,9)_"Specimen: "_$P($G(^LAB(61,LRSPEC,0)),U)
S LRAAO=0
PORD S LRAAO=$O(^TMP("LR",$J,"TP",LRAAO)) G EXIT:LRAAO=""
D ORDER
G PORD
;
EXIT K ^TMP("LR",$J,"TP")
;Q ;IHS/ITSC/TPF 12/04/01 REMOVED PER MITRTEK
;
S LRORU=$G(^LR(LRDFN,LRSS,LRIDT,"ORU")) Q:LRORU=""
I $D(^LRO(68,"C",LRORU)) D
. S LRAA=$O(^LRO(68,"C",LRORU,"")) Q:'LRAA
. S LRAD=$O(^LRO(68,"C",LRORU,LRAA,"")) Q:'LRAD
. S LRAN=$O(^LRO(68,"C",LRORU,LRAA,LRAD,"")) Q:'LRAN
;
Q:+$G(LRAA)<1!(+$G(LRAD)<1)!(+$G(LRAN)<1) ; IHS/OIT/MKK - LR*5.2*1027
;
NEW TST
S TST=0
F S TST=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST)) Q:'TST D
. I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST,0)),U,5)="" D
.. S LRDN=$P($P($G(^LAB(60,TST,0)),U,5),";",2)
.. ; Do not combine the 3 if statements below into 1 ;DAOU/DJW 1/23/02
.. I '$D(LRDN) D PEND Q
.. I $G(LRDN)="" D PEND Q
.. I '$D(^LR(LRDFN,LRSS,LRIDT,LRDN)) D PEND Q
Q
;
PEND ; Set up this test to be displayed as pending
S BLRAZ=$P($G(^LAB(60,TST,0)),U,1),BLRAZ1=30 D Z1
S BLRAZ=BLRAZ_"pending" D Z1
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
Q
;
ORDER S LRCDT=0
TST S LRCDT=$O(^TMP("LR",$J,"TP",LRAAO,LRCDT)) Q:LRCDT=""
D TEST
G TST
TEST S LRIDT=9999999-LRCDT,LRSS=$P($G(^TMP("LR",$J,"TP",LRAAO)),U,2)
;
; Microbiology
I LRSS="MI" S LRH=1,LRHF=1,LRFOOT=0 K A,Z,LRH Q
;
Q:'$P(LR0,U,3)
D ORU
D LIN
S Y=LRCDT D DD^LRX
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,30)_Y
S BLRAZ=$E(BLRABLKS,1,5)_"Test name",BLRAZ1=30 D Z1
S BLRAZ=BLRAZ_"Result units",BLRAZ1=21 D Z1
S BLRAZ=BLRAZ_$E(BLRABLKS,1,6)_"Ref. range"
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
;
S LRPO=0 F S LRPO=$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO)) Q:LRPO'>0 S LRDATA=^(LRPO) D DATA
I $D(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C")) D
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)="Comment: "
. S LRCMNT=0 F S LRCMNT=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) Q:LRCMNT<1 D
.. S ^TMP($J,"BLRA",BLRADSP,0)=$G(^TMP($J,"BLRA",BLRADSP,0))_$G(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT))
.. I $O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,9)
Q
DATA S LRTSTS=+LRDATA,LRPC=$P(LRDATA,U,5),LRSUB=$P(LRDATA,U,6)
S X=$P(LRDATA,U,7),LRFFLG=$P(LRDATA,U,8) Q:X=""
S BLRAZ=$S($L($P(LRDATA,U,2))>20:$P(LRDATA,U,3),1:$P(LRDATA,U,2))
S BLRAZ1=27 D Z1
;
; If value to display is an executable
I LRPC'="" D
. S BLRAZZ="S X="_LRPC
. X BLRAZZ
. S LRPC=X
;
S BLRAZ=BLRAZ_$S(LRPC="":$J(X,LRCW),1:LRPC)_" "_LRFFLG
S X=$S($D(^LAB(60,LRTSTS,1,LRSPEC,0)):^(0),1:"")
;Q:'$L(X)
S LRTHER=$S($L($P(X,U,11,12))>1:1,1:0)
S LRLO=$S(LRTHER:$P(X,U,11),1:$P(X,U,2))
; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025
I $G(LRLO)'["$"&($E($RE(LRLO),1,1)=".") S LRLO=$RE($P($RE(LRLO),".",2,999))
; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025
S LRHI=$S(LRTHER:$P(X,U,12),1:$P(X,U,3))
; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025
I $G(LRHI)'["$"&($E($RE(LRHI),1,1)=".") S LRHI=$RE($P($RE(LRHI),".",2,999))
; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025
;
S @("LRLO="_$S($L(LRLO):LRLO,1:""""""))
S @("LRHI="_$S($L(LRHI):LRHI,1:""""""))
; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025
; The changes that were implemented below DO NOT work if the
; reference ranges are $SELECT statements. Therefore, they
; are being commented out.
; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1022
; The preceding two lines will fail with a <SYNTAX> error if the
; LRLO or the LRHI variables end in periods; viz., 20.
;
; In order to ensure that a variable that ends with a period does not
; adversely effect any other code, the next two lines of code will
; reset the LRLO and/or the LRHI variable, if necessary.
;
I $P(LRLO,".",2)="" S LRLO=$P(LRLO,".")
I $P(LRHI,".",2)="" S LRHI=$P(LRHI,".")
; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1022
; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025
;
S BLRAZ=BLRAZ,BLRAZ1=40 D Z1
S BLRAZ=BLRAZ_$P(X,U,7),BLRAZ1=51 D Z1
S BLRAZ=BLRAZ_$J(LRLO,4)_$S($L(LRHI):" - "_$J(LRHI,4),1:"")
S BLRAZ1=12 D Z1
S BLRAZ=BLRAZ_$S(LRTHER:"(Ther. range)",1:"")
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
I $O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,0))>0 D
. S LRINTP=0
. F S LRINTP=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,LRINTP)) Q:LRINTP<1 D
.. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,7)_"Eval: "_$G(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,LRINTP))
Q
;
HDR ;EP
; Header Information
I $G(BLRABLKS)="" S $P(BLRABLKS," ",80)=""
S LRHF=0,LRJ02=1,VALMHDR(1)=" "
I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG") S VALMHDR(1)="** PERSONAL DATA - PRIVACY ACT OF 1974 **"
S BLRAZ=PNM,BLRAZ1=60 D Z1
S A8=$P($H,",",2),Y=A8\3600_":"_$E((A8\60#60+100),2,3)
S VALMHDR(2)=BLRAZ_$$FMTE^XLFDT(DT)_" "_Y
S VALMHDR(3)=$E(BLRABLKS,1,5)_"HRCN: "_HRCN_" SEX: "_SEX_" AGE: "_AGE_" LOC: "_$G(LROC)
Q
;
ORU ; Display remote ordering info if available
N LRX
S LRX=$G(^LR(LRDFN,"CH",LRIDT,"ORU"))
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=" Accession [UID]: "_$P(LR0,U,6)_" ["_$P(LRX,U)_"]"
I $P(LRX,U,2) D
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,2)="Ordering Site: "_$$EXTERNAL^DILFD(63.04,.32,"",$P(LRX,U,2))
. S BLRAZ=" Ordering Site UID: "_$P(LRX,U,5),BLRZ1=43 D Z1
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
I $P(LRX,U,3) D
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)="Collecting Site: "_$$EXTERNAL^DILFD(63.04,.33,"",$P(LRX,U,3))
Q
;
Z1 ; Pad with trailing spaces
F BLRAI=1:1:(BLRAZ1-$L(BLRAZ)) S BLRAZ=BLRAZ_" "
Q
;
LIN ;EP
; Set a Blank Line
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=" "
Q
BLRALBA ;VA/DALOI/RWF/BA-PRINT THE DATA FOR INTERIM REPORTS ;JUL 06, 2010 3:14 PM
+1 ;;5.2;IHS LABORATORY;**1013,1015,1022,1025,1027**;NOV 01, 1997
+2 ;
+3 ;**Program Description**
+4 ; This program is copied from program, LRRP1 and
+5 ; modified to set the data into a temporary global
+6 ; instead of displaying on a report or to the screen.
+7 ;
PRINT SET BLRADSP=0
SET $PIECE(BLRABLKS," ",80)=""
+1 IF '$LENGTH($GET(SEX))
SET SEX="M"
IF '$LENGTH($GET(AGE))
SET AGE=99
+2 SET LRTC=$PIECE(LR0,U,12)
+3 SET LRSPEC=+$PIECE(LR0,U,5)
SET X=$PIECE(LR0,U,10)
DO DOC^LRX
+4 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)="Ordering Provider: "_LRDOC
+5 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=$EXTRACT(BLRABLKS,1,9)_"Specimen: "_$PIECE($GET(^LAB(61,LRSPEC,0)),U)
+6 SET LRAAO=0
PORD SET LRAAO=$ORDER(^TMP("LR",$JOB,"TP",LRAAO))
IF LRAAO=""
GOTO EXIT
+1 DO ORDER
+2 GOTO PORD
+3 ;
EXIT KILL ^TMP("LR",$JOB,"TP")
+1 ;Q ;IHS/ITSC/TPF 12/04/01 REMOVED PER MITRTEK
+2 ;
+3 SET LRORU=$GET(^LR(LRDFN,LRSS,LRIDT,"ORU"))
IF LRORU=""
QUIT
+4 IF $DATA(^LRO(68,"C",LRORU))
Begin DoDot:1
+5 SET LRAA=$ORDER(^LRO(68,"C",LRORU,""))
IF 'LRAA
QUIT
+6 SET LRAD=$ORDER(^LRO(68,"C",LRORU,LRAA,""))
IF 'LRAD
QUIT
+7 SET LRAN=$ORDER(^LRO(68,"C",LRORU,LRAA,LRAD,""))
IF 'LRAN
QUIT
End DoDot:1
+8 ;
+9 ; IHS/OIT/MKK - LR*5.2*1027
IF +$GET(LRAA)<1!(+$GET(LRAD)<1)!(+$GET(LRAN)<1)
QUIT
+10 ;
+11 NEW TST
+12 SET TST=0
+13 FOR
SET TST=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST))
IF 'TST
QUIT
Begin DoDot:1
+14 IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TST,0)),U,5)=""
Begin DoDot:2
+15 SET LRDN=$PIECE($PIECE($GET(^LAB(60,TST,0)),U,5),";",2)
+16 ; Do not combine the 3 if statements below into 1 ;DAOU/DJW 1/23/02
+17 IF '$DATA(LRDN)
DO PEND
QUIT
+18 IF $GET(LRDN)=""
DO PEND
QUIT
+19 IF '$DATA(^LR(LRDFN,LRSS,LRIDT,LRDN))
DO PEND
QUIT
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
PEND ; Set up this test to be displayed as pending
+1 SET BLRAZ=$PIECE($GET(^LAB(60,TST,0)),U,1)
SET BLRAZ1=30
DO Z1
+2 SET BLRAZ=BLRAZ_"pending"
DO Z1
+3 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+4 QUIT
+5 ;
ORDER SET LRCDT=0
TST SET LRCDT=$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT))
IF LRCDT=""
QUIT
+1 DO TEST
+2 GOTO TST
TEST SET LRIDT=9999999-LRCDT
SET LRSS=$PIECE($GET(^TMP("LR",$JOB,"TP",LRAAO)),U,2)
+1 ;
+2 ; Microbiology
+3 IF LRSS="MI"
SET LRH=1
SET LRHF=1
SET LRFOOT=0
KILL A,Z,LRH
QUIT
+4 ;
+5 IF '$PIECE(LR0,U,3)
QUIT
+6 DO ORU
+7 DO LIN
+8 SET Y=LRCDT
DO DD^LRX
+9 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=$EXTRACT(BLRABLKS,1,30)_Y
+10 SET BLRAZ=$EXTRACT(BLRABLKS,1,5)_"Test name"
SET BLRAZ1=30
DO Z1
+11 SET BLRAZ=BLRAZ_"Result units"
SET BLRAZ1=21
DO Z1
+12 SET BLRAZ=BLRAZ_$EXTRACT(BLRABLKS,1,6)_"Ref. range"
+13 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+14 ;
+15 SET LRPO=0
FOR
SET LRPO=$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO))
IF LRPO'>0
QUIT
SET LRDATA=^(LRPO)
DO DATA
+16 IF $DATA(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C"))
Begin DoDot:1
+17 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)="Comment: "
+18 SET LRCMNT=0
FOR
SET LRCMNT=+$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT))
IF LRCMNT<1
QUIT
Begin DoDot:2
+19 SET ^TMP($JOB,"BLRA",BLRADSP,0)=$GET(^TMP($JOB,"BLRA",BLRADSP,0))_$GET(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT))
+20 IF $ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,"C",LRCMNT))
SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=$EXTRACT(BLRABLKS,1,9)
End DoDot:2
End DoDot:1
+21 QUIT
DATA SET LRTSTS=+LRDATA
SET LRPC=$PIECE(LRDATA,U,5)
SET LRSUB=$PIECE(LRDATA,U,6)
+1 SET X=$PIECE(LRDATA,U,7)
SET LRFFLG=$PIECE(LRDATA,U,8)
IF X=""
QUIT
+2 SET BLRAZ=$SELECT($LENGTH($PIECE(LRDATA,U,2))>20:$PIECE(LRDATA,U,3),1:$PIECE(LRDATA,U,2))
+3 SET BLRAZ1=27
DO Z1
+4 ;
+5 ; If value to display is an executable
+6 IF LRPC'=""
Begin DoDot:1
+7 SET BLRAZZ="S X="_LRPC
+8 XECUTE BLRAZZ
+9 SET LRPC=X
End DoDot:1
+10 ;
+11 SET BLRAZ=BLRAZ_$SELECT(LRPC="":$JUSTIFY(X,LRCW),1:LRPC)_" "_LRFFLG
+12 SET X=$SELECT($DATA(^LAB(60,LRTSTS,1,LRSPEC,0)):^(0),1:"")
+13 ;Q:'$L(X)
+14 SET LRTHER=$SELECT($LENGTH($PIECE(X,U,11,12))>1:1,1:0)
+15 SET LRLO=$SELECT(LRTHER:$PIECE(X,U,11),1:$PIECE(X,U,2))
+16 ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025
+17 IF $GET(LRLO)'["$"&($EXTRACT($REVERSE(LRLO),1,1)=".")
SET LRLO=$REVERSE($PIECE($REVERSE(LRLO),".",2,999))
+18 ; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025
+19 SET LRHI=$SELECT(LRTHER:$PIECE(X,U,12),1:$PIECE(X,U,3))
+20 ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025
+21 IF $GET(LRHI)'["$"&($EXTRACT($REVERSE(LRHI),1,1)=".")
SET LRHI=$REVERSE($PIECE($REVERSE(LRHI),".",2,999))
+22 ; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025
+23 ;
+24 SET @("LRLO="_$SELECT($LENGTH(LRLO):LRLO,1:""""""))
+25 SET @("LRHI="_$SELECT($LENGTH(LRHI):LRHI,1:""""""))
+26 ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1025
+27 ; The changes that were implemented below DO NOT work if the
+28 ; reference ranges are $SELECT statements. Therefore, they
+29 ; are being commented out.
+30 ; ----- BEGIN IHS/OIT/MKK MODIFICATION LR*5.2*1022
+31 ; The preceding two lines will fail with a <SYNTAX> error if the
+32 ; LRLO or the LRHI variables end in periods; viz., 20.
+33 ;
+34 ; In order to ensure that a variable that ends with a period does not
+35 ; adversely effect any other code, the next two lines of code will
+36 ; reset the LRLO and/or the LRHI variable, if necessary.
+37 ;
+38 IF $PIECE(LRLO,".",2)=""
SET LRLO=$PIECE(LRLO,".")
+39 IF $PIECE(LRHI,".",2)=""
SET LRHI=$PIECE(LRHI,".")
+40 ; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1022
+41 ; ----- END IHS/OIT/MKK MODIFICATION LR*5.2*1025
+42 ;
+43 SET BLRAZ=BLRAZ
SET BLRAZ1=40
DO Z1
+44 SET BLRAZ=BLRAZ_$PIECE(X,U,7)
SET BLRAZ1=51
DO Z1
+45 SET BLRAZ=BLRAZ_$JUSTIFY(LRLO,4)_$SELECT($LENGTH(LRHI):" - "_$JUSTIFY(LRHI,4),1:"")
+46 SET BLRAZ1=12
DO Z1
+47 SET BLRAZ=BLRAZ_$SELECT(LRTHER:"(Ther. range)",1:"")
+48 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+49 IF $ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,0))>0
Begin DoDot:1
+50 SET LRINTP=0
+51 FOR
SET LRINTP=+$ORDER(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,LRINTP))
IF LRINTP<1
QUIT
Begin DoDot:2
+52 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=$EXTRACT(BLRABLKS,1,7)_"Eval: "_$GET(^TMP("LR",$JOB,"TP",LRAAO,LRCDT,LRPO,LRINTP))
End DoDot:2
End DoDot:1
+53 QUIT
+54 ;
HDR ;EP
+1 ; Header Information
+2 IF $GET(BLRABLKS)=""
SET $PIECE(BLRABLKS," ",80)=""
+3 SET LRHF=0
SET LRJ02=1
SET VALMHDR(1)=" "
+4 IF $DATA(DUZ("AG"))
IF $LENGTH(DUZ("AG"))
IF "ARMYAFN"[DUZ("AG")
SET VALMHDR(1)="** PERSONAL DATA - PRIVACY ACT OF 1974 **"
+5 SET BLRAZ=PNM
SET BLRAZ1=60
DO Z1
+6 SET A8=$PIECE($HOROLOG,",",2)
SET Y=A8\3600_":"_$EXTRACT((A8\60#60+100),2,3)
+7 SET VALMHDR(2)=BLRAZ_$$FMTE^XLFDT(DT)_" "_Y
+8 SET VALMHDR(3)=$EXTRACT(BLRABLKS,1,5)_"HRCN: "_HRCN_" SEX: "_SEX_" AGE: "_AGE_" LOC: "_$GET(LROC)
+9 QUIT
+10 ;
ORU ; Display remote ordering info if available
+1 NEW LRX
+2 SET LRX=$GET(^LR(LRDFN,"CH",LRIDT,"ORU"))
+3 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=" Accession [UID]: "_$PIECE(LR0,U,6)_" ["_$PIECE(LRX,U)_"]"
+4 IF $PIECE(LRX,U,2)
Begin DoDot:1
+5 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=$EXTRACT(BLRABLKS,1,2)="Ordering Site: "_$$EXTERNAL^DILFD(63.04,.32,"",$PIECE(LRX,U,2))
+6 SET BLRAZ=" Ordering Site UID: "_$PIECE(LRX,U,5)
SET BLRZ1=43
DO Z1
+7 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
End DoDot:1
+8 IF $PIECE(LRX,U,3)
Begin DoDot:1
+9 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)="Collecting Site: "_$$EXTERNAL^DILFD(63.04,.33,"",$PIECE(LRX,U,3))
End DoDot:1
+10 QUIT
+11 ;
Z1 ; Pad with trailing spaces
+1 FOR BLRAI=1:1:(BLRAZ1-$LENGTH(BLRAZ))
SET BLRAZ=BLRAZ_" "
+2 QUIT
+3 ;
LIN ;EP
+1 ; Set a Blank Line
+2 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=" "
+3 QUIT
