DGPMBSG ;ALB/LM - BED STATUS GENERATION; 6 JUNE 90
;;5.3;Registration;**34**;Aug 13, 1993
;
1 D ^DGPMBSG1
S M=MV("MT") ; Movement type
S T=MV("TT") ; Transaction type
2 I T'=1,'REM D ^DGPMBSG2
3 D ^DGPMBSG3
I T=2 D TRF ; if Transfer
I '$D(E("LW")) S ^UTILITY("DGCN",$J,+MV("LWD"))=LW
I '$D(E("PW")) S ^UTILITY("DGCN",$J,+MV("PWD"))=PW
I '$D(E("LT")) S ^UTILITY("DGSN",$J,LTSDV,+MV("LTS"))=LT
I '$D(E("PT")) S ^UTILITY("DGSN",$J,PTSDV,+MV("PTS"))=PT
K K E,II,JJ,LDV,LT,LW,M,MP,PT,PW,X,X1,Z
Q K E Q
;
TRF ; T=2 (Transfer)
; M=44 (resume ASIH in parent facility) M=45 (change ASIH other facility)
I "^44^45^"[("^"_M_"^") S (E("LW"),E("LT"),E("PW"),E("PT"))="" Q
;
; M=13 (to ASIH) 43=TO ASIH (OTHER FAC) 20=To ASIH 24=Cum Losses
I "^13^43^"[("^"_M_"^") S $P(LW,"^",20)=$P(LW,"^",20)+1,$P(LW,"^",24)=$P(LW,"^",24)+1,$P(LT,"^",20)=$P(LT,"^",20)+1,$P(LT,"^",24)=$P(LT,"^",24)+1 K E S (E("PW"),E("PT"))="" Q
;
; M=14 (From ASIH) 19=From ASIH 28=Gains Total
I M=14 S $P(LW,"^",19)=$P(LW,"^",19)+1,$P(LW,"^",28)=$P(LW,"^",28)+1,$P(LT,"^",19)=$P(LT,"^",19)+1,$P(PT,"^",28)=$P(PT,"^",28)+1 K E S E("PW")="" Q
;
; M=2 (AA) M=3 (UA) 24=Cum Losses 26=Cum AA 27=Cum UA
I "^2^3^"[("^"_M_"^") S $P(LW,"^",24)=$P(LW,"^",24)+1,$P(LW,"^",(M+24))=$P(LW,"^",(M+24))+1,$P(LT,"^",24)=$P(LT,"^",24)+1,$P(LT,"^",(M+24))=$P(LT,"^",(M+24))+1 K E S (E("PW"),E("PT"))="" Q
;
; M=22 (From UA) 28=Gain Cum
I M=22 S $P(LW,"^",28)=$P(LW,"^",28)+1,$P(PT,"^",28)=$P(PT,"^",28)+1 K E S (E("PW"),E("LT"))="" Q
;
; M=24 (From AA) 28=Gain Cum
I M=24 S $P(LW,"^",28)=$P(LW,"^",28)+1,$P(PT,"^",28)=$P(PT,"^",28)+1 K E S (E("PW"),E("LT"))="" Q
;
; M=25 (From AA to UA) 26=Cum AA
I M=25 S $P(LW,"^",26)=$P(LW,"^",26)+1,$P(PT,"^",26)=$P(PT,"^",26)+1 K E S (E("PW"),E("LT"))="" Q
;
; M=26 (From UA to AA) 27=Cum UA
I M=26 S $P(LW,"^",27)=$P(LW,"^",27)+1,$P(PT,"^",27)=$P(PT,"^",27)+1 K E S (E("PW"),E("LT"))="" Q
;
WDC Q:'WDC ; Ward Change
; 28=Gain Cum, 23=Cum InterServ Xfer In, 8=Cum InterServ Xfer Out, 6=Cum Inter Xfer, 24=Cum Losses, 29=Cum IWT
S $P(LW,"^",28)=$P(LW,"^",28)+1,X=$S($D(^DIC(42,+MV("LWD"),0)):$P(^(0),"^",3),1:0),X1=$S($D(^DIC(42,+MV("PWD"),0)):$P(^(0),"^",3),1:0) I X'=X1 S $P(LW,"^",23)=$P(LW,"^",23)+1,$P(PW,"^",8)=$P(PW,"^",8)+1
S $P(PW,"^",6)=$P(PW,"^",6)+1,$P(PW,"^",24)=$P(PW,"^",24)+1,$P(LW,"^",29)=$P(LW,"^",29)+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMBSG 2404 printed Sep 23, 2025@20:24:59 Page 2
DGPMBSG ;ALB/LM - BED STATUS GENERATION; 6 JUNE 90
+1 ;;5.3;Registration;**34**;Aug 13, 1993
+2 ;
1 DO ^DGPMBSG1
+1 ; Movement type
SET M=MV("MT")
+2 ; Transaction type
SET T=MV("TT")
2 IF T'=1
IF 'REM
DO ^DGPMBSG2
3 DO ^DGPMBSG3
+1 ; if Transfer
IF T=2
DO TRF
+2 IF '$DATA(E("LW"))
SET ^UTILITY("DGCN",$JOB,+MV("LWD"))=LW
+3 IF '$DATA(E("PW"))
SET ^UTILITY("DGCN",$JOB,+MV("PWD"))=PW
+4 IF '$DATA(E("LT"))
SET ^UTILITY("DGSN",$JOB,LTSDV,+MV("LTS"))=LT
+5 IF '$DATA(E("PT"))
SET ^UTILITY("DGSN",$JOB,PTSDV,+MV("PTS"))=PT
K KILL E,II,JJ,LDV,LT,LW,M,MP,PT,PW,X,X1,Z
Q KILL E
QUIT
+1 ;
TRF ; T=2 (Transfer)
+1 ; M=44 (resume ASIH in parent facility) M=45 (change ASIH other facility)
+2 IF "^44^45^"[("^"_M_"^")
SET (E("LW"),E("LT"),E("PW"),E("PT"))=""
QUIT
+3 ;
+4 ; M=13 (to ASIH) 43=TO ASIH (OTHER FAC) 20=To ASIH 24=Cum Losses
+5 IF "^13^43^"[("^"_M_"^")
SET $PIECE(LW,"^",20)=$PIECE(LW,"^",20)+1
SET $PIECE(LW,"^",24)=$PIECE(LW,"^",24)+1
SET $PIECE(LT,"^",20)=$PIECE(LT,"^",20)+1
SET $PIECE(LT,"^",24)=$PIECE(LT,"^",24)+1
KILL E
SET (E("PW"),E("PT"))=""
QUIT
+6 ;
+7 ; M=14 (From ASIH) 19=From ASIH 28=Gains Total
+8 IF M=14
SET $PIECE(LW,"^",19)=$PIECE(LW,"^",19)+1
SET $PIECE(LW,"^",28)=$PIECE(LW,"^",28)+1
SET $PIECE(LT,"^",19)=$PIECE(LT,"^",19)+1
SET $PIECE(PT,"^",28)=$PIECE(PT,"^",28)+1
KILL E
SET E("PW")=""
QUIT
+9 ;
+10 ; M=2 (AA) M=3 (UA) 24=Cum Losses 26=Cum AA 27=Cum UA
+11 IF "^2^3^"[("^"_M_"^")
SET $PIECE(LW,"^",24)=$PIECE(LW,"^",24)+1
SET $PIECE(LW,"^",(M+24))=$PIECE(LW,"^",(M+24))+1
SET $PIECE(LT,"^",24)=$PIECE(LT,"^",24)+1
SET $PIECE(LT,"^",(M+24))=$PIECE(LT,"^",(M+24))+1
KILL E
SET (E("PW"),E("PT"))=""
QUIT
+12 ;
+13 ; M=22 (From UA) 28=Gain Cum
+14 IF M=22
SET $PIECE(LW,"^",28)=$PIECE(LW,"^",28)+1
SET $PIECE(PT,"^",28)=$PIECE(PT,"^",28)+1
KILL E
SET (E("PW"),E("LT"))=""
QUIT
+15 ;
+16 ; M=24 (From AA) 28=Gain Cum
+17 IF M=24
SET $PIECE(LW,"^",28)=$PIECE(LW,"^",28)+1
SET $PIECE(PT,"^",28)=$PIECE(PT,"^",28)+1
KILL E
SET (E("PW"),E("LT"))=""
QUIT
+18 ;
+19 ; M=25 (From AA to UA) 26=Cum AA
+20 IF M=25
SET $PIECE(LW,"^",26)=$PIECE(LW,"^",26)+1
SET $PIECE(PT,"^",26)=$PIECE(PT,"^",26)+1
KILL E
SET (E("PW"),E("LT"))=""
QUIT
+21 ;
+22 ; M=26 (From UA to AA) 27=Cum UA
+23 IF M=26
SET $PIECE(LW,"^",27)=$PIECE(LW,"^",27)+1
SET $PIECE(PT,"^",27)=$PIECE(PT,"^",27)+1
KILL E
SET (E("PW"),E("LT"))=""
QUIT
+24 ;
WDC ; Ward Change
if 'WDC
QUIT
+1 ; 28=Gain Cum, 23=Cum InterServ Xfer In, 8=Cum InterServ Xfer Out, 6=Cum Inter Xfer, 24=Cum Losses, 29=Cum IWT
+2 SET $PIECE(LW,"^",28)=$PIECE(LW,"^",28)+1
SET X=$SELECT($DATA(^DIC(42,+MV("LWD"),0)):$PIECE(^(0),"^",3),1:0)
SET X1=$SELECT($DATA(^DIC(42,+MV("PWD"),0)):$PIECE(^(0),"^",3),1:0)
IF X'=X1
SET $PIECE(LW,"^",23)=$PIECE(LW,"^",23)+1
SET $PIECE(PW,"^",8)=$PIECE(PW,"^",8)+1
+3 SET $PIECE(PW,"^",6)=$PIECE(PW,"^",6)+1
SET $PIECE(PW,"^",24)=$PIECE(PW,"^",24)+1
SET $PIECE(LW,"^",29)=$PIECE(LW,"^",29)+1
+4 QUIT
