source: WorldVistAEHR/trunk/r/INCOME_VERIFICATION_MATCH-IVM/IVMCME5.m@ 1608

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

initial load of WorldVistAEHR
File size: 6.6 KB
Line 
1IVMCME5 ;ALB/SEK,KCL,BRM,AEG,BRM,TDM - CHECK INCOME TEST DATA (CON'T.) ; 1/9/03 3:51pm
2 ;;2.0;INCOME VERIFICATION MATCH;**17,26,38,49,58,62,67**;21-OCT-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6 ; This routine is called from IVMCME4.
7 ;
8MT(STRING,INCOME) ; Calculate means test status
9 ;
10 ; - init vars
11 N X,Y,ADJ,HAR,INC,NET,THRESH,THRESHA,THRESHT,IVMTEXT,XMSUB,CAT,CAT1
12 N THRESHG,THRESHV,EXP,NWC,DGMTICYR
13 ;DGMTBS - BASE THRESHOLD VALUE FOR SITE
14 ;DGMTBH - BASE THRESHOLD VALUE SENT FROM HEC
15 ;DGTDEP - TOTAL # OF DEPENDENTS SENT BY HEC.
16 N VADM,DGMTBS,DGMTBH,DGTDEP,ECODE,DGMTICY ;BRM added for IVM*2*26
17 ;
18 ; - perform initial error checking
19 S CAT1=$P(STRING,HLFS,3)
20 I '$$GETSTAT^DGMTH(CAT1,1) S ERROR="Invalid Means Test Status" G MTQ
21 ;
22 S CAT=$P(STRING,HLFS,26)
23 ;
24 I CAT="" S CAT=CAT1
25 I CAT'="A",CAT'="C",CAT'="P",CAT'="G" S ERROR="Invalid Means Test Status for Test-Determined Status" G MTQ
26 ;
27 ; - if previous yr mt threshold flag is set use date of prev year
28 S X=$S($P(STRING,HLFS,11):($E($P(STRING,HLFS,2),1,4)-1),1:$E($P(STRING,HLFS,2),1,4)),DGMTICY=$P($G(STRING),HLFS,2)
29 N Y S Y=$$HL7TFM^XLFDT(DGMTICY,"1D") X ^DD("DD") S DGMTICY=Y
30 ;
31 S %DT="" D ^%DT S X=Y K %DT
32 ;
33 S THRESH=$G(^DG(43,1,"MT",X,0)),THRESHT=$P(THRESH,U,2),DGMTBS=THRESHT
34 I $P(STRING,HLFS,12) S THRESHT=THRESHT+$P(THRESH,U,3)+(($P(STRING,HLFS,12)-1)*$P(THRESH,U,4)),DGTDEP=$P($G(STRING),HLFS,12)
35 S DGMTICYR=$$LYR^DGMTSCU1($$HL7TFM^XLFDT($P(STRING,HLFS,2)))
36 S THRESHV=$$GMTT(DFN,DGMTICYR,$G(DGTDEP))
37 ;
38 S INC=$P(STRING,HLFS,4)
39 S EXP=$P(STRING,HLFS,9)
40 S NET=$P(STRING,HLFS,5)
41 S NWC=+$G(^DG(43,1,"GMT")) ; net worth calculation flag
42 S ADJ=$P(STRING,HLFS,6)
43 S THRESHA=$P(STRING,HLFS,8),DGMTBH=THRESHA
44 S THRESHG=$P(STRING,HLFS,28)
45 I $P(STRING,HLFS,12),(THRESHA'=THRESHT) S THRESHA=THRESHA+$P(THRESH,U,3)+(($P(STRING,HLFS,12)-1)*$P(THRESH,U,4))
46 S DECLINE=$P(STRING,HLFS,16)
47 S HAR=$P(STRING,HLFS,13)
48 ;
49 ; - perform error checking
50 I DECLINE,((CAT="A")!(CAT="G")) S ERROR="Declines to give income info-must be MT Copay Required" G MTQ
51 I DECLINE,CAT="C" G MTQ
52 ;
53 ; - if threshold A is incorrect, send message to sites's IVM MESSAGE
54 ; mail group and continue to process
55 I CAT'="G"&(THRESHT'=THRESHA) D
56 .;
57 .;brm;27apr00;code modifications below to add PID and Name to message
58 .D:$G(DFN)'=""
59 ..N VAHOW,VAROOT,VAPTYP
60 ..D DEM^VADPT
61 .S XMSUB="MT threshold discrepancy - "
62 .S XMSUB=XMSUB_"PID - "_$P($G(VADM(2)),U,2)
63 .S IVMTEXT(1)="While uploading the following income test from HEC a"
64 .S IVMTEXT(2)="discrepancy was found with the threshold values."
65 .S IVMTEXT(3)=" ",IVMTEXT(4)=" NAME: "_$G(VADM(1))
66 .S IVMTEXT(5)=" ",IVMTEXT(6)=" PID : "_$P($G(VADM(2)),"^",2)
67 .S IVMTEXT(8)=" ",IVMTEXT(9)="Date of Test sent from HEC: "_DGMTICY
68 .S IVMTEXT(10)=" "
69 .S IVMTEXT(11)="Site MT Threshold value: "_$J($FN($G(THRESHT),",",0),6)
70 .S IVMTEXT(12)=" "
71 .S IVMTEXT(13)="HEC Transmitted MT Threshold value: "_$J($FN($G(DGMTBH),",",0),6)
72 .S IVMTEXT(14)=" ",IVMTEXT(16)="Total number of dependents: "_$G(DGTDEP)
73 .S IVMTEXT(17)=" "
74 .;brm;27apr00;end of changes
75 .;
76 .D MAIL^IVMUFNC("DGMT MT/CT UPLOAD ALERTS")
77 .Q
78 I (INC-EXP)'>THRESHA D I ERROR]"" G MTQ
79 .I NET']"" S ERROR="This veteran requires net worth" Q
80 .I ((NET-EXP)+$S(NWC:0,1:INC)'>$P(THRESH,U,8))&((CAT="C")!(CAT="G")) S ERROR="Income plus net worth not greater than threshold value-incorrect status" Q
81 .I ((NET-EXP)+$S(NWC:0,1:INC)>$P(THRESH,U,8))&(CAT="A"),'$P(STRING,HLFS,6) S ERROR="Patient should be adjudicated-no adjudicated date/time" Q
82 I (INC-EXP)>THRESHA,CAT'="C",'HAR,'ADJ,CAT'="P",CAT'="G" S ERROR="Incorrect means test status for Test-Determined Status"
83MTQ Q
84 ;
85 ;
86CO(STRING) ; Calculate copay test status
87 ;
88 ; - init vars
89 N CAT,CAT1,COPDT,DECLINE,DEDEX,DEP,DGCAT,DGCOPS,DGCOST,INC
90 ;
91 ; - vars containing ZMT fields
92 S COPDT=$$FMDATE^HLFNC($P(STRING,HLFS,2))
93 S CAT1=$P(STRING,HLFS,3)
94 I '$$GETSTAT^DGMTH(CAT1,2) S ERROR="Invalid Copay Test Status" G COQ
95 ;
96 ;For the Test-Determined Status only
97 ; - a status of E or M or P should be transmitted
98 ; - P only is networth is used to determine exemption
99 S CAT=$P(STRING,HLFS,26)
100 I CAT="" S CAT=CAT1
101 I CAT'="E",CAT'="M",CAT'="P" S ERROR="Invalid Copay Test Status for Test-Determined Status" G COQ
102 I CAT="P",'$$NETW^IBARXEU1 S ERROR="Invalid Copay Test Status for Test-Determined Status" G COQ
103 ;
104 ; - a status of E or M or P should be transmitted
105 ; - P only is networth is used to determine exemption
106 I CAT'="E",CAT'="M",CAT'="P" S ERROR="Invalid Copay Test Status" G COQ
107 I CAT="P",'$$NETW^IBARXEU1 S ERROR="Invalid Copay Test Status" G COQ
108 S INC=$P(STRING,HLFS,4)
109 S DEDEX=$P(STRING,HLFS,9)
110 S DEP=$P(STRING,HLFS,12)
111 S DECLINE=$P(STRING,HLFS,16)
112 ;
113 S DGCOST=COPDT_U_DFN_U_U_INC,$P(DGCOST,U,14)=DECLINE,$P(DGCOST,U,15)=DEDEX,$P(DGCOST,U,18)=DEP,$P(DGCOST,U,19)=2
114 S DGCOPS=$$INCDT^IBARXEU1(DGCOST)
115 S DGCAT=$S(+DGCOPS=1:"E",+DGCOPS=2:"M",+DGCOPS=3:"P",1:"I")
116 I CAT'=DGCAT S ERROR="Copay Test Status should be "_DGCAT
117COQ Q
118 ;
119 ;
120INC ; Gather income totals
121 N DEBD,DEB,DEBT,DGX,EXCL,INC,INCYR,NET,X,Y
122 I $P(STRING,HLFS,4)']"",'$$IS^IVMCUC(DFN,DGLY),'$P(STRING,HLFS,16) S ERROR="No Income transmitted"
123 S INC=$P(ARRAY("ZIC"),HLFS,21),DEBT=$P(ARRAY("ZIC"),HLFS,22),NET=$P(ARRAY("ZIC"),HLFS,23)
124 S DGX=0 F S DGX=$O(ARRAY(DGX)) Q:'DGX D
125 .S INC=INC+($P(ARRAY(DGX,"ZIC"),HLFS,21))
126 .S NET=NET+($P(ARRAY(DGX,"ZIC"),HLFS,23))
127 .I $P(ARRAY(DGX,"ZDP"),U,6)'=2 D Q
128 ..S X=$E($P(ARRAY("ZMT"),U,2),1,4),%DT="" D ^%DT S INCYR=Y
129 ..S EXCL=$P($G(^DG(43,1,"MT",INCYR,0)),U,17)
130 ..S DEBD=($P(ARRAY(DGX,"ZIC"),HLFS,9)-EXCL-$P(ARRAY(DGX,"ZIC"),HLFS,15))
131 ..S DEBD=$S(DEBD>0:DEBD,1:0)
132 ..S DEB=($P(ARRAY(DGX,"ZIC"),HLFS,9)-DEBD)
133 ..S DEBT=DEBT+DEB
134 .S DEBT=DEBT+($P(ARRAY(DGX,"ZIC"),HLFS,22))
135INCQ Q
136 ;
137 ;
138SIGN ; Date Veteran Signed/Refused to Sign
139 I $P(STRING,HLFS,15)]"" D G:ERROR]"" SIGNQ
140 .S X=$P(STRING,HLFS,15) I $E(X,1,4)<1994!($E(X,1,4)>($E(DT,1,3)+1700)) S ERROR="Invalid Date Veteran Signed Test" Q
141 .S X=$$FMDATE^HLFNC($P(STRING,HLFS,15)),%DT="X" D ^%DT I Y<0 S ERROR="Invalid Date Veteran Signed Test" Q
142SIGNQ Q
143 ;
144LTC(STRING) ;calculate LTC test status
145 ;
146 N CAT1
147 S CAT1=$P(STRING,HLFS,3)
148 I '$$GETSTAT^DGMTH(CAT1,4) S ERROR="Invalid LTC Test Status"
149 Q
150 ;
151GMTT(DFN,DGMTICY,DGTDEP) ;Get GMT Threshold values for veteran
152 ; Input: DFN = Patient IEN
153 ; DGMTICY = Last Income year
154 ; DGTDEP = Total number of dependents
155 ;Output: GMTT = GMT Thresholds for Veteran
156 ;
157 N DGMTGMT,GMT,GMTT,PCT
158 S GMTT=0
159 D GETFIPS^EASAILK(DFN,DGMTICY,.GMT)
160 I '$G(GMT("GMTIEN")) Q GMTT
161 S DGMTGMT=$G(^EAS(712.5,GMT("GMTIEN"),1))
162 I (DGTDEP+1)<9 S GMTT=$P(DGMTGMT,"^",(DGTDEP+1)) Q GMTT
163 S PCT=((DGTDEP+1)-8)*8+132,GMTT=$P(DGMTGMT,"^",4)*PCT/100
164 S GMTT=$S(GMTT#50=0:GMTT,1:GMTT+(50-(GMTT#50)))
165 Q GMTT
Note: See TracBrowser for help on using the repository browser.