LRMIPSZ5 ; IHS/DIR/FJE - MICRO PATIENT REPORT - BACTERIA, ANTIBIOTICS 10/24/88 16:18 ;
;;5.2;LR;**1013**;JUL 15, 2002
;
;;5.2;LAB SERVICE;;Sep 27, 1994
BACT ;from LRMIPSZ2
Q:+$O(^LR(LRDFN,"MI",LRIDT,3,0))<1
S LRFMT=$P(^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 I=0:0 S LRBN=+$O(LRRES(LRBN)) Q:LRBN<1 S LRABCNT=LRABCNT+1
Q:'LRABCNT!($G(LREND)) D:$Y>(IOSL-LRABCNT-LRFLIP-1) NHDR Q:LREND W !!,"ANTIBIOTIC SUSCEPTIBILITY TEST RESULTS:" W:$D(^XUSEC("LRLAB",DUZ))&'$D(LRWRDVEW) " ('*' indicates display is suppressed)" W:LRHC ! D BUGHDR
S LRCOMTAB=$S(LRFMT="B":A*13+17,1:A*5+17)
S (LRAO,LRACNT)=0 F I=0:0 S LRAO=$O(^LAB(62.06,"AO",LRAO)) Q:LRAO<.001!($G(LREND)) S B=$O(^LAB(62.06,"AO",LRAO,0)) I B>0,$D(^LAB(62.06,B,0)) D AB
;W ! K LR1PASS,LRRES,LRINT,LRBN
K LR1PASS,LRRES,LRINT,LRBN ;IHS/ANMC/CLS 08/18/96
Q
CHECK S LRFLAG=0,LRBN=2 K LR1PASS F I=0:0 S LRBN=+$O(^LR(LRDFN,"MI",LRIDT,3,LRBUG,LRBN)) Q:LRBN'["2."!($G(LREND)) S B=^(LRBN),B1=$P(B,U),B2=$P(B,U,2) I $L(B1),$D(^LAB(62.06,"AI",LRBN,B1)) D FIRST
S LRBN=2 F I=0:0 S LRBN=+$O(LR1PASS(LRBN)) Q:LRBN<1!($G(LREND)) 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
Q
FIRST S B2=$S(B2]"":B2,1:^(B1)),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 Q:$G(LREND)
S J=$P(^LAB(62.06,B,0),U,2) I $D(LRINT(J)),LRINT(J)'?."^" W !,$E($P(^(0),U),1,14) S LRDCOM=$P(^(0),U,3),LRACNT=LRACNT+1 D SIR I $Y>(IOSL-3),LRACNT<LRABCNT D FH^LRMIPSU Q:LREND D BUGHDR
Q
BUGHDR S LRBUG=0 F A=0:1 S LRBUG=+$O(^LR(LRDFN,"MI",LRIDT,3,LRBUG)) Q:LRBUG<1!($G(LREND)) S LRORG=$P(^(LRBUG,0),U),LRORG=$P(^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" W ! F J=1:1:A W ?J-1*13+15,":"
W ! F J=1:1:A W:LRFMT'="B" ?(J*5+10),":" I LRFMT="B" W ?J-1*13+15,"SUSC INTP"
Q
ORG W ! I A>0 F J=1:1:A W ?($S(LRFMT="B":J-1*13+15,1:J*5+10)),":"
W ?($S(LRFMT="B":A*13+15,1:A*5+15)),$S(LR2ORMOR:LRBUG_". ",1:""),LRORG
Q
SIR F II=1:1:10 D:$P(LRINT(J),U,II,10)="" DCOM Q:$P(LRINT(J),U,II,10)="" W:LRFMT'="B" ?(II*5+10),$S(LRFMT="I":$P(LRINT(J),U,II),1:$P(LRRES(J),U,II)) I LRFMT="B" D SIR1
Q
DCOM W ?LRCOMTAB,LRDCOM I $D(LRDCOM(J)) S K=0,A=0 F I=0:0 S A=+$O(LRDCOM(J,A)) Q:A<1 W:'('K&(LRDCOM="")) ! W ?LRCOMTAB,LRDCOM(J,A) S K=1
Q
SIR1 W ?(II-1*13+15),$S($D(LRRES(J)):$P(LRRES(J),U,II),1:""),?(II-1*13+21),$P(LRINT(J),U,II)," "
Q
NHDR F X=1:1 W ! Q:$Y>(IOSL-LRFLIP)
Q:$G(LREND) I 'LRHC D FH^LRMIPSU Q
W ! F X=1:1:80 W "-"
W !,"PATIENT'S IDENTIFICATION",?60,"MICROBIOLOGY REPORT"
;W !!,PNM,?$X+3,SSN,?$X+3,SEX,?$X+3,"DOB: ",DOB," WARD: ",LRWRD,!,"ADM: ",LRADM," ADM DX: ",LRADX
W !!,PNM,?$X+3,HRCN,?$X+3,SEX,?$X+3,"DOB: ",DOB," WARD: ",LRWRD,!,"ADM: ",LRADM," ADM DX: ",LRADX ;IHS/ANMC/CLS 08/18/96
S LRPG=LRPG+1 W @IOF,!,?18,"MICROBIOLOGY LAB ",$$INS^LRU S X="T" D ^%DT,D^LRU W ?$X+10,Y,! F X=1:1:80 W "-"
W !,"ACCESSION: ",LRACC,?25,"TAKEN:",LRTK,?52,"RECEIVED:",LRRC
Q
LRMIPSZ5 ; IHS/DIR/FJE - MICRO PATIENT REPORT - BACTERIA, ANTIBIOTICS 10/24/88 16:18 ;
+1 ;;5.2;LR;**1013**;JUL 15, 2002
+2 ;
+3 ;;5.2;LAB SERVICE;;Sep 27, 1994
BACT ;from LRMIPSZ2
+1 IF +$ORDER(^LR(LRDFN,"MI",LRIDT,3,0))<1
QUIT
+2 SET LRFMT=$PIECE(^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 I=0:0
SET LRBN=+$ORDER(LRRES(LRBN))
IF LRBN<1
QUIT
SET LRABCNT=LRABCNT+1
+6 IF 'LRABCNT!($GET(LREND))
QUIT
IF $Y>(IOSL-LRABCNT-LRFLIP-1)
DO NHDR
IF LREND
QUIT
WRITE !!,"ANTIBIOTIC SUSCEPTIBILITY TEST RESULTS:"
IF $DATA(^XUSEC("LRLAB",DUZ))&'$DATA(LRWRDVEW)
WRITE " ('*' indicates display is suppressed)"
IF LRHC
WRITE !
DO BUGHDR
+7 SET LRCOMTAB=$SELECT(LRFMT="B":A*13+17,1:A*5+17)
+8 SET (LRAO,LRACNT)=0
FOR I=0:0
SET LRAO=$ORDER(^LAB(62.06,"AO",LRAO))
IF LRAO<.001!($GET(LREND))
QUIT
SET B=$ORDER(^LAB(62.06,"AO",LRAO,0))
IF B>0
IF $DATA(^LAB(62.06,B,0))
DO AB
+9 ;W ! K LR1PASS,LRRES,LRINT,LRBN
+10 ;IHS/ANMC/CLS 08/18/96
KILL LR1PASS,LRRES,LRINT,LRBN
+11 QUIT
CHECK SET LRFLAG=0
SET LRBN=2
KILL LR1PASS
FOR I=0:0
SET LRBN=+$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBUG,LRBN))
IF LRBN'["2."!($GET(LREND))
QUIT
SET B=^(LRBN)
SET B1=$PIECE(B,U)
SET B2=$PIECE(B,U,2)
IF $LENGTH(B1)
IF $DATA(^LAB(62.06,"AI",LRBN,B1))
DO FIRST
+1 SET LRBN=2
FOR I=0:0
SET LRBN=+$ORDER(LR1PASS(LRBN))
IF LRBN<1!($GET(LREND))
QUIT
SET B=LR1PASS(LRBN)
SET B1=$PIECE(B,U)
SET B2=$PIECE(B,U,2)
SET B3=$PIECE(B,U,3)
DO LAB
+2 KILL LRBN,LR1PASS,LRFLAG,B,B1,B2,B3
+3 QUIT
FIRST SET B2=$SELECT(B2]"":B2,1:^(B1))
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 IF $GET(LREND)
QUIT
+1 SET J=$PIECE(^LAB(62.06,B,0),U,2)
IF $DATA(LRINT(J))
IF LRINT(J)'?."^"
WRITE !,$EXTRACT($PIECE(^(0),U),1,14)
SET LRDCOM=$PIECE(^(0),U,3)
SET LRACNT=LRACNT+1
DO SIR
IF $Y>(IOSL-3)
IF LRACNT<LRABCNT
DO FH^LRMIPSU
IF LREND
QUIT
DO BUGHDR
+2 QUIT
BUGHDR SET LRBUG=0
FOR A=0:1
SET LRBUG=+$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBUG))
IF LRBUG<1!($GET(LREND))
QUIT
SET LRORG=$PIECE(^(LRBUG,0),U)
SET LRORG=$PIECE(^LAB(61.2,LRORG,0),U)
IF +$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBUG,2))'["2."
SET A=A-1
IF +$ORDER(^(2))["2."
DO ORG
+1 IF LRFMT="B"
WRITE !
FOR J=1:1:A
WRITE ?J-1*13+15,":"
+2 WRITE !
FOR J=1:1:A
IF LRFMT'="B"
WRITE ?(J*5+10),":"
IF LRFMT="B"
WRITE ?J-1*13+15,"SUSC INTP"
+3 QUIT
ORG WRITE !
IF A>0
FOR J=1:1:A
WRITE ?($SELECT(LRFMT="B":J-1*13+15,1:J*5+10)),":"
+1 WRITE ?($SELECT(LRFMT="B":A*13+15,1:A*5+15)),$SELECT(LR2ORMOR:LRBUG_". ",1:""),LRORG
+2 QUIT
SIR FOR II=1:1:10
IF $PIECE(LRINT(J),U,II,10)=""
DO DCOM
IF $PIECE(LRINT(J),U,II,10)=""
QUIT
IF LRFMT'="B"
WRITE ?(II*5+10),$SELECT(LRFMT="I":$PIECE(LRINT(J),U,II),1:$PIECE(LRRES(J),U,II))
IF LRFMT="B"
DO SIR1
+1 QUIT
DCOM WRITE ?LRCOMTAB,LRDCOM
IF $DATA(LRDCOM(J))
SET K=0
SET A=0
FOR I=0:0
SET A=+$ORDER(LRDCOM(J,A))
IF A<1
QUIT
IF '('K&(LRDCOM=""))
WRITE !
WRITE ?LRCOMTAB,LRDCOM(J,A)
SET K=1
+1 QUIT
SIR1 WRITE ?(II-1*13+15),$SELECT($DATA(LRRES(J)):$PIECE(LRRES(J),U,II),1:""),?(II-1*13+21),$PIECE(LRINT(J),U,II)," "
+1 QUIT
NHDR FOR X=1:1
WRITE !
IF $Y>(IOSL-LRFLIP)
QUIT
+1 IF $GET(LREND)
QUIT
IF 'LRHC
DO FH^LRMIPSU
QUIT
+2 WRITE !
FOR X=1:1:80
WRITE "-"
+3 WRITE !,"PATIENT'S IDENTIFICATION",?60,"MICROBIOLOGY REPORT"
+4 ;W !!,PNM,?$X+3,SSN,?$X+3,SEX,?$X+3,"DOB: ",DOB," WARD: ",LRWRD,!,"ADM: ",LRADM," ADM DX: ",LRADX
+5 ;IHS/ANMC/CLS 08/18/96
WRITE !!,PNM,?$X+3,HRCN,?$X+3,SEX,?$X+3,"DOB: ",DOB," WARD: ",LRWRD,!,"ADM: ",LRADM," ADM DX: ",LRADX
+6 SET LRPG=LRPG+1
WRITE @IOF,!,?18,"MICROBIOLOGY LAB ",$$INS^LRU
SET X="T"
DO ^%DT
DO D^LRU
WRITE ?$X+10,Y,!
FOR X=1:1:80
WRITE "-"
+7 WRITE !,"ACCESSION: ",LRACC,?25,"TAKEN:",LRTK,?52,"RECEIVED:",LRRC
+8 QUIT
