source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPMBSG2.m@ 940

Last change on this file since 940 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 3.0 KB
Line 
1DGPMBSG2 ;ALB/LM - BED STATUS ABSENCE REMAINING; 6 JUNE 90
2 ;;5.3;Registration;**34**;Aug 13, 1993
3 ;
4A Q:$S('$D(REM):1,REM:1,1:0) ; +/- from previous day
5 Q:$S('$D(M):1,'M:1,1:0) ; Movement type unknown
6 D PASS,ASIH,AA,UA
7 Q
8 ;
9PASS ; 1=AA<96; 23=From AA<96
10 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
11 Q:"^1^23^"'[("^"_+M_"^")
12 S ^(+MV("LWD"))=$S($D(^UTILITY("DGPS",$J,+MV("LWD"))):^(+MV("LWD")),1:0)+$S(+M=1:1,1:-1)
13 S ^(+MV("PTS"))=$S($D(^UTILITY("DGTP",$J,+PTSDV,+MV("PTS"))):^(+MV("PTS")),1:0)+$S(+M=1:1,1:-1)
14PASSQ S X3=5 ; Piece position on the 1 Node in the Census File
15 Q
16 ;
17ASIH ; Patients on ASIH as of midnight of census date
18 ; 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
19 I "^13^42^43^47^"[("^"_+M_"^") G 40
20 I M'=14 Q
21 S ^(+MV("PTS"))=$G(^UTILITY("DGTAS",$J,+PTSDV,+MV("PTS")))-1 ; decrease TSR ASIH to reflect return
22 S ^(+MV("PWD"))=$G(^UTILITY("DGAS",$J,+MV("PWD")))-1 ; decrease BSR ASIH column to reflect return
23 G ASIHQ
2440 ; Entry place if irregular discharge (M=17) and previous movement TO ASIH (40)
25 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)
26 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)
27ASIHQ S X3=8 ; Piece position on the 1 Node in the Census File
28 Q
29 ;
30AA ; 1=AA<96; 2=AA; 24=From AA; 25=From AA to UA; 26=From UA to AA
31 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
32 Q:"^2^24^25^26^"'[("^"_+M_"^")
33226 ; Entry place if irregular discharge (M=17) and previous movement (2) AA, (26) FROM UA TO AA
34 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)
35 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)
36AAQ S X3=6 ; Piece position on the 1 Node in the Census File
37 Q
38 ;
39UA ; 3=UA; 22=From UA; 25=From AA to UA; 26=From UA to AA
40 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
41 Q:"^3^22^25^26^"'[("^"_+M_"^")
42325 ; Entry place if irregular discharge (M=17) and previous movement (3) UA, (25) FROM AA TO UA
43 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)
44 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)
45UAQ S X3=7 ; Piece position on the 1 Node in the Census File
46 Q
Note: See TracBrowser for help on using the repository browser.