EASEZF2 ;ALB/jap - Filing 1010EZ Data to Patient Database ;10/31/00 13:07
;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,9,51,57,70**;Mar 15, 2001;Build 26
;
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",DATANM["ASSET(N)":"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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASEZF2 9894 printed Apr 09, 2024@20:58:31 Page 2
EASEZF2 ;ALB/jap - Filing 1010EZ Data to Patient Database ;10/31/00 13:07
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,9,51,57,70**;Mar 15, 2001;Build 26
+2 ;
F408(EASAPP,EASDFN) ;
+1 NEW KEYIEN,FILE,SUBFILE,FLD,DATAKEY,MULTIPLE,MM,SECT,QUES,SUBIEN,ACCEPT,EZDATA,PTDATA,LINK
+2 NEW DFN,DGPR12,INCYR,TESTYR,LASTINC,XLINK,EROOT,EAS,ERR,IENS,MSG,X,Y
+3 if '$GET(EASDFN)
QUIT
+4 ;determine income year for financial data
+5 SET Y=$PIECE($GET(^EAS(712,EASAPP,0)),U,6)
IF Y=""
SET Y=DT
+6 SET %F=5
SET X=$$FMTE^XLFDT(Y,%F)
SET X=+$PIECE(X,"/",3)-1
SET %DT="P"
DO ^%DT
SET INCYR=Y
+7 SET YREND=$EXTRACT(DT,1,3)_"1231"
+8 ;don't file any 408 data if applicant has income test for current year at this site
+9 SET LASTINC=$$LST^DGMTU(EASDFN,YREND,1)
IF LASTINC=""
SET LASTINC=$$LST^DGMTU(EASDFN,YREND,2)
+10 SET TESTYR=$PIECE(LASTINC,U,2)
+11 if ($EXTRACT(TESTYR,1,3)=$EXTRACT(DT,1,3))&($PIECE(LASTINC,U,5)>1)
QUIT
+12 ;
+13 ;DGPR12("AP") is the Applicant's (veteran's) IEN in file #408.12
+14 SET DGPR12("AP")=""
+15 ;add Applicant to file #408.12 if not there already;
+16 ;make this addition even if no other financial data is available;
+17 IF '$DATA(^DGPR(408.12,"B",EASDFN))
Begin DoDot:1
+18 ;create the file #408.12 record
+19 KILL EAS,ERR,EZIENS
+20 SET EAS(EASAPP,408.12,"+1,",".01")=EASDFN
+21 SET EAS(EASAPP,408.12,"+1,",".02")=1
+22 SET EAS(EASAPP,408.12,"+1,",".03")=EASDFN_";DPT("
+23 SET EROOT="EAS("_EASAPP_")"
+24 DO UPDATE^DIE("S",EROOT,"EZIENS","ERR")
+25 SET DGPR12("AP")=$GET(EZIENS(1))
+26 if DGPR12("AP")=""
QUIT
+27 ;create the subfile #408.1275 record
+28 KILL EAS,ERR,EZIENS
+29 ;S KEY=+$$KEY711^EASEZU1("APPLICANT DATE OF BIRTH")
+30 ;S DOB=$P($$DATA712^EASEZU1(EASAPP,KEY,1),U,1)
+31 ;use DOB from file #2
+32 SET X=$PIECE($GET(^DPT(EASDFN,0)),U,3)
SET %DT="PX"
DO ^%DT
SET DOB=Y
+33 SET EAS(EASAPP,408.1275,"+1,"_DGPR12("AP")_",",".01")=DOB
+34 SET EAS(EASAPP,408.1275,"+1,"_DGPR12("AP")_",",".02")="YES"
+35 DO UPDATE^DIE("ES",EROOT,"EZIENS","ERR")
+36 ;link 1010EZ data with new record in #408.12
End DoDot:1
+37 IF DGPR12("AP")=""
SET DGPR12("AP")=$ORDER(^DGPR(408.12,"B",EASDFN,0))
+38 ;if no record for Applicant in file #408.12 exists, then don't continue
+39 if DGPR12("AP")=""
QUIT
+40 ;
+41 ;kill local holding arrays
+42 KILL AP,SP,CN,FLINK
+43 ;get data for file #408.12,#408.13,#408.21,#408.22 into local arrays
+44 SET SECT=""
+45 FOR
SET SECT=$ORDER(^TMP("EZTEMP",$JOB,SECT))
if SECT=""
QUIT
SET MULTIPLE=0
Begin DoDot:1
+46 FOR
SET MULTIPLE=$ORDER(^TMP("EZTEMP",$JOB,SECT,MULTIPLE))
if MULTIPLE=""
QUIT
SET QUES=""
Begin DoDot:2
+47 FOR
SET QUES=$ORDER(^TMP("EZTEMP",$JOB,SECT,MULTIPLE,QUES))
if QUES=""
QUIT
Begin DoDot:3
+48 SET DATAKEY=SECT_";"_QUES
+49 ;call to suppress may be redundant
+50 if $$SUPPRESS^EASEZU4(EASAPP,DATAKEY,1,EASVRSN)
QUIT
+51 SET X=^TMP("EZTEMP",$JOB,SECT,MULTIPLE,QUES)
+52 SET KEYIEN=$PIECE(X,U,1)
SET EZDATA=$PIECE(X,U,2)
SET ACCEPT=$PIECE(X,U,3)
SET SUBIEN=$PIECE(X,U,4)
SET PTDATA=$PIECE(X,U,5)
+53 SET LN=^TMP("EZDATA",$JOB,KEYIEN)
SET FILE=$PIECE(LN,U,1)
SET SUBFILE=$PIECE(LN,U,2)
SET FLD=$PIECE(LN,U,3)
+54 if ($PIECE(FILE,".",1)'=408)
QUIT
+55 SET LINK=$PIECE($GET(^EAS(712,EASAPP,10,SUBIEN,2)),U,2)
+56 SET DATANM=$PIECE($GET(^EAS(711,KEYIEN,0)),U,1)
+57 SET MM=MULTIPLE
if DATANM["CHILD(N)"
SET MM=MULTIPLE+1
+58 IF (SECT="IIF")!(SECT="IIG")
SET MM=MULTIPLE
+59 SET ARR=$SELECT(DATANM["SPOUSE":"SP",DATANM["CHILD":"CN",DATANM["ASSET(N)":"CN",1:"AP")
+60 SET @ARR@(MM,FILE,SUBFILE,FLD)=EZDATA_U_ACCEPT_U_SUBIEN_U_PTDATA_U_LINK
End DoDot:3
End DoDot:2
End DoDot:1
+61 ;delete any Spouse or Dependent data if #.01 field for file #408.13 does not exist
+62 IF $DATA(SP(1,408.13,408.13,.01))'=1
KILL SP
+63 ;if contributed to spouse, applicant lived with patient = NO
+64 IF +$PIECE($GET(AP(1,408.22,408.22,.07)),U,1)
Begin DoDot:1
+65 SET AP(1,408.22,408.22,.06)="NO^2^^^"_$PIECE(AP(1,408.22,408.22,.07),U,5)
End DoDot:1
+66 SET MM=0
FOR
SET MM=$ORDER(CN(MM))
if 'MM
QUIT
Begin DoDot:1
+67 IF $DATA(CN(MM,408.13,408.13,.01))'=1
KILL CN(MM)
QUIT
+68 ;check for amt contributed to child
+69 IF +$PIECE($GET(CN(MM,408.22,408.22,.19)),U,1)
Begin DoDot:2
+70 SET CN(MM,408.22,408.22,.1)="YES^2^^^"_$PIECE(CN(MM,408.22,408.22,.19),U,5)
+71 SET CN(MM,408.22,408.22,.06)="NO^2^^^"_$PIECE(CN(MM,408.22,408.22,.19),U,5)
End DoDot:2
End DoDot:1
+72 ;
+73 ;gather links to VistA for Applicant
+74 SET FLINK("AP",1,408.12)=DGPR12("AP")
+75 FOR FILE=408.21,408.22
Begin DoDot:1
+76 SET XLINK=""
SET MULTIPLE=1
SET SUBFILE=FILE
SET FLD=""
+77 FOR
SET FLD=$ORDER(AP(MULTIPLE,FILE,SUBFILE,FLD))
if FLD=""
QUIT
Begin DoDot:2
+78 SET FLINK("AP",1,FILE)=+$PIECE(AP(MULTIPLE,FILE,SUBFILE,FLD),U,5)
End DoDot:2
End DoDot:1
+79 ;gather links to VistA for Spouse
+80 FOR FILE=408.12,408.13,408.21,408.22
Begin DoDot:1
+81 SET XLINK=""
SET MULTIPLE=1
SET SUBFILE=FILE
SET FLD=""
+82 FOR
SET FLD=$ORDER(SP(MULTIPLE,FILE,SUBFILE,FLD))
if FLD=""
QUIT
Begin DoDot:2
+83 SET FLINK("SP",MULTIPLE,FILE)=+$PIECE(SP(MULTIPLE,FILE,SUBFILE,FLD),U,5)
End DoDot:2
+84 IF FILE=408.12
SET SUBFILE=408.1275
FOR
SET FLD=$ORDER(SP(MULTIPLE,FILE,SUBFILE,FLD))
if FLD=""
QUIT
Begin DoDot:2
+85 SET FLINK("SP",MULTIPLE,SUBFILE)=$PIECE($PIECE(SP(MULTIPLE,FILE,SUBFILE,FLD),U,5),";",2)
+86 SET FLINK("SP",MULTIPLE,FILE)=$PIECE($PIECE(SP(MULTIPLE,FILE,SUBFILE,FLD),U,5),";",1)
End DoDot:2
End DoDot:1
+87 ;gather links to VistA for Dependents
+88 SET MULTIPLE=0
FOR
SET MULTIPLE=$ORDER(CN(MULTIPLE))
if 'MULTIPLE
QUIT
Begin DoDot:1
+89 FOR FILE=408.13,408.12,408.21,408.22
Begin DoDot:2
+90 SET XLINK=""
SET SUBFILE=FILE
SET FLD=""
+91 FOR
SET FLD=$ORDER(CN(MULTIPLE,FILE,SUBFILE,FLD))
if FLD=""
QUIT
Begin DoDot:3
+92 SET FLINK("CN",MULTIPLE,FILE)=+$PIECE(CN(MULTIPLE,FILE,SUBFILE,FLD),U,5)
End DoDot:3
+93 IF FILE=408.12
SET SUBFILE=408.1275
FOR
SET FLD=$ORDER(CN(MULTIPLE,FILE,SUBFILE,FLD))
if FLD=""
QUIT
Begin DoDot:3
+94 SET FLINK("CN",MULTIPLE,SUBFILE)=$PIECE($PIECE(CN(MULTIPLE,FILE,SUBFILE,FLD),U,5),";",2)
+95 SET FLINK("CN",MULTIPLE,FILE)=$PIECE($PIECE(CN(MULTIPLE,FILE,SUBFILE,FLD),U,5),";",1)
End DoDot:3
End DoDot:2
End DoDot:1
+96 ;
+97 ;file data
+98 if DGPR12("AP")=""
QUIT
+99 SET DFN=EASDFN
+100 DO AP
+101 IF $DATA(FLINK("SP"))
DO SP^EASEZF3
+102 IF $DATA(FLINK("CN"))
DO CN^EASEZF4
+103 DO LINKUP^EASEZF4
+104 ;
+105 QUIT
+106 ;
AP ;file Applicant data
+1 NEW MT,P22,MULTIPLE,FILE,SUBFILE,FLD,XDATA,ACCEPT,SUBIEN,EZDATA,EAS,ERR,KEY
+2 FOR FILE=408.21,408.22
Begin DoDot:1
+3 SET MULTIPLE=1
SET SUBFILE=FILE
SET FLD=""
+4 SET XLINK=$GET(FLINK("AP",1,FILE))
+5 ;record in file #408.21 needed for all further data filing
+6 if (FILE'=408.21)&('$GET(FLINK("AP",1,408.21)))
QUIT
+7 ;for data elements with link to database,
+8 ;only file 1010EZ data if accepted by user;
+9 ;data in external format
+10 IF XLINK
Begin DoDot:2
+11 SET FLD=""
FOR
SET FLD=$ORDER(AP(MULTIPLE,FILE,SUBFILE,FLD))
if FLD=""
QUIT
Begin DoDot:3
+12 SET XDATA=AP(MULTIPLE,FILE,SUBFILE,FLD)
SET ACCEPT=$PIECE(XDATA,U,2)
+13 IF ACCEPT
DO LINK(XDATA,FILE,FLD,"AP",MULTIPLE)
End DoDot:3
End DoDot:2
+14 ;for data elements with no link to database,
+15 ;always create new record(s) to store 1010EZ data;
+16 ;use internal data format
+17 IF 'XLINK
Begin DoDot:2
+18 KILL EAS,ERR
+19 SET FLD=""
FOR
SET FLD=$ORDER(AP(MULTIPLE,FILE,SUBFILE,FLD))
if FLD=""
QUIT
Begin DoDot:3
+20 SET EZDATA=$PIECE(AP(MULTIPLE,FILE,SUBFILE,FLD),U,1)
+21 SET EAS(EASAPP,FILE,"+1,",FLD)=EZDATA
End DoDot:3
+22 IF FILE=408.21
Begin DoDot:3
+23 SET EAS(EASAPP,FILE,"+1,",".01")=INCYR
+24 SET EAS(EASAPP,FILE,"+1,",".02")=FLINK("AP",1,408.12)
+25 SET EAS(EASAPP,FILE,"+1,","101")=DUZ
+26 SET EAS(EASAPP,FILE,"+1,","102")=DT
+27 SET EAS(EASAPP,FILE,"+1,","103")=DUZ
+28 SET EAS(EASAPP,FILE,"+1,","104")=DT
End DoDot:3
+29 IF FILE=408.22
IF $GET(FLINK("AP",1,408.21))
Begin DoDot:3
+30 SET EAS(EASAPP,FILE,"+1,",".01")=EASDFN
+31 SET EAS(EASAPP,FILE,"+1,",".02")=FLINK("AP",1,408.21)
+32 IF $GET(SP(1,408.13,408.13,.01))'=""
SET EAS(EASAPP,FILE,"+1,",".05")=1
+33 IF $GET(CN(1,408.13,408.13,.01))'=""
SET EAS(EASAPP,FILE,"+1,",".08")=1
+34 SET X=$GET(EAS(EASAPP,FILE,"+1,",".06"))
+35 SET EAS(EASAPP,FILE,"+1,",".06")=$SELECT(X="YES":1,X="NO":0,1:"")
End DoDot:3
+36 SET FLINK("AP",MULTIPLE,FILE)=$$NOLINK(.EAS,"AP",MULTIPLE)
+37 SET FLD=""
FOR
SET FLD=$ORDER(AP(MULTIPLE,FILE,SUBFILE,FLD))
if FLD=""
QUIT
Begin DoDot:3
+38 SET SUBIEN=$PIECE(AP(MULTIPLE,FILE,SUBFILE,FLD),U,3)
+39 ;store link to new record in subfile #712.01
+40 SET $PIECE(AP(MULTIPLE,FILE,SUBFILE,FLD),U,5)=FLINK("AP",1,FILE)
End DoDot:3
End DoDot:2
End DoDot:1
+41 ;
+42 QUIT
+43 ;
LINK(XDATA,FILE,FLD,GRP,MULTIPLE) ;setup to call FM database server if link to file exists & data accepted
+1 NEW MSG,EZDATA,SUBIEN,PTDATA,XLINK
+2 KILL EAS,ERR
+3 SET EZDATA=$PIECE(XDATA,U,1)
SET SUBIEN=$PIECE(XDATA,U,3)
SET PTDATA=$PIECE(XDATA,U,4)
SET XLINK=$PIECE(XDATA,U,5)
+4 SET IENS=XLINK_","
+5 SET EROOT="EAS("_EASAPP_")"
+6 DO VAL^DIE(FILE,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
+7 IF $DATA(ERR)
DO ERROR(GRP,MULTIPLE,.ERR,"LINK")
QUIT
+8 ;file to database if input is valid
+9 IF '$DATA(ERR)
Begin DoDot:1
+10 IF FILE=408.21
Begin DoDot:2
+11 SET EAS(EASAPP,FILE,IENS,103)=DUZ
+12 SET EAS(EASAPP,FILE,IENS,104)=DT
End DoDot:2
+13 DO FILE^DIE("S",EROOT,"ERR")
+14 ;set any replaced data into subfile #712.01 for audit
+15 IF SUBIEN
SET $PIECE(^EAS(712,EASAPP,10,SUBIEN,2),U,1)=PTDATA
End DoDot:1
+16 QUIT
+17 ;
NOLINK(EAS,GRP,MULTIPLE) ;add new record with accepted data if no link exists;
+1 ;
+2 KILL EZIENS,ERR,LINK
+3 SET EROOT="EAS("_EASAPP_")"
+4 DO UPDATE^DIE("S",EROOT,"EZIENS","ERR")
+5 ;call to UPDATE should not return ERR since internal data formats are used, but just in case;
+6 IF $DATA(ERR)
DO ERROR(GRP,MULTIPLE,.ERR,"NOLINK")
+7 ;return ien to new record
+8 SET LINK=$GET(EZIENS(1))
+9 QUIT LINK
+10 ;
ERROR(GRP,MULTIPLE,ERR,FROM) ;add FM error text to error msg
+1 NEW L,LSTLN,ECODE,ENUMBER
+2 SET ECODE=""
FOR
SET ECODE=$ORDER(ERR("DIERR","E",ECODE))
if ECODE=""
QUIT
SET ENUMBER=0
FOR
SET ENUMBER=$ORDER(ERR("DIERR","E",ECODE,ENUMBER))
if 'ENUMBER
QUIT
Begin DoDot:1
+3 SET LSTLN=+$ORDER(^TMP("1010EZERROR",$JOB,""),-1)
IF 'LSTLN
SET LSTLN=6
+4 SET WHO=$SELECT(GRP="SP":"SPOUSE",GRP="CN":"CHILD",1:"APPLICANT")
+5 IF WHO="CHILD"
SET WHO=WHO_" #"_MULTIPLE
+6 SET FIELD=$GET(ERR("DIERR",ENUMBER,"PARAM","FIELD"))
SET FILE=$GET(ERR("DIERR",ENUMBER,"PARAM","FILE"))
+7 IF FROM="LINK"
Begin DoDot:2
+8 SET LSTLN=LSTLN+1
SET ^TMP("1010EZERROR",$JOB,LSTLN,0)="1010EZ data for "_WHO_" was not filed to"
+9 SET LSTLN=LSTLN+1
SET ^TMP("1010EZERROR",$JOB,LSTLN,0)="Field #"_FIELD_" of File #"_FILE_" because:"
End DoDot:2
+10 IF FROM="NOLINK"
Begin DoDot:2
+11 SET LSTLN=LSTLN+1
SET ^TMP("1010EZERROR",$JOB,LSTLN,0)="A new record for "_WHO_" could not be created in"
+12 SET LSTLN=LSTLN+1
SET ^TMP("1010EZERROR",$JOB,LSTLN,0)="File #"_FILE_" because Field #"_FIELD_" produced an error:"
End DoDot:2
+13 SET L=0
FOR
SET L=$ORDER(ERR("DIERR",ENUMBER,"TEXT",L))
if 'L
QUIT
Begin DoDot:2
+14 SET LN=ERR("DIERR",ENUMBER,"TEXT",L)
+15 IF $LENGTH(LN)<50
SET LSTLN=LSTLN+1
SET ^TMP("1010EZERROR",$JOB,LSTLN,0)=LN
QUIT
+16 DO WRAP(LN,.LSTLN)
End DoDot:2
+17 SET LSTLN=LSTLN+1
SET ^TMP("1010EZERROR",$JOB,LSTLN,0)=" "
End DoDot:1
+18 QUIT
+19 ;
WRAP(LN,LSTLN) ;parse a long error text line into several message lines
+1 NEW PART,BB
+2 FOR
Begin DoDot:1
+3 SET PART=""
+4 FOR BB=1:1:99
SET PART=PART_$PIECE(LN," ",BB)_" "
IF $LENGTH(PART)>40
Begin DoDot:2
+5 SET LSTLN=LSTLN+1
SET ^TMP("1010EZERROR",$JOB,LSTLN,0)=PART
+6 SET LN=$PIECE(LN," ",BB+1,99)
End DoDot:2
QUIT
End DoDot:1
if $LENGTH(LN)<41
QUIT
+7 SET LSTLN=LSTLN+1
SET ^TMP("1010EZERROR",$JOB,LSTLN,0)=LN
+8 QUIT
