BEXRREJ ;IHS/CMI/DAY - BEX - Refill Rejections Percentage Report ; 12 Mar 2012 7:15 PM
;;1.0;BEX TELEPHONE REFILL SYSTEM;**4,5**;MAR 12, 2012;Build 1
;
;Prints the Refill Rejections Percentage Report
;
W #
;
W !,"Refill Rejections Percentage Report"
W !
W !,"This option prints a list of Transactions that were processed within"
W !,"a selected date/time range."
W !
;
K BEXDIV
S BEXDIV=0
S BEXSITE=0
S BEXQUIT=0
;
W !,"Press Enter to select ALL Pharmacy Divisions, or"
F D Q:BEXQUIT=1
.K DIC,DIR,DIE,DA,DR,DO,DD
.S DIC(0)="AEQMZ"
.S DIC("A")="Select a Pharmacy Division: "
.S DIC=59
.D ^DIC
.K DIC,DIE,DIR,DA,DD,DR,DO
.I X="" S BEXQUIT=1 Q
.I Y<0 S BEXQUIT=1 Q
.S BEXSITE=+Y
.S BEXDIV=BEXDIV+1
.S Y=$P($G(^PS(59,BEXSITE,"INI")),U)
.I +Y S BEXDIV(Y)=""
;
;
;
;--------------------------------------------------------------------
BEGDATE ;EP - Come here if end date is before begin date
;---------------------------------------------------------------------
;
W !
K DIRUT
K %DT
S %DT("A")="Select the Beginning Date/Time: "
S %DT="AET"
D ^%DT
K %DT
I ($D(DIRUT))!(Y<0) W !!,"No Beginning Date selected" G EOJ
S BEXBEG=Y
;
W !
K DIRUT
K %DT
S %DT("A")="Select the Ending Date/Time: "
S %DT="AET"
D ^%DT
K %DT
I ($D(DIRUT))!(Y<0) W !!,"No Ending Date selected" G EOJ
S BEXEND=Y
I $P(BEXEND,".",2)="" S BEXEND=BEXEND_".240000"
;
I BEXBEG>BEXEND W !!,"Beginning Date is later than the Ending Date. Try Again!",! G BEGDATE
;
W !
S XBRP="LIST^BEXRREJ"
S XBRX="EOJ^BEXRREJ"
S XBNS="BEX"
D ^XBDBQUE
Q
;
;
;---------------------------------------------------------------
EOJ ;EP - End of Job Processing
;---------------------------------------------------------------
;
X ^%ZIS("C")
I $E(IOST)="C" W ! K DIR S DIR(0)="E" D ^DIR K DIR
K BEX
D EN^XBVK("BEX")
K DIR,DIE,DIC,DD,DA,DR
Q
;
;
;---------------------------------------------------------------
LIST ;EP - Entry Point from XBDBQUE
;---------------------------------------------------------------
;
;
W #
D HEADER
;
K BEXTOT
S BEXTOT=0
S BEXTOT("REJECTS")=0
S BEXTOT("TOO EARLY")=0
S BEXTOT("DISCONTINUED")=0
S BEXTOT("CANCELLED")=0
S BEXTOT("NO REFILLS")=0
S BEXTOT("EXPIRED")=0
S BEXTOT("DUE EXPIRE")=0
S BEXTOT("RESTOCKED")=0
;
S BEXQUIT=0
S BEXEXIT=0
;
S BEXDATE=$O(^VEXHRX0(19080.1,"C",BEXBEG),-1)
F S BEXDATE=$O(^VEXHRX0(19080.1,"C",BEXDATE)) Q:'BEXDATE D Q:BEXQUIT=1
.;
.I BEXDATE>BEXEND S BEXQUIT=1 Q
.;
.;This loops around to some non-numeric dates
.I +BEXDATE<BEXBEG S BEXQUIT=1 Q
.;
.S BEXIEN=0
.F S BEXIEN=$O(^VEXHRX0(19080.1,"C",BEXDATE,BEXIEN)) Q:'BEXIEN D Q:BEXQUIT=1
..;
..S BEX(0)=$G(^VEXHRX0(19080.1,BEXIEN,0))
..I BEX(0)="" Q
..;
..;Restrict to non-Pharmacy Type
..I $P(BEX(0),U,4)="P" Q
..;
..D PARSE^BEXRUTL
..;
..;Screen by Division
..I +BEXDIV,BEXDVIEN="" Q
..I +BEXDIV,'$D(BEXDIV(BEXDVIEN)) Q
..;
..D TOTAL
;
S BEXQUIT=0
;Loop through sort array
S BEXDAT=0
F S BEXDAT=$O(BEXTOT(BEXDAT)) Q:'BEXDAT D Q:BEXQUIT=1 Q:BEXEXIT=1
.;
.W !
.S Y=BEXDAT
.W $E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
.;
.W ?30,"TOO EARLY",?49,$J($P(BEXTOT(BEXDAT),U,3),6)
.W ?58,"PERCENT "
.W $$PERCENT($P(BEXTOT(BEXDAT),U,3),$P(BEXTOT(BEXDAT),U,2)),!
.;
.W ?30,"DISCONTINUED",?49,$J($P(BEXTOT(BEXDAT),U,4),6)
.W ?58,"PERCENT "
.W $$PERCENT($P(BEXTOT(BEXDAT),U,4),$P(BEXTOT(BEXDAT),U,2)),!
.;
.W ?30,"CANCELLED",?49,$J($P(BEXTOT(BEXDAT),U,5),6)
.W ?58,"PERCENT "
.W $$PERCENT($P(BEXTOT(BEXDAT),U,5),$P(BEXTOT(BEXDAT),U,2)),!
.;
.W ?30,"NO REFILLS",?49,$J($P(BEXTOT(BEXDAT),U,6),6)
.W ?58,"PERCENT "
.W $$PERCENT($P(BEXTOT(BEXDAT),U,6),$P(BEXTOT(BEXDAT),U,2)),!
.;
.W ?30,"EXPIRED",?49,$J($P(BEXTOT(BEXDAT),U,7),6)
.W ?58,"PERCENT "
.W $$PERCENT($P(BEXTOT(BEXDAT),U,7),$P(BEXTOT(BEXDAT),U,2)),!
.;
.W ?30,"DUE EXPIRE",?49,$J($P(BEXTOT(BEXDAT),U,8),6)
.W ?58,"PERCENT "
.W $$PERCENT($P(BEXTOT(BEXDAT),U,8),$P(BEXTOT(BEXDAT),U,2)),!
.;
.W ?30,"RESTOCKED",?49,$J($P(BEXTOT(BEXDAT),U,9),6)
.W ?58,"PERCENT "
.W $$PERCENT($P(BEXTOT(BEXDAT),U,9),$P(BEXTOT(BEXDAT),U,2)),!
.;
.;
.W ?2,"TOTAL TRANSACTIONS "
.W $J($P(BEXTOT(BEXDAT),U,2),6)
.;
.W ?30,"TOTAL REJECTS "
.W $J($P(BEXTOT(BEXDAT),U),6)
.;
.W ?58,"PERCENT "
.W $$PERCENT($P(BEXTOT(BEXDAT),U),$P(BEXTOT(BEXDAT),U,2))
.;
.W !
.W "----------------------------------------------------------------------------"
.W !
.;
.I $Y>(IOSL-12) D
..I $E(IOST)="C" K DIR S DIR(0)="E" D ^DIR S:X="^" BEXEXIT=1 K DIR
..I BEXEXIT=1 Q
..D HEADER
;
W !
;
W "GRAND TOTALS"
;Write Totals for each type
W ?30,"TOO EARLY"
W ?49,$J(BEXTOT("TOO EARLY"),6)
W ?58,"PERCENT "
W $$PERCENT(BEXTOT("TOO EARLY"),BEXTOT),!
;
W ?30,"DISCONTINUED"
W ?49,$J(BEXTOT("DISCONTINUED"),6)
W ?58,"PERCENT "
W $$PERCENT(BEXTOT("DISCONTINUED"),BEXTOT),!
;
W ?30,"CANCELLED"
W ?49,$J(BEXTOT("CANCELLED"),6)
W ?58,"PERCENT "
W $$PERCENT(BEXTOT("CANCELLED"),BEXTOT),!
;
W ?30,"NO REFILLS"
W ?49,$J(BEXTOT("NO REFILLS"),6)
W ?58,"PERCENT "
W $$PERCENT(BEXTOT("NO REFILLS"),BEXTOT),!
;
W ?30,"EXPIRED"
W ?49,$J(BEXTOT("EXPIRED"),6)
W ?58,"PERCENT "
W $$PERCENT(BEXTOT("EXPIRED"),BEXTOT),!
;
W ?30,"DUE EXPIRE"
W ?49,$J(BEXTOT("DUE EXPIRE"),6)
W ?58,"PERCENT "
W $$PERCENT(BEXTOT("DUE EXPIRE"),BEXTOT),!
;
W ?30,"RESTOCKED"
W ?49,$J(BEXTOT("RESTOCKED"),6)
W ?58,"PERCENT "
W $$PERCENT(BEXTOT("RESTOCKED"),BEXTOT),!
;
W !
W ?2,"TOTAL TRANSACTIONS "
W $J(BEXTOT,6)
W ?30,"TOTAL REJECTS "
W $J(BEXTOT("REJECTS"),6)
W ?58,"PERCENT ",$$PERCENT(BEXTOT("REJECTS"),BEXTOT)
W !
;
Q
;
;
;---------------------------------------------------------------
;---------------------------------------------------------------
;
W #
W !,"REPORT: Refill Rejections Percentage Report"
W " for "
I +BEXSITE W $$GET1^DIQ(59,BEXSITE,.01)
I +BEXSITE=0 W "all Divisions"
W !,"DATE RUN: " S Y=DT X ^DD("DD") W Y
W !,"PARAMETERS: "
;
W "Between "
S Y=BEXBEG
W $E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
X ^DD("DD")
W "@"
I $P(Y,"@",2)]"" W $E($P(Y,"@",2),1,5)
I $P(Y,"@",2)="" W "00:00"
;
W " and "
S Y=BEXEND
W $E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
X ^DD("DD")
W "@"
I $P(Y,"@",2)]"" W $E($P(Y,"@",2),1,5)
I $P(Y,"@",2)="" W "00:00"
;
W !
W "-------------------------------------------------------------------------------"
W !
;
Q
;
;
;---------------------------------------------------------------
PERCENT(X,Y) ;EP - Calculate Percent
;---------------------------------------------------------------
;
I X=0 Q " 0.00%"
I Y=0 Q " 0.00%"
S Z=X/Y
S Z=$J(Z,4,4)
S Z=$E(Z,3,4)_"."_$E(Z,5,6)_"%"
I $E(Z)=0 S Z=" "_$E(Z,2,99)
Q Z
;
;
;-----------------------------------------------------------------
TOTAL ;EP - Add up totals
;-----------------------------------------------------------------
;
;We are adding up individual totals by reject type, but are not
;writing them at this time. In the future, the users may want them.
;
S BEXTOT=BEXTOT+1
;
;Initialize Counters for this date
I '$D(BEXTOT(BEXDAT)) S BEXTOT(BEXDAT)="0^0^0^0^0^0^0^0^0"
;
;Add to Total Transactions for this date
S $P(BEXTOT(BEXDAT),U,2)=$P(BEXTOT(BEXDAT),U,2)+1
;
;Reject - Too Early (piece 3)
I BEXRESLT="TOO EARLY" D Q
.S $P(BEXTOT(BEXDAT),U)=$P(BEXTOT(BEXDAT),U)+1
.S BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
.S BEXTOT("TOO EARLY")=BEXTOT("TOO EARLY")+1
.S $P(BEXTOT(BEXDAT),U,3)=$P(BEXTOT(BEXDAT),U,3)+1
;
;Reject - Discontinued (piece 4)
I BEXRESLT="DISCONTINUED" D Q
.S $P(BEXTOT(BEXDAT),U)=$P(BEXTOT(BEXDAT),U)+1
.S BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
.S BEXTOT("DISCONTINUED")=BEXTOT("DISCONTINUED")+1
.S $P(BEXTOT(BEXDAT),U,4)=$P(BEXTOT(BEXDAT),U,4)+1
;
;Reject - Canceled (piece 5) - yes it is misspelled
I BEXRESLT="CANCELED" D Q
.S $P(BEXTOT(BEXDAT),U)=$P(BEXTOT(BEXDAT),U)+1
.S BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
.S BEXTOT("CANCELLED")=BEXTOT("CANCELLED")+1
.S $P(BEXTOT(BEXDAT),U,5)=$P(BEXTOT(BEXDAT),U,5)+1
;
;Reject - No Refills (piece 6)
I BEXRESLT="NO REFILLS" D Q
.S $P(BEXTOT(BEXDAT),U)=$P(BEXTOT(BEXDAT),U)+1
.S BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
.S BEXTOT("NO REFILLS")=BEXTOT("NO REFILLS")+1
.S $P(BEXTOT(BEXDAT),U,6)=$P(BEXTOT(BEXDAT),U,6)+1
;
;Reject - Expired (piece 7)
I BEXRESLT="EXPIRED" D Q
.S $P(BEXTOT(BEXDAT),U)=$P(BEXTOT(BEXDAT),U)+1
.S BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
.S BEXTOT("EXPIRED")=BEXTOT("EXPIRED")+1
.S $P(BEXTOT(BEXDAT),U,7)=$P(BEXTOT(BEXDAT),U,7)+1
;
;Reject - Due Expire
I BEXRESLT="DUE EXPIRE" D Q
.S $P(BEXTOT(BEXDAT),U)=$P(BEXTOT(BEXDAT),U)+1
.S BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
.S BEXTOT("DUE EXPIRE")=BEXTOT("DUE EXPIRE")+1
.S $P(BEXTOT(BEXDAT),U,8)=$P(BEXTOT(BEXDAT),U,8)+1
;
;Reject - Restocked
I BEXRESLT="RESTOCKED" D Q
.S $P(BEXTOT(BEXDAT),U)=$P(BEXTOT(BEXDAT),U)+1
.S BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
.S BEXTOT("RESTOCKED")=BEXTOT("RESTOCKED")+1
.S $P(BEXTOT(BEXDAT),U,9)=$P(BEXTOT(BEXDAT),U,9)+1
;
Q
;
BEXRREJ ;IHS/CMI/DAY - BEX - Refill Rejections Percentage Report ; 12 Mar 2012 7:15 PM
+1 ;;1.0;BEX TELEPHONE REFILL SYSTEM;**4,5**;MAR 12, 2012;Build 1
+2 ;
+3 ;Prints the Refill Rejections Percentage Report
+4 ;
+5 WRITE #
+6 ;
+7 WRITE !,"Refill Rejections Percentage Report"
+8 WRITE !
+9 WRITE !,"This option prints a list of Transactions that were processed within"
+10 WRITE !,"a selected date/time range."
+11 WRITE !
+12 ;
+13 KILL BEXDIV
+14 SET BEXDIV=0
+15 SET BEXSITE=0
+16 SET BEXQUIT=0
+17 ;
+18 WRITE !,"Press Enter to select ALL Pharmacy Divisions, or"
+19 FOR
Begin DoDot:1
+20 KILL DIC,DIR,DIE,DA,DR,DO,DD
+21 SET DIC(0)="AEQMZ"
+22 SET DIC("A")="Select a Pharmacy Division: "
+23 SET DIC=59
+24 DO ^DIC
+25 KILL DIC,DIE,DIR,DA,DD,DR,DO
+26 IF X=""
SET BEXQUIT=1
QUIT
+27 IF Y<0
SET BEXQUIT=1
QUIT
+28 SET BEXSITE=+Y
+29 SET BEXDIV=BEXDIV+1
+30 SET Y=$PIECE($GET(^PS(59,BEXSITE,"INI")),U)
+31 IF +Y
SET BEXDIV(Y)=""
End DoDot:1
IF BEXQUIT=1
QUIT
+32 ;
+33 ;
+34 ;
+35 ;--------------------------------------------------------------------
BEGDATE ;EP - Come here if end date is before begin date
+1 ;---------------------------------------------------------------------
+2 ;
+3 WRITE !
+4 KILL DIRUT
+5 KILL %DT
+6 SET %DT("A")="Select the Beginning Date/Time: "
+7 SET %DT="AET"
+8 DO ^%DT
+9 KILL %DT
+10 IF ($DATA(DIRUT))!(Y<0)
WRITE !!,"No Beginning Date selected"
GOTO EOJ
+11 SET BEXBEG=Y
+12 ;
+13 WRITE !
+14 KILL DIRUT
+15 KILL %DT
+16 SET %DT("A")="Select the Ending Date/Time: "
+17 SET %DT="AET"
+18 DO ^%DT
+19 KILL %DT
+20 IF ($DATA(DIRUT))!(Y<0)
WRITE !!,"No Ending Date selected"
GOTO EOJ
+21 SET BEXEND=Y
+22 IF $PIECE(BEXEND,".",2)=""
SET BEXEND=BEXEND_".240000"
+23 ;
+24 IF BEXBEG>BEXEND
WRITE !!,"Beginning Date is later than the Ending Date. Try Again!",!
GOTO BEGDATE
+25 ;
+26 WRITE !
+27 SET XBRP="LIST^BEXRREJ"
+28 SET XBRX="EOJ^BEXRREJ"
+29 SET XBNS="BEX"
+30 DO ^XBDBQUE
+31 QUIT
+32 ;
+33 ;
+34 ;---------------------------------------------------------------
EOJ ;EP - End of Job Processing
+1 ;---------------------------------------------------------------
+2 ;
+3 XECUTE ^%ZIS("C")
+4 IF $EXTRACT(IOST)="C"
WRITE !
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
+5 KILL BEX
+6 DO EN^XBVK("BEX")
+7 KILL DIR,DIE,DIC,DD,DA,DR
+8 QUIT
+9 ;
+10 ;
+11 ;---------------------------------------------------------------
LIST ;EP - Entry Point from XBDBQUE
+1 ;---------------------------------------------------------------
+2 ;
+3 ;
+4 WRITE #
+5 DO HEADER
+6 ;
+7 KILL BEXTOT
+8 SET BEXTOT=0
+9 SET BEXTOT("REJECTS")=0
+10 SET BEXTOT("TOO EARLY")=0
+11 SET BEXTOT("DISCONTINUED")=0
+12 SET BEXTOT("CANCELLED")=0
+13 SET BEXTOT("NO REFILLS")=0
+14 SET BEXTOT("EXPIRED")=0
+15 SET BEXTOT("DUE EXPIRE")=0
+16 SET BEXTOT("RESTOCKED")=0
+17 ;
+18 SET BEXQUIT=0
+19 SET BEXEXIT=0
+20 ;
+21 SET BEXDATE=$ORDER(^VEXHRX0(19080.1,"C",BEXBEG),-1)
+22 FOR
SET BEXDATE=$ORDER(^VEXHRX0(19080.1,"C",BEXDATE))
IF 'BEXDATE
QUIT
Begin DoDot:1
+23 ;
+24 IF BEXDATE>BEXEND
SET BEXQUIT=1
QUIT
+25 ;
+26 ;This loops around to some non-numeric dates
+27 IF +BEXDATE<BEXBEG
SET BEXQUIT=1
QUIT
+28 ;
+29 SET BEXIEN=0
+30 FOR
SET BEXIEN=$ORDER(^VEXHRX0(19080.1,"C",BEXDATE,BEXIEN))
IF 'BEXIEN
QUIT
Begin DoDot:2
+31 ;
+32 SET BEX(0)=$GET(^VEXHRX0(19080.1,BEXIEN,0))
+33 IF BEX(0)=""
QUIT
+34 ;
+35 ;Restrict to non-Pharmacy Type
+36 IF $PIECE(BEX(0),U,4)="P"
QUIT
+37 ;
+38 DO PARSE^BEXRUTL
+39 ;
+40 ;Screen by Division
+41 IF +BEXDIV
IF BEXDVIEN=""
QUIT
+42 IF +BEXDIV
IF '$DATA(BEXDIV(BEXDVIEN))
QUIT
+43 ;
+44 DO TOTAL
End DoDot:2
IF BEXQUIT=1
QUIT
End DoDot:1
IF BEXQUIT=1
QUIT
+45 ;
+46 SET BEXQUIT=0
+47 ;Loop through sort array
+48 SET BEXDAT=0
+49 FOR
SET BEXDAT=$ORDER(BEXTOT(BEXDAT))
IF 'BEXDAT
QUIT
Begin DoDot:1
+50 ;
+51 WRITE !
+52 SET Y=BEXDAT
+53 WRITE $EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
+54 ;
+55 WRITE ?30,"TOO EARLY",?49,$JUSTIFY($PIECE(BEXTOT(BEXDAT),U,3),6)
+56 WRITE ?58,"PERCENT "
+57 WRITE $$PERCENT($PIECE(BEXTOT(BEXDAT),U,3),$PIECE(BEXTOT(BEXDAT),U,2)),!
+58 ;
+59 WRITE ?30,"DISCONTINUED",?49,$JUSTIFY($PIECE(BEXTOT(BEXDAT),U,4),6)
+60 WRITE ?58,"PERCENT "
+61 WRITE $$PERCENT($PIECE(BEXTOT(BEXDAT),U,4),$PIECE(BEXTOT(BEXDAT),U,2)),!
+62 ;
+63 WRITE ?30,"CANCELLED",?49,$JUSTIFY($PIECE(BEXTOT(BEXDAT),U,5),6)
+64 WRITE ?58,"PERCENT "
+65 WRITE $$PERCENT($PIECE(BEXTOT(BEXDAT),U,5),$PIECE(BEXTOT(BEXDAT),U,2)),!
+66 ;
+67 WRITE ?30,"NO REFILLS",?49,$JUSTIFY($PIECE(BEXTOT(BEXDAT),U,6),6)
+68 WRITE ?58,"PERCENT "
+69 WRITE $$PERCENT($PIECE(BEXTOT(BEXDAT),U,6),$PIECE(BEXTOT(BEXDAT),U,2)),!
+70 ;
+71 WRITE ?30,"EXPIRED",?49,$JUSTIFY($PIECE(BEXTOT(BEXDAT),U,7),6)
+72 WRITE ?58,"PERCENT "
+73 WRITE $$PERCENT($PIECE(BEXTOT(BEXDAT),U,7),$PIECE(BEXTOT(BEXDAT),U,2)),!
+74 ;
+75 WRITE ?30,"DUE EXPIRE",?49,$JUSTIFY($PIECE(BEXTOT(BEXDAT),U,8),6)
+76 WRITE ?58,"PERCENT "
+77 WRITE $$PERCENT($PIECE(BEXTOT(BEXDAT),U,8),$PIECE(BEXTOT(BEXDAT),U,2)),!
+78 ;
+79 WRITE ?30,"RESTOCKED",?49,$JUSTIFY($PIECE(BEXTOT(BEXDAT),U,9),6)
+80 WRITE ?58,"PERCENT "
+81 WRITE $$PERCENT($PIECE(BEXTOT(BEXDAT),U,9),$PIECE(BEXTOT(BEXDAT),U,2)),!
+82 ;
+83 ;
+84 WRITE ?2,"TOTAL TRANSACTIONS "
+85 WRITE $JUSTIFY($PIECE(BEXTOT(BEXDAT),U,2),6)
+86 ;
+87 WRITE ?30,"TOTAL REJECTS "
+88 WRITE $JUSTIFY($PIECE(BEXTOT(BEXDAT),U),6)
+89 ;
+90 WRITE ?58,"PERCENT "
+91 WRITE $$PERCENT($PIECE(BEXTOT(BEXDAT),U),$PIECE(BEXTOT(BEXDAT),U,2))
+92 ;
+93 WRITE !
+94 WRITE "----------------------------------------------------------------------------"
+95 WRITE !
+96 ;
+97 IF $Y>(IOSL-12)
Begin DoDot:2
+98 IF $EXTRACT(IOST)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
IF X="^"
SET BEXEXIT=1
KILL DIR
+99 IF BEXEXIT=1
QUIT
+100 DO HEADER
End DoDot:2
End DoDot:1
IF BEXQUIT=1
QUIT
IF BEXEXIT=1
QUIT
+101 ;
+102 WRITE !
+103 ;
+104 WRITE "GRAND TOTALS"
+105 ;Write Totals for each type
+106 WRITE ?30,"TOO EARLY"
+107 WRITE ?49,$JUSTIFY(BEXTOT("TOO EARLY"),6)
+108 WRITE ?58,"PERCENT "
+109 WRITE $$PERCENT(BEXTOT("TOO EARLY"),BEXTOT),!
+110 ;
+111 WRITE ?30,"DISCONTINUED"
+112 WRITE ?49,$JUSTIFY(BEXTOT("DISCONTINUED"),6)
+113 WRITE ?58,"PERCENT "
+114 WRITE $$PERCENT(BEXTOT("DISCONTINUED"),BEXTOT),!
+115 ;
+116 WRITE ?30,"CANCELLED"
+117 WRITE ?49,$JUSTIFY(BEXTOT("CANCELLED"),6)
+118 WRITE ?58,"PERCENT "
+119 WRITE $$PERCENT(BEXTOT("CANCELLED"),BEXTOT),!
+120 ;
+121 WRITE ?30,"NO REFILLS"
+122 WRITE ?49,$JUSTIFY(BEXTOT("NO REFILLS"),6)
+123 WRITE ?58,"PERCENT "
+124 WRITE $$PERCENT(BEXTOT("NO REFILLS"),BEXTOT),!
+125 ;
+126 WRITE ?30,"EXPIRED"
+127 WRITE ?49,$JUSTIFY(BEXTOT("EXPIRED"),6)
+128 WRITE ?58,"PERCENT "
+129 WRITE $$PERCENT(BEXTOT("EXPIRED"),BEXTOT),!
+130 ;
+131 WRITE ?30,"DUE EXPIRE"
+132 WRITE ?49,$JUSTIFY(BEXTOT("DUE EXPIRE"),6)
+133 WRITE ?58,"PERCENT "
+134 WRITE $$PERCENT(BEXTOT("DUE EXPIRE"),BEXTOT),!
+135 ;
+136 WRITE ?30,"RESTOCKED"
+137 WRITE ?49,$JUSTIFY(BEXTOT("RESTOCKED"),6)
+138 WRITE ?58,"PERCENT "
+139 WRITE $$PERCENT(BEXTOT("RESTOCKED"),BEXTOT),!
+140 ;
+141 WRITE !
+142 WRITE ?2,"TOTAL TRANSACTIONS "
+143 WRITE $JUSTIFY(BEXTOT,6)
+144 WRITE ?30,"TOTAL REJECTS "
+145 WRITE $JUSTIFY(BEXTOT("REJECTS"),6)
+146 WRITE ?58,"PERCENT ",$$PERCENT(BEXTOT("REJECTS"),BEXTOT)
+147 WRITE !
+148 ;
+149 QUIT
+150 ;
+151 ;
+152 ;---------------------------------------------------------------
+1 ;---------------------------------------------------------------
+2 ;
+3 WRITE #
+4 WRITE !,"REPORT: Refill Rejections Percentage Report"
+5 WRITE " for "
+6 IF +BEXSITE
WRITE $$GET1^DIQ(59,BEXSITE,.01)
+7 IF +BEXSITE=0
WRITE "all Divisions"
+8 WRITE !,"DATE RUN: "
SET Y=DT
XECUTE ^DD("DD")
WRITE Y
+9 WRITE !,"PARAMETERS: "
+10 ;
+11 WRITE "Between "
+12 SET Y=BEXBEG
+13 WRITE $EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
+14 XECUTE ^DD("DD")
+15 WRITE "@"
+16 IF $PIECE(Y,"@",2)]""
WRITE $EXTRACT($PIECE(Y,"@",2),1,5)
+17 IF $PIECE(Y,"@",2)=""
WRITE "00:00"
+18 ;
+19 WRITE " and "
+20 SET Y=BEXEND
+21 WRITE $EXTRACT(Y,4,5),"/",$EXTRACT(Y,6,7),"/",$EXTRACT(Y,2,3)
+22 XECUTE ^DD("DD")
+23 WRITE "@"
+24 IF $PIECE(Y,"@",2)]""
WRITE $EXTRACT($PIECE(Y,"@",2),1,5)
+25 IF $PIECE(Y,"@",2)=""
WRITE "00:00"
+26 ;
+27 WRITE !
+28 WRITE "-------------------------------------------------------------------------------"
+29 WRITE !
+30 ;
+31 QUIT
+32 ;
+33 ;
+34 ;---------------------------------------------------------------
PERCENT(X,Y) ;EP - Calculate Percent
+1 ;---------------------------------------------------------------
+2 ;
+3 IF X=0
QUIT " 0.00%"
+4 IF Y=0
QUIT " 0.00%"
+5 SET Z=X/Y
+6 SET Z=$JUSTIFY(Z,4,4)
+7 SET Z=$EXTRACT(Z,3,4)_"."_$EXTRACT(Z,5,6)_"%"
+8 IF $EXTRACT(Z)=0
SET Z=" "_$EXTRACT(Z,2,99)
+9 QUIT Z
+10 ;
+11 ;
+12 ;-----------------------------------------------------------------
TOTAL ;EP - Add up totals
+1 ;-----------------------------------------------------------------
+2 ;
+3 ;We are adding up individual totals by reject type, but are not
+4 ;writing them at this time. In the future, the users may want them.
+5 ;
+6 SET BEXTOT=BEXTOT+1
+7 ;
+8 ;Initialize Counters for this date
+9 IF '$DATA(BEXTOT(BEXDAT))
SET BEXTOT(BEXDAT)="0^0^0^0^0^0^0^0^0"
+10 ;
+11 ;Add to Total Transactions for this date
+12 SET $PIECE(BEXTOT(BEXDAT),U,2)=$PIECE(BEXTOT(BEXDAT),U,2)+1
+13 ;
+14 ;Reject - Too Early (piece 3)
+15 IF BEXRESLT="TOO EARLY"
Begin DoDot:1
+16 SET $PIECE(BEXTOT(BEXDAT),U)=$PIECE(BEXTOT(BEXDAT),U)+1
+17 SET BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
+18 SET BEXTOT("TOO EARLY")=BEXTOT("TOO EARLY")+1
+19 SET $PIECE(BEXTOT(BEXDAT),U,3)=$PIECE(BEXTOT(BEXDAT),U,3)+1
End DoDot:1
QUIT
+20 ;
+21 ;Reject - Discontinued (piece 4)
+22 IF BEXRESLT="DISCONTINUED"
Begin DoDot:1
+23 SET $PIECE(BEXTOT(BEXDAT),U)=$PIECE(BEXTOT(BEXDAT),U)+1
+24 SET BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
+25 SET BEXTOT("DISCONTINUED")=BEXTOT("DISCONTINUED")+1
+26 SET $PIECE(BEXTOT(BEXDAT),U,4)=$PIECE(BEXTOT(BEXDAT),U,4)+1
End DoDot:1
QUIT
+27 ;
+28 ;Reject - Canceled (piece 5) - yes it is misspelled
+29 IF BEXRESLT="CANCELED"
Begin DoDot:1
+30 SET $PIECE(BEXTOT(BEXDAT),U)=$PIECE(BEXTOT(BEXDAT),U)+1
+31 SET BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
+32 SET BEXTOT("CANCELLED")=BEXTOT("CANCELLED")+1
+33 SET $PIECE(BEXTOT(BEXDAT),U,5)=$PIECE(BEXTOT(BEXDAT),U,5)+1
End DoDot:1
QUIT
+34 ;
+35 ;Reject - No Refills (piece 6)
+36 IF BEXRESLT="NO REFILLS"
Begin DoDot:1
+37 SET $PIECE(BEXTOT(BEXDAT),U)=$PIECE(BEXTOT(BEXDAT),U)+1
+38 SET BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
+39 SET BEXTOT("NO REFILLS")=BEXTOT("NO REFILLS")+1
+40 SET $PIECE(BEXTOT(BEXDAT),U,6)=$PIECE(BEXTOT(BEXDAT),U,6)+1
End DoDot:1
QUIT
+41 ;
+42 ;Reject - Expired (piece 7)
+43 IF BEXRESLT="EXPIRED"
Begin DoDot:1
+44 SET $PIECE(BEXTOT(BEXDAT),U)=$PIECE(BEXTOT(BEXDAT),U)+1
+45 SET BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
+46 SET BEXTOT("EXPIRED")=BEXTOT("EXPIRED")+1
+47 SET $PIECE(BEXTOT(BEXDAT),U,7)=$PIECE(BEXTOT(BEXDAT),U,7)+1
End DoDot:1
QUIT
+48 ;
+49 ;Reject - Due Expire
+50 IF BEXRESLT="DUE EXPIRE"
Begin DoDot:1
+51 SET $PIECE(BEXTOT(BEXDAT),U)=$PIECE(BEXTOT(BEXDAT),U)+1
+52 SET BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
+53 SET BEXTOT("DUE EXPIRE")=BEXTOT("DUE EXPIRE")+1
+54 SET $PIECE(BEXTOT(BEXDAT),U,8)=$PIECE(BEXTOT(BEXDAT),U,8)+1
End DoDot:1
QUIT
+55 ;
+56 ;Reject - Restocked
+57 IF BEXRESLT="RESTOCKED"
Begin DoDot:1
+58 SET $PIECE(BEXTOT(BEXDAT),U)=$PIECE(BEXTOT(BEXDAT),U)+1
+59 SET BEXTOT("REJECTS")=BEXTOT("REJECTS")+1
+60 SET BEXTOT("RESTOCKED")=BEXTOT("RESTOCKED")+1
+61 SET $PIECE(BEXTOT(BEXDAT),U,9)=$PIECE(BEXTOT(BEXDAT),U,9)+1
End DoDot:1
QUIT
+62 ;
+63 QUIT
+64 ;
