BLRALBM3 ;DAOU/ALA-Build Micro Results - AFM, FUNGUS [ 11/18/2002 1:34 PM ]
;;5.2;LR;**1013,1015**;NOV 18, 2002
;
;
;
TB ;EP
I '$L($P($G(^LR(LRDFN,"MI",LRIDT,11)),U)) Q:'$D(LRWRDVEW) Q:LRSB'=11
NEW BLRAMIC
S BLRAMIC=$G(^LR(LRDFN,"MI",LRIDT,11))
S LRTUS=$P(BLRAMIC,U,2),DZ=$P(BLRAMIC,U,5)
S LRAFS=$P(BLRAMIC,U,3),LRAMT=$P(BLRAMIC,U,4),Y=$P(BLRAMIC,U) D D^LRU
S BLRAZ="* MYCOBACTERIOLOGY "_$S(LRTUS="F":"FINAL",LRTUS="P":"PRELIMINARY",1:"")_" REPORT => "_Y_" TECH CODE: "_DZ
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
S LRPRE=23 D PRE^BLRALBM1
K LRTA I $D(^LR(LRDFN,"MI",LRIDT,12,0)),$P(^(0),U,4)>0 S LRTA=0
D:LRAFS'=""!($D(LRTA)) AFS
I $D(^LR(LRDFN,"MI",LRIDT,13,0)),$P(^(0),U,4)>0 D
. S BLRAZ="Mycobacteriology Remark(s):" S B=0
. F S B=+$O(^LR(LRDFN,"MI",LRIDT,13,B)) Q:B<1 D
.. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,3)_$G(^LR(LRDFN,"MI",LRIDT,13,B,0))
Q
;
AFS I LRAFS'="" D
. S BLRAZ=$S(LRAFS["D":"Direct",LRAFS["C":"Concentrate",1:"")_" Acid Fast Stain: "_$S(LRAFS["P":"Positive",LRAFS["N":"Negative",1:LRAFS)
. S BLRAZ=BLRAZ_" "
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
. I $L(LRAMT) S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,3)_"Quantity: "_LRAMT
K ^TMP("LR",$J,"T"),LRTSTS
I $D(LRTA) D
. S LRTSTS=0 F A=0:1 S LRTA=+$O(^LR(LRDFN,"MI",LRIDT,12,LRTA)) Q:LRTA<1 D
.. S BLRAAFS=$G(^LR(LRDFN,"MI",LRIDT,12,LRTA,0))
.. S (LRBUG(LRTA),LRTBC)=$P(BLRAAFS,U),LRQU=$P(BLRAAFS,U,2)
.. S LRTBC=$P($G(^LAB(61.2,LRTBC,0)),U) D LIST
Q
;
LIST S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)="Mycobacterium: "_LRTBC
I $L(LRQU) S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,3)_"Quantity: "_LRQU
S:$D(^LR(LRDFN,"MI",LRIDT,12,LRTA,2)) LRTSTS=LRTSTS+1
I $D(^LR(LRDFN,"MI",LRIDT,12,LRTA,1,0)) D
. S BLRAZ=" Comment: "
. S B=0 F S B=+$O(^LR(LRDFN,"MI",LRIDT,12,LRTA,1,B)) Q:B<1 D
.. S BLRAZ=BLRAZ_$G(^LR(LRDFN,"MI",LRIDT,12,LRTA,1,B,0))
.. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ,BLRAZ=""
;
SEN S LRTB=2 F S LRTB=+$O(^LR(LRDFN,"MI",LRIDT,12,LRTA,LRTB)) Q:LRTB'["2."!(LRTB="") D
. S LRTBA=$O(^DD(63.39,"GL",LRTB,1,0)),LRTBA=$P($G(^DD(63.39,LRTBA,0)),U)
. S LRTBS=$G(^LR(LRDFN,"MI",LRIDT,12,LRTA,LRTB))
. S BLRAZ=LRTBA,BLRAZ1=20 D Z1 S BLRAZ=BLRAZ_LRTBS
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
K LRTB,LRTBA,LRTBS
Q
;
FUNG ;EP
I '$L($P($G(^LR(LRDFN,"MI",LRIDT,8)),U)) Q:'$D(LRWRDVEW) Q:LRSB'=8
NEW BLRAMIC
S BLRAMIC=$G(^LR(LRDFN,"MI",LRIDT,8))
S LRTUS=$P(BLRAMIC,U,2),DZ=$P(BLRAMIC,U,3),Y=$P(BLRAMIC,U) D D^LRU
S BLRAZ="* MYCOLOGY "_$S(LRTUS="F":"FINAL",LRTUS="P":"PRELIMINARY",1:"")_" REPORT => "_Y_" TECH CODE: "_DZ
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
S LRPRE=22 D PRE^BLRALBM1
I $D(^LR(LRDFN,"MI",LRIDT,15)) D
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)="MYCOLOGY SMEAR/PREP:"
. S LRMYC=0 F S LRMYC=+$O(^LR(LRDFN,"MI",LRIDT,15,LRMYC)) Q:LRMYC<1 D
.. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$G(^LR(LRDFN,"MI",LRIDT,15,LRMYC,0))
I $D(^LR(LRDFN,"MI",LRIDT,9,0)),$P(^(0),U,4)>0 D
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)="Fungus/Yeast: " D SHOW
I $D(^LR(LRDFN,"MI",LRIDT,10,0)),$P(^(0),U,4)>0 D
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)="Mycology Remark(s):"
. S LRMYC=0 F S LRMYC=+$O(^LR(LRDFN,"MI",LRIDT,10,LRMYC)) Q:LRMYC<1 D
.. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,3)_$G(^LR(LRDFN,"MI",LRIDT,10,LRMYC,0))
Q
;
SHOW S LRTA=0 F S LRTA=+$O(^LR(LRDFN,"MI",LRIDT,9,LRTA)) Q:LRTA<1 D
. S BLRABUG=$G(^LR(LRDFN,"MI",LRIDT,9,LRTA,0))
. S (LRBUG(LRTA),LRTBC)=$P(BLRABUG,U),LRQU=$P(BLRABUG,U,2)
. S LRTBC=$P($G(^LAB(61.2,LRTBC,0)),U) D LIST1
Q
;
LIST1 S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=LRTBC
I $L(LRQU) S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=$E(BLRABLKS,1,3)_"Quantity: "_LRQU
I $D(^LR(LRDFN,"MI",LRIDT,9,LRTA,1,0)) D
. S BLRAZ=" Comment:"
. S B=0 F S B=+$O(^LR(LRDFN,"MI",LRIDT,9,LRTA,1,B)) Q:B<1 D
.. S BLRAZ=BLRAZ,BLRAZ1=13 D Z1
.. S BLRAZ=BLRAZ_$G(^LR(LRDFN,"MI",LRIDT,9,LRTA,1,B,0))
.. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ,BLRAZ=""
Q
;
Z1 ; Pad with trailing spaces
F BLRAI=1:1:(BLRAZ1-$L(BLRAZ)) S BLRAZ=BLRAZ_" "
Q
BLRALBM3 ;DAOU/ALA-Build Micro Results - AFM, FUNGUS [ 11/18/2002 1:34 PM ]
+1 ;;5.2;LR;**1013,1015**;NOV 18, 2002
+2 ;
+3 ;
+4 ;
TB ;EP
+1 IF '$LENGTH($PIECE($GET(^LR(LRDFN,"MI",LRIDT,11)),U))
IF '$DATA(LRWRDVEW)
QUIT
IF LRSB'=11
QUIT
+2 NEW BLRAMIC
+3 SET BLRAMIC=$GET(^LR(LRDFN,"MI",LRIDT,11))
+4 SET LRTUS=$PIECE(BLRAMIC,U,2)
SET DZ=$PIECE(BLRAMIC,U,5)
+5 SET LRAFS=$PIECE(BLRAMIC,U,3)
SET LRAMT=$PIECE(BLRAMIC,U,4)
SET Y=$PIECE(BLRAMIC,U)
DO D^LRU
+6 SET BLRAZ="* MYCOBACTERIOLOGY "_$SELECT(LRTUS="F":"FINAL",LRTUS="P":"PRELIMINARY",1:"")_" REPORT => "_Y_" TECH CODE: "_DZ
+7 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+8 SET LRPRE=23
DO PRE^BLRALBM1
+9 KILL LRTA
IF $DATA(^LR(LRDFN,"MI",LRIDT,12,0))
IF $PIECE(^(0),U,4)>0
SET LRTA=0
+10 IF LRAFS'=""!($DATA(LRTA))
DO AFS
+11 IF $DATA(^LR(LRDFN,"MI",LRIDT,13,0))
IF $PIECE(^(0),U,4)>0
Begin DoDot:1
+12 SET BLRAZ="Mycobacteriology Remark(s):"
SET B=0
+13 FOR
SET B=+$ORDER(^LR(LRDFN,"MI",LRIDT,13,B))
IF B<1
QUIT
Begin DoDot:2
+14 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=$EXTRACT(BLRABLKS,1,3)_$GET(^LR(LRDFN,"MI",LRIDT,13,B,0))
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
AFS IF LRAFS'=""
Begin DoDot:1
+1 SET BLRAZ=$SELECT(LRAFS["D":"Direct",LRAFS["C":"Concentrate",1:"")_" Acid Fast Stain: "_$SELECT(LRAFS["P":"Positive",LRAFS["N":"Negative",1:LRAFS)
+2 SET BLRAZ=BLRAZ_" "
+3 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+4 IF $LENGTH(LRAMT)
SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=$EXTRACT(BLRABLKS,1,3)_"Quantity: "_LRAMT
End DoDot:1
+5 KILL ^TMP("LR",$JOB,"T"),LRTSTS
+6 IF $DATA(LRTA)
Begin DoDot:1
+7 SET LRTSTS=0
FOR A=0:1
SET LRTA=+$ORDER(^LR(LRDFN,"MI",LRIDT,12,LRTA))
IF LRTA<1
QUIT
Begin DoDot:2
+8 SET BLRAAFS=$GET(^LR(LRDFN,"MI",LRIDT,12,LRTA,0))
+9 SET (LRBUG(LRTA),LRTBC)=$PIECE(BLRAAFS,U)
SET LRQU=$PIECE(BLRAAFS,U,2)
+10 SET LRTBC=$PIECE($GET(^LAB(61.2,LRTBC,0)),U)
DO LIST
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
LIST SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)="Mycobacterium: "_LRTBC
+1 IF $LENGTH(LRQU)
SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=$EXTRACT(BLRABLKS,1,3)_"Quantity: "_LRQU
+2 IF $DATA(^LR(LRDFN,"MI",LRIDT,12,LRTA,2))
SET LRTSTS=LRTSTS+1
+3 IF $DATA(^LR(LRDFN,"MI",LRIDT,12,LRTA,1,0))
Begin DoDot:1
+4 SET BLRAZ=" Comment: "
+5 SET B=0
FOR
SET B=+$ORDER(^LR(LRDFN,"MI",LRIDT,12,LRTA,1,B))
IF B<1
QUIT
Begin DoDot:2
+6 SET BLRAZ=BLRAZ_$GET(^LR(LRDFN,"MI",LRIDT,12,LRTA,1,B,0))
+7 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
SET BLRAZ=""
End DoDot:2
End DoDot:1
+8 ;
SEN SET LRTB=2
FOR
SET LRTB=+$ORDER(^LR(LRDFN,"MI",LRIDT,12,LRTA,LRTB))
IF LRTB'["2."!(LRTB="")
QUIT
Begin DoDot:1
+1 SET LRTBA=$ORDER(^DD(63.39,"GL",LRTB,1,0))
SET LRTBA=$PIECE($GET(^DD(63.39,LRTBA,0)),U)
+2 SET LRTBS=$GET(^LR(LRDFN,"MI",LRIDT,12,LRTA,LRTB))
+3 SET BLRAZ=LRTBA
SET BLRAZ1=20
DO Z1
SET BLRAZ=BLRAZ_LRTBS
+4 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
End DoDot:1
+5 KILL LRTB,LRTBA,LRTBS
+6 QUIT
+7 ;
FUNG ;EP
+1 IF '$LENGTH($PIECE($GET(^LR(LRDFN,"MI",LRIDT,8)),U))
IF '$DATA(LRWRDVEW)
QUIT
IF LRSB'=8
QUIT
+2 NEW BLRAMIC
+3 SET BLRAMIC=$GET(^LR(LRDFN,"MI",LRIDT,8))
+4 SET LRTUS=$PIECE(BLRAMIC,U,2)
SET DZ=$PIECE(BLRAMIC,U,3)
SET Y=$PIECE(BLRAMIC,U)
DO D^LRU
+5 SET BLRAZ="* MYCOLOGY "_$SELECT(LRTUS="F":"FINAL",LRTUS="P":"PRELIMINARY",1:"")_" REPORT => "_Y_" TECH CODE: "_DZ
+6 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+7 SET LRPRE=22
DO PRE^BLRALBM1
+8 IF $DATA(^LR(LRDFN,"MI",LRIDT,15))
Begin DoDot:1
+9 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)="MYCOLOGY SMEAR/PREP:"
+10 SET LRMYC=0
FOR
SET LRMYC=+$ORDER(^LR(LRDFN,"MI",LRIDT,15,LRMYC))
IF LRMYC<1
QUIT
Begin DoDot:2
+11 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=$GET(^LR(LRDFN,"MI",LRIDT,15,LRMYC,0))
End DoDot:2
End DoDot:1
+12 IF $DATA(^LR(LRDFN,"MI",LRIDT,9,0))
IF $PIECE(^(0),U,4)>0
Begin DoDot:1
+13 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)="Fungus/Yeast: "
DO SHOW
End DoDot:1
+14 IF $DATA(^LR(LRDFN,"MI",LRIDT,10,0))
IF $PIECE(^(0),U,4)>0
Begin DoDot:1
+15 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)="Mycology Remark(s):"
+16 SET LRMYC=0
FOR
SET LRMYC=+$ORDER(^LR(LRDFN,"MI",LRIDT,10,LRMYC))
IF LRMYC<1
QUIT
Begin DoDot:2
+17 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=$EXTRACT(BLRABLKS,1,3)_$GET(^LR(LRDFN,"MI",LRIDT,10,LRMYC,0))
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
SHOW SET LRTA=0
FOR
SET LRTA=+$ORDER(^LR(LRDFN,"MI",LRIDT,9,LRTA))
IF LRTA<1
QUIT
Begin DoDot:1
+1 SET BLRABUG=$GET(^LR(LRDFN,"MI",LRIDT,9,LRTA,0))
+2 SET (LRBUG(LRTA),LRTBC)=$PIECE(BLRABUG,U)
SET LRQU=$PIECE(BLRABUG,U,2)
+3 SET LRTBC=$PIECE($GET(^LAB(61.2,LRTBC,0)),U)
DO LIST1
End DoDot:1
+4 QUIT
+5 ;
LIST1 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=LRTBC
+1 IF $LENGTH(LRQU)
SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=$EXTRACT(BLRABLKS,1,3)_"Quantity: "_LRQU
+2 IF $DATA(^LR(LRDFN,"MI",LRIDT,9,LRTA,1,0))
Begin DoDot:1
+3 SET BLRAZ=" Comment:"
+4 SET B=0
FOR
SET B=+$ORDER(^LR(LRDFN,"MI",LRIDT,9,LRTA,1,B))
IF B<1
QUIT
Begin DoDot:2
+5 SET BLRAZ=BLRAZ
SET BLRAZ1=13
DO Z1
+6 SET BLRAZ=BLRAZ_$GET(^LR(LRDFN,"MI",LRIDT,9,LRTA,1,B,0))
+7 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
SET BLRAZ=""
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
Z1 ; Pad with trailing spaces
+1 FOR BLRAI=1:1:(BLRAZ1-$LENGTH(BLRAZ))
SET BLRAZ=BLRAZ_" "
+2 QUIT
