BLRMIIBL ; IHS/MSC/MKK - MIcro Interim report by Location ; 15-Apr-2016 15:41 ; MKK
;;5.2;LAB SERVICE;**1039**;NOV 01, 1997;Build 38
;
EEP ; Ersatz EP
D EEP^BLRGMENU
Q
;
;
EP ; EP
PEP ; EP
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,U,XPARSYS,XQXFLG)
;
S HEADER(1)="Micro Interim Report by Location"
D HEADERDT^BLRGMENU
;
D ^XBFMK
S DIR(0)="PO^44:EMZ"
D ^DIR
I +$G(DIRUT)!(+Y<1) D BADSTUFF^BLRUTIL7("No/Invalid Entry.") Q
;
S ORDLOC=Y
S ORDLOCA=$$GET1^DIQ(44,+ORDLOC,1) ; Abbreviation
;
S HEADER(2)="Location:"_$P(ORDLOC,U,2)
;
D HEADERDT^BLRGMENU
D B^LRU
I $G(LRSDT)<1!($G(LRLDT)<1) D BADSTUFF^BLRUTIL7("Invalid Date Range.") Q
;
S HEADER(3)=$$CJ^XLFSTR("Date Range: "_$$FMTE^XLFDT(LRSDT,"5DZ")_" thru "_$$FMTE^XLFDT(LRLDT,"5DZ"),IOM)
;
K ^TMP("BLRMIIBL",$J)
;
W !!,?4,"Compiling Data"
;
D LDATACOM
;
W !!,?4,"Compilation Complete."
W !!,?9,CNTLRAS," MI Accessions analyzed."
W !!,?14,CNT," MI Accessions with ",$P(ORDLOC,U,2)," Ward.",!!
;
D ^XBFMK
S DIR(0)="YO"
S DIR("A")="Produce Report (Y/N)"
D ^DIR
I +$G(DIRUT)!(+Y<1) D Q
. D BADSTUFF^BLRUTIL7("No/Invalid Entry.")
. K ^TMP("BLRMIIBL",$J)
;
D ^%ZIS
U IO
D LDATARPT
D ^%ZISC
;
D PRESSKEY^BLRGMENU(9)
K ^TMP("BLRMIIBL",$J)
Q
;
LDATACOM ; EP - Compile from the Lab Data file
S LRDFN=.9999999,(CNT,CNTLRAS)=0
F S LRDFN=$O(^LR(LRDFN)) Q:LRDFN<1 D
. S LRIDT=0
. F S LRIDT=$O(^LR(LRDFN,"MI",LRIDT)) Q:LRIDT<1 D
.. S CNTLRAS=CNTLRAS+1
.. I (CNTLRAS#100)=0 W "." W:$X>74 !,?4 ; "Warm fuzzy"
.. ;
.. S DTSPMTKN=+$P($$GET1^DIQ(63.05,LRIDT_","_LRDFN,.01,"I"),".") ; Date Specimen Taken
.. Q:DTSPMTKN<LRSDT!(DTSPMTKN>LRLDT)
.. ;
.. S LRDIEN=LRIDT_","_LRDFN
.. ;
.. S RPTDTAPP=+$$GET1^DIQ(63.05,LRDIEN,11,"I") ; BACT RPT DATE APPROVED
.. Q:RPTDTAPP<1
.. ;
.. S WARD=$$GET1^DIQ(63.05,LRDIEN,.08)
.. Q:WARD'=ORDLOCA
.. ;
.. S ^TMP("BLRMIIBL",$J,RPTDTAPP,LRDFN,LRIDT)=""
.. S CNT=CNT+1
Q
;
LDATARPT ; EP - Report from Lab Data compilation
S RPTDTAPP="A",QFLG="NO",(LRFOOT,LRSTOP)=0
F S RPTDTAPP=$O(^TMP("BLRMIIBL",$J,RPTDTAPP),-1) Q:RPTDTAPP<1!(QFLG="Q")!(LRSTOP) D
. S LRDFN=0
. F S LRDFN=$O(^TMP("BLRMIIBL",$J,RPTDTAPP,LRDFN)) Q:LRDFN<1!(QFLG="Q")!(LRSTOP) D
.. S LRIDT=0
.. F S LRIDT=$O(^TMP("BLRMIIBL",$J,RPTDTAPP,LRDFN,LRIDT)) Q:LRIDT<1!(QFLG="Q")!(LRSTOP) D
... D LDMIRPT(LRDFN,LRIDT,.LRSTOP)
Q
;
LDMIRPT(LRDFN,LRIDT,LRSTOP) ; EP - Setup & Call Interim Report Routines
NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRDFN,LRIDT,LRSTOP,U,XPARSYS,XQXFLG)
S LRSS="MI"
;
D PT^LRX
S (LRFOOT,LRSTOP)=0
S (LRONESPC,LRONETST)=""
W @IOF
D MI^LRRP2
Q
BLRMIIBL ; IHS/MSC/MKK - MIcro Interim report by Location ; 15-Apr-2016 15:41 ; MKK
+1 ;;5.2;LAB SERVICE;**1039**;NOV 01, 1997;Build 38
+2 ;
EEP ; Ersatz EP
+1 DO EEP^BLRGMENU
+2 QUIT
+3 ;
+4 ;
EP ; EP
PEP ; EP
+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)="Micro Interim Report by Location"
+4 DO HEADERDT^BLRGMENU
+5 ;
+6 DO ^XBFMK
+7 SET DIR(0)="PO^44:EMZ"
+8 DO ^DIR
+9 IF +$GET(DIRUT)!(+Y<1)
DO BADSTUFF^BLRUTIL7("No/Invalid Entry.")
QUIT
+10 ;
+11 SET ORDLOC=Y
+12 ; Abbreviation
SET ORDLOCA=$$GET1^DIQ(44,+ORDLOC,1)
+13 ;
+14 SET HEADER(2)="Location:"_$PIECE(ORDLOC,U,2)
+15 ;
+16 DO HEADERDT^BLRGMENU
+17 DO B^LRU
+18 IF $GET(LRSDT)<1!($GET(LRLDT)<1)
DO BADSTUFF^BLRUTIL7("Invalid Date Range.")
QUIT
+19 ;
+20 SET HEADER(3)=$$CJ^XLFSTR("Date Range: "_$$FMTE^XLFDT(LRSDT,"5DZ")_" thru "_$$FMTE^XLFDT(LRLDT,"5DZ"),IOM)
+21 ;
+22 KILL ^TMP("BLRMIIBL",$JOB)
+23 ;
+24 WRITE !!,?4,"Compiling Data"
+25 ;
+26 DO LDATACOM
+27 ;
+28 WRITE !!,?4,"Compilation Complete."
+29 WRITE !!,?9,CNTLRAS," MI Accessions analyzed."
+30 WRITE !!,?14,CNT," MI Accessions with ",$PIECE(ORDLOC,U,2)," Ward.",!!
+31 ;
+32 DO ^XBFMK
+33 SET DIR(0)="YO"
+34 SET DIR("A")="Produce Report (Y/N)"
+35 DO ^DIR
+36 IF +$GET(DIRUT)!(+Y<1)
Begin DoDot:1
+37 DO BADSTUFF^BLRUTIL7("No/Invalid Entry.")
+38 KILL ^TMP("BLRMIIBL",$JOB)
End DoDot:1
QUIT
+39 ;
+40 DO ^%ZIS
+41 USE IO
+42 DO LDATARPT
+43 DO ^%ZISC
+44 ;
+45 DO PRESSKEY^BLRGMENU(9)
+46 KILL ^TMP("BLRMIIBL",$JOB)
+47 QUIT
+48 ;
LDATACOM ; EP - Compile from the Lab Data file
+1 SET LRDFN=.9999999
SET (CNT,CNTLRAS)=0
+2 FOR
SET LRDFN=$ORDER(^LR(LRDFN))
IF LRDFN<1
QUIT
Begin DoDot:1
+3 SET LRIDT=0
+4 FOR
SET LRIDT=$ORDER(^LR(LRDFN,"MI",LRIDT))
IF LRIDT<1
QUIT
Begin DoDot:2
+5 SET CNTLRAS=CNTLRAS+1
+6 ; "Warm fuzzy"
IF (CNTLRAS#100)=0
WRITE "."
IF $X>74
WRITE !,?4
+7 ;
+8 ; Date Specimen Taken
SET DTSPMTKN=+$PIECE($$GET1^DIQ(63.05,LRIDT_","_LRDFN,.01,"I"),".")
+9 IF DTSPMTKN<LRSDT!(DTSPMTKN>LRLDT)
QUIT
+10 ;
+11 SET LRDIEN=LRIDT_","_LRDFN
+12 ;
+13 ; BACT RPT DATE APPROVED
SET RPTDTAPP=+$$GET1^DIQ(63.05,LRDIEN,11,"I")
+14 IF RPTDTAPP<1
QUIT
+15 ;
+16 SET WARD=$$GET1^DIQ(63.05,LRDIEN,.08)
+17 IF WARD'=ORDLOCA
QUIT
+18 ;
+19 SET ^TMP("BLRMIIBL",$JOB,RPTDTAPP,LRDFN,LRIDT)=""
+20 SET CNT=CNT+1
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
LDATARPT ; EP - Report from Lab Data compilation
+1 SET RPTDTAPP="A"
SET QFLG="NO"
SET (LRFOOT,LRSTOP)=0
+2 FOR
SET RPTDTAPP=$ORDER(^TMP("BLRMIIBL",$JOB,RPTDTAPP),-1)
IF RPTDTAPP<1!(QFLG="Q")!(LRSTOP)
QUIT
Begin DoDot:1
+3 SET LRDFN=0
+4 FOR
SET LRDFN=$ORDER(^TMP("BLRMIIBL",$JOB,RPTDTAPP,LRDFN))
IF LRDFN<1!(QFLG="Q")!(LRSTOP)
QUIT
Begin DoDot:2
+5 SET LRIDT=0
+6 FOR
SET LRIDT=$ORDER(^TMP("BLRMIIBL",$JOB,RPTDTAPP,LRDFN,LRIDT))
IF LRIDT<1!(QFLG="Q")!(LRSTOP)
QUIT
Begin DoDot:3
+7 DO LDMIRPT(LRDFN,LRIDT,.LRSTOP)
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
LDMIRPT(LRDFN,LRIDT,LRSTOP) ; EP - Setup & Call Interim Report Routines
+1 NEW (DILOCKTM,DISYS,DT,DTIME,DUZ,IO,IOBS,IOF,IOM,ION,IOS,IOSL,IOST,IOT,IOXY,LRDFN,LRIDT,LRSTOP,U,XPARSYS,XQXFLG)
+2 SET LRSS="MI"
+3 ;
+4 DO PT^LRX
+5 SET (LRFOOT,LRSTOP)=0
+6 SET (LRONESPC,LRONETST)=""
+7 WRITE @IOF
+8 DO MI^LRRP2
+9 QUIT
