- 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
