VistA-FOIAVistA/r/ENROLLMENT_APPLICATION_SYST.../EASEZF2.m

213 lines
9.2 KiB
Mathematica

EASEZF2 ;ALB/jap - Filing 1010EZ Data to Patient Database ;10/31/00 13:07
;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,9,51,57**;Mar 15, 2001
;
F408(EASAPP,EASDFN) ;
N KEYIEN,FILE,SUBFILE,FLD,DATAKEY,MULTIPLE,MM,SECT,QUES,SUBIEN,ACCEPT,EZDATA,PTDATA,LINK
N DFN,DGPR12,INCYR,TESTYR,LASTINC,XLINK,EROOT,EAS,ERR,IENS,MSG,X,Y
Q:'$G(EASDFN)
;determine income year for financial data
S Y=$P($G(^EAS(712,EASAPP,0)),U,6) I Y="" S Y=DT
S %F=5,X=$$FMTE^XLFDT(Y,%F),X=+$P(X,"/",3)-1,%DT="P" D ^%DT S INCYR=Y
S YREND=$E(DT,1,3)_"1231"
;don't file any 408 data if applicant has income test for current year at this site
S LASTINC=$$LST^DGMTU(EASDFN,YREND,1) I LASTINC="" S LASTINC=$$LST^DGMTU(EASDFN,YREND,2)
S TESTYR=$P(LASTINC,U,2)
Q:($E(TESTYR,1,3)=$E(DT,1,3))&($P(LASTINC,U,5)>1)
;
;DGPR12("AP") is the Applicant's (veteran's) IEN in file #408.12
S DGPR12("AP")=""
;add Applicant to file #408.12 if not there already;
;make this addition even if no other financial data is available;
I '$D(^DGPR(408.12,"B",EASDFN)) D
.;create the file #408.12 record
.K EAS,ERR,EZIENS
.S EAS(EASAPP,408.12,"+1,",".01")=EASDFN
.S EAS(EASAPP,408.12,"+1,",".02")=1
.S EAS(EASAPP,408.12,"+1,",".03")=EASDFN_";DPT("
.S EROOT="EAS("_EASAPP_")"
.D UPDATE^DIE("S",EROOT,"EZIENS","ERR")
.S DGPR12("AP")=$G(EZIENS(1))
.Q:DGPR12("AP")=""
.;create the subfile #408.1275 record
.K EAS,ERR,EZIENS
.;S KEY=+$$KEY711^EASEZU1("APPLICANT DATE OF BIRTH")
.;S DOB=$P($$DATA712^EASEZU1(EASAPP,KEY,1),U,1)
.;use DOB from file #2
.S X=$P($G(^DPT(EASDFN,0)),U,3),%DT="PX" D ^%DT S DOB=Y
.S EAS(EASAPP,408.1275,"+1,"_DGPR12("AP")_",",".01")=DOB
.S EAS(EASAPP,408.1275,"+1,"_DGPR12("AP")_",",".02")="YES"
.D UPDATE^DIE("ES",EROOT,"EZIENS","ERR")
.;link 1010EZ data with new record in #408.12
I DGPR12("AP")="" S DGPR12("AP")=$O(^DGPR(408.12,"B",EASDFN,0))
;if no record for Applicant in file #408.12 exists, then don't continue
Q:DGPR12("AP")=""
;
;kill local holding arrays
K AP,SP,CN,FLINK
;get data for file #408.12,#408.13,#408.21,#408.22 into local arrays
S SECT=""
F S SECT=$O(^TMP("EZTEMP",$J,SECT)) Q:SECT="" S MULTIPLE=0 D
.F S MULTIPLE=$O(^TMP("EZTEMP",$J,SECT,MULTIPLE)) Q:MULTIPLE="" S QUES="" D
..F S QUES=$O(^TMP("EZTEMP",$J,SECT,MULTIPLE,QUES)) Q:QUES="" D
...S DATAKEY=SECT_";"_QUES
...;call to suppress may be redundant
...Q:$$SUPPRESS^EASEZU4(EASAPP,DATAKEY,1,EASVRSN)
...S X=^TMP("EZTEMP",$J,SECT,MULTIPLE,QUES)
...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)
...S LN=^TMP("EZDATA",$J,KEYIEN),FILE=$P(LN,U,1),SUBFILE=$P(LN,U,2),FLD=$P(LN,U,3)
...Q:($P(FILE,".",1)'=408)
...S LINK=$P($G(^EAS(712,EASAPP,10,SUBIEN,2)),U,2)
...S DATANM=$P($G(^EAS(711,KEYIEN,0)),U,1)
...S MM=MULTIPLE S:DATANM["CHILD(N)" MM=MULTIPLE+1
...I (SECT="IIF")!(SECT="IIG") S MM=MULTIPLE
...S ARR=$S(DATANM["SPOUSE":"SP",DATANM["CHILD":"CN",1:"AP")
...S @ARR@(MM,FILE,SUBFILE,FLD)=EZDATA_U_ACCEPT_U_SUBIEN_U_PTDATA_U_LINK
;delete any Spouse or Dependent data if #.01 field for file #408.13 does not exist
I $D(SP(1,408.13,408.13,.01))'=1 K SP
;if contributed to spouse, applicant lived with patient = NO
I +$P($G(AP(1,408.22,408.22,.07)),U,1) D
.S AP(1,408.22,408.22,.06)="NO^2^^^"_$P(AP(1,408.22,408.22,.07),U,5)
S MM=0 F S MM=$O(CN(MM)) Q:'MM D
.I $D(CN(MM,408.13,408.13,.01))'=1 K CN(MM) Q
.;check for amt contributed to child
.I +$P($G(CN(MM,408.22,408.22,.19)),U,1) D
..S CN(MM,408.22,408.22,.1)="YES^2^^^"_$P(CN(MM,408.22,408.22,.19),U,5)
..S CN(MM,408.22,408.22,.06)="NO^2^^^"_$P(CN(MM,408.22,408.22,.19),U,5)
;
;gather links to VistA for Applicant
S FLINK("AP",1,408.12)=DGPR12("AP")
F FILE=408.21,408.22 D
.S XLINK="",MULTIPLE=1,SUBFILE=FILE,FLD=""
.F S FLD=$O(AP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
..S FLINK("AP",1,FILE)=+$P(AP(MULTIPLE,FILE,SUBFILE,FLD),U,5)
;gather links to VistA for Spouse
F FILE=408.12,408.13,408.21,408.22 D
.S XLINK="",MULTIPLE=1,SUBFILE=FILE,FLD=""
.F S FLD=$O(SP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
..S FLINK("SP",MULTIPLE,FILE)=+$P(SP(MULTIPLE,FILE,SUBFILE,FLD),U,5)
.I FILE=408.12 S SUBFILE=408.1275 F S FLD=$O(SP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
..S FLINK("SP",MULTIPLE,SUBFILE)=$P($P(SP(MULTIPLE,FILE,SUBFILE,FLD),U,5),";",2)
..S FLINK("SP",MULTIPLE,FILE)=$P($P(SP(MULTIPLE,FILE,SUBFILE,FLD),U,5),";",1)
;gather links to VistA for Dependents
S MULTIPLE=0 F S MULTIPLE=$O(CN(MULTIPLE)) Q:'MULTIPLE D
.F FILE=408.13,408.12,408.21,408.22 D
..S XLINK="",SUBFILE=FILE,FLD=""
..F S FLD=$O(CN(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
...S FLINK("CN",MULTIPLE,FILE)=+$P(CN(MULTIPLE,FILE,SUBFILE,FLD),U,5)
..I FILE=408.12 S SUBFILE=408.1275 F S FLD=$O(CN(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
...S FLINK("CN",MULTIPLE,SUBFILE)=$P($P(CN(MULTIPLE,FILE,SUBFILE,FLD),U,5),";",2)
...S FLINK("CN",MULTIPLE,FILE)=$P($P(CN(MULTIPLE,FILE,SUBFILE,FLD),U,5),";",1)
;
;file data
Q:DGPR12("AP")=""
S DFN=EASDFN
D AP
I $D(FLINK("SP")) D SP^EASEZF3
I $D(FLINK("CN")) D CN^EASEZF4
D LINKUP^EASEZF4
;
Q
;
AP ;file Applicant data
N MT,P22,MULTIPLE,FILE,SUBFILE,FLD,XDATA,ACCEPT,SUBIEN,EZDATA,EAS,ERR,KEY
F FILE=408.21,408.22 D
.S MULTIPLE=1,SUBFILE=FILE,FLD=""
.S XLINK=$G(FLINK("AP",1,FILE))
.;record in file #408.21 needed for all further data filing
.Q:(FILE'=408.21)&('$G(FLINK("AP",1,408.21)))
.;for data elements with link to database,
.;only file 1010EZ data if accepted by user;
.;data in external format
.I XLINK D
..S FLD="" F S FLD=$O(AP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
...S XDATA=AP(MULTIPLE,FILE,SUBFILE,FLD),ACCEPT=$P(XDATA,U,2)
...I ACCEPT D LINK(XDATA,FILE,FLD,"AP",MULTIPLE)
.;for data elements with no link to database,
.;always create new record(s) to store 1010EZ data;
.;use internal data format
.I 'XLINK D
..K EAS,ERR
..S FLD="" F S FLD=$O(AP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
...S EZDATA=$P(AP(MULTIPLE,FILE,SUBFILE,FLD),U,1)
...S EAS(EASAPP,FILE,"+1,",FLD)=EZDATA
..I FILE=408.21 D
...S EAS(EASAPP,FILE,"+1,",".01")=INCYR
...S EAS(EASAPP,FILE,"+1,",".02")=FLINK("AP",1,408.12)
...S EAS(EASAPP,FILE,"+1,","101")=DUZ
...S EAS(EASAPP,FILE,"+1,","102")=DT
...S EAS(EASAPP,FILE,"+1,","103")=DUZ
...S EAS(EASAPP,FILE,"+1,","104")=DT
..I FILE=408.22,$G(FLINK("AP",1,408.21)) D
...S EAS(EASAPP,FILE,"+1,",".01")=EASDFN
...S EAS(EASAPP,FILE,"+1,",".02")=FLINK("AP",1,408.21)
...I $G(SP(1,408.13,408.13,.01))'="" S EAS(EASAPP,FILE,"+1,",".05")=1
...I $G(CN(1,408.13,408.13,.01))'="" S EAS(EASAPP,FILE,"+1,",".08")=1
...S X=$G(EAS(EASAPP,FILE,"+1,",".06"))
...S EAS(EASAPP,FILE,"+1,",".06")=$S(X="YES":1,X="NO":0,1:"")
..S FLINK("AP",MULTIPLE,FILE)=$$NOLINK(.EAS,"AP",MULTIPLE)
..S FLD="" F S FLD=$O(AP(MULTIPLE,FILE,SUBFILE,FLD)) Q:FLD="" D
...S SUBIEN=$P(AP(MULTIPLE,FILE,SUBFILE,FLD),U,3)
...;store link to new record in subfile #712.01
...S $P(AP(MULTIPLE,FILE,SUBFILE,FLD),U,5)=FLINK("AP",1,FILE)
;
Q
;
LINK(XDATA,FILE,FLD,GRP,MULTIPLE) ;setup to call FM database server if link to file exists & data accepted
N MSG,EZDATA,SUBIEN,PTDATA,XLINK
K EAS,ERR
S EZDATA=$P(XDATA,U,1),SUBIEN=$P(XDATA,U,3),PTDATA=$P(XDATA,U,4),XLINK=$P(XDATA,U,5)
S IENS=XLINK_","
S EROOT="EAS("_EASAPP_")"
D VAL^DIE(FILE,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
I $D(ERR) D ERROR(GRP,MULTIPLE,.ERR,"LINK") Q
;file to database if input is valid
I '$D(ERR) D
.I FILE=408.21 D
..S EAS(EASAPP,FILE,IENS,103)=DUZ
..S EAS(EASAPP,FILE,IENS,104)=DT
.D FILE^DIE("S",EROOT,"ERR")
.;set any replaced data into subfile #712.01 for audit
.I SUBIEN S $P(^EAS(712,EASAPP,10,SUBIEN,2),U,1)=PTDATA
Q
;
NOLINK(EAS,GRP,MULTIPLE) ;add new record with accepted data if no link exists;
;
K EZIENS,ERR,LINK
S EROOT="EAS("_EASAPP_")"
D UPDATE^DIE("S",EROOT,"EZIENS","ERR")
;call to UPDATE should not return ERR since internal data formats are used, but just in case;
I $D(ERR) D ERROR(GRP,MULTIPLE,.ERR,"NOLINK")
;return ien to new record
S LINK=$G(EZIENS(1))
Q LINK
;
ERROR(GRP,MULTIPLE,ERR,FROM) ;add FM error text to error msg
N L,LSTLN,ECODE,ENUMBER
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
.S LSTLN=+$O(^TMP("1010EZERROR",$J,""),-1) I 'LSTLN S LSTLN=6
.S WHO=$S(GRP="SP":"SPOUSE",GRP="CN":"CHILD",1:"APPLICANT")
.I WHO="CHILD" S WHO=WHO_" #"_MULTIPLE
.S FIELD=$G(ERR("DIERR",ENUMBER,"PARAM","FIELD")),FILE=$G(ERR("DIERR",ENUMBER,"PARAM","FILE"))
.I FROM="LINK" D
..S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)="1010EZ data for "_WHO_" was not filed to"
..S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)="Field #"_FIELD_" of File #"_FILE_" because:"
.I FROM="NOLINK" D
..S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)="A new record for "_WHO_" could not be created in"
..S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)="File #"_FILE_" because Field #"_FIELD_" produced an error:"
.S L=0 F S L=$O(ERR("DIERR",ENUMBER,"TEXT",L)) Q:'L D
..S LN=ERR("DIERR",ENUMBER,"TEXT",L)
..I $L(LN)<50 S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)=LN Q
..D WRAP(LN,.LSTLN)
.S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)=" "
Q
;
WRAP(LN,LSTLN) ;parse a long error text line into several message lines
N PART,BB
F D Q:$L(LN)<41
.S PART=""
.F BB=1:1:99 S PART=PART_$P(LN," ",BB)_" " I $L(PART)>40 D Q
..S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)=PART
..S LN=$P(LN," ",BB+1,99)
S LSTLN=LSTLN+1,^TMP("1010EZERROR",$J,LSTLN,0)=LN
Q