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

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

initial load of FOIAVistA 6/30/08 version
File size: 2.9 KB
Line 
1DGPMBSR3 ;ALB/LM - STORE NEW CENSUS NODES; 16 JAN 91
2 ;;5.3;Registration;**34**;Aug 13, 1993
3 ;
4 ; Storing in the Census File and accumulating data in ^Utility
5A D Q
6 S FY("B")=$S(+$E(RD,4,5)<10:+$E(RD,1,3)-1,1:$E(RD,1,3)_"0930") ; Place holder for FY
7 S W=0 F I=0:0 S W=$O(^DIC(42,W)) Q:'W D WSET,CMPD,AUTH,OOS,DGR
8 ;
9Q K I,I1,W,X,X1,X2,Z,Z1,Z2,Z3,%,RB,OSI Q
10 ;
11WSET F I1="DGAA","DGUA","DGPS","DGIP","DGVN","DGFR","DG6","DGC","DGCN","DGR","DGRN","DGOD","DGAS" S X(I1)=$S($D(^UTILITY(I1,$J,W)):^(W),1:0)
12 F I1=5,6,8,12,13,14,15,16,17,18,19,20,21,22,23,24,26,27,28,29 S $P(X("DGC"),"^",I1)=$P(X("DGC"),"^",I1)+$P(X("DGCN"),"^",I1)
13 S $P(X("DGC"),"^",7)=$P(X("DGC"),"^",5)+$P(X("DGC"),"^",2) ; Cum Rem = Cum Disch + Patients Remaining
14 S X=$S(REM:X("DGIP"),1:$P(X("DGC"),"^",2)+$P(X("DGCN"),"^",28)-$P(X("DGCN"),"^",24)) ; Inpatient (BO) OR Patients Remaining + Gains-Total [Cum] - Cum Losses
15 S $P(X("DGC"),"^",2)=+X ; Patients Remaining
16 S $P(X("DGC"),"^",3)=X+$P(X("DGC"),"^",3)+X("DGOD") ; Cum Patient Days of Care = previous cum pat days of care + patients remaining + oneday admissions
17 Q
18 ;
19CMPD ; $P(X("DGC"),"^",25) = Cum Monthly Pat Days (0;25) in file #41.9)
20 I +$E(X("DGC"),6,7)=1 S $P(X("DGC"),"^",25)=0 ; initializes monthly pt days of care
21 ; on first of month.
22 S $P(X("DGC"),"^",25)=$P(X("DGC"),"^",25)+$P(X("DGC"),"^",2)+X("DGOD") ; monthly days of care cum.
23 Q
24 ;
25AUTH ; -- how many auth beds
26 S D0=+W,DGPMOS=RD D AUTH^DGPMDDCF S X("AB")=$S(X=-1:0,1:X)
27 K D0,DGPMOS Q
28 ;
29OOS ; -- Is Ward OOS for Date?
30 S D0=+W,DGPMOS=RD D WIN^DGPMDDCF I X=1 S X("OS")=X("AB") G OOSQ
31 D BOS^DGPMDDCF S X("OS")=$S(X=-1:0,1:X)
32OOSQ K D0,DGPMOS Q
33 ;
34DGR S $P(X("DGR"),"^",1)=+X("DGFR") ; Female Patients Remaining
35 S X("OB")=X("AB")-X("OS") ; Operating Beds
36 S $P(X("DGR"),"^",2)=+X("OB") ; Operating Beds
37 S $P(X("DGR"),"^",3)=+X("DG6") ; Bed Occ. 65 and Over
38 S $P(X("DGR"),"^",4)=+X("DGVN") ; Bed Occ. Vietnam Era
39 S $P(X("DGR"),"^",5)=+X("DGPS") ; AA<96
40 S $P(X("DGR"),"^",6)=+X("DGAA") ; AA
41 S $P(X("DGR"),"^",7)=+X("DGUA") ; UA
42 S $P(X("DGR"),"^",8)=+X("DGAS") ; ASIH
43 S $P(X("DGR"),"^",9)=+X("OS") ; Beds Out Of Service
44 S $P(X("DGR"),"^",10)=+X("AB") ; Authorized Beds
45 S $P(X("DGR"),"^",11)=+X("DGOD") ; Oneday admission/discharge
46DGC S $P(X("DGC"),"^",4)=$P(X("DGC"),"^",4)+X("OB") ; Cum Bed + Oper Beds
47 S $P(X("DGC"),"^",9)=$P(X("DGC"),"^",9)+$P(X("DGR"),"^",5) ; Cum Pass Days + AA<96
48 S $P(X("DGC"),"^",10)=$P(X("DGC"),"^",10)+$P(X("DGR"),"^",6) ; Cum ABO Days + AA
49 S $P(X("DGC"),"^",11)=$P(X("DGC"),"^",11)+$P(X("DGR"),"^",7) ; Cum UA Days + UA
50 ;
51CENSUS S:'$D(^DG(41.9,+W,0)) X=^DG(41.9,0),$P(X,"^",3)=+W,$P(X,"^",4)=$P(X,"^",4)+1,^DG(41.9,0)=X,^DG(41.9,"B",+W,+W)=""
52 S:'$D(^DG(41.9,+W,"C",0)) ^(0)="^41.91DA^^"
53 S:'$D(^DG(41.9,+W,"C",RD,0)) X=^DG(41.9,+W,"C",0),$P(X,"^",3)=RD,$P(X,"^",4)=$P(X,"^",4)+1,^DG(41.9,+W,"C",0)=X
54 S ^DG(41.9,+W,"C",RD,0)=X("DGC"),^UTILITY("DGC",$J,+W)=X("DGC")
55 S ^DG(41.9,+W,"C",RD,1)=X("DGR"),^UTILITY("DGR",$J,+W)=X("DGR")
56 Q
Note: See TracBrowser for help on using the repository browser.