- 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 Apr 23, 2025@17:57:33 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
