LAMIAUT3 ;DALOI/JMC - MICRO DISPLAY ANTIBIOTICS FOR VERIFY ;06/04/12 16:23
;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
;
;
BACT ; From LAMIAUT1, LAMIAUT4, LAMIAUT6, LAMIVTL4
;
N A,B,LR1PASS,LR2ORMOR,LRAO,LRABCNT,LRACNT,LRBN,LRBUG,LRCOMTAB,LRINT,LRRES
S LR2ORMOR=1,LREND=0 Q:+$O(^LR(LRDFN,"MI",LRIDT,3,0))<1
D BUGHDR
;
S LRBUG=0
F A=1:1 S LRBUG=+$O(^LR(LRDFN,"MI",LRIDT,3,LRBUG)) Q:LRBUG<1 D
. I +$O(^LR(LRDFN,"MI",LRIDT,3,LRBUG,2))'["2." S A=A-1 Q
. D CHECK
;
S (LRABCNT,LRBN)=0
F S LRBN=+$O(LRRES(LRBN)) Q:LRBN<1 S LRABCNT=LRABCNT+1
I 'LRABCNT W !!?10,"There are NO antibiotics in the patient's file",!! Q
Q:LREND
;
S LRCOMTAB=$S(LRFMT="B":A*13+17,1:A*5+17)
S (LRAO,LREND,LRACNT)=0
F S LRAO=$O(^LAB(62.06,"AO",LRAO)) Q:LRAO<.001 D Q:LREND
. S B=$O(^LAB(62.06,"AO",LRAO,0))
. I B>0,$D(^LAB(62.06,B,0)) D Q:LREND
. . D AB
. . I $Y>(IOSL-3) D WAIT
;
W !
;
Q
;
;
CHECK ;
;
N LRBN,LR1PASS,LRFLAG,B,B1,B2,B3
;
S LRFLAG=0
F LRBN=2:0 S LRBN=+$O(^LR(LRDFN,"MI",LRIDT,3,LRBUG,LRBN)) Q:$E(LRBN,1,2)'="2." D
. S B=^LR(LRDFN,"MI",LRIDT,3,LRBUG,LRBN),B1=$P(B,U),B2=$P(B,U,2),B3=$P(B,U,3)
. I B1'="",$D(^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
;
Q
;
;
FIRST ;
S B2=$S(B2]"":B2,1:^LAB(62.06,"AI",LRBN,B1))
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(LRLABKY),'$D(LRWRDVEW) D Q
. N X
. S X=$S(B3="N"!(B3="R"&LRFLAG):B1_"*",1:B1)
. S $P(LRRES(LRBN),U,A)=X
. S X=$S(B3="N"!(B3="R"&LRFLAG):B2_"*",1:B2)
. S $P(LRINT(LRBN),U,A)=X
;
I B3=""!(B3="A")!(B3="R"&'LRFLAG) S $P(LRRES(LRBN),U,A)=B1,$P(LRINT(LRBN),U,A)=B2
;
Q
;
;
AB ;
; Check if entry is for a bacterial drug, not an AFB drug.
S J=$P(^LAB(62.06,B,0),U,2)
I J="" Q
I $D(LRINT(J)),LRINT(J)'?."^" W !,$E($P(^LAB(62.06,B,0),U),1,14) S LRDCOM=$P(^(0),U,3),LRACNT=LRACNT+1 D SIR
Q
;
;
BUGHDR ;
N A,J,LRBUG,LRORG,LRORGCOM,LRX
W @IOF
W !?5,PNM," SSN: ",SSN,!,LRACCN," ",$P(^LAB(62,LRSAMP,0),U)," ",$P(^LAB(61,LRSPEC,0),U),!
;
S LRBUG=0
F A=0:1 S LRBUG=+$O(^LR(LRDFN,"MI",LRIDT,3,LRBUG)) Q:LRBUG<1 D
. S LRX=$G(^LR(LRDFN,"MI",LRIDT,3,LRBUG,0))
. I LRX="" Q
. S LRORG=$P(LRX,U),LRORGCOM=$P(LRX,U,2),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 ;
N J
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,$S(LRORGCOM'="":" ("_LRORGCOM_")",1:"")
Q
;
;
SIR ;
;
N II
F II=1:1:10 D:$P(LRINT(J),U,II,10)="" DCOM Q:$P(LRINT(J),U,II,10)="" D
. I LRFMT'="B" W ?(II*5+10),$S(LRFMT="I":$P(LRINT(J),U,II),1:$P(LRRES(J),U,II)) Q
. 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
;
;
DCOM ;
;
N A,K
W ?LRCOMTAB,LRDCOM
I $D(LRDCOM(J)) D
. S (A,K)=0
. F S A=+$O(LRDCOM(J,A)) Q:A<1 W:'('K&(LRDCOM="")) ! W ?LRCOMTAB,LRDCOM(J,A) S K=1
Q
;
;
WAIT ; End of page/continue prompt
N DIR,DIROUT,DIRUT,STOUT,X,Y
;
S DIR(0)="E"
D ^DIR
I $D(DIRUT) S LREND=1 Q
;
W @IOF D BUGHDR
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLAMIAUT3 3476 printed Dec 13, 2024@01:43:07 Page 2
LAMIAUT3 ;DALOI/JMC - MICRO DISPLAY ANTIBIOTICS FOR VERIFY ;06/04/12 16:23
+1 ;;5.2;AUTOMATED LAB INSTRUMENTS;**74**;Sep 27, 1994;Build 229
+2 ;
+3 ;
BACT ; From LAMIAUT1, LAMIAUT4, LAMIAUT6, LAMIVTL4
+1 ;
+2 NEW A,B,LR1PASS,LR2ORMOR,LRAO,LRABCNT,LRACNT,LRBN,LRBUG,LRCOMTAB,LRINT,LRRES
+3 SET LR2ORMOR=1
SET LREND=0
if +$ORDER(^LR(LRDFN,"MI",LRIDT,3,0))<1
QUIT
+4 DO BUGHDR
+5 ;
+6 SET LRBUG=0
+7 FOR A=1:1
SET LRBUG=+$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBUG))
if LRBUG<1
QUIT
Begin DoDot:1
+8 IF +$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBUG,2))'["2."
SET A=A-1
QUIT
+9 DO CHECK
End DoDot:1
+10 ;
+11 SET (LRABCNT,LRBN)=0
+12 FOR
SET LRBN=+$ORDER(LRRES(LRBN))
if LRBN<1
QUIT
SET LRABCNT=LRABCNT+1
+13 IF 'LRABCNT
WRITE !!?10,"There are NO antibiotics in the patient's file",!!
QUIT
+14 if LREND
QUIT
+15 ;
+16 SET LRCOMTAB=$SELECT(LRFMT="B":A*13+17,1:A*5+17)
+17 SET (LRAO,LREND,LRACNT)=0
+18 FOR
SET LRAO=$ORDER(^LAB(62.06,"AO",LRAO))
if LRAO<.001
QUIT
Begin DoDot:1
+19 SET B=$ORDER(^LAB(62.06,"AO",LRAO,0))
+20 IF B>0
IF $DATA(^LAB(62.06,B,0))
Begin DoDot:2
+21 DO AB
+22 IF $Y>(IOSL-3)
DO WAIT
End DoDot:2
if LREND
QUIT
End DoDot:1
if LREND
QUIT
+23 ;
+24 WRITE !
+25 ;
+26 QUIT
+27 ;
+28 ;
CHECK ;
+1 ;
+2 NEW LRBN,LR1PASS,LRFLAG,B,B1,B2,B3
+3 ;
+4 SET LRFLAG=0
+5 FOR LRBN=2:0
SET LRBN=+$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBUG,LRBN))
if $EXTRACT(LRBN,1,2)'="2."
QUIT
Begin DoDot:1
+6 SET B=^LR(LRDFN,"MI",LRIDT,3,LRBUG,LRBN)
SET B1=$PIECE(B,U)
SET B2=$PIECE(B,U,2)
SET B3=$PIECE(B,U,3)
+7 IF B1'=""
IF $DATA(^LAB(62.06,"AI",LRBN,B1))
DO FIRST
End DoDot:1
+8 ;
+9 SET LRBN=2
+10 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
+11 ;
+12 QUIT
+13 ;
+14 ;
FIRST ;
+1 SET B2=$SELECT(B2]"":B2,1:^LAB(62.06,"AI",LRBN,B1))
+2 if $EXTRACT(B2)'="R"&("A"[B3)
SET LRFLAG=1
+3 SET LR1PASS(LRBN)=B1_U_B2_U_B3
SET ^LR(LRDFN,"MI",LRIDT,3,LRBUG,LRBN)=LR1PASS(LRBN)
+4 QUIT
+5 ;
+6 ;
LAB ;
+1 IF $DATA(LRLABKY)
IF '$DATA(LRWRDVEW)
Begin DoDot:1
+2 NEW X
+3 SET X=$SELECT(B3="N"!(B3="R"&LRFLAG):B1_"*",1:B1)
+4 SET $PIECE(LRRES(LRBN),U,A)=X
+5 SET X=$SELECT(B3="N"!(B3="R"&LRFLAG):B2_"*",1:B2)
+6 SET $PIECE(LRINT(LRBN),U,A)=X
End DoDot:1
QUIT
+7 ;
+8 IF B3=""!(B3="A")!(B3="R"&'LRFLAG)
SET $PIECE(LRRES(LRBN),U,A)=B1
SET $PIECE(LRINT(LRBN),U,A)=B2
+9 ;
+10 QUIT
+11 ;
+12 ;
AB ;
+1 ; Check if entry is for a bacterial drug, not an AFB drug.
+2 SET J=$PIECE(^LAB(62.06,B,0),U,2)
+3 IF J=""
QUIT
+4 IF $DATA(LRINT(J))
IF LRINT(J)'?."^"
WRITE !,$EXTRACT($PIECE(^LAB(62.06,B,0),U),1,14)
SET LRDCOM=$PIECE(^(0),U,3)
SET LRACNT=LRACNT+1
DO SIR
+5 QUIT
+6 ;
+7 ;
BUGHDR ;
+1 NEW A,J,LRBUG,LRORG,LRORGCOM,LRX
+2 WRITE @IOF
+3 WRITE !?5,PNM," SSN: ",SSN,!,LRACCN," ",$PIECE(^LAB(62,LRSAMP,0),U)," ",$PIECE(^LAB(61,LRSPEC,0),U),!
+4 ;
+5 SET LRBUG=0
+6 FOR A=0:1
SET LRBUG=+$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBUG))
if LRBUG<1
QUIT
Begin DoDot:1
+7 SET LRX=$GET(^LR(LRDFN,"MI",LRIDT,3,LRBUG,0))
+8 IF LRX=""
QUIT
+9 SET LRORG=$PIECE(LRX,U)
SET LRORGCOM=$PIECE(LRX,U,2)
SET LRORG=$PIECE(^LAB(61.2,LRORG,0),U)
+10 if +$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRBUG,2))'["2."
SET A=A-1
IF +$ORDER(^(2))["2."
DO ORG
End DoDot:1
+11 IF LRFMT="B"
WRITE !
FOR J=1:1:A
WRITE ?J-1*13+15,":"
+12 WRITE !
+13 FOR J=1:1:A
if LRFMT'="B"
WRITE ?(J*5+10),":"
IF LRFMT="B"
WRITE ?J-1*13+15,"SUSC INTP"
+14 QUIT
+15 ;
+16 ;
ORG ;
+1 NEW J
+2 WRITE !
+3 IF A>0
FOR J=1:1:A
WRITE ?($SELECT(LRFMT="B":J-1*13+15,1:J*5+10)),":"
+4 WRITE ?($SELECT(LRFMT="B":A*13+15,1:A*5+15)),$SELECT(LR2ORMOR:LRBUG_". ",1:""),LRORG,$SELECT(LRORGCOM'="":" ("_LRORGCOM_")",1:"")
+5 QUIT
+6 ;
+7 ;
SIR ;
+1 ;
+2 NEW II
+3 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
+4 IF LRFMT'="B"
WRITE ?(II*5+10),$SELECT(LRFMT="I":$PIECE(LRINT(J),U,II),1:$PIECE(LRRES(J),U,II))
QUIT
+5 WRITE ?(II-1*13+15),$SELECT($DATA(LRRES(J)):$PIECE(LRRES(J),U,II),1:""),?(II-1*13+21),$PIECE(LRINT(J),U,II)," "
End DoDot:1
+6 QUIT
+7 ;
+8 ;
DCOM ;
+1 ;
+2 NEW A,K
+3 WRITE ?LRCOMTAB,LRDCOM
+4 IF $DATA(LRDCOM(J))
Begin DoDot:1
+5 SET (A,K)=0
+6 FOR
SET A=+$ORDER(LRDCOM(J,A))
if A<1
QUIT
if '('K&(LRDCOM=""))
WRITE !
WRITE ?LRCOMTAB,LRDCOM(J,A)
SET K=1
End DoDot:1
+7 QUIT
+8 ;
+9 ;
WAIT ; End of page/continue prompt
+1 NEW DIR,DIROUT,DIRUT,STOUT,X,Y
+2 ;
+3 SET DIR(0)="E"
+4 DO ^DIR
+5 IF $DATA(DIRUT)
SET LREND=1
QUIT
+6 ;
+7 WRITE @IOF
DO BUGHDR
+8 ;
+9 QUIT
