BLRMIRPT ; IHS/MSC/MKK - IHS Lab Micro Report ; 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
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
Q:$$GETLRDFN()="Q"
;
W !!
;
D B^LRU ; Get Date Range
;
I +$G(LRSDT)<1!(+$G(LRLDT)<1) D BADSTUFF("Quit or Invalid Data. Routine Ends.") Q
;
S LRSIDT=9999999-$$FMADD^XLFDT(LRLDT,1) ; "Starting" Inverse Date
S LREIDT=9999999-LRSDT ; "Ending" Inverse Date
;
W !! D HEADONE^BLRGMENU(.HEADONE) W !! ; Pagination
;
D ^%ZIS
I POP D BADSTUFF("Open Device Failed. Routine Ends.") Q
U IO
;
S BLRVERN=$TR($P($T(+1),";")," "),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,DRUGSORT
.. W ! S LINES=LINES+1
. W ! S LINES=LINES+1
. D FOOTER
. D:IOST["VT" PRESSKEY^BLRGMENU(9)
;
D ^%ZISC
;
Q
;
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))
;
K HEADER
S HEADER(1)="---- MICROBIOLOGY ----"
S:'DOD HEADER(2)=PATNAME_" DOB:"_PATDOB_" HRCN:"_HRCN
S:DOD HEADER(2)=PATNAME_" DOB:"_PATDOB_" DIED:"_PATDOD_" HRCN:"_HRCN
S HEADER(3)=" "
D INSTDATA(DUZ(2),.STR1,.STR2)
S HEADER(4)=$$CJ^XLFSTR("Printed At: "_STR1,IOM)
S:$L(STR2) HEADER(5)=$$CJ^XLFSTR(STR2,IOM)
;
D HEADERDT^BLRGMENU
D DATAHEAD
;
W "Accession:",LRAS,?44,"Received:",RECDDATE,!
W "Collection Sample:",CSNAME,?44,"Collection Date:",COLLDATE,!
W "Site/Specimen:",SSNAME,!,"Provider:",PROVIDER,!
W:$L(COMMENT) "Comment on Specimen:",$G(COMMENT),!
W !!
;
D ORDTESTS
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),PROVIDER=$$GET1^DIQ(200,PHYIEN,"NAME")
S CSIEN=+$P(STR,"^",11),CSNAME=$$GET1^DIQ(62,CSIEN,"NAME") ; Collection Sample
S COMMENT=$G(^LR(LRDFN,"MI",LRIDT,99))
Q
;
W !,$TR($J("",IOM)," ","-"),!
;
S RF=$$GETPERFL()
S:RF<1 RF=$G(DUZ(2))
;
Q:$$INSTDATA(RF,.STR1,.STR2)="Q"
;
W $$CJ^XLFSTR("Performing Laboratory:",IOM),!
W "[",RF,"] ",STR1,!
S LINES=LINES+1
I $L(STR2)<1 D WRITECC Q
;
W STR2,!
S LINES=LINES+1
D WRITECC
Q
;
GETPERFL() ; GET PERForming Lab
S X=$$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRIDT=$P($G(^(3)),"^",5)
;
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
S RF=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,.4))
Q RF
;
WRITECC ; EP - Write County & Country, if they exist
NEW COUNTRY,COUNTY,IENS
;
S (COUNTY,COUNTRY)=""
;
S IENS=LRIDT_","_LRDFN
S COUNTY=$$GET1^DIQ(63.05,IENS,9999996),COUNTRY=$$GET1^DIQ(63.05,IENS,9999997)
Q:$L(COUNTY)<1&($L(COUNTRY)<1)
;
W ?8
W:$L(COUNTY) $$LJ^XLFSTR("County:"_COUNTY,15)
W:$L(COUNTRY) "Country:",COUNTRY
W !
S LINES=LINES+1
Q
;
ORDTESTS ; EP - Ordered Tests(s)
NEW COMPDATE,F6OIEN,F60DESC,IENSTR,LRAA,LRAD,LRAN,LRAS,TESTS
NEW ORG,ORGCOMM,ORGDESC,ORGQUANT,UID
;
W $$CJ^XLFSTR("Tests(s) Ordered:",IOM),!!
;
S UID=+$G(^LR(LRDFN,"MI",LRIDT,"ORU"))
I UID 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
. W ?4,$$GET1^DIQ(60,TESTS,"NAME")
. S COMPDATE=$$GET1^DIQ(68.04,TESTS_","_IENSTR,"COMPLETE DATE","I")
. W:$L(COMPDATE) ?44,"Completed: ",$TR($$FMTE^XLFDT(COMPDATE,"MZ"),"@"," ")
. W !
W !
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")
;
W ?4,"BACTERIOLOGY ",BCRPTSTS," => "
W $$FMTE^XLFDT(BACRPTDA,"5DZ")
W ?59,"TECH CODE:",BCRPTDUZ
W !!
;
D PRELIM^BLRMIRP2 ; Preliminary Remarks
;
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
W ?4,"Bacteriology Remark(s):",!
S BACTREM=0
F S BACTREM=$O(^LR(LRDFN,"MI",LRIDT,4,BACTREM)) Q:BACTREM<1 W ?9,$G(^(BACTREM,0)),!
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),FLAG=$P(STR,"^",3)
S SUSC=$P(STR,"^",4),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," ")=""!(GRAMSTR["***GRAM STAIN")!(GRAMSTR="GRAM STAIN")!($TR(GRAMSTR," ")="GS")
. ;
. S GRAMCNT=GRAMCNT+1
. W:GRAMCNT=1 ?4,"GRAM STAIN:",!
. W ?9,$G(^LR(LRDFN,"MI",LRIDT,2,D2,0)),!
. S LINES=LINES+1
;
W !
S LINES=LINES+1
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,"^"),(ABNFLAG,FLAG)=$P(STR,"^",3),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 W !,"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
. W !,?4,"Description",?39,"Quantity",?58,"FLG",?63,"Observation Date",!
. W ORGL,".",?4,ORGDESC,?39,ORGQUANT,?59,ABNFLAG,?63,$$FMTE^XLFDT(OBSDATE,"5MZ"),!
;
I 'HL7FLAG D
. W !,?4,"Description",?39,"Quantity",?63,"Observation Date",!
. W ORGL,".",?4,ORGDESC,?39,ORGQUANT,?63,$$FMTE^XLFDT(OBSDATE,"5MZ"),!
;
S ORGCOMM=0
F S ORGCOMM=$O(^LR(LRDFN,"MI",LRIDT,3,ORGL,1,ORGCOMM)) Q:ORGCOMM<1 D
. W ?9,$G(^LR(LRDFN,"MI",LRIDT,3,ORGL,1,ORGCOMM,0)),!
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,"^"),INTP=$P(STR,"^",2),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=$$GETPERFL()
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)) S RESULT=$P(SUSC," "),UNITS=$P(SUSC," ",2),SUSC=""
;
W $E(DRUGNAME,1,25),?27,RESULT,?33,UNITS,?40,INTP,?46,ALTI,?53,OBSDATE
W:$L(RF) ?74,"[",RF,"]",!
S LINES=LINES+1
I $L(DRUGDISP) W ?14,DRUGDISP,! S LINES=LINES+1
Q
;
DRUGHEAD ; EP - In-House Drug "Heading"
W !,?46,"ALT",!,"ANTIBIOTIC",?27,"SUSC",?33,"UNITS",?40,"INTP",?46,"INTP",?53,"OBSERVATION DATE",?75,"SITE",!
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)
;
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 W ! S LINES=LINES+1 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")
;
W $E(DRUGNAME,1,25),?27,RESULT,?33,UNITS,?40,FLAG,?43,SUSC,?48,INTP,?54,RPTSTS,?57,OBSDATE
W:$L(RF) ?74,"[",RF,"]"
W !
S LINES=LINES+1
I $L(DRUGDISP) W ?14,DRUGDISP,! S LINES=LINES+1
;
Q
;
HL7DHEAD ; EP - HL7 Incoming Drug "Heading"
W !,?27,"CONC",!,"ANTIBIOTIC",?27,"RANGE",?33,"UNITS",?39,"FLG",?43,"SUSC",?48,"INTP",?53,"STS",?57,"OBSERVATION DATE",?75,"SITE",!
S DRUGHEAD=1+$G(DRUGHEAD)
Q
;
PRELIM ; EP - Preliminary Report -- For Testing Purposes Only
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S HEADER(1)="*** PRELIMINARY ***"
S HEADER(2)="Meaningful Use Stage 2 Micro Report"
;
D HEADERDT^BLRGMENU
;
D ^LRWU4
;
S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRIDT=$P($G(^(3)),"^",5)
;
I LRDFN<1 D Q
. W !!,?4,"Could not determine Accession's data. Routine Ends."
. D PRESSKEY^BLRGMENU(9)
;
S BLRVERN=$TR($P($T(+1),";")," ")
S LINES=0
;
D HEADER
D GRAMSTAN(LRDFN,LRIDT)
S ORGL=.9999999,ORGHEAD=0
F S ORGL=$O(^LR(LRDFN,"MI",LRIDT,3,ORGL)) Q:ORGL<1 D
. D ORGLINE
. D DRUGSORT
. W !
;
D PRESSKEY^BLRGMENU(9)
;
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"
;
DEBUGER ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D B^LRU ; Get Date Range
;
S LRSIDT=9999999-$$FMADD^XLFDT(LRLDT,1) ; "Starting" Inverse Date
S LREIDT=9999999-LRSDT ; "Ending" Inverse Date
;
W !!,?4,"LRSIDT:",LRSIDT,!,?4,"LREIDT:",LREIDT,!!
W ?4,"LRIDT",?24,"$P(LRIDT,""."")>LREIDT",!
W ?4,$TR($J("",15)," ","-"),?24,$TR($J("",22)," ","-"),!
;
S LRDFN=10553,LRIDT=LRSIDT,QFLG="NO"
F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1 D
. W ?4,LRIDT
. W ?24,$S($P(LRIDT,".")>LREIDT:"TRUE",1:"FALSE")
. W !
Q
;
LRAS ; EP - Debug by entering Accession or UID
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
D ^LRWU4
;
I LRAA<1!(LRAD<1)!(LRAN<1) D BADSTUFF("No/Invalid Entry. Routine Ends.") Q
;
I $$GET1^DIQ(68,LRAA,.02,"I")'="MI" D Q
. D BADSTUFF("Accession "_$$GET1^DIQ(68,LRAA,.01)_" (#"_LRAA_") is not a Micro Accession. Routine Ends.")
;
I $D(^LRO(68,LRAA,1,LRAD,1,LRAN))<1 D BADSTUFF("No Accession Data for Accession "_BLRLRAS_". Routine Ends.") Q
;
S LRDFN=+$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0)),LRIDT=$P($G(^(3)),"^",5),DFN=$P($G(^LR(LRDFN,0)),"^",3)
S QFLG="NO"
;
W !!
D HEADONE^BLRGMENU(.HEADONE) ; Pagination
W !!
;
D ^%ZIS
I POP D BADSTUFF("Open Device Failed. Routine Ends.") Q
;
U IO
;
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,DRUGSORT
. W ! S LINES=LINES+1
W ! S LINES=LINES+1
;
D FOOTER
;
D ^%ZISC
;
D PRESSKEY^BLRGMENU(9)
Q
;
BADSTUFF(MSG) ; EP
W !!,?4,MSG
D PRESSKEY^BLRGMENU(9)
Q
BLRMIRPT ; IHS/MSC/MKK - IHS Lab Micro Report ; 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 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 IF $$GETLRDFN()="Q"
QUIT
+4 ;
+5 WRITE !!
+6 ;
+7 ; Get Date Range
DO B^LRU
+8 ;
+9 IF +$GET(LRSDT)<1!(+$GET(LRLDT)<1)
DO BADSTUFF("Quit or Invalid Data. Routine Ends.")
QUIT
+10 ;
+11 ; "Starting" Inverse Date
SET LRSIDT=9999999-$$FMADD^XLFDT(LRLDT,1)
+12 ; "Ending" Inverse Date
SET LREIDT=9999999-LRSDT
+13 ;
+14 ; Pagination
WRITE !!
DO HEADONE^BLRGMENU(.HEADONE)
WRITE !!
+15 ;
+16 DO ^%ZIS
+17 IF POP
DO BADSTUFF("Open Device Failed. Routine Ends.")
QUIT
+18 USE IO
+19 ;
+20 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
SET LINES=0
+21 SET LRIDT=LRSIDT
SET QFLG="NO"
+22 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
IF LRIDT<1!($PIECE(LRIDT,".")>LREIDT)!(QFLG="Q")
QUIT
Begin DoDot:1
+23 DO HEADER
+24 DO GRAMSTAN(LRDFN,LRIDT)
+25 SET ORGL=.9999999
SET ORGHEAD=0
+26 FOR
SET ORGL=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGL))
IF ORGL<1!(QFLG="Q")
QUIT
Begin DoDot:2
+27 DO ORGLINE
DO DRUGSORT
+28 WRITE !
SET LINES=LINES+1
End DoDot:2
+29 WRITE !
SET LINES=LINES+1
+30 DO FOOTER
+31 IF IOST["VT"
DO PRESSKEY^BLRGMENU(9)
End DoDot:1
+32 ;
+33 DO ^%ZISC
+34 ;
+35 QUIT
+36 ;
+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 ;
+8 KILL HEADER
+9 SET HEADER(1)="---- MICROBIOLOGY ----"
+10 IF 'DOD
SET HEADER(2)=PATNAME_" DOB:"_PATDOB_" HRCN:"_HRCN
+11 IF DOD
SET HEADER(2)=PATNAME_" DOB:"_PATDOB_" DIED:"_PATDOD_" HRCN:"_HRCN
+12 SET HEADER(3)=" "
+13 DO INSTDATA(DUZ(2),.STR1,.STR2)
+14 SET HEADER(4)=$$CJ^XLFSTR("Printed At: "_STR1,IOM)
+15 IF $LENGTH(STR2)
SET HEADER(5)=$$CJ^XLFSTR(STR2,IOM)
+16 ;
+17 DO HEADERDT^BLRGMENU
+18 DO DATAHEAD
+19 ;
+20 WRITE "Accession:",LRAS,?44,"Received:",RECDDATE,!
+21 WRITE "Collection Sample:",CSNAME,?44,"Collection Date:",COLLDATE,!
+22 WRITE "Site/Specimen:",SSNAME,!,"Provider:",PROVIDER,!
+23 IF $LENGTH(COMMENT)
WRITE "Comment on Specimen:",$GET(COMMENT),!
+24 WRITE !!
+25 ;
+26 DO ORDTESTS
+27 QUIT
+28 ;
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 ; Received Date
SET RECDDATE=$$FMTE^XLFDT($PIECE(STR,"^",10),"5MZ")
+4 ; Accession
SET LRAS=$PIECE(STR,"^",6)
+5 SET SSIEN=+$PIECE(STR,"^",5)
+6 ; Site/Specimen Name
SET SSNAME=$$GET1^DIQ(61,SSIEN,"NAME")
+7 ;
+8 SET PHYIEN=+$PIECE(STR,"^",7)
SET PROVIDER=$$GET1^DIQ(200,PHYIEN,"NAME")
+9 ; Collection Sample
SET CSIEN=+$PIECE(STR,"^",11)
SET CSNAME=$$GET1^DIQ(62,CSIEN,"NAME")
+10 SET COMMENT=$GET(^LR(LRDFN,"MI",LRIDT,99))
+11 QUIT
+12 ;
+1 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-"),!
+2 ;
+3 SET RF=$$GETPERFL()
+4 IF RF<1
SET RF=$GET(DUZ(2))
+5 ;
+6 IF $$INSTDATA(RF,.STR1,.STR2)="Q"
QUIT
+7 ;
+8 WRITE $$CJ^XLFSTR("Performing Laboratory:",IOM),!
+9 WRITE "[",RF,"] ",STR1,!
+10 SET LINES=LINES+1
+11 IF $LENGTH(STR2)<1
DO WRITECC
QUIT
+12 ;
+13 WRITE STR2,!
+14 SET LINES=LINES+1
+15 DO WRITECC
+16 QUIT
+17 ;
GETPERFL() ; GET PERForming Lab
+1 SET X=$$GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
+2 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LRIDT=$PIECE($GET(^(3)),"^",5)
+3 ;
+4 ; Reference Lab Node
SET RF=+$GET(^LR(LRDFN,"MI",LRIDT,"RF"))
+5 IF RF
QUIT RF
+6 ;
+7 ; Try to get from Organism structure
+8 ; Performing Lab
SET RF=+$PIECE($GET(^LR(LRDFN,"MI",LRIDT,3,1,"IHSOBX")),U,6)
+9 IF RF
QUIT RF
+10 ;
+11 ; Accessioning Lab
SET RF=+$PIECE($GET(^LR(LRDFN,"MI",LRIDT,0)),U,14)
+12 IF RF
QUIT RF
+13 ;
+14 ; Try the Accession Division
+15 SET RF=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,.4))
+16 QUIT RF
+17 ;
WRITECC ; EP - Write County & Country, if they exist
+1 NEW COUNTRY,COUNTY,IENS
+2 ;
+3 SET (COUNTY,COUNTRY)=""
+4 ;
+5 SET IENS=LRIDT_","_LRDFN
+6 SET COUNTY=$$GET1^DIQ(63.05,IENS,9999996)
SET COUNTRY=$$GET1^DIQ(63.05,IENS,9999997)
+7 IF $LENGTH(COUNTY)<1&($LENGTH(COUNTRY)<1)
QUIT
+8 ;
+9 WRITE ?8
+10 IF $LENGTH(COUNTY)
WRITE $$LJ^XLFSTR("County:"_COUNTY,15)
+11 IF $LENGTH(COUNTRY)
WRITE "Country:",COUNTRY
+12 WRITE !
+13 SET LINES=LINES+1
+14 QUIT
+15 ;
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 WRITE $$CJ^XLFSTR("Tests(s) Ordered:",IOM),!!
+5 ;
+6 SET UID=+$GET(^LR(LRDFN,"MI",LRIDT,"ORU"))
+7 IF UID
SET X=$QUERY(^LRO(68,"C",UID,0))
SET LRAA=$QSUBSCRIPT(X,4)
SET LRAD=$QSUBSCRIPT(X,5)
SET LRAN=$QSUBSCRIPT(X,6)
+8 IF UID<1
Begin DoDot:1
+9 SET LRAS=$PIECE($GET(^LR(LRDFN,"MI",LRIDT,0)),"^",6)
+10 DO GETACCCP^BLRUTIL3(LRAS,.LRAA,.LRAD,.LRAN)
End DoDot:1
+11 ;
+12 SET IENSTR=LRAN_","_LRAD_","_LRAA_","
+13 SET TESTS=.9999999
SET X=0
+14 FOR
SET TESTS=$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,TESTS))
IF TESTS<1
QUIT
Begin DoDot:1
+15 WRITE ?4,$$GET1^DIQ(60,TESTS,"NAME")
+16 SET COMPDATE=$$GET1^DIQ(68.04,TESTS_","_IENSTR,"COMPLETE DATE","I")
+17 IF $LENGTH(COMPDATE)
WRITE ?44,"Completed: ",$TRANSLATE($$FMTE^XLFDT(COMPDATE,"MZ"),"@"," ")
+18 WRITE !
End DoDot:1
+19 WRITE !
+20 SET IENSTR=LRIDT_","_LRDFN
+21 SET BACRPTDA=$$GET1^DIQ(63.05,IENSTR,"BACT RPT DATE APPROVED","I")
+22 SET BCRPTSTS=$$GET1^DIQ(63.05,IENSTR,"BACT RPT STATUS")
+23 SET BCRPTDUZ=$$GET1^DIQ(63.05,IENSTR,"BACT PERSON","I")
+24 ;
+25 WRITE ?4,"BACTERIOLOGY ",BCRPTSTS," => "
+26 WRITE $$FMTE^XLFDT(BACRPTDA,"5DZ")
+27 WRITE ?59,"TECH CODE:",BCRPTDUZ
+28 WRITE !!
+29 ;
+30 ; Preliminary Remarks
DO PRELIM^BLRMIRP2
+31 ;
+32 DO REMARKS
+33 ;
+34 FOR
SET TESTS=$ORDER(^LR(LRDFN,"MI",LRIDT,26,TESTS))
IF TESTS<1
QUIT
Begin DoDot:1
End DoDot:1
+35 QUIT
+36 ;
+1 IF $ORDER(^LR(LRDFN,"MI",LRIDT,4,0))<1
QUIT
+2 ;
+3 NEW BACTREM
+4 WRITE ?4,"Bacteriology Remark(s):",!
+5 SET BACTREM=0
+6 FOR
SET BACTREM=$ORDER(^LR(LRDFN,"MI",LRIDT,4,BACTREM))
IF BACTREM<1
QUIT
WRITE ?9,$GET(^(BACTREM,0)),!
+7 QUIT
+8 ;
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 QUIT "OK"
+38 ;
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)
SET FLAG=$PIECE(STR,"^",3)
+4 SET SUSC=$PIECE(STR,"^",4)
SET UP=$PIECE(STR,"^",5)
+5 IF +UP
SET UNITS=$$GET1^DIQ(90475.3,UP,"DESCRIPTION")
+6 SET INTP=$PIECE(STR,"^",6)
+7 QUIT
+8 ;
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 IF $TRANSLATE(GRAMSTR," ")=""!(GRAMSTR["***GRAM STAIN")!(GRAMSTR="GRAM STAIN")!($TRANSLATE(GRAMSTR," ")="GS")
QUIT
+9 ;
+10 SET GRAMCNT=GRAMCNT+1
+11 IF GRAMCNT=1
WRITE ?4,"GRAM STAIN:",!
+12 WRITE ?9,$GET(^LR(LRDFN,"MI",LRIDT,2,D2,0)),!
+13 SET LINES=LINES+1
End DoDot:1
+14 ;
+15 WRITE !
+16 SET LINES=LINES+1
+17 QUIT
+18 ;
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,"^")
SET (ABNFLAG,FLAG)=$PIECE(STR,"^",3)
SET OBSDATE=$PIECE(STR,"^",5)
+7 ;
+8 IF $LENGTH(OBSDATE)<1
Begin DoDot:1
+9 SET OBSDATE=$PIECE($GET(^LR(LRDFN,"MI",LRIDT,ORGL,1)),"^")
+10 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
+11 ;
+12 IF ORGHEAD<1
WRITE !,"CULTURE RESULTS:",!
SET ORGHEAD=1+$GET(ORGHEAD)
+13 ;
+14 SET IENSTR=ORGL_","_LRIDT_","_LRDFN_","
+15 SET ORGDESC=$$GET1^DIQ(63.3,IENSTR,"ORGANISM")
+16 SET ORGQUANT=$$GET1^DIQ(63.3,IENSTR,"QUANTITY")
+17 ;
+18 IF HL7FLAG
Begin DoDot:1
+19 WRITE !,?4,"Description",?39,"Quantity",?58,"FLG",?63,"Observation Date",!
+20 WRITE ORGL,".",?4,ORGDESC,?39,ORGQUANT,?59,ABNFLAG,?63,$$FMTE^XLFDT(OBSDATE,"5MZ"),!
End DoDot:1
+21 ;
+22 IF 'HL7FLAG
Begin DoDot:1
+23 WRITE !,?4,"Description",?39,"Quantity",?63,"Observation Date",!
+24 WRITE ORGL,".",?4,ORGDESC,?39,ORGQUANT,?63,$$FMTE^XLFDT(OBSDATE,"5MZ"),!
End DoDot:1
+25 ;
+26 SET ORGCOMM=0
+27 FOR
SET ORGCOMM=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGL,1,ORGCOMM))
IF ORGCOMM<1
QUIT
Begin DoDot:1
+28 WRITE ?9,$GET(^LR(LRDFN,"MI",LRIDT,3,ORGL,1,ORGCOMM,0)),!
End DoDot:1
+29 QUIT
+30 ;
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,"^")
SET INTP=$PIECE(STR,"^",2)
SET ALTI=$PIECE(STR,"^",3)
+3 ;
+4 IF $LENGTH(SUSC)<1&($LENGTH(INTP)<1)&($LENGTH(ALTI)<1)
QUIT
+5 ;
+6 ; Only display drugs that have valid interpretation for the result (the "AI" X-ref)
+7 SET (BADSUSC,BADINTP)=1
+8 IF $LENGTH(INTP)
SET BADINTP=$DATA(^LAB(62.06,"AI",DRUGNODE,INTP))
+9 IF $LENGTH(SUSC)
SET BADSUSC=$DATA(^LAB(62.06,"AI",DRUGNODE,SUSC))
+10 IF BADINTP<1&(BADSUSC<1)
QUIT
+11 ;
+12 IF +$GET(DRUGHEAD)<1
DO DRUGHEAD
+13 ;
+14 SET RPTSTS=$PIECE($GET(^LR(LRDFN,"MI",LRIDT,1)),"^",2)
+15 ;
+16 SET STR=$GET(^LR(LRDFN,"MI",LRIDT,ORGL,1))
+17 SET OBSDATE=$PIECE(STR,"^")
+18 IF $LENGTH(OBSDATE)<1
SET OBSDATE=$PIECE($GET(^LR(LRDFN,"MI",LRIDT,0)),"^",3)
IF $LENGTH(OBSDATE)<1
SET OBSDATE=$PIECE($GET(^(0)),"^",10)
+19 ;
+20 SET LRAS=$PIECE($GET(^LR(LRDFN,"MI",LRIDT,0)),"^",6)
+21 SET RF=$$GETPERFL()
+22 IF $LENGTH(RF)
SET LRPLS(RF)=""
+23 ;
+24 IF $LENGTH(OBSDATE)
SET OBSDATE=$$FMTE^XLFDT(OBSDATE,"5MZ")
+25 SET (FLAG,RESULT,UNITS)=""
+26 ;
+27 ; Special "trick". See file 62.06 & RESULT entry
+28 SET RESULT=SUSC
+29 IF $LENGTH($PIECE(SUSC," ",2))
SET RESULT=$PIECE(SUSC," ")
SET UNITS=$PIECE(SUSC," ",2)
SET SUSC=""
+30 ;
+31 WRITE $EXTRACT(DRUGNAME,1,25),?27,RESULT,?33,UNITS,?40,INTP,?46,ALTI,?53,OBSDATE
+32 IF $LENGTH(RF)
WRITE ?74,"[",RF,"]",!
+33 SET LINES=LINES+1
+34 IF $LENGTH(DRUGDISP)
WRITE ?14,DRUGDISP,!
SET LINES=LINES+1
+35 QUIT
+36 ;
DRUGHEAD ; EP - In-House Drug "Heading"
+1 WRITE !,?46,"ALT",!,"ANTIBIOTIC",?27,"SUSC",?33,"UNITS",?40,"INTP",?46,"INTP",?53,"OBSERVATION DATE",?75,"SITE",!
+2 SET DRUGHEAD=1+$GET(DRUGHEAD)
+3 QUIT
+4 ;
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 IF +$GET(DRUGHEAD)<1
DO HL7DHEAD
+6 ;
+7 SET ISO=.9999999
SET FOUNDIT=0
+8 FOR
SET ISO=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGL,"ISO",ISO))
IF ISO<1!(FOUNDIT)
QUIT
Begin DoDot:1
+9 IF $GET(^LR(LRDFN,"MI",LRIDT,3,ORGL,"ISO",ISO))[DRUGNODE
SET FOUNDIT=ISO
End DoDot:1
+10 ;
+11 IF FOUNDIT<1
WRITE !
SET LINES=LINES+1
QUIT
+12 ;
+13 SET STR=$GET(^LR(LRDFN,"MI",LRIDT,3,ORGL,"ISO","IHSOBX",FOUNDIT))
+14 SET RESULT=$PIECE(STR,"^")
SET UNITS=$PIECE($PIECE(STR,"^",2),"~")
SET FLAG=$PIECE(STR,"^",3)
+15 SET RPTSTS=$PIECE(STR,"^",4)
SET OBSDATE=$PIECE(STR,"^",5)
SET RF=$PIECE(STR,"^",6)
+16 IF $LENGTH(RF)
SET LRPLS(RF)=""
+17 IF $LENGTH(OBSDATE)
SET OBSDATE=$$FMTE^XLFDT(OBSDATE,"5MZ")
+18 ;
+19 IF SUSC="R"&(INTP="R")
QUIT
+20 ;
+21 WRITE $EXTRACT(DRUGNAME,1,25),?27,RESULT,?33,UNITS,?40,FLAG,?43,SUSC,?48,INTP,?54,RPTSTS,?57,OBSDATE
+22 IF $LENGTH(RF)
WRITE ?74,"[",RF,"]"
+23 WRITE !
+24 SET LINES=LINES+1
+25 IF $LENGTH(DRUGDISP)
WRITE ?14,DRUGDISP,!
SET LINES=LINES+1
+26 ;
+27 QUIT
+28 ;
HL7DHEAD ; EP - HL7 Incoming Drug "Heading"
+1 WRITE !,?27,"CONC",!,"ANTIBIOTIC",?27,"RANGE",?33,"UNITS",?39,"FLG",?43,"SUSC",?48,"INTP",?53,"STS",?57,"OBSERVATION DATE",?75,"SITE",!
+2 SET DRUGHEAD=1+$GET(DRUGHEAD)
+3 QUIT
+4 ;
PRELIM ; EP - Preliminary Report -- For Testing Purposes Only
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 SET HEADER(1)="*** PRELIMINARY ***"
+4 SET HEADER(2)="Meaningful Use Stage 2 Micro Report"
+5 ;
+6 DO HEADERDT^BLRGMENU
+7 ;
+8 DO ^LRWU4
+9 ;
+10 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LRIDT=$PIECE($GET(^(3)),"^",5)
+11 ;
+12 IF LRDFN<1
Begin DoDot:1
+13 WRITE !!,?4,"Could not determine Accession's data. Routine Ends."
+14 DO PRESSKEY^BLRGMENU(9)
End DoDot:1
QUIT
+15 ;
+16 SET BLRVERN=$TRANSLATE($PIECE($TEXT(+1),";")," ")
+17 SET LINES=0
+18 ;
+19 DO HEADER
+20 DO GRAMSTAN(LRDFN,LRIDT)
+21 SET ORGL=.9999999
SET ORGHEAD=0
+22 FOR
SET ORGL=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGL))
IF ORGL<1
QUIT
Begin DoDot:1
+23 DO ORGLINE
+24 DO DRUGSORT
+25 WRITE !
End DoDot:1
+26 ;
+27 DO PRESSKEY^BLRGMENU(9)
+28 ;
+29 QUIT
+30 ;
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 ;
DEBUGER ; EP
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 ; Get Date Range
DO B^LRU
+4 ;
+5 ; "Starting" Inverse Date
SET LRSIDT=9999999-$$FMADD^XLFDT(LRLDT,1)
+6 ; "Ending" Inverse Date
SET LREIDT=9999999-LRSDT
+7 ;
+8 WRITE !!,?4,"LRSIDT:",LRSIDT,!,?4,"LREIDT:",LREIDT,!!
+9 WRITE ?4,"LRIDT",?24,"$P(LRIDT,""."")>LREIDT",!
+10 WRITE ?4,$TRANSLATE($JUSTIFY("",15)," ","-"),?24,$TRANSLATE($JUSTIFY("",22)," ","-"),!
+11 ;
+12 SET LRDFN=10553
SET LRIDT=LRSIDT
SET QFLG="NO"
+13 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
IF LRIDT<1
QUIT
Begin DoDot:1
+14 WRITE ?4,LRIDT
+15 WRITE ?24,$SELECT($PIECE(LRIDT,".")>LREIDT:"TRUE",1:"FALSE")
+16 WRITE !
End DoDot:1
+17 QUIT
+18 ;
LRAS ; EP - Debug by entering Accession or UID
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
+2 ;
+3 DO ^LRWU4
+4 ;
+5 IF LRAA<1!(LRAD<1)!(LRAN<1)
DO BADSTUFF("No/Invalid Entry. Routine Ends.")
QUIT
+6 ;
+7 IF $$GET1^DIQ(68,LRAA,.02,"I")'="MI"
Begin DoDot:1
+8 DO BADSTUFF("Accession "_$$GET1^DIQ(68,LRAA,.01)_" (#"_LRAA_") is not a Micro Accession. Routine Ends.")
End DoDot:1
QUIT
+9 ;
+10 IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN))<1
DO BADSTUFF("No Accession Data for Accession "_BLRLRAS_". Routine Ends.")
QUIT
+11 ;
+12 SET LRDFN=+$GET(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
SET LRIDT=$PIECE($GET(^(3)),"^",5)
SET DFN=$PIECE($GET(^LR(LRDFN,0)),"^",3)
+13 SET QFLG="NO"
+14 ;
+15 WRITE !!
+16 ; Pagination
DO HEADONE^BLRGMENU(.HEADONE)
+17 WRITE !!
+18 ;
+19 DO ^%ZIS
+20 IF POP
DO BADSTUFF("Open Device Failed. Routine Ends.")
QUIT
+21 ;
+22 USE IO
+23 ;
+24 DO HEADER
+25 DO GRAMSTAN(LRDFN,LRIDT)
+26 SET ORGL=.9999999
SET ORGHEAD=0
+27 FOR
SET ORGL=$ORDER(^LR(LRDFN,"MI",LRIDT,3,ORGL))
IF ORGL<1!(QFLG="Q")
QUIT
Begin DoDot:1
+28 DO ORGLINE
DO DRUGSORT
+29 WRITE !
SET LINES=LINES+1
End DoDot:1
+30 WRITE !
SET LINES=LINES+1
+31 ;
+32 DO FOOTER
+33 ;
+34 DO ^%ZISC
+35 ;
+36 DO PRESSKEY^BLRGMENU(9)
+37 QUIT
+38 ;
BADSTUFF(MSG) ; EP
+1 WRITE !!,?4,MSG
+2 DO PRESSKEY^BLRGMENU(9)
+3 QUIT
