- 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 Feb 18, 2025@23:52:36 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