source: FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMLDEM4.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1IVMLDEM4 ;ALB/KCL,PJR - IVM DEMOGRAPHIC UPLOAD/DELETE FIELDS ; 11/22/04 2:27pm
2 ;;2.0;INCOME VERIFICATION MATCH;**5,10,56,102**; 21-OCT-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6UF ; - (action) select uploadable demographic fields for filing
7 ;
8 ; Input: IVMWHERE -- as where the action is coming from
9 ;
10 ; -- If action from UPLOADABLE list:
11 ; array of uploadable fields as
12 ; ^TMP("IVMUPLOAD",$J,"IDX",CTR,CTR)=dfn^da(2)^da(1)^da^ivm field value^pointer to file (#1)^dhcp field number^dhcp field name
13 ;
14 ;
15 ; - generic seletor used within list manager action
16 N VALMY,IVMDOD S IVMDOD=0
17 D EN^VALM2($G(XQORNOD(0)))
18 Q:'$D(VALMY)
19 ;
20 N IVMPKDOD D CHECKS,CHECKDOD
21 ;
22 S IVMENT4=0 F S IVMENT4=$O(VALMY(IVMENT4)) Q:'IVMENT4 D
23 .;
24 .S IVMINDEX=$G(^TMP("IVMUPLOAD",$J,"IDX",IVMENT4,IVMENT4)) I IVMINDEX']"" Q
25 .;
26 .; - check to see if selection is an address field
27 .S IVMADDR=$$ADDR^IVMLDEM6(+IVMINDEX,$P(IVMINDEX,"^",2),$P(IVMINDEX,"^",3),$P(IVMINDEX,"^",4),IVMPPICK)
28 .;
29 .Q:IVMADDR
30 .;
31 .; - check to see if selection is a Date of Death field
32 .I IVMPKDOD S IVMDOD=$$DOD^IVMLDEMD(+IVMINDEX,$P(IVMINDEX,"^",2),$P(IVMINDEX,"^",3),$P(IVMINDEX,"^",4))
33 .;
34 .Q:IVMDOD
35 .;
36 .; - ask user if they are sure they want to update field
37 .D RUSURE^IVMLDEMU($P(IVMINDEX,"^",8),"update") I IVMOUT!'IVMSURE Q
38 .;
39 .W !,"Updating "_$P(IVMINDEX,"^",8)_" field... "
40 .;
41 .; - upload value received from IVM into DHCP field
42 .D UPLOAD^IVMLDEMU(DFN,$P(IVMINDEX,"^",6),$P(IVMINDEX,"^",7),$P(IVMINDEX,"^",5))
43 .;
44 .; - remove entry from file (#301.5)
45 .D DELENT^IVMLDEMU($P(IVMINDEX,"^",2),$P(IVMINDEX,"^",3),$P(IVMINDEX,"^",4)) W "completed."
46 .;
47 ;
48 ; - hold display before building list
49 D PAUSE^VALM1
50 ;
51 ; - init the list and re-display to the user
52 D INIT^IVMLDEM2
53 ;
54DEQ ; clean-up variables
55 D QACTION
56 Q
57 ;
58 ;
59DF ; - (action) select uploadable/non-uploadable demographic fields for deletion
60 ;
61 ; Input: IVMWHERE -- as where the action is coming from
62 ;
63 ; -- If action from UPLOADABLE list:
64 ; array of uploadable fields as
65 ; ^TMP("IVMUPLOAD",$J,"IDX",CTR,CTR)=dfn^da(2)^da(1)^da^ivm field value^pointer to file (#1)^dhcp field number^dhcp field name
66 ;
67 ; OR
68 ;
69 ; -- If action from NON-UPLOADABLE list:
70 ; array of non-uploadable fields as
71 ; ^TMP("IVMNONUP",$J,"IDX",CTR,CTR)=dfn^da(2)^da(1)^da^ivm field value^pointer to file (#1)^dhcp field number^dhcp field name
72 ;
73 ;
74 ; Output: None
75 ;
76 ; - generic seletor used within list manager action
77 N VALMY
78 D EN^VALM2($G(XQORNOD(0)))
79 Q:'$D(VALMY)
80 ;
81 ; - determine array depending on variable IVMWHERE
82 S IVMARRAY=$S(IVMWHERE="UP":"IVMUPLOAD",1:"IVMNONUP")
83 ;
84 N IVMPKDOD D CHECKS,CHECKDOD
85 ;
86 S IVMENT4=0 F S IVMENT4=$O(VALMY(IVMENT4)) Q:'IVMENT4 D
87 .;
88 .I IVMWHERE="NON" D DF^IVMLDEM8 Q ; non-uploadable fields
89 .;
90 .; - get selected entry for uploadable fields
91 .S IVMINDEX=$G(^TMP(IVMARRAY,$J,"IDX",IVMENT4,IVMENT4)) Q:IVMINDEX']""
92 .;
93 .; - check to see if selection is an address field
94 .S IVMADDR=$$ADDR^IVMLDEM7(+IVMINDEX,$P(IVMINDEX,"^",2),$P(IVMINDEX,"^",3),$P(IVMINDEX,"^",4),IVMPPICK)
95 .;
96 .Q:IVMADDR
97 .;
98 .; - ask user if they are sure they want to delete field
99 .D RUSURE^IVMLDEMU($P(IVMINDEX,"^",8),"delete") I IVMOUT!'IVMSURE Q
100 .;
101 .W !,"Deleting "_$P(IVMINDEX,"^",8)_" field from the list... "
102 .;
103 .;if Date of Death is Deleted, send bulletin
104 .I IVMPKDOD D BULLETIN S IVMPKDOD=0
105 .;- remove entry from file (#301.5)
106 .D DELENT^IVMLDEMU($P(IVMINDEX,"^",2),$P(IVMINDEX,"^",3),$P(IVMINDEX,"^",4)) W "completed."
107 ;
108 ; - hold display before re-building list
109 D PAUSE^VALM1
110 ;
111 ; - init the list and re-display to the user
112 D @$S(IVMWHERE="UP":"INIT^IVMLDEM2",1:"INIT^IVMLDEM3")
113 ;
114DFQ ; clean-up variables
115 D QACTION
116 Q
117 ;
118 ;
119CHECKS ; check if residence phone number selected
120 ; check if another address field selected
121 ; IVMPPICK=0 phone or an address field not selected
122 ; 1 address field(s) selected
123 ; 2 phone selected
124 ; 3 both address field(s) and phone selected
125 ;
126 N IVMPPIC1,IVMPPIC2
127 S (IVMPPICK,IVMPPIC2)=0
128 Q:IVMWHERE'="UP"
129 S IVMENT4=0 F S IVMENT4=$O(VALMY(IVMENT4)) Q:'IVMENT4 D
130 .I $G(^TMP("IVMUPLOAD",$J,"IDX",IVMENT4,IVMENT4))["PHONE NUMBER [RESIDENCE]" S IVMPPICK=2 Q
131 .S IVMINDEX=$G(^TMP("IVMUPLOAD",$J,"IDX",IVMENT4,IVMENT4)) I IVMINDEX']"" Q
132 .S IVMPPIC1=+$G(^IVM(301.5,+$P(IVMINDEX,"^",2),"IN",+$P(IVMINDEX,"^",3),"DEM",+$P(IVMINDEX,"^",4),0)) Q:'IVMPPIC1
133 .S:$D(^IVM(301.92,"AD",+IVMPPIC1)) IVMPPIC2=1
134 .Q
135 S IVMPPICK=IVMPPICK+IVMPPIC2
136 Q
137 ;
138CHECKDOD ; check if date of death was selected
139 ; IVMPKDOD=0 date of death not selected
140 ; 1 date of death selected
141 ;
142 N IVMPPIC1,IVMPPIC2,CKST
143 S (IVMPKDOD,IVMPPIC2)=0
144 Q:IVMWHERE'="UP"
145 S IVMENT4=0 F S IVMENT4=$O(VALMY(IVMENT4)) Q:'IVMENT4 D
146 .S CKST=$G(^TMP("IVMUPLOAD",$J,"IDX",IVMENT4,IVMENT4))
147 .I CKST["DATE OF DEATH"!(CKST["SOURCE OF NOTIFICATION")!(CKST["DATE OF DEATH LAST UPDATED") S IVMPKDOD=1 Q
148 Q
149BULLETIN ; Non-Acceptance of Date of Death Data Bulletin
150 N DGBULL,DGLINE,DGMGRP,DGNAME,DIFROM,VA,VAERR,XMTEXT,XMSUB,XMDUZ
151 S DGMGRP=$O(^XMB(3.8,"B","DGEN ELIGIBILITY ALERT",""))
152 Q:'DGMGRP
153 D XMY^DGMTUTL(DGMGRP,0,1)
154 S DGNAME=$P($G(^DPT(DFN,0)),"^"),DGSSN=$P($G(^DPT(DFN,0)),"^",9)
155 S XMTEXT="DGBULL("
156 S XMSUB="NON-ACCEPTANCE OF DATE OF DEATH DATA"
157 S DGLINE=0
158 D LINE^DGEN("Patient: "_DGNAME,.DGLINE)
159 D LINE^DGEN("SSN: "_DGSSN,.DGLINE)
160 D LINE^DGEN("",.DGLINE)
161 D LINE^DGEN("This Veteran's Enrollment Record contains a Date of Death,",.DGLINE)
162 D LINE^DGEN("however, you did not upload this information into VistA.",.DGLINE)
163 D LINE^DGEN("Contact the HEC by phone or by fax with the reason for",.DGLINE)
164 D LINE^DGEN("non-acceptance. The HEC will delete erroneous Date of Death",.DGLINE)
165 D LINE^DGEN("information and update the veteran's enrollment record.",.DGLINE)
166 D ^XMD
167 Q
168QACTION ; - kill variables used from all protocols
169 S VALMBCK="R"
170 K IVMADDR,IVMARRAY,IVMENT4,IVMINDEX,IVMOUT,IVMPPICK,IVMSURE
171 Q
Note: See TracBrowser for help on using the repository browser.