DGPMBSR.m

DGPMBSR ;ALB/LM - BED STATUS REPORT RECALCULATION; [ 05/30/2002  1:17 PM ]

 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 ;IHS/ANMC/LJF  3/30/2001 added call to purge IHS files

 ;                        changed call to calculate census

 ;              3/31/2001 stoppd updating file with auto-queue info

 ;

A I $S('$D(RC):1,'RC:1,1:0) Q  ;  RC=ReCalc from Date

 D CLEAN^DGPMGLG

 ;

 ;D PURG^BDGAD0(PD)  ;IHS/ANMC/LJF 3/30/2001 (per LJF4)

 D PURG^BDGAD0(RC-1)  ;IHS/ANMC/LJF 3/30/2001;5/30/2002  (per LJF4)

 ;D UP43 ;  Update file 43

 S DGP("RD")=RD,DGP("PD")=PD,DGP("GL")=GL,DGP("BS")=BS,DGP("TSR")=TSR,DGP("REM")=REM

 S X1=DT,X2=-1 D C^%DTC S YD=X ;  YD=YesterDay

 S X1=PD,X2=-1 D C^%DTC S TSRIPD=X ;  TSR initialization previous date

 S (BS,GL,TSR)=0,DAYC=-1

 ;

 ;IHS/ANMC/LJF 3/30/2001 use IHS code to calculate census

 ;  Steps thru days to do Recalc

 ;F PP=1:1 S X1=RC,DAYC=DAYC+1,X2=DAYC D C^%DTC S (RD,X1)=X,X2=-1 D C^%DTC S PD=X Q:RD>YD!('PD)  D ^DGPMBSR1,^DGPMBSR2,^DGPMBSR3,^DGPMBSR4 I $D(^DGS(43.5,"AGL")) D DELETE

 F PP=1:1 S X1=RC,DAYC=DAYC+1,X2=DAYC D C^%DTC S (RD,X1)=X,X2=-1 D C^%DTC S PD=X Q:RD>YD!('PD)  D ^BDGAD1 I $D(^DGS(43.5,"AGL")) D DELETE

 ;IHS/ANMC/LJF 3/30/2001 end of code changes

 ;

 ;  Deletes ReCalc started and ReCalc up to from file 43

 S DIE="^DG(43,",DA=1,DR="52///@;53///@" D ^DIE K DA,DIE,DR

 S RD=DGP("RD"),PD=DGP("PD"),GL=DGP("GL"),BS=DGP("BS"),TSR=DGP("TSR"),REM=DGP("REM"),RC=0

 ;

Q K PP,BD,C,D,DAYC,DGP,I,I1,T,W,X,X1,X2,DGI,DR,DA,DIE Q

 ;

UP43 ;

 Q  ;IHS/ANMC/LJF 3/31/2001 stop updating auto-queue info

 I $D(ZTSK),ZTSK]"",$D(^%ZTSK(ZTSK)) S DGX=$P(^%ZTSK(ZTSK,0),"^",6),%H=$P(DGX,",") D YMD^%DTC S DGX=$P(DGX,",",2),Z=X_((DGX#3600\60)/100+(DGX\3600)/100) K DGX ;  Find time queued

 S Y="" S:$D(^%ZOSF("VOL")) Y=^("VOL") S:'$D(ZTSK) ZTSK="" S:'$D(Z) Z="N" S DIE="^DG(43,",DA=1,DR="52///N;54///"_ZTSK_";55///"_$S(Z'="N":"/",1:"")_Z_";56///"_Y D ^DIE K ZTSK,IO("Q"),DA,DIE,DR ;  Update file 43

 Q

 ;

DELETE ; Nulls earliest date to correct in the G&L Corrections file once that date has been recalculated and set recalculation date

 F I=0:0 S I=$O(^DGS(43.5,"AGL",I)) Q:'I  F DGI=0:0 S DGI=$O(^DGS(43.5,"AGL",I,DGI)) Q:'DGI  S DR=".08///@;10////"_DT,DA=DGI,DIE="^DGS(43.5," D ^DIE ; S $P(^DGS(43.5,DA,10),"^")=DT

 Q

 ;

VAR ;  RC=ReCalc from date  ;  YD=YesterDay  ;  RD=Report Date  ;

 ;  BS=Bed Status  ;  GL=G&L  ;  REM=Recalc patient days  ;

 ;  PD=Previous Day  ;  W=Ward  ;  D=Division  ;  T=Treating Speciality

DGPMBSR   ;ALB/LM - BED STATUS REPORT RECALCULATION; [ 05/30/2002  1:17 PM ]

 +1       ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 +2       ;IHS/ANMC/LJF  3/30/2001 added call to purge IHS files

 +3       ;                        changed call to calculate census

 +4       ;              3/31/2001 stoppd updating file with auto-queue info

 +5       ;

A         ;  RC=ReCalc from Date

           IF $SELECT('$DATA(RC):1,'RC:1,1:0)

               QUIT 

 +1        DO CLEAN^DGPMGLG

 +2       ;

 +3       ;D PURG^BDGAD0(PD)  ;IHS/ANMC/LJF 3/30/2001 (per LJF4)

 +4       ;IHS/ANMC/LJF 3/30/2001;5/30/2002  (per LJF4)

           DO PURG^BDGAD0(RC-1)

 +5       ;D UP43 ;  Update file 43

 +6        SET DGP("RD")=RD

           SET DGP("PD")=PD

           SET DGP("GL")=GL

           SET DGP("BS")=BS

           SET DGP("TSR")=TSR

           SET DGP("REM")=REM

 +7       ;  YD=YesterDay

           SET X1=DT

           SET X2=-1

           DO C^%DTC

           SET YD=X

 +8       ;  TSR initialization previous date

           SET X1=PD

           SET X2=-1

           DO C^%DTC

           SET TSRIPD=X

 +9        SET (BS,GL,TSR)=0

           SET DAYC=-1

 +10      ;

 +11      ;IHS/ANMC/LJF 3/30/2001 use IHS code to calculate census

 +12      ;  Steps thru days to do Recalc

 +13      ;F PP=1:1 S X1=RC,DAYC=DAYC+1,X2=DAYC D C^%DTC S (RD,X1)=X,X2=-1 D C^%DTC S PD=X Q:RD>YD!('PD)  D ^DGPMBSR1,^DGPMBSR2,^DGPMBSR3,^DGPMBSR4 I $D(^DGS(43.5,"AGL")) D DELETE

 +14       FOR PP=1:1

               SET X1=RC

               SET DAYC=DAYC+1

               SET X2=DAYC

               DO C^%DTC

               SET (RD,X1)=X

               SET X2=-1

               DO C^%DTC

               SET PD=X

               IF RD>YD!('PD)

                   QUIT 

               DO ^BDGAD1

               IF $DATA(^DGS(43.5,"AGL"))

                   DO DELETE

 +15      ;IHS/ANMC/LJF 3/30/2001 end of code changes

 +16      ;

 +17      ;  Deletes ReCalc started and ReCalc up to from file 43

 +18       SET DIE="^DG(43,"

           SET DA=1

           SET DR="52///@;53///@"

           DO ^DIE

           KILL DA,DIE,DR

 +19       SET RD=DGP("RD")

           SET PD=DGP("PD")

           SET GL=DGP("GL")

           SET BS=DGP("BS")

           SET TSR=DGP("TSR")

           SET REM=DGP("REM")

           SET RC=0

 +20      ;

Q          KILL PP,BD,C,D,DAYC,DGP,I,I1,T,W,X,X1,X2,DGI,DR,DA,DIE

           QUIT 

 +1       ;

UP43      ;

 +1       ;IHS/ANMC/LJF 3/31/2001 stop updating auto-queue info

           QUIT 

 +2       ;  Find time queued

           IF $DATA(ZTSK)

               IF ZTSK]""

                   IF $DATA(^%ZTSK(ZTSK))

                       SET DGX=$PIECE(^%ZTSK(ZTSK,0),"^",6)

                       SET %H=$PIECE(DGX,",")

                       DO YMD^%DTC

                       SET DGX=$PIECE(DGX,",",2)

                       SET Z=X_((DGX#3600\60)/100+(DGX\3600)/100)

                       KILL DGX

 +3       ;  Update file 43

           SET Y=""

           IF $DATA(^%ZOSF("VOL"))

               SET Y=^("VOL")

           IF '$DATA(ZTSK)

               SET ZTSK=""

           IF '$DATA(Z)

               SET Z="N"

           SET DIE="^DG(43,"

           SET DA=1

           SET DR="52///N;54///"_ZTSK_";55///"_$SELECT(Z'="N":"/",1:"")_Z_";56///"_Y

           DO ^DIE

           KILL ZTSK,IO("Q"),DA,DIE,DR

 +4        QUIT 

 +5       ;

DELETE    ; Nulls earliest date to correct in the G&L Corrections file once that date has been recalculated and set recalculation date

 +1       ; S $P(^DGS(43.5,DA,10),"^")=DT

           FOR I=0:0

               SET I=$ORDER(^DGS(43.5,"AGL",I))

               IF 'I

                   QUIT 

               FOR DGI=0:0

                   SET DGI=$ORDER(^DGS(43.5,"AGL",I,DGI))

                   IF 'DGI

                       QUIT 

                   SET DR=".08///@;10////"_DT

                   SET DA=DGI

                   SET DIE="^DGS(43.5,"

                   DO ^DIE

 +2        QUIT 

 +3       ;

VAR       ;  RC=ReCalc from date  ;  YD=YesterDay  ;  RD=Report Date  ;

 +1       ;  BS=Bed Status  ;  GL=G&L  ;  REM=Recalc patient days  ;

 +2       ;  PD=Previous Day  ;  W=Ward  ;  D=Division  ;  T=Treating Speciality