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

GMTSLRME.m

Go to the documentation of this file. 
  1. GMTSLRME ; SLC/JER,KER - Microbiology Extract Routine ; 08/27/2002
  1.  ;;2.7;Health Summary;**25,28,37,56**;Oct 20, 1995
  1.  ;                    
  1.  ; External References
  1.  ;   DBIA    67  ^LAB(60
  1.  ;   DBIA   525  ^LR(
  1.  ;   DBIA   531  ^LRO(68
  1.  ;   DBIA 10006  ^DIC
  1.  ;   DBIA 10007  MIX^DIC1
  1.  ;   DBIA  2056  $$GET1^DIQ
  1.  ;   DBIA 10015  EN^DIQ1
  1.  ;                    
  1. XTRCT ; Extract
  1.  N ACC,CDT,SS,CS,X,DIC,DIQ,DA,DR,MICRO,LOC,RDT,MICCOM K ^TMP("LRM",$J)
  1.  S X=$P(^LR(LRDFN,"MI",IX,0),U),RDT=$P(^(0),U,3),ACC=$P(^(0),U,6),LOC=$P(^(0),U,8) D REGDTM4^GMTSU S CDT=X K X
  1.  D LABTEST($P(^LR(LRDFN,"MI",IX,0),U),ACC)
  1.  ;   Get External format of site/specimen
  1.  ;   collection sample, and comment
  1.  S DIC=63,DIQ="MICRO",DIQ(0)="E",DA=LRDFN,DA(63.05)=IX,DR=5,DR(63.05)=".05;.055;.99"
  1.  D EN^DIQ1
  1.  S SS=MICRO(63.05,IX,.05,"E")
  1.  S CS=MICRO(63.05,IX,.055,"E"),MICCOM=MICRO(63.05,IX,.99,"E")
  1.  S ^TMP("LRM",$J,0)=CDT_U_ACC_U_SS I $D(EXPAND) S ^TMP("LRM",$J,0)=^TMP("LRM",$J,0)_U_RDT_U_LOC
  1.  S $P(^TMP("LRM",$J,0),U,6)=CS_U_MICCOM
  1.  D ABXLEV,BACT,GRAM,STER,PARA^GMTSLRMX,MYCO^GMTSLRMX,TB^GMTSLRMX,VIRO^GMTSLRMX
  1.  Q
  1. BACT ; Get Bacteriology Work-up
  1.  N DA,DIC,DIQ,DR,STATUS,ISO,ORG,RMK,COM,SMEAR
  1.  ;   Work up
  1.  I $D(^LR(LRDFN,"MI",IX,1)) D
  1.  . S DIC=63,DA=LRDFN,DA(63.05)=IX,DR=5,DR(63.05)="11.5;11.51;11.57;11.58",DIQ="STATUS"
  1.  . S DIQ(0)="E" D EN^DIQ1
  1.  . ;     Include Status, sputum screen, and urine screen
  1.  . S ^TMP("LRM",$J,"BACT",0)=$E($P(STATUS(63.05,IX,11.5,"E")," ",1),1,6)_U_STATUS(63.05,IX,11.58,"E")_U_STATUS(63.05,IX,11.57,"E")
  1.  . ;     Include sterility control
  1.  . S ^TMP("LRM",$J,"BSTER",0)=STATUS(63.05,IX,11.51,"E")
  1.  S ISO=0 F  S ISO=$O(^LR(LRDFN,"MI",IX,3,ISO)) Q:+ISO'>0  D
  1.  . D ORGNSM S ^TMP("LRM",$J,"BACT",ISO)=$S($D(EXPAND):ISO_";"_ORG,1:ORG)
  1.  . I $O(^LR(LRDFN,"MI",IX,3,ISO,1)) D ANTIBX
  1.  . ;     Get Comment
  1.  . S COM=0
  1.  . F  S COM=$O(^LR(LRDFN,"MI",IX,3,ISO,1,COM)) Q:COM'>0  S ^TMP("LRM",$J,"BACT",ISO,"COM",COM)=^(COM,0)
  1.  ;   Bacteriology smear/prep
  1.  S SMEAR=0
  1.  F  S SMEAR=$O(^LR(LRDFN,"MI",IX,25,SMEAR)) Q:SMEAR'>0  S ^TMP("LRM",$J,"BACT","SMEAR",SMEAR)=^(SMEAR,0)
  1.  ;     Get Remark
  1.  S RMK=0
  1.  F  S RMK=$O(^LR(LRDFN,"MI",IX,4,RMK)) Q:RMK=""  S ^TMP("LRM",$J,"BACT","R",RMK)=^(RMK,0)
  1.  Q
  1. ORGNSM ; Get Organism
  1.  N QTY
  1.  S ORG=+^LR(LRDFN,"MI",IX,3,ISO,0),QTY=$P(^(0),U,2)
  1.  S ORG=$$GET1^DIQ(61.2,ORG,.01,"I")
  1.  S ORG=ORG_U_QTY
  1.  Q
  1. ANTIBX ; Get Antibitiotic susceptibility results on demand
  1.  N ABX S ABX=1
  1.  F  S ABX=$O(^LR(LRDFN,"MI",IX,3,ISO,ABX)) Q:ABX=""!(ABX'<3)  D ABXSET
  1.  Q
  1. ABXSET ; Antibiotic Susceptability Data
  1.  ;   Separate out by Susceptable, Intermediate, and Resistant
  1.  N FOUND,GMTSR,GMABX,ABXI,ABXNM,ABXN
  1.  S ABXI=$$ABXI(ABX),ABXNM=$$ABXNM(ABXI),ABXN=ABX_";"_ABXNM
  1.  I $P(ABXN,";",2)']"" S $P(ABXN,";",2)="UNKNOWN"
  1.  I ("A"[$P(^LR(LRDFN,"MI",IX,3,ISO,ABX),U,3)) D
  1.  . S GMABX=$G(^LR(LRDFN,"MI",IX,3,ISO,ABX))
  1.  . ;     Check for interpreted result (S, I, or R) first
  1.  . S FOUND=0
  1.  . S GMTSR=$P(GMABX,U,2) D SAVE Q:FOUND
  1.  . ;     If not found then check reported result (S,I, or R)
  1.  . S GMTSR=$P(GMABX,U) D SAVE Q:FOUND
  1.  . ;     Neither interpreted nor reported result equaled
  1.  . ;     S, I, or R so we'll store it in the "other" list
  1.  . ;     provided that reported and interpreted are both
  1.  . ;     not null
  1.  . S:$P(GMABX,U)'=""&($P(GMABX,U,2)'="") ^TMP("LRM",$J,"BACT",ISO,"SUSC","O",$P($P(ABXN,U),";",2))=ABXN_U_GMABX
  1.  Q
  1. ABXI(X) ; Antibiotic Susceptability IEN
  1.  S X=$G(X) Q:'$L(X) 0 N DIC,DTOUT,DUOUT,Y S DIC="^LAB(62.06,",D="AD",DIC(0)="" D MIX^DIC1 S X=+($G(Y)) S:X'>0 X=0 Q X
  1. ABXNM(X) ; Antibiotic Susceptability Name
  1.  S X=$G(X) Q:+X'>0 "" S X=$$GET1^DIQ(62.06,+X,.01) Q X
  1. ABXLEV ; Get Serum antibiotic level
  1.  Q:'$D(^LR(LRDFN,"MI",IX,14))  N GMI S GMI=0
  1.  F  S GMI=$O(^LR(LRDFN,"MI",IX,14,GMI)) Q:GMI'>0  S ^TMP("LRM",$J,"CABXL",GMI)=$G(^(GMI,0))
  1.  Q
  1. STER ; Get sterility results if they exist
  1.  N RESULT,STER S STER=0
  1.  F  S STER=$O(^LR(LRDFN,"MI",IX,31,STER)) Q:STER'>0  D
  1.  . S DIQ(0)="E",DIC=63,DA=LRDFN,DA(63.05)=IX,DR=5,DR(63.05)=11.52
  1.  . S DR(63.292)=.01,DIQ="RESULT"
  1.  . S DA(63.292)=STER
  1.  . D EN^DIQ1
  1.  . S ^TMP("LRM",$J,"BSTER",STER)=RESULT(63.292,STER,.01,"E")
  1.  Q
  1. GRAM ; Get Gram Stain Results
  1.  N ISO Q:'$D(^LR(LRDFN,"MI",IX,2))  S ISO=0
  1.  F  S ISO=$O(^LR(LRDFN,"MI",IX,2,ISO)) Q:ISO=""  S ^TMP("LRM",$J,"GRAM",ISO)=^(ISO,0)
  1.  Q
  1. LABTEST(SDT,LRACC) ; Get lab test names and results
  1.  N X,Y,LRAA,LRAN,LRAD,LRBRR,LRTSTS,LRTS
  1.  S LRAD=+$E(SDT)_$P(LRACC," ",2)_"0000",X=$P(LRACC," "),DIC=68,DIC(0)="M"
  1.  Q:'$L(X)  D ^DIC S LRAA=+Y,LRAN=+$P(LRACC," ",3)
  1.  S LRBRR=0
  1.  F  S LRBRR=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR)) Q:LRBRR'>0  D
  1.  . S LRTS=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR,0),LRTS(1)=$P(^(0),U,5)
  1.  . Q:"BO"'[$P($G(^LAB(60,LRTS,0)),U,3)
  1.  . S LRTSTS=$S($D(^LAB(60,LRTS,0)):$P(^(0),U),1:"deleted test")
  1.  . ;   Lab test name and results in print order
  1.  . S ^TMP("LRM",$J,0,"TEST",$S($D(^LAB(60,LRTS,.1)):$P(^(.1),U,6),1:"")_","_U_LRBRR)=LRTSTS_U_LRTS(1)
  1.  Q
  1. SAVE ; If result = S, I, or R then save
  1.  I $S(GMTSR="I":1,GMTSR="R":1,GMTSR="S":1,1:0) S ^TMP("LRM",$J,"BACT",ISO,"SUSC",GMTSR,$P($P(ABXN,U),";",2))=ABXN_U_GMABX S FOUND=1
  1.  Q