DGPMBSAR.m

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 ;