source: FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMCM.m@ 1801

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

initial load of FOIAVistA 6/30/08 version
File size: 9.4 KB
Line 
1IVMCM ;ALB/SEK,KCL,RTK,AEG,BRM,AEG - PROCESS INCOME TEST (Z10) TRANSMISSIONS ; 04/23/03 1:43pm
2 ;;2.0;INCOME VERIFICATION MATCH;**12,17,28,41,44,53,34,49,59,55,63,77,74,123**;21-OCT-94;Build 6
3 ;
4 ;
5ORF ; Handler for ORF type HL7 messages received from HEC
6 ;
7 ; Make sure POSTMASTER DUZ instead of DUZ of Person who
8 ; started Incoming Logical Link.
9 S DUZ=.5
10 N CNT,IVMRTN,SEGCNT
11 S IVMRTN="IVMCMX" ;USE "IVMCMX" BECAUSE "IVMCM" ALREADY USED
12 K ^TMP($J,IVMRTN),DIC
13 S (DGMSGF,DGMTMSG)=1 ; HL7 rtn. Don't need DG interative messages.
14 S HLECH=HL("ECH"),HLQ=HL("Q"),HLMID=HL("MID")
15 K %,%H,%I D NOW^%DTC S HLDT=%
16 F SEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D
17 . S CNT=0
18 . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE
19 . F S CNT=$O(HLNODE(CNT)) Q:'CNT D
20 . . S ^TMP($J,IVMRTN,SEGCNT,CNT)=HLNODE(CNT)
21 S HLDA=HLMTIEN
22 ;
23 N SEG,EVENT,MSGID
24 S:'$D(HLEVN) HLEVN=0
25 D NXTSEG^DGENUPL(HLDA,0,.SEG)
26 Q:(SEG("TYPE")'="MSH") ;would not have reached here if this happened!
27 S EVENT=$P(SEG(9),$E(HLECH),2)
28 ;
29 ; INITIALIZE HL7 VARIABLES
30 S HLEID="VAMC "_$P($$SITE^VASITE,"^",3)_" ORF-"_EVENT_" SERVER"
31 S HLEID=$O(^ORD(101,"B",HLEID,0))
32 D INIT^HLFNC2(HLEID,.HL)
33 S HLEIDS=$O(^ORD(101,HLEID,775,"B",0))
34 ;
35 ; Handle means test signature ORF (Z06) event
36 I EVENT="Z06" D ORF^IVMPREC7
37 ;
38 ; Handle income test ORF (Z10) event
39 I EVENT="Z10" D Z10
40 ;
41 ; Handle enrollment/elig. ORF (Z11) event
42 I EVENT="Z11" D
43 .S MSGID=SEG(10)
44 .D ORFZ11^DGENUPL(HLDA,MSGID)
45 ;
46 K ^TMP($J,IVMRTN)
47 Q
48 ;
49 ;
50Z10 ; Entry point for receipt of ORF~Z10 transmission
51 ; The Income Test (Z10) transmission has the following format:
52 ;
53 ; BHS ORF msgs do not include batch header or trailer.
54 ; {MSH
55 ; PID They will include the sequence: MSA
56 ; ZIC QRD
57 ; ZIR QRF
58 ; {ZDP These segments will follow the MSH segment.
59 ; ZIC
60 ; ZIR
61 ; }
62 ; {ZMT
63 ; }
64 ; ZBT
65 ; }
66 ; BTS
67 ;
68 S IVMORF=1 ; set ORF msg flag
69 S (HLEVN,IVMCT,IVMERROR,IVMCNTR)=0 ; init vars
70 ;
71ORU ; Entry point for receipt of ORU~Z10 trans (called by IVMPREC2)
72 S IVMTYPE=5,IVMZ10F=1
73 ;
74 ; - loop through the msg in (#772 file), and process (PROC) msgs
75 S IVMDA=0 F S IVMDA=$O(^TMP($J,IVMRTN,IVMDA)) Q:'IVMDA S IVMSEG=$G(^(IVMDA,0)) I $E(IVMSEG,1,3)="MSH" D PROC Q:'IVMDA
76 ;
77 ; - if ORF msg flag, update the Query Tran Log and send ACK
78 I $G(IVMORF) D
79 .I $G(DFN),$D(IVMMCI) D
80 ..N IVMCR
81 ..S IVMCR=$P("1^2^3^7^5^6^4","^",IVMTYPE) ;map reason to test type
82 ..D FIND^IVMCQ2(DFN,IVMMCI,HLDT,$S($D(HLERR):5,1:IVMCR),1)
83 .;D ACK^IVMPREC:'$D(HLERR)
84 .;N HLRESLTA,HLP
85 .;D GENACK^HLMA1(HLEID,HLMTIEN,HLEIDS,"LM",1,.HLRESLTA,"",.HLP)
86 ;
87 ; - if tests are uploaded, generate notification msg
88 I $D(^TMP($J,"IVMBULL")) D ^IVMCMB
89 ;
90ENQ ;
91 K IVMDA,IVMORF,IVMSEG,IVMFLGC,IVMTYPE,IVMMTIEN,IVMMTDT,IVMDGBT,IVMMCI
92 K ^TMP($J,"IVMCM"),^("IVMBULL"),DGMSGF,DGADDF,IVMCPAY,IVMBULL,DFN
93 K DGMTMSG,IVMZ10F
94 Q
95 ;
96PROC ; Process each HL7 message from (#772) file
97 ;
98 N IVMFUTR,TMSTAMP,SOURCE,NODE,HSDATE,IVMZ10,DGMTP,DGMTACT,DGMTI,DGMTA
99 S DGMTACT="ADD"
100 D PRIOR^DGMTEVT
101 S IVMZ10="UPLOAD IN PROGRESS"
102 S IVMFUTR=0 ;this flag will indicate whether or not a test with a future date is being uploaded
103 S IVMMTIEN=0
104 ;
105 S MSGID=$P(IVMSEG,HLFS,10) ; msg control id for ACK's
106 ; - check if DCD messaging is enabled
107 I '$$DCDON^IVMUPAR1() D PROB^IVMCMC("Facility has DCD messaging disabled") Q
108 ;
109 ; - check HL7 msg structure for errors
110 K HLERR,^TMP($J,"IVMCM")
111 D ^IVMCMC I $D(HLERR) K:HLERR="" HLERR Q
112 ;
113 ; Determine type of test/transmission
114 S IVMTYPE=0
115 ;
116 ; - was a means test sent?
117 I $P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2) S IVMTYPE=1 ; MT trans
118 ;
119 ; - if MT and CT transmitted, error - pt can't have both unless
120 ; one is a deletion, but HEC not currently handling that situation
121 I IVMTYPE,$P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2) D PROB^IVMCMC("Patient can not have both a Means Test and Copay Test") Q
122 I $P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2) S IVMTYPE=2 ; CT trans
123 ;
124 ; - if no MT or CT or LTC then Income Screening
125 I 'IVMTYPE,'$P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2) S IVMTYPE=3 ; IS trans
126 ;
127 ;send an eligibility query if no eligibility code
128 I '$$ELIG^IVMCUF1(DFN),'$$PENDING^DGENQRY(DFN) I $$SEND^DGENQRY1(DFN)
129 ;
130 ; obtain locks used to sychronize upload with local income test options
131 D GETLOCKS^IVMCUPL(DFN)
132 ;
133 ;
134MT ; If transmission is a Means Test
135 N NODE0,RET,CODE,DATA
136 S HLQ=$G(HL("Q"))
137 S:HLQ="" HLQ=""""""
138 I IVMTYPE=1 D I $D(HLERR) G PROCQ
139 .S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,2))
140 .S TMSTAMP=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,25))
141 .S HSDATE=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,24))
142 .S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,22)
143 .S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,1)
144 .; Check that test is for same year
145 .I $P(IVMLAST,U,2),$E($P(IVMLAST,U,2),1,3)'=$E(IVMMTDT,1,3) S IVMLAST=""
146 .I $$Z06MT^EASPTRN1(+IVMLAST) D PROB^IVMCMC("IVM Means Test already on file for this year") Q
147 .I '$$ELIG^IVMUFNC5(DFN) S ERRMSG="Means Test upload not appropriate for current patient"
148 .I $$AGE^IVMUFNC5(DT)>$$INCY^IVMUFNC5(IVMMTDT) D
149 ..N CATCZMT S CATCZMT=$G(^TMP($J,"IVMCM","ZMT1"))
150 ..S CATC=$$CATC^IVMUFNC5(CATCZMT)
151 ..I '+$G(CATC) S ERRMSG="Only Means Tests in current/previous income years are valid (not effective)"
152 .I $G(ERRMSG)'="" D PROB^IVMCMC(ERRMSG) K ERRMSG,CATC Q
153 .;
154 .; - perform edit checks and file MT
155 .D CHKDT
156 .;deletion indicator sent?
157 .I $P($G(^TMP($J,"IVMCM","ZMT1")),HLFS,3)=HLQ D Q
158 ..D
159 ...;if there is a future test for that income year, delete that
160 ...N IEN,DATA,IVMPAT
161 ...S IEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),1,.IVMPAT)
162 ...I IEN S DATA(.06)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA)
163 ...I IEN,$D(^DGMT(408.31,IEN,0)) D
164 ....S IVMMTIEN=IEN
165 ....S IVMFUTR=1
166 ...E D
167 ....S IVMFUTR=0
168 ..Q:('IVMMTIEN)
169 ..S NODE0=$G(^DGMT(408.31,IVMMTIEN,0))
170 ..I $$EN^IVMCMD(IVMMTIEN) D
171 ...S RET=$$LST^DGMTU(DFN,DT,IVMTYPE)
172 ...S CODE=$S(($E($P(RET,"^",2),1,3)=$E(DT,1,3)):$P(RET,"^",4),1:"")
173 ...D ADD^IVMCMB(DFN,IVMTYPE,$S(IVMFUTR:"DELETE FUTR TEST",1:"DELETE PRMRY TEST"),+$G(NODE0),$$GETCODE^DGMTH($P(NODE0,"^",3)),CODE)
174 .;
175 .;check timestamp - if matches current primary test and hardship matches, then this is a duplicate and does not need to be uploaded
176 .I TMSTAMP D
177 ..S NODE=""
178 ..I IVMFUTR N IVMMTIEN S IVMMTIEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),1)
179 ..Q:'IVMMTIEN
180 ..S NODE=$G(^DGMT(408.31,IVMMTIEN,2))
181 .S NODE0=$G(^DGMT(408.31,IVMMTIEN,0))
182 .I TMSTAMP,TMSTAMP=$P(NODE,"^",2),IVMMTDT=$P(NODE0,"^"),SOURCE=$P(NODE,"^",5),(HSDATE=$P(NODE,"^")) Q
183 .;
184 .D DELTYPE^IVMCMD(DFN,IVMMTDT,2)
185 .D EN^IVMCM1
186 ;
187 ;
188CT ; If transmission is a Copay Test
189 N NODE0,RET,CODE,DATA
190 I IVMTYPE=2 D I $D(HLERR) G PROCQ
191 .S IVMMTDT=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,2))
192 .S TMSTAMP=$$FMDATE^HLFNC($P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,25))
193 .S SOURCE=$P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,22)
194 .S IVMLAST=$$LST^DGMTU(DFN,$E(IVMMTDT,1,3)_1231,2)
195 .S IVMCPAY=$$RXST^IBARXEU(DFN)
196 .I $$AGE^IVMUFNC5(DT)>$$INCY^IVMUFNC5(IVMMTDT) D PROB^IVMCMC("Only Copay Tests in the current/previous income years are valid. (Not effective)") Q
197 .; - perform edit checks and file CT
198 .D CHKDT
199 .;deletion indicator sent?
200 .I $P($G(^TMP($J,"IVMCM","ZMT2")),HLFS,3)=HLQ D Q
201 ..D
202 ...;if there is a future test for that income year, delete that
203 ...N IEN,DATA,IVMPAT
204 ...S IEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),2,.IVMPAT)
205 ...I IEN S DATA(.07)="" I $$UPD^DGENDBS(301.5,IVMPAT,.DATA)
206 ...I IEN,$D(^DGMT(408.31,IEN,0)) D
207 ....S IVMMTIEN=IEN
208 ....S IVMFUTR=1
209 ...E D
210 ....S IVMFUTR=0
211 ..Q:('IVMMTIEN)
212 ..S NODE0=$G(^DGMT(408.31,IVMMTIEN,0))
213 ..I $$EN^IVMCMD(IVMMTIEN) D
214 ...S RET=$$LST^DGMTU(DFN,DT,IVMTYPE)
215 ...S CODE=$S(($E($P(RET,"^",2),1,3)=$E(DT,1,3)):$P(RET,"^",4),1:"")
216 ...D ADD^IVMCMB(DFN,IVMTYPE,$S(IVMFUTR:"DELETE FUTR TEST",1:"DELETE PRMRY TEST"),+$G(NODE0),$$GETCODE^DGMTH($P(NODE0,"^",3)),CODE)
217 .;
218 .;check timestamp - if matches current primary test, then this is a duplicate and does not need to be uploaded
219 .I TMSTAMP D
220 ..S NODE=""
221 ..I IVMFUTR N IVMMTIEN S IVMMTIEN=$$FUTURE(DFN,($E(IVMMTDT,1,3)-1),2)
222 ..Q:'IVMMTIEN
223 ..S NODE=$G(^DGMT(408.31,IVMMTIEN,2))
224 .S NODE0=$G(^DGMT(408.31,IVMMTIEN,0))
225 .I TMSTAMP,TMSTAMP=$P(NODE,"^",2),IVMMTDT=$P(NODE0,"^"),SOURCE=$P(NODE,"^",5) Q
226 .;
227 .D DELTYPE^IVMCMD(DFN,IVMMTDT,1)
228 .D EN^IVMCM1
229 ;
230IS ; - If transmission is income screening info only then do not process
231 ; - outside of the scope of MTS
232 ;I IVMTYPE=3 S IVMMTDT=0 D EN^IVMCM1 I $D(HLERR) G PROCQ
233 I IVMTYPE=3 S IVMMTDT=0
234 ;
235LTC ; If transmission contains a Long Term Care Test (TYPE 4 TEST)
236 I $P($G(^TMP($J,"IVMCM","ZMT4")),HLFS,2) D LTC^IVMCM1
237 ;
238PROCQ ;
239 ; release locks used to sychronize upload with local income test options
240 D RELLOCKS^IVMCUPL(DFN)
241 Q
242 ;
243CHKDT ; check date of income test being uploaded
244 ; Is it a future date? If so, set IVMFUTR=1
245 ;
246 ; IVMMTIEN is the IEN of current primary test for the year
247 ;
248 I $E($P(IVMLAST,"^",2),1,3)=$E(IVMMTDT,1,3) S IVMMTIEN=+IVMLAST
249 I IVMMTDT>DT S IVMFUTR=1
250 Q
251FUTURE(DFN,YEAR,TYPE,IVMPAT) ;
252 ;Returns the ien of the future test, if there is one
253 ;Inputs: DFN
254 ; YEAR - income year
255 ; TYPE - type of test
256 ;Output:
257 ; function value - ien of future means test, if there is one, "" otherwise
258 ; IVMPAT - Pointer to the IVM Patient file for the income year if there is an entry (pass by reference)
259 ;
260 N RET
261 S RET=""
262 S IVMPAT=$$FIND^IVMPLOG(DFN,YEAR)
263 I IVMPAT S RET=$P($G(^IVM(301.5,IVMPAT,0)),"^",$S(TYPE=1:6,1:7))
264 Q RET
Note: See TracBrowser for help on using the repository browser.