BLRMIEHR ; IHS/MSC/MKK - IHS Lab Micro Report for EHR; 15-Apr-2014 11:42 ; MKK
;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
PEP ; EP
EP ; EP
S LINES=0,QFLG="NO"
D HEADER
D GRAMSTAN(LRDFN,LRIDT)
S ORGL=.9999999,ORGHEAD=0
F S ORGL=$O(^LR(LRDFN,"MI",LRIDT,3,ORGL)) Q:ORGL<1!(QFLG="Q") D
. D ORGLINE
. D DRUGSORT
. D ADDLINE($J("",GIOM))
;
D ADDLINE($J("",GIOM))
; D FOOTER
D PERLABLN ; PERforming LAB LiNe
;
Q
;
ORIGEP ; EP - Original EP code
S LINES=0
;
S LRIDT=LRSIDT,QFLG="NO"
F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1!($P(LRIDT,".")>LREIDT)!(QFLG="Q") D
. D HEADER
. D GRAMSTAN(LRDFN,LRIDT)
. S ORGL=.9999999,ORGHEAD=0
. F S ORGL=$O(^LR(LRDFN,"MI",LRIDT,3,ORGL)) Q:ORGL<1!(QFLG="Q") D
.. D ORGLINE
.. D DRUGSORT
.. D ADDLINE($J("",GIOM))
. D ADDLINE($J("",GIOM))
. D FOOTER
Q
;
NEW RF,STR
;
D BLNKLINE
;
D ADDLINE($$CJ^XLFSTR("---- MICROBIOLOGY ----",GIOM))
;
D DATAHEAD
K STR S STR="Accession:"_LRAS,$E(STR,44)="Received:"_RECDDATE D ADDLINE(STR)
K STR S STR="Collection Sample:"_CSNAME,$E(STR,44)="Collection Date:"_COLLDATE D ADDLINE(STR)
D ADDLINE("Site/Specimen:"_SSNAME)
D ADDLINE("Provider:"_PROVIDER)
D:$L(COMMENT) ADDLINE("Comment on Specimen:"_$G(COMMENT))
;
D BLNKLINE
;
D BLNKLINE,BLNKLINE ; Two blank lines
;
D ORDTESTS
;
Q
;
ADDLINE(STR) ; EP - Add a line
S ^TMP("LRC",$J,GCNT,0)=STR,GCNT=GCNT+1
Q
;
BLNKLINE ; EP - "Blank" line
D ADDLINE($J("",GIOM))
Q
;
DATAHEAD ; EP - Get Data for Header
S STR=$G(^LR(LRDFN,"MI",LRIDT,0))
S COLLDATE=$$FMTE^XLFDT($P(STR,"^"),"5MZ") ; Collection Date
;
S RECDDATE=$$FMTE^XLFDT($P(STR,"^",10),"5MZ") ; Received Date
;
S LRAS=$P(STR,"^",6) ; Accession
;
S SSIEN=+$P(STR,"^",5)
S SSNAME=$$GET1^DIQ(61,SSIEN,"NAME") ; Site/Specimen Name
;
S PHYIEN=+$P(STR,"^",7)
S PROVIDER=$$GET1^DIQ(200,PHYIEN,"NAME")
;
S CSIEN=+$P(STR,"^",11)
S CSNAME=$$GET1^DIQ(62,CSIEN,"NAME") ; Collection Sample
;
S COMMENT=$G(^LR(LRDFN,"MI",LRIDT,99))
;
Q
;
D PERLABLN ; PERforming LAB LiNe
;
D ADDLINE($TR($J("",GIOM)," ","="))
Q
;
PATDEMO ; EP - Get Patient Demographics
S PATNAME=$$GET1^DIQ(2,DFN,"NAME")
S PATDOB=$$GET1^DIQ(2,DFN,"DATE OF BIRTH","I")
S:$L(PATDOB) PATDOB=$$FMTE^XLFDT(PATDOB,"5DZ")
S DOD=+$$GET1^DIQ(2,DFN,"DATE OF DEATH","I")
S:DOD PATDOD=$$FMTE^XLFDT(DOD,"5DZ")
S HRCN=$$HRCN^BDGF2(DFN,DUZ(2))
Q
;
PERLABLN ; EP - PERforming LAB LiNe
S RF=$$GETPLIEN()
;
Q:$$INSTDATA(RF,.STR1,.STR2)="Q"
;
D ADDLINE("Performing Laboratory:")
D ADDLINE($$LJ^XLFSTR("["_RF_"]",7)_STR1)
D:$L(STR2) ADDLINE($J("",7)_STR2)
D CCLABLN
;
Q
;
CCLABLN ; EP - County & Country LAB LiNes
NEW COUNTRY,COUNTY,IENS,CCLINE
;
S (COUNTY,COUNTRY)=""
;
S IENS=LRIDT_","_LRDFN
S COUNTY=$$GET1^DIQ(63.05,IENS,9999996)
S COUNTRY=$$GET1^DIQ(63.05,IENS,9999997)
Q:$L(COUNTY)<1&($L(COUNTRY)<1)
;
S CCLINE=$J("",7)
S:$L(COUNTY) CCLINE=CCLINE_$$LJ^XLFSTR("County:"_COUNTY,15)
S:$L(COUNTRY) CCLINE=CCLINE_"Country:"_COUNTRY
D ADDLINE(CCLINE)
Q
;
GETPLIEN() ; GET Performing Lab IEN
S RF=+$G(^LR(LRDFN,"MI",LRIDT,"RF")) ; Reference Lab Node
Q:RF RF
;
; Try to get from Organism structure
S RF=+$P($G(^LR(LRDFN,"MI",LRIDT,3,1,"IHSOBX")),U,6) ; Performing Lab
Q:RF RF
;
S RF=+$P($G(^LR(LRDFN,"MI",LRIDT,0)),U,14) ; Accessioning Lab
Q:RF RF
;
; Try the Accession Division
NEW LRAA,LRAD,LRAN,LRACC
S LRACC=$P($G(^LR(LRDFN,"MI",LRIDT,0)),"^",6)
I $$GETACCCP^BLRUTIL3(LRACC,.LRAA,.LRAD,.LRAN)<1 Q $G(DUZ(2))
;
S RF=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.4))
Q RF
;
ORDTESTS ; EP - Ordered Tests(s)
NEW COMPDATE,F6OIEN,F60DESC,IENSTR,LRAA,LRAD,LRAN,LRAS,TESTS
NEW ORG,ORGCOMM,ORGDESC,ORGQUANT,UID
;
D ADDLINE($$CJ^XLFSTR("Tests(s) Ordered:",GIOM))
;
S UID=+$G(^LR(LRDFN,"MI",LRIDT,"ORU"))
I UID D
. S X=$Q(^LRO(68,"C",UID,0)),LRAA=$QS(X,4),LRAD=$QS(X,5),LRAN=$QS(X,6)
I UID<1 D
. S LRAS=$P($G(^LR(LRDFN,"MI",LRIDT,0)),"^",6)
. D GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
;
S IENSTR=LRAN_","_LRAD_","_LRAA_","
S TESTS=.9999999,X=0
F S TESTS=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TESTS)) Q:TESTS<1 D
. K STR S STR=TABIT_$$GET1^DIQ(60,TESTS,"NAME")
. S COMPDATE=$$GET1^DIQ(68.04,TESTS_","_IENSTR,"COMPLETE DATE","I")
. S:$L(COMPDATE) $E(STR,44)="Completed: "_$TR($$FMTE^XLFDT(COMPDATE,"MZ"),"@"," ")
. D ADDLINE(STR)
;
D BLNKLINE
S IENSTR=LRIDT_","_LRDFN
S BACRPTDA=$$GET1^DIQ(63.05,IENSTR,"BACT RPT DATE APPROVED","I")
S BCRPTSTS=$$GET1^DIQ(63.05,IENSTR,"BACT RPT STATUS")
S BCRPTDUZ=$$GET1^DIQ(63.05,IENSTR,"BACT PERSON","I")
;
K STR S STR="BACTERIOLOGY "_BCRPTSTS_" => "_$$FMTE^XLFDT(BACRPTDA,"5DZ")
S $E(STR,60)="TECH CODE:"_BCRPTDUZ
D ADDLINE(STR),BLNKLINE,BLNKLINE
;
D EHRPLIM^BLRMIRP2
;
D REMARKS
;
F S TESTS=$O(^LR(LRDFN,"MI",LRIDT,26,TESTS)) Q:TESTS<1 D
Q
;
Q:$O(^LR(LRDFN,"MI",LRIDT,4,0))<1
;
NEW BACTREM
D ADDLINE(TABIT_"Bacteriology Remark(s):")
S BACTREM=0
F S BACTREM=$O(^LR(LRDFN,"MI",LRIDT,4,BACTREM)) Q:BACTREM<1 D ADDLINE(TABIT2_$G(^(BACTREM,0)))
Q
;
IHSTESTS ; EP
Q
;
INSTDATA(INST,STR1,STR2) ; EP
NEW ARRAY,ERRS
;
; Use MAILING Address
D GETS^DIQ(4,INST,".01;4.01;4.02;4.03;4.04;4.05",,"ARRAY","ERRS")
;
Q:$D(ERRS) "Q"
;
S RFS=INST_$C(44)
;
S NAME=$G(ARRAY(4,RFS,.01)) ; Name
S ADDR1=$G(ARRAY(4,RFS,4.01)) ; Street Address 1
S:$L($G(ARRAY(4,RFS,4.02))) ADDR2=$G(ARRAY(4,RFS,1.02)) ; Street Address 2
S CITY=$G(ARRAY(4,RFS,4.03)) ; City
S STATE=$G(ARRAY(4,RFS,4.04)) ; State
S ZIP=$G(ARRAY(4,RFS,4.05)) ; Zip
;
I $L(ADDR1)<1 D ; No Address. Have to try and see if default address entries exist
. K ARRAY,ERRS
. D GETS^DIQ(4,INST,".01;1.01;1.02;1.03;.02;1.04",,"ARRAY","ERRS")
. S NAME=$G(ARRAY(4,RFS,.01)) ; Name
. S ADDR1=$G(ARRAY(4,RFS,1.01)) ; Street Address 1
. S:$L($G(ARRAY(4,RFS,1.02))) ADDR2=$G(ARRAY(4,RFS,1.02))_" " ; Street Address 2
. S CITY=$G(ARRAY(4,RFS,1.03)) ; City
. S STATE=$G(ARRAY(4,RFS,.02)) ; State
. S ZIP=$G(ARRAY(4,RFS,1.04)) ; Zip
;
Q:$D(ERRS) "Q"
Q:$L(ADDR1)<1 "Q"
;
S STR1=NAME_" "_ADDR1_" "_$S($L($G(ADDR2)):ADDR2_" ",1:"")_CITY_", "_STATE_" "_ZIP
I $L(STR1)<(IOM-10) S STR2="" Q "OK"
;
; Need to have 2 line Footer
K STR1,STR2
S STR1=NAME_" "_ADDR1_" "_$S($L($G(ADDR2)):ADDR2,1:"")
S STR2=CITY_", "_STATE_" "_ZIP
;
Q "OK"
;
IHSVARS(LRDFN,LRIDT,ORGANISM) ; EP
S STR=$G(^LR(LRDFN,"MI",LRIDT,3,ORGANISM,"IHS"))
S RELDATE=$P(STR,"^")
S STATUS=$P(STR,"^",2)
S FLAG=$P(STR,"^",3)
S SUSC=$P(STR,"^",4)
S UP=$P(STR,"^",5)
S:+UP UNITS=$$GET1^DIQ(90475.3,UP,"DESCRIPTION")
S INTP=$P(STR,"^",6)
Q
;
GRAMSTAN(LRDFN,LRIDT) ; EP - GRAM STAIN Data
NEW GRAMCNT,GRAMSTR
;
Q:$D(^LR(LRDFN,"MI",LRIDT,2))<1
;
S (D2,GRAMCNT)=0
F S D2=$O(^LR(LRDFN,"MI",LRIDT,2,D2)) Q:D2<1 D
. S GRAMSTR=$G(^LR(LRDFN,"MI",LRIDT,2,D2,0))
. Q:$TR(GRAMSTR," ")="" ; Skip blank line
. Q:GRAMSTR["***GRAM STAIN"
. Q:GRAMSTR="GRAM STAIN"
. Q:$TR(GRAMSTR," ")="GS"
. ;
. S GRAMCNT=GRAMCNT+1
. D:GRAMCNT=1 ADDLINE("GRAM STAIN:")
. D ADDLINE($J("",5)_GRAMSTR)
;
D ADDLINE($J("",GIOM))
Q
;
ORGLINE ; EP - ORGANISM Line
NEW ABNFLAG,HL7FLAG,IENSTR,OBSDATE,ORGCOMM,ORGIEN,ORGDESC,ORGQUANT,ORGSNOMD
;
S HL7FLAG=0
S STR=$G(^LR(LRDFN,"MI",LRIDT,3,ORGL,"IHSOBX"))
S:$L(STR) HL7FLAG=1
S SNOMED=$P(STR,"^")
S (ABNFLAG,FLAG)=$P(STR,"^",3)
S OBSDATE=$P(STR,"^",5)
;
I $L(OBSDATE)<1 D
. S OBSDATE=$P($G(^LR(LRDFN,"MI",LRIDT,ORGL,1)),"^")
. S:$L(OBSDATE)<1 OBSDATE=$P($G(^LR(LRDFN,"MI",LRIDT,0)),"^",3) S:$L(OBSDATE)<1 OBSDATE=$P($G(^(0)),"^",10)
;
I ORGHEAD<1 D
. D ADDLINE("CULTURE RESULTS:")
. S ORGHEAD=1+$G(ORGHEAD)
;
S IENSTR=ORGL_","_LRIDT_","_LRDFN_","
S ORGDESC=$$GET1^DIQ(63.3,IENSTR,"ORGANISM")
S ORGQUANT=$$GET1^DIQ(63.3,IENSTR,"QUANTITY")
;
I HL7FLAG D
. K STR S $E(STR,5)="Description",$E(STR,40)="Quantity",$E(STR,59)="FLG",$E(STR,64)="Observation Date"
. D ADDLINE(STR)
. K STR S STR=ORGL_".",$E(STR,5)=ORGDESC,$E(STR,40)=ORGQUANT,$E(STR,60)=ABNFLAG,$E(STR,64)=$$FMTE^XLFDT(OBSDATE,"5MZ")
. D ADDLINE(STR)
;
I 'HL7FLAG D
. K STR S $E(STR,5)="Description",$E(STR,40)="Quantity",$E(STR,64)="Observation Date"
. D ADDLINE(STR)
. K STR S STR=ORGL_".",$E(STR,5)=ORGDESC,$E(STR,40)=ORGQUANT,$E(STR,64)=$$FMTE^XLFDT(OBSDATE,"5MZ")
. D ADDLINE(STR)
;
S ORGCOMM=0
F S ORGCOMM=$O(^LR(LRDFN,"MI",LRIDT,3,ORGL,1,ORGCOMM)) Q:ORGCOMM<1 D
. K STR S $E(STR,10)=$G(^LR(LRDFN,"MI",LRIDT,3,ORGL,1,ORGCOMM,0))
. D ADDLINE(STR)
;
Q
;
DRUGSORT ; Put drugs into Print Order
S DRUGNODE=2
F S DRUGNODE=$O(^LR(LRDFN,"MI",LRIDT,3,ORGL,DRUGNODE)) Q:DRUGNODE<1 D
. S DRUGIEN=$O(^LAB(62.06,"AD",DRUGNODE,0))
. S DRUGNAME=$$GET1^DIQ(62.06,DRUGIEN,"NAME")
. S DRUGDISP=$$GET1^DIQ(62.06,DRUGIEN,"DISPLAY COMMENT")
. S PRNTORDR=+$$GET1^DIQ(62.06,DRUGIEN,"PRINT ORDER")
. S DRUGSORT(PRNTORDR,DRUGNODE)=DRUGIEN_"^"_DRUGNAME_"^"_DRUGDISP
;
S PRNTORDR="",DRUGHEAD=0
F S PRNTORDR=$O(DRUGSORT(PRNTORDR)) Q:PRNTORDR<1 D
. S DRUGNODE=""
. F S DRUGNODE=$O(DRUGSORT(PRNTORDR,DRUGNODE)) Q:DRUGNODE<1 D
.. S STR=$G(DRUGSORT(PRNTORDR,DRUGNODE))
.. S DRUGIEN=$P(STR,"^"),DRUGNAME=$P(STR,"^",2),DRUGDISP=$P(STR,"^",3)
.. D DRUGAMTS
Q
;
DRUGAMTS ; EP - Drug values
I $D(^LR(LRDFN,"MI",LRIDT,3,ORGL,"ISO")) D HL7DRUGS Q
;
D INHOUSE
Q
;
INHOUSE ; EP - Drug values from RPMS entry
S STR=$G(^LR(LRDFN,"MI",LRIDT,3,ORGL,DRUGNODE))
S SUSC=$P(STR,"^")
S INTP=$P(STR,"^",2)
S ALTI=$P(STR,"^",3)
Q:$L(SUSC)<1&($L(INTP)<1)&($L(ALTI)<1)
;
; Only display drugs that have valid interpretation for the result (the "AI" X-ref)
S (BADSUSC,BADINTP)=1
S:$L(INTP) BADINTP=$D(^LAB(62.06,"AI",DRUGNODE,INTP))
S:$L(SUSC) BADSUSC=$D(^LAB(62.06,"AI",DRUGNODE,SUSC))
Q:BADINTP<1&(BADSUSC<1)
;
D:+$G(DRUGHEAD)<1 DRUGHEAD
;
S RPTSTS=$P($G(^LR(LRDFN,"MI",LRIDT,1)),"^",2)
;
S STR=$G(^LR(LRDFN,"MI",LRIDT,ORGL,1))
S OBSDATE=$P(STR,"^")
S:$L(OBSDATE)<1 OBSDATE=$P($G(^LR(LRDFN,"MI",LRIDT,0)),"^",3) S:$L(OBSDATE)<1 OBSDATE=$P($G(^(0)),"^",10)
;
S LRAS=$P($G(^LR(LRDFN,"MI",LRIDT,0)),"^",6)
S RF=$$GETPLIEN()
S:$L(RF) LRPLS(RF)=""
;
S:$L(OBSDATE) OBSDATE=$$FMTE^XLFDT(OBSDATE,"5MZ")
S (FLAG,RESULT,UNITS)=""
;
; Special "trick". See file 62.06 & RESULT entry
S RESULT=SUSC
I $L($P(SUSC," ",2)) D
. S RESULT=$P(SUSC," ")
. S UNITS=$P(SUSC," ",2)
. S SUSC=""
;
K STR S STR=$E(DRUGNAME,1,25),$E(STR,28)=RESULT,$E(STR,34)=UNITS,$E(STR,41)=INTP
S $E(STR,47)=ALTI,$E(STR,54)=OBSDATE
S:$L(RF) $E(STR,75)="["_RF_"]"
D ADDLINE(STR)
I $L(DRUGDISP) K STR S $E(STR,15)=DRUGDISP D ADDLINE(STR)
Q
;
DRUGHEAD ; EP - In-House Drug "Heading"
D BLNKLINE
K STR S $E(STR,47)="ALT" D ADDLINE(STR)
K STR S STR="ANTIBIOTIC",$E(STR,28)="SUSC",$E(STR,34)="UNITS",$E(STR,41)="INTP"
S $E(STR,47)="INTP",$E(STR,54)="OBSERVATION DATE",$E(STR,76)="SITE"
D ADDLINE(STR)
S DRUGHEAD=1+$G(DRUGHEAD)
Q
;
HL7DRUGS ; EP - Drug values from INCOMING HL7 messages
S STR=$G(^LR(LRDFN,"MI",LRIDT,3,ORGL,DRUGNODE))
S SUSC=$P(STR,"^")
S INTP=$P(STR,"^",2)
;
; Only display drugs that have valid interpretation for the result (the "AI" X-ref)
; Q:INTP&($D(^LAB(62.06,"AI",DRUGNODE,INTP))<1)
; Q:SUSC&($D(^LAB(62.06,"AI",DRUGNODE,SUSC))<1)
;
D:+$G(DRUGHEAD)<1 HL7DHEAD
;
S ISO=.9999999,FOUNDIT=0
F S ISO=$O(^LR(LRDFN,"MI",LRIDT,3,ORGL,"ISO",ISO)) Q:ISO<1!(FOUNDIT) D
. S:$G(^LR(LRDFN,"MI",LRIDT,3,ORGL,"ISO",ISO))[DRUGNODE FOUNDIT=ISO
;
I FOUNDIT<1 D BLNKLINE Q
;
S STR=$G(^LR(LRDFN,"MI",LRIDT,3,ORGL,"ISO","IHSOBX",FOUNDIT))
S RESULT=$P(STR,"^"),UNITS=$P($P(STR,"^",2),"~"),FLAG=$P(STR,"^",3)
S RPTSTS=$P(STR,"^",4),OBSDATE=$P(STR,"^",5),RF=$P(STR,"^",6)
S:$L(RF) LRPLS(RF)=""
S:$L(OBSDATE) OBSDATE=$$FMTE^XLFDT(OBSDATE,"5MZ")
;
Q:SUSC="R"&(INTP="R")
;
K STR S STR=$E(DRUGNAME,1,25),$E(STR,28)=RESULT,$E(STR,34)=UNITS,$E(STR,41)=FLAG
S $E(STR,44)=SUSC,$E(STR,49)=INTP,$E(STR,55)=RPTSTS,$E(STR,58)=OBSDATE
S:$L(RF) $E(STR,75)="["_RF_"]"
D ADDLINE(STR)
I $L(DRUGDISP) K STR S $E(STR,15)=DRUGDISP D ADDLINE(STR)
;
Q
;
HL7DHEAD ; EP - HL7 Incoming Drug "Heading"
D BLNKLINE
K STR S $E(STR,28)="CONC" D ADDLINE(STR)
K STR S STR="ANTIBIOTIC",$E(STR,28)="RANGE",$E(STR,34)="UNITS",$E(STR,40)="FLG"
S $E(STR,44)="SUSC",$E(STR,49)="INTP",$E(STR,54)="STS",$E(STR,58)="OBSERVATION DATE",$E(STR,76)="SITE"
D ADDLINE(STR)
S DRUGHEAD=1+$G(DRUGHEAD)
Q
;
GETLRDFN() ; EP - Always get LRDFN
D ^LRPARAM
;
D ^XBFMK
S DIR(0)="PO^2:E"
S DIR("A")="PATIENT"
D ^DIR
I +$G(Y)<1!(+$G(DIRUT)) D Q "Q"
. W !,?4,"No/Invalid/Quit Entry. Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
S DFN=+$G(Y)
S PNM=$P(Y,"^",2)
;
S DOD=+$$GET1^DIQ(2,DFN,.351,"I")
I DOD D WARN^LRDPA Q:DFN<1 "Q"
;
S LRDFN=+$G(^DPT(DFN,"LR"))
Q:LRDFN "OK"
;
W !!,?4,"Patient ",$$GET1^DIQ(2,+Y,"NAME")," [",+Y,"] has NO Lab Data. Routine Ends."
D PRESSKEY^BLRGMENU(9)
Q "Q"
;
;
TESTIT ; EP - Test Code
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q
;
; Following code cloned from LR7OSMZ0
;
EN(DFN) ; EP - Process Microbiology entries listed in ^TMP("LRRR",$J,DFN,"MI",LRIDT,1)
;Return formated report in ^TMP("LRC",$J)
Q:'$D(^TMP("LRRR",$J,+$G(DFN),"MI"))
;
N LBL,LCNT,LRAA,LRACC,LRAD,LRAN,LRCMNT,LRDFN,LRDPF,LRIDT,LRJ02,LRLLT,LRPG,LRSB
N LRONESPC,LREND,LRONETST,GCNT,GIOM,LREND,CCNT,CT1,COUNT,LRIN,SEX,TABIT
;
K ^TMP("LRC",$J)
S (LRONETST,LRONESPC)="",CCNT=1,(LREND,GCNT)=0,GIOSL=999999,GIOM=80
Q:'$G(DFN)
S LRDFN=$$LRDFN^LR7OR1(DFN)
Q:'LRDFN
S LRDPF="2^DPT(",SEX=$P($G(@("^"_$P(LRDPF,"^",2)_+LRDFN_",0)")),"^",2),LRIDT=0
F S LRIDT=$O(^TMP("LRRR",$J,DFN,"MI",LRIDT)) Q:LRIDT<1 D
. N DFN
. D EN1
Q
;
EN1 ; EP
S LRLLT=$G(^LR(LRDFN,"MI",LRIDT,0))
S LRACC=$P(LRLLT,U,6)
;
Q:$$GETACCCP^BLRUTIL3(LRACC,.LRAA,.LRAD,.LRAN)<1
;
S LRCMNT=$S($D(^LR(LRDFN,"MI",LRIDT,99)):^(99),1:"")
S LRPG=0
S TABIT=$J("",5)
S TABIT2=$J("",10)
; D EN^LR7OSMZ1
D EP^BLRMIEHR
Q
;
BLRMIEHR ; IHS/MSC/MKK - IHS Lab Micro Report for EHR; 15-Apr-2014 11:42 ; MKK
+1 ;;5.2;IHS LABORATORY;**1033**;NOV 01, 1997
+2 ;
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
PEP ; EP
EP ; EP
+1 SET LINES=0
SET QFLG="NO"
+2 DO HEADER
+3 DO GRAMSTAN(LRDFN,LRIDT)
+4 SET ORGL=.9999999
SET ORGHEAD=0
+5 FOR
SET ORGL=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGL))
IF ORGL<1!(QFLG="Q")
QUIT
Begin DoDot:1
+6 DO ORGLINE
+7 DO DRUGSORT
+8 DO ADDLINE($JUSTIFY("",GIOM))
End DoDot:1
+9 ;
+10 DO ADDLINE($JUSTIFY("",GIOM))
+11 ; D FOOTER
+12 ; PERforming LAB LiNe
DO PERLABLN
+13 ;
+14 QUIT
+15 ;
ORIGEP ; EP - Original EP code
+1 SET LINES=0
+2 ;
+3 SET LRIDT=LRSIDT
SET QFLG="NO"
+4 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
IF LRIDT<1!($PIECE(LRIDT,".")>LREIDT)!(QFLG="Q")
QUIT
Begin DoDot:1
+5 DO HEADER
+6 DO GRAMSTAN(LRDFN,LRIDT)
+7 SET ORGL=.9999999
SET ORGHEAD=0
+8 FOR
SET ORGL=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGL))
IF ORGL<1!(QFLG="Q")
QUIT
Begin DoDot:2
+9 DO ORGLINE
+10 DO DRUGSORT
+11 DO ADDLINE($JUSTIFY("",GIOM))
End DoDot:2
+12 DO ADDLINE($JUSTIFY("",GIOM))
+13 DO FOOTER
End DoDot:1
+14 QUIT
+15 ;
+1 NEW RF,STR
+2 ;
+3 DO BLNKLINE
+4 ;
+5 DO ADDLINE($$CJ^XLFSTR("---- MICROBIOLOGY ----",GIOM))
+6 ;
+7 DO DATAHEAD
+8 KILL STR
SET STR="Accession:"_LRAS
SET $EXTRACT(STR,44)="Received:"_RECDDATE
DO ADDLINE(STR)
+9 KILL STR
SET STR="Collection Sample:"_CSNAME
SET $EXTRACT(STR,44)="Collection Date:"_COLLDATE
DO ADDLINE(STR)
+10 DO ADDLINE("Site/Specimen:"_SSNAME)
+11 DO ADDLINE("Provider:"_PROVIDER)
+12 IF $LENGTH(COMMENT)
DO ADDLINE("Comment on Specimen:"_$GET(COMMENT))
+13 ;
+14 DO BLNKLINE
+15 ;
+16 ; Two blank lines
DO BLNKLINE
DO BLNKLINE
+17 ;
+18 DO ORDTESTS
+19 ;
+20 QUIT
+21 ;
ADDLINE(STR) ; EP - Add a line
+1 SET ^TMP("LRC",$JOB,GCNT,0)=STR
SET GCNT=GCNT+1
+2 QUIT
+3 ;
BLNKLINE ; EP - "Blank" line
+1 DO ADDLINE($JUSTIFY("",GIOM))
+2 QUIT
+3 ;
DATAHEAD ; EP - Get Data for Header
+1 SET STR=$GET(^LR(LRDFN,"MI",LRIDT,0))
+2 ; Collection Date
SET COLLDATE=$$FMTE^XLFDT($PIECE(STR,"^"),"5MZ")
+3 ;
+4 ; Received Date
SET RECDDATE=$$FMTE^XLFDT($PIECE(STR,"^",10),"5MZ")
+5 ;
+6 ; Accession
SET LRAS=$PIECE(STR,"^",6)
+7 ;
+8 SET SSIEN=+$PIECE(STR,"^",5)
+9 ; Site/Specimen Name
SET SSNAME=$$GET1^DIQ(61,SSIEN,"NAME")
+10 ;
+11 SET PHYIEN=+$PIECE(STR,"^",7)
+12 SET PROVIDER=$$GET1^DIQ(200,PHYIEN,"NAME")
+13 ;
+14 SET CSIEN=+$PIECE(STR,"^",11)
+15 ; Collection Sample
SET CSNAME=$$GET1^DIQ(62,CSIEN,"NAME")
+16 ;
+17 SET COMMENT=$GET(^LR(LRDFN,"MI",LRIDT,99))
+18 ;
+19 QUIT
+20 ;
+1 ; PERforming LAB LiNe
DO PERLABLN
+2 ;
+3 DO ADDLINE($TRANSLATE($JUSTIFY("",GIOM)," ","="))
+4 QUIT
+5 ;
PATDEMO ; EP - Get Patient Demographics
+1 SET PATNAME=$$GET1^DIQ(2,DFN,"NAME")
+2 SET PATDOB=$$GET1^DIQ(2,DFN,"DATE OF BIRTH","I")
+3 IF $LENGTH(PATDOB)
SET PATDOB=$$FMTE^XLFDT(PATDOB,"5DZ")
+4 SET DOD=+$$GET1^DIQ(2,DFN,"DATE OF DEATH","I")
+5 IF DOD
SET PATDOD=$$FMTE^XLFDT(DOD,"5DZ")
+6 SET HRCN=$$HRCN^BDGF2(DFN,DUZ(2))
+7 QUIT
+8 ;
PERLABLN ; EP - PERforming LAB LiNe
+1 SET RF=$$GETPLIEN()
+2 ;
+3 IF $$INSTDATA(RF,.STR1,.STR2)="Q"
QUIT
+4 ;
+5 DO ADDLINE("Performing Laboratory:")
+6 DO ADDLINE($$LJ^XLFSTR("["_RF_"]",7)_STR1)
+7 IF $LENGTH(STR2)
DO ADDLINE($JUSTIFY("",7)_STR2)
+8 DO CCLABLN
+9 ;
+10 QUIT
+11 ;
CCLABLN ; EP - County & Country LAB LiNes
+1 NEW COUNTRY,COUNTY,IENS,CCLINE
+2 ;
+3 SET (COUNTY,COUNTRY)=""
+4 ;
+5 SET IENS=LRIDT_","_LRDFN
+6 SET COUNTY=$$GET1^DIQ(63.05,IENS,9999996)
+7 SET COUNTRY=$$GET1^DIQ(63.05,IENS,9999997)
+8 IF $LENGTH(COUNTY)<1&($LENGTH(COUNTRY)<1)
QUIT
+9 ;
+10 SET CCLINE=$JUSTIFY("",7)
+11 IF $LENGTH(COUNTY)
SET CCLINE=CCLINE_$$LJ^XLFSTR("County:"_COUNTY,15)
+12 IF $LENGTH(COUNTRY)
SET CCLINE=CCLINE_"Country:"_COUNTRY
+13 DO ADDLINE(CCLINE)
+14 QUIT
+15 ;
GETPLIEN() ; GET Performing Lab IEN
+1 ; Reference Lab Node
SET RF=+$GET(^LR(LRDFN,"MI",LRIDT,"RF"))
+2 IF RF
QUIT RF
+3 ;
+4 ; Try to get from Organism structure
+5 ; Performing Lab
SET RF=+$PIECE($GET(^LR(LRDFN,"MI",LRIDT,3,1,"IHSOBX")),U,6)
+6 IF RF
QUIT RF
+7 ;
+8 ; Accessioning Lab
SET RF=+$PIECE($GET(^LR(LRDFN,"MI",LRIDT,0)),U,14)
+9 IF RF
QUIT RF
+10 ;
+11 ; Try the Accession Division
+12 NEW LRAA,LRAD,LRAN,LRACC
+13 SET LRACC=$PIECE($GET(^LR(LRDFN,"MI",LRIDT,0)),"^",6)
+14 IF $$GETACCCP^BLRUTIL3(LRACC,.LRAA,.LRAD,.LRAN)<1
QUIT $GET(DUZ(2))
+15 ;
+16 SET RF=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.4))
+17 QUIT RF
+18 ;
ORDTESTS ; EP - Ordered Tests(s)
+1 NEW COMPDATE,F6OIEN,F60DESC,IENSTR,LRAA,LRAD,LRAN,LRAS,TESTS
+2 NEW ORG,ORGCOMM,ORGDESC,ORGQUANT,UID
+3 ;
+4 DO ADDLINE($$CJ^XLFSTR("Tests(s) Ordered:",GIOM))
+5 ;
+6 SET UID=+$GET(^LR(LRDFN,"MI",LRIDT,"ORU"))
+7 IF UID
Begin DoDot:1
+8 SET X=$QUERY(^LRO(68,"C",UID,0))
SET LRAA=$QSUBSCRIPT(X,4)
SET LRAD=$QSUBSCRIPT(X,5)
SET LRAN=$QSUBSCRIPT(X,6)
End DoDot:1
+9 IF UID<1
Begin DoDot:1
+10 SET LRAS=$PIECE($GET(^LR(LRDFN,"MI",LRIDT,0)),"^",6)
+11 DO GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
End DoDot:1
+12 ;
+13 SET IENSTR=LRAN_","_LRAD_","_LRAA_","
+14 SET TESTS=.9999999
SET X=0
+15 FOR
SET TESTS=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TESTS))
IF TESTS<1
QUIT
Begin DoDot:1
+16 KILL STR
SET STR=TABIT_$$GET1^DIQ(60,TESTS,"NAME")
+17 SET COMPDATE=$$GET1^DIQ(68.04,TESTS_","_IENSTR,"COMPLETE DATE","I")
+18 IF $LENGTH(COMPDATE)
SET $EXTRACT(STR,44)="Completed: "_$TRANSLATE($$FMTE^XLFDT(COMPDATE,"MZ"),"@"," ")
+19 DO ADDLINE(STR)
End DoDot:1
+20 ;
+21 DO BLNKLINE
+22 SET IENSTR=LRIDT_","_LRDFN
+23 SET BACRPTDA=$$GET1^DIQ(63.05,IENSTR,"BACT RPT DATE APPROVED","I")
+24 SET BCRPTSTS=$$GET1^DIQ(63.05,IENSTR,"BACT RPT STATUS")
+25 SET BCRPTDUZ=$$GET1^DIQ(63.05,IENSTR,"BACT PERSON","I")
+26 ;
+27 KILL STR
SET STR="BACTERIOLOGY "_BCRPTSTS_" => "_$$FMTE^XLFDT(BACRPTDA,"5DZ")
+28 SET $EXTRACT(STR,60)="TECH CODE:"_BCRPTDUZ
+29 DO ADDLINE(STR)
DO BLNKLINE
DO BLNKLINE
+30 ;
+31 DO EHRPLIM^BLRMIRP2
+32 ;
+33 DO REMARKS
+34 ;
+35 FOR
SET TESTS=$ORDER(^LR(LRDFN,"MI",LRIDT,26,TESTS))
IF TESTS<1
QUIT
Begin DoDot:1
End DoDot:1
+36 QUIT
+37 ;
+1 IF $ORDER(^LR(LRDFN,"MI",LRIDT,4,0))<1
QUIT
+2 ;
+3 NEW BACTREM
+4 DO ADDLINE(TABIT_"Bacteriology Remark(s):")
+5 SET BACTREM=0
+6 FOR
SET BACTREM=$ORDER(^LR(LRDFN,"MI",LRIDT,4,BACTREM))
IF BACTREM<1
QUIT
DO ADDLINE(TABIT2_$GET(^(BACTREM,0)))
+7 QUIT
+8 ;
IHSTESTS ; EP
+1 QUIT
+2 ;
INSTDATA(INST,STR1,STR2) ; EP
+1 NEW ARRAY,ERRS
+2 ;
+3 ; Use MAILING Address
+4 DO GETS^DIQ(4,INST,".01;4.01;4.02;4.03;4.04;4.05",,"ARRAY","ERRS")
+5 ;
+6 IF $DATA(ERRS)
QUIT "Q"
+7 ;
+8 SET RFS=INST_$CHAR(44)
+9 ;
+10 ; Name
SET NAME=$GET(ARRAY(4,RFS,.01))
+11 ; Street Address 1
SET ADDR1=$GET(ARRAY(4,RFS,4.01))
+12 ; Street Address 2
IF $LENGTH($GET(ARRAY(4,RFS,4.02)))
SET ADDR2=$GET(ARRAY(4,RFS,1.02))
+13 ; City
SET CITY=$GET(ARRAY(4,RFS,4.03))
+14 ; State
SET STATE=$GET(ARRAY(4,RFS,4.04))
+15 ; Zip
SET ZIP=$GET(ARRAY(4,RFS,4.05))
+16 ;
+17 ; No Address. Have to try and see if default address entries exist
IF $LENGTH(ADDR1)<1
Begin DoDot:1
+18 KILL ARRAY,ERRS
+19 DO GETS^DIQ(4,INST,".01;1.01;1.02;1.03;.02;1.04",,"ARRAY","ERRS")
+20 ; Name
SET NAME=$GET(ARRAY(4,RFS,.01))
+21 ; Street Address 1
SET ADDR1=$GET(ARRAY(4,RFS,1.01))
+22 ; Street Address 2
IF $LENGTH($GET(ARRAY(4,RFS,1.02)))
SET ADDR2=$GET(ARRAY(4,RFS,1.02))_" "
+23 ; City
SET CITY=$GET(ARRAY(4,RFS,1.03))
+24 ; State
SET STATE=$GET(ARRAY(4,RFS,.02))
+25 ; Zip
SET ZIP=$GET(ARRAY(4,RFS,1.04))
End DoDot:1
+26 ;
+27 IF $DATA(ERRS)
QUIT "Q"
+28 IF $LENGTH(ADDR1)<1
QUIT "Q"
+29 ;
+30 SET STR1=NAME_" "_ADDR1_" "_$SELECT($LENGTH($GET(ADDR2)):ADDR2_" ",1:"")_CITY_", "_STATE_" "_ZIP
+31 IF $LENGTH(STR1)<(IOM-10)
SET STR2=""
QUIT "OK"
+32 ;
+33 ; Need to have 2 line Footer
+34 KILL STR1,STR2
+35 SET STR1=NAME_" "_ADDR1_" "_$SELECT($LENGTH($GET(ADDR2)):ADDR2,1:"")
+36 SET STR2=CITY_", "_STATE_" "_ZIP
+37 ;
+38 QUIT "OK"
+39 ;
IHSVARS(LRDFN,LRIDT,ORGANISM) ; EP
+1 SET STR=$GET(^LR(LRDFN,"MI",LRIDT,3,ORGANISM,"IHS"))
+2 SET RELDATE=$PIECE(STR,"^")
+3 SET STATUS=$PIECE(STR,"^",2)
+4 SET FLAG=$PIECE(STR,"^",3)
+5 SET SUSC=$PIECE(STR,"^",4)
+6 SET UP=$PIECE(STR,"^",5)
+7 IF +UP
SET UNITS=$$GET1^DIQ(90475.3,UP,"DESCRIPTION")
+8 SET INTP=$PIECE(STR,"^",6)
+9 QUIT
+10 ;
GRAMSTAN(LRDFN,LRIDT) ; EP - GRAM STAIN Data
+1 NEW GRAMCNT,GRAMSTR
+2 ;
+3 IF $DATA(^LR(LRDFN,"MI",LRIDT,2))<1
QUIT
+4 ;
+5 SET (D2,GRAMCNT)=0
+6 FOR
SET D2=$ORDER(^LR(LRDFN,"MI",LRIDT,2,D2))
IF D2<1
QUIT
Begin DoDot:1
+7 SET GRAMSTR=$GET(^LR(LRDFN,"MI",LRIDT,2,D2,0))
+8 ; Skip blank line
IF $TRANSLATE(GRAMSTR," ")=""
QUIT
+9 IF GRAMSTR["***GRAM STAIN"
QUIT
+10 IF GRAMSTR="GRAM STAIN"
QUIT
+11 IF $TRANSLATE(GRAMSTR," ")="GS"
QUIT
+12 ;
+13 SET GRAMCNT=GRAMCNT+1
+14 IF GRAMCNT=1
DO ADDLINE("GRAM STAIN:")
+15 DO ADDLINE($JUSTIFY("",5)_GRAMSTR)
End DoDot:1
+16 ;
+17 DO ADDLINE($JUSTIFY("",GIOM))
+18 QUIT
+19 ;
ORGLINE ; EP - ORGANISM Line
+1 NEW ABNFLAG,HL7FLAG,IENSTR,OBSDATE,ORGCOMM,ORGIEN,ORGDESC,ORGQUANT,ORGSNOMD
+2 ;
+3 SET HL7FLAG=0
+4 SET STR=$GET(^LR(LRDFN,"MI",LRIDT,3,ORGL,"IHSOBX"))
+5 IF $LENGTH(STR)
SET HL7FLAG=1
+6 SET SNOMED=$PIECE(STR,"^")
+7 SET (ABNFLAG,FLAG)=$PIECE(STR,"^",3)
+8 SET OBSDATE=$PIECE(STR,"^",5)
+9 ;
+10 IF $LENGTH(OBSDATE)<1
Begin DoDot:1
+11 SET OBSDATE=$PIECE($GET(^LR(LRDFN,"MI",LRIDT,ORGL,1)),"^")
+12 IF $LENGTH(OBSDATE)<1
SET OBSDATE=$PIECE($GET(^LR(LRDFN,"MI",LRIDT,0)),"^",3)
IF $LENGTH(OBSDATE)<1
SET OBSDATE=$PIECE($GET(^(0)),"^",10)
End DoDot:1
+13 ;
+14 IF ORGHEAD<1
Begin DoDot:1
+15 DO ADDLINE("CULTURE RESULTS:")
+16 SET ORGHEAD=1+$GET(ORGHEAD)
End DoDot:1
+17 ;
+18 SET IENSTR=ORGL_","_LRIDT_","_LRDFN_","
+19 SET ORGDESC=$$GET1^DIQ(63.3,IENSTR,"ORGANISM")
+20 SET ORGQUANT=$$GET1^DIQ(63.3,IENSTR,"QUANTITY")
+21 ;
+22 IF HL7FLAG
Begin DoDot:1
+23 KILL STR
SET $EXTRACT(STR,5)="Description"
SET $EXTRACT(STR,40)="Quantity"
SET $EXTRACT(STR,59)="FLG"
SET $EXTRACT(STR,64)="Observation Date"
+24 DO ADDLINE(STR)
+25 KILL STR
SET STR=ORGL_"."
SET $EXTRACT(STR,5)=ORGDESC
SET $EXTRACT(STR,40)=ORGQUANT
SET $EXTRACT(STR,60)=ABNFLAG
SET $EXTRACT(STR,64)=$$FMTE^XLFDT(OBSDATE,"5MZ")
+26 DO ADDLINE(STR)
End DoDot:1
+27 ;
+28 IF 'HL7FLAG
Begin DoDot:1
+29 KILL STR
SET $EXTRACT(STR,5)="Description"
SET $EXTRACT(STR,40)="Quantity"
SET $EXTRACT(STR,64)="Observation Date"
+30 DO ADDLINE(STR)
+31 KILL STR
SET STR=ORGL_"."
SET $EXTRACT(STR,5)=ORGDESC
SET $EXTRACT(STR,40)=ORGQUANT
SET $EXTRACT(STR,64)=$$FMTE^XLFDT(OBSDATE,"5MZ")
+32 DO ADDLINE(STR)
End DoDot:1
+33 ;
+34 SET ORGCOMM=0
+35 FOR
SET ORGCOMM=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGL,1,ORGCOMM))
IF ORGCOMM<1
QUIT
Begin DoDot:1
+36 KILL STR
SET $EXTRACT(STR,10)=$GET(^LR(LRDFN,"MI",LRIDT,3,ORGL,1,ORGCOMM,0))
+37 DO ADDLINE(STR)
End DoDot:1
+38 ;
+39 QUIT
+40 ;
DRUGSORT ; Put drugs into Print Order
+1 SET DRUGNODE=2
+2 FOR
SET DRUGNODE=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGL,DRUGNODE))
IF DRUGNODE<1
QUIT
Begin DoDot:1
+3 SET DRUGIEN=$ORDER(^LAB(62.06,"AD",DRUGNODE,0))
+4 SET DRUGNAME=$$GET1^DIQ(62.06,DRUGIEN,"NAME")
+5 SET DRUGDISP=$$GET1^DIQ(62.06,DRUGIEN,"DISPLAY COMMENT")
+6 SET PRNTORDR=+$$GET1^DIQ(62.06,DRUGIEN,"PRINT ORDER")
+7 SET DRUGSORT(PRNTORDR,DRUGNODE)=DRUGIEN_"^"_DRUGNAME_"^"_DRUGDISP
End DoDot:1
+8 ;
+9 SET PRNTORDR=""
SET DRUGHEAD=0
+10 FOR
SET PRNTORDR=$ORDER(DRUGSORT(PRNTORDR))
IF PRNTORDR<1
QUIT
Begin DoDot:1
+11 SET DRUGNODE=""
+12 FOR
SET DRUGNODE=$ORDER(DRUGSORT(PRNTORDR,DRUGNODE))
IF DRUGNODE<1
QUIT
Begin DoDot:2
+13 SET STR=$GET(DRUGSORT(PRNTORDR,DRUGNODE))
+14 SET DRUGIEN=$PIECE(STR,"^")
SET DRUGNAME=$PIECE(STR,"^",2)
SET DRUGDISP=$PIECE(STR,"^",3)
+15 DO DRUGAMTS
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
DRUGAMTS ; EP - Drug values
+1 IF $DATA(^LR(LRDFN,"MI",LRIDT,3,ORGL,"ISO"))
DO HL7DRUGS
QUIT
+2 ;
+3 DO INHOUSE
+4 QUIT
+5 ;
INHOUSE ; EP - Drug values from RPMS entry
+1 SET STR=$GET(^LR(LRDFN,"MI",LRIDT,3,ORGL,DRUGNODE))
+2 SET SUSC=$PIECE(STR,"^")
+3 SET INTP=$PIECE(STR,"^",2)
+4 SET ALTI=$PIECE(STR,"^",3)
+5 IF $LENGTH(SUSC)<1&($LENGTH(INTP)<1)&($LENGTH(ALTI)<1)
QUIT
+6 ;
+7 ; Only display drugs that have valid interpretation for the result (the "AI" X-ref)
+8 SET (BADSUSC,BADINTP)=1
+9 IF $LENGTH(INTP)
SET BADINTP=$DATA(^LAB(62.06,"AI",DRUGNODE,INTP))
+10 IF $LENGTH(SUSC)
SET BADSUSC=$DATA(^LAB(62.06,"AI",DRUGNODE,SUSC))
+11 IF BADINTP<1&(BADSUSC<1)
QUIT
+12 ;
+13 IF +$GET(DRUGHEAD)<1
DO DRUGHEAD
+14 ;
+15 SET RPTSTS=$PIECE($GET(^LR(LRDFN,"MI",LRIDT,1)),"^",2)
+16 ;
+17 SET STR=$GET(^LR(LRDFN,"MI",LRIDT,ORGL,1))
+18 SET OBSDATE=$PIECE(STR,"^")
+19 IF $LENGTH(OBSDATE)<1
SET OBSDATE=$PIECE($GET(^LR(LRDFN,"MI",LRIDT,0)),"^",3)
IF $LENGTH(OBSDATE)<1
SET OBSDATE=$PIECE($GET(^(0)),"^",10)
+20 ;
+21 SET LRAS=$PIECE($GET(^LR(LRDFN,"MI",LRIDT,0)),"^",6)
+22 SET RF=$$GETPLIEN()
+23 IF $LENGTH(RF)
SET LRPLS(RF)=""
+24 ;
+25 IF $LENGTH(OBSDATE)
SET OBSDATE=$$FMTE^XLFDT(OBSDATE,"5MZ")
+26 SET (FLAG,RESULT,UNITS)=""
+27 ;
+28 ; Special "trick". See file 62.06 & RESULT entry
+29 SET RESULT=SUSC
+30 IF $LENGTH($PIECE(SUSC," ",2))
Begin DoDot:1
+31 SET RESULT=$PIECE(SUSC," ")
+32 SET UNITS=$PIECE(SUSC," ",2)
+33 SET SUSC=""
End DoDot:1
+34 ;
+35 KILL STR
SET STR=$EXTRACT(DRUGNAME,1,25)
SET $EXTRACT(STR,28)=RESULT
SET $EXTRACT(STR,34)=UNITS
SET $EXTRACT(STR,41)=INTP
+36 SET $EXTRACT(STR,47)=ALTI
SET $EXTRACT(STR,54)=OBSDATE
+37 IF $LENGTH(RF)
SET $EXTRACT(STR,75)="["_RF_"]"
+38 DO ADDLINE(STR)
+39 IF $LENGTH(DRUGDISP)
KILL STR
SET $EXTRACT(STR,15)=DRUGDISP
DO ADDLINE(STR)
+40 QUIT
+41 ;
DRUGHEAD ; EP - In-House Drug "Heading"
+1 DO BLNKLINE
+2 KILL STR
SET $EXTRACT(STR,47)="ALT"
DO ADDLINE(STR)
+3 KILL STR
SET STR="ANTIBIOTIC"
SET $EXTRACT(STR,28)="SUSC"
SET $EXTRACT(STR,34)="UNITS"
SET $EXTRACT(STR,41)="INTP"
+4 SET $EXTRACT(STR,47)="INTP"
SET $EXTRACT(STR,54)="OBSERVATION DATE"
SET $EXTRACT(STR,76)="SITE"
+5 DO ADDLINE(STR)
+6 SET DRUGHEAD=1+$GET(DRUGHEAD)
+7 QUIT
+8 ;
HL7DRUGS ; EP - Drug values from INCOMING HL7 messages
+1 SET STR=$GET(^LR(LRDFN,"MI",LRIDT,3,ORGL,DRUGNODE))
+2 SET SUSC=$PIECE(STR,"^")
+3 SET INTP=$PIECE(STR,"^",2)
+4 ;
+5 ; Only display drugs that have valid interpretation for the result (the "AI" X-ref)
+6 ; Q:INTP&($D(^LAB(62.06,"AI",DRUGNODE,INTP))<1)
+7 ; Q:SUSC&($D(^LAB(62.06,"AI",DRUGNODE,SUSC))<1)
+8 ;
+9 IF +$GET(DRUGHEAD)<1
DO HL7DHEAD
+10 ;
+11 SET ISO=.9999999
SET FOUNDIT=0
+12 FOR
SET ISO=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGL,"ISO",ISO))
IF ISO<1!(FOUNDIT)
QUIT
Begin DoDot:1
+13 IF $GET(^LR(LRDFN,"MI",LRIDT,3,ORGL,"ISO",ISO))[DRUGNODE
SET FOUNDIT=ISO
End DoDot:1
+14 ;
+15 IF FOUNDIT<1
DO BLNKLINE
QUIT
+16 ;
+17 SET STR=$GET(^LR(LRDFN,"MI",LRIDT,3,ORGL,"ISO","IHSOBX",FOUNDIT))
+18 SET RESULT=$PIECE(STR,"^")
SET UNITS=$PIECE($PIECE(STR,"^",2),"~")
SET FLAG=$PIECE(STR,"^",3)
+19 SET RPTSTS=$PIECE(STR,"^",4)
SET OBSDATE=$PIECE(STR,"^",5)
SET RF=$PIECE(STR,"^",6)
+20 IF $LENGTH(RF)
SET LRPLS(RF)=""
+21 IF $LENGTH(OBSDATE)
SET OBSDATE=$$FMTE^XLFDT(OBSDATE,"5MZ")
+22 ;
+23 IF SUSC="R"&(INTP="R")
QUIT
+24 ;
+25 KILL STR
SET STR=$EXTRACT(DRUGNAME,1,25)
SET $EXTRACT(STR,28)=RESULT
SET $EXTRACT(STR,34)=UNITS
SET $EXTRACT(STR,41)=FLAG
+26 SET $EXTRACT(STR,44)=SUSC
SET $EXTRACT(STR,49)=INTP
SET $EXTRACT(STR,55)=RPTSTS
SET $EXTRACT(STR,58)=OBSDATE
+27 IF $LENGTH(RF)
SET $EXTRACT(STR,75)="["_RF_"]"
+28 DO ADDLINE(STR)
+29 IF $LENGTH(DRUGDISP)
KILL STR
SET $EXTRACT(STR,15)=DRUGDISP
DO ADDLINE(STR)
+30 ;
+31 QUIT
+32 ;
HL7DHEAD ; EP - HL7 Incoming Drug "Heading"
+1 DO BLNKLINE
+2 KILL STR
SET $EXTRACT(STR,28)="CONC"
DO ADDLINE(STR)
+3 KILL STR
SET STR="ANTIBIOTIC"
SET $EXTRACT(STR,28)="RANGE"
SET $EXTRACT(STR,34)="UNITS"
SET $EXTRACT(STR,40)="FLG"
+4 SET $EXTRACT(STR,44)="SUSC"
SET $EXTRACT(STR,49)="INTP"
SET $EXTRACT(STR,54)="STS"
SET $EXTRACT(STR,58)="OBSERVATION DATE"
SET $EXTRACT(STR,76)="SITE"
+5 DO ADDLINE(STR)
+6 SET DRUGHEAD=1+$GET(DRUGHEAD)
+7 QUIT
+8 ;
GETLRDFN() ; EP - Always get LRDFN
+1 DO ^LRPARAM
+2 ;
+3 DO ^XBFMK
+4 SET DIR(0)="PO^2:E"
+5 SET DIR("A")="PATIENT"
+6 DO ^DIR
+7 IF +$GET(Y)<1!(+$GET(DIRUT))
Begin DoDot:1
+8 WRITE !,?4,"No/Invalid/Quit Entry. Routine Ends."
+9 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT "Q"
+10 ;
+11 SET DFN=+$GET(Y)
+12 SET PNM=$PIECE(Y,"^",2)
+13 ;
+14 SET DOD=+$$GET1^DIQ(2,DFN,.351,"I")
+15 IF DOD
DO WARN^LRDPA
IF DFN<1
QUIT "Q"
+16 ;
+17 SET LRDFN=+$GET(^DPT(DFN,"LR"))
+18 IF LRDFN
QUIT "OK"
+19 ;
+20 WRITE !!,?4,"Patient ",$$GET1^DIQ(2,+Y,"NAME")," [",+Y,"] has NO Lab Data. Routine Ends."
+21 DO PRESSKEY^BLRGMENU(9)
+22 QUIT "Q"
+23 ;
+24 ;
TESTIT ; EP - Test Code
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 QUIT
+4 ;
+5 ; Following code cloned from LR7OSMZ0
+6 ;
EN(DFN) ; EP - Process Microbiology entries listed in ^TMP("LRRR",$J,DFN,"MI",LRIDT,1)
+1 ;Return formated report in ^TMP("LRC",$J)
+2 IF '$DATA(^TMP("LRRR",$JOB,+$GET(DFN),"MI"))
QUIT
+3 ;
+4 NEW LBL,LCNT,LRAA,LRACC,LRAD,LRAN,LRCMNT,LRDFN,LRDPF,LRIDT,LRJ02,LRLLT,LRPG,LRSB
+5 NEW LRONESPC,LREND,LRONETST,GCNT,GIOM,LREND,CCNT,CT1,COUNT,LRIN,SEX,TABIT
+6 ;
+7 KILL ^TMP("LRC",$JOB)
+8 SET (LRONETST,LRONESPC)=""
SET CCNT=1
SET (LREND,GCNT)=0
SET GIOSL=999999
SET GIOM=80
+9 IF '$GET(DFN)
QUIT
+10 SET LRDFN=$$LRDFN^LR7OR1(DFN)
+11 IF 'LRDFN
QUIT
+12 SET LRDPF="2^DPT("
SET SEX=$PIECE($GET(@("^"_$PIECE(LRDPF,"^",2)_+LRDFN_",0)")),"^",2)
SET LRIDT=0
+13 FOR
SET LRIDT=$ORDER(^TMP("LRRR",$JOB,DFN,"MI",LRIDT))
IF LRIDT<1
QUIT
Begin DoDot:1
+14 NEW DFN
+15 DO EN1
End DoDot:1
+16 QUIT
+17 ;
EN1 ; EP
+1 SET LRLLT=$GET(^LR(LRDFN,"MI",LRIDT,0))
+2 SET LRACC=$PIECE(LRLLT,U,6)
+3 ;
+4 IF $$GETACCCP^BLRUTIL3(LRACC,.LRAA,.LRAD,.LRAN)<1
QUIT
+5 ;
+6 SET LRCMNT=$SELECT($DATA(^LR(LRDFN,"MI",LRIDT,99)):^(99),1:"")
+7 SET LRPG=0
+8 SET TABIT=$JUSTIFY("",5)
+9 SET TABIT2=$JUSTIFY("",10)
+10 ; D EN^LR7OSMZ1
+11 DO EP^BLRMIEHR
+12 QUIT
+13 ;
