DGPMBSP1 ;ALB/LM - BSR PRINT, CONT.; 17 OCT 90
;;5.3;Registration;**96,170**;Aug 13, 1993
;
A D DATE
S (AT,PL,W)=0
; GL (Ward) Order
F W1=0:0 S W=$O(^DIC(42,W)) Q:W'>0 I $D(^DIC(42,W,0)) S BD("W")=^(0),ORDER=$S($D(^DIC(42,W,"ORDER")):+^("ORDER"),1:0) D:+ORDER WARD,TOTAL,^DGPMBSP2
K TC,TL,TB,C,I,W1,W2,OOS,T,T1,W,X1,X2,FY("B"),FY("L"),ORDER,BD,X,FY("M")
Q Q
;
DATE N XX K ^UTILITY("DGWOR",$J),^UTILITY("DGWON",$J),^UTILITY("DGWOS",$J),^UTILITY("DGWTOR",$J),^UTILITY("DGWNN",$J)
S FY("B")=$S(+$E(RD,4,5)<10:+$E(RD,1,3)-1,1:$E(RD,1,3))_"0930" ; Place holder for FY
S X1=RD,X2=FY("B") D ^%DTC
S FY("D")=+X ; Total Elapsed Fiscal Days
S XX=1700+$E(RD,1,3),X=365 S:((XX#4=0)&(XX#100'=0))!((XX#100=0)&(XX#400=0)) X=366 S XX=X ; Number of days in (report date) year
S BD("M")=12/X ; Turnover rate multiplier
S FY("L")=$S(RD'["0229":RD-10000,1:$E(RD,1,3)-1_"0228") ; Last year
S FY("Y")=$E(FY("B"),1,3)+1,FY("Y")=$E(FY("Y"),2,3) ; Fiscal Year - used in Cum Totals section
S X=$S($E(RD,4,5)'="01":$E(RD,4,5)-1,1:12) ; Month prior
S X1=$S(X'=12:$E(RD,1,3),1:$E(RD,1,3)-1) ; Year of month prior
S X2=$P("31^28^31^30^31^30^31^31^30^31^30^31","^",X) ; Number of days in month prior
I X2=28,XX=366 S X2=29 ; if leap year
S FY("EOM")=X1_$S(X?2N:X,1:"0"_X)_X2 ; YY_MM_DD format of last day for prior month
S X1=RD
S X2=FY("EOM")
D ^%DTC
S FY("DIM")=X ; Total Elapsed Month Days
Q
;
WARD S BD("CB")=$S($D(^DG(41.9,+W,"C",RD,0)):+$P(^(0),"^",4),1:0) ; Cum Beds
S (BD("S"),BD("D"))=1
S BD("N")=$S($P(BD("W"),"^")]"":$E($P(BD("W"),"^"),1,7),1:"UNKNOWN")_"^"_$P(BD("W"),"^",2)_"^" ; Name of ward_^_Bed Section
S BD("PL")=$S($P(BD("W"),"^",15)]"":$P(BD("W"),"^",15),1:"UNKNOWN") ; Primary Location
S BD("DV")=+$P(BD("W"),"^",11) ; Division
S BD("ADC")=$S($P(BD("W"),"^",3)="NH":2,$P(BD("W"),"^",3)="D":3,1:1) ; Service Type
S:'$D(ADC(BD("DV"),BD("ADC"))) ADC(BD("DV"),BD("ADC"))=0,AT=AT+1
I '$D(^UTILITY("DGWPL",$J,BD("PL"))) S ^(BD("PL"))=0,^UTILITY("DGWPLT",$J,BD("PL"))=0,PL=PL+1
;
S (BD("OSD"),BD("OS"))=0 ; OSD=total OOS Days on ward, OS=total OOS beds on ward
; From the beginning of the FY to RD, if there is data in the Bed OOS field of the Census file count the # of days OOS and count the # of beds OOS
F %=FY("B"):0 S %=$O(^DG(41.9,+W,"C",%)) Q:'%!(%>RD) I $D(^DG(41.9,+W,"C",%,1)) S X=^(1) D:$P(X,U,9)=$P(X,U,10) S BD("OS")=BD("OS")+$P(X,"^",9)
.; Check OOS status
.N OOS1,OOS2,OOS3,OOS4
.S OOS4=%
.S OOS1=$O(^DIC(42,+W,"OOS","B",OOS4+1),-1) Q:'OOS1 S OOS2=$O(^(OOS1,0)),OOS3=$P(^DIC(42,+W,"OOS",OOS2,0),U,4)
.I OOS3,OOS3<OOS4 Q ;if return-to-service date < date being calculated, Q
.S BD("OSD")=BD("OSD")+1
; if OOS date not greater than Report Date & Include Stats
I $O(^DIC(42,+W,"OOS","AINV",0))>0 F %=0:0 S %=$O(^DIC(42,+W,"OOS","AINV",%)) Q:'% S I=$O(^DIC(42,+W,"OOS","AINV",%,0)) I I,$D(^DIC(42,+W,"OOS",I,0)) S OOS=^(0) I +OOS'>RD,BD("S") D OOS
Q
;
OOS Q
I +OOS'>FY("B"),'$P(OOS,"^",4) S BD("S")=0 Q ; if OOS date is not greater than beginning of FY and there is no return to service date ; 4th=Return to Service Date ; Bed out last FY and is still out
S:'$P(OOS,"^",8) BD("D")=0 ; 8th=Show on Bed Status Report
I 'BD("D"),'$P(OOS,"^",9) S BD("S")=0 ; 9th=Include stat's on Bed Status
I $S('$P(OOS,"^",7):1,$P(OOS,"^",5)>RD:1,1:0) Q ; 7th=Display OOS on GL 5th=OOS Display End Date
S ^UTILITY("DGWOS",$J,+W)=$P(^DIC(42,+W,0),"^")_" - "_$S($D(^DG(405.4,+$P(OOS,"^",2),0)):$P(^(0),"^"),1:"NO REASON DESIGNATED")_$S($P(OOS,"^",3)]"":(", "_$P(OOS,"^",3)),1:"")_"." ; 2th=Reason ; 3rd=Comment
Q
;
TOTAL ; Total Levels
S X=$O(^DIC(42,+W,1,0)) Q:'X
S T=0
F T1=0:0 S T=$O(^DIC(42,+W,1,T)) Q:T'>0 I $D(^DIC(42,+W,1,T,0)) S X=^(0),^UTILITY("DGWTOR",$J,ORDER,T)=$P(X,"^")_"^"_+$P(X,"^",4) ; 1=Totals Name 4=Print in Cumulative Totals
K X,T,T1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMBSP1 3890 printed Apr 09, 2024@21:40:22 Page 2
DGPMBSP1 ;ALB/LM - BSR PRINT, CONT.; 17 OCT 90
+1 ;;5.3;Registration;**96,170**;Aug 13, 1993
+2 ;
A DO DATE
+1 SET (AT,PL,W)=0
+2 ; GL (Ward) Order
+3 FOR W1=0:0
SET W=$ORDER(^DIC(42,W))
if W'>0
QUIT
IF $DATA(^DIC(42,W,0))
SET BD("W")=^(0)
SET ORDER=$SELECT($DATA(^DIC(42,W,"ORDER")):+^("ORDER"),1:0)
if +ORDER
DO WARD
DO TOTAL
DO ^DGPMBSP2
+4 KILL TC,TL,TB,C,I,W1,W2,OOS,T,T1,W,X1,X2,FY("B"),FY("L"),ORDER,BD,X,FY("M")
Q QUIT
+1 ;
DATE NEW XX
KILL ^UTILITY("DGWOR",$JOB),^UTILITY("DGWON",$JOB),^UTILITY("DGWOS",$JOB),^UTILITY("DGWTOR",$JOB),^UTILITY("DGWNN",$JOB)
+1 ; Place holder for FY
SET FY("B")=$SELECT(+$EXTRACT(RD,4,5)<10:+$EXTRACT(RD,1,3)-1,1:$EXTRACT(RD,1,3))_"0930"
+2 SET X1=RD
SET X2=FY("B")
DO ^%DTC
+3 ; Total Elapsed Fiscal Days
SET FY("D")=+X
+4 ; Number of days in (report date) year
SET XX=1700+$EXTRACT(RD,1,3)
SET X=365
if ((XX#4=0)&(XX#100'=0))!((XX#100=0)&(XX#400=0))
SET X=366
SET XX=X
+5 ; Turnover rate multiplier
SET BD("M")=12/X
+6 ; Last year
SET FY("L")=$SELECT(RD'["0229":RD-10000,1:$EXTRACT(RD,1,3)-1_"0228")
+7 ; Fiscal Year - used in Cum Totals section
SET FY("Y")=$EXTRACT(FY("B"),1,3)+1
SET FY("Y")=$EXTRACT(FY("Y"),2,3)
+8 ; Month prior
SET X=$SELECT($EXTRACT(RD,4,5)'="01":$EXTRACT(RD,4,5)-1,1:12)
+9 ; Year of month prior
SET X1=$SELECT(X'=12:$EXTRACT(RD,1,3),1:$EXTRACT(RD,1,3)-1)
+10 ; Number of days in month prior
SET X2=$PIECE("31^28^31^30^31^30^31^31^30^31^30^31","^",X)
+11 ; if leap year
IF X2=28
IF XX=366
SET X2=29
+12 ; YY_MM_DD format of last day for prior month
SET FY("EOM")=X1_$SELECT(X?2N:X,1:"0"_X)_X2
+13 SET X1=RD
+14 SET X2=FY("EOM")
+15 DO ^%DTC
+16 ; Total Elapsed Month Days
SET FY("DIM")=X
+17 QUIT
+18 ;
WARD ; Cum Beds
SET BD("CB")=$SELECT($DATA(^DG(41.9,+W,"C",RD,0)):+$PIECE(^(0),"^",4),1:0)
+1 SET (BD("S"),BD("D"))=1
+2 ; Name of ward_^_Bed Section
SET BD("N")=$SELECT($PIECE(BD("W"),"^")]"":$EXTRACT($PIECE(BD("W"),"^"),1,7),1:"UNKNOWN")_"^"_$PIECE(BD("W"),"^",2)_"^"
+3 ; Primary Location
SET BD("PL")=$SELECT($PIECE(BD("W"),"^",15)]"":$PIECE(BD("W"),"^",15),1:"UNKNOWN")
+4 ; Division
SET BD("DV")=+$PIECE(BD("W"),"^",11)
+5 ; Service Type
SET BD("ADC")=$SELECT($PIECE(BD("W"),"^",3)="NH":2,$PIECE(BD("W"),"^",3)="D":3,1:1)
+6 if '$DATA(ADC(BD("DV"),BD("ADC")))
SET ADC(BD("DV"),BD("ADC"))=0
SET AT=AT+1
+7 IF '$DATA(^UTILITY("DGWPL",$JOB,BD("PL")))
SET ^(BD("PL"))=0
SET ^UTILITY("DGWPLT",$JOB,BD("PL"))=0
SET PL=PL+1
+8 ;
+9 ; OSD=total OOS Days on ward, OS=total OOS beds on ward
SET (BD("OSD"),BD("OS"))=0
+10 ; From the beginning of the FY to RD, if there is data in the Bed OOS field of the Census file count the # of days OOS and count the # of beds OOS
+11 FOR %=FY("B"):0
SET %=$ORDER(^DG(41.9,+W,"C",%))
if '%!(%>RD)
QUIT
IF $DATA(^DG(41.9,+W,"C",%,1))
SET X=^(1)
if $PIECE(X,U,9)=$PIECE(X,U,10)
Begin DoDot:1
+12 ; Check OOS status
+13 NEW OOS1,OOS2,OOS3,OOS4
+14 SET OOS4=%
+15 SET OOS1=$ORDER(^DIC(42,+W,"OOS","B",OOS4+1),-1)
if 'OOS1
QUIT
SET OOS2=$ORDER(^(OOS1,0))
SET OOS3=$PIECE(^DIC(42,+W,"OOS",OOS2,0),U,4)
+16 ;if return-to-service date < date being calculated, Q
IF OOS3
IF OOS3<OOS4
QUIT
+17 SET BD("OSD")=BD("OSD")+1
End DoDot:1
SET BD("OS")=BD("OS")+$PIECE(X,"^",9)
+18 ; if OOS date not greater than Report Date & Include Stats
+19 IF $ORDER(^DIC(42,+W,"OOS","AINV",0))>0
FOR %=0:0
SET %=$ORDER(^DIC(42,+W,"OOS","AINV",%))
if '%
QUIT
SET I=$ORDER(^DIC(42,+W,"OOS","AINV",%,0))
IF I
IF $DATA(^DIC(42,+W,"OOS",I,0))
SET OOS=^(0)
IF +OOS'>RD
IF BD("S")
DO OOS
+20 QUIT
+21 ;
OOS QUIT
+1 ; if OOS date is not greater than beginning of FY and there is no return to service date ; 4th=Return to Service Date ; Bed out last FY and is still out
IF +OOS'>FY("B")
IF '$PIECE(OOS,"^",4)
SET BD("S")=0
QUIT
+2 ; 8th=Show on Bed Status Report
if '$PIECE(OOS,"^",8)
SET BD("D")=0
+3 ; 9th=Include stat's on Bed Status
IF 'BD("D")
IF '$PIECE(OOS,"^",9)
SET BD("S")=0
+4 ; 7th=Display OOS on GL 5th=OOS Display End Date
IF $SELECT('$PIECE(OOS,"^",7):1,$PIECE(OOS,"^",5)>RD:1,1:0)
QUIT
+5 ; 2th=Reason ; 3rd=Comment
SET ^UTILITY("DGWOS",$JOB,+W)=$PIECE(^DIC(42,+W,0),"^")_" - "_$SELECT($DATA(^DG(405.4,+$PIECE(OOS,"^",2),0)):$PIECE(^(0),"^"),1:"NO REASON DESIGNATED")_$SELECT($PIECE(OOS,"^",3)]"":(", "_$PIECE(OOS,"^",3)),1:"")_"."
+6 QUIT
+7 ;
TOTAL ; Total Levels
+1 SET X=$ORDER(^DIC(42,+W,1,0))
if 'X
QUIT
+2 SET T=0
+3 ; 1=Totals Name 4=Print in Cumulative Totals
FOR T1=0:0
SET T=$ORDER(^DIC(42,+W,1,T))
if T'>0
QUIT
IF $DATA(^DIC(42,+W,1,T,0))
SET X=^(0)
SET ^UTILITY("DGWTOR",$JOB,ORDER,T)=$PIECE(X,"^")_"^"_+$PIECE(X,"^",4)
+4 KILL X,T,T1
+5 QUIT
