source: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMUFNC5.m@ 1005

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

initial load of WorldVistAEHR
File size: 3.1 KB
Line 
1IVMUFNC5 ;ALB/AEG - IVM UTILITIES CONTINUED ; 8/10/05 1:39pm
2 ;;2.0;INCOME VERIFICATION MATCH;**55,109**;5-10-2002
3 ;
4AGE(DT) ;
5 N Y
6 S Y=$E(DT,1,3)-1_"0000",Y=Y-10000
7 Q Y
8 ;
9INCY(IVMMTDT) ;
10 N Y
11 S Y=$E(IVMMTDT,1,3)_"0000",Y=Y-10000
12 Q Y
13 ;
14CATC(DATA) ;
15 ; Extrinsic function to determine is incoming ZMT1 segment meets
16 ; one of the following groups:
17 ; 1. Cat C or Pending Adj. / Provided income info / test date
18 ; is 10/6/99 or later and Agreed to Pay is YES.
19 ; OR
20 ;
21 ; 2. Category C based upon declination to provide income info
22 ; but agreed to pay deductible.
23 ;
24 ; Input(s): $G(^TMP($J,"IVMCM","ZMT1")) global node - Incoming ZMT
25 ; segment.
26 ;
27 ; Output(s): Function Value. 1 = Yes patient meets one of the criteria
28 ; 0 = NO test does not meet criteria.
29 N MTDAT,RETV
30 S RETV=0
31 Q:'$D(DATA) 0
32 S MTDAT("DT")=$P($G(DATA),U,2),MTDAT("MTS")=$P($G(DATA),U,3)
33 S MTDAT("APD")=$P($G(DATA),U,7),MTDAT("DCLI")=$P($G(DATA),U,16)
34 ; Patient Provided income information.
35 I '+$G(MTDAT("DCLI")) D
36 .; If Cat C or Pending Adjudication test date on or after 10/6/99
37 .; Provided Income info and Agreed to Pay.
38 .;
39 .I $G(MTDAT("MTS"))="C",$G(MTDAT("DT"))'<2991006,$G(MTDAT("APD"))=1 S RETV=1 Q
40 .I $G(MTDAT("MTS"))="P",$G(MTDAT("DT"))'<2991006,$G(MTDAT("APD"))=1 S RETV=1 Q
41 ;
42 ; Patient Declined to provide income information.
43 I +$G(MTDAT("DCLI")) D
44 .; Cat C and Agreed to Pay - No date restriction
45 .I $G(MTDAT("MTS"))="C",+$G(MTDAT("APD")) S RETV=1 Q
46 ;
47 Q RETV
48 ;
49ELIG(DFN) ; Eligibility Check for Cat C uploads older than previous
50 ; income year data.
51 ;
52 ; Input: DFN - Patient IEN
53 ; Output: Function Value 0 if Z10 upload not appropriate
54 ;
55 N IVMELI
56 S IVMELI=0
57 ; Check primary eligibility
58 I $D(^DPT(DFN,.36)) S X=^(.36) D
59 .; If NSC or SC < 50 0% appropriate to upload old test.
60 .I $P($G(^DIC(8,+X,0)),U,9)=5!($$SC(DFN)) S IVMELI=1
61 .I $P(X,U,12)=1 S IVMELI=0
62 .I $P(X,U,13)=1 S IVMELI=0
63 .K X
64 ; If deceased patient --- don't upload.
65 I +$$GET1^DIQ(2,DFN_",",.351,"I") S IVMELI=0
66 ; If eligible for medicaid, don't upload.
67 I +$$GET1^DIQ(2,DFN_",",.381,"I") S IVMELI=0
68 ; Check PH status.
69 I $P($G(^DPT(DFN,.53)),U)="Y" S IVMELI=0
70 Q IVMELI
71 ;
72SC(DFN) ; Check to see if patient is SC 0% non-compensable.
73 ; Input -- DFN Patient IEN
74 ; Output -- Function value 1=Yes or 0=No
75 ;
76 N IVMG,IVME,IVMF,IVMY
77 S IVMY=0
78 ; Primary Eligibility is SC < 50 %
79 I $D(^DPT(DFN,.36)),$P($G(^DIC(8,+X,0)),U,9)=3 S IVMY=1
80 G:'IVMY SCQ
81 ; Service Connected percentage = 0
82 I $P($G(^DPT(DFN,.3)),U,2)'=0 S IVMY=0 G SCQ
83 ; No Total annual VA Check amount
84 I $P($G(^DPT(DFN,.362)),U,20) S IVMY=0 G SCQ
85 ; POW Status indicated.
86 I $P($G(^DPT(DFN,.52)),U,5)="Y" S IVMY=0 G SCQ
87 ; Purple Heart Indicated.
88 I $P($G(^DPT(DFN,.53)),U)="Y" S IVMY=0 G SCQ
89 ; Check Secondary Eligibilities.
90 F IVMG=2,4,15:1:18 S IVME(IVMG)=""
91 S IVMG=0 F S IVMG=$O(^DPT(DFN,"E","B",IVMG)) Q:'IVMG D SEL I IVMF,$D(IVME(+IVMF)) S IVMY=0 Q
92SCQ Q +$G(IVMY)
93 ;
94SEL ;
95 S IVMF=$G(^DIC(8,+IVMG,0)) I IVMF="" Q
96 S IVMF=$P(IVMF,U,9)
97 I IVMF=""!('$D(^DIC(8.1,+IVMF,0))) D
98 .S IVMF=""
99 .Q
100 Q
Note: See TracBrowser for help on using the repository browser.