source: FOIAVistA/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASUM7.m@ 1499

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

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1EASUM7 ;ALB/GN,EG - DELETE IVM MEANS TEST ; 07/07/2006
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**42,74**;21-OCT-94;Build 6
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;EAS*1*42 This routine patterned after IVMUM7.
6 ;
7EN ; this routine will process an IVM MT/CT delete request
8 ; from the IVM Center.
9 ;
10 ; delete IVM MT/CT records in the following files:
11 ; 408.22
12 ; 408.21
13 ;
14 ; 408.12 & 408.13 if IVM dependent
15 ; or
16 ; 408.1275 if IVM & VAMC dependent (new 408.1275 record was
17 ; created for each IVM dependent by upload).
18 ; change back the following fields to VAMC values
19 ; from IVM values:
20 ; 408.12 - relationship
21 ; 408.13 - name, dob, ssn, sex
22 ; or
23 ; 408.1275 if VAMC dependent (new inactivated 408.1275 record
24 ; was created by upload).
25 ;
26 ; 408.31
27 ;
28 ; the "PRIM" node for the VAMC MT will be changed to 1
29 ;
30 ; the event driver will be called twice
31 ; DGMTACT="DUP"
32 ; DGMTACT="DEL"
33 ;
34 ;
35 ; Input IVMMTDT MT date
36 ; IVMMTIEN primary MT IEN
37 ;
38 ; check primary test is IVM
39 S IVMNO=$G(^DGMT(408.31,IVMMTIEN,0)) ; ivm mt 0th node
40 S IVMSOT=$P($G(^DG(408.34,+$P(IVMNO,"^",23),0)),"^") ; source of test
41 I IVMSOT'="IVM" D Q
42 .S HLERR="IVM "_^DG(408.33,DGMTYPT,0)_" for income year "_($E(DGLY,1,3)+1700)_" not found"
43 .D ACK^IVMPREC
44 ;
45 ; get VAMC MT/CT via AD xref (by type) to be re-instated ;EAS*1*42
46 S IVMVAMC="A" ; ivmvamc is vamc ien
47 ;make sure you get the latest test of that type for that date first
48 F S IVMVAMC=$O(^DGMT(408.31,"AD",DGMTYPT,DFN,IVMMTDT,IVMVAMC),-1) Q:'IVMVAMC D Q:$D(IVMVNO)
49 . S IVMVNO=$G(^DGMT(408.31,+IVMVAMC,0)) ; vamc 0th node
50 . S IVMSOT=$P($G(^DG(408.34,+$P(IVMVNO,"^",23),0)),"^") ; source of test
51 . I IVMSOT'="VAMC",IVMSOT'="DCD",IVMSOT'="OTHER FACILITY" K IVMVNO Q
52 . Q
53 ;
54 ; if no previous VAMC RXCT (type 2) on file, then ;EAS*1*42
55 ; simply delete the IVM RX converted 408.31 record
56 I '$D(IVMVNO),DGMTYPT=2 D EN1^EASUM8 Q
57 ;
58 ; if no VAMC MT type 1, then error
59 I '$D(IVMVNO) D Q
60 .S HLERR=IVMSOT_^DG(408.33,DGMTYPT,0)_" for income year "_($E(DGLY,1,3)+1700)_" not found"
61 .D ACK^IVMPREC
62 ;
63 ; get array dginc containing ien(s) of 408.21
64 ; get array dginr containing ien(s) of 408.22
65 D ALL^DGMTU21(DFN,"VSC",IVMMTDT,"IR",IVMMTIEN)
66 ;
67 ; delete 408.22
68 ;
69 S DA=$G(DGINR("V")) D
70 .Q:'DA S DIK="^DGMT(408.22," D ^DIK
71 S DA=$G(DGINR("S")) D
72 .Q:'DA S DIK="^DGMT(408.22," D ^DIK
73 S IVMN=0
74 F S IVMN=$O(DGINR("C",IVMN)) Q:'IVMN S DA=$G(DGINR("C",IVMN)),DIK="^DGMT(408.22," D ^DIK
75 ;
76 ; delete 408.21
77 ;
78 S DA=$G(DGINC("V")) D
79 .Q:'DA S DIK="^DGMT(408.21," D ^DIK
80 S DA=$G(DGINC("S")) D
81 .Q:'DA S DIK="^DGMT(408.21," D ^DIK
82 S IVMN=0
83 F S IVMN=$O(DGINC("C",IVMN)) Q:'IVMN S DA=$G(DGINC("C",IVMN)),DIK="^DGMT(408.21," D ^DIK
84 ;
85 ; logic for 408.12/408.1275 & 408.13
86 ;
87 D SETUPAR^EASUM8
88 ;
89 ; no "AIVM" x-ref means
90 ; no dependents
91 ; or
92 ; IVM v2.0 means test (no dependent difference)
93 ; only 408.22, 408.21, and 408.31 records will be deleted
94 ;
95 S IVM12="" F S IVM12=$O(^DGPR(408.12,"AIVM",IVMMTIEN,IVM12)) Q:'IVM12 D Q:$D(IVMFERR)
96 .I $G(^DGPR(408.12,+IVM12,0))']"" D Q
97 ..S (IVMTEXT(6),HLERR)="Can't find 408.12 record "_IVM12
98 ..D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
99 ..S IVMFERR=""
100 ..D ACK^IVMPREC
101 ..Q
102 .;
103 .I $P($G(^DGPR(408.12,+IVM12,"E",0)),"^",4)=1 D Q
104 ..; only 1 multiple record (408.1275) indicates IVM dependent
105 ..; delete 408.12 & 408.13 records for IVM dependent
106 ..S IVM13=$P($P($G(^DGPR(408.12,+IVM12,0)),"^",3),";") I $G(^DGPR(408.13,+IVM13,0))']"" D Q
107 ...S (IVMTEXT(6),HLERR)="Can't find 408.13 record "_IVM13
108 ...D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
109 ...S IVMFERR=""
110 ...D ACK^IVMPREC
111 ...Q
112 ..S DA=IVM12,DIK="^DGPR(408.12," D ^DIK K DA,DIK
113 ..S DA=IVM13,DIK="^DGPR(408.13," D ^DIK K DA,DIK
114 ..Q
115 .;
116 .; delete 408.1275 record for IVM dependent and
117 .; change demo data in 408.12 & 408.13 back to VAMC values
118 .; or
119 .; delete 408.1275 record for inactivated VAMC dependent
120 .S IVM121="",IVM121=$O(^DGPR(408.12,"AIVM",IVMMTIEN,+IVM12,IVM121))
121 .I $G(^DGPR(408.12,+IVM12,"E",+IVM121,0))']"" D Q
122 ..S (IVMTEXT(6),HLERR)="Can't find 408.1275 record "_IVM12_" "_IVM121
123 ..D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
124 ..S IVMFERR=""
125 ..D ACK^IVMPREC
126 ..Q
127 .S IVMVAMCA=$P(^(0),"^",2) ; dependent active?
128 .S DA(1)=IVM12,DA=IVM121,DIK="^DGPR(408.12,"_DA(1)_",""E"","
129 .D ^DIK K DA(1),DA,DIK
130 .Q:'IVMVAMCA ; quit if inactivated VAMC dependent
131 .S IVM13=+$P($P($G(^DGPR(408.12,+IVM12,0)),"^",3),";")
132 .D EN^EASUM8
133 .Q
134 ;
135 Q:$D(IVMFERR)
136 D EN1^EASUM8
137 Q
138 ;
139ERRBULL ; build mail message for transmission to IVM mail group notifying site
140 ; of upload error.
141 S IVMPAT=$$PT^IVMUFNC4(DFN)
142 S XMSUB="IVM - MEANS TEST UPLOAD"
143 S IVMTEXT(1)="The following error occured when an Income Verification Match"
144 S IVMTEXT(2)="verified Means Test was being uploaded for the following patient:"
145 S IVMTEXT(3)=" "
146 S IVMTEXT(4)=" NAME: "_$P(IVMPAT,"^")
147 S IVMTEXT(5)=" ID: "_$P(IVMPAT,"^",2)
148 S IVMTEXT(6)=" ERROR: "_IVMTEXT(6)
149 Q
150 ;
151MTBULL ; build mail message for transmission to IVM mail group notifying them
152 ; an IVM verified MT/CT has been uploaded into DHCP for a patient.
153 ;
154 S IVMPAT=$$PT^IVMUFNC4(DFN)
155 S XMSUB="IVM - INCOME TEST UPLOAD for "_$P($P(IVMPAT,"^"),",")_" ("_$P(IVMPAT,"^",3)_")"
156 S IVMTEXT(1)="An Income Verification Match verified "
157 S IVMTEXT(1)=IVMTEXT(1)_^DG(408.33,DGMTYPT,0)_" has been uploaded"
158 S IVMTEXT(2)="for the following patient:"
159 S IVMTEXT(3)=" "
160 S IVMTEXT(4)=" NAME: "_$P(IVMPAT,"^")
161 S IVMTEXT(5)=" ID: "_$P(IVMPAT,"^",2)
162 S Y=IVMMTDT X ^DD("DD")
163 S IVMTEXT(6)=" DATE OF TEST: "_Y
164 ;set previous sts from previous 408.31 or previous RX sts
165 S IVMTEXT(7)=" PREV CATEGORY: "
166 I DGMTYPT=2 D
167 . S IVMTEXT(7)=IVMTEXT(7)_IVMCEB
168 E D
169 . S IVMTEXT(7)=IVMTEXT(7)_$P($G(^DG(408.32,+$P(IVMMT31,"^",3),0)),"^",1)
170 ;
171 S IVMTEXT(8)=" NEW CATEGORY: "_DGCAT
172 I IVM5 S Y=IVM5 X ^DD("DD") S IVMTEXT(9)=" DATE/TIME OF ADJUDICATION: "_Y
173 Q
Note: See TracBrowser for help on using the repository browser.