- DGPMBSP1 ;ALB/LM - BSR PRINT, CONT.; 17 OCT 90
- ;;5.3;Registration;**96,170,1015**;Aug 13, 1993;Build 21
- ;
- 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
- DGPMBSP1 ;ALB/LM - BSR PRINT, CONT.; 17 OCT 90
- +1 ;;5.3;Registration;**96,170,1015**;Aug 13, 1993;Build 21
- +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