GMTSLRME ;SLC/JER,KER - Microbiology Extract Routine; Aug 02, 2022@08:31:08
;;2.7;Health Summary;**25,28,37,56,138**;Oct 20, 1995;Build 4
;
; External References
; Reference to ^LAB(60 in ICR #67
; Reference to ^LR( in ICR #525
; Reference to ^LRO(68 in ICR #531
; Reference to ^DIC in ICR #10006
; Reference to ^MIX^DIC1 in ICR #10007
; Reference to $$GET1^DIQ in ICR #2056
; Reference to EN^DIQ1 in ICR #10015
;
XTRCT ; Extract
N ACC,CDT,SS,CS,X,DIC,DIQ,DA,DR,MICRO,LOC,RDT,MICCOM K ^TMP("LRM",$J)
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
D LABTEST($P(^LR(LRDFN,"MI",IX,0),U),ACC)
; Get External format of site/specimen
; collection sample, and comment
S DIC=63,DIQ="MICRO",DIQ(0)="E",DA=LRDFN,DA(63.05)=IX,DR=5,DR(63.05)=".05;.055;.99"
D EN^DIQ1
S SS=MICRO(63.05,IX,.05,"E")
S CS=MICRO(63.05,IX,.055,"E"),MICCOM=MICRO(63.05,IX,.99,"E")
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
S $P(^TMP("LRM",$J,0),U,6)=CS_U_MICCOM
D ABXLEV,BACT,GRAM,STER,PARA^GMTSLRMX,MYCO^GMTSLRMX,TB^GMTSLRMX,VIRO^GMTSLRMX
Q
BACT ; Get Bacteriology Work-up
;Do not display if results not verified (GMTS*2.7*138)
I $P($G(^LR(LRDFN,"MI",IX,1)),U)="" D Q
. ;Were results previously verified and are now in the process
. ;of being amended?
. Q:'$D(^XTMP("LRMICRO EDIT",LRDFN,IX,1))
. S ^TMP("LRM",$J,"BACT",0)="Results currently being edited by tech code "_$G(^XTMP("LRMICRO EDIT",LRDFN,IX,1))
N DA,DIC,DIQ,DR,STATUS,ISO,ORG,RMK,COM,SMEAR
; Work up
I $D(^LR(LRDFN,"MI",IX,1)) D
. S DIC=63,DA=LRDFN,DA(63.05)=IX,DR=5,DR(63.05)="11.5;11.51;11.57;11.58",DIQ="STATUS"
. S DIQ(0)="E" D EN^DIQ1
. ; Include Status, sputum screen, and urine screen
. 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")
. ; Include sterility control
. S ^TMP("LRM",$J,"BSTER",0)=STATUS(63.05,IX,11.51,"E")
S ISO=0 F S ISO=$O(^LR(LRDFN,"MI",IX,3,ISO)) Q:+ISO'>0 D
. D ORGNSM S ^TMP("LRM",$J,"BACT",ISO)=$S($D(EXPAND):ISO_";"_ORG,1:ORG)
. I $O(^LR(LRDFN,"MI",IX,3,ISO,1)) D ANTIBX
. ; Get Comment
. S COM=0
. 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)
; Bacteriology smear/prep
S SMEAR=0
F S SMEAR=$O(^LR(LRDFN,"MI",IX,25,SMEAR)) Q:SMEAR'>0 S ^TMP("LRM",$J,"BACT","SMEAR",SMEAR)=^(SMEAR,0)
; Get Remark
S RMK=0
F S RMK=$O(^LR(LRDFN,"MI",IX,4,RMK)) Q:RMK="" S ^TMP("LRM",$J,"BACT","R",RMK)=^(RMK,0)
Q
ORGNSM ; Get Organism
N QTY
S ORG=+^LR(LRDFN,"MI",IX,3,ISO,0),QTY=$P(^(0),U,2)
S ORG=$$GET1^DIQ(61.2,ORG,.01,"I")
S ORG=ORG_U_QTY
Q
ANTIBX ; Get Antibitiotic susceptibility results on demand
N ABX S ABX=1
F S ABX=$O(^LR(LRDFN,"MI",IX,3,ISO,ABX)) Q:ABX=""!(ABX'<3) D ABXSET
Q
ABXSET ; Antibiotic Susceptability Data
; Separate out by Susceptable, Intermediate, and Resistant
N FOUND,GMTSR,GMABX,ABXI,ABXNM,ABXN
S ABXI=$$ABXI(ABX),ABXNM=$$ABXNM(ABXI),ABXN=ABX_";"_ABXNM
I $P(ABXN,";",2)']"" S $P(ABXN,";",2)="UNKNOWN"
I ("A"[$P(^LR(LRDFN,"MI",IX,3,ISO,ABX),U,3)) D
. S GMABX=$G(^LR(LRDFN,"MI",IX,3,ISO,ABX))
. ; Check for interpreted result (S, I, or R) first
. S FOUND=0
. S GMTSR=$P(GMABX,U,2) D SAVE Q:FOUND
. ; If not found then check reported result (S,I, or R)
. S GMTSR=$P(GMABX,U) D SAVE Q:FOUND
. ; Neither interpreted nor reported result equaled
. ; S, I, or R so we'll store it in the "other" list
. ; provided that reported and interpreted are both
. ; not null
. S:$P(GMABX,U)'=""&($P(GMABX,U,2)'="") ^TMP("LRM",$J,"BACT",ISO,"SUSC","O",$P($P(ABXN,U),";",2))=ABXN_U_GMABX
Q
ABXI(X) ; Antibiotic Susceptability IEN
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
ABXNM(X) ; Antibiotic Susceptability Name
S X=$G(X) Q:+X'>0 "" S X=$$GET1^DIQ(62.06,+X,.01) Q X
ABXLEV ; Get Serum antibiotic level
Q:'$D(^LR(LRDFN,"MI",IX,14)) N GMI S GMI=0
F S GMI=$O(^LR(LRDFN,"MI",IX,14,GMI)) Q:GMI'>0 S ^TMP("LRM",$J,"CABXL",GMI)=$G(^(GMI,0))
Q
STER ; Get sterility results if they exist
N RESULT,STER S STER=0
F S STER=$O(^LR(LRDFN,"MI",IX,31,STER)) Q:STER'>0 D
. S DIQ(0)="E",DIC=63,DA=LRDFN,DA(63.05)=IX,DR=5,DR(63.05)=11.52
. S DR(63.292)=.01,DIQ="RESULT"
. S DA(63.292)=STER
. D EN^DIQ1
. S ^TMP("LRM",$J,"BSTER",STER)=RESULT(63.292,STER,.01,"E")
Q
GRAM ; Get Gram Stain Results
;Do not display if results not verified (GMTS*2.7*138)
I $P($G(^LR(LRDFN,"MI",IX,1)),U)="" Q
N ISO Q:'$D(^LR(LRDFN,"MI",IX,2)) S ISO=0
F S ISO=$O(^LR(LRDFN,"MI",IX,2,ISO)) Q:ISO="" S ^TMP("LRM",$J,"GRAM",ISO)=^(ISO,0)
Q
LABTEST(SDT,LRACC) ; Get lab test names and results
N X,Y,LRAA,LRAN,LRAD,LRBRR,LRTSTS,LRTS
S LRAD=+$E(SDT)_$P(LRACC," ",2)_"0000",X=$P(LRACC," "),DIC=68,DIC(0)="M"
Q:'$L(X) D ^DIC S LRAA=+Y,LRAN=+$P(LRACC," ",3)
S LRBRR=0
F S LRBRR=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR)) Q:LRBRR'>0 D
. S LRTS=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR,0),LRTS(1)=$P(^(0),U,5)
. Q:"BO"'[$P($G(^LAB(60,LRTS,0)),U,3)
. S LRTSTS=$S($D(^LAB(60,LRTS,0)):$P(^(0),U),1:"deleted test")
. ; Lab test name and results in print order
. S ^TMP("LRM",$J,0,"TEST",$S($D(^LAB(60,LRTS,.1)):$P(^(.1),U,6),1:"")_","_U_LRBRR)=LRTSTS_U_LRTS(1)
Q
SAVE ; If result = S, I, or R then save
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSLRME 5685 printed Dec 13, 2024@01:57:50 Page 2
GMTSLRME ;SLC/JER,KER - Microbiology Extract Routine; Aug 02, 2022@08:31:08
+1 ;;2.7;Health Summary;**25,28,37,56,138**;Oct 20, 1995;Build 4
+2 ;
+3 ; External References
+4 ; Reference to ^LAB(60 in ICR #67
+5 ; Reference to ^LR( in ICR #525
+6 ; Reference to ^LRO(68 in ICR #531
+7 ; Reference to ^DIC in ICR #10006
+8 ; Reference to ^MIX^DIC1 in ICR #10007
+9 ; Reference to $$GET1^DIQ in ICR #2056
+10 ; Reference to EN^DIQ1 in ICR #10015
+11 ;
XTRCT ; Extract
+1 NEW ACC,CDT,SS,CS,X,DIC,DIQ,DA,DR,MICRO,LOC,RDT,MICCOM
KILL ^TMP("LRM",$JOB)
+2 SET X=$PIECE(^LR(LRDFN,"MI",IX,0),U)
SET RDT=$PIECE(^(0),U,3)
SET ACC=$PIECE(^(0),U,6)
SET LOC=$PIECE(^(0),U,8)
DO REGDTM4^GMTSU
SET CDT=X
KILL X
+3 DO LABTEST($PIECE(^LR(LRDFN,"MI",IX,0),U),ACC)
+4 ; Get External format of site/specimen
+5 ; collection sample, and comment
+6 SET DIC=63
SET DIQ="MICRO"
SET DIQ(0)="E"
SET DA=LRDFN
SET DA(63.05)=IX
SET DR=5
SET DR(63.05)=".05;.055;.99"
+7 DO EN^DIQ1
+8 SET SS=MICRO(63.05,IX,.05,"E")
+9 SET CS=MICRO(63.05,IX,.055,"E")
SET MICCOM=MICRO(63.05,IX,.99,"E")
+10 SET ^TMP("LRM",$JOB,0)=CDT_U_ACC_U_SS
IF $DATA(EXPAND)
SET ^TMP("LRM",$JOB,0)=^TMP("LRM",$JOB,0)_U_RDT_U_LOC
+11 SET $PIECE(^TMP("LRM",$JOB,0),U,6)=CS_U_MICCOM
+12 DO ABXLEV
DO BACT
DO GRAM
DO STER
DO PARA^GMTSLRMX
DO MYCO^GMTSLRMX
DO TB^GMTSLRMX
DO VIRO^GMTSLRMX
+13 QUIT
BACT ; Get Bacteriology Work-up
+1 ;Do not display if results not verified (GMTS*2.7*138)
+2 IF $PIECE($GET(^LR(LRDFN,"MI",IX,1)),U)=""
Begin DoDot:1
+3 ;Were results previously verified and are now in the process
+4 ;of being amended?
+5 if '$DATA(^XTMP("LRMICRO EDIT",LRDFN,IX,1))
QUIT
+6 SET ^TMP("LRM",$JOB,"BACT",0)="Results currently being edited by tech code "_$GET(^XTMP("LRMICRO EDIT",LRDFN,IX,1))
End DoDot:1
QUIT
+7 NEW DA,DIC,DIQ,DR,STATUS,ISO,ORG,RMK,COM,SMEAR
+8 ; Work up
+9 IF $DATA(^LR(LRDFN,"MI",IX,1))
Begin DoDot:1
+10 SET DIC=63
SET DA=LRDFN
SET DA(63.05)=IX
SET DR=5
SET DR(63.05)="11.5;11.51;11.57;11.58"
SET DIQ="STATUS"
+11 SET DIQ(0)="E"
DO EN^DIQ1
+12 ; Include Status, sputum screen, and urine screen
+13 SET ^TMP("LRM",$JOB,"BACT",0)=$EXTRACT($PIECE(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")
+14 ; Include sterility control
+15 SET ^TMP("LRM",$JOB,"BSTER",0)=STATUS(63.05,IX,11.51,"E")
End DoDot:1
+16 SET ISO=0
FOR
SET ISO=$ORDER(^LR(LRDFN,"MI",IX,3,ISO))
if +ISO'>0
QUIT
Begin DoDot:1
+17 DO ORGNSM
SET ^TMP("LRM",$JOB,"BACT",ISO)=$SELECT($DATA(EXPAND):ISO_";"_ORG,1:ORG)
+18 IF $ORDER(^LR(LRDFN,"MI",IX,3,ISO,1))
DO ANTIBX
+19 ; Get Comment
+20 SET COM=0
+21 FOR
SET COM=$ORDER(^LR(LRDFN,"MI",IX,3,ISO,1,COM))
if COM'>0
QUIT
SET ^TMP("LRM",$JOB,"BACT",ISO,"COM",COM)=^(COM,0)
End DoDot:1
+22 ; Bacteriology smear/prep
+23 SET SMEAR=0
+24 FOR
SET SMEAR=$ORDER(^LR(LRDFN,"MI",IX,25,SMEAR))
if SMEAR'>0
QUIT
SET ^TMP("LRM",$JOB,"BACT","SMEAR",SMEAR)=^(SMEAR,0)
+25 ; Get Remark
+26 SET RMK=0
+27 FOR
SET RMK=$ORDER(^LR(LRDFN,"MI",IX,4,RMK))
if RMK=""
QUIT
SET ^TMP("LRM",$JOB,"BACT","R",RMK)=^(RMK,0)
+28 QUIT
ORGNSM ; Get Organism
+1 NEW QTY
+2 SET ORG=+^LR(LRDFN,"MI",IX,3,ISO,0)
SET QTY=$PIECE(^(0),U,2)
+3 SET ORG=$$GET1^DIQ(61.2,ORG,.01,"I")
+4 SET ORG=ORG_U_QTY
+5 QUIT
ANTIBX ; Get Antibitiotic susceptibility results on demand
+1 NEW ABX
SET ABX=1
+2 FOR
SET ABX=$ORDER(^LR(LRDFN,"MI",IX,3,ISO,ABX))
if ABX=""!(ABX'<3)
QUIT
DO ABXSET
+3 QUIT
ABXSET ; Antibiotic Susceptability Data
+1 ; Separate out by Susceptable, Intermediate, and Resistant
+2 NEW FOUND,GMTSR,GMABX,ABXI,ABXNM,ABXN
+3 SET ABXI=$$ABXI(ABX)
SET ABXNM=$$ABXNM(ABXI)
SET ABXN=ABX_";"_ABXNM
+4 IF $PIECE(ABXN,";",2)']""
SET $PIECE(ABXN,";",2)="UNKNOWN"
+5 IF ("A"[$PIECE(^LR(LRDFN,"MI",IX,3,ISO,ABX),U,3))
Begin DoDot:1
+6 SET GMABX=$GET(^LR(LRDFN,"MI",IX,3,ISO,ABX))
+7 ; Check for interpreted result (S, I, or R) first
+8 SET FOUND=0
+9 SET GMTSR=$PIECE(GMABX,U,2)
DO SAVE
if FOUND
QUIT
+10 ; If not found then check reported result (S,I, or R)
+11 SET GMTSR=$PIECE(GMABX,U)
DO SAVE
if FOUND
QUIT
+12 ; Neither interpreted nor reported result equaled
+13 ; S, I, or R so we'll store it in the "other" list
+14 ; provided that reported and interpreted are both
+15 ; not null
+16 if $PIECE(GMABX,U)'=""&($PIECE(GMABX,U,2)'="")
SET ^TMP("LRM",$JOB,"BACT",ISO,"SUSC","O",$PIECE($PIECE(ABXN,U),";",2))=ABXN_U_GMABX
End DoDot:1
+17 QUIT
ABXI(X) ; Antibiotic Susceptability IEN
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT 0
NEW DIC,DTOUT,DUOUT,Y
SET DIC="^LAB(62.06,"
SET D="AD"
SET DIC(0)=""
DO MIX^DIC1
SET X=+($GET(Y))
if X'>0
SET X=0
QUIT X
ABXNM(X) ; Antibiotic Susceptability Name
+1 SET X=$GET(X)
if +X'>0
QUIT ""
SET X=$$GET1^DIQ(62.06,+X,.01)
QUIT X
ABXLEV ; Get Serum antibiotic level
+1 if '$DATA(^LR(LRDFN,"MI",IX,14))
QUIT
NEW GMI
SET GMI=0
+2 FOR
SET GMI=$ORDER(^LR(LRDFN,"MI",IX,14,GMI))
if GMI'>0
QUIT
SET ^TMP("LRM",$JOB,"CABXL",GMI)=$GET(^(GMI,0))
+3 QUIT
STER ; Get sterility results if they exist
+1 NEW RESULT,STER
SET STER=0
+2 FOR
SET STER=$ORDER(^LR(LRDFN,"MI",IX,31,STER))
if STER'>0
QUIT
Begin DoDot:1
+3 SET DIQ(0)="E"
SET DIC=63
SET DA=LRDFN
SET DA(63.05)=IX
SET DR=5
SET DR(63.05)=11.52
+4 SET DR(63.292)=.01
SET DIQ="RESULT"
+5 SET DA(63.292)=STER
+6 DO EN^DIQ1
+7 SET ^TMP("LRM",$JOB,"BSTER",STER)=RESULT(63.292,STER,.01,"E")
End DoDot:1
+8 QUIT
GRAM ; Get Gram Stain Results
+1 ;Do not display if results not verified (GMTS*2.7*138)
+2 IF $PIECE($GET(^LR(LRDFN,"MI",IX,1)),U)=""
QUIT
+3 NEW ISO
if '$DATA(^LR(LRDFN,"MI",IX,2))
QUIT
SET ISO=0
+4 FOR
SET ISO=$ORDER(^LR(LRDFN,"MI",IX,2,ISO))
if ISO=""
QUIT
SET ^TMP("LRM",$JOB,"GRAM",ISO)=^(ISO,0)
+5 QUIT
LABTEST(SDT,LRACC) ; Get lab test names and results
+1 NEW X,Y,LRAA,LRAN,LRAD,LRBRR,LRTSTS,LRTS
+2 SET LRAD=+$EXTRACT(SDT)_$PIECE(LRACC," ",2)_"0000"
SET X=$PIECE(LRACC," ")
SET DIC=68
SET DIC(0)="M"
+3 if '$LENGTH(X)
QUIT
DO ^DIC
SET LRAA=+Y
SET LRAN=+$PIECE(LRACC," ",3)
+4 SET LRBRR=0
+5 FOR
SET LRBRR=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR))
if LRBRR'>0
QUIT
Begin DoDot:1
+6 SET LRTS=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR,0)
SET LRTS(1)=$PIECE(^(0),U,5)
+7 if "BO"'[$PIECE($GET(^LAB(60,LRTS,0)),U,3)
QUIT
+8 SET LRTSTS=$SELECT($DATA(^LAB(60,LRTS,0)):$PIECE(^(0),U),1:"deleted test")
+9 ; Lab test name and results in print order
+10 SET ^TMP("LRM",$JOB,0,"TEST",$SELECT($DATA(^LAB(60,LRTS,.1)):$PIECE(^(.1),U,6),1:"")_","_U_LRBRR)=LRTSTS_U_LRTS(1)
End DoDot:1
+11 QUIT
SAVE ; If result = S, I, or R then save
+1 IF $SELECT(GMTSR="I":1,GMTSR="R":1,GMTSR="S":1,1:0)
SET ^TMP("LRM",$JOB,"BACT",ISO,"SUSC",GMTSR,$PIECE($PIECE(ABXN,U),";",2))=ABXN_U_GMABX
SET FOUND=1
+2 QUIT
