Routine: DGPMBSG2

DGPMBSG2 ;ALB/LM - BED STATUS ABSENCE REMAINING; 6 JUNE 90

 ;;5.3;Registration;**34**;Aug 13, 1993

A Q:$S('$D(REM):1,REM:1,1:0)  ;  +/- from previous day

 Q:$S('$D(M):1,'M:1,1:0)  ;  Movement type unknown

 D PASS,ASIH,AA,UA

PASS ;  1=AA<96; 23=From AA<96

 I NLS=1 S ^(+MV("LWD"))=$S($D(^UTILITY("DGPS",$J,+MV("LWD"))):^(+MV("LWD")),1:0)-1,^(+MV("PTS"))=$S($D(^UTILITY("DGTP",$J,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)-1 G PASSQ

 Q:"^1^23^"'[("^"_+M_"^")

 S ^(+MV("LWD"))=$S($D(^UTILITY("DGPS",$J,+MV("LWD"))):^(+MV("LWD")),1:0)+$S(+M=1:1,1:-1)

 S ^(+MV("PTS"))=$S($D(^UTILITY("DGTP",$J,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)+$S(+M=1:1,1:-1)

PASSQ S X3=5 ;  Piece position on the 1 Node in the Census File

ASIH ;  Patients on ASIH as of midnight of census date

 ;  13=To ASIH (VAH); 14=From ASIH (VAH); 40=To ASIH; 41=From ASIH; 42=While ASIH; 43=To ASIH (OTHER FACILITY); 44=Resume ASIH in parent facility 45=Change ASIH location (other fac); 46=Continue ASIH (Other Fac); 47=Discharge From NHCU

 I "^13^42^43^47^"[("^"_+M_"^") G 40

 I M'=14 Q

 S ^(+MV("PTS"))=$G(^UTILITY("DGTAS",$J,+PTSDV,+MV("PTS")))-1 ; decrease TSR ASIH to reflect return

 S ^(+MV("PWD"))=$G(^UTILITY("DGAS",$J,+MV("PWD")))-1 ; decrease BSR ASIH column to reflect return

 G ASIHQ

40 ; Entry place if irregular discharge (M=17) and previous movement TO ASIH (40)

 S ^(+MV("LWD"))=$S($D(^UTILITY("DGAS",$J,+MV("LWD"))):^(+MV("LWD")),1:0)+$S(+M=13:1,+M=43:1,+M=14:0,+M=42:-1,+M=47:-1,1:0)

 S ^(+MV("PTS"))=$S($D(^UTILITY("DGTAS",$J,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)+$S(+M=13:1,+M=43:1,+M=14:0,+M=42:-1,+M=47:-1,1:0)

ASIHQ S X3=8 ;  Piece position on the 1 Node in the Census File

AA ;  1=AA<96; 2=AA; 24=From AA; 25=From AA to UA; 26=From UA to AA

 I NLS=2!(NLS=26) S ^(+MV("LWD"))=$S($D(^UTILITY("DGAA",$J,+MV("LWD"))):^(+MV("LWD")),1:0)-1,^(+MV("PTS"))=$S($D(^UTILITY("DGTA",$J,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)-1 G AAQ

 Q:"^2^24^25^26^"'[("^"_+M_"^")

226 ; Entry place if irregular discharge (M=17) and previous movement (2) AA, (26) FROM UA TO AA

 S ^(+MV("LWD"))=$S($D(^UTILITY("DGAA",$J,+MV("LWD"))):^(+MV("LWD")),1:0)+$S(+M=2:1,+M=26:1,+$P(MDP,"^",18)=1:0,NLS=2:0,MP=2:0,MP=26:0,1:-1)

 S ^(+MV("PTS"))=$S($D(^UTILITY("DGTA",$J,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)+$S(+M=2:1,+M=26:1,+$P(MDP,"^",18)=1:0,NLS=2:0,MP=2:0,MP=26:0,1:-1)

AAQ S X3=6 ;  Piece position on the 1 Node in the Census File

UA ;  3=UA; 22=From UA; 25=From AA to UA; 26=From UA to AA

 I NLS=3!(NLS=25) S ^(+MV("LWD"))=$S($D(^UTILITY("DGUA",$J,+MV("LWD"))):^(+MV("LWD")),1:0)-1,^(+MV("PTS"))=$S($D(^UTILITY("DGTU",$J,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)-1 G UAQ

 Q:"^3^22^25^26^"'[("^"_+M_"^")

325 ; Entry place if irregular discharge (M=17) and previous movement (3) UA, (25) FROM AA TO UA

 S ^(+MV("LWD"))=$S($D(^UTILITY("DGUA",$J,+MV("LWD"))):^(+MV("LWD")),1:0)+$S(+M=3:1,+M=25:1,NLS=3:0,MP=3:0,MP=25:0,1:-1)

 S ^(+MV("PTS"))=$S($D(^UTILITY("DGTU",$J,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)+$S(+M=3:1,+M=25:1,NLS=3:0,MP=3:0,MP=25:0,1:-1)

UAQ S X3=7 ;  Piece position on the 1 Node in the Census File

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPMBSG2   3134     printed  Apr 09, 2024@22:05:25                                                                                                                                                                                                    Page 2

DGPMBSG2  ;ALB/LM - BED STATUS ABSENCE REMAINING; 6 JUNE 90

 +1       ;;5.3;Registration;**34**;Aug 13, 1993

 +2       ;

A         ;  +/- from previous day

           if $SELECT('$DATA(REM)

               QUIT

 +1       ;  Movement type unknown

           if $SELECT('$DATA(M)

               QUIT

 +2        DO PASS

           DO ASIH

           DO AA

           DO UA

 +3        QUIT

 +4       ;

PASS      ;  1=AA<96; 23=From AA<96

 +1        IF NLS=1

               SET ^(+MV("LWD"))=$SELECT($DATA(^UTILITY("DGPS",$JOB,+MV("LWD"))):^(+MV("LWD")),1:0)-1

               SET ^(+MV("PTS"))=$SELECT($DATA(^UTILITY("DGTP",$JOB,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)-1

               GOTO PASSQ

 +2        if "^1^23^"'[("^"_+M_"^")

               QUIT

 +3        SET ^(+MV("LWD"))=$SELECT($DATA(^UTILITY("DGPS",$JOB,+MV("LWD"))):^(+MV("LWD")),1:0)+$SELECT(+M=1:1,1:-1)

 +4        SET ^(+MV("PTS"))=$SELECT($DATA(^UTILITY("DGTP",$JOB,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)+$SELECT(+M=1:1,1:-1)

PASSQ     ;  Piece position on the 1 Node in the Census File

           SET X3=5

 +1        QUIT

 +2       ;

ASIH      ;  Patients on ASIH as of midnight of census date

 +1       ;  13=To ASIH (VAH); 14=From ASIH (VAH); 40=To ASIH; 41=From ASIH; 42=While ASIH; 43=To ASIH (OTHER FACILITY); 44=Resume ASIH in parent facility 45=Change ASIH location (other fac); 46=Continue ASIH (Other Fac); 47=Discharge From NHCU

 +2        IF "^13^42^43^47^"[("^"_+M_"^")

               GOTO 40

 +3        IF M'=14

               QUIT

 +4       ; decrease TSR ASIH to reflect return

           SET ^(+MV("PTS"))=$GET(^UTILITY("DGTAS",$JOB,+PTSDV,+MV("PTS")))-1

 +5       ; decrease BSR ASIH column to reflect return

           SET ^(+MV("PWD"))=$GET(^UTILITY("DGAS",$JOB,+MV("PWD")))-1

 +6        GOTO ASIHQ

40        ; Entry place if irregular discharge (M=17) and previous movement TO ASIH (40)

 +1        SET ^(+MV("LWD"))=$SELECT($DATA(^UTILITY("DGAS",$JOB,+MV("LWD"))):^(+MV("LWD")),1:0)+$SELECT(+M=13:1,+M=43:1,+M=14:0,+M=42:-1,+M=47:-1,1:0)

 +2        SET ^(+MV("PTS"))=$SELECT($DATA(^UTILITY("DGTAS",$JOB,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)+$SELECT(+M=13:1,+M=43:1,+M=14:0,+M=42:-1,+M=47:-1,1:0)

ASIHQ     ;  Piece position on the 1 Node in the Census File

           SET X3=8

 +1        QUIT

 +2       ;

AA        ;  1=AA<96; 2=AA; 24=From AA; 25=From AA to UA; 26=From UA to AA

 +1        IF NLS=2!(NLS=26)

               SET ^(+MV("LWD"))=$SELECT($DATA(^UTILITY("DGAA",$JOB,+MV("LWD"))):^(+MV("LWD")),1:0)-1

               SET ^(+MV("PTS"))=$SELECT($DATA(^UTILITY("DGTA",$JOB,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)-1

               GOTO AAQ

 +2        if "^2^24^25^26^"'[("^"_+M_"^")

               QUIT

226       ; Entry place if irregular discharge (M=17) and previous movement (2) AA, (26) FROM UA TO AA

 +1        SET ^(+MV("LWD"))=$SELECT($DATA(^UTILITY("DGAA",$JOB,+MV("LWD"))):^(+MV("LWD")),1:0)+$SELECT(+M=2:1,+M=26:1,+$PIECE(MDP,"^",18)=1:0,NLS=2:0,MP=2:0,MP=26:0,1:-1)

 +2        SET ^(+MV("PTS"))=$SELECT($DATA(^UTILITY("DGTA",$JOB,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)+$SELECT(+M=2:1,+M=26:1,+$PIECE(MDP,"^",18)=1:0,NLS=2:0,MP=2:0,MP=26:0,1:-1)

AAQ       ;  Piece position on the 1 Node in the Census File

           SET X3=6

 +1        QUIT

 +2       ;

UA        ;  3=UA; 22=From UA; 25=From AA to UA; 26=From UA to AA

 +1        IF NLS=3!(NLS=25)

               SET ^(+MV("LWD"))=$SELECT($DATA(^UTILITY("DGUA",$JOB,+MV("LWD"))):^(+MV("LWD")),1:0)-1

               SET ^(+MV("PTS"))=$SELECT($DATA(^UTILITY("DGTU",$JOB,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)-1

               GOTO UAQ

 +2        if "^3^22^25^26^"'[("^"_+M_"^")

               QUIT

325       ; Entry place if irregular discharge (M=17) and previous movement (3) UA, (25) FROM AA TO UA

 +1        SET ^(+MV("LWD"))=$SELECT($DATA(^UTILITY("DGUA",$JOB,+MV("LWD"))):^(+MV("LWD")),1:0)+$SELECT(+M=3:1,+M=25:1,NLS=3:0,MP=3:0,MP=25:0,1:-1)

 +2        SET ^(+MV("PTS"))=$SELECT($DATA(^UTILITY("DGTU",$JOB,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)+$SELECT(+M=3:1,+M=25:1,NLS=3:0,MP=3:0,MP=25:0,1:-1)

UAQ       ;  Piece position on the 1 Node in the Census File

           SET X3=7

 +1        QUIT

DGPMBSG2.m