RGADTP3 ;BIR/CMC-RGADTP2 - CONTINUED ;4/21/22 10:52
;;1.0;CLINICAL INFO RESOURCE NETWORK;**48,59,63,65,67,68,71,73,76,77**;30 Apr 99;Build 3
;
;MOVED CHKPVT AND DIFF FROM RGADTP2 DUE TO ROUTINE SIZE ISSUE
Q
CHKPVT(ARRAY) ;CHECKS TO SEE IF OUTSTANDING IDENTITY EDIT IS WAITING TO BE SENT IN THE ADT/HL7 PIVOT FILE
;**44 CREATED - ARRAY CONTAINS THE ARRAY ELEMENTS NEEDED TO FIND THE PATIENT IN THE ADT/HL7 PIVOT FILE
;RETURNED IS -1^EDIT PENDING IN PIVOT FILE OR 0 IF THERE ISN'T ONE
I '$D(^VAT(391.71,"C",ARRAY("DFN"))) Q 0
N PIV,FIELDS
S PIV=$O(^VAT(391.71,"C",ARRAY("DFN"),"A"),-1) ;get last entry in the pivot file for this patient
I '$D(^VAT(391.71,"AXMIT",4,PIV))&('$D(^VAT(391.71,"AXMIT",3,PIV))) Q 0
S FIELDS=$$GET1^DIQ(391.71,PIV_",",2.1,"I")
I FIELDS[".01;"!(FIELDS[".02;")!(FIELDS[".03;")!(FIELDS[".09;")!(FIELDS[".0906;")!(FIELDS[".2403;")!(FIELDS["994;") Q "-1^DFN "_ARRAY("DFN")_": Edits made to identity fields waiting to come to MPI, MPI update not processed as of yet."
Q 0
;
DIFF(ARRAY,RGRSDFN,DR,ARAY) ; are there fields to update? **47
N NAME,SSN,PDOB,SEX,SID,MMN,OLDNAME,OLDHLNAM,OLDMMN,OLDHLMMN,HLNAME,HLMMN,SSNV,MBI,PSNR,PREFNAME,TIN,FIN,ITIN,SEXORDES,PRONOUNDES
S DR="",NAME=$$GET1^DIQ(2,+RGRSDFN_",",.01,"I"),HLNAME=ARRAY("NAME")
;**48 remove name standardization check
;D STDNAME^XLFNAME(.NAME,"F",.OLDNAME) S HLNAME=ARRAY("NAME") D STDNAME^XLFNAME(.HLNAME,"F",.OLDHLNAM)
;**71,Story 841921 (mko): If the Name Components flag is not set, and the incoming name is > 30 chars,
; use the name components to build a truncated name
; If the flag is set, then we need to update the Name Components entry rather than the Patient Name.
; Save the incoming components in ARAY(20), when different from existing values
I '$$GETFLAG^MPIFNAMC D
.S:$L(HLNAME)>30 (HLNAME,ARRAY("NAME"))=$$FMTNAME(.ARRAY,30)
.S:NAME'=$G(HLNAME) DR=DR_".01;",ARAY(2,.01)=ARRAY("NAME")
E D
.N DIERR,DIMSG,DIHELP,MSG,NCIENS,TARG
.S NCIENS=$$GET1^DIQ(2,+RGRSDFN_",",1.01,"I","","MSG")_","
.D:NCIENS>0 GETS^DIQ(20,NCIENS,"1;2;3;5","I","TARG","MSG")
.S:$G(TARG(20,NCIENS,1,"I"))'=$G(ARRAY("SURNAME")) ARAY(2,1.01,"FAMILY")=$G(ARRAY("SURNAME"))
.S:$G(TARG(20,NCIENS,2,"I"))'=$G(ARRAY("FIRST")) ARAY(2,1.01,"GIVEN")=$G(ARRAY("FIRST"))
.S:$G(TARG(20,NCIENS,3,"I"))'=$G(ARRAY("MIDDLE")) ARAY(2,1.01,"MIDDLE")=$G(ARRAY("MIDDLE"))
.S:$G(TARG(20,NCIENS,5,"I"))'=$G(ARRAY("SUFFIX")) ARAY(2,1.01,"SUFFIX")=$G(ARRAY("SUFFIX"))
.S:$D(ARAY(2,1.01)) DR=DR_"1.01;"
;**67 - Story 455460 (ckn) - Update Preferred Name
S PREFNAME=$$GET1^DIQ(2,+RGRSDFN_",",.2405,"I") D
.I PREFNAME="",$G(ARRAY("PREFERREDNAME"))="@" Q
.I PREFNAME'=$G(ARRAY("PREFERREDNAME")) S DR=DR_".2405;",ARAY(2,.2405)=$G(ARRAY("PREFERREDNAME"))
S PDOB=$$GET1^DIQ(2,+RGRSDFN_",",.03,"I") I PDOB'=ARRAY("MPIDOB") S DR=DR_".03;",ARAY(2,.03)=ARRAY("MPIDOB")
S SSN=$$GET1^DIQ(2,+RGRSDFN_",",.09,"I") D
.I SSN["P",ARRAY("SSN")=""!(ARRAY("SSN")="@") Q
.; **47 if incoming SSN value is null/@ and existing SSN isn't a pseudo create a new pseudo SSN
.I SSN'["P" I ARRAY("SSN")="@"!(ARRAY("SSN")="") S ARRAY("SSN")="P"
.I SSN'=ARRAY("SSN"),ARRAY("SSN")'="" S DR=DR_".09;",ARAY(2,.09)=ARRAY("SSN")
S SEX=$$GET1^DIQ(2,+RGRSDFN_",",.02,"I") D
.I SEX=""&(ARRAY("SEX")="@") Q
.I SEX'=ARRAY("SEX") S DR=DR_".02;",ARAY(2,.02)=ARRAY("SEX")
;**63 Story 174247: Self-ID Gender
S SID=$$GET1^DIQ(2,+RGRSDFN_",",.024,"I") D
.I SID="",$G(ARRAY(.024))="@" Q
.I SID'=$G(ARRAY(.024)) S DR=DR_".024;",ARAY(2,.024)=$G(ARRAY(".024"))
;S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") I SSNV="" S SSNV="@"
;I SSNV'=$G(ARRAY(.0907)) S ARAY(2,.0907)=$G(ARRAY(.0907)),DR=DR_".0907;" ;**76 don't file until after ssn is filed by EDIT^VAFCPTED in ^RGADTP2
;S PSNR=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") I PSNR="" S PSNR="@"
;I PSNR'=ARRAY(.0906) S ARAY(2,.0906)=$G(ARRAY(.0906)),DR=DR_".0906;" ;**76 don't file until after ssn is filed by EDIT^VAFCPTED in ^RGADTP2
I $G(ARRAY("MBI"))'="" D ;**59, MVI_881
. S MBI=$$GET1^DIQ(2,+RGRSDFN_",",994,"I") S:MBI="" MBI="@"
. I MBI'=ARRAY("MBI") S DR=DR_"994;",ARAY(2,994)=ARRAY("MBI")
S HLMMN=$G(ARRAY("MMN")) ;**59, MVI_881
I HLMMN'="" D
. S MMN=$$GET1^DIQ(2,+RGRSDFN_",",.2403,"I") S:MMN="" MMN="@"
. I MMN'="@" D STDNAME^XLFNAME(.MMN,"F",.OLDMMN)
. I HLMMN'="@" D STDNAME^XLFNAME(.HLMMN,"F",.OLDHLMMN)
. I MMN'=HLMMN S DR=DR_".2403;",ARAY(2,.2403)=ARRAY("MMN")
I $G(ARRAY("TIN"))'="" D
. S TIN=$$GET1^DIQ(2,+RGRSDFN_",",991.08,"I") S:TIN="" TIN="@"
. I TIN'=ARRAY("TIN") S DR=DR_"991.08;",ARAY(2,991.08)=ARRAY("TIN")
I $G(ARRAY("FIN"))'="" D
. S FIN=$$GET1^DIQ(2,+RGRSDFN_",",991.09,"I") S:FIN="" FIN="@"
. I FIN'=ARRAY("FIN") S DR=DR_"991.09;",ARAY(2,991.09)=ARRAY("FIN")
I $G(ARRAY("ITIN"))'="" D ;**76, VAMPI-11120 (dri) update ITIN field
. S ITIN=$$GET1^DIQ(2,+RGRSDFN_",",991.11,"I") S:ITIN="" ITIN="@"
. I ITIN'=ARRAY("ITIN") S DR=DR_"991.11;",ARAY(2,991.11)=ARRAY("ITIN")
I $S($O(ARRAY("SexOr",0)):1,$O(^DPT(+RGRSDFN,.025,0)):1,1:0) S DR=DR_".025;" ;**76, VAMPI-11114 (dri) check in ^vafcpted whether to update sexual orientation
I $G(ARRAY("SexOrDes"))'="" D ;**76, VAMPI-11114 (dri) update sexual orientation description ;**77, VAMPI-13755 (dri) - file after "SexOr" for "AHIST" x-ref
. S SEXORDES=$$GET1^DIQ(2,+RGRSDFN_",",.0251,"I") S:SEXORDES="" SEXORDES="@"
. I SEXORDES'=ARRAY("SexOrDes") S DR=DR_".0251;",ARAY(2,.0251)=ARRAY("SexOrDes")
I $S($O(ARRAY("Pronoun",0)):1,$O(^DPT(+RGRSDFN,.2406,0)):1,1:0) S DR=DR_".2406;" ;**76, VAMPI-11118 (dri) check in vafcpted whether to update pronoun
I $G(ARRAY("PronounDes"))'="" D ;**76, VAMPI-11118 (dri) update pronoun description
. S PRONOUNDES=$$GET1^DIQ(2,+RGRSDFN_",",.24061,"I") S:PRONOUNDES="" PRONOUNDES="@"
. I PRONOUNDES'=ARRAY("PronounDes") S DR=DR_".24061;",ARAY(2,.24061)=ARRAY("PronounDes")
I $S($O(ARRAY("ALIAS",0)):1,$O(^DPT(+RGRSDFN,.01,0)):1,1:0) S DR=DR_"1;"
;**65 - Story 323009 (ckn): Update DOD fields
N ODOD,ODODP,ODODLUP,ODODSRC,ODODARY,ODODD,ANSWER,DUPDFLG
S DUPDFLG=$$CHK^VAFCDODA() ;Date of Death update flag
; check for validation of Date of Death- if imprecise date of
; death - remove all Date of Death if no existin date of death
D VAL^DIE(2,+RGRSDFN_",",.351,"R",$G(ARRAY("MPIDOD")),.ANSWER)
I DUPDFLG D
. I $G(ARRAY("MPIDOD"))="""@"""!($G(ARRAY("MPIDOD"))="") D Q
..;**68 - Story 500735 (ckn) : Only Delete Date of Death data if
..; deletion through PSIM TK OVERRIDE
.. I '$G(ARRAY("TKOVRDOD")) Q
.. I $$GET1^DIQ(2,+RGRSDFN_",",.351,"I")="" Q
.. S DR=DR_".354;",ARAY(2,.354)=$G(ARRAY(.354)) ;Date of death last updated date
.. ;Remove rest of the DOD fields
.. S DR=DR_".351;.352;.353;.355;.357;.358;",(ARAY(2,.351),ARAY(2,.352),ARAY(2,.353),ARAY(2,.355),ARAY(2,.357),ARAY(2,.358))="@"
. I ANSWER="^" S DODIMPF=1_"^"_$G(ARRAY("MPIDOD")) Q ;Date of Death Imprecise Flag - No update on VistA
. I $G(ARRAY("MPIDOD"))>0 D Q
.. N TUPD S TUPD=0
.. D GETS^DIQ(2,+RGRSDFN_",",".351;.353;.354;.357","I","ODODARY")
.. S ODOD=ODODARY(2,+RGRSDFN_",",.351,"I")
..; S ODODD=ODODARY(2,+RGRSDFN_",",.357,"I")
.. S ODODLUP=ODODARY(2,+RGRSDFN_",",.354,"I")
.. S ODODSRC=ODODARY(2,+RGRSDFN_",",.353,"I")
..; I ODOD=ARRAY("MPIDOD") Q ;No update if no change in Date of Death
..;**71 - Story 841797 (ckn)
..;DOD metadata update allowed if update is from PSIM TK OVERRIDE even
..;if no change in Date of Death
..;**131 - Story 1125116 (ckn) DOD metadata update is allowed now regardless
..; I ODOD=ARRAY("MPIDOD"),'$G(ARRAY("TKOVRDOD")) Q
.. I ODOD'=ARRAY("MPIDOD") S DR=DR_".351;",ARAY(2,.351)=$G(ARRAY(.351)),TUPD=1
..; I ODODD'=$G(ARRAY("DODDocType")) S DR=DR_".357;",ARAY(2,.357)=$G(ARRAY(.357))
.. I ODODLUP'=$G(ARRAY("DODLastUpdated")),(ODOD'=ARRAY("MPIDOD")) S DR=DR_".354;",ARAY(2,.354)=$G(ARRAY(.354))
.. I ODODSRC'=$G(ARRAY("DODSource")) S DR=DR_".353;",ARAY(2,.353)=$G(ARRAY(.353)),TUPD=1
.. ;S DR=DR_".353;",ARAY(2,.353)=$G(ARRAY(.353))
.. ;Remove rest of the DOD fields if Date Of Death is getting updated
.. S DR=DR_".352;.357;.358",ARAY(2,.352)="@",ARAY(2,.358)="@",ARAY(2,.357)="@"
.. I TUPD S DR=DR_";.355",ARAY(2,.355)="@"
Q
;
FMTNAME(ARRAY,LEN) ;Return a formatted name from cleaned Name Components that doesn't exceed LEN characters in length.
;**71,Story 841921 (mko): New function
N NC
S:'$G(LEN) LEN=30
;
;If ARRAY is passed as a string and doesn't have descendants assume it equals "surname^first^middle^suffix"
D:$D(ARRAY)=1
. S ARRAY("SURNAME")=$P(ARRAY,"^")
. S ARRAY("FIRST")=$P(ARRAY,"^",2)
. S ARRAY("MIDDLE")=$P(ARRAY,"^",3)
. S ARRAY("SUFFIX")=$P(ARRAY,"^",4)
;
;Clean the components
S NC("FAMILY")=$$CLEANC^XLFNAME($G(ARRAY("SURNAME")))
S NC("GIVEN")=$$CLEANC^XLFNAME($G(ARRAY("FIRST")))
S NC("MIDDLE")=$$CLEANC^XLFNAME($G(ARRAY("MIDDLE")))
S NC("SUFFIX")=$$CLEANC^XLFNAME($G(ARRAY("SUFFIX")))
;
;Build a full name, maximum length LEN
Q $$NAMEFMT^XLFNAME(.NC,"F","CL"_LEN)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRGADTP3 9019 printed Jan 18, 2025@02:42:40 Page 2
RGADTP3 ;BIR/CMC-RGADTP2 - CONTINUED ;4/21/22 10:52
+1 ;;1.0;CLINICAL INFO RESOURCE NETWORK;**48,59,63,65,67,68,71,73,76,77**;30 Apr 99;Build 3
+2 ;
+3 ;MOVED CHKPVT AND DIFF FROM RGADTP2 DUE TO ROUTINE SIZE ISSUE
+4 QUIT
CHKPVT(ARRAY) ;CHECKS TO SEE IF OUTSTANDING IDENTITY EDIT IS WAITING TO BE SENT IN THE ADT/HL7 PIVOT FILE
+1 ;**44 CREATED - ARRAY CONTAINS THE ARRAY ELEMENTS NEEDED TO FIND THE PATIENT IN THE ADT/HL7 PIVOT FILE
+2 ;RETURNED IS -1^EDIT PENDING IN PIVOT FILE OR 0 IF THERE ISN'T ONE
+3 IF '$DATA(^VAT(391.71,"C",ARRAY("DFN")))
QUIT 0
+4 NEW PIV,FIELDS
+5 ;get last entry in the pivot file for this patient
SET PIV=$ORDER(^VAT(391.71,"C",ARRAY("DFN"),"A"),-1)
+6 IF '$DATA(^VAT(391.71,"AXMIT",4,PIV))&('$DATA(^VAT(391.71,"AXMIT",3,PIV)))
QUIT 0
+7 SET FIELDS=$$GET1^DIQ(391.71,PIV_",",2.1,"I")
+8 IF FIELDS[".01;"!(FIELDS[".02;")!(FIELDS[".03;")!(FIELDS[".09;")!(FIELDS[".0906;")!(FIELDS[".2403;")!(FIELDS["994;")
QUIT "-1^DFN "_ARRAY("DFN")_": Edits made to identity fields waiting to come to MPI, MPI update not processed as of yet."
+9 QUIT 0
+10 ;
DIFF(ARRAY,RGRSDFN,DR,ARAY) ; are there fields to update? **47
+1 NEW NAME,SSN,PDOB,SEX,SID,MMN,OLDNAME,OLDHLNAM,OLDMMN,OLDHLMMN,HLNAME,HLMMN,SSNV,MBI,PSNR,PREFNAME,TIN,FIN,ITIN,SEXORDES,PRONOUNDES
+2 SET DR=""
SET NAME=$$GET1^DIQ(2,+RGRSDFN_",",.01,"I")
SET HLNAME=ARRAY("NAME")
+3 ;**48 remove name standardization check
+4 ;D STDNAME^XLFNAME(.NAME,"F",.OLDNAME) S HLNAME=ARRAY("NAME") D STDNAME^XLFNAME(.HLNAME,"F",.OLDHLNAM)
+5 ;**71,Story 841921 (mko): If the Name Components flag is not set, and the incoming name is > 30 chars,
+6 ; use the name components to build a truncated name
+7 ; If the flag is set, then we need to update the Name Components entry rather than the Patient Name.
+8 ; Save the incoming components in ARAY(20), when different from existing values
+9 IF '$$GETFLAG^MPIFNAMC
Begin DoDot:1
+10 if $LENGTH(HLNAME)>30
SET (HLNAME,ARRAY("NAME"))=$$FMTNAME(.ARRAY,30)
+11 if NAME'=$GET(HLNAME)
SET DR=DR_".01;"
SET ARAY(2,.01)=ARRAY("NAME")
End DoDot:1
+12 IF '$TEST
Begin DoDot:1
+13 NEW DIERR,DIMSG,DIHELP,MSG,NCIENS,TARG
+14 SET NCIENS=$$GET1^DIQ(2,+RGRSDFN_",",1.01,"I","","MSG")_","
+15 if NCIENS>0
DO GETS^DIQ(20,NCIENS,"1;2;3;5","I","TARG","MSG")
+16 if $GET(TARG(20,NCIENS,1,"I"))'=$GET(ARRAY("SURNAME"))
SET ARAY(2,1.01,"FAMILY")=$GET(ARRAY("SURNAME"))
+17 if $GET(TARG(20,NCIENS,2,"I"))'=$GET(ARRAY("FIRST"))
SET ARAY(2,1.01,"GIVEN")=$GET(ARRAY("FIRST"))
+18 if $GET(TARG(20,NCIENS,3,"I"))'=$GET(ARRAY("MIDDLE"))
SET ARAY(2,1.01,"MIDDLE")=$GET(ARRAY("MIDDLE"))
+19 if $GET(TARG(20,NCIENS,5,"I"))'=$GET(ARRAY("SUFFIX"))
SET ARAY(2,1.01,"SUFFIX")=$GET(ARRAY("SUFFIX"))
+20 if $DATA(ARAY(2,1.01))
SET DR=DR_"1.01;"
End DoDot:1
+21 ;**67 - Story 455460 (ckn) - Update Preferred Name
+22 SET PREFNAME=$$GET1^DIQ(2,+RGRSDFN_",",.2405,"I")
Begin DoDot:1
+23 IF PREFNAME=""
IF $GET(ARRAY("PREFERREDNAME"))="@"
QUIT
+24 IF PREFNAME'=$GET(ARRAY("PREFERREDNAME"))
SET DR=DR_".2405;"
SET ARAY(2,.2405)=$GET(ARRAY("PREFERREDNAME"))
End DoDot:1
+25 SET PDOB=$$GET1^DIQ(2,+RGRSDFN_",",.03,"I")
IF PDOB'=ARRAY("MPIDOB")
SET DR=DR_".03;"
SET ARAY(2,.03)=ARRAY("MPIDOB")
+26 SET SSN=$$GET1^DIQ(2,+RGRSDFN_",",.09,"I")
Begin DoDot:1
+27 IF SSN["P"
IF ARRAY("SSN")=""!(ARRAY("SSN")="@")
QUIT
+28 ; **47 if incoming SSN value is null/@ and existing SSN isn't a pseudo create a new pseudo SSN
+29 IF SSN'["P"
IF ARRAY("SSN")="@"!(ARRAY("SSN")="")
SET ARRAY("SSN")="P"
+30 IF SSN'=ARRAY("SSN")
IF ARRAY("SSN")'=""
SET DR=DR_".09;"
SET ARAY(2,.09)=ARRAY("SSN")
End DoDot:1
+31 SET SEX=$$GET1^DIQ(2,+RGRSDFN_",",.02,"I")
Begin DoDot:1
+32 IF SEX=""&(ARRAY("SEX")="@")
QUIT
+33 IF SEX'=ARRAY("SEX")
SET DR=DR_".02;"
SET ARAY(2,.02)=ARRAY("SEX")
End DoDot:1
+34 ;**63 Story 174247: Self-ID Gender
+35 SET SID=$$GET1^DIQ(2,+RGRSDFN_",",.024,"I")
Begin DoDot:1
+36 IF SID=""
IF $GET(ARRAY(.024))="@"
QUIT
+37 IF SID'=$GET(ARRAY(.024))
SET DR=DR_".024;"
SET ARAY(2,.024)=$GET(ARRAY(".024"))
End DoDot:1
+38 ;S SSNV=$$GET1^DIQ(2,+RGRSDFN_",",.0907,"I") I SSNV="" S SSNV="@"
+39 ;I SSNV'=$G(ARRAY(.0907)) S ARAY(2,.0907)=$G(ARRAY(.0907)),DR=DR_".0907;" ;**76 don't file until after ssn is filed by EDIT^VAFCPTED in ^RGADTP2
+40 ;S PSNR=$$GET1^DIQ(2,+RGRSDFN_",",.0906,"I") I PSNR="" S PSNR="@"
+41 ;I PSNR'=ARRAY(.0906) S ARAY(2,.0906)=$G(ARRAY(.0906)),DR=DR_".0906;" ;**76 don't file until after ssn is filed by EDIT^VAFCPTED in ^RGADTP2
+42 ;**59, MVI_881
IF $GET(ARRAY("MBI"))'=""
Begin DoDot:1
+43 SET MBI=$$GET1^DIQ(2,+RGRSDFN_",",994,"I")
if MBI=""
SET MBI="@"
+44 IF MBI'=ARRAY("MBI")
SET DR=DR_"994;"
SET ARAY(2,994)=ARRAY("MBI")
End DoDot:1
+45 ;**59, MVI_881
SET HLMMN=$GET(ARRAY("MMN"))
+46 IF HLMMN'=""
Begin DoDot:1
+47 SET MMN=$$GET1^DIQ(2,+RGRSDFN_",",.2403,"I")
if MMN=""
SET MMN="@"
+48 IF MMN'="@"
DO STDNAME^XLFNAME(.MMN,"F",.OLDMMN)
+49 IF HLMMN'="@"
DO STDNAME^XLFNAME(.HLMMN,"F",.OLDHLMMN)
+50 IF MMN'=HLMMN
SET DR=DR_".2403;"
SET ARAY(2,.2403)=ARRAY("MMN")
End DoDot:1
+51 IF $GET(ARRAY("TIN"))'=""
Begin DoDot:1
+52 SET TIN=$$GET1^DIQ(2,+RGRSDFN_",",991.08,"I")
if TIN=""
SET TIN="@"
+53 IF TIN'=ARRAY("TIN")
SET DR=DR_"991.08;"
SET ARAY(2,991.08)=ARRAY("TIN")
End DoDot:1
+54 IF $GET(ARRAY("FIN"))'=""
Begin DoDot:1
+55 SET FIN=$$GET1^DIQ(2,+RGRSDFN_",",991.09,"I")
if FIN=""
SET FIN="@"
+56 IF FIN'=ARRAY("FIN")
SET DR=DR_"991.09;"
SET ARAY(2,991.09)=ARRAY("FIN")
End DoDot:1
+57 ;**76, VAMPI-11120 (dri) update ITIN field
IF $GET(ARRAY("ITIN"))'=""
Begin DoDot:1
+58 SET ITIN=$$GET1^DIQ(2,+RGRSDFN_",",991.11,"I")
if ITIN=""
SET ITIN="@"
+59 IF ITIN'=ARRAY("ITIN")
SET DR=DR_"991.11;"
SET ARAY(2,991.11)=ARRAY("ITIN")
End DoDot:1
+60 ;**76, VAMPI-11114 (dri) check in ^vafcpted whether to update sexual orientation
IF $SELECT($ORDER(ARRAY("SexOr",0)):1,$ORDER(^DPT(+RGRSDFN,.025,0)):1,1:0)
SET DR=DR_".025;"
+61 ;**76, VAMPI-11114 (dri) update sexual orientation description ;**77, VAMPI-13755 (dri) - file after "SexOr" for "AHIST" x-ref
IF $GET(ARRAY("SexOrDes"))'=""
Begin DoDot:1
+62 SET SEXORDES=$$GET1^DIQ(2,+RGRSDFN_",",.0251,"I")
if SEXORDES=""
SET SEXORDES="@"
+63 IF SEXORDES'=ARRAY("SexOrDes")
SET DR=DR_".0251;"
SET ARAY(2,.0251)=ARRAY("SexOrDes")
End DoDot:1
+64 ;**76, VAMPI-11118 (dri) check in vafcpted whether to update pronoun
IF $SELECT($ORDER(ARRAY("Pronoun",0)):1,$ORDER(^DPT(+RGRSDFN,.2406,0)):1,1:0)
SET DR=DR_".2406;"
+65 ;**76, VAMPI-11118 (dri) update pronoun description
IF $GET(ARRAY("PronounDes"))'=""
Begin DoDot:1
+66 SET PRONOUNDES=$$GET1^DIQ(2,+RGRSDFN_",",.24061,"I")
if PRONOUNDES=""
SET PRONOUNDES="@"
+67 IF PRONOUNDES'=ARRAY("PronounDes")
SET DR=DR_".24061;"
SET ARAY(2,.24061)=ARRAY("PronounDes")
End DoDot:1
+68 IF $SELECT($ORDER(ARRAY("ALIAS",0)):1,$ORDER(^DPT(+RGRSDFN,.01,0)):1,1:0)
SET DR=DR_"1;"
+69 ;**65 - Story 323009 (ckn): Update DOD fields
+70 NEW ODOD,ODODP,ODODLUP,ODODSRC,ODODARY,ODODD,ANSWER,DUPDFLG
+71 ;Date of Death update flag
SET DUPDFLG=$$CHK^VAFCDODA()
+72 ; check for validation of Date of Death- if imprecise date of
+73 ; death - remove all Date of Death if no existin date of death
+74 DO VAL^DIE(2,+RGRSDFN_",",.351,"R",$GET(ARRAY("MPIDOD")),.ANSWER)
+75 IF DUPDFLG
Begin DoDot:1
+76 IF $GET(ARRAY("MPIDOD"))="""@"""!($GET(ARRAY("MPIDOD"))="")
Begin DoDot:2
+77 ;**68 - Story 500735 (ckn) : Only Delete Date of Death data if
+78 ; deletion through PSIM TK OVERRIDE
+79 IF '$GET(ARRAY("TKOVRDOD"))
QUIT
+80 IF $$GET1^DIQ(2,+RGRSDFN_",",.351,"I")=""
QUIT
+81 ;Date of death last updated date
SET DR=DR_".354;"
SET ARAY(2,.354)=$GET(ARRAY(.354))
+82 ;Remove rest of the DOD fields
+83 SET DR=DR_".351;.352;.353;.355;.357;.358;"
SET (ARAY(2,.351),ARAY(2,.352),ARAY(2,.353),ARAY(2,.355),ARAY(2,.357),ARAY(2,.358))="@"
End DoDot:2
QUIT
+84 ;Date of Death Imprecise Flag - No update on VistA
IF ANSWER="^"
SET DODIMPF=1_"^"_$GET(ARRAY("MPIDOD"))
QUIT
+85 IF $GET(ARRAY("MPIDOD"))>0
Begin DoDot:2
+86 NEW TUPD
SET TUPD=0
+87 DO GETS^DIQ(2,+RGRSDFN_",",".351;.353;.354;.357","I","ODODARY")
+88 SET ODOD=ODODARY(2,+RGRSDFN_",",.351,"I")
+89 ; S ODODD=ODODARY(2,+RGRSDFN_",",.357,"I")
+90 SET ODODLUP=ODODARY(2,+RGRSDFN_",",.354,"I")
+91 SET ODODSRC=ODODARY(2,+RGRSDFN_",",.353,"I")
+92 ; I ODOD=ARRAY("MPIDOD") Q ;No update if no change in Date of Death
+93 ;**71 - Story 841797 (ckn)
+94 ;DOD metadata update allowed if update is from PSIM TK OVERRIDE even
+95 ;if no change in Date of Death
+96 ;**131 - Story 1125116 (ckn) DOD metadata update is allowed now regardless
+97 ; I ODOD=ARRAY("MPIDOD"),'$G(ARRAY("TKOVRDOD")) Q
+98 IF ODOD'=ARRAY("MPIDOD")
SET DR=DR_".351;"
SET ARAY(2,.351)=$GET(ARRAY(.351))
SET TUPD=1
+99 ; I ODODD'=$G(ARRAY("DODDocType")) S DR=DR_".357;",ARAY(2,.357)=$G(ARRAY(.357))
+100 IF ODODLUP'=$GET(ARRAY("DODLastUpdated"))
IF (ODOD'=ARRAY("MPIDOD"))
SET DR=DR_".354;"
SET ARAY(2,.354)=$GET(ARRAY(.354))
+101 IF ODODSRC'=$GET(ARRAY("DODSource"))
SET DR=DR_".353;"
SET ARAY(2,.353)=$GET(ARRAY(.353))
SET TUPD=1
+102 ;S DR=DR_".353;",ARAY(2,.353)=$G(ARRAY(.353))
+103 ;Remove rest of the DOD fields if Date Of Death is getting updated
+104 SET DR=DR_".352;.357;.358"
SET ARAY(2,.352)="@"
SET ARAY(2,.358)="@"
SET ARAY(2,.357)="@"
+105 IF TUPD
SET DR=DR_";.355"
SET ARAY(2,.355)="@"
End DoDot:2
QUIT
End DoDot:1
+106 QUIT
+107 ;
FMTNAME(ARRAY,LEN) ;Return a formatted name from cleaned Name Components that doesn't exceed LEN characters in length.
+1 ;**71,Story 841921 (mko): New function
+2 NEW NC
+3 if '$GET(LEN)
SET LEN=30
+4 ;
+5 ;If ARRAY is passed as a string and doesn't have descendants assume it equals "surname^first^middle^suffix"
+6 if $DATA(ARRAY)=1
Begin DoDot:1
+7 SET ARRAY("SURNAME")=$PIECE(ARRAY,"^")
+8 SET ARRAY("FIRST")=$PIECE(ARRAY,"^",2)
+9 SET ARRAY("MIDDLE")=$PIECE(ARRAY,"^",3)
+10 SET ARRAY("SUFFIX")=$PIECE(ARRAY,"^",4)
End DoDot:1
+11 ;
+12 ;Clean the components
+13 SET NC("FAMILY")=$$CLEANC^XLFNAME($GET(ARRAY("SURNAME")))
+14 SET NC("GIVEN")=$$CLEANC^XLFNAME($GET(ARRAY("FIRST")))
+15 SET NC("MIDDLE")=$$CLEANC^XLFNAME($GET(ARRAY("MIDDLE")))
+16 SET NC("SUFFIX")=$$CLEANC^XLFNAME($GET(ARRAY("SUFFIX")))
+17 ;
+18 ;Build a full name, maximum length LEN
+19 QUIT $$NAMEFMT^XLFNAME(.NC,"F","CL"_LEN)
+20 ;
