BLRMIIBL.m

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