XU8P724 ;BIR/DRI - Patch XU*8*724 Post-Init ;1/29/20 14:15
;;8.0;KERNEL;**724**;Jul 10, 1995;Build 2
;Per VHA VA Directive 6402, this routine should not be modified
;
; Story 1201071 (dri) queue updating of additional new person NPI related fields
; Story 1209890 (mko) Fix the KEY subentries for the New Person records where the
; PROVIDER or XUORES security keys were added by code in XU*8.0*711
; but not DINUMd.
; Story 1209795 (jfw) Fix "ADUPN" X-Ref entries that are > 30 chars and standardize
; "ADUPN" value stored in 205.5 in NEW PERSON File (#200) to
; LowerCase.
;
POST ;
D BMES^XPDUTL("Post-Install: Starting")
D QUENPI ;queue off updating of npi
D BMES^XPDUTL("Post-Install: Finished")
Q
;
QUENPI ;task off update of npi
N ZTSAVE,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK
S ZTRTN="UPDNPI^XU8P724"
S ZTDESC="XU*8*724 post-install process for updating NPI in NEW PERSON (#200) file."
S ZTIO="",ZTDTH=$H
D ^%ZTLOAD
D BMES^XPDUTL(" - Filing updates for NPI, KEYS and ADUPN have been queued."),MES^XPDUTL(" Task #"_$G(ZTSK))
D MES^XPDUTL(" Upon completion a Mailman message will be sent to the installer.")
Q
;
UPDNPI ;update npi
N ERRMSG,XUARR,XUDUZ,XUKEYCNT,XUNPITOT,XUNPIUPD,XUCNT,XUMAX,XUPD,XUERR
S XUNPITOT=0,XUNPIUPD=0
S XUARR("NPI")="" F S XUARR("NPI")=$O(^VA(200,"ANPI",XUARR("NPI"))) Q:'XUARR("NPI") D
.S XUDUZ=0 F S XUDUZ=$O(^VA(200,"ANPI",XUARR("NPI"),XUDUZ)) Q:'XUDUZ S XUNPITOT=XUNPITOT+1 I '$D(^VA(200,XUDUZ,"NPISTATUS","C",XUARR("NPI"))) D
..S XUNPIUPD=XUNPIUPD+1 ;npi updated
..S ERRMSG=$$UPDU^XUMVINPA(.XUARR,XUDUZ)
;
D FIXKEYS(.XUKEYCNT)
D UPDADUPN ;Fix ADUPN X-REF where > 30 chars and standardize value to lowercase
D GENMSG ;Send msg to inform installer cleanup completed
Q
;
GENMSG ;Send mail message on completion of Task
N XMDUZ,XMSUB,XMY,XMTEXT,DIFROM,MSGTXT,X,XUNAME,XUSITE,XUI,XUDUZ
S X=$$SITE^VASITE(),XUNAME=$P(X,"^",2),XUSITE=$P(X,"^",3)
S XMDUZ=".5" ;From Postmaster
S XMY(DUZ)="" ;To User who installed
S XMY("DAN.IHLENFELD@DOMAIN.EXT")=""
S XMY("CHRISTINE.CHESNEY@DOMAIN.EXT")=""
S XMY("JOHN.WILLIAMS30EC0C@DOMAIN.EXT")=""
S XMY("MICHAEL.OGI@DOMAIN.EXT")=""
S XMSUB="XU*8*724 Post-Install complete at station #"_XUSITE_" ("_$S($$PROD^XUPROD(1):"PROD",1:"TEST")_")"
S XMTEXT="MSGTXT("
S MSGTXT(1)="Updates occurred at "_XUNAME_" on "_$$FMTE^XLFDT(DT)_":"
S MSGTXT(2)=" "
S MSGTXT(3)="Total NPI's: "_$FN(XUNPITOT,",")
S MSGTXT(4)=" "
S MSGTXT(5)="Total NPI's Updated: "_$FN(XUNPIUPD,",")
S MSGTXT(6)=" "
S MSGTXT(7)="Total KEYS subentries corrected: "_$FN($G(XUKEYCNT),",")
S MSGTXT(8)=" "
S MSGTXT(9)="Total 'ADUPN' records: "_$FN(XUCNT,",")
S MSGTXT(10)="Total 'ADUPN' records updated: "_$FN(XUPD,",")
S MSGTXT(11)="Total 'ADUPN' records > 30 chars: "_$FN(XUMAX,",")
I $D(XUERR) D
.S MSGTXT(12)=" "
.S MSGTXT(13)="ADUPN DUZ Lock Errors:"
.S XUI=14,XUDUZ="" F S XUDUZ=$O(XUERR(XUDUZ)) Q:XUDUZ']"" D
..S MSGTXT(XUI)=" "_XUDUZ,XUI=XUI+1
.S MSGTXT(XUI)="Use DEVMOU option [MPI VIEW/EDIT NEW PERSON DATA] to update!"
D ^XMD
Q
;
FIXKEYS(XUKEYCNT) ;Fix the subrecords in the KEYS multiple in which the .01 is not DINUMd
;Use the whole-file "AB" index. Look at "PROVIDER" and "XUORES" keys only
N XUDUZ,XUKEY,XUKEYIEN,XUSUBIEN
S XUKEYCNT=0
;
F XUKEY="PROVIDER","XUORES" D
. S XUKEYIEN=$O(^DIC(19.1,"B",XUKEY,0)) Q:XUKEYIEN'>0
. S XUDUZ=0 F S XUDUZ=$O(^VA(200,"AB",XUKEYIEN,XUDUZ)) Q:'XUDUZ D
.. S XUSUBIEN=0 F S XUSUBIEN=$O(^VA(200,"AB",XUKEYIEN,XUDUZ,XUSUBIEN)) Q:'XUSUBIEN D:XUKEYIEN'=XUSUBIEN PROCKEY(XUDUZ,XUSUBIEN,.XUKEYCNT)
Q
;
PROCKEY(XUDUZ,XUSUBIEN,XUKEYCNT) ;Process this KEY subentry
N XUIENS,XUVALS
Q:$D(^VA(200,XUDUZ,51,XUSUBIEN,0))[0
S XUIENS=XUSUBIEN_","_XUDUZ_","
;
;Get the original data in the KEY subentry
D GETKEY(XUIENS,"IN",.XUVALS) Q:$G(XUVALS(200.051,XUIENS,.01,"I"))'>0
;
;Delete the KEY subentry
D DELKEY(XUIENS)
;
;Re-add the KEY subentry
D ADDKEY(XUIENS,.XUVALS)
S XUKEYCNT=$G(XUKEYCNT)+1
Q
;
GETKEY(XUIENS,XUFLAGS,XUVALS) ;Get internal values of KEY subentry
N DIERR,DIHELP,DIMSG,XUMVIERR
D GETS^DIQ(200.051,XUIENS,"*",$G(XUFLAGS),"XUVALS","XUMVIERR")
Q
;
DELKEY(XUIENS) ;Delete a KEY subentry
N DA,DIK,X,Y
D DA^DILF(XUIENS,.DA)
S DIK="^VA(200,"_DA(1)_",51,"
D ^DIK
Q
;
ADDKEY(XUIENS,XUVALS) ;Add a KEY subentry
N D0,D1,DIERR,DIHELP,DIMSG,XUFDA,XUFLD,XUIEN,XUIENSN,XUMVIERR
S XUIENSN=XUIENS,$P(XUIENSN,",")="+1"
;
;Build the FDA from internal values in XUVALS
S XUFLD="" F S XUFLD=$O(XUVALS(200.051,XUIENS,XUFLD)) Q:XUFLD="" D
. S XUFDA(200.051,XUIENSN,XUFLD)=$G(XUVALS(200.051,XUIENS,XUFLD,"I"))
;
;Set the IEN of the new entry equal to the #.01 pointer value
S XUIEN(1)=XUVALS(200.051,XUIENS,.01,"I") Q:XUIEN(1)'>0
;
;Add the entry
D UPDATE^DIE("","XUFDA","XUIEN","XUMVIERR")
Q
;
UPDADUPN ;Update ADUPN (For values > 30 chars and NOT LowerCase)
N XUADUPN,XUDUZ,XUVAL,XUFDA,XUPRDUZ,DA,DIK
S (XUCNT,XUMAX,XUPD)=0,XUADUPN=""
;Loop on ADUPN X-Ref to cleanup/standardize records in NEW PERSON File (#200)
F S XUADUPN=$O(^VA(200,"ADUPN",XUADUPN)) Q:XUADUPN']"" D
.;Should only be 1 record, but just in case look again...
.S XUDUZ="" F S XUDUZ=$O(^VA(200,"ADUPN",XUADUPN,XUDUZ)) Q:XUDUZ']"" D
..S:('$D(XUPRDUZ(XUDUZ))) XUCNT=XUCNT+1
..S XUPRDUZ(XUDUZ)="",XUVAL=$$GET1^DIQ(200,XUDUZ,205.5,"I")
..S:($L(XUVAL)>30) XUMAX=XUMAX+1
..D:($$LOW^XLFSTR(XUVAL)'=XUADUPN)
...K ^VA(200,"ADUPN",XUADUPN,XUDUZ)
...;Just execute X-REF Re-Index for record if no change to ADUPN is required
...I ($$LOW^XLFSTR(XUVAL)=XUVAL) D Q
....S XUPD=XUPD+1,DA=XUDUZ,DIK="^VA(200,",DIK(1)="205.5^ADUPN" D EN1^DIK
...;Change to ADUPN field will automatically execute X-REF
...L +^VA(200,XUDUZ,205):10 I '$T S XUERR(XUDUZ)="" Q
...S XUFDA(200,XUDUZ_",",205.5)=XUVAL D FILE^DIE("E","XUFDA")
...L -^VA(200,XUDUZ,205)
...S XUPD=XUPD+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXU8P724 6041 printed Dec 13, 2024@02:08:39 Page 2
XU8P724 ;BIR/DRI - Patch XU*8*724 Post-Init ;1/29/20 14:15
+1 ;;8.0;KERNEL;**724**;Jul 10, 1995;Build 2
+2 ;Per VHA VA Directive 6402, this routine should not be modified
+3 ;
+4 ; Story 1201071 (dri) queue updating of additional new person NPI related fields
+5 ; Story 1209890 (mko) Fix the KEY subentries for the New Person records where the
+6 ; PROVIDER or XUORES security keys were added by code in XU*8.0*711
+7 ; but not DINUMd.
+8 ; Story 1209795 (jfw) Fix "ADUPN" X-Ref entries that are > 30 chars and standardize
+9 ; "ADUPN" value stored in 205.5 in NEW PERSON File (#200) to
+10 ; LowerCase.
+11 ;
POST ;
+1 DO BMES^XPDUTL("Post-Install: Starting")
+2 ;queue off updating of npi
DO QUENPI
+3 DO BMES^XPDUTL("Post-Install: Finished")
+4 QUIT
+5 ;
QUENPI ;task off update of npi
+1 NEW ZTSAVE,ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK
+2 SET ZTRTN="UPDNPI^XU8P724"
+3 SET ZTDESC="XU*8*724 post-install process for updating NPI in NEW PERSON (#200) file."
+4 SET ZTIO=""
SET ZTDTH=$HOROLOG
+5 DO ^%ZTLOAD
+6 DO BMES^XPDUTL(" - Filing updates for NPI, KEYS and ADUPN have been queued.")
DO MES^XPDUTL(" Task #"_$GET(ZTSK))
+7 DO MES^XPDUTL(" Upon completion a Mailman message will be sent to the installer.")
+8 QUIT
+9 ;
UPDNPI ;update npi
+1 NEW ERRMSG,XUARR,XUDUZ,XUKEYCNT,XUNPITOT,XUNPIUPD,XUCNT,XUMAX,XUPD,XUERR
+2 SET XUNPITOT=0
SET XUNPIUPD=0
+3 SET XUARR("NPI")=""
FOR
SET XUARR("NPI")=$ORDER(^VA(200,"ANPI",XUARR("NPI")))
if 'XUARR("NPI")
QUIT
Begin DoDot:1
+4 SET XUDUZ=0
FOR
SET XUDUZ=$ORDER(^VA(200,"ANPI",XUARR("NPI"),XUDUZ))
if 'XUDUZ
QUIT
SET XUNPITOT=XUNPITOT+1
IF '$DATA(^VA(200,XUDUZ,"NPISTATUS","C",XUARR("NPI")))
Begin DoDot:2
+5 ;npi updated
SET XUNPIUPD=XUNPIUPD+1
+6 SET ERRMSG=$$UPDU^XUMVINPA(.XUARR,XUDUZ)
End DoDot:2
End DoDot:1
+7 ;
+8 DO FIXKEYS(.XUKEYCNT)
+9 ;Fix ADUPN X-REF where > 30 chars and standardize value to lowercase
DO UPDADUPN
+10 ;Send msg to inform installer cleanup completed
DO GENMSG
+11 QUIT
+12 ;
GENMSG ;Send mail message on completion of Task
+1 NEW XMDUZ,XMSUB,XMY,XMTEXT,DIFROM,MSGTXT,X,XUNAME,XUSITE,XUI,XUDUZ
+2 SET X=$$SITE^VASITE()
SET XUNAME=$PIECE(X,"^",2)
SET XUSITE=$PIECE(X,"^",3)
+3 ;From Postmaster
SET XMDUZ=".5"
+4 ;To User who installed
SET XMY(DUZ)=""
+5 SET XMY("DAN.IHLENFELD@DOMAIN.EXT")=""
+6 SET XMY("CHRISTINE.CHESNEY@DOMAIN.EXT")=""
+7 SET XMY("JOHN.WILLIAMS30EC0C@DOMAIN.EXT")=""
+8 SET XMY("MICHAEL.OGI@DOMAIN.EXT")=""
+9 SET XMSUB="XU*8*724 Post-Install complete at station #"_XUSITE_" ("_$SELECT($$PROD^XUPROD(1):"PROD",1:"TEST")_")"
+10 SET XMTEXT="MSGTXT("
+11 SET MSGTXT(1)="Updates occurred at "_XUNAME_" on "_$$FMTE^XLFDT(DT)_":"
+12 SET MSGTXT(2)=" "
+13 SET MSGTXT(3)="Total NPI's: "_$FNUMBER(XUNPITOT,",")
+14 SET MSGTXT(4)=" "
+15 SET MSGTXT(5)="Total NPI's Updated: "_$FNUMBER(XUNPIUPD,",")
+16 SET MSGTXT(6)=" "
+17 SET MSGTXT(7)="Total KEYS subentries corrected: "_$FNUMBER($GET(XUKEYCNT),",")
+18 SET MSGTXT(8)=" "
+19 SET MSGTXT(9)="Total 'ADUPN' records: "_$FNUMBER(XUCNT,",")
+20 SET MSGTXT(10)="Total 'ADUPN' records updated: "_$FNUMBER(XUPD,",")
+21 SET MSGTXT(11)="Total 'ADUPN' records > 30 chars: "_$FNUMBER(XUMAX,",")
+22 IF $DATA(XUERR)
Begin DoDot:1
+23 SET MSGTXT(12)=" "
+24 SET MSGTXT(13)="ADUPN DUZ Lock Errors:"
+25 SET XUI=14
SET XUDUZ=""
FOR
SET XUDUZ=$ORDER(XUERR(XUDUZ))
if XUDUZ']""
QUIT
Begin DoDot:2
+26 SET MSGTXT(XUI)=" "_XUDUZ
SET XUI=XUI+1
End DoDot:2
+27 SET MSGTXT(XUI)="Use DEVMOU option [MPI VIEW/EDIT NEW PERSON DATA] to update!"
End DoDot:1
+28 DO ^XMD
+29 QUIT
+30 ;
FIXKEYS(XUKEYCNT) ;Fix the subrecords in the KEYS multiple in which the .01 is not DINUMd
+1 ;Use the whole-file "AB" index. Look at "PROVIDER" and "XUORES" keys only
+2 NEW XUDUZ,XUKEY,XUKEYIEN,XUSUBIEN
+3 SET XUKEYCNT=0
+4 ;
+5 FOR XUKEY="PROVIDER","XUORES"
Begin DoDot:1
+6 SET XUKEYIEN=$ORDER(^DIC(19.1,"B",XUKEY,0))
if XUKEYIEN'>0
QUIT
+7 SET XUDUZ=0
FOR
SET XUDUZ=$ORDER(^VA(200,"AB",XUKEYIEN,XUDUZ))
if 'XUDUZ
QUIT
Begin DoDot:2
+8 SET XUSUBIEN=0
FOR
SET XUSUBIEN=$ORDER(^VA(200,"AB",XUKEYIEN,XUDUZ,XUSUBIEN))
if 'XUSUBIEN
QUIT
if XUKEYIEN'=XUSUBIEN
DO PROCKEY(XUDUZ,XUSUBIEN,.XUKEYCNT)
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
PROCKEY(XUDUZ,XUSUBIEN,XUKEYCNT) ;Process this KEY subentry
+1 NEW XUIENS,XUVALS
+2 if $DATA(^VA(200,XUDUZ,51,XUSUBIEN,0))[0
QUIT
+3 SET XUIENS=XUSUBIEN_","_XUDUZ_","
+4 ;
+5 ;Get the original data in the KEY subentry
+6 DO GETKEY(XUIENS,"IN",.XUVALS)
if $GET(XUVALS(200.051,XUIENS,.01,"I"))'>0
QUIT
+7 ;
+8 ;Delete the KEY subentry
+9 DO DELKEY(XUIENS)
+10 ;
+11 ;Re-add the KEY subentry
+12 DO ADDKEY(XUIENS,.XUVALS)
+13 SET XUKEYCNT=$GET(XUKEYCNT)+1
+14 QUIT
+15 ;
GETKEY(XUIENS,XUFLAGS,XUVALS) ;Get internal values of KEY subentry
+1 NEW DIERR,DIHELP,DIMSG,XUMVIERR
+2 DO GETS^DIQ(200.051,XUIENS,"*",$GET(XUFLAGS),"XUVALS","XUMVIERR")
+3 QUIT
+4 ;
DELKEY(XUIENS) ;Delete a KEY subentry
+1 NEW DA,DIK,X,Y
+2 DO DA^DILF(XUIENS,.DA)
+3 SET DIK="^VA(200,"_DA(1)_",51,"
+4 DO ^DIK
+5 QUIT
+6 ;
ADDKEY(XUIENS,XUVALS) ;Add a KEY subentry
+1 NEW D0,D1,DIERR,DIHELP,DIMSG,XUFDA,XUFLD,XUIEN,XUIENSN,XUMVIERR
+2 SET XUIENSN=XUIENS
SET $PIECE(XUIENSN,",")="+1"
+3 ;
+4 ;Build the FDA from internal values in XUVALS
+5 SET XUFLD=""
FOR
SET XUFLD=$ORDER(XUVALS(200.051,XUIENS,XUFLD))
if XUFLD=""
QUIT
Begin DoDot:1
+6 SET XUFDA(200.051,XUIENSN,XUFLD)=$GET(XUVALS(200.051,XUIENS,XUFLD,"I"))
End DoDot:1
+7 ;
+8 ;Set the IEN of the new entry equal to the #.01 pointer value
+9 SET XUIEN(1)=XUVALS(200.051,XUIENS,.01,"I")
if XUIEN(1)'>0
QUIT
+10 ;
+11 ;Add the entry
+12 DO UPDATE^DIE("","XUFDA","XUIEN","XUMVIERR")
+13 QUIT
+14 ;
UPDADUPN ;Update ADUPN (For values > 30 chars and NOT LowerCase)
+1 NEW XUADUPN,XUDUZ,XUVAL,XUFDA,XUPRDUZ,DA,DIK
+2 SET (XUCNT,XUMAX,XUPD)=0
SET XUADUPN=""
+3 ;Loop on ADUPN X-Ref to cleanup/standardize records in NEW PERSON File (#200)
+4 FOR
SET XUADUPN=$ORDER(^VA(200,"ADUPN",XUADUPN))
if XUADUPN']""
QUIT
Begin DoDot:1
+5 ;Should only be 1 record, but just in case look again...
+6 SET XUDUZ=""
FOR
SET XUDUZ=$ORDER(^VA(200,"ADUPN",XUADUPN,XUDUZ))
if XUDUZ']""
QUIT
Begin DoDot:2
+7 if ('$DATA(XUPRDUZ(XUDUZ)))
SET XUCNT=XUCNT+1
+8 SET XUPRDUZ(XUDUZ)=""
SET XUVAL=$$GET1^DIQ(200,XUDUZ,205.5,"I")
+9 if ($LENGTH(XUVAL)>30)
SET XUMAX=XUMAX+1
+10 if ($$LOW^XLFSTR(XUVAL)'=XUADUPN)
Begin DoDot:3
+11 KILL ^VA(200,"ADUPN",XUADUPN,XUDUZ)
+12 ;Just execute X-REF Re-Index for record if no change to ADUPN is required
+13 IF ($$LOW^XLFSTR(XUVAL)=XUVAL)
Begin DoDot:4
+14 SET XUPD=XUPD+1
SET DA=XUDUZ
SET DIK="^VA(200,"
SET DIK(1)="205.5^ADUPN"
DO EN1^DIK
End DoDot:4
QUIT
+15 ;Change to ADUPN field will automatically execute X-REF
+16 LOCK +^VA(200,XUDUZ,205):10
IF '$TEST
SET XUERR(XUDUZ)=""
QUIT
+17 SET XUFDA(200,XUDUZ_",",205.5)=XUVAL
DO FILE^DIE("E","XUFDA")
+18 LOCK -^VA(200,XUDUZ,205)
+19 SET XUPD=XUPD+1
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT
