source: FOIAVistA/tag/r/CMOP-PSX/PSXCSHI.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.5 KB
Line 
1PSXCSHI ;BIR/JMB-High Cost Rx Report ;03/11/98 11:01 AM
2 ;;2.0;CMOP;**11,38**;11 Apr 97
3 ; Reference to ^PSDRUG supported by DBIA #1983
4 ;This routine compiles data for Rx's that cost over a specified dollar
5 ;amount for a specified date range.
6BEG W ! S %DT("A")="Beginning Date: ",%DT="APE" D ^%DT G:"^"[X EXIT G:Y<0 BEG S (%DT(0),PSXBDT)=Y
7 I Y>DT W !!,"Future Dates are not allowed!",! K %DT G BEG
8EN W ! S %DT("A")="Ending Date: " D ^%DT G:"^"[X EXIT G:Y<0 EN S PSXEDT=Y
9 S:$E(PSXBDT,6,7)="00" PSXBDT=$E(PSXBDT,1,5)_"01" S:$E(PSXEDT,6,7)="00" PSXEDT=$E(PSXEDT,1,5)_"31"
10 ;If no data in file, write error msg.
11 S PSXFND=$O(^PSX(552.4,"AD",PSXBDT-1))
12 I PSXFND>PSXEDT!(+PSXFND=0) S Y=PSXBDT X ^DD("DD") S PSXSDATE=Y,Y=PSXEDT X ^DD("DD") S PSXEDATE=Y
13 I W !!?4,"** There is no prescription data between "_PSXSDATE_" and "_PSXEDATE_". **" K PSXEDATE,PSXFND,PSXSDATE G EXIT
14FACYN ;Gets facility
15 K ^UTILITY("DIQ1",$J)
16 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
17FAC K PSXEDATE,PSXSDATE S DIC(0)="AEQMZ",DIC="^DIC(4,",DIC("A")="Select FACILITY: " D ^DIC K DIC G:$G(DTOUT)!($G(DUOUT)) EXIT
18 G:Y<0 FAC S XSITE=X,DA=+Y K Y
19 S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1
20 S PSXFAC=$G(^UTILITY("DIQ1",$J,4,DA,99,"I"))
21 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
22 K ^UTILITY("DIQ1",$J)
23 I '$D(^PSX(552.5,PSXFAC,0)) W !,"There is no data for "_XSITE G FACYN
24MAX ;Gets lowest $ amt to print
25 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"
26 D ^DIR K DIR G:$G(DIRUT) EXIT S PSXMAX=Y
27DEV ;Device handling
28 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
29 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)=""
30 I K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Report is queued!" K ZTSK G EXIT
31START ;Queued entry point
32 S Y=PSXBDT X ^DD("DD") S PSXBDTR=Y,Y=PSXEDT X ^DD("DD") S PSXEDTR=Y
33 ;Loops thru date range
34 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
35 .F PSXSUB=0:0 S PSXSUB=$O(^PSX(552.4,"AD",PSXDT,PSXIEN,PSXSUB)) Q:'PSXSUB D CHK
36 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
37 ;If no data, print report with error msg.
38 I '$D(^TMP($J)) D HD^PSXCSHI1 W !!,"<<< NO HIGH COST DATA FOUND. >>>" G EXIT
39 D PRINT^PSXCSHI1
40EXIT I $G(IOST)["C-" S DIR(0)="E" D ^DIR K DIR,DIRUT,DTOUT,DIROUT,DUOUT W @IOF
41 W ! W:$E(IOST)'["C" @IOF D ^%ZISC G END^PSXCSUTL
42CHK ;Sets ^TMP global
43 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)="")
44 I $D(PSXFAC) Q:+PSXFAC'=+$G(^PSX(552.1,+^PSX(552.4,PSXIEN,0),0))
45 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))
46 Q:'PSX50!('$D(^PSDRUG(PSX50,0))) S PSXDR0=^(0)
47 I 'PSXDRCST S PSXDRCST=$S($P($G(^PSDRUG(PSX50,660)),"^",6):+$P(^(660),"^",6),1:0)
48 S PSXCOST=PSXQTY*PSXDRCST Q:PSXCOST<PSXMAX
49 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
50 Q
Note: See TracBrowser for help on using the repository browser.