source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMBSP1.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1DGPMBSP1 ;ALB/LM - BSR PRINT, CONT.; 17 OCT 90
2 ;;5.3;Registration;**96,170**;Aug 13, 1993
3 ;
4A D DATE
5 S (AT,PL,W)=0
6 ; GL (Ward) Order
7 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
8 K TC,TL,TB,C,I,W1,W2,OOS,T,T1,W,X1,X2,FY("B"),FY("L"),ORDER,BD,X,FY("M")
9Q Q
10 ;
11DATE N XX K ^UTILITY("DGWOR",$J),^UTILITY("DGWON",$J),^UTILITY("DGWOS",$J),^UTILITY("DGWTOR",$J),^UTILITY("DGWNN",$J)
12 S FY("B")=$S(+$E(RD,4,5)<10:+$E(RD,1,3)-1,1:$E(RD,1,3))_"0930" ; Place holder for FY
13 S X1=RD,X2=FY("B") D ^%DTC
14 S FY("D")=+X ; Total Elapsed Fiscal Days
15 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
16 S BD("M")=12/X ; Turnover rate multiplier
17 S FY("L")=$S(RD'["0229":RD-10000,1:$E(RD,1,3)-1_"0228") ; Last year
18 S FY("Y")=$E(FY("B"),1,3)+1,FY("Y")=$E(FY("Y"),2,3) ; Fiscal Year - used in Cum Totals section
19 S X=$S($E(RD,4,5)'="01":$E(RD,4,5)-1,1:12) ; Month prior
20 S X1=$S(X'=12:$E(RD,1,3),1:$E(RD,1,3)-1) ; Year of month prior
21 S X2=$P("31^28^31^30^31^30^31^31^30^31^30^31","^",X) ; Number of days in month prior
22 I X2=28,XX=366 S X2=29 ; if leap year
23 S FY("EOM")=X1_$S(X?2N:X,1:"0"_X)_X2 ; YY_MM_DD format of last day for prior month
24 S X1=RD
25 S X2=FY("EOM")
26 D ^%DTC
27 S FY("DIM")=X ; Total Elapsed Month Days
28 Q
29 ;
30WARD S BD("CB")=$S($D(^DG(41.9,+W,"C",RD,0)):+$P(^(0),"^",4),1:0) ; Cum Beds
31 S (BD("S"),BD("D"))=1
32 S BD("N")=$S($P(BD("W"),"^")]"":$E($P(BD("W"),"^"),1,7),1:"UNKNOWN")_"^"_$P(BD("W"),"^",2)_"^" ; Name of ward_^_Bed Section
33 S BD("PL")=$S($P(BD("W"),"^",15)]"":$P(BD("W"),"^",15),1:"UNKNOWN") ; Primary Location
34 S BD("DV")=+$P(BD("W"),"^",11) ; Division
35 S BD("ADC")=$S($P(BD("W"),"^",3)="NH":2,$P(BD("W"),"^",3)="D":3,1:1) ; Service Type
36 S:'$D(ADC(BD("DV"),BD("ADC"))) ADC(BD("DV"),BD("ADC"))=0,AT=AT+1
37 I '$D(^UTILITY("DGWPL",$J,BD("PL"))) S ^(BD("PL"))=0,^UTILITY("DGWPLT",$J,BD("PL"))=0,PL=PL+1
38 ;
39 S (BD("OSD"),BD("OS"))=0 ; OSD=total OOS Days on ward, OS=total OOS beds on ward
40 ; 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
41 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)
42 .; Check OOS status
43 .N OOS1,OOS2,OOS3,OOS4
44 .S OOS4=%
45 .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)
46 .I OOS3,OOS3<OOS4 Q ;if return-to-service date < date being calculated, Q
47 .S BD("OSD")=BD("OSD")+1
48 ; if OOS date not greater than Report Date & Include Stats
49 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
50 Q
51 ;
52OOS Q
53 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
54 S:'$P(OOS,"^",8) BD("D")=0 ; 8th=Show on Bed Status Report
55 I 'BD("D"),'$P(OOS,"^",9) S BD("S")=0 ; 9th=Include stat's on Bed Status
56 I $S('$P(OOS,"^",7):1,$P(OOS,"^",5)>RD:1,1:0) Q ; 7th=Display OOS on GL 5th=OOS Display End Date
57 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
58 Q
59 ;
60TOTAL ; Total Levels
61 S X=$O(^DIC(42,+W,1,0)) Q:'X
62 S T=0
63 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
64 K X,T,T1
65 Q
Note: See TracBrowser for help on using the repository browser.