PSXCSHI ;BIR/JMB-High Cost Rx Report ;03/11/98 11:01 AM
;;2.0;CMOP;**11,38**;11 Apr 97
; Reference to ^PSDRUG supported by DBIA #1983
;This routine compiles data for Rx's that cost over a specified dollar
;amount for a specified date range.
BEG W ! S %DT("A")="Beginning Date: ",%DT="APE" D ^%DT G:"^"[X EXIT G:Y<0 BEG S (%DT(0),PSXBDT)=Y
I Y>DT W !!,"Future Dates are not allowed!",! K %DT G BEG
EN W ! S %DT("A")="Ending Date: " D ^%DT G:"^"[X EXIT G:Y<0 EN S PSXEDT=Y
S:$E(PSXBDT,6,7)="00" PSXBDT=$E(PSXBDT,1,5)_"01" S:$E(PSXEDT,6,7)="00" PSXEDT=$E(PSXEDT,1,5)_"31"
;If no data in file, write error msg.
S PSXFND=$O(^PSX(552.4,"AD",PSXBDT-1))
I PSXFND>PSXEDT!(+PSXFND=0) S Y=PSXBDT X ^DD("DD") S PSXSDATE=Y,Y=PSXEDT X ^DD("DD") S PSXEDATE=Y
I W !!?4,"** There is no prescription data between "_PSXSDATE_" and "_PSXEDATE_". **" K PSXEDATE,PSXFND,PSXSDATE G EXIT
FACYN ;Gets facility
K ^UTILITY("DIQ1",$J)
W ! S DIR("A")="Print data for a specific facility",DIR("B")="Y",DIR(0)="Y" D ^DIR K DIR G:$G(DIRUT) EXIT G:'Y MAX
FAC K PSXEDATE,PSXSDATE S DIC(0)="AEQMZ",DIC="^DIC(4,",DIC("A")="Select FACILITY: " D ^DIC K DIC G:$G(DTOUT)!($G(DUOUT)) EXIT
G:Y<0 FAC S XSITE=X,DA=+Y K Y
S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1
S PSXFAC=$G(^UTILITY("DIQ1",$J,4,DA,99,"I"))
I 'PSXFAC S DA(1)=DA,DA=1,IENS=DA_","_DA(1),PSXFAC=$$GET1^DIQ(4.9999,IENS,.02) I +PSXFAC S PSXFAC=1_PSXFAC ;****DOD L1
K ^UTILITY("DIQ1",$J)
I '$D(^PSX(552.5,PSXFAC,0)) W !,"There is no data for "_XSITE G FACYN
MAX ;Gets lowest $ amt to print
W ! S DIR("A")="Dollar Limit (Minimum Total Cost) ",DIR("B")=30,DIR(0)="N^0:9999:2",DIR("?")="Enter a dollar amount between 0-9999 with no more than two decimals"
D ^DIR K DIR G:$G(DIRUT) EXIT S PSXMAX=Y
DEV ;Device handling
W ! S PSXION=ION,%ZIS="QM" D ^%ZIS K %ZIS I POP S IOP=PSXION D ^%ZIS K IOP,PSXION W !,"Please try later!" G EXIT
K PSXION I $D(IO("Q")) S ZTDESC="CMOP High Cost Report",ZTRTN="START^PSXCSHI" F PSXG="PSXBDT","PSXEDT","PSXFAC","PSXMAX" S:$D(@PSXG) ZTSAVE(PSXG)=""
I K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Report is queued!" K ZTSK G EXIT
START ;Queued entry point
S Y=PSXBDT X ^DD("DD") S PSXBDTR=Y,Y=PSXEDT X ^DD("DD") S PSXEDTR=Y
;Loops thru date range
F PSXDT=PSXBDT-1:0 S PSXDT=$O(^PSX(552.4,"AD",PSXDT)) Q:'PSXDT!(PSXDT>PSXEDT) F PSXIEN=0:0 S PSXIEN=+$O(^PSX(552.4,"AD",PSXDT,PSXIEN)) Q:'PSXIEN D
.F PSXSUB=0:0 S PSXSUB=$O(^PSX(552.4,"AD",PSXDT,PSXIEN,PSXSUB)) Q:'PSXSUB D CHK
U IO S PSXCNT=0,PSXPG=1,PSXFAC=$S(+$G(PSXFAC):+PSXFAC,1:$O(^TMP($J,0))) D NOW^%DTC S Y=% D DD^%DT S PSXPDT=Y
;If no data, print report with error msg.
I '$D(^TMP($J)) D HD^PSXCSHI1 W !!,"<<< NO HIGH COST DATA FOUND. >>>" G EXIT
D PRINT^PSXCSHI1
EXIT I $G(IOST)["C-" S DIR(0)="E" D ^DIR K DIR,DIRUT,DTOUT,DIROUT,DUOUT W @IOF
W ! W:$E(IOST)'["C" @IOF D ^%ZISC G END^PSXCSUTL
CHK ;Sets ^TMP global
Q:'$D(^PSX(552.4,PSXIEN,0))!($P($G(^PSX(552.4,PSXIEN,1,PSXSUB,0)),"^",2)=2)!($P($G(^PSX(552.4,PSXIEN,1,PSXSUB,0)),"^",4)="")
I $D(PSXFAC) Q:+PSXFAC'=+$G(^PSX(552.1,+^PSX(552.4,PSXIEN,0),0))
S PSXNODE=^PSX(552.4,PSXIEN,1,PSXSUB,0),PSXRXN=$P(PSXNODE,"^"),PSXFL=$P(PSXNODE,"^",12),PSXID=$P(PSXNODE,"^",4),PSXQTY=$P(PSXNODE,"^",13),PSXDRCST=$P(PSXNODE,"^",11),PSX50=+$O(^PSDRUG("AQ1",PSXID,0))
Q:'PSX50!('$D(^PSDRUG(PSX50,0))) S PSXDR0=^(0)
I 'PSXDRCST S PSXDRCST=$S($P($G(^PSDRUG(PSX50,660)),"^",6):+$P(^(660),"^",6),1:0)
S PSXCOST=PSXQTY*PSXDRCST Q:PSXCOST<PSXMAX
S ^TMP($J,$S($G(PSXFAC):+PSXFAC,1:+$G(^PSX(552.1,+^PSX(552.4,PSXIEN,0),0))),$E($P(PSXDR0,"^"),1,34),PSXRXN,PSXIEN)=PSXFL_"^"_PSXQTY_"^"_PSXDRCST_"^"_PSXCOST
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXCSHI 3617 printed Apr 09, 2024@20:50:33 Page 2
PSXCSHI ;BIR/JMB-High Cost Rx Report ;03/11/98 11:01 AM
+1 ;;2.0;CMOP;**11,38**;11 Apr 97
+2 ; Reference to ^PSDRUG supported by DBIA #1983
+3 ;This routine compiles data for Rx's that cost over a specified dollar
+4 ;amount for a specified date range.
BEG WRITE !
SET %DT("A")="Beginning Date: "
SET %DT="APE"
DO ^%DT
if "^"[X
GOTO EXIT
if Y<0
GOTO BEG
SET (%DT(0),PSXBDT)=Y
+1 IF Y>DT
WRITE !!,"Future Dates are not allowed!",!
KILL %DT
GOTO BEG
EN WRITE !
SET %DT("A")="Ending Date: "
DO ^%DT
if "^"[X
GOTO EXIT
if Y<0
GOTO EN
SET PSXEDT=Y
+1 if $EXTRACT(PSXBDT,6,7)="00"
SET PSXBDT=$EXTRACT(PSXBDT,1,5)_"01"
if $EXTRACT(PSXEDT,6,7)="00"
SET PSXEDT=$EXTRACT(PSXEDT,1,5)_"31"
+2 ;If no data in file, write error msg.
+3 SET PSXFND=$ORDER(^PSX(552.4,"AD",PSXBDT-1))
+4 IF PSXFND>PSXEDT!(+PSXFND=0)
SET Y=PSXBDT
XECUTE ^DD("DD")
SET PSXSDATE=Y
SET Y=PSXEDT
XECUTE ^DD("DD")
SET PSXEDATE=Y
+5 IF $TEST
WRITE !!?4,"** There is no prescription data between "_PSXSDATE_" and "_PSXEDATE_". **"
KILL PSXEDATE,PSXFND,PSXSDATE
GOTO EXIT
FACYN ;Gets facility
+1 KILL ^UTILITY("DIQ1",$JOB)
+2 WRITE !
SET DIR("A")="Print data for a specific facility"
SET DIR("B")="Y"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
if $GET(DIRUT)
GOTO EXIT
if 'Y
GOTO MAX
FAC KILL PSXEDATE,PSXSDATE
SET DIC(0)="AEQMZ"
SET DIC="^DIC(4,"
SET DIC("A")="Select FACILITY: "
DO ^DIC
KILL DIC
if $GET(DTOUT)!($GET(DUOUT))
GOTO EXIT
+1 if Y<0
GOTO FAC
SET XSITE=X
SET DA=+Y
KILL Y
+2 SET DIC=4
SET DIQ(0)="I"
SET DR="99"
DO EN^DIQ1
+3 SET PSXFAC=$GET(^UTILITY("DIQ1",$JOB,4,DA,99,"I"))
+4 ;****DOD L1
IF 'PSXFAC
SET DA(1)=DA
SET DA=1
SET IENS=DA_","_DA(1)
SET PSXFAC=$$GET1^DIQ(4.9999,IENS,.02)
IF +PSXFAC
SET PSXFAC=1_PSXFAC
+5 KILL ^UTILITY("DIQ1",$JOB)
+6 IF '$DATA(^PSX(552.5,PSXFAC,0))
WRITE !,"There is no data for "_XSITE
GOTO FACYN
MAX ;Gets lowest $ amt to print
+1 WRITE !
SET DIR("A")="Dollar Limit (Minimum Total Cost) "
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"
+2 DO ^DIR
KILL DIR
if $GET(DIRUT)
GOTO EXIT
SET PSXMAX=Y
DEV ;Device handling
+1 WRITE !
SET PSXION=ION
SET %ZIS="QM"
DO ^%ZIS
KILL %ZIS
IF POP
SET IOP=PSXION
DO ^%ZIS
KILL IOP,PSXION
WRITE !,"Please try later!"
GOTO EXIT
+2 KILL PSXION
IF $DATA(IO("Q"))
SET ZTDESC="CMOP High Cost Report"
SET ZTRTN="START^PSXCSHI"
FOR PSXG="PSXBDT","PSXEDT","PSXFAC","PSXMAX"
if $DATA(@PSXG)
SET ZTSAVE(PSXG)=""
+3 IF $TEST
KILL IO("Q")
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report is queued!"
KILL ZTSK
GOTO EXIT
START ;Queued entry point
+1 SET Y=PSXBDT
XECUTE ^DD("DD")
SET PSXBDTR=Y
SET Y=PSXEDT
XECUTE ^DD("DD")
SET PSXEDTR=Y
+2 ;Loops thru date range
+3 FOR PSXDT=PSXBDT-1:0
SET PSXDT=$ORDER(^PSX(552.4,"AD",PSXDT))
if 'PSXDT!(PSXDT>PSXEDT)
QUIT
FOR PSXIEN=0:0
SET PSXIEN=+$ORDER(^PSX(552.4,"AD",PSXDT,PSXIEN))
if 'PSXIEN
QUIT
Begin DoDot:1
+4 FOR PSXSUB=0:0
SET PSXSUB=$ORDER(^PSX(552.4,"AD",PSXDT,PSXIEN,PSXSUB))
if 'PSXSUB
QUIT
DO CHK
End DoDot:1
+5 USE IO
SET PSXCNT=0
SET PSXPG=1
SET PSXFAC=$SELECT(+$GET(PSXFAC):+PSXFAC,1:$ORDER(^TMP($JOB,0)))
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET PSXPDT=Y
+6 ;If no data, print report with error msg.
+7 IF '$DATA(^TMP($JOB))
DO HD^PSXCSHI1
WRITE !!,"<<< NO HIGH COST DATA FOUND. >>>"
GOTO EXIT
+8 DO PRINT^PSXCSHI1
EXIT IF $GET(IOST)["C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR,DIRUT,DTOUT,DIROUT,DUOUT
WRITE @IOF
+1 WRITE !
if $EXTRACT(IOST)'["C"
WRITE @IOF
DO ^%ZISC
GOTO END^PSXCSUTL
CHK ;Sets ^TMP global
+1 if '$DATA(^PSX(552.4,PSXIEN,0))!($PIECE($GET(^PSX(552.4,PSXIEN,1,PSXSUB,0)),"^",2)=2)!($PIECE($GET(^PSX(552.4,PSXIEN,1,PSXSUB,0)),"^",4)="")
QUIT
+2 IF $DATA(PSXFAC)
if +PSXFAC'=+$GET(^PSX(552.1,+^PSX(552.4,PSXIEN,0),0))
QUIT
+3 SET PSXNODE=^PSX(552.4,PSXIEN,1,PSXSUB,0)
SET PSXRXN=$PIECE(PSXNODE,"^")
SET PSXFL=$PIECE(PSXNODE,"^",12)
SET PSXID=$PIECE(PSXNODE,"^",4)
SET PSXQTY=$PIECE(PSXNODE,"^",13)
SET PSXDRCST=$PIECE(PSXNODE,"^",11)
SET PSX50=+$ORDER(^PSDRUG("AQ1",PSXID,0))
+4 if 'PSX50!('$DATA(^PSDRUG(PSX50,0)))
QUIT
SET PSXDR0=^(0)
+5 IF 'PSXDRCST
SET PSXDRCST=$SELECT($PIECE($GET(^PSDRUG(PSX50,660)),"^",6):+$PIECE(^(660),"^",6),1:0)
+6 SET PSXCOST=PSXQTY*PSXDRCST
if PSXCOST<PSXMAX
QUIT
+7 SET ^TMP($JOB,$SELECT($GET(PSXFAC):+PSXFAC,1:+$GET(^PSX(552.1,+^PSX(552.4,PSXIEN,0),0))),$EXTRACT($PIECE(PSXDR0,"^"),1,34),PSXRXN,PSXIEN)=PSXFL_"^"_PSXQTY_"^"_PSXDRCST_"^"_PSXCOST
+8 QUIT
