BLRALBM4.m

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