DGPMBSR3.m

DGPMBSR3 ;ALB/LM - STORE NEW CENSUS NODES; 16 JAN 91

 ;;5.3;Registration;**34,1015**;Aug 13, 1993;Build 21

 ;

 ;  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

DGPMBSR3  ;ALB/LM - STORE NEW CENSUS NODES; 16 JAN 91

 +1       ;;5.3;Registration;**34,1015**;Aug 13, 1993;Build 21

 +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