source: FOIAVistA/tag/r/INCOME_VERIFICATION_MATCH-IVM/IVMPREC7.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1IVMPREC7 ;ALB/SEK,RTK - ROUTINE TO PROCESS INCOMING (Z06 EVENT TYPE) HL7 MESSAGES ; 31 May 94
2 ;;2.0;INCOME VERIFICATION MATCH;**1,17,44,34,77**;21-OCT-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; This routine will process (validate) batch ORU Means Test(event type
6 ; Z06) HL7 messages received from the IVM center. Format of batch:
7 ; BHS
8 ; {MSH
9 ; PID
10 ; ZIC
11 ; ZIR
12 ; {ZDP
13 ; ZIC
14 ; ZIR
15 ; }
16 ; ZMT
17 ; }
18 ; BTS
19 ;
20EN ; entry point to validate Means Test messages
21 ;
22 F IVMDA=1:0 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D Q:'IVMDA
23 .K HLERR
24EN1 .S HLMID=$P(IVMSEG,HLFS,10) ; message control id from MSH
25 .S IVMFLGC=0
26 .D GET I IVMSEG1'="PID" D Q
27 ..S HLERR="Missing PID segment" D ACK^IVMPREC
28 .S DFN=$P($P(IVMSEG,HLFS,4),$E(HLECH))
29 .I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D Q
30 ..S HLERR="Invalid DFN" D ACK^IVMPREC
31 .I $P(IVMSEG,HLFS,20)'=$P(^DPT(DFN,0),"^",9) S HLERR="Couldn't match IVM SSN with DHCP SSN" D ACK^IVMPREC Q
32 .S IVMDAP=IVMDA ; save IVMDA for veteran PID segment
33 .;
34 .; check for veteran's ZIC and ZIR segments
35 .D GET I IVMSEG1'="ZIC" D Q
36 ..S HLERR="Missing veteran's ZIC segment" D ACK^IVMPREC
37 .S IVMDGLY=$P(IVMSEG,"^",3) ; income year
38 .D GET I IVMSEG1'="ZIR" D Q
39 ..S HLERR="Missing veteran's ZIR segment" D ACK^IVMPREC
40 .;
41 .; check for spouse's ZDP, ZIC, ZIR segments
42 .D GET I IVMSEG1'="ZDP" D Q
43 ..S HLERR="Missing spouse's ZDP segment" D ACK^IVMPREC
44 .S IVMDAS=IVMDA ; save IVMDA for spouse ZDP segment
45 .D GET I IVMSEG1'="ZIC" D Q
46 ..S HLERR="Missing spouse's ZIC segment" D ACK^IVMPREC
47 .D GET I IVMSEG1'="ZIR" D Q
48 ..S HLERR="Missing spouse's ZIR segment" D ACK^IVMPREC
49 .;
50 .; check for dependent children's ZDP, ZIC, ZIR segments and ZMT segment
51 .K IVMERR
52 .S IVMFLG7=0
53 .F D Q:$D(IVMERR)!(IVMSEG1="ZMT")
54 ..D GET I IVMSEG1'="ZDP"&(IVMSEG1'="ZMT") D Q
55 ...S HLERR="Missing child's ZDP segment or ZMT segment",IVMERR="" D ACK^IVMPREC
56 ..I IVMSEG1="ZMT" D Q
57 ...S:$P(IVMSEG,"^",4)=HLQ IVMFLG7=1 ; delete MT if status is HLQ
58 ...S IVMDAZ=IVMDA ; ZMT segment ivmda
59 ..I $P(IVMSEG,"^",2)']""!($P(IVMSEG,"^",3)']"")!($P(IVMSEG,"^",4)']"") D Q
60 ... S HLERR="Missing child data from ZDP segment",IVMERR="" D ACK^IVMPREC
61 ..D GET I IVMSEG1'="ZIC" D Q
62 ...S HLERR="Missing child's ZIC segment",IVMERR="" D ACK^IVMPREC
63 ..D GET I IVMSEG1'="ZIR" D Q
64 ...S HLERR="Missing child's ZIR segment",IVMERR="" D ACK^IVMPREC
65 ..S IVMFLGC=IVMFLGC+1 ; # of children
66 .;
67 .Q:$D(IVMERR)&(IVMSEG1'="MSH")
68 .G EN1:IVMSEG1="MSH"
69 .;
70 .; get primary means test
71 .; ivmmtdt - means test date
72 .; dgly - income year
73 .; if Means Test not in DHCP don't upload IVM Means Test
74 .S IVMMTDT=$$FMDATE^HLFNC($P(IVMSEG,HLFS,3)) ; means test date from ZMT segment
75 .S DGLY=$$LYR^DGMTSCU1(IVMMTDT)
76 .S IVMMTIEN=+$$LST^DGMTU(DFN,IVMMTDT) ; primary means test IEN
77 .;
78 .I IVMFLG7 D ^IVMUM7 Q ; delete means test
79 .;
80 .S (IVMMT31,DGMTP)=$G(^DGMT(408.31,IVMMTIEN,0)) ; dgmtp is event driver variable
81 .I $P(IVMMT31,"^")'=IVMMTDT D Q
82 ..S Y=IVMMTDT X ^DD("DD")
83 ..S IVMTEXT(6)="Means Test of "_Y_" not in DHCP."
84 ..D ERRBULL,MAIL^IVMUFNC()
85 ..S HLERR="Means test not in DHCP" D ACK^IVMPREC
86 ..Q
87 .I $P(IVMMT31,"^",23)=2 S Y=IVMMTDT X ^DD("DD") S HLERR="2nd means test sent for "_Y D ACK^IVMPREC Q
88 .;
89 .; do not upload IVM means test if primary means test status is
90 .; 3-no longer required
91 .; or if hardship case
92 .S IVMSTAT=$P(IVMMT31,"^",3)
93 .I IVMSTAT=3 S HLERR="NOT UPLOADED no longer required" D ACK^IVMPREC Q
94 .I $P(IVMMT31,"^",20)=1 S HLERR="NOT UPLOADED hardship case" D ACK^IVMPREC Q
95 .D ^IVMUM1 ; upload means test
96 .I $D(HLERR) D ACK^IVMPREC
97 .;
98 .; cleanup
99 .K DGLY,DGMTP,IVMDAP,IVMDAS,IVMDAZ,IVMDGLY,IVMFLG7,IVMFLGC,IVMMT31,IVMMTDT,IVMMTIEN,IVMSEG,IVMSEG1,IVMSTAT,IVMTEXT,XMSUB
100 .Q
101 Q
102 ;
103GET ; get HL7 segment from ^HL
104 S IVMDA=$O(^TMP($J,IVMRTN,+IVMDA)),IVMSEG=$G(^(+IVMDA,0))
105 S IVMSEG1=$E(IVMSEG,1,3)
106 Q
107 ;
108ERRBULL ; build mail message for transmission to IVM mail group notifying site
109 ; of upload error.
110 S IVMPAT=$$PT^IVMUFNC4(DFN)
111 S XMSUB="IVM - MEANS TEST UPLOAD"
112 S IVMTEXT(1)="The following error occured when an Income Verification Match"
113 S IVMTEXT(2)="verified Means Test was being uploaded for the following patient:"
114 S IVMTEXT(3)=" "
115 S IVMTEXT(4)=" NAME: "_$P(IVMPAT,"^")
116 S IVMTEXT(5)=" ID: "_$P(IVMPAT,"^",2)
117 S IVMTEXT(6)=" ERROR: "_IVMTEXT(6)
118 Q
119ORF ;entry point for Means Test Signature Z06 msgs.
120 I $G(HLFS)="" S HLFS="^"
121 I $G(HLECH)="" S HLECH="~"
122 F IVMDA=0:0 S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D Q:'IVMDA
123 .K HLERR
124 .S HLMID=$P(IVMSEG,HLFS,10) ; message control id from MSH
125 .S IVMFLGC=0
126 .D GET I IVMSEG1'="PID" D Q
127 ..S HLERR="Missing PID segment" D ACK^IVMPREC
128 .S DFN=$P($P(IVMSEG,HLFS,4),$E(HLECH))
129 .I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D Q
130 ..S HLERR="Invalid DFN" D ACK^IVMPREC
131 .I $P(IVMSEG,HLFS,20)'=$P(^DPT(DFN,0),"^",9) S HLERR="Couldn't match IVMSSN with DHCP SSN" D ACK^IVMPREC Q
132 .S IVMDAP=IVMDA ; save IVMDA for veteran PID segment
133 .D GET I IVMSEG1'="ZMT" D Q
134 ..S HLERR="Missing ZMT segment" D ACK^IVMPREC
135 .; IVMMTDT - means test date
136 .; DGLY - income year
137 .; if Means Test not in DHCP don't upload IVM Means Test
138 .S IVMMTDT=$$FMDATE^HLFNC($P(IVMSEG,HLFS,3)) ; means test date from ZMT segment
139 .S DGLY=$$LYR^DGMTSCU1(IVMMTDT)
140 .; get means test to be updated
141 .N UPMTS
142 .S MTDATE=-IVMMTDT,IVMMTIEN="",MTFND=0
143 .F S IVMMTIEN=$O(^DGMT(408.31,"AID",1,DFN,MTDATE,IVMMTIEN),-1) Q:MTFND!(IVMMTIEN="") D
144 ..I $$Z06MT^EASPTRN1(IVMMTIEN) Q ;EDB Z06 - Don't use this one
145 ..; match site completing in case multiple tests for same date
146 ..I $P(IVMSEG,HLFS,23)=$P(^DGMT(408.31,IVMMTIEN,2),HLFS,5) S UPMTS=IVMMTIEN,MTFND=1 Q
147 .S (IVMMT31,DGMTP)=$G(^DGMT(408.31,UPMTS,0)) ; DGMTP is event driver variable
148 .I $P(IVMMT31,"^")'=IVMMTDT D Q
149 ..S Y=IVMMTDT X ^DD("DD")
150 ..S IVMTEXT(6)="Means Test of "_Y_" not in DHCP."
151 ..D ERRBULL,MAIL^IVMUFNC()
152 ..S HLERR="Means test not in DHCP" D ACK^IVMPREC
153 ..Q
154 .I $P(IVMMT31,"^",23)=2 S Y=IVMMTDT X ^DD("DD") S HLERR="2nd means test sent for "_Y D ACK^IVMPREC Q
155 .; do not upload IVM means test if primary means test status is
156 .; 3-no longer required
157 .; or if hardship case
158 .S IVMSTAT=$P(IVMMT31,"^",3)
159 .I IVMSTAT=3 S HLERR="NOT UPLOADED no longer required" D ACK^IVMPREC Q
160 .I $P(IVMMT31,"^",20)=1 S HLERR="NOT UPLOADED hardship case" D ACK^IVMPREC Q
161 .;get MT signature and date/time edited info, update means test
162 .N DATA
163 .S DATA(.29)=$P(IVMSEG,HLFS,28),DATA(2.02)=$$FMDATE^HLFNC($P(IVMSEG,HLFS,26)) I $D(DATA(.29)) D
164 ..I $$UPD^DGENDBS(408.31,UPMTS,.DATA)
165 .I '$D(HLERR) D ACK^IVMPREC
166 .;
167 .; cleanup
168 .K DGLY,DGMTP,IVMDAP,IVMDAS,IVMDAZ,IVMDGLY,IVMFLG7,IVMFLGC,IVMMT31,IVMMTDT,IVMMTIEN,IVMSEG,IVMSEG1,IVMSTAT,IVMTEXT,XMSUB,FMDATE,MTDATE
169 .Q
170 Q
Note: See TracBrowser for help on using the repository browser.