DGPMBSR1.m

DGPMBSR1 ;ALB/LM - BED STATUS REPORT RECALCULATION CONT.; 16 JAN 91

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

 ;

A S DIE="^DG(43,",DA=1,DR="53///"_RD D ^DIE K DA,DIE,DR ;  Date when recalc up to

 S W=0 F I=0:0 S W=$O(^DIC(42,W)) Q:'W  D SET

 S D=0 F I=0:0 S D=$O(^DG(40.8,D)) Q:'D  S ^UTILITY("DGD",$J,D)=$S($D(^DG(40.8,D,"CEN",PD,0)):$P(^(0),"^",12),1:0),^UTILITY("DGDN",$J,D)="" S T=0 F I1=0:0 S T=$O(^DG(40.8,D,"TS",T)) Q:'T  D TSET

 K I,I1,T,W,D

 D ^DGPMGLG

 Q

 ;

SET S X=$S($D(^DG(41.9,W,"C",PD,0)):^(0),1:""),X=RD_"^"_$P(X,"^",2,99)

 S:$E(PD,4,7)="0930" X=$P(X,"^",1,2) ;  New fiscal year

 S ^UTILITY("DGC",$J,W)=X ;  Census

 S ^UTILITY("DGCN",$J,W)="" ;  New census

 S ^UTILITY("DGOD",$J,+W)=0 ; One Day Admissions

 S X1=$S($D(^DG(41.9,W,"C",PD,1)):$P(^(1),"^",1,10),1:"")

 S ^UTILITY("DGR",$J,W)=X1 ;  Remaining

 S ^UTILITY("DGRN",$J,W)="" ;  New remaining (one node)

 S ^UTILITY("DGFR",$J,+W)=0 ;  Female Patients Remaining

 S ^UTILITY("DG6",$J,+W)=0 ;  Bed Occupants 65 & Over

 S ^UTILITY("DGVN",$J,+W)=0 ;  Bed Occupants VN

 S ^UTILITY("DGPS",$J,+W)=$S('REM:+$P(X1,"^",5),1:0) ;  Pass

 S ^UTILITY("DGAA",$J,+W)=$S('REM:+$P(X1,"^",6),1:0) ;  Auth absense

 S ^UTILITY("DGUA",$J,+W)=$S('REM:+$P(X1,"^",7),1:0) ;  Unauth absense

 S:'REM ^UTILITY("DGAS",$J,+W)=+$P(X1,"^",8) ;  ASIH

 S:REM ^UTILITY("DGIP",$J,+W)=0 ; if count pt. remaining

CEN S ^DG(41.9,W,"C",RD,0)=RD_"^"_$P(^UTILITY("DGC",$J,W),"^",2,99)

 S:'$D(^DG(41.9,W,0))#2 ^(0)=W,^DG(41.9,"B",W,W)="",$P(^(0),"^",4)=$P(^DG(41.9,0),"^",4)+1,$P(^(0),"^",3)=RD

 S:'$D(^DG(41.9,W,"C",0))#2 ^(0)="^41.91DA^^"

 Q

 ;

TSET I TSRI>RD Q  ; If TSR Initialization date is greater than report date quit

 S X=$S($D(^DG(40.8,D,"TS",T,"C",PD,0)):^(0),1:""),X=RD_"^"_$P(X,"^",2,99)

 I RD=TSRI,$P(X,U,2)']"" S X=RD_"^"_$P(^DG(40.8,D,"TS",T,0),"^",3)

 S:$E(PD,4,7)="0930" X=$P(X,"^",1,2)

 S ^UTILITY("DGS",$J,+D,+T)=X ;  Treating Specialty census

 S ^UTILITY("DGSN",$J,+D,+T)="" ;  Treating Specialty new census

 S ^UTILITY("DGTOD",$J,+D,+T)=0 ; One Day Admissions

 S X1=$S($D(^DG(40.8,D,"TS",T,"C",PD,1)):$P(^(1),"^",1,10),1:"")

 S ^UTILITY("DGS1",$J,+D,+T)=X1 ;  Treating Specialty remaining

 S ^UTILITY("DGSN1",$J,+D,+T)="" ;  Treating Specialty new remaining (one node)

 S ^UTILITY("DGTF",$J,+D,+T)=0 ;  Female Patients Remaining

 S ^UTILITY("DGT6",$J,+D,+T)=0 ;  Bed Occupants 65 & Over

 S ^UTILITY("DGTV",$J,+D,+T)=0 ;  Bed Occupants VN

 S ^UTILITY("DGTP",$J,+D,+T)=$S('REM:+$P(X1,"^",5),1:0) ;  Treating Specialty Pass

 S ^UTILITY("DGTA",$J,+D,+T)=$S('REM:+$P(X1,"^",6),1:0) ;  Treating Specialty Auth absense

 S ^UTILITY("DGTU",$J,+D,+T)=$S('REM:+$P(X1,"^",7),1:0) ;  Treating Specialty Unauth absense

 S:'REM ^UTILITY("DGTAS",$J,+D,+T)=+$P(X1,"^",8) ;  Treating Specialty ASIH

 S:REM ^UTILITY("DGTI",$J,+D,+T)=0 ; if count pt. remaining

TCEN S ^DG(40.8,D,"TS",T,"C",RD,0)=RD_"^"_$P(^UTILITY("DGS",$J,D,T),"^",2,99),^DG(40.8,D,"TS",T,"C","B",RD,RD)=""

 S:'$D(^DG(40.8,D,"TS",T,0))#2 ^(0)=T,^DG(40.8,D,"TS","B",T,T)=""

 S:'$D(^DG(40.8,D,"TS",T,"C",0))#2 ^(0)="^40.807D^^",^DG(40.8,D,"TS",T,"C","B",T,T)=""

 Q

 ;

UTIL ;  Utility Nodes

 ;  DGD=Monthly Planned Dom. (yesterday)  ;

 ;  DGDN=Monthly Planned Dom. (new)  ;

 ;  DGC=Zero Node Census file (yesterday)  ;

 ;  DGCN=Zero Node Census file (new)  ;

 ;  DGR=One Node Census file (yesterday)  ;

 ;  DGRN=One Node Census file (new)  ;

 ;  DGS=Treating Specialty (yesterday)  ;

 ;  DGSN=Treating Specialty (new)  ;

 ;  DGS1=Treating Specialty One Node (yesterday)  ;

 ;  DGSN1=Treating Specialty One Node (new)  ;

 ;

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 Specialty

DGPMBSR1  ;ALB/LM - BED STATUS REPORT RECALCULATION CONT.; 16 JAN 91

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

 +2       ;

A         ;  Date when recalc up to

           SET DIE="^DG(43,"

           SET DA=1

           SET DR="53///"_RD

           DO ^DIE

           KILL DA,DIE,DR

 +1        SET W=0

           FOR I=0:0

               SET W=$ORDER(^DIC(42,W))

               IF 'W

                   QUIT 

               DO SET

 +2        SET D=0

           FOR I=0:0

               SET D=$ORDER(^DG(40.8,D))

               IF 'D

                   QUIT 

               SET ^UTILITY("DGD",$JOB,D)=$SELECT($DATA(^DG(40.8,D,"CEN",PD,0)):$PIECE(^(0),"^",12),1:0)

               SET ^UTILITY("DGDN",$JOB,D)=""

               SET T=0

               FOR I1=0:0

                   SET T=$ORDER(^DG(40.8,D,"TS",T))

                   IF 'T

                       QUIT 

                   DO TSET

 +3        KILL I,I1,T,W,D

 +4        DO ^DGPMGLG

 +5        QUIT 

 +6       ;

SET        SET X=$SELECT($DATA(^DG(41.9,W,"C",PD,0)):^(0),1:"")

           SET X=RD_"^"_$PIECE(X,"^",2,99)

 +1       ;  New fiscal year

           IF $EXTRACT(PD,4,7)="0930"

               SET X=$PIECE(X,"^",1,2)

 +2       ;  Census

           SET ^UTILITY("DGC",$JOB,W)=X

 +3       ;  New census

           SET ^UTILITY("DGCN",$JOB,W)=""

 +4       ; One Day Admissions

           SET ^UTILITY("DGOD",$JOB,+W)=0

 +5        SET X1=$SELECT($DATA(^DG(41.9,W,"C",PD,1)):$PIECE(^(1),"^",1,10),1:"")

 +6       ;  Remaining

           SET ^UTILITY("DGR",$JOB,W)=X1

 +7       ;  New remaining (one node)

           SET ^UTILITY("DGRN",$JOB,W)=""

 +8       ;  Female Patients Remaining

           SET ^UTILITY("DGFR",$JOB,+W)=0

 +9       ;  Bed Occupants 65 & Over

           SET ^UTILITY("DG6",$JOB,+W)=0

 +10      ;  Bed Occupants VN

           SET ^UTILITY("DGVN",$JOB,+W)=0

 +11      ;  Pass

           SET ^UTILITY("DGPS",$JOB,+W)=$SELECT('REM:+$PIECE(X1,"^",5),1:0)

 +12      ;  Auth absense

           SET ^UTILITY("DGAA",$JOB,+W)=$SELECT('REM:+$PIECE(X1,"^",6),1:0)

 +13      ;  Unauth absense

           SET ^UTILITY("DGUA",$JOB,+W)=$SELECT('REM:+$PIECE(X1,"^",7),1:0)

 +14      ;  ASIH

           IF 'REM

               SET ^UTILITY("DGAS",$JOB,+W)=+$PIECE(X1,"^",8)

 +15      ; if count pt. remaining

           IF REM

               SET ^UTILITY("DGIP",$JOB,+W)=0

CEN        SET ^DG(41.9,W,"C",RD,0)=RD_"^"_$PIECE(^UTILITY("DGC",$JOB,W),"^",2,99)

 +1        IF '$DATA(^DG(41.9,W,0))#2

               SET ^(0)=W

               SET ^DG(41.9,"B",W,W)=""

               SET $PIECE(^(0),"^",4)=$PIECE(^DG(41.9,0),"^",4)+1

               SET $PIECE(^(0),"^",3)=RD

 +2        IF '$DATA(^DG(41.9,W,"C",0))#2

               SET ^(0)="^41.91DA^^"

 +3        QUIT 

 +4       ;

TSET      ; If TSR Initialization date is greater than report date quit

           IF TSRI>RD

               QUIT 

 +1        SET X=$SELECT($DATA(^DG(40.8,D,"TS",T,"C",PD,0)):^(0),1:"")

           SET X=RD_"^"_$PIECE(X,"^",2,99)

 +2        IF RD=TSRI

               IF $PIECE(X,U,2)']""

                   SET X=RD_"^"_$PIECE(^DG(40.8,D,"TS",T,0),"^",3)

 +3        IF $EXTRACT(PD,4,7)="0930"

               SET X=$PIECE(X,"^",1,2)

 +4       ;  Treating Specialty census

           SET ^UTILITY("DGS",$JOB,+D,+T)=X

 +5       ;  Treating Specialty new census

           SET ^UTILITY("DGSN",$JOB,+D,+T)=""

 +6       ; One Day Admissions

           SET ^UTILITY("DGTOD",$JOB,+D,+T)=0

 +7        SET X1=$SELECT($DATA(^DG(40.8,D,"TS",T,"C",PD,1)):$PIECE(^(1),"^",1,10),1:"")

 +8       ;  Treating Specialty remaining

           SET ^UTILITY("DGS1",$JOB,+D,+T)=X1

 +9       ;  Treating Specialty new remaining (one node)

           SET ^UTILITY("DGSN1",$JOB,+D,+T)=""

 +10      ;  Female Patients Remaining

           SET ^UTILITY("DGTF",$JOB,+D,+T)=0

 +11      ;  Bed Occupants 65 & Over

           SET ^UTILITY("DGT6",$JOB,+D,+T)=0

 +12      ;  Bed Occupants VN

           SET ^UTILITY("DGTV",$JOB,+D,+T)=0

 +13      ;  Treating Specialty Pass

           SET ^UTILITY("DGTP",$JOB,+D,+T)=$SELECT('REM:+$PIECE(X1,"^",5),1:0)

 +14      ;  Treating Specialty Auth absense

           SET ^UTILITY("DGTA",$JOB,+D,+T)=$SELECT('REM:+$PIECE(X1,"^",6),1:0)

 +15      ;  Treating Specialty Unauth absense

           SET ^UTILITY("DGTU",$JOB,+D,+T)=$SELECT('REM:+$PIECE(X1,"^",7),1:0)

 +16      ;  Treating Specialty ASIH

           IF 'REM

               SET ^UTILITY("DGTAS",$JOB,+D,+T)=+$PIECE(X1,"^",8)

 +17      ; if count pt. remaining

           IF REM

               SET ^UTILITY("DGTI",$JOB,+D,+T)=0

TCEN       SET ^DG(40.8,D,"TS",T,"C",RD,0)=RD_"^"_$PIECE(^UTILITY("DGS",$JOB,D,T),"^",2,99)

           SET ^DG(40.8,D,"TS",T,"C","B",RD,RD)=""

 +1        IF '$DATA(^DG(40.8,D,"TS",T,0))#2

               SET ^(0)=T

               SET ^DG(40.8,D,"TS","B",T,T)=""

 +2        IF '$DATA(^DG(40.8,D,"TS",T,"C",0))#2

               SET ^(0)="^40.807D^^"

               SET ^DG(40.8,D,"TS",T,"C","B",T,T)=""

 +3        QUIT 

 +4       ;

UTIL      ;  Utility Nodes

 +1       ;  DGD=Monthly Planned Dom. (yesterday)  ;

 +2       ;  DGDN=Monthly Planned Dom. (new)  ;

 +3       ;  DGC=Zero Node Census file (yesterday)  ;

 +4       ;  DGCN=Zero Node Census file (new)  ;

 +5       ;  DGR=One Node Census file (yesterday)  ;

 +6       ;  DGRN=One Node Census file (new)  ;

 +7       ;  DGS=Treating Specialty (yesterday)  ;

 +8       ;  DGSN=Treating Specialty (new)  ;

 +9       ;  DGS1=Treating Specialty One Node (yesterday)  ;

 +10      ;  DGSN1=Treating Specialty One Node (new)  ;

 +11      ;

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 Specialty