source: FOIAVistA/tag/r/CMOP-PSX/PSXCSUTL.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.6 KB
Line 
1PSXCSUTL ;BIR/JMB-Utilities for Cost Routines ;[ 04/09/98 9:41 AM ]
2 ;;2.0;CMOP;**11,16,38**;11 Apr 97
3 ;reference to ^PSDRUG( supported by DBIA #1983
4NAME ;Gets drug name by looking up drug ID #
5 K PSXNAM S PSXI=$O(^PSDRUG("AQ1",PSXDGID,0))
6 S:PSXI PSXNAM=$P($G(^PSDRUG(PSXI,0)),"^")
7 S:'PSXI PSXNAM="UNKNOWN" K PSXI
8 Q
9MN ;Gets month & yr
10 S PSXRPT="MN"
11 S %DT("A")="Enter Month/Year: ",%DT="AQEP" D ^%DT I "^"[X S PSXOUT=1 Q
12 G:Y'>0 MN S PSXBDT=$E(Y,1,5)_"00",PSXEDT=$E(Y,1,5)_$P("31^29^31^30^31^30^31^31^30^31^30^31^","^",$E(Y,4,5))
13 S PSXFND=$O(^PSX(552.5,"AD",PSXBDT-1))
14 D:PSXFND>PSXEDT!(+PSXFND=0) NODATA Q:$G(PSXOUT) ;Determine if no data for date range
15IDYN K PSXEDATE,PSXSDATE W ! S DIR("A")="Do you want to look at data concerning a specific drug",DIR("B")="Y",DIR(0)="Y" D ^DIR K DIR I $G(DIRUT) S PSXOUT=1 Q
16 I 'Y G:$G(PSXRPT)="MN" FACYN G BEG
17ID S DIC="^PSDRUG(",DIC(0)="AEQMZ" S DIC("S")="I $P($G(^(""ND"")),U,10)]"""""
18 D ^DIC K DIC I $D(DTOUT)!$D(DUOUT) S PSXOUT=1 Q
19 G:X="" IDYN S PSXID=$P($G(^PSDRUG(+Y,"ND")),"^",10),PSXIDG=+Y
20 K X,Y
21 G:$G(PSXRPT)="MN" FACYN
22BEG W ! S %DT("A")="Beginning Date: ",%DT="AEP" D ^%DT I X["^" S PSXOUT=1 Q
23 G:Y<0 BEG S (%DT(0),PSXBDT)=Y
24 I Y>DT W !!,"Future dates are not allowed!",! K %DT G BEG
25EN W ! S %DT("A")="Ending Date: " D ^%DT I X["^" S PSXOUT=1 Q
26 G:Y<0 EN S PSXEDT=Y
27 S PSXFND=$O(^PSX(552.5,"AD",PSXBDT-1))
28 D:PSXFND>PSXEDT!(+PSXFND=0) NODATA Q:$G(PSXOUT) ;Determine if no data for date range
29FACYN ;Gets facility
30 K ^UTILITY("DIQ1",$J)
31 W ! S DIR("A")="Print data for a specific facility",DIR("B")="Y",DIR(0)="Y" D ^DIR K DIR I $G(DIRUT) S PSXOUT=1 Q
32FAC K PSXEDATE,PSXSDATE Q:'Y S DIC(0)="AEQMZ",DIC="^DIC(4,",DIC("A")="Select FACILITY: " D ^DIC K DIC G:$G(DTOUT)!($G(DUOUT)) END
33 G:Y<0 FAC S XSITE=X,DA=+Y K Y
34 S DIC=4,DIQ(0)="I",DR="99" D EN^DIQ1
35 S PSXFAC=$G(^UTILITY("DIQ1",$J,4,DA,99,"I"))
36 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
37 I '$D(^PSX(552.5,PSXFAC,0)) W !,"There is no data for "_XSITE G FACYN
38 W ! S DIR("A")="Print data for a specific division",DIR("B")="Y",DIR(0)="Y" D ^DIR K DIR I $G(DIRUT) S PSXOUT=1 Q
39DV Q:'Y S DIC(0)="AEQM",DIC="^PSX(552.5,"_PSXFAC_",1,",DIC("A")="Select DIVISION: " D ^DIC K DIC I $G(DTOUT)!($G(DUOUT)) S PSXOUT=1 Q
40 G:Y<0 DV S PSXIENDV=+Y,PSXDV=$P(Y,"^",2)
41 Q
42NODATA ;No data in file
43 S Y=PSXBDT X ^DD("DD") S PSXSDATE=Y,Y=PSXEDT X ^DD("DD") S PSXEDATE=Y W !!?4,"** There is no CMOP cost data between "_PSXSDATE_" and "_PSXEDATE_". **"
44 W !!?4,"Use the Date Range Compile/Recompile Cost Data option to compile the",!?4,"cost data for this date range." S PSXOUT=1 K PSXEDATE,PSXFND,PSXSDATE
45 Q
46END K ^TMP($J),%,%DT,%H,%T,%Y,%ZIS,DA,DIC,DIE,DIK,DINUM,DIR,DIRUT,DLAYGO,DR
47 K DTOUT,DUOUT,POP,PSX50,PSXAVCST,PSXAVG,PSXBDT,PSXBDTE,PSXBDTH,PSXBDTR
48 K PSXBEG,PSXBMN,PSXBY,PSXBYR,PSXCDT,PSXCID,PSXCMN,PSXCNT,PSXCNTO
49 K PSXCNTDV,PSXCNTR,PSXCOM,PSXCOST,PSXCST,PSXCUT,PSXCYR,PSXDG,PSXDGID
50 K PSXDIV,PSXDLN,PSXDT90,PSXDT90R,PSXDR0,PSXDRCST,PSXDT,PSXDV,PSXDVCNT
51 K PSXEDT,PSXEDTE,PSXEDTR,PSXEND,PSXEMN,PSXERR,PSXEXIT,PSXEYR,PSXFAC
52 K PSXFACN,PSXFACR,PSXFACYN,PSXFCID,PSXFL,PSXFLS,PSXFLD,PSXFND,PSXG
53 K PSXID,PSXI,PSXIDG,PSXIDV,PSXIEN,PSXIENDV,PSXJOB,PSXJOBE,PSXLAYGO
54 K PSXLGN,PSXLOC,PSXMAX,PSXMC,PSXMCDT,PSXMN,PSXMON,PSXNAM,PSXNEXT
55 K PSXNODE,PSXOUT,PSXPC,PSXPDT,PSXPG,PSXPSDT,PSXQTY,PSXRF,PSXRPT,PSXRUN
56 K PSXRXN,PSXSLN,PSXSPDV,PSXSUB,PSXT,PSXT1,PSXT2,PSXT3,PSXT4,PSXT5,PSXT6
57 K PSXTH,PSXTH1,PSXTH2,PSXTH3,PSXTH4,PSXTH5,PSXTH6,PSXTMP,PSXTOT,PSXVAPRT
58 K PSXX,PSXYR,X,X1,X2,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK,ZTIO
59 S:$D(ZTQUEUED) ZTREQ="@"
60 K PSXION,PSXSTA,PSXSTART,^UTILITY("DIQ1",$J) Q
Note: See TracBrowser for help on using the repository browser.