DGPMBSR3 ;ALB/LM - STORE NEW CENSUS NODES; 16 JAN 91
;;5.3;Registration;**34**;Aug 13, 1993
;
; Storing in the Census File and accumulating data in ^Utility
A D Q
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 W=0 F I=0:0 S W=$O(^DIC(42,W)) Q:'W D WSET,CMPD,AUTH,OOS,DGR
;
Q K I,I1,W,X,X1,X2,Z,Z1,Z2,Z3,%,RB,OSI Q
;
WSET 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)
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)
S $P(X("DGC"),"^",7)=$P(X("DGC"),"^",5)+$P(X("DGC"),"^",2) ; Cum Rem = Cum Disch + Patients Remaining
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
S $P(X("DGC"),"^",2)=+X ; Patients Remaining
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
Q
;
CMPD ; $P(X("DGC"),"^",25) = Cum Monthly Pat Days (0;25) in file #41.9)
I +$E(X("DGC"),6,7)=1 S $P(X("DGC"),"^",25)=0 ; initializes monthly pt days of care
; on first of month.
S $P(X("DGC"),"^",25)=$P(X("DGC"),"^",25)+$P(X("DGC"),"^",2)+X("DGOD") ; monthly days of care cum.
Q
;
AUTH ; -- how many auth beds
S D0=+W,DGPMOS=RD D AUTH^DGPMDDCF S X("AB")=$S(X=-1:0,1:X)
K D0,DGPMOS Q
;
OOS ; -- Is Ward OOS for Date?
S D0=+W,DGPMOS=RD D WIN^DGPMDDCF I X=1 S X("OS")=X("AB") G OOSQ
D BOS^DGPMDDCF S X("OS")=$S(X=-1:0,1:X)
OOSQ K D0,DGPMOS Q
;
DGR S $P(X("DGR"),"^",1)=+X("DGFR") ; Female Patients Remaining
S X("OB")=X("AB")-X("OS") ; Operating Beds
S $P(X("DGR"),"^",2)=+X("OB") ; Operating Beds
S $P(X("DGR"),"^",3)=+X("DG6") ; Bed Occ. 65 and Over
S $P(X("DGR"),"^",4)=+X("DGVN") ; Bed Occ. Vietnam Era
S $P(X("DGR"),"^",5)=+X("DGPS") ; AA<96
S $P(X("DGR"),"^",6)=+X("DGAA") ; AA
S $P(X("DGR"),"^",7)=+X("DGUA") ; UA
S $P(X("DGR"),"^",8)=+X("DGAS") ; ASIH
S $P(X("DGR"),"^",9)=+X("OS") ; Beds Out Of Service
S $P(X("DGR"),"^",10)=+X("AB") ; Authorized Beds
S $P(X("DGR"),"^",11)=+X("DGOD") ; Oneday admission/discharge
DGC S $P(X("DGC"),"^",4)=$P(X("DGC"),"^",4)+X("OB") ; Cum Bed + Oper Beds
S $P(X("DGC"),"^",9)=$P(X("DGC"),"^",9)+$P(X("DGR"),"^",5) ; Cum Pass Days + AA<96
S $P(X("DGC"),"^",10)=$P(X("DGC"),"^",10)+$P(X("DGR"),"^",6) ; Cum ABO Days + AA
S $P(X("DGC"),"^",11)=$P(X("DGC"),"^",11)+$P(X("DGR"),"^",7) ; Cum UA Days + UA
;
CENSUS 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)=""
S:'$D(^DG(41.9,+W,"C",0)) ^(0)="^41.91DA^^"
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
S ^DG(41.9,+W,"C",RD,0)=X("DGC"),^UTILITY("DGC",$J,+W)=X("DGC")
S ^DG(41.9,+W,"C",RD,1)=X("DGR"),^UTILITY("DGR",$J,+W)=X("DGR")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMBSR3 3062 printed Apr 09, 2024@21:41:48 Page 2
DGPMBSR3 ;ALB/LM - STORE NEW CENSUS NODES; 16 JAN 91
+1 ;;5.3;Registration;**34**;Aug 13, 1993
+2 ;
+3 ; Storing in the Census File and accumulating data in ^Utility
A DO Q
+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 W=0
FOR I=0:0
SET W=$ORDER(^DIC(42,W))
if 'W
QUIT
DO WSET
DO CMPD
DO AUTH
DO OOS
DO DGR
+3 ;
Q KILL I,I1,W,X,X1,X2,Z,Z1,Z2,Z3,%,RB,OSI
QUIT
+1 ;
WSET FOR I1="DGAA","DGUA","DGPS","DGIP","DGVN","DGFR","DG6","DGC","DGCN","DGR","DGRN","DGOD","DGAS"
SET X(I1)=$SELECT($DATA(^UTILITY(I1,$JOB,W)):^(W),1:0)
+1 FOR I1=5,6,8,12,13,14,15,16,17,18,19,20,21,22,23,24,26,27,28,29
SET $PIECE(X("DGC"),"^",I1)=$PIECE(X("DGC"),"^",I1)+$PIECE(X("DGCN"),"^",I1)
+2 ; Cum Rem = Cum Disch + Patients Remaining
SET $PIECE(X("DGC"),"^",7)=$PIECE(X("DGC"),"^",5)+$PIECE(X("DGC"),"^",2)
+3 ; Inpatient (BO) OR Patients Remaining + Gains-Total [Cum] - Cum Losses
SET X=$SELECT(REM:X("DGIP"),1:$PIECE(X("DGC"),"^",2)+$PIECE(X("DGCN"),"^",28)-$PIECE(X("DGCN"),"^",24))
+4 ; Patients Remaining
SET $PIECE(X("DGC"),"^",2)=+X
+5 ; Cum Patient Days of Care = previous cum pat days of care + patients remaining + oneday admissions
SET $PIECE(X("DGC"),"^",3)=X+$PIECE(X("DGC"),"^",3)+X("DGOD")
+6 QUIT
+7 ;
CMPD ; $P(X("DGC"),"^",25) = Cum Monthly Pat Days (0;25) in file #41.9)
+1 ; initializes monthly pt days of care
IF +$EXTRACT(X("DGC"),6,7)=1
SET $PIECE(X("DGC"),"^",25)=0
+2 ; on first of month.
+3 ; monthly days of care cum.
SET $PIECE(X("DGC"),"^",25)=$PIECE(X("DGC"),"^",25)+$PIECE(X("DGC"),"^",2)+X("DGOD")
+4 QUIT
+5 ;
AUTH ; -- how many auth beds
+1 SET D0=+W
SET DGPMOS=RD
DO AUTH^DGPMDDCF
SET X("AB")=$SELECT(X=-1:0,1:X)
+2 KILL D0,DGPMOS
QUIT
+3 ;
OOS ; -- Is Ward OOS for Date?
+1 SET D0=+W
SET DGPMOS=RD
DO WIN^DGPMDDCF
IF X=1
SET X("OS")=X("AB")
GOTO OOSQ
+2 DO BOS^DGPMDDCF
SET X("OS")=$SELECT(X=-1:0,1:X)
OOSQ KILL D0,DGPMOS
QUIT
+1 ;
DGR ; Female Patients Remaining
SET $PIECE(X("DGR"),"^",1)=+X("DGFR")
+1 ; Operating Beds
SET X("OB")=X("AB")-X("OS")
+2 ; Operating Beds
SET $PIECE(X("DGR"),"^",2)=+X("OB")
+3 ; Bed Occ. 65 and Over
SET $PIECE(X("DGR"),"^",3)=+X("DG6")
+4 ; Bed Occ. Vietnam Era
SET $PIECE(X("DGR"),"^",4)=+X("DGVN")
+5 ; AA<96
SET $PIECE(X("DGR"),"^",5)=+X("DGPS")
+6 ; AA
SET $PIECE(X("DGR"),"^",6)=+X("DGAA")
+7 ; UA
SET $PIECE(X("DGR"),"^",7)=+X("DGUA")
+8 ; ASIH
SET $PIECE(X("DGR"),"^",8)=+X("DGAS")
+9 ; Beds Out Of Service
SET $PIECE(X("DGR"),"^",9)=+X("OS")
+10 ; Authorized Beds
SET $PIECE(X("DGR"),"^",10)=+X("AB")
+11 ; Oneday admission/discharge
SET $PIECE(X("DGR"),"^",11)=+X("DGOD")
DGC ; Cum Bed + Oper Beds
SET $PIECE(X("DGC"),"^",4)=$PIECE(X("DGC"),"^",4)+X("OB")
+1 ; Cum Pass Days + AA<96
SET $PIECE(X("DGC"),"^",9)=$PIECE(X("DGC"),"^",9)+$PIECE(X("DGR"),"^",5)
+2 ; Cum ABO Days + AA
SET $PIECE(X("DGC"),"^",10)=$PIECE(X("DGC"),"^",10)+$PIECE(X("DGR"),"^",6)
+3 ; Cum UA Days + UA
SET $PIECE(X("DGC"),"^",11)=$PIECE(X("DGC"),"^",11)+$PIECE(X("DGR"),"^",7)
+4 ;
CENSUS if '$DATA(^DG(41.9,+W,0))
SET X=^DG(41.9,0)
SET $PIECE(X,"^",3)=+W
SET $PIECE(X,"^",4)=$PIECE(X,"^",4)+1
SET ^DG(41.9,0)=X
SET ^DG(41.9,"B",+W,+W)=""
+1 if '$DATA(^DG(41.9,+W,"C",0))
SET ^(0)="^41.91DA^^"
+2 if '$DATA(^DG(41.9,+W,"C",RD,0))
SET X=^DG(41.9,+W,"C",0)
SET $PIECE(X,"^",3)=RD
SET $PIECE(X,"^",4)=$PIECE(X,"^",4)+1
SET ^DG(41.9,+W,"C",0)=X
+3 SET ^DG(41.9,+W,"C",RD,0)=X("DGC")
SET ^UTILITY("DGC",$JOB,+W)=X("DGC")
+4 SET ^DG(41.9,+W,"C",RD,1)=X("DGR")
SET ^UTILITY("DGR",$JOB,+W)=X("DGR")
+5 QUIT
