Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPMBSR

DGPMBSR.m

Go to the documentation of this file.
  1. DGPMBSR ;ALB/LM - BED STATUS REPORT RECALCULATION; [ 05/30/2002 1:17 PM ]
  1. ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
  1. ;IHS/ANMC/LJF 3/30/2001 added call to purge IHS files
  1. ; changed call to calculate census
  1. ; 3/31/2001 stoppd updating file with auto-queue info
  1. ;
  1. A I $S('$D(RC):1,'RC:1,1:0) Q ; RC=ReCalc from Date
  1. D CLEAN^DGPMGLG
  1. ;
  1. ;D PURG^BDGAD0(PD) ;IHS/ANMC/LJF 3/30/2001 (per LJF4)
  1. D PURG^BDGAD0(RC-1) ;IHS/ANMC/LJF 3/30/2001;5/30/2002 (per LJF4)
  1. ;D UP43 ; Update file 43
  1. S DGP("RD")=RD,DGP("PD")=PD,DGP("GL")=GL,DGP("BS")=BS,DGP("TSR")=TSR,DGP("REM")=REM
  1. S X1=DT,X2=-1 D C^%DTC S YD=X ; YD=YesterDay
  1. S X1=PD,X2=-1 D C^%DTC S TSRIPD=X ; TSR initialization previous date
  1. S (BS,GL,TSR)=0,DAYC=-1
  1. ;
  1. ;IHS/ANMC/LJF 3/30/2001 use IHS code to calculate census
  1. ; Steps thru days to do Recalc
  1. ;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
  1. 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
  1. ;IHS/ANMC/LJF 3/30/2001 end of code changes
  1. ;
  1. ; Deletes ReCalc started and ReCalc up to from file 43
  1. S DIE="^DG(43,",DA=1,DR="52///@;53///@" D ^DIE K DA,DIE,DR
  1. S RD=DGP("RD"),PD=DGP("PD"),GL=DGP("GL"),BS=DGP("BS"),TSR=DGP("TSR"),REM=DGP("REM"),RC=0
  1. ;
  1. Q K PP,BD,C,D,DAYC,DGP,I,I1,T,W,X,X1,X2,DGI,DR,DA,DIE Q
  1. ;
  1. UP43 ;
  1. Q ;IHS/ANMC/LJF 3/31/2001 stop updating auto-queue info
  1. 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
  1. 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
  1. Q
  1. ;
  1. DELETE ; Nulls earliest date to correct in the G&L Corrections file once that date has been recalculated and set recalculation date
  1. 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
  1. Q
  1. ;
  1. VAR ; RC=ReCalc from date ; YD=YesterDay ; RD=Report Date ;
  1. ; BS=Bed Status ; GL=G&L ; REM=Recalc patient days ;
  1. ; PD=Previous Day ; W=Ward ; D=Division ; T=Treating Speciality