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

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

initial load of FOIAVistA 6/30/08 version
File size: 4.2 KB
Line 
1DGPMGLG2 ;ALB/LM - G&L GENERATION, CONT.; 24 MAY 90
2 ;;5.3;Registration;**12,34,418**;Aug 13, 1993
3 ;
4 ;Finds 2 most recent locations and treating specialties for the
5 ;corresponding admission (note that ASIH creates its own admission,
6 ;and its TS's and wards apply to that admit only.)
7 ;
8 ;MV("LWD")= last ward (actually, current ward for this MN)
9 ;MV("PWD")= previous ward (just prior to MV("LWD"))
10 ;MV("LTS")= last TS (actually, current TS for this MN)
11 ;MV("LTS")= previous TS (just prior to MV("LTS"))
12 ;
13 ;Note: ASIH is a special case, as the movement TO ASIH contains the
14 ;first ASIH location and TS, which do not really apply to the NHCU/DOM
15 ;corresponding admission.
16 ;Thus, when returning from ASIH, the corresponding Previous data
17 ;must be found in the movement prior to the move TO ASIH.
18 ;
19A D LAST,^DGPMGLG5
20Q K X,X3,J,J1,J2
21 Q
22 ;
23LAST S (D,MV("LWD"),MV("PWD"),MV("LTS"),MV("PTS"),MV("ASIH"),ZMV("LWD"),ZMV("LTS"),ATS,PTS)="",(WDC,TSC)=0
24 ;
25 I "^13^42^43^44^45^47^"'[("^"_+MV("MT")_"^") S:$P(MD,"^",6)]"" MV("LWD")=$P(MD,"^",6) ; Last Ward
26 I "^13^"[("^"_+MV("MT")_"^") S:$P(MD,"^",6)]"" ZMV("LWD")=$P(MD,"^",6) ; Last Ward
27 I "^7^"[("^"_+MV("MT")_"^") S:$P(AD,"^",6)]"" MV("LWD")=$P(AD,"^",6) ; Last Ward
28 ; check for corres. movement for location, If admit, Quit
29 I +MV("MT")=20,$P(MD,"^",24)]"",$D(^DGPM(+$P(MD,"^",24),0)) S:$P(^(0),"^",6)]"" MV("LWD")=$P(^(0),"^",6) I +MV("TT")=6,$P(^DGPM($P(MD,"^",24),0),"^",2)=1 Q
30 I "^13^42^43^44^45^47^"'[("^"_+MV("MT")_"^") S:$P(MD,"^",9)]"" MV("LTS")=$P(MD,"^",9) ; Last TS
31 I "^13^"[("^"_+MV("MT")_"^"),$P(MD,"^",15)]"" S X=$O(^DGPM("ATS",DFN,$P(MD,"^",15),0)) I X D ; looks for ASIH admisssion
32 .S ZMV("LTS")=$O(^DGPM("ATS",DFN,$P(MD,"^",15),X,0)) ; Last TS
33 I ZMV("LTS")]"" S ZMV("LTS")=ZMV("LTS")_"^"_$S('$D(^DIC(45.7,+ZMV("LTS"),0)):"NO TS",$P(^(0),"^",3)]"":$P(^(0),"^",3),$P(^(0),"^")]"":$E($P(^(0),"^"),1,5),1:"NO TS") ; Last TS
34 ;
35 S J=9999999.9999999-(MD+($P(MD,"^",22)/10000000))
36 F S J=$O(^DGPM("APMV",DFN,MV("CA"),J)) Q:'J!(D) D
37 .I MV("MT")=14,MV("LWD"),'MV("PWD") D ASIHR^DGPMGLG4 Q ;checks if return from ASIH
38 .I MV("LWD"),MV("MT")=20,$F("^13^43^44^45^",U_$P(MDP,"^",18)_U),'MV("PWD") D ASIHR^DGPMGLG4 Q ;return from ASIH, TS change
39 .S J2=$O(^DGPM("APMV",DFN,MV("CA"),J,0)) Q:'J2!(D) I $D(^DGPM(J2,0)) S X=^(0) D LAST1
40 ;
41PREV S:MV("PWD")="" MV("PWD")=MV("LWD")
42 I MV("MT")=13 S:$P(MDP,"^",6)]"" MV("PWD")=$P(MDP,"^",6) S:$P(MDP,"^",9)]"" MV("PTS")=$P(MDP,"^",9)
43 I MV("TT")=3&($P(MDP,"^",18)=4) S:$P(MDP,"^",6)]"" MV("PWD")=$P(MDP,"^",6) S:$P(MDP,"^",9)]"" MV("PTS")=$P(MDP,"^",9)
44 S MV("PWD")=MV("PWD")_"^"_$S($D(^DIC(42,+MV("PWD"),0)):$E($P(^(0),"^",1),1,7),1:"NO WARD") ; Previous Ward
45 S MV("LWD")=MV("LWD")_"^"_$S($D(^DIC(42,+MV("LWD"),0)):$E($P(^(0),"^",1),1,7),1:"NO WARD") ; Last Ward
46 I +MV("PWD")'=+MV("LWD") S WDC=1 ; Ward Change
47 ;
48TSC ;looks for most recent, or corresponding TS if one was associated with
49 ;the movement
50 S X=$O(^DGPM("ATS",DFN,MV("CA"),9999999.999999-MD))
51 S ATS=$O(^DGPM("ATS",DFN,MV("CA"),+X,0)) ; ATS=Associated TS
52 I 9999999.9999999-MD=X D ; If the TS is a corresponding one, look for one previous.
53 .S X3=$O(^DGPM("ATS",DFN,MV("CA"),+X)) I X3 S PTS=$O(^(X3,0)) ; PTS=Previous TS
54 ;
55 S:MV("LTS")="" MV("LTS")=ATS
56 I MV("PTS")="" S MV("PTS")=$S(PTS]"":PTS,1:MV("LTS")) I PTS="" S E("PT")="" I MV("TT")=6 S TSC=1
57 S MV("PTS")=MV("PTS")_"^"_$S('$D(^DIC(45.7,+MV("PTS"),0)):"NO TS",$P(^(0),"^",3)]"":$P(^(0),"^",3),$P(^(0),"^")]"":$E($P(^(0),"^"),1,5),1:"NO TS") ; Previous TS
58 S MV("LTS")=MV("LTS")_"^"_$S('$D(^DIC(45.7,+MV("LTS"),0)):"NO TS",$P(^(0),"^",3)]"":$P(^(0),"^",3),$P(^(0),"^")]"":$E($P(^(0),"^"),1,5),1:"NO TS") ; Last TS
59 I +MV("PTS")'=+MV("LTS") S TSC=1 ; TS Change
60 D TSDIV^DGPMGLG4 ; retrieves associated divisions for TS's.
61 Q
62 ;
63LAST1 ; Ward location
64 ; Service (NH or Dom) check
65 I $P(X,"^",6)]"" S D1=0 F II="LWD","PWD" Q:D1 I MV(II)="" S MV(II)=$P(X,"^",6),D1=1 I "^42^43^44^45^47^"[("^"_+MV("MT")_"^") S X1=$S($D(^DIC(42,+MV(II),0)):$P(^(0),"^",3),1:"") D ;p-418
66 .I "^NH^D^"'[("^"_X1_"^")&($P(^(0),"^",17)'=1) S MV(II)="",D1=0 ;p-418 added second condition for IMLTC wards
67 ;
68 ; Facility TS
69 I $P(X,"^",9)]"" S D1=0 F II="LTS","PTS" Q:D1 I MV(II)="" S MV(II)=$P(X,"^",9),D1=1
70 S D1=0 F II="LTS","PTS","LWD","PWD" I MV(II)]"" S D1=D1+1
71 S:D1=4 D=1 K D1
72 Q
Note: See TracBrowser for help on using the repository browser.