DGPMBSG3 ;ALB/LM - BED STATUS GENERATION; 6 JUNE 90
;;5.3;Registration;**34**;Aug 13, 1993
;
A D ADM,DISCH,OTHER,TS
I T=2,$G(PTSDV)'=$G(LTSDV) D TSDIV ; checks for move between divisions
Q
;
ADM Q:T'=1 ; 1=Admission
S $P(LW,"^",28)=$P(LW,"^",28)+1,$P(LT,"^",28)=$P(LT,"^",28)+1 ; Gains-Total [Cum]
S $P(LW,"^",17)=$P(LW,"^",17)+1,$P(LT,"^",17)=$P(LT,"^",17)+1 ; 17=Cum Admissions
S:M=9 $P(LW,"^",13)=$P(LW,"^",13)+1,$P(LT,"^",13)=$P(LT,"^",13)+1 ; M=9 (Movement=Transfer In) 13=Cum Admis from xfer in
S:M=18 $P(LW,"^",18)=$P(LW,"^",18)+1,$P(LT,"^",18)=$P(LT,"^",18)+1 S (E("PW"),E("PT"))="" ; M=18 (Movement=Readmission to NHCU/DOM) 18=Adm after rehosp >30 days
Q
;
DISCH Q:T'=3 ; 3=Discharge
S $P(LW,"^",5)=$P(LW,"^",5)+1,$P(LT,"^",5)=$P(LT,"^",5)+1 ; 5=Cum Discharge
S MP=$P(MDP,"^",18) I "2^3^25^26^40^"[("^"_MP_"^") D IRREG I MP'=40 D ONEDAY Q
I 'NLS!(NLS=1) S $P(LW,"^",24)=$P(LW,"^",24)+1,$P(LT,"^",24)=$P(LT,"^",24)+1 ; If not showing Non-Loss set 24=Cum Losses
; M=10(xfer out,), M=11(OPT-NSC), M=12(Death), M=38(Death w/autopsy), 14=Cum disch to xfer out, 16=Cum disch to OPT/NSC, 15=Cum disch to death
I "^10^11^12^38^"[("^"_M_"^") S X=$S(M=10:14,M=11:16,1:15),$P(LW,"^",X)=$P(LW,"^",X)+1,$P(LT,"^",X)=$P(LT,"^",X)+1
;
ASIH ; M=42 (While ASIH) M=47 (Discharge From NHCU/DOM while ASIH)
I M=42!(M=47) S X=21 S:"^12^38^"[("^"_MV("AS")_"^") X=22 S $P(LW,"^",X)=$P(LW,"^",X)+1,$P(LT,"^",X)=$P(LT,"^",X)+1 ; 12=death, 38 death w/autopsy, 22=Died while ASIH, 21=Disch while ASIH
;
ONEDAY ; MV("OD") set in ONEDAY^DGPMGLG1
I MV("OD") S ^(+MV("LWD"))=$S($D(^UTILITY("DGOD",$J,+MV("LWD"))):^(+MV("LWD")),1:0)+1,^(+MV("LTS"))=$S($D(^UTILITY("DGTOD",$J,LTSDV,+MV("LTS"))):^(+MV("LTS")),1:0)+1
S:+MV("LWD")=+MV("PWD") E("PW")=""
S:+MV("LTS")=+MV("PTS") E("PT")=""
Q
;
IRREG ; If irregular discharge or regular discharge after a loss
;S MP=$P(MDP,"^",18) ; MP=Previous Movement
I MP=40 D 40^DGPMBSG2 ; 40=TO ASIH
I "^2^26^"[("^"_MP_"^") D 226^DGPMBSG2 ; 2=AA, 26=FROM UA TO AA
I "^3^25^"[("^"_MP_"^") D 325^DGPMBSG2 ; 3=UA, 25=FROM AA TO UA
Q
;
OTHER ; T=4 (Lodger CheckIn), T=5 (Lodger CheckOut), T=7 (Non-Movement)
S:"^4^5^7^"[("^"_T_"^") (E("LW"),E("LT"),E("PW"),E("PT"))=""
Q
;
TS Q:T'=6 ; T=6 (Specialty transfer)
; 28=Gains Cum, 29=IWT Gains Cum, 24=Losses Cum, 6=IWT Losses Cum, 8=XRF other TS Cum, 23=XRF from other TS Cum
I TSC S $P(LT,"^",28)=$P(LT,"^",28)+1,$P(LT,"^",29)=$P(LT,"^",29)+1,$P(PT,"^",24)=$P(PT,"^",24)+1,$P(PT,"^",6)=$P(PT,"^",6)+1 I +MV("LTS")'=+MV("PTS") S $P(PT,"^",8)=$P(PT,"^",8)+1,$P(LT,"^",23)=$P(LT,"^",23)+1,(E("LW"),E("PW"))=""
Q
TSDIV ; Interward Transfer without TS change between different divisions
I MV("LTS")=MV("PTS") S $P(LT,"^",28)=$P(LT,"^",28)+1,$P(LT,"^",29)=$P(LT,"^",29)+1,$P(PT,"^",24)=$P(PT,"^",24)+1,$P(PT,"^",6)=$P(PT,"^",6)+1,$P(PT,"^",8)=$P(PT,"^",8)+1,$P(LT,"^",23)=$P(LT,"^",23)+1 K E("PT")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMBSG3 2953 printed Nov 22, 2024@17:59:10 Page 2
DGPMBSG3 ;ALB/LM - BED STATUS GENERATION; 6 JUNE 90
+1 ;;5.3;Registration;**34**;Aug 13, 1993
+2 ;
A DO ADM
DO DISCH
DO OTHER
DO TS
+1 ; checks for move between divisions
IF T=2
IF $GET(PTSDV)'=$GET(LTSDV)
DO TSDIV
+2 QUIT
+3 ;
ADM ; 1=Admission
if T'=1
QUIT
+1 ; Gains-Total [Cum]
SET $PIECE(LW,"^",28)=$PIECE(LW,"^",28)+1
SET $PIECE(LT,"^",28)=$PIECE(LT,"^",28)+1
+2 ; 17=Cum Admissions
SET $PIECE(LW,"^",17)=$PIECE(LW,"^",17)+1
SET $PIECE(LT,"^",17)=$PIECE(LT,"^",17)+1
+3 ; M=9 (Movement=Transfer In) 13=Cum Admis from xfer in
if M=9
SET $PIECE(LW,"^",13)=$PIECE(LW,"^",13)+1
SET $PIECE(LT,"^",13)=$PIECE(LT,"^",13)+1
+4 ; M=18 (Movement=Readmission to NHCU/DOM) 18=Adm after rehosp >30 days
if M=18
SET $PIECE(LW,"^",18)=$PIECE(LW,"^",18)+1
SET $PIECE(LT,"^",18)=$PIECE(LT,"^",18)+1
SET (E("PW"),E("PT"))=""
+5 QUIT
+6 ;
DISCH ; 3=Discharge
if T'=3
QUIT
+1 ; 5=Cum Discharge
SET $PIECE(LW,"^",5)=$PIECE(LW,"^",5)+1
SET $PIECE(LT,"^",5)=$PIECE(LT,"^",5)+1
+2 SET MP=$PIECE(MDP,"^",18)
IF "2^3^25^26^40^"[("^"_MP_"^")
DO IRREG
IF MP'=40
DO ONEDAY
QUIT
+3 ; If not showing Non-Loss set 24=Cum Losses
IF 'NLS!(NLS=1)
SET $PIECE(LW,"^",24)=$PIECE(LW,"^",24)+1
SET $PIECE(LT,"^",24)=$PIECE(LT,"^",24)+1
+4 ; M=10(xfer out,), M=11(OPT-NSC), M=12(Death), M=38(Death w/autopsy), 14=Cum disch to xfer out, 16=Cum disch to OPT/NSC, 15=Cum disch to death
+5 IF "^10^11^12^38^"[("^"_M_"^")
SET X=$SELECT(M=10:14,M=11:16,1:15)
SET $PIECE(LW,"^",X)=$PIECE(LW,"^",X)+1
SET $PIECE(LT,"^",X)=$PIECE(LT,"^",X)+1
+6 ;
ASIH ; M=42 (While ASIH) M=47 (Discharge From NHCU/DOM while ASIH)
+1 ; 12=death, 38 death w/autopsy, 22=Died while ASIH, 21=Disch while ASIH
IF M=42!(M=47)
SET X=21
if "^12^38^"[("^"_MV("AS")_"^")
SET X=22
SET $PIECE(LW,"^",X)=$PIECE(LW,"^",X)+1
SET $PIECE(LT,"^",X)=$PIECE(LT,"^",X)+1
+2 ;
ONEDAY ; MV("OD") set in ONEDAY^DGPMGLG1
+1 IF MV("OD")
SET ^(+MV("LWD"))=$SELECT($DATA(^UTILITY("DGOD",$JOB,+MV("LWD"))):^(+MV("LWD")),1:0)+1
SET ^(+MV("LTS"))=$SELECT($DATA(^UTILITY("DGTOD",$JOB,LTSDV,+MV("LTS"))):^(+MV("LTS")),1:0)+1
+2 if +MV("LWD")=+MV("PWD")
SET E("PW")=""
+3 if +MV("LTS")=+MV("PTS")
SET E("PT")=""
+4 QUIT
+5 ;
IRREG ; If irregular discharge or regular discharge after a loss
+1 ;S MP=$P(MDP,"^",18) ; MP=Previous Movement
+2 ; 40=TO ASIH
IF MP=40
DO 40^DGPMBSG2
+3 ; 2=AA, 26=FROM UA TO AA
IF "^2^26^"[("^"_MP_"^")
DO 226^DGPMBSG2
+4 ; 3=UA, 25=FROM AA TO UA
IF "^3^25^"[("^"_MP_"^")
DO 325^DGPMBSG2
+5 QUIT
+6 ;
OTHER ; T=4 (Lodger CheckIn), T=5 (Lodger CheckOut), T=7 (Non-Movement)
+1 if "^4^5^7^"[("^"_T_"^")
SET (E("LW"),E("LT"),E("PW"),E("PT"))=""
+2 QUIT
+3 ;
TS ; T=6 (Specialty transfer)
if T'=6
QUIT
+1 ; 28=Gains Cum, 29=IWT Gains Cum, 24=Losses Cum, 6=IWT Losses Cum, 8=XRF other TS Cum, 23=XRF from other TS Cum
+2 IF TSC
SET $PIECE(LT,"^",28)=$PIECE(LT,"^",28)+1
SET $PIECE(LT,"^",29)=$PIECE(LT,"^",29)+1
SET $PIECE(PT,"^",24)=$PIECE(PT,"^",24)+1
SET $PIECE(PT,"^",6)=$PIECE(PT,"^",6)+1
IF +MV("LTS")'=+MV("PTS")
SET $PIECE(PT,"^",8)=$PIECE(PT,"^",8)+1
SET $PIECE(LT,"^",23)=$PIECE(LT,"^",23)+1
SET (E("LW"),E("PW"))=""
+3 QUIT
TSDIV ; Interward Transfer without TS change between different divisions
+1 IF MV("LTS")=MV("PTS")
SET $PIECE(LT,"^",28)=$PIECE(LT,"^",28)+1
SET $PIECE(LT,"^",29)=$PIECE(LT,"^",29)+1
SET $PIECE(PT,"^",24)=$PIECE(PT,"^",24)+1
SET $PIECE(PT,"^",6)=$PIECE(PT,"^",6)+1
SET $PIECE(PT,"^",8)=$PIECE(PT,"^",8)+1
SET $PIECE(LT,"^",23)=$PIECE(LT,"^",23)+1
KILL E("PT")
+2 QUIT
