BEXRSRT.m

BEXRSRT ; cmi/anch/maw - BEX SORT PATIENTS AND DATE 4/6/95 ; 12 Mar 2012  4:22 PM

 ;;1.0;BEX TELEPHONE REFILL SYSTEM;**1,2,3,4,5**;MAR 12, 2012;Build 1

 ;This routine optimizes sorting for

 ;option BEX TRANSACTIONS BY PATIENT.

 ;After sorting, it calls routine ^BEXRPAT, which is a compilation

 ;of print template [BEX TRANSACTIONS BY PATIENT].

 ;

 ;cmi/anch/maw 2/1/2007 patch 3 added check of piece 10 for DUZ(2)

 ;IHS/CMI/DAY - 4/28/2010 - patch 4 - allow time in sort

 ;IHS/CMI/DAY - 4/28/2010 - patch 4 - limit to one site

 ;IHS/CMI/DAY - 7/26/2011 - patch 5 - Fix if no RX# in Tran Global

 ;

MAIN ;MAIN DRIVER SUBROUTINE

 N BEX,%DT,X,Y,DTOUT

 S DTIME=$S($D(DTIME):DTIME,1:180),U="^",BEX("OUT")=0

 D ASKDATE

 Q:$D(DTOUT)!(Y=-1)  ;QUIT IF TIMEOUT, "^", OR INVALID DATE

 ;IHS/CMI/DAY - Add question to limit by site (4/28/2010)

 D ASKSITE

 I BEX("OUT")=1 Q

 D DEVICE Q:BEX("OUT")

MAINDQ ;ENTRY POINT FOR TASKMAN WHEN PRINTOUT IS QUEUED

 D SORT Q:BEX("OUT")

 D PRT

 I $D(ZTQUEUED) S ZTREQ="@" D ^%ZISC K BEX

 I '$D(ZTQUEUED) D ^%ZISC D HOME^%ZIS

 ;I $D(ZTQUEUED) D

 ;.S ZTREQ="@" D ^%ZISC K BEX

 ;E  D

 ;.D HOME^%ZIS

 ;IHS/PIMC/WAR 10/20/06 End mod

 D ^%ZISC  ;cmi/maw 6/12/2006 added for device close

 K ^TMP($J)

 Q

ASKDATE ;GET BEGINNING AND ENDING DATES

 ;IHS/CMI/DAY - Patch 4 - Add T to allow entry of time

 S %DT="AEXT"

 D ASKDATE1 Q:$D(DTOUT)!(Y=-1)

 D ASKDATE2

 Q

ASKDATE1 ;GET BEGINNING DATE

 S BEX("BEGIN")=$O(^VEXHRX0(19080.1,"C",0)),BEX("BEGIN")=$P(BEX("BEGIN"),".")

 S Y=BEX("BEGIN") D DD^%DT

 ;cmi/anch/maw 7/22/2007 new lines for default date patch 3

 S X1=DT,X2=-10 D C^%DTC

 S Y=X D DD^%DT

 ;cmi/anch/maw end of mods patch 3

 ;S %DT("B")=Y,%DT("A")="BEGIN WITH DATE: " D ^%DT  cmi/anch/maw 7/23/2007 orig line patch 3

 S %DT("B")=Y,%DT("A")="BEGIN WITH DATE: " D ^%DT  ;cmi/anch/maw 7/23/2007 new line for default date patch 3

 ;IHS/CMI/DAY - Patch 4 - Allow begin time to be used

 ;S BEX("BEGIN")=$P(Y,".")

 S BEX("BEGIN")=Y

 Q

ASKDATE2 ;GET ENDING DATE

 S BEX("END")=$O(^VEXHRX0(19080.1,"C","ZZZ"),-1)

 S BEX("END")=$P(BEX("END"),".")

 ;IHS/CMI/DAY - Patch 5 - Make sure End Date default is later than Begin Date

 I BEX("END")<BEX("BEGIN") S BEX("END")=BEX("BEGIN")

 ;

 S Y=BEX("END") D DD^%DT

 S %DT(0)=BEX("BEGIN"),%DT("B")=Y,%DT("A")="END WITH DATE: "

 D ^%DT

 ;IHS/CMI/DAY - Patch 4 - Allow End date to use Time

 S BEX("END")=Y

 I $P(Y,".",2)="" S BEX("END")=$P(Y,".")_"."_235959

 Q

 ;

ASKSITE ;EP - Ask to limit by site

 K DIR

 S DIR("A")="Limit to transactions for "_$P($G(^DIC(4,DUZ(2),0)),U)

 S DIR("B")="Y"

 S DIR(0)="YO"

 D ^DIR

 K DIR

 I $D(DIRUT) S BEX("OUT")=1

 I Y=0 S BEXALL=0

 I Y=1 S BEXALL=1

 Q

 ;

DEVICE ;DEVICE SELECTION

 K IO("Q"),ZTSK,ZTQUEUED

 S %ZIS="QML" D ^%ZIS I POP S BEX("OUT")=1 Q

 I $D(IO("Q")) D  Q

 . S ZTRTN="MAINDQ^BEXRSRT"

 . S ZTDESC="BEXR DHCP REFILL TRANSACTIONS BY PATIENT"

 . S ZTSAVE("BEX*")=""

 . S ZTSAVE("DTIME")=""

 . D ^%ZTLOAD

 . K IO("Q")

 . I $D(ZTSK) D  ;

 . .  W !,"REQUEST QUEUED!"

 . .  W !,"Task number: ",ZTSK,!

 . S BEX("OUT")=1

 Q

SORT ;SORT ENTRIES TO BE PRINTED

 ;THIS SUBROUTINE BUILDS TEMPORARY GLOBAL ^TMP($J, IN CORRECT SORT ORDER

 K ^TMP($J) I $E(IOST,1,2)="C-" W !,"Sorting "

 S BEX("DATE")=$O(^VEXHRX0(19080.1,"C",BEX("BEGIN")),-1),BEX("D0")=""

 F  S BEX("DATE")=$O(^VEXHRX0(19080.1,"C",BEX("DATE"))) Q:BEX("DATE")=""!(BEX("DATE")>BEX("END"))  D  ;

 . F  S BEX("D0")=$O(^VEXHRX0(19080.1,"C",BEX("DATE"),BEX("D0"))) Q:BEX("D0")=""  D  ;

 .. Q:BEX("DATE")<BEX("BEGIN")  ;maw to screen out date with 0 timestamp

 . .  S BEX("NAME")=$P($G(^VEXHRX0(19080.1,BEX("D0"),0)),U)

 . .  S BEX("RX")=$P($G(^VEXHRX0(19080.1,BEX("D0"),0)),U,3)

 . .  ;cmi/anch/maw 2/1/2007 added next 3 lines to screen report by site

 . .  N BEXSITE

 . .  S BEXSITE=$P($G(^VEXHRX0(19080.1,BEX("D0"),0)),U,10)

 . .  I $G(BEXALL)=1 Q:BEXSITE'=DUZ(2)  ;screen out patients not at this site added $G for patch 3 7/19/2007

 . .  K BEX("MED")

 . . ;IHS/CMI/DAY - Patch 5 - fix if no RX # in Tran Global

 . .  S BEX("MED")="None"

 . .  I $G(BEX("RX")) D

 . . . N BEXRXI

 . . . S BEXRXI=$O(^PSRX("B",BEX("RX"),0))

 . . . Q:'BEXRXI

 . . . S BEX("MED")=$$GET1^DIQ(52,BEXRXI,6)

 . .  S BEX("DFN")=BEX("NAME")

 . .  Q:BEX("NAME")=""

 . .  S BEX("FOUND")=0

 . .  ;get info from ^TMP($J, if possible

 . .  I $G(^TMP($J,BEX("DFN")))'="" D  ;

 . . .   S BEX("NAME")=^TMP($J,BEX("DFN"))

 . . .   S BEX("SSN")=$P(BEX("NAME"),U,2),BEX("NAME")=$P(BEX("NAME"),U)

 . . .   S BEX("FOUND")=1

 . .  ;get info from ^DPT if you don't have it in ^TMP

 . .  I 'BEX("FOUND") D  ;

 . . .   S BEX("DPT")=$G(^DPT(BEX("NAME"),0))

 . . .   ;S BEX("SSN")=$P(BEX("DPT"),U,9)

 . . .   S BEX("SSN")=$$HRN^AUPNPAT(BEX("DFN"),DUZ(2))  ;cmi/maw 9/12/2002

 . . .   I BEX("SSN")="" S BEX("SSN")="N/A"

 . . .   S BEX("NAME")=$P(BEX("DPT"),U)

 . . .   S ^TMP($J,BEX("DFN"))=BEX("NAME")_U_BEX("SSN")_U_BEX("MED")

 . . .   I $E(IOST,1,2)="C-" W "."

 . .  Q:BEX("NAME")=""

 . .  S ^TMP($J,BEX("NAME"),BEX("SSN"),+BEX("DATE"),BEX("D0"))=BEX("MED")

 I '$D(^TMP($J)) S BEX("OUT")=1

 I BEX("OUT"),$E(IOST,1,2)="C-" W !,*7,"NO RECORDS IN SPECIFIED RANGE!" H 1

 Q

PRT ;PRINT REPORT

 ;This subroutine loops through ^TMP($J, and calls

 ;compiled print template routine ^BEXRPAT.

 U IO  ;cmi/maw added 6/9/2006 not printing to device only screen

 N D0,DXS,DC,N

 S (BEX("TOTAL"),BEX("PATTOT"))=0,BEX=""

 D NOW^%DTC S $P(%,".",2)=$E($P(%,".",2),1,4),BEX("HEADDATE")=%

 S Y=BEX("HEADDATE") D DD^%DT S BEX("HEADDATE")=$TR(Y,"@"," ")

 S BEX("HEAD")=$O(^DIPT("B","BEX TRANSACTIONS BY PATIENT",0))

 S BEX("HEAD")=$G(^DIPT(BEX("HEAD"),"H"))

 Q:BEX("HEAD")=""

 S DC=0,N(1)=1,BEX("LINE")=0

 S BEX("NAME")="@",(BEX("DATE"),BEX("D0"),BEX("SSN"),BEX("LASTSSN"),BEX("MED"))=""

 S BEX("NAME")=$O(^TMP($J,BEX("NAME")))

 S BEX("LASTSSN")=$O(^TMP($J,BEX("NAME"),BEX("LASTSSN"))),BEX("NAME")="@"

PRT2 ;BEGINNING OF PRINTING LOOP

 D PRTHEAD

 F  S BEX("NAME")=$O(^TMP($J,BEX("NAME"))) Q:BEX("NAME")=""!(BEX("OUT"))  D  ;

 . F  S BEX("SSN")=$O(^TMP($J,BEX("NAME"),BEX("SSN"))) Q:BEX("SSN")=""!(BEX("OUT"))  D  ;

 . .  I BEX("SSN")'=BEX("LASTSSN") D PRTTOTP S BEX("LASTSSN")=BEX("SSN")

 . .  F  S BEX("DATE")=$O(^TMP($J,BEX("NAME"),BEX("SSN"),BEX("DATE"))) Q:BEX("DATE")=""!(BEX("OUT"))  D  ;

 . . .   F  S BEX("D0")=$O(^TMP($J,BEX("NAME"),BEX("SSN"),BEX("DATE"),BEX("D0"))) Q:BEX("D0")=""!(BEX("OUT"))  D  ;

 . . . .    I BEX("LINE")>(+IOSL-4) D PRTHEAD

 . . . .    S BEX("MED")=$G(^TMP($J,BEX("NAME"),BEX("SSN"),BEX("DATE"),BEX("D0")))

 . . . .    S D0=BEX("D0") W ! D ^BEXRPAT

 . . . .    S BEX("LINE")=BEX("LINE")+1

 . . . .    S BEX("PATTOT")=BEX("PATTOT")+1,BEX("TOTAL")=BEX("TOTAL")+1

 I 'BEX("OUT") D PRTTOTP,PRTOTAL

 E  I $E(IOST,1,2)="C-" W !,*7,"Exiting report." H 1

 Q

PRTHEAD ;PRINT PAGE HEADING

 ;IHS/CMI/DAY - Changed following read to use DIR

 I $E(IOST,1,2)="C-",DC'=0 K DIR S DIR(0)="E" D ^DIR K DIR

 I $E(X)="^" S BEX("OUT")=1 Q

 I $E(X)="?" G PRTHEAD

 I DC>0!($E(IOST,1,2)="C-") W #

 S DC=DC+1,BEX("LINE")=0

 W !,BEX("HEAD"),?53,BEX("HEADDATE")," PAGE ",DC,!

 D HEAD^BEXRPAT

 S BEX("LINE")=BEX("LINE")+9

 Q

PRTTOTP ;PRINT TOTAL TRANSACTIONS FOR A PATIENT

 ;W !,?8,"Total transactions for patient = ",BEX("PATTOT"),!  ;cmi/maw 9/26/2006 not wanted

 S BEX("PATTOT")=0  ;,BEX("LINE")=BEX("LINE")+2  ;cmi/anch/maw 8/16/2007 patch 3

 Q

PRTOTAL ;PRINT TOTAL TRANSACTIONS FOR REPORT

 S BEX("END")=$P(BEX("END"),".")

 S BEX("BEGIN")=$E(BEX("BEGIN"),4,5)_"/"_$E(BEX("BEGIN"),6,7)_"/"_$E(BEX("BEGIN"),2,3)

 S BEX("END")=$E(BEX("END"),4,5)_"/"_$E(BEX("END"),6,7)_"/"_$E(BEX("END"),2,3)

 W !,?8,"Total transactions for date range ",BEX("BEGIN")," through ",BEX("END")," = ",BEX("TOTAL")

 Q

BEXRSRT   ; cmi/anch/maw - BEX SORT PATIENTS AND DATE 4/6/95 ; 12 Mar 2012  4:22 PM

 +1       ;;1.0;BEX TELEPHONE REFILL SYSTEM;**1,2,3,4,5**;MAR 12, 2012;Build 1

 +2       ;This routine optimizes sorting for

 +3       ;option BEX TRANSACTIONS BY PATIENT.

 +4       ;After sorting, it calls routine ^BEXRPAT, which is a compilation

 +5       ;of print template [BEX TRANSACTIONS BY PATIENT].

 +6       ;

 +7       ;cmi/anch/maw 2/1/2007 patch 3 added check of piece 10 for DUZ(2)

 +8       ;IHS/CMI/DAY - 4/28/2010 - patch 4 - allow time in sort

 +9       ;IHS/CMI/DAY - 4/28/2010 - patch 4 - limit to one site

 +10      ;IHS/CMI/DAY - 7/26/2011 - patch 5 - Fix if no RX# in Tran Global

 +11      ;

MAIN      ;MAIN DRIVER SUBROUTINE

 +1        NEW BEX,%DT,X,Y,DTOUT

 +2        SET DTIME=$SELECT($DATA(DTIME):DTIME,1:180)

           SET U="^"

           SET BEX("OUT")=0

 +3        DO ASKDATE

 +4       ;QUIT IF TIMEOUT, "^", OR INVALID DATE

           IF $DATA(DTOUT)!(Y=-1)

               QUIT 

 +5       ;IHS/CMI/DAY - Add question to limit by site (4/28/2010)

 +6        DO ASKSITE

 +7        IF BEX("OUT")=1

               QUIT 

 +8        DO DEVICE

           IF BEX("OUT")

               QUIT 

MAINDQ    ;ENTRY POINT FOR TASKMAN WHEN PRINTOUT IS QUEUED

 +1        DO SORT

           IF BEX("OUT")

               QUIT 

 +2        DO PRT

 +3        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

               DO ^%ZISC

               KILL BEX

 +4        IF '$DATA(ZTQUEUED)

               DO ^%ZISC

               DO HOME^%ZIS

 +5       ;I $D(ZTQUEUED) D

 +6       ;.S ZTREQ="@" D ^%ZISC K BEX

 +7       ;E  D

 +8       ;.D HOME^%ZIS

 +9       ;IHS/PIMC/WAR 10/20/06 End mod

 +10      ;cmi/maw 6/12/2006 added for device close

           DO ^%ZISC

 +11       KILL ^TMP($JOB)

 +12       QUIT 

ASKDATE   ;GET BEGINNING AND ENDING DATES

 +1       ;IHS/CMI/DAY - Patch 4 - Add T to allow entry of time

 +2        SET %DT="AEXT"

 +3        DO ASKDATE1

           IF $DATA(DTOUT)!(Y=-1)

               QUIT 

 +4        DO ASKDATE2

 +5        QUIT 

ASKDATE1  ;GET BEGINNING DATE

 +1        SET BEX("BEGIN")=$ORDER(^VEXHRX0(19080.1,"C",0))

           SET BEX("BEGIN")=$PIECE(BEX("BEGIN"),".")

 +2        SET Y=BEX("BEGIN")

           DO DD^%DT

 +3       ;cmi/anch/maw 7/22/2007 new lines for default date patch 3

 +4        SET X1=DT

           SET X2=-10

           DO C^%DTC

 +5        SET Y=X

           DO DD^%DT

 +6       ;cmi/anch/maw end of mods patch 3

 +7       ;S %DT("B")=Y,%DT("A")="BEGIN WITH DATE: " D ^%DT  cmi/anch/maw 7/23/2007 orig line patch 3

 +8       ;cmi/anch/maw 7/23/2007 new line for default date patch 3

           SET %DT("B")=Y

           SET %DT("A")="BEGIN WITH DATE: "

           DO ^%DT

 +9       ;IHS/CMI/DAY - Patch 4 - Allow begin time to be used

 +10      ;S BEX("BEGIN")=$P(Y,".")

 +11       SET BEX("BEGIN")=Y

 +12       QUIT 

ASKDATE2  ;GET ENDING DATE

 +1        SET BEX("END")=$ORDER(^VEXHRX0(19080.1,"C","ZZZ"),-1)

 +2        SET BEX("END")=$PIECE(BEX("END"),".")

 +3       ;IHS/CMI/DAY - Patch 5 - Make sure End Date default is later than Begin Date

 +4        IF BEX("END")<BEX("BEGIN")

               SET BEX("END")=BEX("BEGIN")

 +5       ;

 +6        SET Y=BEX("END")

           DO DD^%DT

 +7        SET %DT(0)=BEX("BEGIN")

           SET %DT("B")=Y

           SET %DT("A")="END WITH DATE: "

 +8        DO ^%DT

 +9       ;IHS/CMI/DAY - Patch 4 - Allow End date to use Time

 +10       SET BEX("END")=Y

 +11       IF $PIECE(Y,".",2)=""

               SET BEX("END")=$PIECE(Y,".")_"."_235959

 +12       QUIT 

 +13      ;

ASKSITE   ;EP - Ask to limit by site

 +1        KILL DIR

 +2        SET DIR("A")="Limit to transactions for "_$PIECE($GET(^DIC(4,DUZ(2),0)),U)

 +3        SET DIR("B")="Y"

 +4        SET DIR(0)="YO"

 +5        DO ^DIR

 +6        KILL DIR

 +7        IF $DATA(DIRUT)

               SET BEX("OUT")=1

 +8        IF Y=0

               SET BEXALL=0

 +9        IF Y=1

               SET BEXALL=1

 +10       QUIT 

 +11      ;

DEVICE    ;DEVICE SELECTION

 +1        KILL IO("Q"),ZTSK,ZTQUEUED

 +2        SET %ZIS="QML"

           DO ^%ZIS

           IF POP

               SET BEX("OUT")=1

               QUIT 

 +3        IF $DATA(IO("Q"))

               Begin DoDot:1

 +4                SET ZTRTN="MAINDQ^BEXRSRT"

 +5                SET ZTDESC="BEXR DHCP REFILL TRANSACTIONS BY PATIENT"

 +6                SET ZTSAVE("BEX*")=""

 +7                SET ZTSAVE("DTIME")=""

 +8                DO ^%ZTLOAD

 +9                KILL IO("Q")

 +10      ;

                   IF $DATA(ZTSK)

                       Begin DoDot:2

 +11                       WRITE !,"REQUEST QUEUED!"

 +12                       WRITE !,"Task number: ",ZTSK,!

                       End DoDot:2

 +13               SET BEX("OUT")=1

               End DoDot:1

               QUIT 

 +14       QUIT 

SORT      ;SORT ENTRIES TO BE PRINTED

 +1       ;THIS SUBROUTINE BUILDS TEMPORARY GLOBAL ^TMP($J, IN CORRECT SORT ORDER

 +2        KILL ^TMP($JOB)

           IF $EXTRACT(IOST,1,2)="C-"

               WRITE !,"Sorting "

 +3        SET BEX("DATE")=$ORDER(^VEXHRX0(19080.1,"C",BEX("BEGIN")),-1)

           SET BEX("D0")=""

 +4       ;

           FOR 

               SET BEX("DATE")=$ORDER(^VEXHRX0(19080.1,"C",BEX("DATE")))

               IF BEX("DATE")=""!(BEX("DATE")>BEX("END"))

                   QUIT 

               Begin DoDot:1

 +5       ;

                   FOR 

                       SET BEX("D0")=$ORDER(^VEXHRX0(19080.1,"C",BEX("DATE"),BEX("D0")))

                       IF BEX("D0")=""

                           QUIT 

                       Begin DoDot:2

 +6       ;maw to screen out date with 0 timestamp

                           IF BEX("DATE")<BEX("BEGIN")

                               QUIT 

 +7                        SET BEX("NAME")=$PIECE($GET(^VEXHRX0(19080.1,BEX("D0"),0)),U)

 +8                        SET BEX("RX")=$PIECE($GET(^VEXHRX0(19080.1,BEX("D0"),0)),U,3)

 +9       ;cmi/anch/maw 2/1/2007 added next 3 lines to screen report by site

 +10                       NEW BEXSITE

 +11                       SET BEXSITE=$PIECE($GET(^VEXHRX0(19080.1,BEX("D0"),0)),U,10)

 +12      ;screen out patients not at this site added $G for patch 3 7/19/2007

                           IF $GET(BEXALL)=1

                               IF BEXSITE'=DUZ(2)

                                   QUIT 

 +13                       KILL BEX("MED")

 +14      ;IHS/CMI/DAY - Patch 5 - fix if no RX # in Tran Global

 +15                       SET BEX("MED")="None"

 +16                       IF $GET(BEX("RX"))

                               Begin DoDot:3

 +17                               NEW BEXRXI

 +18                               SET BEXRXI=$ORDER(^PSRX("B",BEX("RX"),0))

 +19                               IF 'BEXRXI

                                       QUIT 

 +20                               SET BEX("MED")=$$GET1^DIQ(52,BEXRXI,6)

                               End DoDot:3

 +21                       SET BEX("DFN")=BEX("NAME")

 +22                       IF BEX("NAME")=""

                               QUIT 

 +23                       SET BEX("FOUND")=0

 +24      ;get info from ^TMP($J, if possible

 +25      ;

                           IF $GET(^TMP($JOB,BEX("DFN")))'=""

                               Begin DoDot:3

 +26                               SET BEX("NAME")=^TMP($JOB,BEX("DFN"))

 +27                               SET BEX("SSN")=$PIECE(BEX("NAME"),U,2)

                                   SET BEX("NAME")=$PIECE(BEX("NAME"),U)

 +28                               SET BEX("FOUND")=1

                               End DoDot:3

 +29      ;get info from ^DPT if you don't have it in ^TMP

 +30      ;

                           IF 'BEX("FOUND")

                               Begin DoDot:3

 +31                               SET BEX("DPT")=$GET(^DPT(BEX("NAME"),0))

 +32      ;S BEX("SSN")=$P(BEX("DPT"),U,9)

 +33      ;cmi/maw 9/12/2002

                                   SET BEX("SSN")=$$HRN^AUPNPAT(BEX("DFN"),DUZ(2))

 +34                               IF BEX("SSN")=""

                                       SET BEX("SSN")="N/A"

 +35                               SET BEX("NAME")=$PIECE(BEX("DPT"),U)

 +36                               SET ^TMP($JOB,BEX("DFN"))=BEX("NAME")_U_BEX("SSN")_U_BEX("MED")

 +37                               IF $EXTRACT(IOST,1,2)="C-"

                                       WRITE "."

                               End DoDot:3

 +38                       IF BEX("NAME")=""

                               QUIT 

 +39                       SET ^TMP($JOB,BEX("NAME"),BEX("SSN"),+BEX("DATE"),BEX("D0"))=BEX("MED")

                       End DoDot:2

               End DoDot:1

 +40       IF '$DATA(^TMP($JOB))

               SET BEX("OUT")=1

 +41       IF BEX("OUT")

               IF $EXTRACT(IOST,1,2)="C-"

                   WRITE !,*7,"NO RECORDS IN SPECIFIED RANGE!"

                   HANG 1

 +42       QUIT 

PRT       ;PRINT REPORT

 +1       ;This subroutine loops through ^TMP($J, and calls

 +2       ;compiled print template routine ^BEXRPAT.

 +3       ;cmi/maw added 6/9/2006 not printing to device only screen

           USE IO

 +4        NEW D0,DXS,DC,N

 +5        SET (BEX("TOTAL"),BEX("PATTOT"))=0

           SET BEX=""

 +6        DO NOW^%DTC

           SET $PIECE(%,".",2)=$EXTRACT($PIECE(%,".",2),1,4)

           SET BEX("HEADDATE")=%

 +7        SET Y=BEX("HEADDATE")

           DO DD^%DT

           SET BEX("HEADDATE")=$TRANSLATE(Y,"@"," ")

 +8        SET BEX("HEAD")=$ORDER(^DIPT("B","BEX TRANSACTIONS BY PATIENT",0))

 +9        SET BEX("HEAD")=$GET(^DIPT(BEX("HEAD"),"H"))

 +10       IF BEX("HEAD")=""

               QUIT 

 +11       SET DC=0

           SET N(1)=1

           SET BEX("LINE")=0

 +12       SET BEX("NAME")="@"

           SET (BEX("DATE"),BEX("D0"),BEX("SSN"),BEX("LASTSSN"),BEX("MED"))=""

 +13       SET BEX("NAME")=$ORDER(^TMP($JOB,BEX("NAME")))

 +14       SET BEX("LASTSSN")=$ORDER(^TMP($JOB,BEX("NAME"),BEX("LASTSSN")))

           SET BEX("NAME")="@"

PRT2      ;BEGINNING OF PRINTING LOOP

 +1        DO PRTHEAD

 +2       ;

           FOR 

               SET BEX("NAME")=$ORDER(^TMP($JOB,BEX("NAME")))

               IF BEX("NAME")=""!(BEX("OUT"))

                   QUIT 

               Begin DoDot:1

 +3       ;

                   FOR 

                       SET BEX("SSN")=$ORDER(^TMP($JOB,BEX("NAME"),BEX("SSN")))

                       IF BEX("SSN")=""!(BEX("OUT"))

                           QUIT 

                       Begin DoDot:2

 +4                        IF BEX("SSN")'=BEX("LASTSSN")

                               DO PRTTOTP

                               SET BEX("LASTSSN")=BEX("SSN")

 +5       ;

                           FOR 

                               SET BEX("DATE")=$ORDER(^TMP($JOB,BEX("NAME"),BEX("SSN"),BEX("DATE")))

                               IF BEX("DATE")=""!(BEX("OUT"))

                                   QUIT 

                               Begin DoDot:3

 +6       ;

                                   FOR 

                                       SET BEX("D0")=$ORDER(^TMP($JOB,BEX("NAME"),BEX("SSN"),BEX("DATE"),BEX("D0")))

                                       IF BEX("D0")=""!(BEX("OUT"))

                                           QUIT 

                                       Begin DoDot:4

 +7                                        IF BEX("LINE")>(+IOSL-4)

                                               DO PRTHEAD

 +8                                        SET BEX("MED")=$GET(^TMP($JOB,BEX("NAME"),BEX("SSN"),BEX("DATE"),BEX("D0")))

 +9                                        SET D0=BEX("D0")

                                           WRITE !

                                           DO ^BEXRPAT

 +10                                       SET BEX("LINE")=BEX("LINE")+1

 +11                                       SET BEX("PATTOT")=BEX("PATTOT")+1

                                           SET BEX("TOTAL")=BEX("TOTAL")+1

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +12       IF 'BEX("OUT")

               DO PRTTOTP

               DO PRTOTAL

 +13      IF '$TEST

               IF $EXTRACT(IOST,1,2)="C-"

                   WRITE !,*7,"Exiting report."

                   HANG 1

 +14       QUIT 

PRTHEAD   ;PRINT PAGE HEADING

 +1       ;IHS/CMI/DAY - Changed following read to use DIR

 +2        IF $EXTRACT(IOST,1,2)="C-"

               IF DC'=0

                   KILL DIR

                   SET DIR(0)="E"

                   DO ^DIR

                   KILL DIR

 +3        IF $EXTRACT(X)="^"

               SET BEX("OUT")=1

               QUIT 

 +4        IF $EXTRACT(X)="?"

               GOTO PRTHEAD

 +5        IF DC>0!($EXTRACT(IOST,1,2)="C-")

               WRITE #

 +6        SET DC=DC+1

           SET BEX("LINE")=0

 +7        WRITE !,BEX("HEAD"),?53,BEX("HEADDATE")," PAGE ",DC,!

 +8        DO HEAD^BEXRPAT

 +9        SET BEX("LINE")=BEX("LINE")+9

 +10       QUIT 

PRTTOTP   ;PRINT TOTAL TRANSACTIONS FOR A PATIENT

 +1       ;W !,?8,"Total transactions for patient = ",BEX("PATTOT"),!  ;cmi/maw 9/26/2006 not wanted

 +2       ;,BEX("LINE")=BEX("LINE")+2  ;cmi/anch/maw 8/16/2007 patch 3

           SET BEX("PATTOT")=0

 +3        QUIT 

PRTOTAL   ;PRINT TOTAL TRANSACTIONS FOR REPORT

 +1        SET BEX("END")=$PIECE(BEX("END"),".")

 +2        SET BEX("BEGIN")=$EXTRACT(BEX("BEGIN"),4,5)_"/"_$EXTRACT(BEX("BEGIN"),6,7)_"/"_$EXTRACT(BEX("BEGIN"),2,3)

 +3        SET BEX("END")=$EXTRACT(BEX("END"),4,5)_"/"_$EXTRACT(BEX("END"),6,7)_"/"_$EXTRACT(BEX("END"),2,3)

 +4        WRITE !,?8,"Total transactions for date range ",BEX("BEGIN")," through ",BEX("END")," = ",BEX("TOTAL")

 +5        QUIT