DGRNCVNP ;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#: 10103 $$FMADD^XLFDT
EN ;
S DGNMSP="DPTNAME"
D LOOP
D RESULTS
I '$D(^XTMP("UPDATE")) W !,"No Patient records found requiring the DG NAME COMPONENT UPDATE",!! H 5 Q
H 5
K DGXRARY,DGFIELD,DGNMSP,DGDFN
Q
LOOP ;Loop through Patient file
N DGNAME,DGNAMEC,DGCNT
K ^XTMP("UPDATE"),^XTMP("RESULTS")
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"
S DGDFN=0 F S DGDFN=$O(^DPT(DGDFN)) Q:'DGDFN D
. I $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
RESULTS ;
I $D(^XTMP("UPDATE")) D
. W !!," Records were found, and the Missing Name Components message was sent to your mailman acct."
. W " The DG NAME COMPONENT UPDATE option needs to be run after reviewing 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[HDGRNCVNP 2582 printed Sep 15, 2024@22:19:08 Page 2
DGRNCVNP ;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#: 10103 $$FMADD^XLFDT
EN ;
+1 SET DGNMSP="DPTNAME"
+2 DO LOOP
+3 DO RESULTS
+4 IF '$DATA(^XTMP("UPDATE"))
WRITE !,"No Patient records found requiring the DG NAME COMPONENT UPDATE",!!
HANG 5
QUIT
+5 HANG 5
+6 KILL DGXRARY,DGFIELD,DGNMSP,DGDFN
+7 QUIT
LOOP ;Loop through Patient file
+1 NEW DGNAME,DGNAMEC,DGCNT
+2 KILL ^XTMP("UPDATE"),^XTMP("RESULTS")
+3 SET DGCNT=1
+4 SET ^XTMP("RESULTS",0)=$$FMADD^XLFDT(DT,180)_"^"_DT
+5 SET ^XTMP("RESULTS",DGCNT)="VALID FINDINGS THAT REQUIRE PATIENT NAME COMPONENT UPDATE"
SET DGCNT=DGCNT+1
+6 SET ^XTMP("RESULTS",DGCNT)=" DGDFN "_"PATIENT NAME"
SET DGCNT=DGCNT+1
+7 SET ^XTMP("RESULTS",DGCNT)=""
SET DGCNT=DGCNT+1
+8 SET ^XTMP("RESULTS",DGCNT)="No Patient records found requiring the PATIENT NAME COMPONENT UPDATE"
+9 SET DGDFN=0
FOR
SET DGDFN=$ORDER(^DPT(DGDFN))
if 'DGDFN
QUIT
Begin DoDot:1
+10 IF $DATA(^DPT(DGDFN,0))
SET DGNAME=$PIECE(^DPT(DGDFN,0),U)
+11 ;Skip merging patients
+12 if $PIECE($GET(^DPT(DGDFN,0)),U)["MERGING INTO"
QUIT
+13 ;Skip patients that have been merged to another record
+14 if $DATA(^DPT(DGDFN,-9))
QUIT
+15 ;Evaluate field values
+16 IF $DATA(^DPT(DGDFN,"NAME"))
Begin DoDot:2
+17 IF '$PIECE(^DPT(DGDFN,"NAME"),U,1)
Begin DoDot:3
+18 SET ^XTMP("UPDATE",DGDFN)=DGNAME
SET ^XTMP("RESULTS",DGCNT)=DGDFN_"^"_DGNAME
SET DGCNT=DGCNT+1
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
RESULTS ;
+1 IF $DATA(^XTMP("UPDATE"))
Begin DoDot:1
+2 WRITE !!," Records were found, and the Missing Name Components message was sent to your mailman acct."
+3 WRITE " The DG NAME COMPONENT UPDATE option needs to be run after reviewing the findings",!
End DoDot:1
+4 SET XMDUZ=DUZ
+5 SET XMSUBJ="Missing Name Components"
+6 SET XMBODY="^XTMP(""RESULTS"")"
+7 SET XMTO(DUZ)=""
+8 SET XMINSTR("FLAGS")="P"
+9 SET (XMZ,XMATTACH)=""
+10 DO SENDMSG(.XMDUZ,.XMSUBJ,.XMBODY,.XMTO,.XMINSTR,.XMZ,.XMATTACH)
+11 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
