source: FOIAVistA/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMPTRN9.m@ 1446

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

initial load of FOIAVistA 6/30/08 version
File size: 8.7 KB
Line 
1IVMPTRN9 ;ALB/KCL/CN/BRM,TDM,EG - HL7 FULL DATA TRANSMISSION (Z07) BUILDER (CONTINUED) ; 4/10/06 4:36pm
2 ;;2.0;INCOME VERIFICATION MATCH;**9,11,19,12,21,17,46,50,53,34,49,58,79,99,116,105**; 21-OCT-94;Build 2
3 ;
4 ;
5GOTO ; place to break up the routine
6 ;
7 ; create (ZIO) Inpatient/Outpatient segment for veteran
8 S N101015=$G(^DPT(DFN,1010.15))
9 S ZIOSEG="ZIO^1^"_$$EN^IVMUFNC1(DFN,IVMMTDT,.IVMQUERY) ;seq 1-3
10 S ZIOSEG=ZIOSEG_"^"_$$LTD^IVMUFNC(DFN,.IVMQUERY) ;seq 4
11 S X=$P(N101015,"^",9),$P(ZIOSEG,U,6)=$S(X=0:"N",X=1:"Y",1:HLQ) ;Appt Request
12 S X=$P(N101015,"^",11),$P(ZIOSEG,U,7)=$S(X]"":$$HLDATE^HLFNC(X),1:HLQ) ;Appt Request Date
13 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=ZIOSEG
14 ;
15 ; create (NTE) Notes and Comments segment
16 D NTE^IVMUFNC4(DFN,.IVMNTE,IVMMTDT)
17 I '$D(IVMNTE) D
18 .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)="NTE^1"
19 I $D(IVMNTE) D
20 .; - get notes and comments
21 .F IVMSUB=0:0 S IVMSUB=$O(IVMNTE(IVMSUB)) Q:'IVMSUB D
22 ..S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=IVMNTE(IVMSUB)
23 ;
24 ; create (IN1) Insurance segment(s) for all active insurance
25 K ^TMP("VAFIN1",$J)
26 D EN^VAFHLIN1(DFN,"1,4,5,7,8,9,12,13,15,16,17,28,36")
27 F IVMSUB=0:0 S IVMSUB=$O(^TMP("VAFIN1",$J,IVMSUB)) Q:'IVMSUB D
28 .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=^TMP("VAFIN1",$J,+IVMSUB,0)
29 ;
30 ;find if the deletion flags were set in the IVM Patient file, and if so, should the deletion indicators be sent?
31 F I="RX","MT","HARDSHIP","DATE OF TEST","LTC" S DELETE(I)=""
32 S IVMPIEN=$$FIND^IVMPLOG(DFN,($E(IVMMTDT,1,3)-1))
33 I IVMPIEN D
34 .S IVMPNODE=$G(^IVM(301.5,IVMPIEN,0))
35 .I $P(IVMPNODE,"^",8)!$P(IVMPNODE,"^",9)!$P(IVMPNODE,"^",10)!$P(IVMPNODE,"^",11) S DELETE("SET")=1
36 .;was the MT deletion flag set, and if so verify that there is no completed MT
37 .I $P(IVMPNODE,"^",8),(TESTTYPE'=1)!(TESTCODE="")!("ACGP"'[TESTCODE) S DELETE("DATE OF TEST")=$P(IVMPNODE,"^",8),DELETE("MT")=1
38 .;
39 .;was the hardship deletion flag set, and if so verify that there is no completed hardship
40 .I $P(IVMPNODE,"^",10),'HARDSHIP D
41 ..S:('DELETE("DATE OF TEST")) DELETE("DATE OF TEST")=$P(IVMPNODE,"^",10)
42 ..S DELETE("HARDSHIP")=1
43 ;
44 ; create (ZMT) Means Test segment
45 ;
46 S SEQS=$S(TESTTYPE=1:"1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,21,22,23,24,25,26,28,29,30",1:"1,17")
47 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,1,1,.DELETE,1)
48 ;
49 ; create (ZMT) Rx-Copay Test segment
50 I IVMPIEN D
51 .;was the RX deletion flag set, and if so verify that there is no completed test
52 .I $P(IVMPNODE,"^",9),(TESTTYPE'=2)!(TESTCODE="")!("EM"'[TESTCODE) S DELETE("DATE OF TEST")=$P(IVMPNODE,"^",9),DELETE("RX")=1
53 ;
54 N IVMCPDT,CPTST,LINK,CPDATE
55 ;should be ok to get the last co-pay test for this year vs. looking from the IVMMTDT backwards
56 ;as long as the means test date is in the current year
57 S CPTST=$$LST^DGMTU(DFN,$E(IVMIY,1,3)+1_1231,2)
58 I CPTST D
59 . S CPDATE=$P(CPTST,U,2)
60 . S LINK=$P($G(^DGMT(408.31,+CPTST,2)),U,6)
61 . I TESTTYPE=1,$E(CPDATE,1,3)=$E(IVMMTDT,1,3) D
62 . . ;if you have a means test and a linked co-pay test then send both (the means test
63 . . ;was already sent from above)
64 . . ;if means and copay are not linked, don't send the co-pay test (the means test
65 . . ;was already sent from above)
66 . . I LINK=+$$LST^DGMTU(DFN,IVMMTDT,1) S TESTTYPE=2,(IVMCPDT,IVMMTDT)=CPDATE
67 . . Q
68 . Q
69 ;always send the 2nd ZMT segment
70 S SEQS="1,17"
71 ;can also send a co-pay test if there is no means test (see module GETTYPE)
72 I TESTTYPE=2 D
73 . S SEQS="1,2,3,4,5,6,7,9,10,12,15,16,17,18,21,22,25,26"
74 . Q
75 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,2,2,.DELETE,1)
76 ;
77 ; create (ZMT) Long Term Care Copay Exemption Test segment
78 I IVMPIEN D
79 .; set deletion indicators if LTC test deletion should be transmitted
80 .I $P(IVMPNODE,"^",11) S DELETE("LTC")=1 S:('DELETE("DATE OF TEST")) DELETE("DATE OF TEST")=$P(IVMPNODE,"^",11)
81 ;
82 S SEQS="1,2,3,4,5,7,9,10,12,16,17,18,22,25"
83 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^IVMCZMT(DFN,SEQS,IVMMTDT,4,4,.DELETE,1)
84 ;
85 ;if the deletion flags were set in the IVM Patient file, unset them
86 I $G(DELETE("SET")) D
87 .N DATA
88 .S DATA(.08)="",DATA(.09)="",DATA(.1)="",DATA(.11)=""
89 .I $$UPD^DGENDBS(301.5,IVMPIEN,.DATA)
90 ;
91 ; create (ZBT) Beneficiary Travel segment based on last BT Claim
92 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZBT($$BTCLM^IVMUFNC4(DFN),"1,2,3,4,7")
93 ;
94 ; create (ZFE) Fee Basis segment(s)
95 D EN^FBHLZFE(DFN,"1,2,3,4,5")
96 F IVMSUB=0:0 S IVMSUB=+$O(FBZFE(IVMSUB)) Q:'IVMSUB D
97 .S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$G(FBZFE(+IVMSUB))
98 ;
99 ; create (ZSP) Service Period segment
100 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$EN^VAFHLZSP(DFN,1,1)
101 ;
102 ; optionally create (OBX) segment for Patient Sensitivity Flag
103 K OBXTMP
104 S OBXCNT=0,GETCUR=$$FINDSEC^DGENSEC(DFN)
105 I GETCUR,$$GET^DGENSEC(GETCUR,.DGSEC) D
106 .Q:(DGSEC("LEVEL")'=1)&(DGSEC("LEVEL")'=0)
107 .S OBXTMP(2)="CE",OBXTMP(3)="38.1"_$E(HL("ECH"))_"SECURITY LOG"
108 .S:DGSEC("LEVEL") OBXTMP(5)="Y"_$E(HL("ECH"))_"YES"_$E(HL("ECH"))_"HL70136"
109 .S:'DGSEC("LEVEL") OBXTMP(5)="N"_$E(HL("ECH"))_"NO"_$E(HL("ECH"))_"HL70136"
110 .S OBXTMP(11)="R",OBXTMP(14)=DGSEC("DATETIME")
111 .S OBXTMP(16)="" I $G(DGSEC("SOURCE"))'="" D
112 ..S $P(OBXTMP(16),$E(HL("ECH")),14)=$E(HL("ECH"),4)_DGSEC("SOURCE")
113 .S IVMCT=IVMCT+1,OBXCNT=OBXCNT+1
114 .S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLOBX(.OBXTMP,OBXCNT,"2,3,5,11,14,16")
115 .I $G(OBXTMP(16))'="" S $P(^TMP("HLS",$J,IVMCT),"^",17)=$G(OBXTMP(16))
116 ;
117 ; create (OBX) segment for NTR
118 ; CALL PIMS API TO GET NTRARRY OF NTR DATA
119 S GETCUR=$$ENRGET^DGNTAPI1(DFN)
120 I GETCUR D NTROBX^IVMPTRNA(.DGNTARR)
121 I $D(NTROBX) D
122 . S IVMCT=IVMCT+1,OBXCNT=OBXCNT+1
123 . S ^TMP("HLS",$J,IVMCT)=$$EN^VAFHLOBX(.NTROBX,OBXCNT,"2,3,5,11,12,14,15,16,17")
124 . I $G(NTROBX(16))'="" S $P(^TMP("HLS",$J,IVMCT),"^",17)=$G(NTROBX(16))
125 . K NTROBX
126 ;
127 ; create (RF1) segment
128 S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=$$RF1^IVMPTRNA(DFN,"SAD")
129 F RF1TYP="CAD","CPH","PNO","EAD" D ;Create Optional RF1 Segments
130 . S RF1SEG=$$RF1^IVMPTRNA(DFN,RF1TYP) Q:RF1SEG=""
131 . S IVMCT=IVMCT+1,^TMP("HLS",$J,IVMCT)=RF1SEG
132 ;
133 Q
134 ;
135GETTYPE(DFN,IVMMTDT,CODE,HARDSHIP,ACTVIEN) ;
136 ;Determines the type of test to include in the Z10. HEC wants only the
137 ;test that they would consider primary,i.e., preference given to a comptleted means test, even if not currently in effect.
138 ;
139 ;Input:
140 ; DFN
141 ; IVMMTDT -date to be the search for the test
142 ;Output:
143 ; Function value - type of test to send in Z10
144 ; CODE - status code of test (pass by reference)
145 ; HARDSHIP - hardship indicator (pass by reference)
146 ; ACTVIEN - ien of test that should have the associated Income Relations (pass by reference)
147 ;
148 N TESTTYPE,MTNODE,RXNODE,NODE0,NODE2
149 S TESTTYPE=1
150 S (HARDSHIP,CODE,ACTVIEN)=""
151 Q:'$G(IVMMTDT) TESTTYPE
152 Q:'$G(DFN) TESTTYPE
153 ;
154 S MTNODE=$$LST^DGMTU(DFN,IVMMTDT,1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE=""
155 S RXNODE=$$LST^DGMTU(DFN,IVMMTDT,2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE=""
156 ;
157 I MTNODE="" S MTNODE=$$FUT^DGMTU(DFN,"",1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE=""
158 I RXNODE="" S RXNODE=$$FUT^DGMTU(DFN,"",2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE=""
159 D
160 .;determine which test has the associated income relations
161 .;
162 .I +MTNODE S CODE=$P(MTNODE,"^",4) I CODE'="",("ACGPR"[CODE) S ACTVIEN=+MTNODE Q
163 .I +RXNODE S CODE=$P(RXNODE,"^",4) I CODE'="",("EMI"[CODE) S ACTVIEN=+RXNODE Q
164 .I +MTNODE S ACTVIEN=+MTNODE Q
165 .I +RXNODE S ACTVIEN=+RXNODE Q
166 I ACTVIEN,+MTNODE,+RXNODE D TRANSFER^DGMTU4(DFN,$S((ACTVIEN=+MTNODE):+RXNODE,1:+MTNODE),ACTVIEN)
167 ;
168 ;now find the primary test
169 I '(+MTNODE) G CHKCOPAY
170 S CODE=$P(MTNODE,"^",4)
171 S HARDSHIP=$P($G(^DGMT(408.31,+MTNODE,0)),"^",20)
172 I (CODE="")!("ACGP"'[CODE) S NODE2=$G(^DGMT(408.31,+MTNODE,2)),CODE=$$GETCODE^DGMTH($P(NODE2,"^",3)) I (CODE="")!("ACGP"'[CODE) G CHKCOPAY
173 ;
174 G QGETTYPE
175 ;
176CHKCOPAY ;
177 I '(+RXNODE) G QGETTYPE
178 S CODE=$P(RXNODE,"^",4)
179 I (CODE="")!("EM"'[CODE) S NODE2=$G(^DGMT(408.31,+RXNODE,2)),CODE=$$GETCODE^DGMTH($P(NODE2,"^",3)) I (CODE="")!("EM"'[CODE) G QGETTYPE
180 S TESTTYPE=2
181 ;
182QGETTYPE ;
183 Q TESTTYPE
184 ;
185FILTER(DFN) ; address transmission filter
186 ; Check Bad Address Indicator for a known bad address and
187 ; Scrutinize the Street Address line 1 field for known bad address
188 ; strings based on functionality currently in place in HEC Legacy.
189 ;
190 ; Input: DFN - ien of the Patient (#2) file
191 ; Output: 0 - filter passed (ok to transmit address)
192 ; 1 - filter failed (do not transmit address)
193 ;
194 N VAPA
195 Q:'$G(DFN) 1 ;DFN missing
196 Q:$$BADADR^DGUTL3(DFN) 1 ;check Bad Address Indicator
197 D ADD^VADPT ;get patient address
198 ; Street Address Line 1 or Zip Code is <null>
199 Q:($G(VAPA(1))="")!($P($G(VAPA(11)),"^")="") 1
200 ; St Addr Line 1 contains 'UNKNOWN', 'HOMELESS', or 'ADDRESS'
201 Q:(VAPA(1)["UNKNOWN")!(VAPA(1)["HOMELESS")!(VAPA(1)["ADDRESS") 1
202 ; The first two characters of the address is equal to '**'
203 Q:$E(VAPA(1),1,2)="**" 1
204 ; passed all address filters - ok to send
205 Q 0
Note: See TracBrowser for help on using the repository browser.