source: FOIAVistA/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASPREC7.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: 8.7 KB
Line 
1EASPREC7 ;ALB/SEK,RTK,GN - ROUTINE TO PROCESS INCOMING (Z06 EVENT TYPE) HL7 MESSAGES ; 6/16/04 9:28am
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**23,30,35,52,42**;21-OCT-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;** Warning ** currently only one ZMT seg per Z06 can be processed.
6 ;
7 ;EAS*1*52 call PARSEZMT within tag ZMT to define all ZMT variables
8 ;EAS*1*42 add RX Copay Testing Upload and Delete to this routine.
9 ; - added DGMTYPT and passed down thru all calls that need.
10 ; o DGMTYPT = 1 (Means Test, MT)
11 ; o DGMTYPT = 2 (RX Copay Test, CT)
12 ;
13 ; This routine will process (validate) batch ORU Means Test(event type
14 ; Z06) HL7 messages received from the IVM center. Format of batch:
15 ; BHS
16 ; {MSH
17 ; PID
18 ; ZIC
19 ; ZIR
20 ; {ZDP
21 ; ZIC
22 ; ZIR
23 ; }
24 ; ZMT
25 ; ZIV
26 ; }
27 ; BTS
28 ;
29EN ; entry point to validate Means Test messages
30 ;
31 N DEPFLG,EDB,CANCFLG,CASEFLG,SEGSTR,SEGMENTS,MISSING,ERRFLG,Z06COM
32 N IVM2,IVM3,IVM7,IVM8,IVM10,IVM12,IVM17,IVM18,IVM20,IVM25,IVM26,IVMIY
33 N IVMDA,IVMPAT,IVMMTSTS,MTFND,UPMTS,MTDATE,TYPE,EASMTDT,EASZ06,EXPIRED
34 N IVM5,EASZ06D,DGMTYPT
35 S SEGSTR="00000000000" ;One byte for each segment in message
36 S SEGMENTS="BHS,MSH,PID,ZIC,ZIR,ZDP,ZIC,ZIR,ZMT,ZIV,BTS"
37 S EDB="EDB-EAS"
38 S Z06COM="Z06 MT via Edb"
39 S (CASEFLG,DEPFLG,ERRFLG,HLERR,IVMDA,IVMFLGC,MTFND,UPMTS)=0
40EN1 F S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA D I $D(HLERR) D ACK^IVMPREC S ERRFLG=1 Q
41 .K HLERR
42 .D GET
43 .D @IVMSEG1 ;process each segment type
44 Q:ERRFLG ;Error detected do not continue
45 S MISSING=$F(SEGSTR,0) ;Ensure all required segments
46 I MISSING D I $D(HLERR) D ACK^IVMPREC,CLEANUP Q
47 . S TYPE=$S(MISSING=3!(MISSING=4):"Veteran's",MISSING>4&(MISSING<8):"Spouse's",1:"")
48 . S HLERR="Missing "_TYPE_" "_$P(SEGMENTS,",",(MISSING-1))_" Segment"
49 D PROCESS
50 I $D(HLERR) D ACK^IVMPREC
51 ;
52 ; cleanup
53CLEANUP K DGLY,DGMTP,IVMDAP,IVMDAS,IVMDAZ,IVMDGLY,CANCFLG,IVMFLGC,IVMMT31
54 K IVMMTDT,IVMMTIEN,IVMSEG,IVMSEG1,IVMSTAT,IVMTEXT,XMSUB,HLERR,CLOSFLG
55 K IVMZ10,IVMDAV,ZIVSEG,ZMTSEG
56 Q
57 ;
58 ;Dependent upon type of Z06 sent perform the following;
59 ;IVM Case Status:
60 ; Value of 1 = Create/Update Z06 MT/CT, Close Case & Mark REASON CODE
61 ; as 'Converted'
62 ; Value of 0 = Cancel Z06 MT/CT and Mark REASON CODE as 'Not Convert'
63 ;
64 ; If Z06 MT/CT and IVM Case Status is 1 and Z06 MT/CT doesn't exist then
65 ; Create new Z06 MT/CT (new Z06 MT/CT becomes primary and existing
66 ; MT/CT becomes non-primary)
67 ; Assign REASON CODE of 'Converted' in #301.5
68 ; If Z06 MT/CT already exists then
69 ; If IVM Case Status is 0 Then
70 ; Delete Z06 MT/CT for income year and return old MT/CT to primary
71 ; Change REASON CODE from 'Converted' to 'Not Converted' in #301.5
72 ; If IVM Case Status is 1 Then
73 ; Update MT/CT Z06 and Close/Convert Case
74 ; Else (Z06 MT/CT, IVM Case Status=0 and Z06 MT/CT does not exist)
75 ; Send back 'AE' to Edb indicating MT/CT Z06 not available for
76 ; cancellation
77 ;
78PROCESS N DIC,%,%H,%I,IVMDATE
79 D NOW^%DTC
80 S IVMDATE=%
81 I '$D(ZMTSEG) S HLERR="ZMT Segment is Missing" Q
82 S EASZ06=1,EXPIRED=0
83 S:DGMTYPT=2 IVMCEB=$P($$RXST^IBARXEU(DFN),"^",2) ;prev RX sts
84 I $G(IVMMTIEN)="" D
85 . S CURMT=$$LST^DGMTU(DFN,,DGMTYPT) ;Retrieve current test on file
86 . S IVMMTIEN=$P(CURMT,"^",1) ;for appropriate income year
87 . S IVMMTDT=$P(CURMT,"^",2)
88 . S IVMMTSTS=$P(CURMT,"^",3)
89 I $G(IVMMTIEN)]"" D ;dgmtp is event driver variable
90 . S (IVMMT31,DGMTP)=$G(^DGMT(408.31,IVMMTIEN,0))
91 ;
92 ; Main loop to process the IVM income test just received.
93 ;
94 ; No previous 408.31 test on file
95 I 'MTFND D Q
96 . I CASEFLG D ;Case=1 Close/Converted
97 . . ;change old MT/CT to non-primary
98 . . I $G(IVMMTIEN)>0 D
99 . . . S DA=IVMMTIEN,DIE="^DGMT(408.31,",DR="2////0;"
100 . . . D ^DIE K DA,DIE,DR
101 . . ;
102 . . S IVMMTDT=EASMTDT
103 . . D ^EASUM1 ;Create New Z06 MT/CT
104 . . I $G(IVMMTDT)="" S IVMMTDT=EASMTDT
105 . . I $$EXPIRED^EASPTRN1(DFN,$G(IVMMTDT)) D
106 . . . S EXPIRED=1,IVMZ10="UPLOAD IN PROGRESS"
107 . . D CLOSE^EASPTRN1(IVMIY,DFN,1,6) ;Close Case/Converted
108 . ;
109 . I 'CASEFLG D Q
110 . . S:DGMTYPT=1 HLERR="Existing Z06 MT not found"
111 . . S:DGMTYPT=2 HLERR="Existing Z06 CT not found"
112 ;
113 ; Previous 408.31 test on file
114 I MTFND D
115 . I 'CASEFLG D ;Case=0 Close/Not Convert
116 . . ; Check to see if MT/CT Z06 exists prior to trying to delete
117 . . ; If NOT defined then send an AE back to Edb
118 . . I 'UPMTS D Q ;Existing Z06 not found
119 . . . S:DGMTYPT=1 HLERR="Existing Z06 MT not found"
120 . . . S:DGMTYPT=2 HLERR="Existing Z06 CT not found"
121 . . I UPMTS D Q
122 . . . N CURMT,IVMMTI,IVMDFN,DGCAT
123 . . . S IVMDFN=DFN ;Save off DFN
124 . . . I $$EXPIRED^EASPTRN1(DFN,$G(IVMMTDT)) D
125 . . . . S EXPIRED=1,IVMZ10="UPLOAD IN PROGRESS"
126 . . . S DGCAT=$P($G(^DG(408.32,IVM3,0)),"^",1),IVM5=""
127 . . . S EASZ06D=1 ;Set del flag for IB event
128 . . . D ^EASUM7 ;Delete Z06 MT/CT
129 . . . S DFN=IVMDFN
130 . . . I $G(IVMMTDT)="" S IVMMTDT=EASMTDT
131 . . . D CLOSE^EASPTRN1(IVMIY,DFN,1,7) ;Close Case/Not Converted
132 . ;
133 . I CASEFLG D ;Case=1 Close/Converted
134 . . Q:$G(IVMMTIEN)<1
135 . . S DA=IVMMTIEN,DIE="^DGMT(408.31,"
136 . . S DR=".03////^S X=IVM3;.12////^S X=IVM8;.07////^S X=IVM10;"
137 . . S DR=DR_".09////^S X=IVM25;.11////^S X=IVM7;.18////^S X=IVM12;"
138 . . S DR=DR_".23////^S X=IVM18;.25////^S X=IVM20;"
139 . . S DR=DR_"2.02////^S X=IVMDATE;2.03////^S X=IVM26"
140 . . D ^DIE K DA,DIE,DR ;Update existing Z06
141 . . I $G(IVMMTDT)="" S IVMMTDT=EASMTDT
142 . . I $$EXPIRED^EASPTRN1(DFN,$G(IVMMTDT)) D
143 . . . S EXPIRED=1,IVMZ10="UPLOAD IN PROGRESS"
144 . . D CLOSE^EASPTRN1(IVMIY,DFN,1,6) ;Close Case/Converted
145 . . S DGCAT=$P($G(^DG(408.32,IVM3,0)),"^",1),IVM5=""
146 . . D MTBULL^EASUM7,MAIL^IVMUFNC() ;Send Bulletin
147 Q
148 ;
149MSH S (HLMID,MSGID)=$P(IVMSEG,HLFS,10) ;Message control id from MSH
150 Q
151PID S DFN=$P($P(IVMSEG,HLFS,4),$E(HLECH))
152 I ('DFN!(DFN'=+DFN)!('$D(^DPT(+DFN,0)))) D Q
153 . S HLERR="Invalid DFN"
154 I $P(IVMSEG,HLFS,20)'=$P(^DPT(DFN,0),"^",9) D Q
155 . S HLERR="Couldn't match IVM SSN with DHCP SSN"
156 S IVMDAP=IVMDA ;Save IVMDA for veteran PID segment
157 Q
158ZIC I 'DEPFLG S IVMDGLY=$P(IVMSEG,"^",3) ;Income year
159 Q
160ZIR Q
161ZDP S DEPFLG=1
162 Q
163 ;Get primary means test
164 ; IVMMTDT - means test date
165 ; DGLY - income year
166 ; If Means Test not in DHCP, don't upload IVM Means Test
167 ;
168ZMT N IVMIEN,MTCODE ;EAS*1*42
169 S IVMDAZ=IVMDA,ZMTSEG=IVMSEG ;ZMT segment ivmda
170 D PARSEZMT(ZMTSEG) ;Retrieve ZMT Values
171 ;Means test date from ZMT segment
172 S (EASMTDT,IVMMTDT)=$$FMDATE^HLFNC($P(IVMSEG,HLFS,3))
173 S DGMTYPT=$G(IVM17) ;int type of test
174 S:DGMTYPT="" DGMTYPT=1 ;insure type defined
175 S DGLY=$$LYR^DGMTSCU1(IVMMTDT) ;Get means test to be updated
176 S MTDATE=-IVMMTDT
177 S IVMIEN=""
178 S MTFND=0
179 F S IVMIEN=$O(^DGMT(408.31,"AID",DGMTYPT,DFN,MTDATE,IVMIEN)) Q:MTFND!(IVMIEN="") D
180 . S IVMMTIEN=IVMIEN
181 . ; match to MT Z06 from Edb
182 . S MTCODE=$P($G(^DGMT(408.31,IVMIEN,0)),"^",3)
183 . I (MTCODE=6)!(MTCODE=16)!(MTCODE=8) D ;Previous Converted MT/CT?
184 . . S UPMTS=IVMIEN
185 . . S MTFND=1
186 Q
187ZIV S IVMDAV=IVMDA,ZIVSEG=IVMSEG
188 S IVMIY=$P(IVMSEG,HLFS,3)
189 S IVMIY=$$FMDATE^HLFNC(IVMIY)
190 I $E(IVMIY,4,7)'="0000"!($E(IVMIY,1,3)<292) D Q
191 . S HLERR="Invalid Income Year"
192 I "01"'[$P(IVMSEG,HLFS,9) D Q
193 . S HLERR="Case Status not 0 or 1"
194 I $P(IVMSEG,HLFS,9)=1 S CASEFLG=1 ;Close/Convert Case Flag
195 I $P(IVMSEG,HLFS,9)=0 S CASEFLG=0 ;Delete/Not Converted MT Flag
196BHS Q
197BTS Q
198 ;
199GET ; get HL7 segment from ^TMP
200 ;S IVMDA=$O(^TMP($J,IVMRTN,+IVMDA))
201 S IVMSEG=$G(^TMP($J,IVMRTN,+IVMDA,0))
202 S IVMSEG1=$E(IVMSEG,1,3)
203 S $E(SEGSTR,IVMDA)=1
204 Q
205 ;
206 ;Parse ZMT Segment for MT Data
207 ;
208PARSEZMT(ZSEG) S IVM2=$$FMDATE^HLFNC($P(ZSEG,"^",3)) ;Means Test Date
209 S IVM3=$O(^DG(408.32,"C",$P(ZSEG,"^",4),"")) ;Means Test Status
210 S IVM7=$S($P(ZSEG,"^",8)="Y":1,1:0) ;Agrees To Deductible
211 S IVM8=$P(ZSEG,"^",9) ;Threshold A
212 S IVM10=$$FMDATE^HLFNC($P(ZSEG,"^",11)) ;Date/Time Completed
213 S IVM12=$P(ZSEG,"^",13) ;Number of Dependents
214 S IVM17=$P(ZSEG,"^",18) ;Type of Test
215 S IVM18=$P(ZSEG,"^",19) ;Source of Test
216 S IVM20=$$FMDATE^HLFNC($P(ZSEG,"^",21)) ;IVM Verified MT
217 S IVM25=$$FMDATE^HLFNC($P(ZSEG,"^",26)) ;D/T Last Changed
218 S IVM26=$O(^DG(408.32,"C",$P(ZSEG,"^",27),"")) ;Test Determined Status
219 Q
Note: See TracBrowser for help on using the repository browser.