DGPMBSR ;ALB/LM - BED STATUS REPORT RECALCULATION; 16 JAN 91
;;5.3;Registration;;Aug 13, 1993
;
A I $S('$D(RC):1,'RC:1,1:0) Q ; RC=ReCalc from Date
D CLEAN^DGPMGLG
;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
; 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
; 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 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMBSR 1841 printed Mar 13, 2025@21:53:50 Page 2
DGPMBSR ;ALB/LM - BED STATUS REPORT RECALCULATION; 16 JAN 91
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
A ; RC=ReCalc from Date
IF $SELECT('$DATA(RC):1,'RC:1,1:0)
QUIT
+1 DO CLEAN^DGPMGLG
+2 ;D UP43 ; Update file 43
+3 SET DGP("RD")=RD
SET DGP("PD")=PD
SET DGP("GL")=GL
SET DGP("BS")=BS
SET DGP("TSR")=TSR
SET DGP("REM")=REM
+4 ; YD=YesterDay
SET X1=DT
SET X2=-1
DO C^%DTC
SET YD=X
+5 ; TSR initialization previous date
SET X1=PD
SET X2=-1
DO C^%DTC
SET TSRIPD=X
+6 SET (BS,GL,TSR)=0
SET DAYC=-1
+7 ; Steps thru days to do Recalc
+8 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 ^DGPMBSR1
DO ^DGPMBSR2
DO ^DGPMBSR3
DO ^DGPMBSR4
IF $DATA(^DGS(43.5,"AGL"))
DO DELETE
+9 ; Deletes ReCalc started and ReCalc up to from file 43
+10 SET DIE="^DG(43,"
SET DA=1
SET DR="52///@;53///@"
DO ^DIE
KILL DA,DIE,DR
+11 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
+12 ;
Q KILL PP,BD,C,D,DAYC,DGP,I,I1,T,W,X,X1,X2,DGI,DR,DA,DIE
QUIT
+1 ;
UP43 ; 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
+1 ; 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
+2 QUIT
+3 ;
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
