PSOCST10 ;BHAM ISC/SAB - high cost report ; 12/16/14 8:53am
;;7.0;OUTPATIENT PHARMACY;**31,56,331,398,452**;DEC 1997;Build 56
;this routine list rxs that cost over a specified $ amount for a specified date range
;External Ref. ^PSDRUG( is supp. by DBIA# 221
BEG W ! S %DT(0)=-DT,%DT("A")="Beginning Date: ",%DT="APE" D ^%DT G:Y<0!($D(DTOUT)) EXIT S (%DT(0),BEGDATE)=Y
W ! S %DT("A")="Ending Date: " D ^%DT G:Y<0!($D(DTOUT)) EXIT S ENDDATE=Y D:+$E(Y,6,7)=0 DTC
MAX K DIR S DIR("A")="Dollar Limit ",DIR("B")=30,DIR(0)="N^0:9999:2",DIR("?")="Enter a dollar amount between 0-9999 with no more than two decimals or ^ quit"
D ^DIR K DIR G:$D(DIRUT) EXIT S MAX=Y
; BEGIN prompt for selection of Outpatient Site(s) //rtw
N @($$DIR^PSODIR4()),PSOSITE D OPTSITE^PSODIR4(.PSOSITE,$T(+0),1) G:PSOSITE="^" EXIT
; END prompt for selection of Outpatient Site(s)
DEV K %ZIS,IOP,POP,ZTSK S PSOION=ION,%ZIS="QM" D ^%ZIS K %ZIS I POP S IOP=PSOION D ^%ZIS K IOP,PSOION W !,"Please try later!" G EXIT
K PSOION I $D(IO("Q")) D G EXIT
.S ZTDESC="Outpatient High Cost Report",ZTRTN="START^PSOCST10" F G="BEGDATE","ENDDATE","MAX" S:$D(@G) ZTSAVE(G)=""
.; Begin save & pass PSOSITE* to tasked entry point //rtw
.S ZTSAVE("PSOSITE*")=""
.; End save & pass PSOSITE* to tasked entry point /rtw
.K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print !!" K ZTSK
START U IO S PAGE=1,(CNT,TCOST)=0 D HD
F NDT=BEGDATE:1:ENDDATE F PSOTY="AL","AM" S PSDT=NDT-1_".999999" D ST1 Q:$D(DIRUT) ;*331
Q:$D(DIRUT) D HD:($Y+4)>IOSL
D:'$D(DIRUT) FT
EXIT W ! D ^%ZISC K XTYPE,DIR,DTOUT,DUOUT,DIROUT,DIRUT,^TMP($J),NDT,PSOTY,BEGDATE,CNT,COST,TCOST,DR0,DRCST,ENDDATE,MAX,PAGE,PGM,POP,PSDT,PSFILL,PSRXN,QTY,RX0,RX1,VAR,X,Y,%DT
S:$D(ZTQUEUED) ZTREQ="@" Q
ST1 F S PSDT=$O(^PSRX(PSOTY,PSDT)) Q:'PSDT!(PSDT>(NDT_".999999")) D ST2 Q:$D(DIRUT)
Q
ST2 S PSRXN=0 F S PSRXN=$O(^PSRX(PSOTY,PSDT,PSRXN)) Q:'PSRXN D ST3 Q:$D(DIRUT)
Q
ST3 S PSFILL=""
F S PSFILL=$O(^PSRX(PSOTY,PSDT,PSRXN,PSFILL)) Q:PSFILL="" D CHK Q:$D(DIRUT)
Q
CHK Q:'$D(^PSRX(PSRXN,0))!(+$P(^PSRX(PSRXN,"STA"),"^")=13) S RX0=^(0) Q:'$D(^PSDRUG(+$P(RX0,"^",6),0)) S DR0=^(0)
I PSOTY="AL" S:PSFILL RX1=$G(^PSRX(PSRXN,1,PSFILL,0)) Q:PSFILL&($G(RX1)="")
I PSOTY="AM" Q:'$P($G(^PSRX(PSRXN,"P",PSFILL,0)),"^",19) S RX1=^(0)
; Begin to screen RX on selected Outpatient Site(s) ;rtw
Q:'$$DIVOK^PSODIR4(.PSOSITE,PSOTY,PSRXN,PSFILL)
; End screen of RX on selected Outpatient Site(s) ;rtw
S DRCST=$S('PSFILL&(+$P(RX0,"^",17)):$P(RX0,"^",17),PSFILL&(+$P($G(RX1),"^",11)):$P($G(RX1),"^",11),1:0)
S QTY=$S('PSFILL:+$P(RX0,"^",7),1:+$P(RX1,"^",4))
I 'DRCST S DRCST=$S($P($G(^PSDRUG(+$P(RX0,"^",6),660)),"^",6):+$P(^(660),"^",6),1:0)
S COST=QTY*DRCST Q:COST<MAX
Q:$D(DIRUT) D HD:($Y+4)>IOSL
Q:$D(DIRUT) W !,$S(PSFILL&(PSOTY="AL"):"*",PSOTY="AM":"%",1:" ")_$P(RX0,"^"),?11,$E($P(DR0,"^"),"^",40),?51,$J(QTY,6),?60,$J(DRCST,6,3),?68,$J(COST,12,2) S CNT=CNT+1,TCOST=TCOST+COST
Q
HD I PAGE>1,$E(IOST)="C" S DIR(0)="E",DIR("A")=" Press Return to Continue or ^ to Exit" D ^DIR K DIR
Q:$D(DIRUT) W @IOF,!,"Fills That Cost at Least $"_MAX_" for the Period: " S Y=BEGDATE D DT^DIO2 W " to " S Y=ENDDATE D DT^DIO2 W ?72,"Page "_PAGE,!,"Run Date: " S Y=DT D DT^DIO2 S PAGE=PAGE+1
; Begin display selected Outpatient Site(s) //rtw
N PSOLTIEN,PSOIEN59,PSOSTANM
W !,"Outpatient Site" I PSOSITE("PSOSCNT")>1 W "s"
W " Included in this Report: " I PSOSITE("PSOSCNT")>1 W !?2
S PSOLTIEN=$O(PSOSITE(":"),-1) ; Do not append a comma on last site
S PSOIEN59=0 F S PSOIEN59=$O(PSOSITE(PSOIEN59)) Q:'PSOIEN59 D ;
. ; Format PSOSTANM variable, for example: JOHN COCHRAN VAMC (657)
. S PSOSTANM=PSOSITE(PSOIEN59)_" ("_$$GET1^DIQ(59,PSOIEN59,.06)_")"
. I PSOIEN59'=PSOLTIEN S PSOSTANM=PSOSTANM_", " ; Format multiples sites w/comma separation
. I $X+($L(PSOSTANM)+2)>(IOM-1) W !?2 ; Issue line feed if IOM exceeded
. W PSOSTANM
; End display selected Outpatient Site(s) //rtw
W !!,"Rx #",?11,"Drug",?54,"QTY",?59,"Un.Cost",?70,"Total Cost"
W ! F I=1:1:80 W "-"
Q
FT W ! F I=1:1:80 W "-"
S TCOST="Total Cost = "_$FN(TCOST,",",2)
W !,"No. of Fills = "_CNT,?50,$J(TCOST,30)
W ! F I=1:1:80 W "-"
W !,"(* indicates a refill, % indicates a partial) "
Q
DTC N DD,MM S DD=31,MM=+$E(Y,4,5) I MM'=12 S MM=MM+1,MM=$S(MM<10:"0",1:"")_MM,X2=Y,X1=$E(Y,1,3)_MM_"00" D ^%DTC S DD=X
S ENDDATE=Y+DD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOCST10 4402 printed Oct 16, 2024@18:26:48 Page 2
PSOCST10 ;BHAM ISC/SAB - high cost report ; 12/16/14 8:53am
+1 ;;7.0;OUTPATIENT PHARMACY;**31,56,331,398,452**;DEC 1997;Build 56
+2 ;this routine list rxs that cost over a specified $ amount for a specified date range
+3 ;External Ref. ^PSDRUG( is supp. by DBIA# 221
BEG WRITE !
SET %DT(0)=-DT
SET %DT("A")="Beginning Date: "
SET %DT="APE"
DO ^%DT
if Y<0!($DATA(DTOUT))
GOTO EXIT
SET (%DT(0),BEGDATE)=Y
+1 WRITE !
SET %DT("A")="Ending Date: "
DO ^%DT
if Y<0!($DATA(DTOUT))
GOTO EXIT
SET ENDDATE=Y
if +$EXTRACT(Y,6,7)=0
DO DTC
MAX KILL DIR
SET DIR("A")="Dollar Limit "
SET DIR("B")=30
SET DIR(0)="N^0:9999:2"
SET DIR("?")="Enter a dollar amount between 0-9999 with no more than two decimals or ^ quit"
+1 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
SET MAX=Y
+2 ; BEGIN prompt for selection of Outpatient Site(s) //rtw
+3 NEW @($$DIR^PSODIR4()),PSOSITE
DO OPTSITE^PSODIR4(.PSOSITE,$TEXT(+0),1)
if PSOSITE="^"
GOTO EXIT
+4 ; END prompt for selection of Outpatient Site(s)
DEV KILL %ZIS,IOP,POP,ZTSK
SET PSOION=ION
SET %ZIS="QM"
DO ^%ZIS
KILL %ZIS
IF POP
SET IOP=PSOION
DO ^%ZIS
KILL IOP,PSOION
WRITE !,"Please try later!"
GOTO EXIT
+1 KILL PSOION
IF $DATA(IO("Q"))
Begin DoDot:1
+2 SET ZTDESC="Outpatient High Cost Report"
SET ZTRTN="START^PSOCST10"
FOR G="BEGDATE","ENDDATE","MAX"
if $DATA(@G)
SET ZTSAVE(G)=""
+3 ; Begin save & pass PSOSITE* to tasked entry point //rtw
+4 SET ZTSAVE("PSOSITE*")=""
+5 ; End save & pass PSOSITE* to tasked entry point /rtw
+6 KILL IO("Q")
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report is Queued to print !!"
KILL ZTSK
End DoDot:1
GOTO EXIT
START USE IO
SET PAGE=1
SET (CNT,TCOST)=0
DO HD
+1 ;*331
FOR NDT=BEGDATE:1:ENDDATE
FOR PSOTY="AL","AM"
SET PSDT=NDT-1_".999999"
DO ST1
if $DATA(DIRUT)
QUIT
+2 if $DATA(DIRUT)
QUIT
if ($Y+4)>IOSL
DO HD
+3 if '$DATA(DIRUT)
DO FT
EXIT WRITE !
DO ^%ZISC
KILL XTYPE,DIR,DTOUT,DUOUT,DIROUT,DIRUT,^TMP($JOB),NDT,PSOTY,BEGDATE,CNT,COST,TCOST,DR0,DRCST,ENDDATE,MAX,PAGE,PGM,POP,PSDT,PSFILL,PSRXN,QTY,RX0,RX1,VAR,X,Y,%DT
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
ST1 FOR
SET PSDT=$ORDER(^PSRX(PSOTY,PSDT))
if 'PSDT!(PSDT>(NDT_".999999"))
QUIT
DO ST2
if $DATA(DIRUT)
QUIT
+1 QUIT
ST2 SET PSRXN=0
FOR
SET PSRXN=$ORDER(^PSRX(PSOTY,PSDT,PSRXN))
if 'PSRXN
QUIT
DO ST3
if $DATA(DIRUT)
QUIT
+1 QUIT
ST3 SET PSFILL=""
+1 FOR
SET PSFILL=$ORDER(^PSRX(PSOTY,PSDT,PSRXN,PSFILL))
if PSFILL=""
QUIT
DO CHK
if $DATA(DIRUT)
QUIT
+2 QUIT
CHK if '$DATA(^PSRX(PSRXN,0))!(+$PIECE(^PSRX(PSRXN,"STA"),"^")=13)
QUIT
SET RX0=^(0)
if '$DATA(^PSDRUG(+$PIECE(RX0,"^",6),0))
QUIT
SET DR0=^(0)
+1 IF PSOTY="AL"
if PSFILL
SET RX1=$GET(^PSRX(PSRXN,1,PSFILL,0))
if PSFILL&($GET(RX1)="")
QUIT
+2 IF PSOTY="AM"
if '$PIECE($GET(^PSRX(PSRXN,"P",PSFILL,0)),"^",19)
QUIT
SET RX1=^(0)
+3 ; Begin to screen RX on selected Outpatient Site(s) ;rtw
+4 if '$$DIVOK^PSODIR4(.PSOSITE,PSOTY,PSRXN,PSFILL)
QUIT
+5 ; End screen of RX on selected Outpatient Site(s) ;rtw
+6 SET DRCST=$SELECT('PSFILL&(+$PIECE(RX0,"^",17)):$PIECE(RX0,"^",17),PSFILL&(+$PIECE($GET(RX1),"^",11)):$PIECE($GET(RX1),"^",11),1:0)
+7 SET QTY=$SELECT('PSFILL:+$PIECE(RX0,"^",7),1:+$PIECE(RX1,"^",4))
+8 IF 'DRCST
SET DRCST=$SELECT($PIECE($GET(^PSDRUG(+$PIECE(RX0,"^",6),660)),"^",6):+$PIECE(^(660),"^",6),1:0)
+9 SET COST=QTY*DRCST
if COST<MAX
QUIT
+10 if $DATA(DIRUT)
QUIT
if ($Y+4)>IOSL
DO HD
+11 if $DATA(DIRUT)
QUIT
WRITE !,$SELECT(PSFILL&(PSOTY="AL"):"*",PSOTY="AM":"%",1:" ")_$PIECE(RX0,"^"),?11,$EXTRACT($PIECE(DR0,"^"),"^",40),?51,$JUSTIFY(QTY,6),?60,$JUSTIFY(DRCST,6,3),?68,$JUSTIFY(COST,12,2)
SET CNT=CNT+1
SET TCOST=TCOST+COST
+12 QUIT
HD IF PAGE>1
IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
SET DIR("A")=" Press Return to Continue or ^ to Exit"
DO ^DIR
KILL DIR
+1 if $DATA(DIRUT)
QUIT
WRITE @IOF,!,"Fills That Cost at Least $"_MAX_" for the Period: "
SET Y=BEGDATE
DO DT^DIO2
WRITE " to "
SET Y=ENDDATE
DO DT^DIO2
WRITE ?72,"Page "_PAGE,!,"Run Date: "
SET Y=DT
DO DT^DIO2
SET PAGE=PAGE+1
+2 ; Begin display selected Outpatient Site(s) //rtw
+3 NEW PSOLTIEN,PSOIEN59,PSOSTANM
+4 WRITE !,"Outpatient Site"
IF PSOSITE("PSOSCNT")>1
WRITE "s"
+5 WRITE " Included in this Report: "
IF PSOSITE("PSOSCNT")>1
WRITE !?2
+6 ; Do not append a comma on last site
SET PSOLTIEN=$ORDER(PSOSITE(":"),-1)
+7 ;
SET PSOIEN59=0
FOR
SET PSOIEN59=$ORDER(PSOSITE(PSOIEN59))
if 'PSOIEN59
QUIT
Begin DoDot:1
+8 ; Format PSOSTANM variable, for example: JOHN COCHRAN VAMC (657)
+9 SET PSOSTANM=PSOSITE(PSOIEN59)_" ("_$$GET1^DIQ(59,PSOIEN59,.06)_")"
+10 ; Format multiples sites w/comma separation
IF PSOIEN59'=PSOLTIEN
SET PSOSTANM=PSOSTANM_", "
+11 ; Issue line feed if IOM exceeded
IF $X+($LENGTH(PSOSTANM)+2)>(IOM-1)
WRITE !?2
+12 WRITE PSOSTANM
End DoDot:1
+13 ; End display selected Outpatient Site(s) //rtw
+14 WRITE !!,"Rx #",?11,"Drug",?54,"QTY",?59,"Un.Cost",?70,"Total Cost"
+15 WRITE !
FOR I=1:1:80
WRITE "-"
+16 QUIT
FT WRITE !
FOR I=1:1:80
WRITE "-"
+1 SET TCOST="Total Cost = "_$FNUMBER(TCOST,",",2)
+2 WRITE !,"No. of Fills = "_CNT,?50,$JUSTIFY(TCOST,30)
+3 WRITE !
FOR I=1:1:80
WRITE "-"
+4 WRITE !,"(* indicates a refill, % indicates a partial) "
+5 QUIT
DTC NEW DD,MM
SET DD=31
SET MM=+$EXTRACT(Y,4,5)
IF MM'=12
SET MM=MM+1
SET MM=$SELECT(MM<10:"0",1:"")_MM
SET X2=Y
SET X1=$EXTRACT(Y,1,3)_MM_"00"
DO ^%DTC
SET DD=X
+1 SET ENDDATE=Y+DD
+2 QUIT
