PSXCSUTL ;BIR/JMB-Utilities for Cost Routines ;[ 04/09/98 9:41 AM ]
;;2.0;CMOP;**11,16,38**;11 Apr 97
;reference to ^PSDRUG( supported by DBIA #1983
NAME ;Gets drug name by looking up drug ID #
K PSXNAM S PSXI=$O(^PSDRUG("AQ1",PSXDGID,0))
S:PSXI PSXNAM=$P($G(^PSDRUG(PSXI,0)),"^")
S:'PSXI PSXNAM="UNKNOWN" K PSXI
Q
MN ;Gets month & yr
S PSXRPT="MN"
S %DT("A")="Enter Month/Year: ",%DT="AQEP" D ^%DT I "^"[X S PSXOUT=1 Q
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))
S PSXFND=$O(^PSX(552.5,"AD",PSXBDT-1))
D:PSXFND>PSXEDT!(+PSXFND=0) NODATA Q:$G(PSXOUT) ;Determine if no data for date range
IDYN 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
I 'Y G:$G(PSXRPT)="MN" FACYN G BEG
ID S DIC="^PSDRUG(",DIC(0)="AEQMZ" S DIC("S")="I $P($G(^(""ND"")),U,10)]"""""
D ^DIC K DIC I $D(DTOUT)!$D(DUOUT) S PSXOUT=1 Q
G:X="" IDYN S PSXID=$P($G(^PSDRUG(+Y,"ND")),"^",10),PSXIDG=+Y
K X,Y
G:$G(PSXRPT)="MN" FACYN
BEG W ! S %DT("A")="Beginning Date: ",%DT="AEP" D ^%DT I X["^" S PSXOUT=1 Q
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 I X["^" S PSXOUT=1 Q
G:Y<0 EN S PSXEDT=Y
S PSXFND=$O(^PSX(552.5,"AD",PSXBDT-1))
D:PSXFND>PSXEDT!(+PSXFND=0) NODATA Q:$G(PSXOUT) ;Determine if no data for date range
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 I $G(DIRUT) S PSXOUT=1 Q
FAC 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
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
I '$D(^PSX(552.5,PSXFAC,0)) W !,"There is no data for "_XSITE G FACYN
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
DV 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
G:Y<0 DV S PSXIENDV=+Y,PSXDV=$P(Y,"^",2)
Q
NODATA ;No data in file
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_". **"
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
Q
END K ^TMP($J),%,%DT,%H,%T,%Y,%ZIS,DA,DIC,DIE,DIK,DINUM,DIR,DIRUT,DLAYGO,DR
K DTOUT,DUOUT,POP,PSX50,PSXAVCST,PSXAVG,PSXBDT,PSXBDTE,PSXBDTH,PSXBDTR
K PSXBEG,PSXBMN,PSXBY,PSXBYR,PSXCDT,PSXCID,PSXCMN,PSXCNT,PSXCNTO
K PSXCNTDV,PSXCNTR,PSXCOM,PSXCOST,PSXCST,PSXCUT,PSXCYR,PSXDG,PSXDGID
K PSXDIV,PSXDLN,PSXDT90,PSXDT90R,PSXDR0,PSXDRCST,PSXDT,PSXDV,PSXDVCNT
K PSXEDT,PSXEDTE,PSXEDTR,PSXEND,PSXEMN,PSXERR,PSXEXIT,PSXEYR,PSXFAC
K PSXFACN,PSXFACR,PSXFACYN,PSXFCID,PSXFL,PSXFLS,PSXFLD,PSXFND,PSXG
K PSXID,PSXI,PSXIDG,PSXIDV,PSXIEN,PSXIENDV,PSXJOB,PSXJOBE,PSXLAYGO
K PSXLGN,PSXLOC,PSXMAX,PSXMC,PSXMCDT,PSXMN,PSXMON,PSXNAM,PSXNEXT
K PSXNODE,PSXOUT,PSXPC,PSXPDT,PSXPG,PSXPSDT,PSXQTY,PSXRF,PSXRPT,PSXRUN
K PSXRXN,PSXSLN,PSXSPDV,PSXSUB,PSXT,PSXT1,PSXT2,PSXT3,PSXT4,PSXT5,PSXT6
K PSXTH,PSXTH1,PSXTH2,PSXTH3,PSXTH4,PSXTH5,PSXTH6,PSXTMP,PSXTOT,PSXVAPRT
K PSXX,PSXYR,X,X1,X2,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK,ZTIO
S:$D(ZTQUEUED) ZTREQ="@"
K PSXION,PSXSTA,PSXSTART,^UTILITY("DIQ1",$J) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSXCSUTL 3721 printed Dec 13, 2024@01:43:57 Page 2
PSXCSUTL ;BIR/JMB-Utilities for Cost Routines ;[ 04/09/98 9:41 AM ]
+1 ;;2.0;CMOP;**11,16,38**;11 Apr 97
+2 ;reference to ^PSDRUG( supported by DBIA #1983
NAME ;Gets drug name by looking up drug ID #
+1 KILL PSXNAM
SET PSXI=$ORDER(^PSDRUG("AQ1",PSXDGID,0))
+2 if PSXI
SET PSXNAM=$PIECE($GET(^PSDRUG(PSXI,0)),"^")
+3 if 'PSXI
SET PSXNAM="UNKNOWN"
KILL PSXI
+4 QUIT
MN ;Gets month & yr
+1 SET PSXRPT="MN"
+2 SET %DT("A")="Enter Month/Year: "
SET %DT="AQEP"
DO ^%DT
IF "^"[X
SET PSXOUT=1
QUIT
+3 if Y'>0
GOTO MN
SET PSXBDT=$EXTRACT(Y,1,5)_"00"
SET PSXEDT=$EXTRACT(Y,1,5)_$PIECE("31^29^31^30^31^30^31^31^30^31^30^31^","^",$EXTRACT(Y,4,5))
+4 SET PSXFND=$ORDER(^PSX(552.5,"AD",PSXBDT-1))
+5 ;Determine if no data for date range
if PSXFND>PSXEDT!(+PSXFND=0)
DO NODATA
if $GET(PSXOUT)
QUIT
IDYN KILL PSXEDATE,PSXSDATE
WRITE !
SET DIR("A")="Do you want to look at data concerning a specific drug"
SET DIR("B")="Y"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
IF $GET(DIRUT)
SET PSXOUT=1
QUIT
+1 IF 'Y
if $GET(PSXRPT)="MN"
GOTO FACYN
GOTO BEG
ID SET DIC="^PSDRUG("
SET DIC(0)="AEQMZ"
SET DIC("S")="I $P($G(^(""ND"")),U,10)]"""""
+1 DO ^DIC
KILL DIC
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PSXOUT=1
QUIT
+2 if X=""
GOTO IDYN
SET PSXID=$PIECE($GET(^PSDRUG(+Y,"ND")),"^",10)
SET PSXIDG=+Y
+3 KILL X,Y
+4 if $GET(PSXRPT)="MN"
GOTO FACYN
BEG WRITE !
SET %DT("A")="Beginning Date: "
SET %DT="AEP"
DO ^%DT
IF X["^"
SET PSXOUT=1
QUIT
+1 if Y<0
GOTO BEG
SET (%DT(0),PSXBDT)=Y
+2 IF Y>DT
WRITE !!,"Future dates are not allowed!",!
KILL %DT
GOTO BEG
EN WRITE !
SET %DT("A")="Ending Date: "
DO ^%DT
IF X["^"
SET PSXOUT=1
QUIT
+1 if Y<0
GOTO EN
SET PSXEDT=Y
+2 SET PSXFND=$ORDER(^PSX(552.5,"AD",PSXBDT-1))
+3 ;Determine if no data for date range
if PSXFND>PSXEDT!(+PSXFND=0)
DO NODATA
if $GET(PSXOUT)
QUIT
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)
SET PSXOUT=1
QUIT
FAC KILL PSXEDATE,PSXSDATE
if 'Y
QUIT
SET DIC(0)="AEQMZ"
SET DIC="^DIC(4,"
SET DIC("A")="Select FACILITY: "
DO ^DIC
KILL DIC
if $GET(DTOUT)!($GET(DUOUT))
GOTO END
+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 IF '$DATA(^PSX(552.5,PSXFAC,0))
WRITE !,"There is no data for "_XSITE
GOTO FACYN
+6 WRITE !
SET DIR("A")="Print data for a specific division"
SET DIR("B")="Y"
SET DIR(0)="Y"
DO ^DIR
KILL DIR
IF $GET(DIRUT)
SET PSXOUT=1
QUIT
DV if 'Y
QUIT
SET DIC(0)="AEQM"
SET DIC="^PSX(552.5,"_PSXFAC_",1,"
SET DIC("A")="Select DIVISION: "
DO ^DIC
KILL DIC
IF $GET(DTOUT)!($GET(DUOUT))
SET PSXOUT=1
QUIT
+1 if Y<0
GOTO DV
SET PSXIENDV=+Y
SET PSXDV=$PIECE(Y,"^",2)
+2 QUIT
NODATA ;No data in file
+1 SET Y=PSXBDT
XECUTE ^DD("DD")
SET PSXSDATE=Y
SET Y=PSXEDT
XECUTE ^DD("DD")
SET PSXEDATE=Y
WRITE !!?4,"** There is no CMOP cost data between "_PSXSDATE_" and "_PSXEDATE_". **"
+2 WRITE !!?4,"Use the Date Range Compile/Recompile Cost Data option to compile the",!?4,"cost data for this date range."
SET PSXOUT=1
KILL PSXEDATE,PSXFND,PSXSDATE
+3 QUIT
END KILL ^TMP($JOB),%,%DT,%H,%T,%Y,%ZIS,DA,DIC,DIE,DIK,DINUM,DIR,DIRUT,DLAYGO,DR
+1 KILL DTOUT,DUOUT,POP,PSX50,PSXAVCST,PSXAVG,PSXBDT,PSXBDTE,PSXBDTH,PSXBDTR
+2 KILL PSXBEG,PSXBMN,PSXBY,PSXBYR,PSXCDT,PSXCID,PSXCMN,PSXCNT,PSXCNTO
+3 KILL PSXCNTDV,PSXCNTR,PSXCOM,PSXCOST,PSXCST,PSXCUT,PSXCYR,PSXDG,PSXDGID
+4 KILL PSXDIV,PSXDLN,PSXDT90,PSXDT90R,PSXDR0,PSXDRCST,PSXDT,PSXDV,PSXDVCNT
+5 KILL PSXEDT,PSXEDTE,PSXEDTR,PSXEND,PSXEMN,PSXERR,PSXEXIT,PSXEYR,PSXFAC
+6 KILL PSXFACN,PSXFACR,PSXFACYN,PSXFCID,PSXFL,PSXFLS,PSXFLD,PSXFND,PSXG
+7 KILL PSXID,PSXI,PSXIDG,PSXIDV,PSXIEN,PSXIENDV,PSXJOB,PSXJOBE,PSXLAYGO
+8 KILL PSXLGN,PSXLOC,PSXMAX,PSXMC,PSXMCDT,PSXMN,PSXMON,PSXNAM,PSXNEXT
+9 KILL PSXNODE,PSXOUT,PSXPC,PSXPDT,PSXPG,PSXPSDT,PSXQTY,PSXRF,PSXRPT,PSXRUN
+10 KILL PSXRXN,PSXSLN,PSXSPDV,PSXSUB,PSXT,PSXT1,PSXT2,PSXT3,PSXT4,PSXT5,PSXT6
+11 KILL PSXTH,PSXTH1,PSXTH2,PSXTH3,PSXTH4,PSXTH5,PSXTH6,PSXTMP,PSXTOT,PSXVAPRT
+12 KILL PSXX,PSXYR,X,X1,X2,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK,ZTIO
+13 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+14 KILL PSXION,PSXSTA,PSXSTART,^UTILITY("DIQ1",$JOB)
QUIT
