1 | IVMPREC7 ;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 | ;
|
---|
20 | EN ; 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
|
---|
24 | EN1 .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 | ;
|
---|
103 | GET ; 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 | ;
|
---|
108 | ERRBULL ; 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
|
---|
119 | ORF ;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
|
---|