ORDV05E ; slc/jdl - Microbiology Extract Routine ;6/13/01 11:49
;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,208,315**;Dec 17, 1997;Build 20
;
; DBIA 531 ^LRO(68
; DBIA 684 ^LR(
; DBIA 2387 ^LAB(60
; DBIA 5466 GETACC^LRJWLST
;
;;Called from ORDV05, return ^TMP("ORM",$J in GCPR format
;;For Bacteriology,Sterility,Gram stain
GET ;Extract data from LR global
N I,IX,IXO,PNM,AGE,SEX,LRDFN,ALL,FORMAT,DONE,OUTCNT
S LRDFN="",ALL=1,FORMAT=0,DONE=0,OUTCNT=1 ;Parameters required by MI^LR7OGMM
D DEMO^LR7OGU(DFN,.LRDFN,.PNM,.AGE,.SEX) ;Demograph required by LR7OGMM
I '$G(LRDFN) Q
S ^TMP("OR7OG",$J,"G")=DFN_U_PNM_U_LRDFN_U_AGE_U_SEX_"^8"
S IX=GMTS1
F IXO=1:1:GMTSNDM S IX=$O(^LR(LRDFN,"MI",IX)) Q:'IX!(IX>GMTS2) D XTRCT
Q
XTRCT N ACC,CDT,SS,CS,X,X0,DIC,DIQ,DA,DR,MICRO,LOC,RDT,MICCOM,RPT,OACC
S RPT=IX,X0=^LR(LRDFN,"MI",IX,0),X=$P(X0,U),RDT=$P(X0,U,3),ACC=$P(X0,U,6),LOC=$P(X0,U,8)
Q:'X Q:'$P(X0,"^",5)
S CDT=$$REGDTM4^ORDVU(X)
D LABTEST(X,ACC)
I $T(GETACC^LRJWLST)]"" D
. N X,OACC
. S OACC=$$GETACC^LRJWLST(LRDFN,"MI",IX) I OACC]"" S ACC=OACC
; 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"),CS=MICRO(63.05,IX,.055,"E"),MICCOM=MICRO(63.05,IX,.99,"E")
S ^TMP("ORM",$J,RPT,SS)=CDT_U_ACC_U_CS_U_SS_U_LRTSTS
S ^TMP("ORM",$J,RPT,SS,"IMP")=MICCOM
D ABXLEV,BACT,GRAM,STER,PARA^ORDV05X,MYCO^ORDV05X,TB^ORDV05X,VIRO^ORDV05X
D MI^ORDV05T(LRDFN,IX,ALL,.OUTCNT,FORMAT,.DONE)
I $D(^TMP("OR7OGX",$J,"OUTPUT"))>0 M ^TMP("ORM",$J,RPT,SS,"REPORT")=^TMP("OR7OGX",$J,"OUTPUT")
K ^TMP("OR7OGX",$J,"OUTPUT")
K LRTSTS
Q
BACT ; Get Bacteriology Work-up
N DA,DIC,DIQ,DR,STATUS,ISO,ORG,RMK,COM,SMEAR,ORGIEN
I $D(^LR(LRDFN,"MI",IX,1)) D
. S DIC=63,DA=LRDFN,DA(63.05)=IX,DR=5,DR(63.05)="11.5",DIQ="STATUS"
. S DIQ(0)="E" D EN^DIQ1
. S ^TMP("ORM",$J,RPT,SS)=^TMP("ORM",$J,RPT,SS)_U_STATUS(63.05,IX,11.5,"E")
S ISO=0 F S ISO=$O(^LR(LRDFN,"MI",IX,3,ISO)) Q:+ISO'>0 D
. S ORGIEN=+^LR(LRDFN,"MI",IX,3,ISO,0)
. D ORGNSM
. S ^TMP("ORM",$J,RPT,SS,"RPT",ORGIEN)="B"_U_$S($D(EXPAND):ISO_";"_ORG,1:ORG)
. I $O(^LR(LRDFN,"MI",IX,3,ISO,1)) D ANTIBX
; Bacteriology smear/prep
S SMEAR=0
F S SMEAR=$O(^LR(LRDFN,"MI",IX,25,SMEAR)) Q:SMEAR'>0 S ^TMP("ORM",$J,RPT,SS,"IMP","BACT","SMEAR",SMEAR)=^(SMEAR,0)
; remark
S RMK=0
F S RMK=$O(^LR(LRDFN,"MI",IX,4,RMK)) Q:RMK="" S ^TMP("ORM",$J,RPT,SS,"IMP","BACT","RMK",RMK)=^(RMK,0)
Q
ORGNSM N QTY
S QTY=$P(^(0),U,2)
S ORG=$$GET1^DIQ(61.2,ORGIEN,.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 ; Set Antibiotic Susceptability data, when appropriate
; 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 being 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 for S, I, or R
. S GMTSR=$P(GMABX,U) D SAVE Q:FOUND
Q
ABXI(X) ; Antibiotic Susceptability IEN
S X=$G(X) Q:'$L(X) 0 N D,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("ORM",$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("ORM",$J,RPT,SS,"IMP","BSTER",STER)=RESULT(63.292,STER,.01,"E")
Q
GRAM ; Get Gram Stain Results
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("ORM",$J,RPT,SS,"IMP","GRAM",ISO)=^(ISO,0)
Q
LABTEST(SDT,LRACC) ;Get lab test names and results
N X,Y,LRAA,LRAN,LRAD,LRBRR,LRTS
K LRTSTS
S LRTSTS="UNKNOWN"
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")
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("ORM",$J,RPT,SS,"RPT",ORGIEN,ABX)=ABXNM_U_GMABX S FOUND=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORDV05E 5009 printed Apr 09, 2024@21:32:22 Page 2
ORDV05E ; slc/jdl - Microbiology Extract Routine ;6/13/01 11:49
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,208,315**;Dec 17, 1997;Build 20
+2 ;
+3 ; DBIA 531 ^LRO(68
+4 ; DBIA 684 ^LR(
+5 ; DBIA 2387 ^LAB(60
+6 ; DBIA 5466 GETACC^LRJWLST
+7 ;
+8 ;;Called from ORDV05, return ^TMP("ORM",$J in GCPR format
+9 ;;For Bacteriology,Sterility,Gram stain
GET ;Extract data from LR global
+1 NEW I,IX,IXO,PNM,AGE,SEX,LRDFN,ALL,FORMAT,DONE,OUTCNT
+2 ;Parameters required by MI^LR7OGMM
SET LRDFN=""
SET ALL=1
SET FORMAT=0
SET DONE=0
SET OUTCNT=1
+3 ;Demograph required by LR7OGMM
DO DEMO^LR7OGU(DFN,.LRDFN,.PNM,.AGE,.SEX)
+4 IF '$GET(LRDFN)
QUIT
+5 SET ^TMP("OR7OG",$JOB,"G")=DFN_U_PNM_U_LRDFN_U_AGE_U_SEX_"^8"
+6 SET IX=GMTS1
+7 FOR IXO=1:1:GMTSNDM
SET IX=$ORDER(^LR(LRDFN,"MI",IX))
if 'IX!(IX>GMTS2)
QUIT
DO XTRCT
+8 QUIT
XTRCT NEW ACC,CDT,SS,CS,X,X0,DIC,DIQ,DA,DR,MICRO,LOC,RDT,MICCOM,RPT,OACC
+1 SET RPT=IX
SET X0=^LR(LRDFN,"MI",IX,0)
SET X=$PIECE(X0,U)
SET RDT=$PIECE(X0,U,3)
SET ACC=$PIECE(X0,U,6)
SET LOC=$PIECE(X0,U,8)
+2 if 'X
QUIT
if '$PIECE(X0,"^",5)
QUIT
+3 SET CDT=$$REGDTM4^ORDVU(X)
+4 DO LABTEST(X,ACC)
+5 IF $TEXT(GETACC^LRJWLST)]""
Begin DoDot:1
+6 NEW X,OACC
+7 SET OACC=$$GETACC^LRJWLST(LRDFN,"MI",IX)
IF OACC]""
SET ACC=OACC
End DoDot:1
+8 ; External format of site/specimen, collection sample, and comment
+9 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"
+10 DO EN^DIQ1
+11 SET SS=MICRO(63.05,IX,.05,"E")
SET CS=MICRO(63.05,IX,.055,"E")
SET MICCOM=MICRO(63.05,IX,.99,"E")
+12 SET ^TMP("ORM",$JOB,RPT,SS)=CDT_U_ACC_U_CS_U_SS_U_LRTSTS
+13 SET ^TMP("ORM",$JOB,RPT,SS,"IMP")=MICCOM
+14 DO ABXLEV
DO BACT
DO GRAM
DO STER
DO PARA^ORDV05X
DO MYCO^ORDV05X
DO TB^ORDV05X
DO VIRO^ORDV05X
+15 DO MI^ORDV05T(LRDFN,IX,ALL,.OUTCNT,FORMAT,.DONE)
+16 IF $DATA(^TMP("OR7OGX",$JOB,"OUTPUT"))>0
MERGE ^TMP("ORM",$JOB,RPT,SS,"REPORT")=^TMP("OR7OGX",$JOB,"OUTPUT")
+17 KILL ^TMP("OR7OGX",$JOB,"OUTPUT")
+18 KILL LRTSTS
+19 QUIT
BACT ; Get Bacteriology Work-up
+1 NEW DA,DIC,DIQ,DR,STATUS,ISO,ORG,RMK,COM,SMEAR,ORGIEN
+2 IF $DATA(^LR(LRDFN,"MI",IX,1))
Begin DoDot:1
+3 SET DIC=63
SET DA=LRDFN
SET DA(63.05)=IX
SET DR=5
SET DR(63.05)="11.5"
SET DIQ="STATUS"
+4 SET DIQ(0)="E"
DO EN^DIQ1
+5 SET ^TMP("ORM",$JOB,RPT,SS)=^TMP("ORM",$JOB,RPT,SS)_U_STATUS(63.05,IX,11.5,"E")
End DoDot:1
+6 SET ISO=0
FOR
SET ISO=$ORDER(^LR(LRDFN,"MI",IX,3,ISO))
if +ISO'>0
QUIT
Begin DoDot:1
+7 SET ORGIEN=+^LR(LRDFN,"MI",IX,3,ISO,0)
+8 DO ORGNSM
+9 SET ^TMP("ORM",$JOB,RPT,SS,"RPT",ORGIEN)="B"_U_$SELECT($DATA(EXPAND):ISO_";"_ORG,1:ORG)
+10 IF $ORDER(^LR(LRDFN,"MI",IX,3,ISO,1))
DO ANTIBX
End DoDot:1
+11 ; Bacteriology smear/prep
+12 SET SMEAR=0
+13 FOR
SET SMEAR=$ORDER(^LR(LRDFN,"MI",IX,25,SMEAR))
if SMEAR'>0
QUIT
SET ^TMP("ORM",$JOB,RPT,SS,"IMP","BACT","SMEAR",SMEAR)=^(SMEAR,0)
+14 ; remark
+15 SET RMK=0
+16 FOR
SET RMK=$ORDER(^LR(LRDFN,"MI",IX,4,RMK))
if RMK=""
QUIT
SET ^TMP("ORM",$JOB,RPT,SS,"IMP","BACT","RMK",RMK)=^(RMK,0)
+17 QUIT
ORGNSM NEW QTY
+1 SET QTY=$PIECE(^(0),U,2)
+2 SET ORG=$$GET1^DIQ(61.2,ORGIEN,.01,"I")
+3 SET ORG=ORG_U_QTY
+4 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 ; Set Antibiotic Susceptability data, when appropriate
+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 being 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 for S, I, or R
+11 SET GMTSR=$PIECE(GMABX,U)
DO SAVE
if FOUND
QUIT
End DoDot:1
+12 QUIT
ABXI(X) ; Antibiotic Susceptability IEN
+1 SET X=$GET(X)
if '$LENGTH(X)
QUIT 0
NEW D,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("ORM",$JOB,"CABXL",GMI)=$GET(^(GMI,0))
+3 QUIT
STER ; Get sterility results if they exist
+1 NEW RESULT,STER
+2 SET STER=0
+3 FOR
SET STER=$ORDER(^LR(LRDFN,"MI",IX,31,STER))
if STER'>0
QUIT
Begin DoDot:1
+4 SET DIQ(0)="E"
SET DIC=63
SET DA=LRDFN
SET DA(63.05)=IX
SET DR=5
SET DR(63.05)=11.52
+5 SET DR(63.292)=.01
SET DIQ="RESULT"
+6 SET DA(63.292)=STER
+7 DO EN^DIQ1
+8 SET ^TMP("ORM",$JOB,RPT,SS,"IMP","BSTER",STER)=RESULT(63.292,STER,.01,"E")
End DoDot:1
+9 QUIT
GRAM ; Get Gram Stain Results
+1 NEW ISO
+2 if '$DATA(^LR(LRDFN,"MI",IX,2))
QUIT
+3 SET ISO=0
+4 FOR
SET ISO=$ORDER(^LR(LRDFN,"MI",IX,2,ISO))
if ISO=""
QUIT
SET ^TMP("ORM",$JOB,RPT,SS,"IMP","GRAM",ISO)=^(ISO,0)
+5 QUIT
LABTEST(SDT,LRACC) ;Get lab test names and results
+1 NEW X,Y,LRAA,LRAN,LRAD,LRBRR,LRTS
+2 KILL LRTSTS
+3 SET LRTSTS="UNKNOWN"
+4 SET LRAD=+$EXTRACT(SDT)_$PIECE(LRACC," ",2)_"0000"
SET X=$PIECE(LRACC," ")
SET DIC=68
SET DIC(0)="M"
+5 if '$LENGTH(X)
QUIT
DO ^DIC
SET LRAA=+Y
SET LRAN=+$PIECE(LRACC," ",3)
+6 SET LRBRR=0
+7 FOR
SET LRBRR=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR))
if LRBRR'>0
QUIT
Begin DoDot:1
+8 SET LRTS=+^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRBRR,0)
SET LRTS(1)=$PIECE(^(0),U,5)
+9 if "BO"'[$PIECE($GET(^LAB(60,LRTS,0)),U,3)
QUIT
+10 SET LRTSTS=$SELECT($DATA(^LAB(60,LRTS,0)):$PIECE(^(0),U),1:"deleted test")
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("ORM",$JOB,RPT,SS,"RPT",ORGIEN,ABX)=ABXNM_U_GMABX
SET FOUND=1
+2 QUIT
