LR7OSUM4 ;VA/SLC/DCM - Silent Patient cum cont. ; 17-Oct-2014 09:22 ; MKK
;;5.2;LR;**1002,121,187,228,241,251,1018,1021,1028,1031,1033,1034**;NOV 01, 1997;Build 88
;
BS ; EP -- from LR7OSUM3
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
NEW P3,P6
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
K I,^TMP($J,"TY")
S LRCW=10,LRHI="",LRLO="",LRTT=1,I=0,LRTY=GIOM-20\10,LRMU=LRMU+1,LRII=0
F S LRII=$O(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII)) Q:LRII<1 S Z=^(LRII,0),P3=$P(Z,U,3),P6=$P(Z,U,6),I=I+1,I(I)=LRII,^TMP($J,"TY",0,I)=P3 S:P6 ^TMP($J,"TY",I,"D")=P6
;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
;K P3,P6
;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
F K=1:1:(LRTY-1) S LRFDT=$O(^TMP($J,LRDFN,LRMH,LRSH,LRFDT)) Q:LRFDT<1 S Z=^(LRFDT,0),^TMP($J,"TY",K,"L")=$P(Z,U,1),LRTT=LRTT+1 S:LRFDT>LRLFDT LRLFDT=LRFDT D UDT^LR7OSUM3 D BS1
S:LRTT>(LRTY-1)&(LRMULT=1) LRFULL=1
S:LRTT>(LRTY-1)&(LRMU=(LRMULT-1)) LRFULL=1
F I=1:1:LRSHD D LRLO^LR7OSUM5 S:$L(LRLOHI) ^TMP($J,"TY",(LRTT+1),I)=LRLOHI S:$L(P7) ^TMP($J,"TY",LRTT,I)=P7
S ^TMP($J,"TY",LRTT,"T")="Units",^TMP($J,"TY",(LRTT+1),"T")="Ranges",^TMP($J,"TY",(LRTT+1),0)=$S($L($P(^LAB(64.5,"A",1,LRMH,LRSH,I(1)),U,11)):"Therapeutic",1:"Reference"),^TMP($J,"TY",LRTT,0)=""
D LINE
D LN
S ^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(CCNT,CCNT,$E(LRTOPP,1,7))
F I=1:1:(LRTT+1) S ^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(I*10-4,CCNT,$J(^TMP($J,"TY",I,0),10))
D LN
S XZ="",$P(XZ," ",3)="",^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(CCNT,CCNT,XZ)
F I=1:1:(LRTT-1) S ^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(I*10-4,CCNT,$J(^TMP($J,"Y2K",I),10))
D LN
S XZ="",$P(XZ," ",3)="",^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(CCNT,CCNT,XZ)
F I=1:1:(LRTT+1) S ^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(I*10-4,CCNT,$J(^TMP($J,"TY",I,"T"),10))
D LN
S XZ="",$P(XZ,"-",GIOM)="",^TMP("LRC",$J,GCNT,0)=XZ
F I=1:1:LRSHD S LRCL=8,LRG=^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0) D LN S ^TMP("LRC",$J,GCNT,0)="" D BS4
I $D(LRTX) D LN S LRTX="",^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,"Comments: ") F I=1:1 S LRTX=$O(LRTX(LRTX)) Q:LRTX="" S ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(10*LRTX-6,CCNT,$C(96+(I#26))_$S(I\26>0:I\26,1:""))
D TXT1^LR7OSUM5
S LROFDT=LRFDT
I $D(LRTX) S LRTX="" F I=1:1 S LRTX=$O(LRTX(LRTX)) Q:LRTX="" D LN S LRFDT=LRTX(LRTX),^TMP("LRC",$J,GCNT,0)=$$S^LR7OS(1,CCNT,$C(96+(I#26))_$S(I\26>0:I\26,1:"")_". ") D TXT^LR7OSUM5
S LRFDT=LROFDT
K LRTY,LRTX,^TMP($J,"TY")
I 'LRFDT G LRSH^LR7OSUM3
I $O(^TMP($J,LRDFN,LRMH,LRSH,LRFDT))="" G LRSH^LR7OSUM3
S LRFDT=LRLFDT
I LRFULL D HEAD^LR7OSUM6,LRNP^LR7OSUM3 S LRFULL=0,LRMU=0
G BS
BS1 ;
S ^TMP($J,"TY",K,0)=$P(LRUDT," ",1),^TMP($J,"TY",K,"T")=$P(LRUDT," ",2),^TMP($J,"Y2K",K)=$E($P($P($$Y2K^LRX(9999999-LRFDT),"."),"/",3),1,4)
F J=1:1:LRSHD S:$D(^TMP($J,LRDFN,LRMH,LRSH,LRFDT,I(J))) ^TMP($J,"TY",K,J)=^(I(J)) S:$D(^TMP($J,LRDFN,LRMH,LRSH,LRFDT,"TX"))&'$D(LRTX(LRTT)) LRTX(LRTT)=LRFDT
Q
BS2 ;
S X=$S($D(^TMP($J,"TY",J,I)):$P(^(I),U,1),1:""),X1=$S($L(X):$P(^TMP($J,"TY",J,I),U,2),1:""),LRDP=$S($D(^TMP($J,"TY",I,"D")):^("D"),1:""),LRCL=LRCL+10
K T1,T3
Q
BS4 F J=0:1:(LRTT+1) S XZ="",$P(XZ," ",LRCL)="" D
. I J=0 S X=^TMP($J,"TY",J,I),^TMP("LRC",$J,GCNT,0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(J*10,CCNT,X) S:'$P($G(^TMP("LRT",$J,X)),"^",2) $P(^TMP("LRT",$J,X),"^",2)=GCNT
. I J>0 D
.. D BS2
.. I J=(LRTT+1) D BS2RRCHK ; IHS/MSC/MKK - LR*5.2*1031 - Reference Range double-check
.. I J<LRTT D BS2DPCHK ; IHS/MSC/MKK - LR*5.2*1031 - Leading and/or trailing zero(s) check
.. I $L(X) S LRCW=10 D C1^LR7OSUM5(.X,.X1) S:$L($P(LRG,U,4))&(J<LRTT) @("X="_$P(LRG,"^",4)),^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(J*10-2,CCNT,X_X1) D
... ; S:'$L($P(LRG,U,4))!(J'<LRTT) ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(J*10-2,CCNT,$J(X,LRCW))
... ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1028
... I '$L($P(LRG,U,4))!(J'<LRTT) D
.... I J'<LRTT&(X=+X) S X=$P($G(^BLRUCUM(X,0)),U,3)
.... S ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(J*10-2,CCNT,$J(X,LRCW))
... ; ----- END IHS/OIT/MKK - LR*5.2*1028
Q
LN ;Increment the counter
S GCNT=GCNT+1,CCNT=1
Q
LINE ;Fill in the global with blank lines
N X
D LN
S X="",$P(X," ",GIOM)="",^TMP("LRC",$J,GCNT,0)=X
Q
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
BS2RRCHK ; EP - Reference Range double-check: make sure they reflect values in File 60 if not in File 63
NEW DATANAME,F6O,LRSS,OLDHI,OLDLO,OLDX,REFHI,REFLO,SITESPEC,STR
NEW CNT,DN,DP
;
; Get Dataname Decimal definition
S DN=+$P($P(LRG,"^",5),";",2) ; Data Name number
S STR=$P($G(^DD(63.04,DN,0)),"^",5)
S DP=+$P($P(STR,",",3),$C(34))
;
; Save off old variables
S OLDX=X
S STR=$TR(X," ")
S OLDLO=$P(STR,"-")
S OLDHI=$P(STR,"-",2)
;
; First, check to see if Ref values are in file 63
S LRSS=$P($P(LRG,"^",5),";")
S LRSS=$S($L(LRSS):LRSS,1:"<NO>") ; Make sure LRSS has a value
S DATANAME=+$P($P(LRG,"^",5),";",2)
S STR=$P($G(^LR(+LRDFN,LRSS,+LRLFDT,DATANAME)),"^",5)
;
Q:STR["$S" ; IHS/MSC/MKK - LR*5.2*1033 DEBUG - Skip if $SELECT statment -- cannot parse for all sites.
Q:$L(STR)<1&(($G(REFLO)["$")!($G(REFHI)["$")) ; IHS/MSC/MKK - LR*5.2*1034
;
I $L(STR) D
. S REFLO=$P(STR,"!",2)
. S REFHI=$P(STR,"!",3)
;
I $L(STR)<1 D
. S F60=+$G(LRG)
. S SITESPEC=+$G(LRSPM)
. Q:F60<1!(SITESPEC<1) ; Skip if no test or no Site/Specimen
. ;
. S STR=$G(^LAB(60,F60,1,SITESPEC,0))
. Q:$L(STR)<1 ; Skip if no Reference Ranges
. ;
. S REFLO=$P(STR,"^",2)
. S REFHI=$P(STR,"^",3)
;
Q:$L($G(REFLO))<1&($L($G(REFHI))<1) ; Skip if no Reference Ranges defined
;
I $G(REFLO)["$S" D ; If $S in Reference Range, set to value
. S REFLO="REFLO="_REFLO
. S @REFLO
;
I $G(REFHI)["$S" D ; If $S in Reference Range, set to value
. S REFHI="REFHI="_REFHI
. S @REFHI
;
Q:$G(REFLO)[$C(34)&($L(REFHI)<1) ; Skip if REFLO is a string & No REFHI
Q:$G(REFHI)[$C(34)&($L(REFLO)<1) ; Skip if REFHI is a string & No REFLO
;
; Make sure REFLO & REFHI have some sort of value
S:$L(REFLO)<1 REFLO=OLDLO
S:$L(REFHI)<1 REFHI=OLDHI
;
; Set up the decimals, if possible
I DP>0 D
. S:+REFLO>0 REFLO=$TR($FN(REFLO,"P",DP)," ")
. S:+REFHI>0 REFHI=$TR($FN(REFHI,"P",DP)," ")
;
Q:OLDLO=REFLO&(OLDHI=REFHI) ; Skip if double-check is the same
;
S X=REFLO_" - "_REFHI
Q
;
;
BS2DPCHK ; EP - Check Result to determine if it needs leading and/or trailing zero(s)
Q:$L(X)<1 ; Skip if no result
;
NEW DN,DP,ORIGRLST,RESULT,STR,SYMBOL
S DN=+$P($P(LRG,"^",5),";",2) ; Data Name number
Q:DN<1 ; Skip if no Data Name number
;
Q:$G(^DD(63.04,DN,0))'["^LRNUM" ; Skip if no numeric defintiion
;
S STR=$P($P($G(^DD(63.04,DN,0)),"Q9=",2),$C(34),2) ; Get numeric formatting
;
S DP=+$P(STR,",",3) ; Decimal Places
Q:DP<1 ; Skip if no Decimal Defintion
;
S RESULT=$G(X)
;
Q:$$UP^XLFSTR($G(RESULT))["SPECIMEN IN LAB" ; Skip if not resulted
;
S SYMBOL="",ORIGRSLT=RESULT
F Q:$E(RESULT)?1N!(RESULT="") D ; Adjust if ANY Non-Numeric is at the beginning of RESULT
. S SYMBOL=SYMBOL_$E(RESULT)
. S RESULT=$E(RESULT,2,$L(RESULT))
;
I $E(RESULT)'?1N S RESULT=ORIGRSLT Q ; Skip if RESULT has no numeric part
;
S:$E(RESULT)="." RESULT="0"_RESULT ; Leading Zero Fix
;
S RESULT=$TR($FN(RESULT,"P",DP)," ")
;
S:$L($G(SYMBOL)) RESULT=SYMBOL_RESULT ; Restore "symbol", if necessary
;
S X=RESULT ; Reset X
Q
; ----- END IHS/MSC/MKK - LR*5.2*1031
LR7OSUM4 ;VA/SLC/DCM - Silent Patient cum cont. ; 17-Oct-2014 09:22 ; MKK
+1 ;;5.2;LR;**1002,121,187,228,241,251,1018,1021,1028,1031,1033,1034**;NOV 01, 1997;Build 88
+2 ;
BS ; EP -- from LR7OSUM3
+1 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
+2 NEW P3,P6
+3 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
+4 KILL I,^TMP($JOB,"TY")
+5 SET LRCW=10
SET LRHI=""
SET LRLO=""
SET LRTT=1
SET I=0
SET LRTY=GIOM-20\10
SET LRMU=LRMU+1
SET LRII=0
+6 FOR
SET LRII=$ORDER(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRII))
IF LRII<1
QUIT
SET Z=^(LRII,0)
SET P3=$PIECE(Z,U,3)
SET P6=$PIECE(Z,U,6)
SET I=I+1
SET I(I)=LRII
SET ^TMP($JOB,"TY",0,I)=P3
IF P6
SET ^TMP($JOB,"TY",I,"D")=P6
+7 ;----- BEGIN IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
+8 ;K P3,P6
+9 ;----- END IHS/OIT/MKK MODIFICATIONS LR*5.2*1021
+10 FOR K=1:1:(LRTY-1)
SET LRFDT=$ORDER(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT))
IF LRFDT<1
QUIT
SET Z=^(LRFDT,0)
SET ^TMP($JOB,"TY",K,"L")=$PIECE(Z,U,1)
SET LRTT=LRTT+1
IF LRFDT>LRLFDT
SET LRLFDT=LRFDT
DO UDT^LR7OSUM3
DO BS1
+11 IF LRTT>(LRTY-1)&(LRMULT=1)
SET LRFULL=1
+12 IF LRTT>(LRTY-1)&(LRMU=(LRMULT-1))
SET LRFULL=1
+13 FOR I=1:1:LRSHD
DO LRLO^LR7OSUM5
IF $LENGTH(LRLOHI)
SET ^TMP($JOB,"TY",(LRTT+1),I)=LRLOHI
IF $LENGTH(P7)
SET ^TMP($JOB,"TY",LRTT,I)=P7
+14 SET ^TMP($JOB,"TY",LRTT,"T")="Units"
SET ^TMP($JOB,"TY",(LRTT+1),"T")="Ranges"
SET ^TMP($JOB,"TY",(LRTT+1),0)=$SELECT($LENGTH($PIECE(^LAB(64.5,"A",1,LRMH,LRSH,I(1)),U,11)):"Therapeutic",1:"Reference")
SET ^TMP($JOB,"TY",LRTT,0)=""
+15 DO LINE
+16 DO LN
+17 SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(CCNT,CCNT,$EXTRACT(LRTOPP,1,7))
+18 FOR I=1:1:(LRTT+1)
SET ^TMP("LRC",$JOB,GCNT,0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(I*10-4,CCNT,$JUSTIFY(^TMP($JOB,"TY",I,0),10))
+19 DO LN
+20 SET XZ=""
SET $PIECE(XZ," ",3)=""
SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(CCNT,CCNT,XZ)
+21 FOR I=1:1:(LRTT-1)
SET ^TMP("LRC",$JOB,GCNT,0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(I*10-4,CCNT,$JUSTIFY(^TMP($JOB,"Y2K",I),10))
+22 DO LN
+23 SET XZ=""
SET $PIECE(XZ," ",3)=""
SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(CCNT,CCNT,XZ)
+24 FOR I=1:1:(LRTT+1)
SET ^TMP("LRC",$JOB,GCNT,0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(I*10-4,CCNT,$JUSTIFY(^TMP($JOB,"TY",I,"T"),10))
+25 DO LN
+26 SET XZ=""
SET $PIECE(XZ,"-",GIOM)=""
SET ^TMP("LRC",$JOB,GCNT,0)=XZ
+27 FOR I=1:1:LRSHD
SET LRCL=8
SET LRG=^LAB(64.5,1,1,LRMH,1,LRSH,1,I(I),0)
DO LN
SET ^TMP("LRC",$JOB,GCNT,0)=""
DO BS4
+28 IF $DATA(LRTX)
DO LN
SET LRTX=""
SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,"Comments: ")
FOR I=1:1
SET LRTX=$ORDER(LRTX(LRTX))
IF LRTX=""
QUIT
SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(10*LRTX-6,CCNT,$CHAR(96+(I#26))_$SELECT(I\26>0:I\26,1:""))
+29 DO TXT1^LR7OSUM5
+30 SET LROFDT=LRFDT
+31 IF $DATA(LRTX)
SET LRTX=""
FOR I=1:1
SET LRTX=$ORDER(LRTX(LRTX))
IF LRTX=""
QUIT
DO LN
SET LRFDT=LRTX(LRTX)
SET ^TMP("LRC",$JOB,GCNT,0)=$$S^LR7OS(1,CCNT,$CHAR(96+(I#26))_$SELECT(I\26>0:I\26,1:"")_". ")
DO TXT^LR7OSUM5
+32 SET LRFDT=LROFDT
+33 KILL LRTY,LRTX,^TMP($JOB,"TY")
+34 IF 'LRFDT
GOTO LRSH^LR7OSUM3
+35 IF $ORDER(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT))=""
GOTO LRSH^LR7OSUM3
+36 SET LRFDT=LRLFDT
+37 IF LRFULL
DO HEAD^LR7OSUM6
DO LRNP^LR7OSUM3
SET LRFULL=0
SET LRMU=0
+38 GOTO BS
BS1 ;
+1 SET ^TMP($JOB,"TY",K,0)=$PIECE(LRUDT," ",1)
SET ^TMP($JOB,"TY",K,"T")=$PIECE(LRUDT," ",2)
SET ^TMP($JOB,"Y2K",K)=$EXTRACT($PIECE($PIECE($$Y2K^LRX(9999999-LRFDT),"."),"/",3),1,4)
+2 FOR J=1:1:LRSHD
IF $DATA(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,I(J)))
SET ^TMP($JOB,"TY",K,J)=^(I(J))
IF $DATA(^TMP($JOB,LRDFN,LRMH,LRSH,LRFDT,"TX"))&'$DATA(LRTX(LRTT))
SET LRTX(LRTT)=LRFDT
+3 QUIT
BS2 ;
+1 SET X=$SELECT($DATA(^TMP($JOB,"TY",J,I)):$PIECE(^(I),U,1),1:"")
SET X1=$SELECT($LENGTH(X):$PIECE(^TMP($JOB,"TY",J,I),U,2),1:"")
SET LRDP=$SELECT($DATA(^TMP($JOB,"TY",I,"D")):^("D"),1:"")
SET LRCL=LRCL+10
+2 KILL T1,T3
+3 QUIT
BS4 FOR J=0:1:(LRTT+1)
SET XZ=""
SET $PIECE(XZ," ",LRCL)=""
Begin DoDot:1
+1 IF J=0
SET X=^TMP($JOB,"TY",J,I)
SET ^TMP("LRC",$JOB,GCNT,0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(J*10,CCNT,X)
IF '$PIECE($GET(^TMP("LRT",$JOB,X)),"^",2)
SET $PIECE(^TMP("LRT",$JOB,X),"^",2)=GCNT
+2 IF J>0
Begin DoDot:2
+3 DO BS2
+4 ; IHS/MSC/MKK - LR*5.2*1031 - Reference Range double-check
IF J=(LRTT+1)
DO BS2RRCHK
+5 ; IHS/MSC/MKK - LR*5.2*1031 - Leading and/or trailing zero(s) check
IF J<LRTT
DO BS2DPCHK
+6 IF $LENGTH(X)
SET LRCW=10
DO C1^LR7OSUM5(.X,.X1)
IF $LENGTH($PIECE(LRG,U,4))&(J<LRTT)
SET @("X="_$PIECE(LRG,"^",4))
SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(J*10-2,CCNT,X_X1)
Begin DoDot:3
+7 ; S:'$L($P(LRG,U,4))!(J'<LRTT) ^(0)=^TMP("LRC",$J,GCNT,0)_$$S^LR7OS(J*10-2,CCNT,$J(X,LRCW))
+8 ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1028
+9 IF '$LENGTH($PIECE(LRG,U,4))!(J'<LRTT)
Begin DoDot:4
+10 IF J'<LRTT&(X=+X)
SET X=$PIECE($GET(^BLRUCUM(X,0)),U,3)
+11 SET ^(0)=^TMP("LRC",$JOB,GCNT,0)_$$S^LR7OS(J*10-2,CCNT,$JUSTIFY(X,LRCW))
End DoDot:4
+12 ; ----- END IHS/OIT/MKK - LR*5.2*1028
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
LN ;Increment the counter
+1 SET GCNT=GCNT+1
SET CCNT=1
+2 QUIT
LINE ;Fill in the global with blank lines
+1 NEW X
+2 DO LN
+3 SET X=""
SET $PIECE(X," ",GIOM)=""
SET ^TMP("LRC",$JOB,GCNT,0)=X
+4 QUIT
+5 ;
+6 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
BS2RRCHK ; EP - Reference Range double-check: make sure they reflect values in File 60 if not in File 63
+1 NEW DATANAME,F6O,LRSS,OLDHI,OLDLO,OLDX,REFHI,REFLO,SITESPEC,STR
+2 NEW CNT,DN,DP
+3 ;
+4 ; Get Dataname Decimal definition
+5 ; Data Name number
SET DN=+$PIECE($PIECE(LRG,"^",5),";",2)
+6 SET STR=$PIECE($GET(^DD(63.04,DN,0)),"^",5)
+7 SET DP=+$PIECE($PIECE(STR,",",3),$CHAR(34))
+8 ;
+9 ; Save off old variables
+10 SET OLDX=X
+11 SET STR=$TRANSLATE(X," ")
+12 SET OLDLO=$PIECE(STR,"-")
+13 SET OLDHI=$PIECE(STR,"-",2)
+14 ;
+15 ; First, check to see if Ref values are in file 63
+16 SET LRSS=$PIECE($PIECE(LRG,"^",5),";")
+17 ; Make sure LRSS has a value
SET LRSS=$SELECT($LENGTH(LRSS):LRSS,1:"<NO>")
+18 SET DATANAME=+$PIECE($PIECE(LRG,"^",5),";",2)
+19 SET STR=$PIECE($GET(^LR(+LRDFN,LRSS,+LRLFDT,DATANAME)),"^",5)
+20 ;
+21 ; IHS/MSC/MKK - LR*5.2*1033 DEBUG - Skip if $SELECT statment -- cannot parse for all sites.
IF STR["$S"
QUIT
+22 ; IHS/MSC/MKK - LR*5.2*1034
IF $LENGTH(STR)<1&(($GET(REFLO)["$")!($GET(REFHI)["$"))
QUIT
+23 ;
+24 IF $LENGTH(STR)
Begin DoDot:1
+25 SET REFLO=$PIECE(STR,"!",2)
+26 SET REFHI=$PIECE(STR,"!",3)
End DoDot:1
+27 ;
+28 IF $LENGTH(STR)<1
Begin DoDot:1
+29 SET F60=+$GET(LRG)
+30 SET SITESPEC=+$GET(LRSPM)
+31 ; Skip if no test or no Site/Specimen
IF F60<1!(SITESPEC<1)
QUIT
+32 ;
+33 SET STR=$GET(^LAB(60,F60,1,SITESPEC,0))
+34 ; Skip if no Reference Ranges
IF $LENGTH(STR)<1
QUIT
+35 ;
+36 SET REFLO=$PIECE(STR,"^",2)
+37 SET REFHI=$PIECE(STR,"^",3)
End DoDot:1
+38 ;
+39 ; Skip if no Reference Ranges defined
IF $LENGTH($GET(REFLO))<1&($LENGTH($GET(REFHI))<1)
QUIT
+40 ;
+41 ; If $S in Reference Range, set to value
IF $GET(REFLO)["$S"
Begin DoDot:1
+42 SET REFLO="REFLO="_REFLO
+43 SET @REFLO
End DoDot:1
+44 ;
+45 ; If $S in Reference Range, set to value
IF $GET(REFHI)["$S"
Begin DoDot:1
+46 SET REFHI="REFHI="_REFHI
+47 SET @REFHI
End DoDot:1
+48 ;
+49 ; Skip if REFLO is a string & No REFHI
IF $GET(REFLO)[$CHAR(34)&($LENGTH(REFHI)<1)
QUIT
+50 ; Skip if REFHI is a string & No REFLO
IF $GET(REFHI)[$CHAR(34)&($LENGTH(REFLO)<1)
QUIT
+51 ;
+52 ; Make sure REFLO & REFHI have some sort of value
+53 IF $LENGTH(REFLO)<1
SET REFLO=OLDLO
+54 IF $LENGTH(REFHI)<1
SET REFHI=OLDHI
+55 ;
+56 ; Set up the decimals, if possible
+57 IF DP>0
Begin DoDot:1
+58 IF +REFLO>0
SET REFLO=$TRANSLATE($FNUMBER(REFLO,"P",DP)," ")
+59 IF +REFHI>0
SET REFHI=$TRANSLATE($FNUMBER(REFHI,"P",DP)," ")
End DoDot:1
+60 ;
+61 ; Skip if double-check is the same
IF OLDLO=REFLO&(OLDHI=REFHI)
QUIT
+62 ;
+63 SET X=REFLO_" - "_REFHI
+64 QUIT
+65 ;
+66 ;
BS2DPCHK ; EP - Check Result to determine if it needs leading and/or trailing zero(s)
+1 ; Skip if no result
IF $LENGTH(X)<1
QUIT
+2 ;
+3 NEW DN,DP,ORIGRLST,RESULT,STR,SYMBOL
+4 ; Data Name number
SET DN=+$PIECE($PIECE(LRG,"^",5),";",2)
+5 ; Skip if no Data Name number
IF DN<1
QUIT
+6 ;
+7 ; Skip if no numeric defintiion
IF $GET(^DD(63.04,DN,0))'["^LRNUM"
QUIT
+8 ;
+9 ; Get numeric formatting
SET STR=$PIECE($PIECE($GET(^DD(63.04,DN,0)),"Q9=",2),$CHAR(34),2)
+10 ;
+11 ; Decimal Places
SET DP=+$PIECE(STR,",",3)
+12 ; Skip if no Decimal Defintion
IF DP<1
QUIT
+13 ;
+14 SET RESULT=$GET(X)
+15 ;
+16 ; Skip if not resulted
IF $$UP^XLFSTR($GET(RESULT))["SPECIMEN IN LAB"
QUIT
+17 ;
+18 SET SYMBOL=""
SET ORIGRSLT=RESULT
+19 ; Adjust if ANY Non-Numeric is at the beginning of RESULT
FOR
IF $EXTRACT(RESULT)?1N!(RESULT="")
QUIT
Begin DoDot:1
+20 SET SYMBOL=SYMBOL_$EXTRACT(RESULT)
+21 SET RESULT=$EXTRACT(RESULT,2,$LENGTH(RESULT))
End DoDot:1
+22 ;
+23 ; Skip if RESULT has no numeric part
IF $EXTRACT(RESULT)'?1N
SET RESULT=ORIGRSLT
QUIT
+24 ;
+25 ; Leading Zero Fix
IF $EXTRACT(RESULT)="."
SET RESULT="0"_RESULT
+26 ;
+27 SET RESULT=$TRANSLATE($FNUMBER(RESULT,"P",DP)," ")
+28 ;
+29 ; Restore "symbol", if necessary
IF $LENGTH($GET(SYMBOL))
SET RESULT=SYMBOL_RESULT
+30 ;
+31 ; Reset X
SET X=RESULT
+32 QUIT
+33 ; ----- END IHS/MSC/MKK - LR*5.2*1031
