LRMIBUG ;AVAMC/REG,SLC/CJS,BA- DISPLAY ORGANISMS ;JUL 06, 2010 3:14 PM;
;;5.2;LAB SERVICE;**1013,1018,,1027,1031**;NOV 01, 1997
;
; VA Patch(s): 318,321,339
;
BUGS ; Q:$G(LREND) D KVAR^VADPT S LR1PASS=1 F I=0:0 D BUGIN Q:Y<1 S LRBG1=Y(0) D:$P(Y,U,3)&($P(LRPARAM,U,14))&($P($G(^LRO(68,LRAA,0)),U,16)) ETIO^LRCAPV1 D BUGGER,BUGOUT
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
Q:$G(LREND)
D KVAR^VADPT
S LR1PASS=1
F I=0:0 D BUGIN Q:+$G(Y)<1 S LRBG1=Y(0) D:$P(Y,U,3)&($P(LRPARAM,U,14))&($P($G(^LRO(68,LRAA,0)),U,16)) ETIO^LRCAPV1 D BUGGER,BUGOUT
; ----- END IHS/MSC/MKK - LR*5.2*1031
D BUGOUT K LR1PASS,LRBG,LRBI,LRBG1
Q
BUGIN S DIC=DIC_DA_",3,",LRODA=DA,LRODIE=DIE,DA(1)=DA,DA(2)=LRDFN,DIC(0)="AEFLMOQZ",DIC("S")="I 1 Q:$D(^LR(DA(2),""MI"",DA(1),3,+X)) Q:'$D(^LAB(61.2,+X,0)) I $L($P(^(0),U,5)),""PVRBFM""[$P(^(0),U,5)"
S:'$D(@(DIC_"0)")) ^(0)="^63.3PA" S LRSPEC=$P(^LR(LRDFN,"MI",LRIDT,0),U,5)
; W ! S LRBG=0 F I=0:0 S LRBG=$O(^LR(LRDFN,"MI",DA,3,LRBG)) Q:LRBG<1 S LRBUG=+^(LRBG,0) K DIC("B") S:LRBG=1&LR1PASS DIC("B")=$P(^LAB(61.2,+^LR(LRDFN,"MI",DA,3,1,0),0),U) W !?2,LRBG,?5,$P(^LAB(61.2,LRBUG,0),U)
; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
; The micro-organism field can be blank. Modify above line of code.
; Making it multiple lines so it's easier to read.
NEW LRBUGG
W !
S LRBG=0
F I=0:0 S LRBG=$O(^LR(LRDFN,"MI",DA,3,LRBG)) Q:LRBG<1 D
. S LRBUG=+$G(^LR(LRDFN,"MI",DA,3,LRBG,0))
. Q:LRBUG<1 ; If no Organism, get next anitimicrobial entry
. ;
. S LRBUGG=LRBUG
. K DIC("B")
. S:LRBG=1&LR1PASS DIC("B")=$P(^LAB(61.2,+^LR(LRDFN,"MI",DA,3,1,0),0),U)
. W !?2,LRBG,?5,$P(^LAB(61.2,LRBUG,0),U)
; Q:+$G(LRBUGG)<1 ; Quit if LRBUGG variable null ==> LRBUG variable never set
; ----- END IHS/MSC/MKK - LR*5.2*1031
;
S DLAYGO=63 D ^DIC K DIC("B"),DIC("S"),DLAYGO S LR1PASS=0
Q
;
BUGGER S LRNB=$S($L($P(^LAB(61.2,+LRBG1,0),U,4)):$P(^(0),U,4),1:LRMIDEF),LRBI=$P(^(0),U,5)
N LRTHISDA
S DIE=DIC,DA=+Y,LRTHISDA=DA D TEMP,^DIE,DELINT I '$D(Y) Q
W !,"Any other antibiotics" S %=2 D YN^DICN I %'=1 Q
I '$L(LRMIOTH) S DR="S Y=200;2.0000001:200",DR(2,63.32)=.01 D ^DIE Q
K DR S LRNB=LRMIOTH D TEMP F J=1:1 S K=$P(DR,";",J) Q:+K'=K!(K>2)!'$L(K)
S (DR,DR(1,63.3))=$P(DR,";",J,245) D ^DIE
Q
TEMP S LRNB=+$O(^DIE("B",$S($L(LRNB):LRNB,1:0),0))
I LRNB,$D(^DIE(LRNB,"DR",3,63.3)) S (DR,DR(1,63.3))=^(63.3),J=0 F I=0:0 S J=$O(^DIE(LRNB,"DR",3,63.3,J)) Q:J<1 S DR(1,63.3,J)=^(J)
I 'LRNB!('$D(^DIE(LRNB,"DR",3,63.3))) S DR=$S(($L(LRBI)&("MFBVRP"[LRBI)):".01;1;2",1:".01;1;2:195")
Q
BUGOUT S (DIE,DIC)=LRODIE,DA=LRODA,DA(1)=LRDFN K DR(1,63.3)
Q
DELINT ; If a Result is (1st piece) deleted in ^LR(LRDFN,"MI",LRIDT,3
; the associated Interpretation (2nd piece) should be deleted
; as well. If S^S^ exists, and the Result is deleted, ^S^ Interpretation remains.
; This process will clean up the remaining Interpretation
Q:'LRDFN!('LRIDT)!('LRTHISDA)
N LRXX,I
S LRXX=2 ;This node bumps in fractions exp. 2.001 2.00234
F I=1:1 S LRXX=$O(^LR(LRDFN,"MI",LRIDT,3,LRTHISDA,LRXX)) Q:'LRXX!(LRXX'<3) D
.I $P(^LR(LRDFN,"MI",LRIDT,3,LRTHISDA,LRXX),U)="" S $P(^LR(LRDFN,"MI",LRIDT,3,LRTHISDA,LRXX),U,2)=""
Q
LRMIBUG ;AVAMC/REG,SLC/CJS,BA- DISPLAY ORGANISMS ;JUL 06, 2010 3:14 PM;
+1 ;;5.2;LAB SERVICE;**1013,1018,,1027,1031**;NOV 01, 1997
+2 ;
+3 ; VA Patch(s): 318,321,339
+4 ;
BUGS ; Q:$G(LREND) D KVAR^VADPT S LR1PASS=1 F I=0:0 D BUGIN Q:Y<1 S LRBG1=Y(0) D:$P(Y,U,3)&($P(LRPARAM,U,14))&($P($G(^LRO(68,LRAA,0)),U,16)) ETIO^LRCAPV1 D BUGGER,BUGOUT
+1 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+2 IF $GET(LREND)
QUIT
+3 DO KVAR^VADPT
+4 SET LR1PASS=1
+5 FOR I=0:0
DO BUGIN
IF +$GET(Y)<1
QUIT
SET LRBG1=Y(0)
IF $PIECE(Y,U,3)&($PIECE(LRPARAM,U,14))&($PIECE($GET(^LRO(68,LRAA,0)),U,16))
DO ETIO^LRCAPV1
DO BUGGER
DO BUGOUT
+6 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+7 DO BUGOUT
KILL LR1PASS,LRBG,LRBI,LRBG1
+8 QUIT
BUGIN SET DIC=DIC_DA_",3,"
SET LRODA=DA
SET LRODIE=DIE
SET DA(1)=DA
SET DA(2)=LRDFN
SET DIC(0)="AEFLMOQZ"
SET DIC("S")="I 1 Q:$D(^LR(DA(2),""MI"",DA(1),3,+X)) Q:'$D(^LAB(61.2,+X,0)) I $L($P(^(0),U,5)),""PVRBFM""[$P(^(0),U,5)"
+1 IF '$DATA(@(DIC_"0)"))
SET ^(0)="^63.3PA"
SET LRSPEC=$PIECE(^LR(LRDFN,"MI",LRIDT,0),U,5)
+2 ; W ! S LRBG=0 F I=0:0 S LRBG=$O(^LR(LRDFN,"MI",DA,3,LRBG)) Q:LRBG<1 S LRBUG=+^(LRBG,0) K DIC("B") S:LRBG=1&LR1PASS DIC("B")=$P(^LAB(61.2,+^LR(LRDFN,"MI",DA,3,1,0),0),U) W !?2,LRBG,?5,$P(^LAB(61.2,LRBUG,0),U)
+3 ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
+4 ; The micro-organism field can be blank. Modify above line of code.
+5 ; Making it multiple lines so it's easier to read.
+6 NEW LRBUGG
+7 WRITE !
+8 SET LRBG=0
+9 FOR I=0:0
SET LRBG=$ORDER(^LR(LRDFN,"MI",DA,3,LRBG))
IF LRBG<1
QUIT
Begin DoDot:1
+10 SET LRBUG=+$GET(^LR(LRDFN,"MI",DA,3,LRBG,0))
+11 ; If no Organism, get next anitimicrobial entry
IF LRBUG<1
QUIT
+12 ;
+13 SET LRBUGG=LRBUG
+14 KILL DIC("B")
+15 IF LRBG=1&LR1PASS
SET DIC("B")=$PIECE(^LAB(61.2,+^LR(LRDFN,"MI",DA,3,1,0),0),U)
+16 WRITE !?2,LRBG,?5,$PIECE(^LAB(61.2,LRBUG,0),U)
End DoDot:1
+17 ; Q:+$G(LRBUGG)<1 ; Quit if LRBUGG variable null ==> LRBUG variable never set
+18 ; ----- END IHS/MSC/MKK - LR*5.2*1031
+19 ;
+20 SET DLAYGO=63
DO ^DIC
KILL DIC("B"),DIC("S"),DLAYGO
SET LR1PASS=0
+21 QUIT
+22 ;
BUGGER SET LRNB=$SELECT($LENGTH($PIECE(^LAB(61.2,+LRBG1,0),U,4)):$PIECE(^(0),U,4),1:LRMIDEF)
SET LRBI=$PIECE(^(0),U,5)
+1 NEW LRTHISDA
+2 SET DIE=DIC
SET DA=+Y
SET LRTHISDA=DA
DO TEMP
DO ^DIE
DO DELINT
IF '$DATA(Y)
QUIT
+3 WRITE !,"Any other antibiotics"
SET %=2
DO YN^DICN
IF %'=1
QUIT
+4 IF '$LENGTH(LRMIOTH)
SET DR="S Y=200;2.0000001:200"
SET DR(2,63.32)=.01
DO ^DIE
QUIT
+5 KILL DR
SET LRNB=LRMIOTH
DO TEMP
FOR J=1:1
SET K=$PIECE(DR,";",J)
IF +K'=K!(K>2)!'$LENGTH(K)
QUIT
+6 SET (DR,DR(1,63.3))=$PIECE(DR,";",J,245)
DO ^DIE
+7 QUIT
TEMP SET LRNB=+$ORDER(^DIE("B",$SELECT($LENGTH(LRNB):LRNB,1:0),0))
+1 IF LRNB
IF $DATA(^DIE(LRNB,"DR",3,63.3))
SET (DR,DR(1,63.3))=^(63.3)
SET J=0
FOR I=0:0
SET J=$ORDER(^DIE(LRNB,"DR",3,63.3,J))
IF J<1
QUIT
SET DR(1,63.3,J)=^(J)
+2 IF 'LRNB!('$DATA(^DIE(LRNB,"DR",3,63.3)))
SET DR=$SELECT(($LENGTH(LRBI)&("MFBVRP"[LRBI)):".01;1;2",1:".01;1;2:195")
+3 QUIT
BUGOUT SET (DIE,DIC)=LRODIE
SET DA=LRODA
SET DA(1)=LRDFN
KILL DR(1,63.3)
+1 QUIT
DELINT ; If a Result is (1st piece) deleted in ^LR(LRDFN,"MI",LRIDT,3
+1 ; the associated Interpretation (2nd piece) should be deleted
+2 ; as well. If S^S^ exists, and the Result is deleted, ^S^ Interpretation remains.
+3 ; This process will clean up the remaining Interpretation
+4 IF 'LRDFN!('LRIDT)!('LRTHISDA)
QUIT
+5 NEW LRXX,I
+6 ;This node bumps in fractions exp. 2.001 2.00234
SET LRXX=2
+7 FOR I=1:1
SET LRXX=$ORDER(^LR(LRDFN,"MI",LRIDT,3,LRTHISDA,LRXX))
IF 'LRXX!(LRXX'<3)
QUIT
Begin DoDot:1
+8 IF $PIECE(^LR(LRDFN,"MI",LRIDT,3,LRTHISDA,LRXX),U)=""
SET $PIECE(^LR(LRDFN,"MI",LRIDT,3,LRTHISDA,LRXX),U,2)=""
End DoDot:1
+9 QUIT
