LR7OSUM1 ;VA/DALOI/dcm - Silent Patient cum cont. ; Mar 11, 2003
;;5.2;LAB SERVICE;**1003,1031**;NOV 1, 1997
;
;;VA LR Patche(s): 121,187,256,286,384
;
LRIDT ; from LR7OSUM
F S LRIDT=$O(^LR(LRDFN,"CH",LRIDT)) Q:LRIDT<1!(LRIDT>LROUT)!(CT1>COUNT) I $D(^(LRIDT,0)) S X=^(0),CT1=CT1+1 D LRIIDT
Q
;
LRIIDT ;
S (LRIIDT,LRVIDT)=$P(X,U,1),LRSUB=1,LRTNN=1,LRSPM=$P(X,U,5),LRTLOC=$E($P(X,U,11),1,7),LRVDT=$P(X,U,3),LRAN=$P(X,U,6)
Q:'$L(LRVDT)
D LRSUB
Q
;
;
LRSUB ;
N LRTRES
S LRSUB=1
F S LRSUB=$O(^LR(LRDFN,"CH",LRIDT,LRSUB)) Q:LRSUB<1 D
. S X=^LR(LRDFN,"CH",LRIDT,LRSUB)
. S LRTRES=$$TSTRES^LRRPU(LRDFN,"CH",LRIDT,LRSUB,"")
. D SUB1
Q
SUB1 ;
S LRTSTVAL=$P(X,U,1),X1=$P(X,U,2)
S LRNOFL="",LRTST=$O(^LAB(60,"C","CH;"_LRSUB_";"_1,0))
Q:LRTST=""
Q:"IN"[$P(^LAB(60,LRTST,0),U,3)
I '$D(^LAB(64.5,"AC",LRSUB)) D MISC Q
K LRNON
D LRMH
I '$D(LRNON) D MISC
Q
;
LRMH ;
S LRMH=0
F S LRMH=$O(^LAB(64.5,"AC",LRSUB,1,LRMH)) Q:LRMH<1 D LRSH
Q
;
LRSH ;
S LRSH=0
F S LRSH=$O(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH)) Q:LRSH<1 D TST
Q
;
TST ;
S LRTSTS=0
F S LRTSTS=$O(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH,LRTSTS)) Q:'LRTSTS S LRSPM1=^(LRTSTS) D TST1
Q
;
;
TST1 ;
Q:LRSPM'=LRSPM1
SBSET ;
S LRMHN=$P(^LAB(64.5,1,1,LRMH,0),U,1),LRTF=^(1,LRSH,0),$P(LRTF,U,4)=$P(LRTF,U,3),$P(LRTF,U,3)=$P(^(1,0),U,4),LRNON=1
Q:$S('$D(SUBHEAD):0,1:'$D(SUBHEAD($P(LRTF,"^"))))
;
;** LRTE=Total minor headings
;** LRMHN=Major heading name^TE^Lab performing tests
;** LRTF=Minor header^Profile specimen^Total tests^Type of display
;
S LRIIDT=LRVIDT
S:'$D(^TMP($J,LRDFN,LRMH)) ^(LRMH)=LRMHN
S:'$D(^TMP($J,LRDFN,LRMH,LRSH))!($D(^(LRSH))=10) ^(LRSH)=LRTF_U
S:'$D(^TMP($J,LRDFN,LRMH,LRSH,LRIDT,0)) ^(0)=LRTLOC_U_LRVIDT_U_LRVDT_U_LRAN_U_LRIDT
;
LRTSTVAL ;
;
S ^TMP($J,LRDFN,LRMH,LRSH,LRIDT,LRTSTS)=$P(LRTRES,"^")_"^"_$P(LRTRES,"^",2)
S X=$P($G(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRTSTS,0)),"^",3)
I $L(X) S ^TMP("LRT",$J,X)=$P(LRTF,"^")
I $D(^LR(LRDFN,"CH",LRIDT,1,0)),'$D(^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",0)) D TEXT
D CHKUN
I $O(^LAB(60,LRTST,1,LRSPM,1,0)),'$D(^TMP($J,"EVAL",LRTST,LRSPM)) D
. S ^TMP($J,"EVAL",LRTST,LRSPM)=""
. N I,L,X,TST
. S I=0,TST=$S($L($P($G(^LAB(60,LRTST,.1)),"^")):$P(^(.1),"^"),1:$P(^LAB(60,LRTST,0),"^"))
. S L=+$O(^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",9999999),-1),L=L+1,^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)="Evaluation for "_TST_":"
. F S I=$O(^LAB(60,LRTST,1,LRSPM,1,I)) Q:'I S X=^(I,0) S L=L+1,^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=X
Q
;
;
MISC ;
Q:$S('$D(SUBHEAD):0,1:'$D(SUBHEAD("MISCELLANEOUS TESTS")))
S LRTST=$O(^LAB(60,"C","CH;"_LRSUB_";"_1,0))
Q:LRTST=""
Q:"IN"[$P(^LAB(60,LRTST,0),U,3)
S LRTOP=LRSPM
;
D ZEROFIX ; IHS/MSC/MKK - LR*5.2*1031
;
S:'$D(^TMP($J,LRDFN,"MISC",LRIDT,0)) ^(0)=LRIDT_U_LRVIDT_U_LRVDT_U_LRAN_U_LRSPM
;S ^TMP($J,LRDFN,"MISC",LRIDT,LRTNN)=LRTSTVAL_U_LRSPM_U_LRTST_U_X1_U_LRSUB
; S ^TMP($J,LRDFN,"MISC",LRIDT,LRTNN)=$P(LRTRES,"^")_U_LRSPM_U_LRTST_U_$P(LRTRES,"^",2)_U_LRSUB_U_$P(LRTRES,"^",3,6)
;
; ----- BEGIN IHS/OIT/MKK -- LR*5.2*1027
; If the result of the test is free text, it's possible that the
; the $L(LRTRES)>30, which is too wide for 80-char screen AND the
; text of the result needs to be wrapped.
S:$L($P(LRTRES,"^"))<31 ^TMP($J,LRDFN,"MISC",LRIDT,LRTNN)=$P(LRTRES,"^")_U_LRSPM_U_LRTST_U_$P(LRTRES,"^",2)_U_LRSUB_U_$P(LRTRES,"^",3,6)
I $L($P(LRTRES,"^"))>30 D
. NEW CRLF,LINE,RESULT,WRAPPED
. S RESULT(1)=$P(LRTRES,"^")
. D WRAP^BLRUTIL3("RESULT",29)
. S LINE=1
. S CRLF=$C(13)_$C(10)
. S WRAPPED=$G(^TMP("BLRUTIL3",$J,LINE,0))
. F S LINE=$O(^TMP("BLRUTIL3",$J,LINE)) Q:LINE<1 D
.. S WRAPPED=WRAPPED_CRLF_$J("",49)_$G(^TMP("BLRUTIL3",$J,LINE,0))
. S ^TMP($J,LRDFN,"MISC",LRIDT,LRTNN)=WRAPPED_U_LRSPM_U_LRTST_U_$P(LRTRES,"^",2)_U_LRSUB_U_$P(LRTRES,"^",3,6)
. K ^TMP("BLRUTIL3",$J)
; ----- END IHS/OIT/MKK -- LR*5.2*1027
;
S X=$S($D(^LAB(60,LRTST,.1)):$P(^(.1),"^"),1:$P(^LAB(60,LRTST,0),"^")),^TMP("LRT",$J,X)="MISCELLANEOUS TESTS"
;
; Grab specimen comments
I $D(^LR(LRDFN,"CH",LRIDT,1,0)),'$D(^TMP($J,LRDFN,"MISC",LRIDT,"TX",0)) D
. S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",0)="",L=0
. ; F S L=$O(^LR(LRDFN,"CH",LRIDT,1,L)) Q:L<1 S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
. ; BEGIN -- IHS/OIT/MKK - LR*5.2*1027
. NEW ADDRFLAG
. S ADDRFLAG="NO"
. F S L=$O(^LR(LRDFN,"CH",LRIDT,1,L)) Q:L<1 D
.. S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
.. I $G(^LR(LRDFN,"CH",LRIDT,1,L,0))["Test Performed at" S ADDRFLAG="YES"
. ;
. I ADDRFLAG="YES" D
.. S L=1+$O(^LR(LRDFN,"CH",LRIDT,1,L),-1)
.. S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)=" " ; Put in extra "space" -- better readibility
. ; END -- IHS/OIT/MKK - LR*5.2*1027
;
; Grab test interpretation
I $O(^LAB(60,LRTST,1,LRSPM,1,0)) D
. N I,L,X,TST
. S I=0,TST=$S($L($P($G(^LAB(60,LRTST,.1)),"^")):$P(^(.1),"^"),1:$P(^LAB(60,LRTST,0),"^"))
. S:'$D(^TMP($J,LRDFN,"MISC",LRIDT,"TX",0)) ^TMP($J,LRDFN,"MISC",LRIDT,"TX",0)=""
. S L=+$O(^TMP($J,LRDFN,"MISC",LRIDT,"TX",9999999),-1),L=L+1
. S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)="Evaluation for "_TST_":"
. F S I=$O(^LAB(60,LRTST,1,LRSPM,1,I)) Q:'I S X=^(I,0) S L=L+1,^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)=X
;
S LRTNN=LRTNN+1
Q
;
;
TEXT ;
S LRYESCOM=0
S M=0
F S M=$O(^LR(LRDFN,"CH",LRIDT,1,M)) Q:M<1!(LRYESCOM) F N=1:1:$L(^LR(LRDFN,"CH",LRIDT,1,M,0)) Q:LRYESCOM S:$E(^(0),N)'[$C(32) LRYESCOM=1
Q:'LRYESCOM
S L=0
F S L=$O(^LR(LRDFN,"CH",LRIDT,1,L)) Q:L<1 S ^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
Q
;
;
MICRO ;from LR7OSUM
Q:'$D(^LR(LRDFN,"MI"))
N MICROCNT
S:'$D(LRUNKNOW) LRUNKNOW=$P(^LAB(69.9,1,1),U,5)
S (LRONESPC,LRONETST)="",LREND=0,MICROCNT=GCNT+1
I $O(^LR(LRDFN,"MI",0)) S ^TMP("LRH",$J,"MICROBIOLOGY")=MICROCNT
S LRWRDVEW="",LRSB=0,LRIDT=LRIN
F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1!(LRIDT>LROUT)!(CT1>COUNT) S LRNLOC=LRLLOC,CT1=CT1+1 D EN1^LR7OSMZ0 S LRLLOC=LRNLOC
I GCNT'>MICROCNT K ^TMP("LRH",$J,"MICROBIOLOGY")
K %,A,A1,AGE,B,B1,DFN,DOB,DZ,I,J,LR2ORMOR,LRAA,LRACC,LRACN,LRAD,LRADM,LRADX,LRAFS,LRAX,LRBUG,LRCMNT,LRCS,LRDCOM,LREF,LREND,LRIFN,LRLLT,LRMD,LRNLOC,LRNS,LROK,LRONESPC,LRONETST,LRORG,LRPRE,LRPRINT
Q
;
;
CHKUN ; Check units and normals with cumulative report values
; Add comment if these differ from file #64.5 values
;
N I,L,LRFLAG,LRHI,LRLO,LRLOHI,LRX,LRY,TST
S LRX=$G(^LAB(64.5,"A",1,LRMH,LRSH,LRTSTS)),LRFLAG=0
S TST=$P($G(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRTSTS,0)),"^",3)
S LRY="*** For test "_TST
; Check units - if different generate comment
I $$UP^XLFSTR($P(LRX,"^",7))'=$$UP^XLFSTR($P(LRTRES,"^",5)) S LRY=LRY_" Units: "_$P(LRTRES,"^",5),LRFLAG=1
;
; Check normals - if different generate comment
S @("LRLO="_$S($P(LRX,"^",2)'="":$P(LRX,"^",2),$P(LRX,"^",11)'="":$P(LRX,"^",11),1:""""""))
;
S @("LRHI="_$S($P(LRX,"^",3)'="":$P(LRX,"^",3),$P(LRX,"^",12)'="":$P(LRX,"^",12),1:""""""))
I LRLO'=$P(LRTRES,"^",3)!(LRHI'=$P(LRTRES,"^",4)) D
. ; check to see if these values are numeric and are different because of leading or trailing zeroes
. I '$$REALDIFF Q
. I LRFLAG S LRY=LRY_" and"
. S LRY=LRY_" Normals: "_$P(LRTRES,"^",3)_"-"_$P(LRTRES,"^",4),LRFLAG=1
;
I 'LRFLAG Q
;
S L=+$O(^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",9999999),-1),L=L+1
S LRY=LRY_" ***",^TMP($J,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=LRY
Q
;
;
REALDIFF() ;
; function to determine if values are numeric and are different
; solely because of leading or trailing zeroes
; returns 0 if difference is because of leading/trailing zeroes
; returns 1 if differences are meaningful
N LRTRESLO,LRTRESHI,DIFF
S LRTRESLO=$P(LRTRES,"^",3),LRTRESHI=$P(LRTRES,"^",4)
S DIFF=0
I LRLO'=LRTRESLO S DIFF=1 D
. I LRLO?.N!(LRLO?.N1".".N) D
. . I LRTRESLO?.N!(LRTRESLO?.N1".".N) D
. . . I +LRLO=+LRTRESLO S DIFF=0
I DIFF Q 1
I LRHI'=LRTRESHI S DIFF=1 D
. I LRHI?.N!(LRHI?.N1".".N) D
. . I LRTRESHI?.N!(LRTRESHI?.N1".".N) D
. . . I +LRHI=+LRTRESHI S DIFF=0
I DIFF Q 1
Q 0
;
;
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
ZEROFIX ; EP - Leading & Trailing Zero Fix for Results
Q:$L($P(LRTRES,"^"))<1 ; Skip if no Result
;
NEW DN,DP,ORIGRLST,RESULT,STR,SYMBOL
S DN=+$G(LRSUB) ; 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=$P(LRTRES,"^")
;
Q:$$UP^XLFSTR($G(RESULT))["SPECIMEN IN LAB" ; Skip if not resulted
;
S SYMBOL="",ORIGRSLT=RESULT
F Q:$E(RESULT)="."!($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))
;
S:$E(RESULT)="." RESULT="0"_RESULT ; Leading Zero Fix
;
I $E(RESULT)'?1N S RESULT=ORIGRSLT Q ; Skip if RESULT has no numeric part
;
S RESULT=$TR($FN(RESULT,"P",DP)," ")
;
S:$L($G(SYMBOL)) RESULT=SYMBOL_RESULT ; Restore "symbol", if necessary
;
S $P(LRTRES,"^",1)=RESULT
Q
; ----- END IHS/MSC/MKK - LR*5.2*1031
LR7OSUM1 ;VA/DALOI/dcm - Silent Patient cum cont. ; Mar 11, 2003
+1 ;;5.2;LAB SERVICE;**1003,1031**;NOV 1, 1997
+2 ;
+3 ;;VA LR Patche(s): 121,187,256,286,384
+4 ;
LRIDT ; from LR7OSUM
+1 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"CH",LRIDT))
IF LRIDT<1!(LRIDT>LROUT)!(CT1>COUNT)
QUIT
IF $DATA(^(LRIDT,0))
SET X=^(0)
SET CT1=CT1+1
DO LRIIDT
+2 QUIT
+3 ;
LRIIDT ;
+1 SET (LRIIDT,LRVIDT)=$PIECE(X,U,1)
SET LRSUB=1
SET LRTNN=1
SET LRSPM=$PIECE(X,U,5)
SET LRTLOC=$EXTRACT($PIECE(X,U,11),1,7)
SET LRVDT=$PIECE(X,U,3)
SET LRAN=$PIECE(X,U,6)
+2 IF '$LENGTH(LRVDT)
QUIT
+3 DO LRSUB
+4 QUIT
+5 ;
+6 ;
LRSUB ;
+1 NEW LRTRES
+2 SET LRSUB=1
+3 FOR
SET LRSUB=$ORDER(^LR(LRDFN,"CH",LRIDT,LRSUB))
IF LRSUB<1
QUIT
Begin DoDot:1
+4 SET X=^LR(LRDFN,"CH",LRIDT,LRSUB)
+5 SET LRTRES=$$TSTRES^LRRPU(LRDFN,"CH",LRIDT,LRSUB,"")
+6 DO SUB1
End DoDot:1
+7 QUIT
SUB1 ;
+1 SET LRTSTVAL=$PIECE(X,U,1)
SET X1=$PIECE(X,U,2)
+2 SET LRNOFL=""
SET LRTST=$ORDER(^LAB(60,"C","CH;"_LRSUB_";"_1,0))
+3 IF LRTST=""
QUIT
+4 IF "IN"[$PIECE(^LAB(60,LRTST,0),U,3)
QUIT
+5 IF '$DATA(^LAB(64.5,"AC",LRSUB))
DO MISC
QUIT
+6 KILL LRNON
+7 DO LRMH
+8 IF '$DATA(LRNON)
DO MISC
+9 QUIT
+10 ;
LRMH ;
+1 SET LRMH=0
+2 FOR
SET LRMH=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH))
IF LRMH<1
QUIT
DO LRSH
+3 QUIT
+4 ;
LRSH ;
+1 SET LRSH=0
+2 FOR
SET LRSH=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH))
IF LRSH<1
QUIT
DO TST
+3 QUIT
+4 ;
TST ;
+1 SET LRTSTS=0
+2 FOR
SET LRTSTS=$ORDER(^LAB(64.5,"AC",LRSUB,1,LRMH,LRSH,LRTSTS))
IF 'LRTSTS
QUIT
SET LRSPM1=^(LRTSTS)
DO TST1
+3 QUIT
+4 ;
+5 ;
TST1 ;
+1 IF LRSPM'=LRSPM1
QUIT
SBSET ;
+1 SET LRMHN=$PIECE(^LAB(64.5,1,1,LRMH,0),U,1)
SET LRTF=^(1,LRSH,0)
SET $PIECE(LRTF,U,4)=$PIECE(LRTF,U,3)
SET $PIECE(LRTF,U,3)=$PIECE(^(1,0),U,4)
SET LRNON=1
+2 IF $SELECT('$DATA(SUBHEAD)
QUIT
+3 ;
+4 ;** LRTE=Total minor headings
+5 ;** LRMHN=Major heading name^TE^Lab performing tests
+6 ;** LRTF=Minor header^Profile specimen^Total tests^Type of display
+7 ;
+8 SET LRIIDT=LRVIDT
+9 IF '$DATA(^TMP($JOB,LRDFN,LRMH))
SET ^(LRMH)=LRMHN
+10 IF '$DATA(^TMP($JOB,LRDFN,LRMH,LRSH))!($DATA(^(LRSH))=10)
SET ^(LRSH)=LRTF_U
+11 IF '$DATA(^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,0))
SET ^(0)=LRTLOC_U_LRVIDT_U_LRVDT_U_LRAN_U_LRIDT
+12 ;
LRTSTVAL ;
+1 ;
+2 SET ^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,LRTSTS)=$PIECE(LRTRES,"^")_"^"_$PIECE(LRTRES,"^",2)
+3 SET X=$PIECE($GET(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRTSTS,0)),"^",3)
+4 IF $LENGTH(X)
SET ^TMP("LRT",$JOB,X)=$PIECE(LRTF,"^")
+5 IF $DATA(^LR(LRDFN,"CH",LRIDT,1,0))
IF '$DATA(^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",0))
DO TEXT
+6 DO CHKUN
+7 IF $ORDER(^LAB(60,LRTST,1,LRSPM,1,0))
IF '$DATA(^TMP($JOB,"EVAL",LRTST,LRSPM))
Begin DoDot:1
+8 SET ^TMP($JOB,"EVAL",LRTST,LRSPM)=""
+9 NEW I,L,X,TST
+10 SET I=0
SET TST=$SELECT($LENGTH($PIECE($GET(^LAB(60,LRTST,.1)),"^")):$PIECE(^(.1),"^"),1:$PIECE(^LAB(60,LRTST,0),"^"))
+11 SET L=+$ORDER(^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",9999999),-1)
SET L=L+1
SET ^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)="Evaluation for "_TST_":"
+12 FOR
SET I=$ORDER(^LAB(60,LRTST,1,LRSPM,1,I))
IF 'I
QUIT
SET X=^(I,0)
SET L=L+1
SET ^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=X
End DoDot:1
+13 QUIT
+14 ;
+15 ;
MISC ;
+1 IF $SELECT('$DATA(SUBHEAD)
QUIT
+2 SET LRTST=$ORDER(^LAB(60,"C","CH;"_LRSUB_";"_1,0))
+3 IF LRTST=""
QUIT
+4 IF "IN"[$PIECE(^LAB(60,LRTST,0),U,3)
QUIT
+5 SET LRTOP=LRSPM
+6 ;
+7 ; IHS/MSC/MKK - LR*5.2*1031
DO ZEROFIX
+8 ;
+9 IF '$DATA(^TMP($JOB,LRDFN,"MISC",LRIDT,0))
SET ^(0)=LRIDT_U_LRVIDT_U_LRVDT_U_LRAN_U_LRSPM
+10 ;S ^TMP($J,LRDFN,"MISC",LRIDT,LRTNN)=LRTSTVAL_U_LRSPM_U_LRTST_U_X1_U_LRSUB
+11 ; S ^TMP($J,LRDFN,"MISC",LRIDT,LRTNN)=$P(LRTRES,"^")_U_LRSPM_U_LRTST_U_$P(LRTRES,"^",2)_U_LRSUB_U_$P(LRTRES,"^",3,6)
+12 ;
+13 ; ----- BEGIN IHS/OIT/MKK -- LR*5.2*1027
+14 ; If the result of the test is free text, it's possible that the
+15 ; the $L(LRTRES)>30, which is too wide for 80-char screen AND the
+16 ; text of the result needs to be wrapped.
+17 IF $LENGTH($PIECE(LRTRES,"^"))<31
SET ^TMP($JOB,LRDFN,"MISC",LRIDT,LRTNN)=$PIECE(LRTRES,"^")_U_LRSPM_U_LRTST_U_$PIECE(LRTRES,"^",2)_U_LRSUB_U_$PIECE(LRTRES,"^",3,6)
+18 IF $LENGTH($PIECE(LRTRES,"^"))>30
Begin DoDot:1
+19 NEW CRLF,LINE,RESULT,WRAPPED
+20 SET RESULT(1)=$PIECE(LRTRES,"^")
+21 DO WRAP^BLRUTIL3("RESULT",29)
+22 SET LINE=1
+23 SET CRLF=$CHAR(13)_$CHAR(10)
+24 SET WRAPPED=$GET(^TMP("BLRUTIL3",$JOB,LINE,0))
+25 FOR
SET LINE=$ORDER(^TMP("BLRUTIL3",$JOB,LINE))
IF LINE<1
QUIT
Begin DoDot:2
+26 SET WRAPPED=WRAPPED_CRLF_$JUSTIFY("",49)_$GET(^TMP("BLRUTIL3",$JOB,LINE,0))
End DoDot:2
+27 SET ^TMP($JOB,LRDFN,"MISC",LRIDT,LRTNN)=WRAPPED_U_LRSPM_U_LRTST_U_$PIECE(LRTRES,"^",2)_U_LRSUB_U_$PIECE(LRTRES,"^",3,6)
+28 KILL ^TMP("BLRUTIL3",$JOB)
End DoDot:1
+29 ; ----- END IHS/OIT/MKK -- LR*5.2*1027
+30 ;
+31 SET X=$SELECT($DATA(^LAB(60,LRTST,.1)):$PIECE(^(.1),"^"),1:$PIECE(^LAB(60,LRTST,0),"^"))
SET ^TMP("LRT",$JOB,X)="MISCELLANEOUS TESTS"
+32 ;
+33 ; Grab specimen comments
+34 IF $DATA(^LR(LRDFN,"CH",LRIDT,1,0))
IF '$DATA(^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",0))
Begin DoDot:1
+35 SET ^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",0)=""
SET L=0
+36 ; F S L=$O(^LR(LRDFN,"CH",LRIDT,1,L)) Q:L<1 S ^TMP($J,LRDFN,"MISC",LRIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
+37 ; BEGIN -- IHS/OIT/MKK - LR*5.2*1027
+38 NEW ADDRFLAG
+39 SET ADDRFLAG="NO"
+40 FOR
SET L=$ORDER(^LR(LRDFN,"CH",LRIDT,1,L))
IF L<1
QUIT
Begin DoDot:2
+41 SET ^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
+42 IF $GET(^LR(LRDFN,"CH",LRIDT,1,L,0))["Test Performed at"
SET ADDRFLAG="YES"
End DoDot:2
+43 ;
+44 IF ADDRFLAG="YES"
Begin DoDot:2
+45 SET L=1+$ORDER(^LR(LRDFN,"CH",LRIDT,1,L),-1)
+46 ; Put in extra "space" -- better readibility
SET ^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",L,0)=" "
End DoDot:2
+47 ; END -- IHS/OIT/MKK - LR*5.2*1027
End DoDot:1
+48 ;
+49 ; Grab test interpretation
+50 IF $ORDER(^LAB(60,LRTST,1,LRSPM,1,0))
Begin DoDot:1
+51 NEW I,L,X,TST
+52 SET I=0
SET TST=$SELECT($LENGTH($PIECE($GET(^LAB(60,LRTST,.1)),"^")):$PIECE(^(.1),"^"),1:$PIECE(^LAB(60,LRTST,0),"^"))
+53 IF '$DATA(^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",0))
SET ^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",0)=""
+54 SET L=+$ORDER(^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",9999999),-1)
SET L=L+1
+55 SET ^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",L,0)="Evaluation for "_TST_":"
+56 FOR
SET I=$ORDER(^LAB(60,LRTST,1,LRSPM,1,I))
IF 'I
QUIT
SET X=^(I,0)
SET L=L+1
SET ^TMP($JOB,LRDFN,"MISC",LRIDT,"TX",L,0)=X
End DoDot:1
+57 ;
+58 SET LRTNN=LRTNN+1
+59 QUIT
+60 ;
+61 ;
TEXT ;
+1 SET LRYESCOM=0
+2 SET M=0
+3 FOR
SET M=$ORDER(^LR(LRDFN,"CH",LRIDT,1,M))
IF M<1!(LRYESCOM)
QUIT
FOR N=1:1:$LENGTH(^LR(LRDFN,"CH",LRIDT,1,M,0))
IF LRYESCOM
QUIT
IF $EXTRACT(^(0),N)'[$CHAR(32)
SET LRYESCOM=1
+4 IF 'LRYESCOM
QUIT
+5 SET L=0
+6 FOR
SET L=$ORDER(^LR(LRDFN,"CH",LRIDT,1,L))
IF L<1
QUIT
SET ^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=^LR(LRDFN,"CH",LRIDT,1,L,0)
+7 QUIT
+8 ;
+9 ;
MICRO ;from LR7OSUM
+1 IF '$DATA(^LR(LRDFN,"MI"))
QUIT
+2 NEW MICROCNT
+3 IF '$DATA(LRUNKNOW)
SET LRUNKNOW=$PIECE(^LAB(69.9,1,1),U,5)
+4 SET (LRONESPC,LRONETST)=""
SET LREND=0
SET MICROCNT=GCNT+1
+5 IF $ORDER(^LR(LRDFN,"MI",0))
SET ^TMP("LRH",$JOB,"MICROBIOLOGY")=MICROCNT
+6 SET LRWRDVEW=""
SET LRSB=0
SET LRIDT=LRIN
+7 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
IF LRIDT<1!(LRIDT>LROUT)!(CT1>COUNT)
QUIT
SET LRNLOC=LRLLOC
SET CT1=CT1+1
DO EN1^LR7OSMZ0
SET LRLLOC=LRNLOC
+8 IF GCNT'>MICROCNT
KILL ^TMP("LRH",$JOB,"MICROBIOLOGY")
+9 KILL %,A,A1,AGE,B,B1,DFN,DOB,DZ,I,J,LR2ORMOR,LRAA,LRACC,LRACN,LRAD,LRADM,LRADX,LRAFS,LRAX,LRBUG,LRCMNT,LRCS,LRDCOM,LREF,LREND,LRIFN,LRLLT,LRMD,LRNLOC,LRNS,LROK,LRONESPC,LRONETST,LRORG,LRPRE,LRPRINT
+10 QUIT
+11 ;
+12 ;
CHKUN ; Check units and normals with cumulative report values
+1 ; Add comment if these differ from file #64.5 values
+2 ;
+3 NEW I,L,LRFLAG,LRHI,LRLO,LRLOHI,LRX,LRY,TST
+4 SET LRX=$GET(^LAB(64.5,"A",1,LRMH,LRSH,LRTSTS))
SET LRFLAG=0
+5 SET TST=$PIECE($GET(^LAB(64.5,1,1,LRMH,1,LRSH,1,LRTSTS,0)),"^",3)
+6 SET LRY="*** For test "_TST
+7 ; Check units - if different generate comment
+8 IF $$UP^XLFSTR($PIECE(LRX,"^",7))'=$$UP^XLFSTR($PIECE(LRTRES,"^",5))
SET LRY=LRY_" Units: "_$PIECE(LRTRES,"^",5)
SET LRFLAG=1
+9 ;
+10 ; Check normals - if different generate comment
+11 SET @("LRLO="_$SELECT($PIECE(LRX,"^",2)'="":$PIECE(LRX,"^",2),$PIECE(LRX,"^",11)'="":$PIECE(LRX,"^",11),1:""""""))
+12 ;
+13 SET @("LRHI="_$SELECT($PIECE(LRX,"^",3)'="":$PIECE(LRX,"^",3),$PIECE(LRX,"^",12)'="":$PIECE(LRX,"^",12),1:""""""))
+14 IF LRLO'=$PIECE(LRTRES,"^",3)!(LRHI'=$PIECE(LRTRES,"^",4))
Begin DoDot:1
+15 ; check to see if these values are numeric and are different because of leading or trailing zeroes
+16 IF '$$REALDIFF
QUIT
+17 IF LRFLAG
SET LRY=LRY_" and"
+18 SET LRY=LRY_" Normals: "_$PIECE(LRTRES,"^",3)_"-"_$PIECE(LRTRES,"^",4)
SET LRFLAG=1
End DoDot:1
+19 ;
+20 IF 'LRFLAG
QUIT
+21 ;
+22 SET L=+$ORDER(^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",9999999),-1)
SET L=L+1
+23 SET LRY=LRY_" ***"
SET ^TMP($JOB,LRDFN,LRMH,LRSH,LRIDT,"TX",L,0)=LRY
+24 QUIT
+25 ;
+26 ;
REALDIFF() ;
+1 ; function to determine if values are numeric and are different
+2 ; solely because of leading or trailing zeroes
+3 ; returns 0 if difference is because of leading/trailing zeroes
+4 ; returns 1 if differences are meaningful
+5 NEW LRTRESLO,LRTRESHI,DIFF
+6 SET LRTRESLO=$PIECE(LRTRES,"^",3)
SET LRTRESHI=$PIECE(LRTRES,"^",4)
+7 SET DIFF=0
+8 IF LRLO'=LRTRESLO
SET DIFF=1
Begin DoDot:1
+9 IF LRLO?.N!(LRLO?.N1".".N)
Begin DoDot:2
+10 IF LRTRESLO?.N!(LRTRESLO?.N1".".N)
Begin DoDot:3
+11 IF +LRLO=+LRTRESLO
SET DIFF=0
End DoDot:3
End DoDot:2
End DoDot:1
+12 IF DIFF
QUIT 1
+13 IF LRHI'=LRTRESHI
SET DIFF=1
Begin DoDot:1
+14 IF LRHI?.N!(LRHI?.N1".".N)
Begin DoDot:2
+15 IF LRTRESHI?.N!(LRTRESHI?.N1".".N)
Begin DoDot:3
+16 IF +LRHI=+LRTRESHI
SET DIFF=0
End DoDot:3
End DoDot:2
End DoDot:1
+17 IF DIFF
QUIT 1
+18 QUIT 0
+19 ;
+20 ;
+21 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
ZEROFIX ; EP - Leading & Trailing Zero Fix for Results
+1 ; Skip if no Result
IF $LENGTH($PIECE(LRTRES,"^"))<1
QUIT
+2 ;
+3 NEW DN,DP,ORIGRLST,RESULT,STR,SYMBOL
+4 ; Data Name number
SET DN=+$GET(LRSUB)
+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=$PIECE(LRTRES,"^")
+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)="."!($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 ; Leading Zero Fix
IF $EXTRACT(RESULT)="."
SET RESULT="0"_RESULT
+24 ;
+25 ; Skip if RESULT has no numeric part
IF $EXTRACT(RESULT)'?1N
SET RESULT=ORIGRSLT
QUIT
+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 SET $PIECE(LRTRES,"^",1)=RESULT
+32 QUIT
+33 ; ----- END IHS/MSC/MKK - LR*5.2*1031
