BLRMIEHR.m

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

 ;

HEADER ; EP

 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

 ;

FOOTER ; EP

 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

 ;

REMARKS ; EP - BACT RPT REMARKS

 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      ;

HEADER    ; EP

 +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      ;

FOOTER    ; EP

 +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")