DGPMBSAR ;ALB/LM/MJK - RECALC ENTRY POINTS; [ 09/13/2001 3:55 PM ]
;;5.3;Registration;**85,1015**;Aug 13, 1993;Build 21
;IHS/ANMC/LJF 4/18/2001 removed check for VA only parameters
; bypassed auto queuing of recalc
;
A D PCHK^DGPMGL I E G ERR^DGPMGL ; Parameter check
D RCCK G:'$D(RCCK) Q ; Check for ReCalc already running
D PAR^DGPMGL ; Display parameters
;
ASK W ! S %DT("A")="RECALCULATE TOTALS FROM WHICH DATE: ",%DT="APE",%DT(0)=-(DT-1) D ^%DT K %DT G Q:Y'>0
S RC=+Y,X=$S($P(DGPM("G"),"^",7):$P(DGPM("G"),"^",7),1:+DGPM("G")) ; X=Earliest date ReCalc can be run ;
I RC<X S Y=X X ^DD("DD") W !!?4,*7,"Can't Recalculate data prior to ",Y,"!" G ASK
D DEFS
;
RPD ;W !!,"Recalculation of patient days could take up to 30 minutes longer per date..."
PR ;W !,"DO YOU WANT TO RECALCULATE PATIENT DAYS" S %=2 D YN^DICN
;I %=1!(%=2) S:%=1 REM=1 G QUE
;I %=-1 G Q
;W !?4,"Answer YES to recalculate patient days or NO to avoid this lengthy process.",!?4,"If you don't recalculate patient days then the appropriate statistical data"
;W !?4,"will be calculated based on the prior days remaining totals and the current",!?4,"(recalculation) days actual gains and losses. Unless you have a lot of"
;W !?4,"time on your hands or an obvious error exists recalculation of patient days",!?4,"is not normally recommended.",!
;G PR
;
QUE ; Recalculation Queue
;
;IHS/ANMC/LJF 4/18/2001 bypass auto-queue; run in foreground
;S ZTRTN="GO1^DGPMBSAR",ZTIO="",ZTDESC="BSR RECALCULATION" F I="DGPM(""G"")","RC","RD","PD","REM","GL","BS","TSR","TSRI","DIV","MT","TS","CP","RM","OS","VN","SF","TSD","SNM","RCCK","GLS" S ZTSAVE(I)=""
;K ZTSK D ^%ZTLOAD I $D(ZTSK) D UP43^DGPMBSR W !!,"Request Queued!"
D UP43^DGPMBSR G GO ;new IHS line
;IHS/ANMC/LJF 4/18/2001 end of new code
G Q
;
GO1 S DIE="^DG(43,",DA=1,DR="54////@;55////@;56////@" D ^DIE K DIE,DR,DA
GO D DAT,^DGPMBSR
Q K RCCK G DONE^DGPMGLG
Q
;
DAT ; -- get params and chk data
D DAT^DGPMGL,DEFS S E=0
I DGPM(0)="" S E=1 G DATQ
;F I=2,3,4,6:1:9 S C=I*.01 I $P(DGPM("G"),U,I)="" S E=1 ; modified re FORUM [#16205729];IHS/ANMC/LJF 4/18/2001
F I=7 S C=I*.01 I $P(DGPM("G"),U,I)="" S E=1 ;IHS/ANMC/LJF 4/18/2001 IHS only uses "recalc from" field"
DATQ Q
;
CLEAN ; -- clean up corrections file
S DGCDT=0,X=$P(DGPM(0),U,29) I X S X1=DT,X2=-X D C^%DTC S DGCDT=X
F DGI=0:0 S DGI=$O(^DGS(43.5,DGI)) Q:'DGI!(DGI>DGCDT) S DA=DGI,DIK="^DGS(43.5," D ^DIK
K DA,DIK
F DGCDT=0:0 S DGCDT=$O(^DGS(43.5,"AGL",DGCDT)) Q:'DGCDT!(DGCDT>EGL) F DGI=0:0 S DGI=$O(^DGS(43.5,"AGL",DGCDT,DGI)) Q:'DGI S DR=".08///@",DA=DGI,DIE="^DGS(43.5," D ^DIE
K DR,DA,DIE,DQ,DE,DG,DGCDT
Q
;
WDCHK ; -- chk first ward
S %=+$O(^DIC(42,"AGL",0)),WD=+$O(^(%,0))
S X=RC F J=1:1 S X1=X,X2=-1 D C^%DTC Q:X'>EGL!($D(^DG(41.9,WD,"C",X)))
S RC=X I X'=EGL S X1=X,X2=1 D C^%DTC S RC=X
K WD,%
Q
;
RCCK ; Check for ReCalc already running
K RCCK
I $P(DGPM("GLS"),"^",3) D RCR^DGPMGL Q ; ReCalc running
I $P(DGPM("GLS"),"^",5),$P(DGPM("GLS"),"^",4),$P(DGPM("GLS"),"^",6)]"" S ZTSK=$P(DGPM("GLS"),"^",4),ZTCPU=$P(DGPM("GLS"),"^",6)
D ISQED^%ZTLOAD
I ZTSK(0) S Y=$P(DGPM("GLS"),"^",5) X ^DD("DD") W !,"ReCalc Already Scheduled for ",Y,! Q
I $P(DGPM("GLS"),"^",5) S Y=$P(DGPM("GLS"),"^",5) X ^DD("DD") W !,"ReCalc appears to be scheduled for ",Y,!,"Do you wish to continue" S %=2 D YN^DICN Q:%=2!(%=-1) G RCCK:'%
S RCCK=1
Q
;
DEFS ; -- defaults for recalc
S %DT="",X="T" D ^%DT K %DT S DT=Y
S X1=DT,X2=-1 D C^%DTC S RD=X
S X1=X,X2=-1 D C^%DTC S PD=X
S (REM,GL,BS,TSR)=0
Q
;
VAR ; RC=ReCalc from date ; RD=Report Date ;
; PD=Previous Date ; REM=Recalc patient days ;
DGPMBSAR ;ALB/LM/MJK - RECALC ENTRY POINTS; [ 09/13/2001 3:55 PM ]
+1 ;;5.3;Registration;**85,1015**;Aug 13, 1993;Build 21
+2 ;IHS/ANMC/LJF 4/18/2001 removed check for VA only parameters
+3 ; bypassed auto queuing of recalc
+4 ;
A ; Parameter check
DO PCHK^DGPMGL
IF E
GOTO ERR^DGPMGL
+1 ; Check for ReCalc already running
DO RCCK
IF '$DATA(RCCK)
GOTO Q
+2 ; Display parameters
DO PAR^DGPMGL
+3 ;
ASK WRITE !
SET %DT("A")="RECALCULATE TOTALS FROM WHICH DATE: "
SET %DT="APE"
SET %DT(0)=-(DT-1)
DO ^%DT
KILL %DT
IF Y'>0
GOTO Q
+1 ; X=Earliest date ReCalc can be run ;
SET RC=+Y
SET X=$SELECT($PIECE(DGPM("G"),"^",7):$PIECE(DGPM("G"),"^",7),1:+DGPM("G"))
+2 IF RC<X
SET Y=X
XECUTE ^DD("DD")
WRITE !!?4,*7,"Can't Recalculate data prior to ",Y,"!"
GOTO ASK
+3 DO DEFS
+4 ;
RPD ;W !!,"Recalculation of patient days could take up to 30 minutes longer per date..."
PR ;W !,"DO YOU WANT TO RECALCULATE PATIENT DAYS" S %=2 D YN^DICN
+1 ;I %=1!(%=2) S:%=1 REM=1 G QUE
+2 ;I %=-1 G Q
+3 ;W !?4,"Answer YES to recalculate patient days or NO to avoid this lengthy process.",!?4,"If you don't recalculate patient days then the appropriate statistical data"
+4 ;W !?4,"will be calculated based on the prior days remaining totals and the current",!?4,"(recalculation) days actual gains and losses. Unless you have a lot of"
+5 ;W !?4,"time on your hands or an obvious error exists recalculation of patient days",!?4,"is not normally recommended.",!
+6 ;G PR
+7 ;
QUE ; Recalculation Queue
+1 ;
+2 ;IHS/ANMC/LJF 4/18/2001 bypass auto-queue; run in foreground
+3 ;S ZTRTN="GO1^DGPMBSAR",ZTIO="",ZTDESC="BSR RECALCULATION" F I="DGPM(""G"")","RC","RD","PD","REM","GL","BS","TSR","TSRI","DIV","MT","TS","CP","RM","OS","VN","SF","TSD","SNM","RCCK","GLS" S ZTSAVE(I)=""
+4 ;K ZTSK D ^%ZTLOAD I $D(ZTSK) D UP43^DGPMBSR W !!,"Request Queued!"
+5 ;new IHS line
DO UP43^DGPMBSR
GOTO GO
+6 ;IHS/ANMC/LJF 4/18/2001 end of new code
+7 GOTO Q
+8 ;
GO1 SET DIE="^DG(43,"
SET DA=1
SET DR="54////@;55////@;56////@"
DO ^DIE
KILL DIE,DR,DA
GO DO DAT
DO ^DGPMBSR
Q KILL RCCK
GOTO DONE^DGPMGLG
+1 QUIT
+2 ;
DAT ; -- get params and chk data
+1 DO DAT^DGPMGL
DO DEFS
SET E=0
+2 IF DGPM(0)=""
SET E=1
GOTO DATQ
+3 ;F I=2,3,4,6:1:9 S C=I*.01 I $P(DGPM("G"),U,I)="" S E=1 ; modified re FORUM [#16205729];IHS/ANMC/LJF 4/18/2001
+4 ;IHS/ANMC/LJF 4/18/2001 IHS only uses "recalc from" field"
FOR I=7
SET C=I*.01
IF $PIECE(DGPM("G"),U,I)=""
SET E=1
DATQ QUIT
+1 ;
CLEAN ; -- clean up corrections file
+1 SET DGCDT=0
SET X=$PIECE(DGPM(0),U,29)
IF X
SET X1=DT
SET X2=-X
DO C^%DTC
SET DGCDT=X
+2 FOR DGI=0:0
SET DGI=$ORDER(^DGS(43.5,DGI))
IF 'DGI!(DGI>DGCDT)
QUIT
SET DA=DGI
SET DIK="^DGS(43.5,"
DO ^DIK
+3 KILL DA,DIK
+4 FOR DGCDT=0:0
SET DGCDT=$ORDER(^DGS(43.5,"AGL",DGCDT))
IF 'DGCDT!(DGCDT>EGL)
QUIT
FOR DGI=0:0
SET DGI=$ORDER(^DGS(43.5,"AGL",DGCDT,DGI))
IF 'DGI
QUIT
SET DR=".08///@"
SET DA=DGI
SET DIE="^DGS(43.5,"
DO ^DIE
+5 KILL DR,DA,DIE,DQ,DE,DG,DGCDT
+6 QUIT
+7 ;
WDCHK ; -- chk first ward
+1 SET %=+$ORDER(^DIC(42,"AGL",0))
SET WD=+$ORDER(^(%,0))
+2 SET X=RC
FOR J=1:1
SET X1=X
SET X2=-1
DO C^%DTC
IF X'>EGL!($DATA(^DG(41.9,WD,"C",X)))
QUIT
+3 SET RC=X
IF X'=EGL
SET X1=X
SET X2=1
DO C^%DTC
SET RC=X
+4 KILL WD,%
+5 QUIT
+6 ;
RCCK ; Check for ReCalc already running
+1 KILL RCCK
+2 ; ReCalc running
IF $PIECE(DGPM("GLS"),"^",3)
DO RCR^DGPMGL
QUIT
+3 IF $PIECE(DGPM("GLS"),"^",5)
IF $PIECE(DGPM("GLS"),"^",4)
IF $PIECE(DGPM("GLS"),"^",6)]""
SET ZTSK=$PIECE(DGPM("GLS"),"^",4)
SET ZTCPU=$PIECE(DGPM("GLS"),"^",6)
+4 DO ISQED^%ZTLOAD
+5 IF ZTSK(0)
SET Y=$PIECE(DGPM("GLS"),"^",5)
XECUTE ^DD("DD")
WRITE !,"ReCalc Already Scheduled for ",Y,!
QUIT
+6 IF $PIECE(DGPM("GLS"),"^",5)
SET Y=$PIECE(DGPM("GLS"),"^",5)
XECUTE ^DD("DD")
WRITE !,"ReCalc appears to be scheduled for ",Y,!,"Do you wish to continue"
SET %=2
DO YN^DICN
IF %=2!(%=-1)
QUIT
IF '%
GOTO RCCK
+7 SET RCCK=1
+8 QUIT
+9 ;
DEFS ; -- defaults for recalc
+1 SET %DT=""
SET X="T"
DO ^%DT
KILL %DT
SET DT=Y
+2 SET X1=DT
SET X2=-1
DO C^%DTC
SET RD=X
+3 SET X1=X
SET X2=-1
DO C^%DTC
SET PD=X
+4 SET (REM,GL,BS,TSR)=0
+5 QUIT
+6 ;
VAR ; RC=ReCalc from date ; RD=Report Date ;
+1 ; PD=Previous Date ; REM=Recalc patient days ;
