source: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMUM7.m@ 724

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

initial load of WorldVistAEHR
File size: 4.1 KB
Line 
1IVMUM7 ;ALB/SEK,RTK - DELETE IVM MEANS TEST ; 23 JUNE 00
2 ;;2.0;INCOME VERIFICATION MATCH;**1,17,31**;21-OCT-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN ; this routine will process an IVM means test delete request
6 ; from the IVM Center.
7 ;
8 ; delete IVM mean test records in the following files:
9 ; 408.22
10 ; 408.21
11 ;
12 ; 408.12 & 408.13 if IVM dependent
13 ; or
14 ; 408.1275 if IVM & VAMC dependent (new 408.1275 record was
15 ; created for each IVM dependent by upload).
16 ; change back the following fields to VAMC values
17 ; from IVM values:
18 ; 408.12 - relationship
19 ; 408.13 - name, dob, ssn, sex
20 ; or
21 ; 408.1275 if VAMC dependent (new inactivated 408.1275 record
22 ; was created by upload).
23 ;
24 ; 408.31
25 ;
26 ; the "PRIM" node for the VAMC MT will be changed to 1
27 ;
28 ; the event driver will be called twice
29 ; DGMTACT="DUP"
30 ; DGMTACT="DEL"
31 ;
32 ;
33 ; Input IVMMTDT MT date
34 ; IVMMTIEN primary MT IEN
35 ;
36 ; check primary test is IVM
37 S IVMNO=$G(^DGMT(408.31,IVMMTIEN,0)) ; ivm mt 0th node
38 S IVMSOT=$P($G(^DG(408.34,+$P(IVMNO,"^",23),0)),"^") ; source of test
39 I IVMSOT'="IVM" D Q
40 .S HLERR="IVM means test for income year "_($E(DGLY,1,3)+1700)_" not found"
41 .D ACK^IVMPREC
42 ;
43 ; get VAMC mt
44 S IVMVAMC=0 ; ivmvamc is vamc ien
45 F S IVMVAMC=$O(^DGMT(408.31,"AD",1,DFN,IVMMTDT,IVMVAMC)) Q:'IVMVAMC D Q:$D(IVMVNO)
46 .S IVMVNO=$G(^DGMT(408.31,+IVMVAMC,0)) ; vamc 0th node
47 .S IVMSOT=$P($G(^DG(408.34,+$P(IVMVNO,"^",23),0)),"^") ; source of test
48 .I IVMSOT'="VAMC",IVMSOT'="DCD",IVMSOT'="OTHER FACILITY" K IVMVNO Q
49 I '$D(IVMVNO) D Q
50 .S HLERR=IVMSOT_" means test for income year "_($E(DGLY,1,3)+1700)_" not found"
51 .D ACK^IVMPREC
52 ;
53 ; get array dginc containing ien(s) of 408.21
54 ; get array dginr containing ien(s) of 408.22
55 D ALL^DGMTU21(DFN,"VSC",IVMMTDT,"IR",IVMMTIEN)
56 ;
57 ; delete 408.22
58 ;
59 S DA=$G(DGINR("V")) D
60 .Q:'DA S DIK="^DGMT(408.22," D ^DIK
61 S DA=$G(DGINR("S")) D
62 .Q:'DA S DIK="^DGMT(408.22," D ^DIK
63 S IVMN=0
64 F S IVMN=$O(DGINR("C",IVMN)) Q:'IVMN S DA=$G(DGINR("C",IVMN)),DIK="^DGMT(408.22," D ^DIK
65 ;
66 ; delete 408.21
67 ;
68 S DA=$G(DGINC("V")) D
69 .Q:'DA S DIK="^DGMT(408.21," D ^DIK
70 S DA=$G(DGINC("S")) D
71 .Q:'DA S DIK="^DGMT(408.21," D ^DIK
72 S IVMN=0
73 F S IVMN=$O(DGINC("C",IVMN)) Q:'IVMN S DA=$G(DGINC("C",IVMN)),DIK="^DGMT(408.21," D ^DIK
74 ;
75 ; logic for 408.12/408.1275 & 408.13
76 ;
77 D SETUPAR^IVMUM8
78 ;
79 ; no "AIVM" x-ref means
80 ; no dependents
81 ; or
82 ; IVM v2.0 means test (no dependent difference)
83 ; only 408.22, 408.21, and 408.31 records will be deleted
84 ;
85 S IVM12="" F S IVM12=$O(^DGPR(408.12,"AIVM",IVMMTIEN,IVM12)) Q:'IVM12 D Q:$D(IVMFERR)
86 .I $G(^DGPR(408.12,+IVM12,0))']"" D Q
87 ..S (IVMTEXT(6),HLERR)="Can't find 408.12 record "_IVM12
88 ..D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
89 ..S IVMFERR=""
90 ..D ACK^IVMPREC
91 ..Q
92 .;
93 .I $P($G(^DGPR(408.12,+IVM12,"E",0)),"^",4)=1 D Q
94 ..; only 1 multiple record (408.1275) indicates IVM dependent
95 ..; delete 408.12 & 408.13 records for IVM dependent
96 ..S IVM13=$P($P($G(^DGPR(408.12,+IVM12,0)),"^",3),";") I $G(^DGPR(408.13,+IVM13,0))']"" D Q
97 ...S (IVMTEXT(6),HLERR)="Can't find 408.13 record "_IVM13
98 ...D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
99 ...S IVMFERR=""
100 ...D ACK^IVMPREC
101 ...Q
102 ..S DA=IVM12,DIK="^DGPR(408.12," D ^DIK K DA,DIK
103 ..S DA=IVM13,DIK="^DGPR(408.13," D ^DIK K DA,DIK
104 ..Q
105 .;
106 .; delete 408.1275 record for IVM dependent and
107 .; change demo data in 408.12 & 408.13 back to VAMC values
108 .; or
109 .; delete 408.1275 record for inactivated VAMC dependent
110 .S IVM121="",IVM121=$O(^DGPR(408.12,"AIVM",IVMMTIEN,+IVM12,IVM121))
111 .I $G(^DGPR(408.12,+IVM12,"E",+IVM121,0))']"" D Q
112 ..S (IVMTEXT(6),HLERR)="Can't find 408.1275 record "_IVM12_" "_IVM121
113 ..D ERRBULL^IVMPREC7,MAIL^IVMUFNC()
114 ..S IVMFERR=""
115 ..D ACK^IVMPREC
116 ..Q
117 .S IVMVAMCA=$P(^(0),"^",2) ; dependent active?
118 .S DA(1)=IVM12,DA=IVM121,DIK="^DGPR(408.12,"_DA(1)_",""E"","
119 .D ^DIK K DA(1),DA,DIK
120 .Q:'IVMVAMCA ; quit if inactivated VAMC dependent
121 .S IVM13=+$P($P($G(^DGPR(408.12,+IVM12,0)),"^",3),";")
122 .D EN^IVMUM8
123 .Q
124 ;
125 Q:$D(IVMFERR)
126 D EN1^IVMUM8
127 Q
Note: See TracBrowser for help on using the repository browser.