EASEZF1 ;ALB/jap,TM - Filing 1010EZ Data to Patient Database ; 8/16/11 4:04pm
;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,51,57,62,70,93,92**;Mar 15, 2001;Build 20
;
F2(EASAPP,EASDFN) ;file to Patient record in #2
;input EASDFN = ien to #2
N KEYIEN,FILE,SUBFILE,FLD,DATAKEY,MULTIPLE,SECT,QUES,SUBIEN,ACCEPT,EZDATA,PTDATA,LINK,EROOT,EAS,ERR,IENS,ARRAY,ELIGVER
N DIC,DIQ,DA,DR,X,Y,EZSTRG
Q:'$G(EASDFN)
;L +^DPT(EASDFN) ;Handling locking in EASEZFM - EAS*1*93
I '$G(EASVRSN) S EASVRSN=$$VERSION^EASEZU4(EASAPP)
;EAS*1.0*70 - Special handling for Foreign Address
S KEYIEN=+$$KEY711^EASEZU1("APPLICANT COUNTRY")
S DATAKEY=$P(^TMP("EZDATA",$J,KEYIEN),U,4)
S SECT=$P(DATAKEY,";"),QUES=$P(DATAKEY,";",2)
S EZDATA=$P($G(^TMP("EZTEMP",$J,SECT,1,QUES)),U,2)
I EZDATA="UNITED STATES" S EZSTRG="APPLICANT PROVINCE^APPLICANT POSTAL CODE"
E S EZSTRG="APPLICANT COUNTY^APPLICANT STATE^APPLICANT ZIP"
F X=1:1 S DATANM=$P(EZSTRG,U,X) Q:DATANM="" D
. S KEYIEN=+$$KEY711^EASEZU1(DATANM) Q:(KEYIEN=.1)
. S DATAKEY=$P(^TMP("EZDATA",$J,KEYIEN),U,4)
. S SECT=$P(DATAKEY,";"),QUES=$P(DATAKEY,";",2)
. K ^TMP("EZDATA",$J,KEYIEN),^TMP("EZTEMP",$J,SECT,1,QUES)
;
S KEYIEN=0
F S KEYIEN=$O(^TMP("EZDATA",$J,KEYIEN)) Q:'KEYIEN D
. S LN=^TMP("EZDATA",$J,KEYIEN),FILE=$P(LN,U,1)
. Q:FILE'=2
. S SUBFILE=$P(LN,U,2),FLD=$P(LN,U,3),DATAKEY=$P(LN,U,4)
. S SECT=$P(DATAKEY,";",1),QUES=$P(DATAKEY,";",2)
. ;call to suppress may be redundant
. Q:$$SUPPRESS^EASEZU4(EASAPP,DATAKEY,1,EASVRSN)
. ;in file #2, multiple is always 1
. S MULTIPLE=1
. Q:'$D(^TMP("EZDATA",$J,KEYIEN,MULTIPLE,1))
. S X=$G(^TMP("EZTEMP",$J,SECT,MULTIPLE,QUES))
. Q:$P(X,U,1)'=KEYIEN
. S EZDATA=$P(X,U,2),ACCEPT=$P(X,U,3),SUBIEN=$P(X,U,4),PTDATA=$P(X,U,5)
. Q:EZDATA=""
. Q:'SUBIEN
. ;special handling for Designee
. I FLD=.3405 S EZDATA=$S(EZDATA="NEXT OF KIN":"YES",1:"NO")
. ;strip off code display from county
. I SECT="I",QUES="9E." S EZDATA=$P(EZDATA," (",1)
. ;get file #2 ien; always same as EASDFN
. S LINK=EASDFN
. ;don't continue if data item not accepted
. Q:ACCEPT<1
. ;process subfile data elsewhere
. I SUBFILE=2.01 Q
. I SUBFILE=2.101 Q
. I SUBFILE=2.02 D F202^EASEZF1(SUBFILE,DATAKEY,EZDATA,SUBIEN,KEYIEN) Q
. I SUBFILE=2.06 D F206^EASEZF1(SUBFILE,DATAKEY,EZDATA,SUBIEN) Q
. ;Special for Military Service Episodes
. I SUBFILE=2.3216 D:KEYIEN=28 Q
. . D F23216(SUBFILE,DATAKEY,EZDATA,SUBIEN,KEYIEN)
. ;special conversion to file data to field #.328
. I FLD=.328 D
. . S X=$$UC^EASEZT1(EZDATA) I X="SSN" D
. . . ;allow SSN as Service Number only if field #.328 in patient record is null;
. . . S PTSSN=$$GETANY^EASEZU1(EASAPP,EASDFN,SUBIEN)
. . . I PTSSN="" S EZDATA="SS" Q
. . . ;otherwise Applicant SSN must match Patient SSN
. . . S KK=$$KEY711^EASEZU1("APPLICANT SOCIAL SECURITY NUMBER")
. . . S EZSSN=$P($G(^TMP("EZDATA",$J,KK,1,1)),U,1),EZSSN=$TR(EZSSN,"-","")
. . . I EZSSN=PTSSN S EZDATA="SS" Q
. . . S EZDATA="ssn"
. . K KK,PTSSN,EZSSN
. ;special for fields #.092 & #.093
. I FILE=2,((FLD=.092)!(FLD=.093)) D FPOB(DATAKEY,EZDATA,SUBIEN,PTDATA) Q
. ;don't need these lines after 672
. ;special for field #.362
. ;I FILE=2,FLD=.362,EASVRSN>5.99 I (EZDATA="Y")!(EZDATA="YES") S EZDATA="YES, RECEIVING MILITARY RETIREMENT IN LIEU OF VA COMPENSATION"
. Q:EZDATA=PTDATA
. ;repeat check for verified eligibility;
. ;do not file certain fields if eligibility verified
. K ARRAY
. S DA=EASDFN,DIC="^DPT(",DR=".3611;.3613",DIQ(0)="I",DIQ="ARRAY"
. D EN^DIQ1 K DA,DIC,DIQ,DR
. I $G(ARRAY(2,EASDFN,.3611,"I"))="V",$G(ARRAY(2,EASDFN,.3613,"I"))="H" S ELIGVER=1
. I FLD=.313,$G(ARRAY(2,EASDFN,.3611,"I"))="V" Q
. I $G(ELIGVER),((FLD=.301)!(FLD=.302)!(FLD=.36235)) Q
. ;special for field #.32102 - Agent Orange Exposure . DATAKEY = I;14F
. I FLD=.32102 D F32102^EASEZF1A(EASAPP,EASDFN,EZDATA)
. ;setup to call FM database server using EASDFN as file #2 record
. K EAS,ERR
. S IENS=EASDFN_","
. S EROOT="EAS("_EASAPP_")"
. D VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
. ;try to resolve possible invalid input for free text fields due to length
. I $D(ERR) D RESOLVE
. I $D(ERR) D ERROR^EASEZF2("AP",MULTIPLE,.ERR,"LINK")
. ;file to database if input is valid
. I '$D(ERR) D
. . ;2/1/2001 - don't attempt to file Name, SSN, DOB; too many complications;
. . ; example: if system assigns pseudo-SSN to new patient, user could overwrite;
. . ; example: if applicant matched to existing patient, all critical identifying
. . ; data could be overwritten; could impact HEC as well
. . D FILE^DIE("S",EROOT,"ERR")
. . ;set any replaced data into subfile #712.01 for audit
. . S ^EAS(712,EASAPP,10,SUBIEN,2)=PTDATA_U_LINK
;
;L -^DPT(EASDFN) ;Handling locking in EASEZFM - EAS*1*93
Q
;
RESOLVE ;try to resolve invalid input for free text fields only
;see if mapped to free text field
N FDEF,FTYPE,MAX
I (SUBFILE=FILE)!(SUBFILE="") S FDEF=FILE
E S FDEF=SUBFILE
S FTYPE=$$GET1^DID(FDEF,FLD,"","TYPE")
Q:FTYPE'="FREE TEXT"
S MAX=$$GET1^DID(FDEF,FLD,"","FIELD LENGTH")
S EZDATA=$E(EZDATA,1,MAX)
K ERR
D VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
;if still sets ERR array then won't be filed to database
Q
;
F202(SUBFILE,DATAKEY,EZDATA,SUBIEN,KEYIEN) ;add or edit subrecord in subfile #2.02
;input SUBFILE = 2.02
; DATAKEY = data item identifier, e.g., I;4B.
; EZDATA = in these cases, either "N(o)" or "Y(es)"
; SUBIEN = subrecord # for data in #712/#10
; KEYIEN = record # for data element in #711
N X,N,DATANM,EROOT,EAS,EIEN,ERR,FLD,IENS,EASARRAY,LINK,OUT,K1,K3
Q:EZDATA'["Y"
Q:SUBFILE'=2.02
;covert data to corresponding file #10 pointer
S X=$$KEY711^EASEZU1(DATAKEY)
S K1=$P(X,U,1),DATANM=$P(X,U,2),K3=$P(X,U,3)
Q:(DATANM="")
Q:(K1'=KEYIEN)
Q:(K3'=DATAKEY)
S DATANM=$P(DATANM," - ",2),DATANM=$E(DATANM,1,30)
I DATANM["UNANSWERED" S DATANM="UNKNOWN BY PATIENT"
S EZDATA=$O(^DIC(10,"B",DATANM,0))
Q:EZDATA=""
D I202^EASEZI(EASDFN,.EASARRAY)
;if matching race already exists, edit method only
S OUT=0,N=0 F S N=$O(EASARRAY(N)) Q:'N D
. Q:($P(EASARRAY(N),";",2)'=EZDATA)
. K EAS,ERR
. S IENS=EZDATA_","_EASDFN_","
. S EROOT="EAS("_EASAPP_")"
. S FLD=.02,EAS(EASAPP,SUBFILE,IENS,FLD)=1
. D FILE^DIE("S",EROOT,"ERR")
. S OUT=1
;no matching race in patient record, add new subrecord
I 'OUT D
. K ERR
. S EROOT="EAS("_EASAPP_")"
. S IENS="+1,"_EASDFN_",",EIEN(1)=EZDATA
. S FLD=.01,EAS(EASAPP,SUBFILE,IENS,FLD)=EZDATA
. S FLD=.02,EAS(EASAPP,SUBFILE,IENS,FLD)=1
. D UPDATE^DIE("S",EROOT,"EIEN","ERR")
. I $D(ERR) D ERROR^EASEZF2("AP",1,.ERR,"LINK") Q
. S LINK=EASDFN_";"_EZDATA
. S ^EAS(712,EASAPP,10,SUBIEN,2)=U_LINK
Q
;
F206(SUBFILE,DATAKEY,EZDATA,SUBIEN) ;add subrecord in subfile #2.06
;input SUBFILE = 2.06
; DATAKEY = data item identifier, e.g., I;4A.
; EZDATA = in these cases, either "N(o)" or "Y(es)"
N X,EROOT,EAS,EIEN,ERR,FLD,EASARRAY,IENS,LINK,PTDATA
Q:SUBFILE'=2.06
D I206^EASEZI(EASDFN,.EASARRAY)
S LINK=$P($G(EASARRAY(1)),";",2),PTDATA="" I LINK S PTDATA=$P(^DPT(EASDFN,.06,LINK,0),U,1)
I DATAKEY="I;4A." S EZDATA=$S(EZDATA["Y":"H",$E(EZDATA,1)="N":"N",1:"U") D
. S EROOT="EAS("_EASAPP_")"
. S IENS="+1,"_EASDFN_","
. S FLD=.01,EAS(EASAPP,SUBFILE,IENS,FLD)=EZDATA
. S FLD=.02,EAS(EASAPP,SUBFILE,IENS,FLD)="SELF IDENTIFICATION"
. D UPDATE^DIE("ES",EROOT,"EIEN","ERR")
. S LINK=EASDFN_";"_$G(EIEN(1))
. S ^EAS(712,EASAPP,10,SUBIEN,2)=PTDATA_U_LINK
Q
;
FPOB(DATAKEY,EZDATA,SUBIEN,PTDATA) ;add or edit pob city & state
;input DATAKEY = data item identifier, either, I;8A. or I;8B.
; EZDATA = free text if city or
; state abbrv if state
;filing for both city & state only done when datakey=I;8A.
N X,EROOT,EAS,EIEN,ERR,FLD,EASARRAY,IENS,LINK,SECT,QUES,XIEN,XDATA
Q:(DATAKEY'="I;8A.")
Q:(EZDATA="")
Q:(EZDATA=PTDATA)
;file pob city
K EAS,ERR
S FLD=.092,LINK=EASDFN
S IENS=EASDFN_","
S EROOT="EAS("_EASAPP_")"
D VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
I $D(ERR) D RESOLVE
I $D(ERR) D ERROR^EASEZF2("AP",1,.ERR,"LINK") Q
D FILE^DIE("ES",EROOT,"ERR")
;set any replaced data into subfile #712.01 for audit
S ^EAS(712,EASAPP,10,SUBIEN,2)=PTDATA_U_LINK
;file pob state
S (EZDATA,XDATA)=""
S DATAKEY="I;8B.",SECT=$P(DATAKEY,";",1),QUES=$P(DATAKEY,";",2)
S X=$G(^TMP("EZTEMP",$J,SECT,1,QUES)),EZDATA=$P(X,U,2),XIEN=$P(X,U,4),XDATA=$P(X,U,5)
Q:(EZDATA="")
Q:(EZDATA=XDATA)
I (EZDATA["FOREIGN")!(EZDATA="FC")!(EZDATA="FG") S EZDATA="FOREIGN"
K EAS,ERR
S FLD=.093
S IENS=EASDFN_","
S EROOT="EAS("_EASAPP_")"
D VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
I $D(ERR) D ERROR^EASEZF2("AP",1,.ERR,"LINK") Q
D FILE^DIE("ES",EROOT,"ERR")
S ^EAS(712,EASAPP,10,XIEN,2)=XDATA_U_LINK
Q
;
F23216(SUBFILE,DATAKEY,EZDATA,SUBIEN,KEYIEN) ;add subrecord in subfile #2.3216
;input SUBFILE = 2.3216
; DATAKEY = data item identifier, e.g., I;13A.
; EZDATA = data value in external format
; KEYIEN = record # for data element in #711
;
;Values for KEYIEN DATAKEY
; 28 - Branch of Service I;13A
; 29 - Last Entry Date I;13B
; 30 - Last Separation Date I;13C
; 31 - Last Discharge Type I;13D
; 32 - Last Service Number I;13E
;
Q:SUBFILE'=2.3216
;
N X,EAS,EASARRAY,LINK,PTDATA,SUBIEN
;Get episodes from VistA into EASARRAY
D GETMSE^DGMSEUTL(EASDFN,.EASARRAY)
;Move last VistA episode into PDATA (for future use in edit option)
S LINK=$G(EASARRAY(1,"IEN")),PTDATA=""
I LINK S PTDATA=$G(^DPT(EASDFN,2.3216,LINK,0))
;
;Only proceed to add new subrecord if no .3216 data exists
Q:PTDATA'=""
;
TBD1 ;if this is entirely new and later than VistA episodes, allow add?
;
; (compare EDATE to last episode in PDATA and allow addition if it is; a date later than last separation date)
;
TBD2 ;if matching episode already exists, allow update?
;
; (see code in F202^EASEZF1 for update, get last IENS from EASARRAY)
;
;Get last episode 1010EZ fields from ^TMP("EZDATA"
N BOS,EDATE,SDATE,DTYPE,SERVNO
S BOS=$P($G(^TMP("EZDATA",$J,28,1,1)),U) Q:BOS=""
S EDATE=$P($G(^TMP("EZDATA",$J,29,1,1)),U) Q:EDATE=""
S SDATE=$P($G(^TMP("EZDATA",$J,30,1,1)),U) Q:SDATE=""
S DTYPE=$P($G(^TMP("EZDATA",$J,31,1,1)),U) Q:DTYPE=""
S SERVNO=$P($G(^TMP("EZDATA",$J,32,1,1)),U)
;
;Special conversion of service number (see code in EASEZF1)
I $$UC^EASEZT1(SERVNO)="SSN" D
.N EZSSN,KK,PTSSN
.;allow SSN as Service Number if service number in patient last
.;.3216 record is null. Always case if no .3216 data exists
.S PTSSN=$P(PTDATA,U,5)
.I PTSSN="" S SERVNO="SS" Q
.;alternatively Applicant SSN must match service number
.S KK=$$KEY711^EASEZU1("APPLICANT SOCIAL SECURITY NUMBER")
.S EZSSN=$P($G(^TMP("EZDATA",$J,KK,1,1)),U,1)
.S EZSSN=$TR(EZSSN,"-","")
.I EZSSN=PTSSN S SERVNO="SS" Q
.S SERVNO="ssn"
;
;File 1010EZ data to .3216
N X,Y,EROOT,ERR,FLD,IENS,EIEN
S EROOT="EAS("_EASAPP_")"
S IENS="+1,"_EASDFN_","
S FLD=.01,EAS(EASAPP,SUBFILE,IENS,FLD)=EDATE
S FLD=.02,EAS(EASAPP,SUBFILE,IENS,FLD)=SDATE
S FLD=.03,EAS(EASAPP,SUBFILE,IENS,FLD)=BOS
S FLD=.05,EAS(EASAPP,SUBFILE,IENS,FLD)=SERVNO
S FLD=.06,EAS(EASAPP,SUBFILE,IENS,FLD)=DTYPE
D UPDATE^DIE("ES",EROOT,"EIEN","ERR")
I $D(ERR) D ERROR^EASEZF2("AP",1,.ERR,"LINK") Q
;
S SUBIEN=$O(^EAS(712,EASAPP,10,"B",28,""))
S:SUBIEN ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$G(EIEN(1))
S SUBIEN=$O(^EAS(712,EASAPP,10,"B",29,""))
S:SUBIEN ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$G(EIEN(1))
S SUBIEN=$O(^EAS(712,EASAPP,10,"B",30,""))
S:SUBIEN ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$G(EIEN(1))
S SUBIEN=$O(^EAS(712,EASAPP,10,"B",31,""))
S:SUBIEN ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$G(EIEN(1))
S SUBIEN=$O(^EAS(712,EASAPP,10,"B",32,""))
S:SUBIEN ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$G(EIEN(1))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASEZF1 12072 printed Dec 13, 2024@01:54:28 Page 2
EASEZF1 ;ALB/jap,TM - Filing 1010EZ Data to Patient Database ; 8/16/11 4:04pm
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,51,57,62,70,93,92**;Mar 15, 2001;Build 20
+2 ;
F2(EASAPP,EASDFN) ;file to Patient record in #2
+1 ;input EASDFN = ien to #2
+2 NEW KEYIEN,FILE,SUBFILE,FLD,DATAKEY,MULTIPLE,SECT,QUES,SUBIEN,ACCEPT,EZDATA,PTDATA,LINK,EROOT,EAS,ERR,IENS,ARRAY,ELIGVER
+3 NEW DIC,DIQ,DA,DR,X,Y,EZSTRG
+4 if '$GET(EASDFN)
QUIT
+5 ;L +^DPT(EASDFN) ;Handling locking in EASEZFM - EAS*1*93
+6 IF '$GET(EASVRSN)
SET EASVRSN=$$VERSION^EASEZU4(EASAPP)
+7 ;EAS*1.0*70 - Special handling for Foreign Address
+8 SET KEYIEN=+$$KEY711^EASEZU1("APPLICANT COUNTRY")
+9 SET DATAKEY=$PIECE(^TMP("EZDATA",$JOB,KEYIEN),U,4)
+10 SET SECT=$PIECE(DATAKEY,";")
SET QUES=$PIECE(DATAKEY,";",2)
+11 SET EZDATA=$PIECE($GET(^TMP("EZTEMP",$JOB,SECT,1,QUES)),U,2)
+12 IF EZDATA="UNITED STATES"
SET EZSTRG="APPLICANT PROVINCE^APPLICANT POSTAL CODE"
+13 IF '$TEST
SET EZSTRG="APPLICANT COUNTY^APPLICANT STATE^APPLICANT ZIP"
+14 FOR X=1:1
SET DATANM=$PIECE(EZSTRG,U,X)
if DATANM=""
QUIT
Begin DoDot:1
+15 SET KEYIEN=+$$KEY711^EASEZU1(DATANM)
if (KEYIEN=.1)
QUIT
+16 SET DATAKEY=$PIECE(^TMP("EZDATA",$JOB,KEYIEN),U,4)
+17 SET SECT=$PIECE(DATAKEY,";")
SET QUES=$PIECE(DATAKEY,";",2)
+18 KILL ^TMP("EZDATA",$JOB,KEYIEN),^TMP("EZTEMP",$JOB,SECT,1,QUES)
End DoDot:1
+19 ;
+20 SET KEYIEN=0
+21 FOR
SET KEYIEN=$ORDER(^TMP("EZDATA",$JOB,KEYIEN))
if 'KEYIEN
QUIT
Begin DoDot:1
+22 SET LN=^TMP("EZDATA",$JOB,KEYIEN)
SET FILE=$PIECE(LN,U,1)
+23 if FILE'=2
QUIT
+24 SET SUBFILE=$PIECE(LN,U,2)
SET FLD=$PIECE(LN,U,3)
SET DATAKEY=$PIECE(LN,U,4)
+25 SET SECT=$PIECE(DATAKEY,";",1)
SET QUES=$PIECE(DATAKEY,";",2)
+26 ;call to suppress may be redundant
+27 if $$SUPPRESS^EASEZU4(EASAPP,DATAKEY,1,EASVRSN)
QUIT
+28 ;in file #2, multiple is always 1
+29 SET MULTIPLE=1
+30 if '$DATA(^TMP("EZDATA",$JOB,KEYIEN,MULTIPLE,1))
QUIT
+31 SET X=$GET(^TMP("EZTEMP",$JOB,SECT,MULTIPLE,QUES))
+32 if $PIECE(X,U,1)'=KEYIEN
QUIT
+33 SET EZDATA=$PIECE(X,U,2)
SET ACCEPT=$PIECE(X,U,3)
SET SUBIEN=$PIECE(X,U,4)
SET PTDATA=$PIECE(X,U,5)
+34 if EZDATA=""
QUIT
+35 if 'SUBIEN
QUIT
+36 ;special handling for Designee
+37 IF FLD=.3405
SET EZDATA=$SELECT(EZDATA="NEXT OF KIN":"YES",1:"NO")
+38 ;strip off code display from county
+39 IF SECT="I"
IF QUES="9E."
SET EZDATA=$PIECE(EZDATA," (",1)
+40 ;get file #2 ien; always same as EASDFN
+41 SET LINK=EASDFN
+42 ;don't continue if data item not accepted
+43 if ACCEPT<1
QUIT
+44 ;process subfile data elsewhere
+45 IF SUBFILE=2.01
QUIT
+46 IF SUBFILE=2.101
QUIT
+47 IF SUBFILE=2.02
DO F202^EASEZF1(SUBFILE,DATAKEY,EZDATA,SUBIEN,KEYIEN)
QUIT
+48 IF SUBFILE=2.06
DO F206^EASEZF1(SUBFILE,DATAKEY,EZDATA,SUBIEN)
QUIT
+49 ;Special for Military Service Episodes
+50 IF SUBFILE=2.3216
if KEYIEN=28
Begin DoDot:2
+51 DO F23216(SUBFILE,DATAKEY,EZDATA,SUBIEN,KEYIEN)
End DoDot:2
QUIT
+52 ;special conversion to file data to field #.328
+53 IF FLD=.328
Begin DoDot:2
+54 SET X=$$UC^EASEZT1(EZDATA)
IF X="SSN"
Begin DoDot:3
+55 ;allow SSN as Service Number only if field #.328 in patient record is null;
+56 SET PTSSN=$$GETANY^EASEZU1(EASAPP,EASDFN,SUBIEN)
+57 IF PTSSN=""
SET EZDATA="SS"
QUIT
+58 ;otherwise Applicant SSN must match Patient SSN
+59 SET KK=$$KEY711^EASEZU1("APPLICANT SOCIAL SECURITY NUMBER")
+60 SET EZSSN=$PIECE($GET(^TMP("EZDATA",$JOB,KK,1,1)),U,1)
SET EZSSN=$TRANSLATE(EZSSN,"-","")
+61 IF EZSSN=PTSSN
SET EZDATA="SS"
QUIT
+62 SET EZDATA="ssn"
End DoDot:3
+63 KILL KK,PTSSN,EZSSN
End DoDot:2
+64 ;special for fields #.092 & #.093
+65 IF FILE=2
IF ((FLD=.092)!(FLD=.093))
DO FPOB(DATAKEY,EZDATA,SUBIEN,PTDATA)
QUIT
+66 ;don't need these lines after 672
+67 ;special for field #.362
+68 ;I FILE=2,FLD=.362,EASVRSN>5.99 I (EZDATA="Y")!(EZDATA="YES") S EZDATA="YES, RECEIVING MILITARY RETIREMENT IN LIEU OF VA COMPENSATION"
+69 if EZDATA=PTDATA
QUIT
+70 ;repeat check for verified eligibility;
+71 ;do not file certain fields if eligibility verified
+72 KILL ARRAY
+73 SET DA=EASDFN
SET DIC="^DPT("
SET DR=".3611;.3613"
SET DIQ(0)="I"
SET DIQ="ARRAY"
+74 DO EN^DIQ1
KILL DA,DIC,DIQ,DR
+75 IF $GET(ARRAY(2,EASDFN,.3611,"I"))="V"
IF $GET(ARRAY(2,EASDFN,.3613,"I"))="H"
SET ELIGVER=1
+76 IF FLD=.313
IF $GET(ARRAY(2,EASDFN,.3611,"I"))="V"
QUIT
+77 IF $GET(ELIGVER)
IF ((FLD=.301)!(FLD=.302)!(FLD=.36235))
QUIT
+78 ;special for field #.32102 - Agent Orange Exposure . DATAKEY = I;14F
+79 IF FLD=.32102
DO F32102^EASEZF1A(EASAPP,EASDFN,EZDATA)
+80 ;setup to call FM database server using EASDFN as file #2 record
+81 KILL EAS,ERR
+82 SET IENS=EASDFN_","
+83 SET EROOT="EAS("_EASAPP_")"
+84 DO VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
+85 ;try to resolve possible invalid input for free text fields due to length
+86 IF $DATA(ERR)
DO RESOLVE
+87 IF $DATA(ERR)
DO ERROR^EASEZF2("AP",MULTIPLE,.ERR,"LINK")
+88 ;file to database if input is valid
+89 IF '$DATA(ERR)
Begin DoDot:2
+90 ;2/1/2001 - don't attempt to file Name, SSN, DOB; too many complications;
+91 ; example: if system assigns pseudo-SSN to new patient, user could overwrite;
+92 ; example: if applicant matched to existing patient, all critical identifying
+93 ; data could be overwritten; could impact HEC as well
+94 DO FILE^DIE("S",EROOT,"ERR")
+95 ;set any replaced data into subfile #712.01 for audit
+96 SET ^EAS(712,EASAPP,10,SUBIEN,2)=PTDATA_U_LINK
End DoDot:2
End DoDot:1
+97 ;
+98 ;L -^DPT(EASDFN) ;Handling locking in EASEZFM - EAS*1*93
+99 QUIT
+100 ;
RESOLVE ;try to resolve invalid input for free text fields only
+1 ;see if mapped to free text field
+2 NEW FDEF,FTYPE,MAX
+3 IF (SUBFILE=FILE)!(SUBFILE="")
SET FDEF=FILE
+4 IF '$TEST
SET FDEF=SUBFILE
+5 SET FTYPE=$$GET1^DID(FDEF,FLD,"","TYPE")
+6 if FTYPE'="FREE TEXT"
QUIT
+7 SET MAX=$$GET1^DID(FDEF,FLD,"","FIELD LENGTH")
+8 SET EZDATA=$EXTRACT(EZDATA,1,MAX)
+9 KILL ERR
+10 DO VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
+11 ;if still sets ERR array then won't be filed to database
+12 QUIT
+13 ;
F202(SUBFILE,DATAKEY,EZDATA,SUBIEN,KEYIEN) ;add or edit subrecord in subfile #2.02
+1 ;input SUBFILE = 2.02
+2 ; DATAKEY = data item identifier, e.g., I;4B.
+3 ; EZDATA = in these cases, either "N(o)" or "Y(es)"
+4 ; SUBIEN = subrecord # for data in #712/#10
+5 ; KEYIEN = record # for data element in #711
+6 NEW X,N,DATANM,EROOT,EAS,EIEN,ERR,FLD,IENS,EASARRAY,LINK,OUT,K1,K3
+7 if EZDATA'["Y"
QUIT
+8 if SUBFILE'=2.02
QUIT
+9 ;covert data to corresponding file #10 pointer
+10 SET X=$$KEY711^EASEZU1(DATAKEY)
+11 SET K1=$PIECE(X,U,1)
SET DATANM=$PIECE(X,U,2)
SET K3=$PIECE(X,U,3)
+12 if (DATANM="")
QUIT
+13 if (K1'=KEYIEN)
QUIT
+14 if (K3'=DATAKEY)
QUIT
+15 SET DATANM=$PIECE(DATANM," - ",2)
SET DATANM=$EXTRACT(DATANM,1,30)
+16 IF DATANM["UNANSWERED"
SET DATANM="UNKNOWN BY PATIENT"
+17 SET EZDATA=$ORDER(^DIC(10,"B",DATANM,0))
+18 if EZDATA=""
QUIT
+19 DO I202^EASEZI(EASDFN,.EASARRAY)
+20 ;if matching race already exists, edit method only
+21 SET OUT=0
SET N=0
FOR
SET N=$ORDER(EASARRAY(N))
if 'N
QUIT
Begin DoDot:1
+22 if ($PIECE(EASARRAY(N),";",2)'=EZDATA)
QUIT
+23 KILL EAS,ERR
+24 SET IENS=EZDATA_","_EASDFN_","
+25 SET EROOT="EAS("_EASAPP_")"
+26 SET FLD=.02
SET EAS(EASAPP,SUBFILE,IENS,FLD)=1
+27 DO FILE^DIE("S",EROOT,"ERR")
+28 SET OUT=1
End DoDot:1
+29 ;no matching race in patient record, add new subrecord
+30 IF 'OUT
Begin DoDot:1
+31 KILL ERR
+32 SET EROOT="EAS("_EASAPP_")"
+33 SET IENS="+1,"_EASDFN_","
SET EIEN(1)=EZDATA
+34 SET FLD=.01
SET EAS(EASAPP,SUBFILE,IENS,FLD)=EZDATA
+35 SET FLD=.02
SET EAS(EASAPP,SUBFILE,IENS,FLD)=1
+36 DO UPDATE^DIE("S",EROOT,"EIEN","ERR")
+37 IF $DATA(ERR)
DO ERROR^EASEZF2("AP",1,.ERR,"LINK")
QUIT
+38 SET LINK=EASDFN_";"_EZDATA
+39 SET ^EAS(712,EASAPP,10,SUBIEN,2)=U_LINK
End DoDot:1
+40 QUIT
+41 ;
F206(SUBFILE,DATAKEY,EZDATA,SUBIEN) ;add subrecord in subfile #2.06
+1 ;input SUBFILE = 2.06
+2 ; DATAKEY = data item identifier, e.g., I;4A.
+3 ; EZDATA = in these cases, either "N(o)" or "Y(es)"
+4 NEW X,EROOT,EAS,EIEN,ERR,FLD,EASARRAY,IENS,LINK,PTDATA
+5 if SUBFILE'=2.06
QUIT
+6 DO I206^EASEZI(EASDFN,.EASARRAY)
+7 SET LINK=$PIECE($GET(EASARRAY(1)),";",2)
SET PTDATA=""
IF LINK
SET PTDATA=$PIECE(^DPT(EASDFN,.06,LINK,0),U,1)
+8 IF DATAKEY="I;4A."
SET EZDATA=$SELECT(EZDATA["Y":"H",$EXTRACT(EZDATA,1)="N":"N",1:"U")
Begin DoDot:1
+9 SET EROOT="EAS("_EASAPP_")"
+10 SET IENS="+1,"_EASDFN_","
+11 SET FLD=.01
SET EAS(EASAPP,SUBFILE,IENS,FLD)=EZDATA
+12 SET FLD=.02
SET EAS(EASAPP,SUBFILE,IENS,FLD)="SELF IDENTIFICATION"
+13 DO UPDATE^DIE("ES",EROOT,"EIEN","ERR")
+14 SET LINK=EASDFN_";"_$GET(EIEN(1))
+15 SET ^EAS(712,EASAPP,10,SUBIEN,2)=PTDATA_U_LINK
End DoDot:1
+16 QUIT
+17 ;
FPOB(DATAKEY,EZDATA,SUBIEN,PTDATA) ;add or edit pob city & state
+1 ;input DATAKEY = data item identifier, either, I;8A. or I;8B.
+2 ; EZDATA = free text if city or
+3 ; state abbrv if state
+4 ;filing for both city & state only done when datakey=I;8A.
+5 NEW X,EROOT,EAS,EIEN,ERR,FLD,EASARRAY,IENS,LINK,SECT,QUES,XIEN,XDATA
+6 if (DATAKEY'="I;8A.")
QUIT
+7 if (EZDATA="")
QUIT
+8 if (EZDATA=PTDATA)
QUIT
+9 ;file pob city
+10 KILL EAS,ERR
+11 SET FLD=.092
SET LINK=EASDFN
+12 SET IENS=EASDFN_","
+13 SET EROOT="EAS("_EASAPP_")"
+14 DO VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
+15 IF $DATA(ERR)
DO RESOLVE
+16 IF $DATA(ERR)
DO ERROR^EASEZF2("AP",1,.ERR,"LINK")
QUIT
+17 DO FILE^DIE("ES",EROOT,"ERR")
+18 ;set any replaced data into subfile #712.01 for audit
+19 SET ^EAS(712,EASAPP,10,SUBIEN,2)=PTDATA_U_LINK
+20 ;file pob state
+21 SET (EZDATA,XDATA)=""
+22 SET DATAKEY="I;8B."
SET SECT=$PIECE(DATAKEY,";",1)
SET QUES=$PIECE(DATAKEY,";",2)
+23 SET X=$GET(^TMP("EZTEMP",$JOB,SECT,1,QUES))
SET EZDATA=$PIECE(X,U,2)
SET XIEN=$PIECE(X,U,4)
SET XDATA=$PIECE(X,U,5)
+24 if (EZDATA="")
QUIT
+25 if (EZDATA=XDATA)
QUIT
+26 IF (EZDATA["FOREIGN")!(EZDATA="FC")!(EZDATA="FG")
SET EZDATA="FOREIGN"
+27 KILL EAS,ERR
+28 SET FLD=.093
+29 SET IENS=EASDFN_","
+30 SET EROOT="EAS("_EASAPP_")"
+31 DO VAL^DIE(2,IENS,FLD,"F",EZDATA,,EROOT,"ERR")
+32 IF $DATA(ERR)
DO ERROR^EASEZF2("AP",1,.ERR,"LINK")
QUIT
+33 DO FILE^DIE("ES",EROOT,"ERR")
+34 SET ^EAS(712,EASAPP,10,XIEN,2)=XDATA_U_LINK
+35 QUIT
+36 ;
F23216(SUBFILE,DATAKEY,EZDATA,SUBIEN,KEYIEN) ;add subrecord in subfile #2.3216
+1 ;input SUBFILE = 2.3216
+2 ; DATAKEY = data item identifier, e.g., I;13A.
+3 ; EZDATA = data value in external format
+4 ; KEYIEN = record # for data element in #711
+5 ;
+6 ;Values for KEYIEN DATAKEY
+7 ; 28 - Branch of Service I;13A
+8 ; 29 - Last Entry Date I;13B
+9 ; 30 - Last Separation Date I;13C
+10 ; 31 - Last Discharge Type I;13D
+11 ; 32 - Last Service Number I;13E
+12 ;
+13 if SUBFILE'=2.3216
QUIT
+14 ;
+15 NEW X,EAS,EASARRAY,LINK,PTDATA,SUBIEN
+16 ;Get episodes from VistA into EASARRAY
+17 DO GETMSE^DGMSEUTL(EASDFN,.EASARRAY)
+18 ;Move last VistA episode into PDATA (for future use in edit option)
+19 SET LINK=$GET(EASARRAY(1,"IEN"))
SET PTDATA=""
+20 IF LINK
SET PTDATA=$GET(^DPT(EASDFN,2.3216,LINK,0))
+21 ;
+22 ;Only proceed to add new subrecord if no .3216 data exists
+23 if PTDATA'=""
QUIT
+24 ;
TBD1 ;if this is entirely new and later than VistA episodes, allow add?
+1 ;
+2 ; (compare EDATE to last episode in PDATA and allow addition if it is; a date later than last separation date)
+3 ;
TBD2 ;if matching episode already exists, allow update?
+1 ;
+2 ; (see code in F202^EASEZF1 for update, get last IENS from EASARRAY)
+3 ;
+4 ;Get last episode 1010EZ fields from ^TMP("EZDATA"
+5 NEW BOS,EDATE,SDATE,DTYPE,SERVNO
+6 SET BOS=$PIECE($GET(^TMP("EZDATA",$JOB,28,1,1)),U)
if BOS=""
QUIT
+7 SET EDATE=$PIECE($GET(^TMP("EZDATA",$JOB,29,1,1)),U)
if EDATE=""
QUIT
+8 SET SDATE=$PIECE($GET(^TMP("EZDATA",$JOB,30,1,1)),U)
if SDATE=""
QUIT
+9 SET DTYPE=$PIECE($GET(^TMP("EZDATA",$JOB,31,1,1)),U)
if DTYPE=""
QUIT
+10 SET SERVNO=$PIECE($GET(^TMP("EZDATA",$JOB,32,1,1)),U)
+11 ;
+12 ;Special conversion of service number (see code in EASEZF1)
+13 IF $$UC^EASEZT1(SERVNO)="SSN"
Begin DoDot:1
+14 NEW EZSSN,KK,PTSSN
+15 ;allow SSN as Service Number if service number in patient last
+16 ;.3216 record is null. Always case if no .3216 data exists
+17 SET PTSSN=$PIECE(PTDATA,U,5)
+18 IF PTSSN=""
SET SERVNO="SS"
QUIT
+19 ;alternatively Applicant SSN must match service number
+20 SET KK=$$KEY711^EASEZU1("APPLICANT SOCIAL SECURITY NUMBER")
+21 SET EZSSN=$PIECE($GET(^TMP("EZDATA",$JOB,KK,1,1)),U,1)
+22 SET EZSSN=$TRANSLATE(EZSSN,"-","")
+23 IF EZSSN=PTSSN
SET SERVNO="SS"
QUIT
+24 SET SERVNO="ssn"
End DoDot:1
+25 ;
+26 ;File 1010EZ data to .3216
+27 NEW X,Y,EROOT,ERR,FLD,IENS,EIEN
+28 SET EROOT="EAS("_EASAPP_")"
+29 SET IENS="+1,"_EASDFN_","
+30 SET FLD=.01
SET EAS(EASAPP,SUBFILE,IENS,FLD)=EDATE
+31 SET FLD=.02
SET EAS(EASAPP,SUBFILE,IENS,FLD)=SDATE
+32 SET FLD=.03
SET EAS(EASAPP,SUBFILE,IENS,FLD)=BOS
+33 SET FLD=.05
SET EAS(EASAPP,SUBFILE,IENS,FLD)=SERVNO
+34 SET FLD=.06
SET EAS(EASAPP,SUBFILE,IENS,FLD)=DTYPE
+35 DO UPDATE^DIE("ES",EROOT,"EIEN","ERR")
+36 IF $DATA(ERR)
DO ERROR^EASEZF2("AP",1,.ERR,"LINK")
QUIT
+37 ;
+38 SET SUBIEN=$ORDER(^EAS(712,EASAPP,10,"B",28,""))
+39 if SUBIEN
SET ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$GET(EIEN(1))
+40 SET SUBIEN=$ORDER(^EAS(712,EASAPP,10,"B",29,""))
+41 if SUBIEN
SET ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$GET(EIEN(1))
+42 SET SUBIEN=$ORDER(^EAS(712,EASAPP,10,"B",30,""))
+43 if SUBIEN
SET ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$GET(EIEN(1))
+44 SET SUBIEN=$ORDER(^EAS(712,EASAPP,10,"B",31,""))
+45 if SUBIEN
SET ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$GET(EIEN(1))
+46 SET SUBIEN=$ORDER(^EAS(712,EASAPP,10,"B",32,""))
+47 if SUBIEN
SET ^EAS(712,EASAPP,10,SUBIEN,2)=U_EASDFN_";"_$GET(EIEN(1))
+48 QUIT
