DGRNCVNC ;HDSO/RTW - Run Patient Name Standardization ; 25 OCT 2023 10:21
;;5.3;Registration;**1107**;Aug 13, 1993;Build 29
;DG RUN FILE 2 NAME COMPONENT POINTER TO VA(20, NAME COMPONENT FILE
;ADAPTED FROM DG53244U PATCH DG*5.3*620
;ICR#: 3065 API: $$NAMEFMT^XLFNAME()
;ICR#: 2701 $$GETICN^MPIF001
;ICR#: 3765 $$A31^MPIFA31B
;ICR#: 10103 $$FMADD^XLFDT
Q ;NO DIRECT ENTRY
EN ;
S DGFLAG="P",DGNMSP="DPTNAME"
S DGFIL=2
D DIRHL7 Q:X["N"!(X["n")!(X["^") ;ONLY ASKS IF FILERS ARE SHUT DOWN.
D RUN(DGFLAG)
D LOOP
D RESULTS
I '$D(^XTMP("UPDATE")) D Q
. W !!,"No Patient records found requiring the PATIENT NAME COMPONENT UPDATE",!!
. W !,"****Warning ensure you restart the filers. Use the Monitor, Start, Stop Filers [HL FILER MONITOR] option to properly restart to avoid errors while editing the patient file****",!!
D DIR ;IF YES DO LOOP2 AND PROCESSES ALL.
W !!,"****Warning ensure you restart the filers.",!!," Use the Monitor, Start, Stop Filers [HL FILER MONITOR] option to properly restart to avoid errors while editing the patient file****",!!
K DGXRARY,DGFIELD
Q
DIRHL7 ;
;
N DIROUT,DIRUT,DTOUT,DUOUT,DGNMSP,Y
S DIR(0)="YAO"
S DIR("A")="Are the HL7 filers shut down "
S DIR("A",1)=""
S DIR("A",2)="****Use the Monitor, Start, Stop Filers [HL FILER MONITOR] option"
S DIR("A",3)="to properly shut down to avoid errors while editing the patient file****"
S DIR("A",4)=""
S DIR("A",5)=" A ""NO"" answer will stop the Name Component restoration process."
S DIR("A",6)=" Answer YES OR NO OR '^' TO EXIT "
S DIR("A",7)=""
S DIR("B")="NO" D ^DIR I Y'>0!($G(DTOUT))!($D(DUOUT))!($D(DIROUT))!($D(DIRUT)) K DIR Q
I Y=0 Q
Q
RUN(DGFLAG) ;Convert PATIENT file names;
;[ "P" : Kill ^XTMP, update names, generate global
;
N DGA,DGET,DGI,DGFILE,DGENUPLD,DGNOFDEL,DGPRUN,DGOUT,DGQ,DGY,VAFCA08,VAFCNO,VAFHCA08
K ^XTMP(DGNMSP)
I '$D(^XTMP(DGNMSP,"STATS")) D
.S $P(^XTMP(DGNMSP,"STATS",2,.01),U,7)="Patient name"
.S $P(^XTMP(DGNMSP,"STATS",2,.211),U,7)="Primary NOK name"
.S $P(^XTMP(DGNMSP,"STATS",2,.2191),U,7)="Secondary NOK name"
.S $P(^XTMP(DGNMSP,"STATS",2,.2401),U,7)="Father's name"
.S $P(^XTMP(DGNMSP,"STATS",2,.2402),U,7)="Mother's name"
.S $P(^XTMP(DGNMSP,"STATS",2,.2403),U,7)="Mother's maiden name"
.S $P(^XTMP(DGNMSP,"STATS",2,.331),U,7)="Prim. E-contact name"
.S $P(^XTMP(DGNMSP,"STATS",2,.3311),U,7)="2nd E-contact name"
.S $P(^XTMP(DGNMSP,"STATS",2,.341),U,7)="Designee name"
.S $P(^XTMP(DGNMSP,"STATS",2.01,.01),U,7)="Alias name"
.S $P(^XTMP(DGNMSP,"STATS",2.101,30),U,7)="Attorney's name"
;Initialize variables
S DGQ="""",DGOUT=0
F DGI=1:1 S DGA=$T(FIELD+DGI) Q:(DGA'[";;") D
.S DGFIELD(DGI,$P($P(DGA,";;",2),U,3))=$P(DGA,";;",2) Q
D XRARY
S DGFILE=0
F S DGFILE=$O(^XTMP(DGNMSP,"STATS",DGFILE)) Q:'DGFILE!DGOUT D
.S (DGFLD,DGET)=0
.F S DGFLD=$O(^XTMP(DGNMSP,"STATS",DGFILE,DGFLD)) Q:'DGFLD!DGOUT D
..S DGY=^XTMP(DGNMSP,"STATS",DGFILE,DGFLD),DGX=DGFILE_","_DGFLD
..S $E(DGX,10)=$P(DGY,U,7),$E(DGX,30)=$J(+$P(DGY,U),9,0)
..S $E(DGX,41)=$J(+$P(DGY,U,2),7,0),$E(DGX,50)=$J(+$P(DGY,U,3),6,0)
..S $E(DGX,58)=$J(+$P(DGY,U,4),6,0),$E(DGX,66)=$J(+$P(DGY,U,5),6,0)
..S $E(DGX,74)=$J(+$P(DGY,U,6),6,0),DGET=DGET+$P(DGY,U)
;Set up ^XTMP
I '$G(^XTMP(DGNMSP,0,0)) D
.S ^XTMP(DGNMSP,0)=$$FMADD^XLFDT(DT,90)_"^"_DT
.I DGFLAG="P" D
..S ^XTMP(DGNMSP,0,0)=$$NOW^XLFDT(),$P(^XTMP(DGNMSP,0),U,4)=0
..S $P(^XTMP(DGNMSP,0),U,3)="Perform Name Conversion"
..Q
I DGFLAG="P" D
.S $P(^XTMP(DGNMSP,0),U)=$$FMADD^XLFDT(DT,90)
.S $P(^XTMP(DGNMSP,0),U,5)="RUN"
.S DGPRUN=$O(^XTMP(DGNMSP,0,""),-1)+1
.S ^XTMP(DGNMSP,0,DGPRUN)=$$NOW^XLFDT()_"^^"_+$P($G(^XTMP(DGNMSP,"STATS")),U)
.Q
;
;Prevent messages to HEC
S DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
S VAFCNO=1 ;Prevent MPI messages
S (VAFCA08,VAFHCA08)=1 ;Prevent PIMS Generic Messaging
S DGNOFDEL=1 ;Prevent deletion of contact address fields
;
Q
LOOP ;Loop through Patient file
N DGNAME,DGNAMEC,DGCNT
K ^XTMP("UPDATE"),^XTMP("RESULTS")
S DGDFN=+$P(^XTMP(DGNMSP,0),U,4)
S DGCNT=1
S ^XTMP("RESULTS",0)=$$FMADD^XLFDT(DT,180)_"^"_DT
S ^XTMP("RESULTS",DGCNT)="VALID FINDINGS THAT REQUIRE PATIENT NAME COMPONENT UPDATE",DGCNT=DGCNT+1
S ^XTMP("RESULTS",DGCNT)=" DGDFN "_"PATIENT NAME",DGCNT=DGCNT+1
S ^XTMP("RESULTS",DGCNT)="",DGCNT=DGCNT+1
S ^XTMP("RESULTS",DGCNT)="No Patient records found requiring the PATIENT NAME COMPONENT UPDATE"
F S DGDFN=$O(^DPT(DGDFN)) Q:'DGDFN D
. Q:'$D(^DPT(DGDFN,0))
. S DGNAME=$P(^DPT(DGDFN,0),U)
.;Skip merging patients
.Q:$P($G(^DPT(DGDFN,0)),U)["MERGING INTO"
.;Skip patients that have been merged to another record
.Q:$D(^DPT(DGDFN,-9))
.;Evaluate field values
. I $D(^DPT(DGDFN,"NAME")) D
. . I '$P(^DPT(DGDFN,"NAME"),U,1) D
. . . S ^XTMP("UPDATE",DGDFN)=DGNAME,^XTMP("RESULTS",DGCNT)=DGDFN_"^"_DGNAME,DGCNT=DGCNT+1
Q
DIR ;
N DIROUT,DIRUT,DTOUT,DUOUT,DGNMSP,Y
S DGNMSP="DPTNAME"
S DIR(0)="YAO"
S DIR("?")="Answering yes restores Missing Name Components in the patient file"
S DIR("?",1)=""
S DIR("?",2)="****Warning the process updates missing PATIENT File name component"
S DIR("?",3)=" entries and re-indexes existing name component entries"
S DIR("?",4)=" in the patient file****"
S DIR("?",5)=""
S DIR("?",6)=""
S DIR("A")="Are prepared to restore Patient file Name Components: "
S DIR("A",1)=""
S DIR("A",2)="Have you reviewed the Missing Name Components Message ?"
S DIR("A",3)=""
S DIR("A",4)=""
S DIR("A",5)="!!!Enter ""?"" for more information, and ""^"" to EXIT"
S DIR("A",6)=""
S DIR("B")="NO" D ^DIR I Y'>0!($G(DTOUT))!($D(DUOUT))!($D(DIROUT))!($D(DIRUT)) K DIR Q
I Y=0 Q
I Y=1 S DGFLAG="P",DGFIL=2 I Y=1 S DGFLAG="P" W !!,"The ""Missing Name Components"" message can be found in your mailman messages" D LOOP2
D CONFIRM
Q
LOOP2 ;
N DGTYPE,DPTFIL,FPTFLD,DPTI,DPTFLD,DPTIENS,DPTINV,DPTVALUE
S DGDFN=7
F S DGDFN=$O(^XTMP("UPDATE",DGDFN)) Q:'DGDFN D
.S DGIENS=DGDFN_",",DGMPI=0
.S DGZ=0 F S DGZ=$O(DGFIELD(DGZ)) Q:'DGZ D
..S DPTA="" F S DPTA=$O(DGFIELD(DGZ,DPTA)) Q:DPTA="" D
...Q:'$D(^DPT(DGDFN,$P(DPTA,";")))
...S DGTYPE=DGFIELD(DGZ,DPTA),DPTFLD=$P(DGTYPE,U,2)
...S DPTMAX=$P(DGTYPE,U,5) S:'DPTMAX DPTMAX=35
...I $L(DPTA,";")=3 D Q
....F DPTI=0:0 S DPTI=$O(^DPT(DGDFN,$P(DPTA,";"),DPTI)) Q:'DPTI D
.....S DPTIENS=DGDFN_","_DPTI_",",DPTFIL=$P(DGTYPE,U,6)
.....S DPTVALUE=$P($G(^DPT(DGDFN,$P(DPTA,";"),DPTI,$P(DPTA,";",2))),U,$P(DPTA,";",3))
.....Q:'$L(DPTVALUE)
.....D UPDATE(DGFLAG,DPTFIL,DPTIENS,DPTFLD,DPTVALUE,DGNMSP,DPTMAX,DPTA)
...S DPTIENS=DGDFN_",",DPTFIL=2
...S DPTVALUE=$P($G(^DPT(DGDFN,$P(DPTA,";"))),U,$P(DPTA,";",2))
...Q:'$L(DPTVALUE)
...D UPDATE(DGFLAG,DPTFIL,DPTIENS,DPTFLD,DPTVALUE,DGNMSP,DPTMAX,DPTA,.DGMPI)
..S $P(^XTMP(DGNMSP,0),U,4)=DGDFN
Q
;
UPDATE(DGFLAG,DGFIL,DGIENS,DGFLD,DGNAM,DGNMSP,DPTMAX,DPTA,DGMPI) ;Process name field
;
N DGAUD,DGFDA,DGMSG,DIERR,DGOLD,DGTINV
;Total names evaluated
S $P(^XTMP(DGNMSP,"STATS"),U)=$P($G(^XTMP(DGNMSP,"STATS")),U)+1
;Total evaluated by field
S $P(^XTMP(DGNMSP,"STATS",DGFIL,DGFLD),U)=$P($G(^XTMP(DGNMSP,"STATS",DGFIL,DGFLD)),U)+1
;Format name
S DGOLD=$G(DGNAM)
S DGNAM=$$FORMAT^XLFNAME7(.DGNAM,3,DPTMAX,,2,.DGAUD,$S(DGFLD=.2403:1,1:0))
Q:$P(^DPT(DGDFN,0),U)["ERROR"
D:(DGAUD'=0) RECORD(DGFIL,DGFLD,DGIENS,DGNAM,.DGAUD,DGNMSP,DGDFN,DGOLD)
Q:DGFLAG'="P" ;Processing only
Q:DGAUD=2 ;Unconvertible
;Update components if name is not changed
I DGAUD=0 D Q
.N DGI,DA,X,DG20NAME,XUNOTRIG
.F DGI=2.1,1.1 D
..S:(DGFIL=2) DA=DGDFN S:(DGFIL'=2) DA(1)=DGDFN,DA=$P(DGIENS,",",2)
..S X=DGNAM X DGXRARY($P(DGFIELD(DGZ,DPTA),U,7),DGI)
..Q
.Q
;Update source name if different
S DPTINV=$TR($$INV(DGIENS),":",",")_","
S DGFDA(DGFIL,DPTINV,DGFLD)=DGNAM
D FILE^DIE("","DGFDA","DGMSG") K DIERR,DGMSG
;Changes of interest to MPI
I DGAUD=1,DGFIL=2 D
.I DGFLD=.01 S DGMPI=1
.I DGFLD=.2403,DGOLD_","'=DGNAM S DGMPI=1
Q
;
RECORD(DGFIL,DGFLD,DGREC,DGNAM,DGAUD,DGNMSP,DGDFN,DGOLD) ;file changes in ^XTMP
;^XTMP global format:
;^XTMP(DGNMSP,0)=purge_date^date_created^process^last_ien^
;stop_flag^name_change_mail_group
;^XTMP(DGNMSP,0,0)=conversion_start^conversion_end
;^XTMP(DGNMSP,0,n)=conversion_start^conversion_end^
;pts_evaluated_start^pts_evaluated_end
;^XTMP(DGNMSP,DFN,FILE,IFN,FIELD)=old_value^new_value^change_types
;^XTMP(DGNMSP,DFN,"MPI")=1^1^1^1^1^1 (status of MPI messaging)
;^XTMP(DGNMSP,DFN,"MPI","A31")=the result of call to $$A31^MPIFA31B
;^XTMP(DGNMSP,"STATS")=names_evaluated^pts_w/changes^total_changes^
;type1_changes^type2_changes^type3_changes^
;type4_changes
;^XTMP(DGNMSP,"STATS",FILE,FIELD)=total_evaluated^total_changed^
;type1_changes^type2_changes^
;type3_changes^type4_changes
;^XTMP(DGNMSP,"B",NAME)=dfn
;
;Data change types: 1=name contains no comma
;2=parenthetical text is removed
;3=value could not be converted
;4=characters are removed or changed
;
N DGIENS,DGIEN2,DGTSTR,DGI,DGN S DGTSTR=""
S DGIEN2=$S($P(DGREC,",",2):$P(DGREC,",",2),1:DGDFN)
;Record values
F DGI=1:1:4 I $D(DGAUD(DGI)) D
.S DGTSTR=DGTSTR_DGI
.;Field changes by type
.S $P(^XTMP(DGNMSP,"STATS",DGFIL,DGFLD),U,(DGI+2))=$P($G(^XTMP(DGNMSP,"STATS",DGFIL,DGFLD)),U,(DGI+2))+1
.;Total changes by type
.S $P(^XTMP(DGNMSP,"STATS"),U,(DGI+3))=$P($G(^XTMP(DGNMSP,"STATS")),U,(DGI+3))+1
.Q
;Total patients with changes
I '$D(^XTMP(DGNMSP,DGDFN)) S $P(^XTMP(DGNMSP,"STATS"),U,2)=$P($G(^XTMP(DGNMSP,"STATS")),U,2)+1
;Total fields with changes
S $P(^XTMP(DGNMSP,"STATS"),U,3)=$P($G(^XTMP(DGNMSP,"STATS")),U,3)+1
;Total changes by field
S $P(^XTMP(DGNMSP,"STATS",DGFIL,DGFLD),U,2)=$P($G(^XTMP(DGNMSP,"STATS",DGFIL,DGFLD)),U,2)+1
;PATIENT field name change and types
S ^XTMP(DGNMSP,DGDFN,DGFIL,DGIEN2,DGFLD)=DGOLD_U_DGNAM_U_DGTSTR
;Name x-ref
S DGN=$P($G(^DPT(DGDFN,0)),U) S:DGN="" DGN=" "
S ^XTMP(DGNMSP,"B",DGN,DGDFN)=""
Q
;
INV(DGIENS) ;Invert the IENS CALL FROM UPDATE
N DGI,DGX
Q:DGIENS?."," ""
S:DGIENS'?.E1"," DGIENS=DGIENS_","
S DGX="" F DGI=$L(DGIENS,",")-1:-1:1 S DGX=DGX_$P(DGIENS,",",DGI)_":"
S:DGX?.E1":" DGX=$E(DGX,1,$L(DGX)-1)
Q DGX
;
FIELD ;;
;;NAME^.01^0;1^1.01^30^^ANAM01
;;K-NAME^.211^.21;1^1.02^^^ANAM211
;;K2-NAME^.2191^.211;1^1.03^^^ANAM2191
;;FATHER'S NAME^.2401^.24;1^1.04^^^ANAM2401
;;MOTHER'S NAME^.2402^.24;2^1.05^^^ANAM2402
;;MOTHER'S MAIDEN^.2403^.24;3^1.06^^^ANAM2403
;;E-NAME^.331^.33;1^1.07^^^ANAM331
;;E2-NAME^.3311^.331;1^1.08^^^ANAM3311
;;D NAME^.341^.34;1^1.09^^^ANAM341
;;ALIAS^.01^.01;0;1^100.03^30^2.01^ANAM201
;;ATTORNEY^30^DIS;3;1^100.21^30^2.101^ANAM1001
XRARY ;Gather xref kills and sets
N DGI,DGII,DGDFN,DGVAL,DGDATA,DGZ
S DGI="",DGVAL(1)=2,DGZ=0
F S DGZ=$O(DGFIELD(DGZ)) Q:'DGZ D
.F S DGI=$O(DGFIELD(DGZ,DGI)) Q:DGI="" D
..S DGVAL(2)=$P(DGFIELD(DGZ,DGI),U,7)
..D FIND^DIC(.11,"","@;IXIE","KP",.DGVAL,"","","","","DGDATA")
..S DGDFN=+DGDATA("DILIST",1,0)_"," K DGDATA
..D GETS^DIQ(.11,DGDFN,"1.1;2.1","","DGDATA")
..F DGII=1.1,2.1 S DGXRARY(DGVAL(2),DGII)=DGDATA(.11,DGDFN,DGII)
..Q
.Q
Q
CONFIRM ; SEND A CONFIRMATION MAILMAN MESSAGE
S DGDFN=0
K ^XTMP("CONFIRM")
I $D(^XTMP("UPDATE")) W !!,"The Name Component restore results was sent to your mailman acct.",!
S ^XTMP("CONFIRM",0)=$$FMADD^XLFDT(DT,180)_"^"_DT
F S DGDFN=$O(^XTMP("UPDATE",DGDFN)) Q:'DGDFN D
. S DGNAME=$P(^XTMP("UPDATE",DGDFN),U)
. S DGNAMEC=$G(^DPT(DGDFN,"NAME"))
. S ^XTMP("CONFIRM",DGDFN)="^DPT("_DGDFN_",""NAME""""="_DGNAMEC
S XMDUZ=DUZ
S XMSUBJ="Restored Name Components"
S XMBODY="^XTMP(""CONFIRM"")"
S XMTO(DUZ)=""
S XMINSTR("FLAGS")="P"
S (XMZ,XMATTACH)=""
D SENDMSG(.XMDUZ,.XMSUBJ,.XMBODY,.XMTO,.XMINSTR,.XMZ,.XMATTACH)
Q
RESULTS ;
;W !!," The Missing Name Components message was sent to your mailman acct."
I $D(^XTMP("UPDATE")) W !," Please review the findings",!
S XMDUZ=DUZ
S XMSUBJ="Missing Name Components"
S XMBODY="^XTMP(""RESULTS"")"
S XMTO(DUZ)=""
S XMINSTR("FLAGS")="P"
S (XMZ,XMATTACH)=""
D SENDMSG(.XMDUZ,.XMSUBJ,.XMBODY,.XMTO,.XMINSTR,.XMZ,.XMATTACH)
Q
SENDMSG(XMDUZ,XMSUBJ,XMBODY,XMTO,XMINSTR,XMZ,XMATTACH) ; Send a msg
; In: User, basket (if you are recipient), all msg parts,
; priority?, closed?, (info?,cc?), send now or later (when?),
; (KIDS,MIME,text,PackMan), delete date (if to shared,mail)
; XMINSTR("RCPT BSKT")
N DIERR,XMERR ; ADDED IN PATCH XM*8.0*41 JDG
I '$D(XMV) N XMV,XMDISPI,XMDUN,XMNOSEND,XMPRIV
; ** XM*8*47 Adds code to automatically truncate subject line if too long or concatenate if too short. **
I $L(XMSUBJ)<3,XMSUBJ'="" S XMSUBJ=XMSUBJ_"..."
I $L(XMSUBJ)>65 S XMSUBJ=$E(XMSUBJ,1,65)
D SENDMSG^XMXPARM(.XMDUZ,.XMSUBJ,.XMBODY,.XMTO,.XMINSTR,.XMATTACH) Q:$D(XMERR)
D SENDMSG^XMXSEND(XMDUZ,XMSUBJ,XMBODY,.XMTO,.XMINSTR,.XMZ,.XMATTACH)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRNCVNC 12967 printed Sep 15, 2024@22:19:07 Page 2
DGRNCVNC ;HDSO/RTW - Run Patient Name Standardization ; 25 OCT 2023 10:21
+1 ;;5.3;Registration;**1107**;Aug 13, 1993;Build 29
+2 ;DG RUN FILE 2 NAME COMPONENT POINTER TO VA(20, NAME COMPONENT FILE
+3 ;ADAPTED FROM DG53244U PATCH DG*5.3*620
+4 ;ICR#: 3065 API: $$NAMEFMT^XLFNAME()
+5 ;ICR#: 2701 $$GETICN^MPIF001
+6 ;ICR#: 3765 $$A31^MPIFA31B
+7 ;ICR#: 10103 $$FMADD^XLFDT
+8 ;NO DIRECT ENTRY
QUIT
EN ;
+1 SET DGFLAG="P"
SET DGNMSP="DPTNAME"
+2 SET DGFIL=2
+3 ;ONLY ASKS IF FILERS ARE SHUT DOWN.
DO DIRHL7
if X["N"!(X["n")!(X["^")
QUIT
+4 DO RUN(DGFLAG)
+5 DO LOOP
+6 DO RESULTS
+7 IF '$DATA(^XTMP("UPDATE"))
Begin DoDot:1
+8 WRITE !!,"No Patient records found requiring the PATIENT NAME COMPONENT UPDATE",!!
+9 WRITE !,"****Warning ensure you restart the filers. Use the Monitor, Start, Stop Filers [HL FILER MONITOR] option to properly restart to avoid errors while editing the patient file****",!!
End DoDot:1
QUIT
+10 ;IF YES DO LOOP2 AND PROCESSES ALL.
DO DIR
+11 WRITE !!,"****Warning ensure you restart the filers.",!!," Use the Monitor, Start, Stop Filers [HL FILER MONITOR] option to properly restart to avoid errors while editing the patient file****",!!
+12 KILL DGXRARY,DGFIELD
+13 QUIT
DIRHL7 ;
+1 ;
+2 NEW DIROUT,DIRUT,DTOUT,DUOUT,DGNMSP,Y
+3 SET DIR(0)="YAO"
+4 SET DIR("A")="Are the HL7 filers shut down "
+5 SET DIR("A",1)=""
+6 SET DIR("A",2)="****Use the Monitor, Start, Stop Filers [HL FILER MONITOR] option"
+7 SET DIR("A",3)="to properly shut down to avoid errors while editing the patient file****"
+8 SET DIR("A",4)=""
+9 SET DIR("A",5)=" A ""NO"" answer will stop the Name Component restoration process."
+10 SET DIR("A",6)=" Answer YES OR NO OR '^' TO EXIT "
+11 SET DIR("A",7)=""
+12 SET DIR("B")="NO"
DO ^DIR
IF Y'>0!($GET(DTOUT))!($DATA(DUOUT))!($DATA(DIROUT))!($DATA(DIRUT))
KILL DIR
QUIT
+13 IF Y=0
QUIT
+14 QUIT
RUN(DGFLAG) ;Convert PATIENT file names;
+1 ;[ "P" : Kill ^XTMP, update names, generate global
+2 ;
+3 NEW DGA,DGET,DGI,DGFILE,DGENUPLD,DGNOFDEL,DGPRUN,DGOUT,DGQ,DGY,VAFCA08,VAFCNO,VAFHCA08
+4 KILL ^XTMP(DGNMSP)
+5 IF '$DATA(^XTMP(DGNMSP,"STATS"))
Begin DoDot:1
+6 SET $PIECE(^XTMP(DGNMSP,"STATS",2,.01),U,7)="Patient name"
+7 SET $PIECE(^XTMP(DGNMSP,"STATS",2,.211),U,7)="Primary NOK name"
+8 SET $PIECE(^XTMP(DGNMSP,"STATS",2,.2191),U,7)="Secondary NOK name"
+9 SET $PIECE(^XTMP(DGNMSP,"STATS",2,.2401),U,7)="Father's name"
+10 SET $PIECE(^XTMP(DGNMSP,"STATS",2,.2402),U,7)="Mother's name"
+11 SET $PIECE(^XTMP(DGNMSP,"STATS",2,.2403),U,7)="Mother's maiden name"
+12 SET $PIECE(^XTMP(DGNMSP,"STATS",2,.331),U,7)="Prim. E-contact name"
+13 SET $PIECE(^XTMP(DGNMSP,"STATS",2,.3311),U,7)="2nd E-contact name"
+14 SET $PIECE(^XTMP(DGNMSP,"STATS",2,.341),U,7)="Designee name"
+15 SET $PIECE(^XTMP(DGNMSP,"STATS",2.01,.01),U,7)="Alias name"
+16 SET $PIECE(^XTMP(DGNMSP,"STATS",2.101,30),U,7)="Attorney's name"
End DoDot:1
+17 ;Initialize variables
+18 SET DGQ=""""
SET DGOUT=0
+19 FOR DGI=1:1
SET DGA=$TEXT(FIELD+DGI)
if (DGA'[";;")
QUIT
Begin DoDot:1
+20 SET DGFIELD(DGI,$PIECE($PIECE(DGA,";;",2),U,3))=$PIECE(DGA,";;",2)
QUIT
End DoDot:1
+21 DO XRARY
+22 SET DGFILE=0
+23 FOR
SET DGFILE=$ORDER(^XTMP(DGNMSP,"STATS",DGFILE))
if 'DGFILE!DGOUT
QUIT
Begin DoDot:1
+24 SET (DGFLD,DGET)=0
+25 FOR
SET DGFLD=$ORDER(^XTMP(DGNMSP,"STATS",DGFILE,DGFLD))
if 'DGFLD!DGOUT
QUIT
Begin DoDot:2
+26 SET DGY=^XTMP(DGNMSP,"STATS",DGFILE,DGFLD)
SET DGX=DGFILE_","_DGFLD
+27 SET $EXTRACT(DGX,10)=$PIECE(DGY,U,7)
SET $EXTRACT(DGX,30)=$JUSTIFY(+$PIECE(DGY,U),9,0)
+28 SET $EXTRACT(DGX,41)=$JUSTIFY(+$PIECE(DGY,U,2),7,0)
SET $EXTRACT(DGX,50)=$JUSTIFY(+$PIECE(DGY,U,3),6,0)
+29 SET $EXTRACT(DGX,58)=$JUSTIFY(+$PIECE(DGY,U,4),6,0)
SET $EXTRACT(DGX,66)=$JUSTIFY(+$PIECE(DGY,U,5),6,0)
+30 SET $EXTRACT(DGX,74)=$JUSTIFY(+$PIECE(DGY,U,6),6,0)
SET DGET=DGET+$PIECE(DGY,U)
End DoDot:2
End DoDot:1
+31 ;Set up ^XTMP
+32 IF '$GET(^XTMP(DGNMSP,0,0))
Begin DoDot:1
+33 SET ^XTMP(DGNMSP,0)=$$FMADD^XLFDT(DT,90)_"^"_DT
+34 IF DGFLAG="P"
Begin DoDot:2
+35 SET ^XTMP(DGNMSP,0,0)=$$NOW^XLFDT()
SET $PIECE(^XTMP(DGNMSP,0),U,4)=0
+36 SET $PIECE(^XTMP(DGNMSP,0),U,3)="Perform Name Conversion"
+37 QUIT
End DoDot:2
End DoDot:1
+38 IF DGFLAG="P"
Begin DoDot:1
+39 SET $PIECE(^XTMP(DGNMSP,0),U)=$$FMADD^XLFDT(DT,90)
+40 SET $PIECE(^XTMP(DGNMSP,0),U,5)="RUN"
+41 SET DGPRUN=$ORDER(^XTMP(DGNMSP,0,""),-1)+1
+42 SET ^XTMP(DGNMSP,0,DGPRUN)=$$NOW^XLFDT()_"^^"_+$PIECE($GET(^XTMP(DGNMSP,"STATS")),U)
+43 QUIT
End DoDot:1
+44 ;
+45 ;Prevent messages to HEC
+46 SET DGENUPLD="ENROLLMENT/ELIGIBILITY UPLOAD IN PROGRESS"
+47 ;Prevent MPI messages
SET VAFCNO=1
+48 ;Prevent PIMS Generic Messaging
SET (VAFCA08,VAFHCA08)=1
+49 ;Prevent deletion of contact address fields
SET DGNOFDEL=1
+50 ;
+51 QUIT
LOOP ;Loop through Patient file
+1 NEW DGNAME,DGNAMEC,DGCNT
+2 KILL ^XTMP("UPDATE"),^XTMP("RESULTS")
+3 SET DGDFN=+$PIECE(^XTMP(DGNMSP,0),U,4)
+4 SET DGCNT=1
+5 SET ^XTMP("RESULTS",0)=$$FMADD^XLFDT(DT,180)_"^"_DT
+6 SET ^XTMP("RESULTS",DGCNT)="VALID FINDINGS THAT REQUIRE PATIENT NAME COMPONENT UPDATE"
SET DGCNT=DGCNT+1
+7 SET ^XTMP("RESULTS",DGCNT)=" DGDFN "_"PATIENT NAME"
SET DGCNT=DGCNT+1
+8 SET ^XTMP("RESULTS",DGCNT)=""
SET DGCNT=DGCNT+1
+9 SET ^XTMP("RESULTS",DGCNT)="No Patient records found requiring the PATIENT NAME COMPONENT UPDATE"
+10 FOR
SET DGDFN=$ORDER(^DPT(DGDFN))
if 'DGDFN
QUIT
Begin DoDot:1
+11 if '$DATA(^DPT(DGDFN,0))
QUIT
+12 SET DGNAME=$PIECE(^DPT(DGDFN,0),U)
+13 ;Skip merging patients
+14 if $PIECE($GET(^DPT(DGDFN,0)),U)["MERGING INTO"
QUIT
+15 ;Skip patients that have been merged to another record
+16 if $DATA(^DPT(DGDFN,-9))
QUIT
+17 ;Evaluate field values
+18 IF $DATA(^DPT(DGDFN,"NAME"))
Begin DoDot:2
+19 IF '$PIECE(^DPT(DGDFN,"NAME"),U,1)
Begin DoDot:3
+20 SET ^XTMP("UPDATE",DGDFN)=DGNAME
SET ^XTMP("RESULTS",DGCNT)=DGDFN_"^"_DGNAME
SET DGCNT=DGCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
DIR ;
+1 NEW DIROUT,DIRUT,DTOUT,DUOUT,DGNMSP,Y
+2 SET DGNMSP="DPTNAME"
+3 SET DIR(0)="YAO"
+4 SET DIR("?")="Answering yes restores Missing Name Components in the patient file"
+5 SET DIR("?",1)=""
+6 SET DIR("?",2)="****Warning the process updates missing PATIENT File name component"
+7 SET DIR("?",3)=" entries and re-indexes existing name component entries"
+8 SET DIR("?",4)=" in the patient file****"
+9 SET DIR("?",5)=""
+10 SET DIR("?",6)=""
+11 SET DIR("A")="Are prepared to restore Patient file Name Components: "
+12 SET DIR("A",1)=""
+13 SET DIR("A",2)="Have you reviewed the Missing Name Components Message ?"
+14 SET DIR("A",3)=""
+15 SET DIR("A",4)=""
+16 SET DIR("A",5)="!!!Enter ""?"" for more information, and ""^"" to EXIT"
+17 SET DIR("A",6)=""
+18 SET DIR("B")="NO"
DO ^DIR
IF Y'>0!($GET(DTOUT))!($DATA(DUOUT))!($DATA(DIROUT))!($DATA(DIRUT))
KILL DIR
QUIT
+19 IF Y=0
QUIT
+20 IF Y=1
SET DGFLAG="P"
SET DGFIL=2
IF Y=1
SET DGFLAG="P"
WRITE !!,"The ""Missing Name Components"" message can be found in your mailman messages"
DO LOOP2
+21 DO CONFIRM
+22 QUIT
LOOP2 ;
+1 NEW DGTYPE,DPTFIL,FPTFLD,DPTI,DPTFLD,DPTIENS,DPTINV,DPTVALUE
+2 SET DGDFN=7
+3 FOR
SET DGDFN=$ORDER(^XTMP("UPDATE",DGDFN))
if 'DGDFN
QUIT
Begin DoDot:1
+4 SET DGIENS=DGDFN_","
SET DGMPI=0
+5 SET DGZ=0
FOR
SET DGZ=$ORDER(DGFIELD(DGZ))
if 'DGZ
QUIT
Begin DoDot:2
+6 SET DPTA=""
FOR
SET DPTA=$ORDER(DGFIELD(DGZ,DPTA))
if DPTA=""
QUIT
Begin DoDot:3
+7 if '$DATA(^DPT(DGDFN,$PIECE(DPTA,";")))
QUIT
+8 SET DGTYPE=DGFIELD(DGZ,DPTA)
SET DPTFLD=$PIECE(DGTYPE,U,2)
+9 SET DPTMAX=$PIECE(DGTYPE,U,5)
if 'DPTMAX
SET DPTMAX=35
+10 IF $LENGTH(DPTA,";")=3
Begin DoDot:4
+11 FOR DPTI=0:0
SET DPTI=$ORDER(^DPT(DGDFN,$PIECE(DPTA,";"),DPTI))
if 'DPTI
QUIT
Begin DoDot:5
+12 SET DPTIENS=DGDFN_","_DPTI_","
SET DPTFIL=$PIECE(DGTYPE,U,6)
+13 SET DPTVALUE=$PIECE($GET(^DPT(DGDFN,$PIECE(DPTA,";"),DPTI,$PIECE(DPTA,";",2))),U,$PIECE(DPTA,";",3))
+14 if '$LENGTH(DPTVALUE)
QUIT
+15 DO UPDATE(DGFLAG,DPTFIL,DPTIENS,DPTFLD,DPTVALUE,DGNMSP,DPTMAX,DPTA)
End DoDot:5
End DoDot:4
QUIT
+16 SET DPTIENS=DGDFN_","
SET DPTFIL=2
+17 SET DPTVALUE=$PIECE($GET(^DPT(DGDFN,$PIECE(DPTA,";"))),U,$PIECE(DPTA,";",2))
+18 if '$LENGTH(DPTVALUE)
QUIT
+19 DO UPDATE(DGFLAG,DPTFIL,DPTIENS,DPTFLD,DPTVALUE,DGNMSP,DPTMAX,DPTA,.DGMPI)
End DoDot:3
+20 SET $PIECE(^XTMP(DGNMSP,0),U,4)=DGDFN
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
UPDATE(DGFLAG,DGFIL,DGIENS,DGFLD,DGNAM,DGNMSP,DPTMAX,DPTA,DGMPI) ;Process name field
+1 ;
+2 NEW DGAUD,DGFDA,DGMSG,DIERR,DGOLD,DGTINV
+3 ;Total names evaluated
+4 SET $PIECE(^XTMP(DGNMSP,"STATS"),U)=$PIECE($GET(^XTMP(DGNMSP,"STATS")),U)+1
+5 ;Total evaluated by field
+6 SET $PIECE(^XTMP(DGNMSP,"STATS",DGFIL,DGFLD),U)=$PIECE($GET(^XTMP(DGNMSP,"STATS",DGFIL,DGFLD)),U)+1
+7 ;Format name
+8 SET DGOLD=$GET(DGNAM)
+9 SET DGNAM=$$FORMAT^XLFNAME7(.DGNAM,3,DPTMAX,,2,.DGAUD,$SELECT(DGFLD=.2403:1,1:0))
+10 if $PIECE(^DPT(DGDFN,0),U)["ERROR"
QUIT
+11 if (DGAUD'=0)
DO RECORD(DGFIL,DGFLD,DGIENS,DGNAM,.DGAUD,DGNMSP,DGDFN,DGOLD)
+12 ;Processing only
if DGFLAG'="P"
QUIT
+13 ;Unconvertible
if DGAUD=2
QUIT
+14 ;Update components if name is not changed
+15 IF DGAUD=0
Begin DoDot:1
+16 NEW DGI,DA,X,DG20NAME,XUNOTRIG
+17 FOR DGI=2.1,1.1
Begin DoDot:2
+18 if (DGFIL=2)
SET DA=DGDFN
if (DGFIL'=2)
SET DA(1)=DGDFN
SET DA=$PIECE(DGIENS,",",2)
+19 SET X=DGNAM
XECUTE DGXRARY($PIECE(DGFIELD(DGZ,DPTA),U,7),DGI)
+20 QUIT
End DoDot:2
+21 QUIT
End DoDot:1
QUIT
+22 ;Update source name if different
+23 SET DPTINV=$TRANSLATE($$INV(DGIENS),":",",")_","
+24 SET DGFDA(DGFIL,DPTINV,DGFLD)=DGNAM
+25 DO FILE^DIE("","DGFDA","DGMSG")
KILL DIERR,DGMSG
+26 ;Changes of interest to MPI
+27 IF DGAUD=1
IF DGFIL=2
Begin DoDot:1
+28 IF DGFLD=.01
SET DGMPI=1
+29 IF DGFLD=.2403
IF DGOLD_","'=DGNAM
SET DGMPI=1
End DoDot:1
+30 QUIT
+31 ;
RECORD(DGFIL,DGFLD,DGREC,DGNAM,DGAUD,DGNMSP,DGDFN,DGOLD) ;file changes in ^XTMP
+1 ;^XTMP global format:
+2 ;^XTMP(DGNMSP,0)=purge_date^date_created^process^last_ien^
+3 ;stop_flag^name_change_mail_group
+4 ;^XTMP(DGNMSP,0,0)=conversion_start^conversion_end
+5 ;^XTMP(DGNMSP,0,n)=conversion_start^conversion_end^
+6 ;pts_evaluated_start^pts_evaluated_end
+7 ;^XTMP(DGNMSP,DFN,FILE,IFN,FIELD)=old_value^new_value^change_types
+8 ;^XTMP(DGNMSP,DFN,"MPI")=1^1^1^1^1^1 (status of MPI messaging)
+9 ;^XTMP(DGNMSP,DFN,"MPI","A31")=the result of call to $$A31^MPIFA31B
+10 ;^XTMP(DGNMSP,"STATS")=names_evaluated^pts_w/changes^total_changes^
+11 ;type1_changes^type2_changes^type3_changes^
+12 ;type4_changes
+13 ;^XTMP(DGNMSP,"STATS",FILE,FIELD)=total_evaluated^total_changed^
+14 ;type1_changes^type2_changes^
+15 ;type3_changes^type4_changes
+16 ;^XTMP(DGNMSP,"B",NAME)=dfn
+17 ;
+18 ;Data change types: 1=name contains no comma
+19 ;2=parenthetical text is removed
+20 ;3=value could not be converted
+21 ;4=characters are removed or changed
+22 ;
+23 NEW DGIENS,DGIEN2,DGTSTR,DGI,DGN
SET DGTSTR=""
+24 SET DGIEN2=$SELECT($PIECE(DGREC,",",2):$PIECE(DGREC,",",2),1:DGDFN)
+25 ;Record values
+26 FOR DGI=1:1:4
IF $DATA(DGAUD(DGI))
Begin DoDot:1
+27 SET DGTSTR=DGTSTR_DGI
+28 ;Field changes by type
+29 SET $PIECE(^XTMP(DGNMSP,"STATS",DGFIL,DGFLD),U,(DGI+2))=$PIECE($GET(^XTMP(DGNMSP,"STATS",DGFIL,DGFLD)),U,(DGI+2))+1
+30 ;Total changes by type
+31 SET $PIECE(^XTMP(DGNMSP,"STATS"),U,(DGI+3))=$PIECE($GET(^XTMP(DGNMSP,"STATS")),U,(DGI+3))+1
+32 QUIT
End DoDot:1
+33 ;Total patients with changes
+34 IF '$DATA(^XTMP(DGNMSP,DGDFN))
SET $PIECE(^XTMP(DGNMSP,"STATS"),U,2)=$PIECE($GET(^XTMP(DGNMSP,"STATS")),U,2)+1
+35 ;Total fields with changes
+36 SET $PIECE(^XTMP(DGNMSP,"STATS"),U,3)=$PIECE($GET(^XTMP(DGNMSP,"STATS")),U,3)+1
+37 ;Total changes by field
+38 SET $PIECE(^XTMP(DGNMSP,"STATS",DGFIL,DGFLD),U,2)=$PIECE($GET(^XTMP(DGNMSP,"STATS",DGFIL,DGFLD)),U,2)+1
+39 ;PATIENT field name change and types
+40 SET ^XTMP(DGNMSP,DGDFN,DGFIL,DGIEN2,DGFLD)=DGOLD_U_DGNAM_U_DGTSTR
+41 ;Name x-ref
+42 SET DGN=$PIECE($GET(^DPT(DGDFN,0)),U)
if DGN=""
SET DGN=" "
+43 SET ^XTMP(DGNMSP,"B",DGN,DGDFN)=""
+44 QUIT
+45 ;
INV(DGIENS) ;Invert the IENS CALL FROM UPDATE
+1 NEW DGI,DGX
+2 if DGIENS?.","
QUIT ""
+3 if DGIENS'?.E1","
SET DGIENS=DGIENS_","
+4 SET DGX=""
FOR DGI=$LENGTH(DGIENS,",")-1:-1:1
SET DGX=DGX_$PIECE(DGIENS,",",DGI)_":"
+5 if DGX?.E1"
SET DGX=$EXTRACT(DGX,1,$LENGTH(DGX)-1)
+6 QUIT DGX
+7 ;
FIELD ;;
+1 ;;NAME^.01^0;1^1.01^30^^ANAM01
+2 ;;K-NAME^.211^.21;1^1.02^^^ANAM211
+3 ;;K2-NAME^.2191^.211;1^1.03^^^ANAM2191
+4 ;;FATHER'S NAME^.2401^.24;1^1.04^^^ANAM2401
+5 ;;MOTHER'S NAME^.2402^.24;2^1.05^^^ANAM2402
+6 ;;MOTHER'S MAIDEN^.2403^.24;3^1.06^^^ANAM2403
+7 ;;E-NAME^.331^.33;1^1.07^^^ANAM331
+8 ;;E2-NAME^.3311^.331;1^1.08^^^ANAM3311
+9 ;;D NAME^.341^.34;1^1.09^^^ANAM341
+10 ;;ALIAS^.01^.01;0;1^100.03^30^2.01^ANAM201
+11 ;;ATTORNEY^30^DIS;3;1^100.21^30^2.101^ANAM1001
XRARY ;Gather xref kills and sets
+1 NEW DGI,DGII,DGDFN,DGVAL,DGDATA,DGZ
+2 SET DGI=""
SET DGVAL(1)=2
SET DGZ=0
+3 FOR
SET DGZ=$ORDER(DGFIELD(DGZ))
if 'DGZ
QUIT
Begin DoDot:1
+4 FOR
SET DGI=$ORDER(DGFIELD(DGZ,DGI))
if DGI=""
QUIT
Begin DoDot:2
+5 SET DGVAL(2)=$PIECE(DGFIELD(DGZ,DGI),U,7)
+6 DO FIND^DIC(.11,"","@;IXIE","KP",.DGVAL,"","","","","DGDATA")
+7 SET DGDFN=+DGDATA("DILIST",1,0)_","
KILL DGDATA
+8 DO GETS^DIQ(.11,DGDFN,"1.1;2.1","","DGDATA")
+9 FOR DGII=1.1,2.1
SET DGXRARY(DGVAL(2),DGII)=DGDATA(.11,DGDFN,DGII)
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
CONFIRM ; SEND A CONFIRMATION MAILMAN MESSAGE
+1 SET DGDFN=0
+2 KILL ^XTMP("CONFIRM")
+3 IF $DATA(^XTMP("UPDATE"))
WRITE !!,"The Name Component restore results was sent to your mailman acct.",!
+4 SET ^XTMP("CONFIRM",0)=$$FMADD^XLFDT(DT,180)_"^"_DT
+5 FOR
SET DGDFN=$ORDER(^XTMP("UPDATE",DGDFN))
if 'DGDFN
QUIT
Begin DoDot:1
+6 SET DGNAME=$PIECE(^XTMP("UPDATE",DGDFN),U)
+7 SET DGNAMEC=$GET(^DPT(DGDFN,"NAME"))
+8 SET ^XTMP("CONFIRM",DGDFN)="^DPT("_DGDFN_",""NAME""""="_DGNAMEC
End DoDot:1
+9 SET XMDUZ=DUZ
+10 SET XMSUBJ="Restored Name Components"
+11 SET XMBODY="^XTMP(""CONFIRM"")"
+12 SET XMTO(DUZ)=""
+13 SET XMINSTR("FLAGS")="P"
+14 SET (XMZ,XMATTACH)=""
+15 DO SENDMSG(.XMDUZ,.XMSUBJ,.XMBODY,.XMTO,.XMINSTR,.XMZ,.XMATTACH)
+16 QUIT
RESULTS ;
+1 ;W !!," The Missing Name Components message was sent to your mailman acct."
+2 IF $DATA(^XTMP("UPDATE"))
WRITE !," Please review the findings",!
+3 SET XMDUZ=DUZ
+4 SET XMSUBJ="Missing Name Components"
+5 SET XMBODY="^XTMP(""RESULTS"")"
+6 SET XMTO(DUZ)=""
+7 SET XMINSTR("FLAGS")="P"
+8 SET (XMZ,XMATTACH)=""
+9 DO SENDMSG(.XMDUZ,.XMSUBJ,.XMBODY,.XMTO,.XMINSTR,.XMZ,.XMATTACH)
+10 QUIT
SENDMSG(XMDUZ,XMSUBJ,XMBODY,XMTO,XMINSTR,XMZ,XMATTACH) ; Send a msg
+1 ; In: User, basket (if you are recipient), all msg parts,
+2 ; priority?, closed?, (info?,cc?), send now or later (when?),
+3 ; (KIDS,MIME,text,PackMan), delete date (if to shared,mail)
+4 ; XMINSTR("RCPT BSKT")
+5 ; ADDED IN PATCH XM*8.0*41 JDG
NEW DIERR,XMERR
+6 IF '$DATA(XMV)
NEW XMV,XMDISPI,XMDUN,XMNOSEND,XMPRIV
+7 ; ** XM*8*47 Adds code to automatically truncate subject line if too long or concatenate if too short. **
+8 IF $LENGTH(XMSUBJ)<3
IF XMSUBJ'=""
SET XMSUBJ=XMSUBJ_"..."
+9 IF $LENGTH(XMSUBJ)>65
SET XMSUBJ=$EXTRACT(XMSUBJ,1,65)
+10 DO SENDMSG^XMXPARM(.XMDUZ,.XMSUBJ,.XMBODY,.XMTO,.XMINSTR,.XMATTACH)
if $DATA(XMERR)
QUIT
+11 DO SENDMSG^XMXSEND(XMDUZ,XMSUBJ,XMBODY,.XMTO,.XMINSTR,.XMZ,.XMATTACH)
+12 QUIT
