source: WorldVistAEHR/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASEZF2.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: 9.2 KB
Line 
1EASEZF2 ;ALB/jap - Filing 1010EZ Data to Patient Database ;10/31/00 13:07
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,9,51,57**;Mar 15, 2001
3 ;
4F408(EASAPP,EASDFN) ;
5 N KEYIEN,FILE,SUBFILE,FLD,DATAKEY,MULTIPLE,MM,SECT,QUES,SUBIEN,ACCEPT,EZDATA,PTDATA,LINK
6 N DFN,DGPR12,INCYR,TESTYR,LASTINC,XLINK,EROOT,EAS,ERR,IENS,MSG,X,Y
7 Q:'$G(EASDFN)
8 ;determine income year for financial data
9 S Y=$P($G(^EAS(712,EASAPP,0)),U,6) I Y="" S Y=DT
10 S %F=5,X=$$FMTE^XLFDT(Y,%F),X=+$P(X,"/",3)-1,%DT="P" D ^%DT S INCYR=Y
11 S YREND=$E(DT,1,3)_"1231"
12 ;don't file any 408 data if applicant has income test for current year at this site
13 S LASTINC=$$LST^DGMTU(EASDFN,YREND,1) I LASTINC="" S LASTINC=$$LST^DGMTU(EASDFN,YREND,2)
14 S TESTYR=$P(LASTINC,U,2)
15 Q:($E(TESTYR,1,3)=$E(DT,1,3))&($P(LASTINC,U,5)>1)
16 ;
17 ;DGPR12("AP") is the Applicant's (veteran's) IEN in file #408.12
18 S DGPR12("AP")=""
19 ;add Applicant to file #408.12 if not there already;
20 ;make this addition even if no other financial data is available;
21 I '$D(^DGPR(408.12,"B",EASDFN)) D
22 .;create the file #408.12 record
23 .K EAS,ERR,EZIENS
24 .S EAS(EASAPP,408.12,"+1,",".01")=EASDFN
25 .S EAS(EASAPP,408.12,"+1,",".02")=1
26 .S EAS(EASAPP,408.12,"+1,",".03")=EASDFN_";DPT("
27 .S EROOT="EAS("_EASAPP_")"
28 .D UPDATE^DIE("S",EROOT,"EZIENS","ERR")
29 .S DGPR12("AP")=$G(EZIENS(1))
30 .Q:DGPR12("AP")=""
31 .;create the subfile #408.1275 record
32 .K EAS,ERR,EZIENS
33 .;S KEY=+$$KEY711^EASEZU1("APPLICANT DATE OF BIRTH")
34 .;S DOB=$P($$DATA712^EASEZU1(EASAPP,KEY,1),U,1)
35 .;use DOB from file #2
36 .S X=$P($G(^DPT(EASDFN,0)),U,3),%DT="PX" D ^%DT S DOB=Y
37 .S EAS(EASAPP,408.1275,"+1,"_DGPR12("AP")_",",".01")=DOB
38 .S EAS(EASAPP,408.1275,"+1,"_DGPR12("AP")_",",".02")="YES"
39 .D UPDATE^DIE("ES",EROOT,"EZIENS","ERR")
40 .;link 1010EZ data with new record in #408.12
41 I DGPR12("AP")="" S DGPR12("AP")=$O(^DGPR(408.12,"B",EASDFN,0))
42 ;if no record for Applicant in file #408.12 exists, then don't continue
43 Q:DGPR12("AP")=""
44 ;
45 ;kill local holding arrays
46 K AP,SP,CN,FLINK
47 ;get data for file #408.12,#408.13,#408.21,#408.22 into local arrays
48 S SECT=""
49 F S SECT=$O(^TMP("EZTEMP",$J,SECT)) Q:SECT="" S MULTIPLE=0 D
50 .F S MULTIPLE=$O(^TMP("EZTEMP",$J,SECT,MULTIPLE)) Q:MULTIPLE="" S QUES="" D
51 ..F S QUES=$O(^TMP("EZTEMP",$J,SECT,MULTIPLE,QUES)) Q:QUES="" D
52 ...S DATAKEY=SECT_";"_QUES
53 ...;call to suppress may be redundant
54 ...Q:$$SUPPRESS^EASEZU4(EASAPP,DATAKEY,1,EASVRSN)
55 ...S X=^TMP("EZTEMP",$J,SECT,MULTIPLE,QUES)
56 ...S KEYIEN=$P(X,U,1),EZDATA=$P(X,U,2),ACCEPT=$P(X,U,3),SUBIEN=$P(X,U,4),PTDATA=$P(X,U,5)
57 ...S LN=^TMP("EZDATA",$J,KEYIEN),FILE=$P(LN,U,1),SUBFILE=$P(LN,U,2),FLD=$P(LN,U,3)
58 ...Q:($P(FILE,".",1)'=408)
59 ...S LINK=$P($G(^EAS(712,EASAPP,10,SUBIEN,2)),U,2)
60 ...S DATANM=$P($G(^EAS(711,KEYIEN,0)),U,1)
61 ...S MM=MULTIPLE S:DATANM["CHILD(N)" MM=MULTIPLE+1
62 ...I (SECT="IIF")!(SECT="IIG") S MM=MULTIPLE
63 ...S ARR=$S(DATANM["SPOUSE":"SP",DATANM["CHILD":"CN",1:"AP")
64 ...S @ARR@(MM,FILE,SUBFILE,FLD)=EZDATA_U_ACCEPT_U_SUBIEN_U_PTDATA_U_LINK
65 ;delete any Spouse or Dependent data if #.01 field for file #408.13 does not exist
66 I $D(SP(1,408.13,408.13,.01))'=1 K SP
67 ;if contributed to spouse, applicant lived with patient = NO
68 I +$P($G(AP(1,408.22,408.22,.07)),U,1) D
69 .S AP(1,408.22,408.22,.06)="NO^2^^^"_$P(AP(1,408.22,408.22,.07),U,5)
70 S MM=0 F S MM=$O(CN(MM)) Q:'MM D
71 .I $D(CN(MM,408.13,408.13,.01))'=1 K CN(MM) Q
72 .;check for amt contributed to child
73 .I +$P($G(CN(MM,408.22,408.22,.19)),U,1) D
74 ..S CN(MM,408.22,408.22,.1)="YES^2^^^"_$P(CN(MM,408.22,408.22,.19),U,5)
75 ..S CN(MM,408.22,408.22,.06)="NO^2^^^"_$P(CN(MM,408.22,408.22,.19),U,5)
76 ;
77 ;gather links to VistA for Applicant
78 S FLINK("AP",1,408.12)=DGPR12("AP")
79 F FILE=408.21,408.22 D
80 .S XLINK="",MULTIPLE=1,SUBFILE=FILE,FLD=""
81 .F S FLD=$O(AP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
82 ..S FLINK("AP",1,FILE)=+$P(AP(MULTIPLE,FILE,SUBFILE,FLD),U,5)
83 ;gather links to VistA for Spouse
84 F FILE=408.12,408.13,408.21,408.22 D
85 .S XLINK="",MULTIPLE=1,SUBFILE=FILE,FLD=""
86 .F S FLD=$O(SP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
87 ..S FLINK("SP",MULTIPLE,FILE)=+$P(SP(MULTIPLE,FILE,SUBFILE,FLD),U,5)
88 .I FILE=408.12 S SUBFILE=408.1275 F S FLD=$O(SP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
89 ..S FLINK("SP",MULTIPLE,SUBFILE)=$P($P(SP(MULTIPLE,FILE,SUBFILE,FLD),U,5),";",2)
90 ..S FLINK("SP",MULTIPLE,FILE)=$P($P(SP(MULTIPLE,FILE,SUBFILE,FLD),U,5),";",1)
91 ;gather links to VistA for Dependents
92 S MULTIPLE=0 F S MULTIPLE=$O(CN(MULTIPLE)) Q:'MULTIPLE D
93 .F FILE=408.13,408.12,408.21,408.22 D
94 ..S XLINK="",SUBFILE=FILE,FLD=""
95 ..F S FLD=$O(CN(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
96 ...S FLINK("CN",MULTIPLE,FILE)=+$P(CN(MULTIPLE,FILE,SUBFILE,FLD),U,5)
97 ..I FILE=408.12 S SUBFILE=408.1275 F S FLD=$O(CN(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
98 ...S FLINK("CN",MULTIPLE,SUBFILE)=$P($P(CN(MULTIPLE,FILE,SUBFILE,FLD),U,5),";",2)
99 ...S FLINK("CN",MULTIPLE,FILE)=$P($P(CN(MULTIPLE,FILE,SUBFILE,FLD),U,5),";",1)
100 ;
101 ;file data
102 Q:DGPR12("AP")=""
103 S DFN=EASDFN
104 D AP
105 I $D(FLINK("SP")) D SP^EASEZF3
106 I $D(FLINK("CN")) D CN^EASEZF4
107 D LINKUP^EASEZF4
108 ;
109 Q
110 ;
111AP ;file Applicant data
112 N MT,P22,MULTIPLE,FILE,SUBFILE,FLD,XDATA,ACCEPT,SUBIEN,EZDATA,EAS,ERR,KEY
113 F FILE=408.21,408.22 D
114 .S MULTIPLE=1,SUBFILE=FILE,FLD=""
115 .S XLINK=$G(FLINK("AP",1,FILE))
116 .;record in file #408.21 needed for all further data filing
117 .Q:(FILE'=408.21)&('$G(FLINK("AP",1,408.21)))
118 .;for data elements with link to database,
119 .;only file 1010EZ data if accepted by user;
120 .;data in external format
121 .I XLINK D
122 ..S FLD="" F S FLD=$O(AP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
123 ...S XDATA=AP(MULTIPLE,FILE,SUBFILE,FLD),ACCEPT=$P(XDATA,U,2)
124 ...I ACCEPT D LINK(XDATA,FILE,FLD,"AP",MULTIPLE)
125 .;for data elements with no link to database,
126 .;always create new record(s) to store 1010EZ data;
127 .;use internal data format
128 .I 'XLINK D
129 ..K EAS,ERR
130 ..S FLD="" F S FLD=$O(AP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
131 ...S EZDATA=$P(AP(MULTIPLE,FILE,SUBFILE,FLD),U,1)
132 ...S EAS(EASAPP,FILE,"+1,",FLD)=EZDATA
133 ..I FILE=408.21 D
134 ...S EAS(EASAPP,FILE,"+1,",".01")=INCYR
135 ...S EAS(EASAPP,FILE,"+1,",".02")=FLINK("AP",1,408.12)
136 ...S EAS(EASAPP,FILE,"+1,","101")=DUZ
137 ...S EAS(EASAPP,FILE,"+1,","102")=DT
138 ...S EAS(EASAPP,FILE,"+1,","103")=DUZ
139 ...S EAS(EASAPP,FILE,"+1,","104")=DT
140 ..I FILE=408.22,$G(FLINK("AP",1,408.21)) D
141 ...S EAS(EASAPP,FILE,"+1,",".01")=EASDFN
142 ...S EAS(EASAPP,FILE,"+1,",".02")=FLINK("AP",1,408.21)
143 ...I $G(SP(1,408.13,408.13,.01))'="" S EAS(EASAPP,FILE,"+1,",".05")=1
144 ...I $G(CN(1,408.13,408.13,.01))'="" S EAS(EASAPP,FILE,"+1,",".08")=1
145 ...S X=$G(EAS(EASAPP,FILE,"+1,",".06"))
146 ...S EAS(EASAPP,FILE,"+1,",".06")=$S(X="YES":1,X="NO":0,1:"")
147 ..S FLINK("AP",MULTIPLE,FILE)=$$NOLINK(.EAS,"AP",MULTIPLE)
148 ..S FLD="" F S FLD=$O(AP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
149 ...S SUBIEN=$P(AP(MULTIPLE,FILE,SUBFILE,FLD),U,3)
150 ...;store link to new record in subfile #712.01
151 ...S $P(AP(MULTIPLE,FILE,SUBFILE,FLD),U,5)=FLINK("AP",1,FILE)
152 ;
153 Q
154 ;
155LINK(XDATA,FILE,FLD,GRP,MULTIPLE) ;setup to call FM database server if link to file exists & data accepted
156 N MSG,EZDATA,SUBIEN,PTDATA,XLINK
157 K EAS,ERR
158 S EZDATA=$P(XDATA,U,1),SUBIEN=$P(XDATA,U,3),PTDATA=$P(XDATA,U,4),XLINK=$P(XDATA,U,5)
159 S IENS=XLINK_","
160 S EROOT="EAS("_EASAPP_")"
161 D VAL^DIE(FILE,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
162 I $D(ERR) D ERROR(GRP,MULTIPLE,.ERR,"LINK") Q
163 ;file to database if input is valid
164 I '$D(ERR) D
165 .I FILE=408.21 D
166 ..S EAS(EASAPP,FILE,IENS,103)=DUZ
167 ..S EAS(EASAPP,FILE,IENS,104)=DT
168 .D FILE^DIE("S",EROOT,"ERR")
169 .;set any replaced data into subfile #712.01 for audit
170 .I SUBIEN S $P(^EAS(712,EASAPP,10,SUBIEN,2),U,1)=PTDATA
171 Q
172 ;
173NOLINK(EAS,GRP,MULTIPLE) ;add new record with accepted data if no link exists;
174 ;
175 K EZIENS,ERR,LINK
176 S EROOT="EAS("_EASAPP_")"
177 D UPDATE^DIE("S",EROOT,"EZIENS","ERR")
178 ;call to UPDATE should not return ERR since internal data formats are used, but just in case;
179 I $D(ERR) D ERROR(GRP,MULTIPLE,.ERR,"NOLINK")
180 ;return ien to new record
181 S LINK=$G(EZIENS(1))
182 Q LINK
183 ;
184ERROR(GRP,MULTIPLE,ERR,FROM) ;add FM error text to error msg
185 N L,LSTLN,ECODE,ENUMBER
186 S ECODE="" F S ECODE=$O(ERR("DIERR","E",ECODE)) Q:ECODE="" S ENUMBER=0 F S ENUMBER=$O(ERR("DIERR","E",ECODE,ENUMBER)) Q:'ENUMBER D
187 .S LSTLN=+$O(^TMP("1010EZERROR",$J,""),-1) I 'LSTLN S LSTLN=6
188 .S WHO=$S(GRP="SP":"SPOUSE",GRP="CN":"CHILD",1:"APPLICANT")
189 .I WHO="CHILD" S WHO=WHO_" #"_MULTIPLE
190 .S FIELD=$G(ERR("DIERR",ENUMBER,"PARAM","FIELD")),FILE=$G(ERR("DIERR",ENUMBER,"PARAM","FILE"))
191 .I FROM="LINK" D
192 ..S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)="1010EZ data for "_WHO_" was not filed to"
193 ..S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)="Field #"_FIELD_" of File #"_FILE_" because:"
194 .I FROM="NOLINK" D
195 ..S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)="A new record for "_WHO_" could not be created in"
196 ..S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)="File #"_FILE_" because Field #"_FIELD_" produced an error:"
197 .S L=0 F S L=$O(ERR("DIERR",ENUMBER,"TEXT",L)) Q:'L D
198 ..S LN=ERR("DIERR",ENUMBER,"TEXT",L)
199 ..I $L(LN)<50 S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)=LN Q
200 ..D WRAP(LN,.LSTLN)
201 .S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)=" "
202 Q
203 ;
204WRAP(LN,LSTLN) ;parse a long error text line into several message lines
205 N PART,BB
206 F D Q:$L(LN)<41
207 .S PART=""
208 .F BB=1:1:99 S PART=PART_$P(LN," ",BB)_" " I $L(PART)>40 D Q
209 ..S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)=PART
210 ..S LN=$P(LN," ",BB+1,99)
211 S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)=LN
212 Q
Note: See TracBrowser for help on using the repository browser.