Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRMIBUG

LRMIBUG.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; VA Patch(s): 318,321,339
  1. ;
  1. 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
  1. Q:$G(LREND)
  1. D KVAR^VADPT
  1. S LR1PASS=1
  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
  1. ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1. D BUGOUT K LR1PASS,LRBG,LRBI,LRBG1
  1. Q
  1. 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)"
  1. S:'$D(@(DIC_"0)")) ^(0)="^63.3PA" S LRSPEC=$P(^LR(LRDFN,"MI",LRIDT,0),U,5)
  1. ; 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)
  1. ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1. ; The micro-organism field can be blank. Modify above line of code.
  1. ; Making it multiple lines so it's easier to read.
  1. NEW LRBUGG
  1. W !
  1. S LRBG=0
  1. F I=0:0 S LRBG=$O(^LR(LRDFN,"MI",DA,3,LRBG)) Q:LRBG<1 D
  1. . S LRBUG=+$G(^LR(LRDFN,"MI",DA,3,LRBG,0))
  1. . Q:LRBUG<1 ; If no Organism, get next anitimicrobial entry
  1. . ;
  1. . S LRBUGG=LRBUG
  1. . K DIC("B")
  1. . S:LRBG=1&LR1PASS DIC("B")=$P(^LAB(61.2,+^LR(LRDFN,"MI",DA,3,1,0),0),U)
  1. . W !?2,LRBG,?5,$P(^LAB(61.2,LRBUG,0),U)
  1. ; Q:+$G(LRBUGG)<1 ; Quit if LRBUGG variable null ==> LRBUG variable never set
  1. ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1. ;
  1. S DLAYGO=63 D ^DIC K DIC("B"),DIC("S"),DLAYGO S LR1PASS=0
  1. Q
  1. ;
  1. BUGGER S LRNB=$S($L($P(^LAB(61.2,+LRBG1,0),U,4)):$P(^(0),U,4),1:LRMIDEF),LRBI=$P(^(0),U,5)
  1. N LRTHISDA
  1. S DIE=DIC,DA=+Y,LRTHISDA=DA D TEMP,^DIE,DELINT I '$D(Y) Q
  1. W !,"Any other antibiotics" S %=2 D YN^DICN I %'=1 Q
  1. I '$L(LRMIOTH) S DR="S Y=200;2.0000001:200",DR(2,63.32)=.01 D ^DIE Q
  1. K DR S LRNB=LRMIOTH D TEMP F J=1:1 S K=$P(DR,";",J) Q:+K'=K!(K>2)!'$L(K)
  1. S (DR,DR(1,63.3))=$P(DR,";",J,245) D ^DIE
  1. Q
  1. TEMP S LRNB=+$O(^DIE("B",$S($L(LRNB):LRNB,1:0),0))
  1. 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)
  1. I 'LRNB!('$D(^DIE(LRNB,"DR",3,63.3))) S DR=$S(($L(LRBI)&("MFBVRP"[LRBI)):".01;1;2",1:".01;1;2:195")
  1. Q
  1. BUGOUT S (DIE,DIC)=LRODIE,DA=LRODA,DA(1)=LRDFN K DR(1,63.3)
  1. Q
  1. DELINT ; If a Result is (1st piece) deleted in ^LR(LRDFN,"MI",LRIDT,3
  1. ; the associated Interpretation (2nd piece) should be deleted
  1. ; as well. If S^S^ exists, and the Result is deleted, ^S^ Interpretation remains.
  1. ; This process will clean up the remaining Interpretation
  1. Q:'LRDFN!('LRIDT)!('LRTHISDA)
  1. N LRXX,I
  1. S LRXX=2 ;This node bumps in fractions exp. 2.001 2.00234
  1. F I=1:1 S LRXX=$O(^LR(LRDFN,"MI",LRIDT,3,LRTHISDA,LRXX)) Q:'LRXX!(LRXX'<3) D
  1. .I $P(^LR(LRDFN,"MI",LRIDT,3,LRTHISDA,LRXX),U)="" S $P(^LR(LRDFN,"MI",LRIDT,3,LRTHISDA,LRXX),U,2)=""
  1. Q