source: FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMPREC8.m@ 1671

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

initial load of FOIAVistA 6/30/08 version
File size: 4.9 KB
Line 
1IVMPREC8 ;ALB/KCL/BRM/PJR - PROCESS INCOMING (Z05 EVENT TYPE) HL7 MESSAGES (CON'T) ; 11/24/04 9:58am
2 ;;2.0; INCOME VERIFICATION MATCH ;**5,6,12,58,73,79,102**; 21-OCT-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; This routine is called from IVMPREC6.
6 ; This routine will process batch ORU demographic (event type Z05) HL7
7 ; messages received from the IVM center.
8 ;
9 ;
10 ;
11PID ; - compare PID segment fields with DHCP fields
12 N COMPPH1,COMPPH2
13 ;
14 ; - strip off segment name
15 S IVMPIECE=$E(IVMXREF,4,7)
16 ;
17 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
18 .;
19 .; - if PID field is the address field - parse address
20 .S IVMADFLG=0
21 .I IVMXREF["PID11" D Q:IVMFLD=""
22 ..; - get PID address field containing 5 pieces seperated by HLECH (~)
23 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2))
24 ..; - get piece of address field, and set IVMFLD
25 ..S IVMPIECE=$E(IVMPIECE,3,4),IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE)
26 ..Q:IVMFLD=""
27 ..; - convert state abbrev. to pointer
28 ..I IVMPIECE=4 S (IVMSTPTR,IVMFLD)=+$O(^DIC(5,"C",IVMFLD,0))
29 ..I IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=X
30 ..S IVMADFLG=1
31 .;
32 .I IVMXREF["PID12" S IVMADFLG=1,IVMFLD=+$O(^DIC(5,IVMSTPTR,1,"C",$P(IVMSEG,HLFS,12),0))
33 .; line remove so that the phone number is compared
34 .; before saving to 301.5.
35 .;I IVMXREF["PID13" S IVMFLD=$P(IVMSEG,HLFS,13) D STORE^IVMPREC9 S IVMADFLG=1 Q
36 .;
37 .; - file address fields and quit
38 .I IVMADFLG D STORE^IVMPREC9 Q
39 .;
40 .; - otherwise, set IVMFLD to field rec'd from IVM
41 .; for comparison with DHCP field
42 .S IVMFLD=$P(IVMSEG,HLFS,IVMPIECE)
43 .;
44 .; - if HL7 date convert to FM date and set IVMFLD
45 .I IVMXREF["PID07" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
46 .;
47 .; - call VADPT routine to return DHCP demographics
48 .D DEM^VADPT,ADD^VADPT
49 .;
50 .; - execute code on the 1 node and get DHCP field for comparison
51 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
52 .;
53 .; - special logic for phone number processing
54 .; - if different, then store the actual value received, then quit
55 .I IVMXREF["PID13",IVMFLD]"" D Q
56 ..S COMPPH1=$$CONVPH(IVMFLD)
57 ..S COMPPH2=$$CONVPH(IVMDHCP)
58 ..I COMPPH1'=COMPPH2 D STORE^IVMPREC9
59 .;
60 .; - if field from IVM does not equal DHCP field - store for uploading
61 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
62 Q
63 ;
64 ;
65ZPD ; - compare ZPD segment fields with DHCP fields
66 S IVMPIECE=$E(IVMXREF,4,5)
67 I $P(IVMSEG,HLFS,IVMPIECE)]"" D
68 .;
69 .; - set var to HL7 field
70 .S IVMFLD=$P(IVMSEG,HLFS,IVMPIECE)
71 .;
72 .; - if HL7 date convert to FM date
73 .I IVMXREF["ZPD09"!(IVMXREF["ZPD13")!(IVMXREF["ZPD32") S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
74 .;
75 .; - execute code on the 1 node and get DHCP field
76 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
77 .;
78 .; - if field from IVM does not equal DHCP field - store for uploading
79 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9 Q
80 .I IVMXREF["ZPD09"!(IVMXREF["ZPD31")!(IVMXREF["ZPD32") D STORE^IVMPREC9
81 I IVMXREF["ZPD32",$$AUTODOD^IVMLDEMD(DFN)
82 Q
83 ;
84 ;
85ZGD ; - compare ZGD segment fields with DHCP fields
86 S IVMADFLG=0
87 S IVMPIECE=$E(IVMXREF,4,7)
88 I $P(IVMSEG,HLFS,$E(IVMPIECE,1,2))]"" D
89 .;
90 .; - set var IVMFLD to incoming HL7 field
91 .I 'IVMADFLG S IVMFLD=$P(IVMSEG,HLFS,IVMPIECE)
92 .;
93 .; - ZGD06 as the ZGD address field containing 5 pieces seperated by HLECH (~)
94 .I IVMXREF["ZGD06" D
95 ..S IVMADDR=$P(IVMSEG,HLFS,$E(IVMPIECE,1,2)),IVMPIECE=$E(IVMPIECE,3)
96 ..S IVMFLD=$P(IVMADDR,$E(HLECH),IVMPIECE),IVMADFLG=1
97 ..I IVMFLD]"",IVMPIECE=4 S IVMFLD=$O(^DIC(5,"C",IVMFLD,0))
98 ..I IVMFLD]"",IVMPIECE=5 S X=IVMFLD D ZIPIN^VAFADDR S IVMFLD=$G(X)
99 .;
100 .; - if HL7 date convert to FM date
101 .I IVMXREF["ZGD08" S IVMFLD=$$FMDATE^HLFNC(IVMFLD)
102 .;
103 .; - execute code on the 1 node and get DHCP field
104 .S IVMDHCP="" X:$D(^IVM(301.92,+IVMDEMDA,1)) ^(1) S IVMDHCP=Y
105 .;
106 .; if field from IVM does not equal DHCP field - store for uploading
107 .I IVMFLD]"",(IVMFLD'=IVMDHCP) D STORE^IVMPREC9
108 Q
109RF1 ; - compare RF1 segment fields with DHCP fields
110 S IVMPIECE=$E(IVMXREF,4),IVMADFLG=1
111 I $P(IVMSEG,HLFS,IVMPIECE)]"" D
112 .;if RF1 field is SEQ6, then parse subcomponents
113 .I IVMXREF["RF16" D Q
114 ..;- get data containing 4 pieces seperated by HLECH (~)
115 ..S IVMRFDAT=$P(IVMSEG,HLFS,6)
116 ..S IVMPIECE=$E(IVMXREF,5),IVMFLD=$P(IVMRFDAT,"~",IVMPIECE)
117 ..I IVMPIECE=2 S IVMFLD=$$ADDRCNV(IVMFLD)
118 ..Q:IVMFLD=""
119 ..D STORE^IVMPREC9
120 .I IVMXREF["RF17" D Q
121 ..;get address change date/tm field
122 ..S IVMFLD=$$FMDATE^HLFNC($P(IVMSEG,HLFS,7))
123 ..Q:IVMFLD=""
124 ..D STORE^IVMPREC9
125 ..; check for auto-upload
126 ..S NOUPDT=0,IVMDHCP=$P($G(^DPT(DFN,.11)),HLFS,13)
127 ..I IVMFLD]"",(IVMFLD'>IVMDHCP) S NOUPDT=1
128 ..I $$AUTOADDR^IVMLDEM6(DFN,1,NOUPDT)
129 Q
130 ;
131ADDRCNV(ADDRSRC) ;convert Address Source from HL7 to DHCP format
132 ;
133 Q:$G(ADDRSRC)']"" ""
134 Q:ADDRSRC="USVAHEC" "HEC"
135 Q:ADDRSRC="USVAMC" "VAMC"
136 Q:ADDRSRC="USVAHBSC" "HBSC"
137 Q:ADDRSRC="USNCOA" "NCOA"
138 Q:ADDRSRC="USVABVA" "BVA"
139 Q:ADDRSRC="USVAINS" "VAINS"
140 Q:ADDRSRC="USPS" "USPS"
141 Q ""
142CONVPH(PH) ;remove special chars/spaces from Phone number
143 Q $TR(PH," )(/#\-","")
Note: See TracBrowser for help on using the repository browser.