- 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