- ORDV05E ; slc/jdl - Microbiology Extract Routine ;22-Jul-2013 22:35;PLS
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,208,1012**;Dec 17, 1997
- ;;Called from ORDV05, return ^TMP("ORM",$J in GCPR format
- ;;For Bacteriology,Sterility,Gram stain
- ; Modified - IHS/MSC/PLS - 07/22/2013 - Line ANTIBX+1
- 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
- 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)
- ; 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
- ;IHS/MSC/MK - 07/22/2013
- ;N ABX S ABX=1
- ;F S ABX=$O(^LR(LRDFN,"MI",IX,3,ISO,ABX)) Q:ABX=""!(ABX'<3) D ABXSET
- N ABX S ABX=2
- 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
- ORDV05E ; slc/jdl - Microbiology Extract Routine ;22-Jul-2013 22:35;PLS
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**109,208,1012**;Dec 17, 1997
- +2 ;;Called from ORDV05, return ^TMP("ORM",$J in GCPR format
- +3 ;;For Bacteriology,Sterility,Gram stain
- +4 ; Modified - IHS/MSC/PLS - 07/22/2013 - Line ANTIBX+1
- 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
- +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 ; External format of site/specimen, 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")
- SET CS=MICRO(63.05,IX,.055,"E")
- SET MICCOM=MICRO(63.05,IX,.99,"E")
- +9 SET ^TMP("ORM",$JOB,RPT,SS)=CDT_U_ACC_U_CS_U_SS_U_LRTSTS
- +10 SET ^TMP("ORM",$JOB,RPT,SS,"IMP")=MICCOM
- +11 DO ABXLEV
- DO BACT
- DO GRAM
- DO STER
- DO PARA^ORDV05X
- DO MYCO^ORDV05X
- DO TB^ORDV05X
- DO VIRO^ORDV05X
- +12 DO MI^ORDV05T(LRDFN,IX,ALL,.OUTCNT,FORMAT,.DONE)
- +13 IF $DATA(^TMP("OR7OGX",$JOB,"OUTPUT"))>0
- MERGE ^TMP("ORM",$JOB,RPT,SS,"REPORT")=^TMP("OR7OGX",$JOB,"OUTPUT")
- +14 KILL ^TMP("OR7OGX",$JOB,"OUTPUT")
- +15 KILL LRTSTS
- +16 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 ;IHS/MSC/MK - 07/22/2013
- +2 ;N ABX S ABX=1
- +3 ;F S ABX=$O(^LR(LRDFN,"MI",IX,3,ISO,ABX)) Q:ABX=""!(ABX'<3) D ABXSET
- +4 NEW ABX
- SET ABX=2
- +5 FOR
- SET ABX=$ORDER(^LR(LRDFN,"MI",IX,3,ISO,ABX))
- IF 'ABX!(ABX'<3)
- QUIT
- DO ABXSET
- +6 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
