DGRNCVNP.m

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 ---DGRNCVNP   2582     printed  Apr 23, 2025@19:09:11                                                                                                                                                                                                    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