BLRALBM4 ;DAOU/ALA-Build Micro Results - BACTERIA, ANTIBIOTICS [ 11/18/2002 1:34 PM ]
;;5.2;LR;**1013,1015**;NOV 18, 2002
;
;
;
BACT ;EP
Q:+$O(^LR(LRDFN,"MI",LRIDT,3,0))<1
S LRFMT=$P($G(^LAB(69.9,1,0)),U,11),LRFMT=$S(LRFMT="":"I",1:LRFMT)
K LRRES,LRINT
S LRBUG=0 F A=1:1 S LRBUG=+$O(^LR(LRDFN,"MI",LRIDT,3,LRBUG)) Q:LRBUG<1 S:+$O(^(LRBUG,2))'["2." A=A-1 I +$O(^(2))["2." D CHECK
S (LRABCNT,LRBN)=0 F S LRBN=+$O(LRRES(LRBN)) Q:LRBN<1 S LRABCNT=LRABCNT+1
Q:'LRABCNT!($G(LREND))
D LIN^BLRALBA
S BLRAZ="ANTIBIOTIC SUSCEPTIBILITY TEST RESULTS:"
I $D(^XUSEC("LRLAB",DUZ))&'$D(LRWRDVEW) D
. S BLRAZ=BLRAZ_" ('*' indicates display is suppressed)"
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
. D BUGHDR
S LRCOMTAB=$S(LRFMT="B":A*13+17,1:A*5+17)
S (LRAO,LRACNT)=0
F S LRAO=$O(^LAB(62.06,"AO",LRAO)) Q:LRAO<.001 D
. S B=$O(^LAB(62.06,"AO",LRAO,0)) I B>0,$D(^LAB(62.06,B,0)) D AB
K LR1PASS,LRRES,LRINT,LRBN ;IHS/ANMC/CLS 08/18/96
Q
CHECK S LRFLAG=0,LRBN=2 K LR1PASS
F S LRBN=+$O(^LR(LRDFN,"MI",LRIDT,3,LRBUG,LRBN)) Q:LRBN'["2." D
. S B=$G(^LR(LRDFN,"MI",LRIDT,3,LRBUG,LRBN))
. S B1=$P(B,U),B2=$P(B,U,2)
. I $L(B1),$D(^LAB(62.06,"AI",LRBN,B1)) S BLRAB1=$G(^LAB(62.06,"AI",LRBN,B1)) D FIRST
S LRBN=2 F S LRBN=+$O(LR1PASS(LRBN)) Q:LRBN<1 S B=LR1PASS(LRBN),B1=$P(B,U),B2=$P(B,U,2),B3=$P(B,U,3) D LAB
K LRBN,LR1PASS,LRFLAG,B,B1,B2,B3,BLRAB1
Q
FIRST S B2=$S(B2]"":B2,1:BLRAB1),B3=$P(B,U,3) S:$E(B2)'="R"&("A"[B3) LRFLAG=1 S LR1PASS(LRBN)=B1_U_B2_U_B3,^LR(LRDFN,"MI",LRIDT,3,LRBUG,LRBN)=LR1PASS(LRBN)
Q
LAB I $D(^XUSEC("LRLAB",DUZ)),'$D(LRWRDVEW) S $P(LRRES(LRBN),U,A)=$S(B3="N"!(B3="R"&LRFLAG):B1_"*",1:B1),$P(LRINT(LRBN),U,A)=$S(B3="N"!(B3="R"&LRFLAG):B2_"*",1:B2) Q
I B3=""!(B3="A")!(B3="R"&'LRFLAG) S $P(LRRES(LRBN),U,A)=B1,$P(LRINT(LRBN),U,A)=B2
Q
AB ;
S J=$P($G(^LAB(62.06,B,0)),U,2),BLRAAB=$G(^LAB(62.06,B,0))
I $D(LRINT(J)),LRINT(J)'?."^" D
. S BLRAZ=$E($P(BLRAAB,U),1,14),LRDCOM=$P(BLRAAB,U,3),LRACNT=LRACNT+1
. D SIR
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
Q
BUGHDR S LRBUG=0 F A=0:1 S LRBUG=+$O(^LR(LRDFN,"MI",LRIDT,3,LRBUG)) Q:LRBUG<1 D
. S BLRABUG=$G(^LR(LRDFN,"MI",LRIDT,3,LRBUG,0))
. S LRORG=$P(BLRABUG,U),LRORG=$P($G(^LAB(61.2,LRORG,0)),U)
. S:+$O(^LR(LRDFN,"MI",LRIDT,3,LRBUG,2))'["2." A=A-1 I +$O(^(2))["2." D ORG
. I LRFMT="B" D
.. ;D LIN^BLRALBA
.. S BLRAZ="" F J=1:1:A S BLRAZ1=J-1*13+15 D Z1 S BLRAZ=BLRAZ_":"
. D LIN^BLRALBA F J=1:1:A D
.. I LRFMT'="B" S BLRAZ1=(J*5+10) D Z1 S BLRAZ=BLRAZ_":"
.. I LRFMT="B" S BLRAZ1=J-1*13+15 D Z1 S BLRAZ=BLRAZ_"SUSC INTP"
Q
;
ORG D LIN^BLRALBA
S BLRAZ=""
I A>0 F J=1:1:A S BLRAZ=$E(BLRABLKS,1,$S(LRFMT="B":J-1*13+15,1:J*5+10))_":"
S BLRAZ=$E(BLRABLKS,1,$S(LRFMT="B":A*13+15,1:A*5+15))_$S(LR2ORMOR:LRBUG_". ",1:"")_LRORG
S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
Q
SIR F II=1:1:10 D:$P(LRINT(J),U,II,10)="" DCOM Q:$P(LRINT(J),U,II,10)="" D
. I LRFMT'="B" D
.. S BLRAZ1=(II*5+10) D Z1
.. S BLRAZ=BLRAZ_$S(LRFMT="I":$P(LRINT(J),U,II),1:$P(LRRES(J),U,II))
.. I LRFMT="B" D SIR1
Q
DCOM S BLRAZ1=LRCOMTAB D Z1 S BLRAZ=BLRAZ_LRDCOM
; Comments
I $D(LRDCOM(J)) S K=0,A=0 F S A=+$O(LRDCOM(J,A)) Q:A<1 D
. ;W:'('K&(LRDCOM="")) !
. S BLRAZ1=LRCOMTAB D Z1 S BLRAZ=BLRAZ_LRDCOM(J,A) S K=1
. S BLRADSP=BLRADSP+1,^TMP($J,"BLRA",BLRADSP,0)=BLRAZ
Q
;
SIR1 S BLRAZ1=(II-1*13+15) D Z1
S BLRAZ=BLRAZ_$S($D(LRRES(J)):$P(LRRES(J),U,II),1:"")
S BLRAZ1=(II-1*13+21) D Z1 S BLRAZ=BLRAZ_$P(LRINT(J),U,II)_" "
Q
;
Z1 ; Pad with trailing spaces
F BLRAI=1:1:(BLRAZ1-$L(BLRAZ)) S BLRAZ=BLRAZ_" "
Q
BLRALBM4 ;DAOU/ALA-Build Micro Results - BACTERIA, ANTIBIOTICS [ 11/18/2002 1:34 PM ]
+1 ;;5.2;LR;**1013,1015**;NOV 18, 2002
+2 ;
+3 ;
+4 ;
BACT ;EP
+1 IF +$ORDER(^LR(LRDFN,"MI",LRIDT,3,0))<1
QUIT
+2 SET LRFMT=$PIECE($GET(^LAB(69.9,1,0)),U,11)
SET LRFMT=$SELECT(LRFMT="":"I",1:LRFMT)
+3 KILL LRRES,LRINT
+4 SET LRBUG=0
FOR A=1:1
SET LRBUG=+$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBUG))
IF LRBUG<1
QUIT
IF +$ORDER(^(LRBUG,2))'["2."
SET A=A-1
IF +$ORDER(^(2))["2."
DO CHECK
+5 SET (LRABCNT,LRBN)=0
FOR
SET LRBN=+$ORDER(LRRES(LRBN))
IF LRBN<1
QUIT
SET LRABCNT=LRABCNT+1
+6 IF 'LRABCNT!($GET(LREND))
QUIT
+7 DO LIN^BLRALBA
+8 SET BLRAZ="ANTIBIOTIC SUSCEPTIBILITY TEST RESULTS:"
+9 IF $DATA(^XUSEC("LRLAB",DUZ))&'$DATA(LRWRDVEW)
Begin DoDot:1
+10 SET BLRAZ=BLRAZ_" ('*' indicates display is suppressed)"
+11 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+12 DO BUGHDR
End DoDot:1
+13 SET LRCOMTAB=$SELECT(LRFMT="B":A*13+17,1:A*5+17)
+14 SET (LRAO,LRACNT)=0
+15 FOR
SET LRAO=$ORDER(^LAB(62.06,"AO",LRAO))
IF LRAO<.001
QUIT
Begin DoDot:1
+16 SET B=$ORDER(^LAB(62.06,"AO",LRAO,0))
IF B>0
IF $DATA(^LAB(62.06,B,0))
DO AB
End DoDot:1
+17 ;IHS/ANMC/CLS 08/18/96
KILL LR1PASS,LRRES,LRINT,LRBN
+18 QUIT
CHECK SET LRFLAG=0
SET LRBN=2
KILL LR1PASS
+1 FOR
SET LRBN=+$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBUG,LRBN))
IF LRBN'["2."
QUIT
Begin DoDot:1
+2 SET B=$GET(^LR(LRDFN,"MI",LRIDT,3,LRBUG,LRBN))
+3 SET B1=$PIECE(B,U)
SET B2=$PIECE(B,U,2)
+4 IF $LENGTH(B1)
IF $DATA(^LAB(62.06,"AI",LRBN,B1))
SET BLRAB1=$GET(^LAB(62.06,"AI",LRBN,B1))
DO FIRST
End DoDot:1
+5 SET LRBN=2
FOR
SET LRBN=+$ORDER(LR1PASS(LRBN))
IF LRBN<1
QUIT
SET B=LR1PASS(LRBN)
SET B1=$PIECE(B,U)
SET B2=$PIECE(B,U,2)
SET B3=$PIECE(B,U,3)
DO LAB
+6 KILL LRBN,LR1PASS,LRFLAG,B,B1,B2,B3,BLRAB1
+7 QUIT
FIRST SET B2=$SELECT(B2]"":B2,1:BLRAB1)
SET B3=$PIECE(B,U,3)
IF $EXTRACT(B2)'="R"&("A"[B3)
SET LRFLAG=1
SET LR1PASS(LRBN)=B1_U_B2_U_B3
SET ^LR(LRDFN,"MI",LRIDT,3,LRBUG,LRBN)=LR1PASS(LRBN)
+1 QUIT
LAB IF $DATA(^XUSEC("LRLAB",DUZ))
IF '$DATA(LRWRDVEW)
SET $PIECE(LRRES(LRBN),U,A)=$SELECT(B3="N"!(B3="R"&LRFLAG):B1_"*",1:B1)
SET $PIECE(LRINT(LRBN),U,A)=$SELECT(B3="N"!(B3="R"&LRFLAG):B2_"*",1:B2)
QUIT
+1 IF B3=""!(B3="A")!(B3="R"&'LRFLAG)
SET $PIECE(LRRES(LRBN),U,A)=B1
SET $PIECE(LRINT(LRBN),U,A)=B2
+2 QUIT
AB ;
+1 SET J=$PIECE($GET(^LAB(62.06,B,0)),U,2)
SET BLRAAB=$GET(^LAB(62.06,B,0))
+2 IF $DATA(LRINT(J))
IF LRINT(J)'?."^"
Begin DoDot:1
+3 SET BLRAZ=$EXTRACT($PIECE(BLRAAB,U),1,14)
SET LRDCOM=$PIECE(BLRAAB,U,3)
SET LRACNT=LRACNT+1
+4 DO SIR
+5 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
End DoDot:1
+6 QUIT
BUGHDR SET LRBUG=0
FOR A=0:1
SET LRBUG=+$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBUG))
IF LRBUG<1
QUIT
Begin DoDot:1
+1 SET BLRABUG=$GET(^LR(LRDFN,"MI",LRIDT,3,LRBUG,0))
+2 SET LRORG=$PIECE(BLRABUG,U)
SET LRORG=$PIECE($GET(^LAB(61.2,LRORG,0)),U)
+3 IF +$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBUG,2))'["2."
SET A=A-1
IF +$ORDER(^(2))["2."
DO ORG
+4 IF LRFMT="B"
Begin DoDot:2
+5 ;D LIN^BLRALBA
+6 SET BLRAZ=""
FOR J=1:1:A
SET BLRAZ1=J-1*13+15
DO Z1
SET BLRAZ=BLRAZ_":"
End DoDot:2
+7 DO LIN^BLRALBA
FOR J=1:1:A
Begin DoDot:2
+8 IF LRFMT'="B"
SET BLRAZ1=(J*5+10)
DO Z1
SET BLRAZ=BLRAZ_":"
+9 IF LRFMT="B"
SET BLRAZ1=J-1*13+15
DO Z1
SET BLRAZ=BLRAZ_"SUSC INTP"
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
ORG DO LIN^BLRALBA
+1 SET BLRAZ=""
+2 IF A>0
FOR J=1:1:A
SET BLRAZ=$EXTRACT(BLRABLKS,1,$SELECT(LRFMT="B":J-1*13+15,1:J*5+10))_":"
+3 SET BLRAZ=$EXTRACT(BLRABLKS,1,$SELECT(LRFMT="B":A*13+15,1:A*5+15))_$SELECT(LR2ORMOR:LRBUG_". ",1:"")_LRORG
+4 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
+5 QUIT
SIR FOR II=1:1:10
IF $PIECE(LRINT(J),U,II,10)=""
DO DCOM
IF $PIECE(LRINT(J),U,II,10)=""
QUIT
Begin DoDot:1
+1 IF LRFMT'="B"
Begin DoDot:2
+2 SET BLRAZ1=(II*5+10)
DO Z1
+3 SET BLRAZ=BLRAZ_$SELECT(LRFMT="I":$PIECE(LRINT(J),U,II),1:$PIECE(LRRES(J),U,II))
+4 IF LRFMT="B"
DO SIR1
End DoDot:2
End DoDot:1
+5 QUIT
DCOM SET BLRAZ1=LRCOMTAB
DO Z1
SET BLRAZ=BLRAZ_LRDCOM
+1 ; Comments
+2 IF $DATA(LRDCOM(J))
SET K=0
SET A=0
FOR
SET A=+$ORDER(LRDCOM(J,A))
IF A<1
QUIT
Begin DoDot:1
+3 ;W:'('K&(LRDCOM="")) !
+4 SET BLRAZ1=LRCOMTAB
DO Z1
SET BLRAZ=BLRAZ_LRDCOM(J,A)
SET K=1
+5 SET BLRADSP=BLRADSP+1
SET ^TMP($JOB,"BLRA",BLRADSP,0)=BLRAZ
End DoDot:1
+6 QUIT
+7 ;
SIR1 SET BLRAZ1=(II-1*13+15)
DO Z1
+1 SET BLRAZ=BLRAZ_$SELECT($DATA(LRRES(J)):$PIECE(LRRES(J),U,II),1:"")
+2 SET BLRAZ1=(II-1*13+21)
DO Z1
SET BLRAZ=BLRAZ_$PIECE(LRINT(J),U,II)_" "
+3 QUIT
+4 ;
Z1 ; Pad with trailing spaces
+1 FOR BLRAI=1:1:(BLRAZ1-$LENGTH(BLRAZ))
SET BLRAZ=BLRAZ_" "
+2 QUIT
