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
