VDI1P1 ;BP/CMF/GJW - Patch 1 Post-Init ; 3/23/2023
;;1.0;VETERANS DATA INTEGRATION AND FEDERATION;**1**;Dec 30, 1994;Build 19
;
; External Reference DBIA#
; ------------------ -----
; ^VA(200 10060
; XPDUTL 10141
; UPDATE^DIE 2053
; $$SHAHASH^XUSHSH() 6189
; Add new NPE user 7423
;
ENV ;do environment check
S XPDABORT=""
D PROGCHK(.XPDABORT) I XPDABORT=2 Q
D RQIDCHK(.XPDABORT) I XPDABORT=2 Q
I XPDABORT="" K XPDABORT
Q
;
PROGCHK(XPDABORT) ; checks for necessary programmer variables
I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D
.D MES^XPDUTL("Your programming variables are not set up properly.")
.D MES^XPDUTL("Installation aborted.")
.S XPDABORT=2
Q
;
RQIDCHK(XPDABORT) ; checks for additional required identifiers beyond .01 field
; loop through required identifier fields, if a field outside of our filing list, abort, alert user with message
Q:+$G(XPDENV)=0 ; do not execute if run by load a distribution.
N RQIDOUT,RQIDMSG,RQIDENT,RQIDNUM,RQIDNAM,RQIDABRT,RQIDVAL
;S XPDGREF="^XTMP(""VDI1P1"")"
D FILE^DID(200,,"REQUIRED IDENTIFIERS","RQIDOUT","RQIDMSG")
S RQIDENT=0,RQIDABRT=0,XPDABORT=""
F S RQIDENT=$O(RQIDOUT("REQUIRED IDENTIFIERS",RQIDENT)) Q:+RQIDENT=0 D
.S RQIDNUM=$G(RQIDOUT("REQUIRED IDENTIFIERS",RQIDENT,"FIELD"))
.Q:RQIDNUM=""
.Q:"^.01^2^11^7.2^205.1^205.2^205.3^205.4^205.5^"[(U_RQIDNUM_U)
.S RQIDABRT=1
.S RQIDABRT(RQIDNUM)=""
.Q
Q:RQIDABRT=0
D BMES^XPDUTL("This site has required identifier fields for New Person file entries")
D MES^XPDUTL("which are not contained in the new entries being made for this patch.")
D MES^XPDUTL("Please supply the values for these fields at your facility.")
D BMES^XPDUTL("The fields are:")
S RQIDNUM=0
F S RQIDNUM=$O(RQIDABRT(RQIDNUM)) Q:+RQIDNUM=0!(XPDABORT=2) D
.N DIR,X,Y
.S DIR(0)="200,"_RQIDNUM
.D ^DIR
.I $D(DIRUT) S XPDABORT=2 Q
.S RQIDNAM=$$GET1^DID(200,RQIDNUM,"","LABEL","","RQIDMSG")
.S RQIDVAL=$P(Y,U,2)
.I RQIDVAL="" S XPDABORT=2 Q
.M @XPDGREF@("VDI1P1",RQIDNUM)=RQIDVAL
.D MES^XPDUTL(" "_RQIDNUM_" "_RQIDNAM_" "_RQIDVAL_" added to filer array")
.Q
S:XPDABORT'="" XPDABORT=2
Q
;
HELP ; Help for ?? on Installation Question POS1 (use direct writes in env check routine)
W !,"Enter 1 if patch is being installed in a Pre-Production system."
W !,"Enter 2 if patch is being installed in a Software Quality Assurance system."
W !,"Enter 3 if patch is being installed in a Test system."
W !,"Enter 4 if patch is being installed in a Development system."
Q
;
POST ; Post-init for VDI*1*1
N VDIENV,VDITYPE
S VDITYPE=$G(XPDQUES("POS1"))
;VDITYPE will be a value of 1-4 (pre-prod, sqa, test, development) if no value, this is a production system
I 'VDITYPE S VDITYPE=5
S VDIENV=$S(VDITYPE=1:"PPD",VDITYPE=2:"SQA",VDITYPE=3:"TST",VDITYPE=4:"DEV",1:"PRD")
D IZG(VDIENV) ; for IZG
D MHV(VDIENV) ; for MHV
Q
;
IZG(VDIENV) ; Create Non Person Entity (NPE) user
; look for type of VistA instance
; create NPE for type of instance
N VDINPE,VDISECID,VDIUPN,VDIRSLT,VDIRSLT2,VDIERR,VDIERTXT
S VDINPE="OITAUSIZG"_VDIENV
; need SecID for dev
S VDISECID=$S(VDIENV="PRD":1076035779,VDIENV="PPD":1017862488,VDIENV="SQA":1013776211,VDIENV="TST":1013776210,1:"")
S VDIUPN="OITAUSIZG"_VDIENV_"@AAC.DVA.DOMAIN.EXT" ;
S VDIRSLT=$$ADD(VDINPE,VDINPE,VDISECID,VDIUPN,"VDIERR")
I +VDIRSLT>0 D QUIT
. D BMES^XPDUTL(VDINPE_" NPE User created or updated")
. Q
D BMES^XPDUTL(VDINPE_" NPE User not created or updated")
S VDIRSLT2=$P(VDIRSLT,U,2)
D:VDIRSLT2'="" MES^XPDUTL(VDIRSLT2)
S VDIERTXT=$G(VDIERR("DIERR",1,"TEXT",1))
D:VDIERTXT'="" MES^XPDUTL(VDIERTXT)
Q
;
MHV(VDIENV) ; Create NPE user
; create NPE for type of instance
N VDINPE,VDISECID,VDIUPN,VDIRSLT,VDIRSLT2,VDIERR,VDIERTXT
I VDIENV="PRD"!(VDIENV="PPD") D
. S VDINPE="OITSVCMHV"_VDIENV
. S VDIUPN=VDINPE_"@DOMAIN.EXT"
. Q
E D
. S VDINPE="OITAUSMHV"_VDIENV
. S VDIUPN=VDINPE_"@AAC.DVA.DOMAIN.EXT"
. Q
; no names/secids for tst & dev defined
S VDISECID=$S(VDIENV="PRD":1076218582,VDIENV="PPD":1017863107,VDIENV="SQA":1013775925,1:"")
S VDIRSLT=$$ADD(VDINPE,VDINPE,VDISECID,VDIUPN,"VDIERR")
I +VDIRSLT>0 D QUIT
. D BMES^XPDUTL(VDINPE_" NPE User created or updated")
. Q
D BMES^XPDUTL(VDINPE_" NPE User not created")
S VDIRSLT2=$P(VDIRSLT,U,2)
D:VDIRSLT2'="" MES^XPDUTL(VDIRSLT2)
S VDIERTXT=$G(VDIERR("DIERR",1,"TEXT",1))
D:VDIERTXT'="" MES^XPDUTL(VDIERTXT)
Q
;
;
ADD(VDIFIRST,VDILAST,VDISECID,VDIEMAIL,VDIMSG) ;create new non-person user
;
;VDIFIRST - first name
;VDILAST - last name
;VDISECID (optional) - SECID
;VDIEMAIL (optional) - VA email address (UPN)
;VDIMSG (optional) - error message array from UPDATE^DIE
;
;return value: DUZ of user or a value < 0 on error:
;
; -1 - could not obtain lock
; -2 - FileMan signaled an error (see VDIMSG)
; -3 - User does not have DUZ(0)="@"
;
N MYFDA,IROOT,MROOT,DIC,VDINAME,AC,VC,RQIDNUM,RQIDVAL
Q:DUZ(0)'="@" "-3^User must have DUZ(0)=""@"""
H 1 ;ensure that succeive calls do not occur with the same value of $H.
S VDINAME=VDILAST_","_$G(VDIFIRST)
S AC=$$SHAHASH^XUSHSH(256,$J_$H,"B")
S VC=$$SHAHASH^XUSHSH(256,$J_$H_1,"B")
L +^VA(200,0):5 I '$T Q "-1^Could not obtain lock on NEW PERSON file"
S DIC(0)="" ;required to avoid hard error in FileMan
S MYFDA(200,"?+1,",.01)=VDINAME
S MYFDA(200,"?+1,",2)=AC ;ACCESS CODE
S MYFDA(200,"?+1,",11)=VC ;VERIFY CODE
S MYFDA(200,"?+1,",7.2)="Yes" ;VERIFY CODE never expires
S MYFDA(200.07,"?+2,?+1,",.01)="NON-PERSON" ;USER CLASS
S MYFDA(200,"?+1,",205.1)=$G(VDISECID) ;SECID
S MYFDA(200,"?+1,",205.2)="Department of Veterans Affairs" ;SUBJECT ORGANIZATION
S MYFDA(200,"?+1,",205.3)="urn:oid:2.16.840.1.113883.4.349" ;SUBJECT ORGANIZATION ID
S MYFDA(200,"?+1,",205.4)=$G(VDISECID) ;UNIQUE USER ID
S MYFDA(200,"?+1,",205.5)=$G(VDIEMAIL) ;ADUPN
I $G(XPDGREF)'="" D:$D(@XPDGREF)
.S RQIDNUM=0
.F S RQIDNUM=$O(@XPDGREF@("VDI1P1",RQIDNUM)) Q:+RQIDNUM=0 D
..S RQIDVAL=$G(@XPDGREF@("VDI1P1",RQIDNUM))
..Q:RQIDVAL=""
..S MYFDA(200,"?+1,",RQIDNUM)=RQIDVAL
..Q
.Q
D UPDATE^DIE("E","MYFDA","IROOT","MROOT")
L -^VA(200,0)
S VDIIEN=$G(IROOT(1))
M:$D(VDIMSG) @VDIMSG=MROOT
Q $S(VDIIEN="":"-2^FileMan signaled an error",1:VDIIEN)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVDI1P1 6392 printed Mar 25, 2026@16:11:17 Page 2
VDI1P1 ;BP/CMF/GJW - Patch 1 Post-Init ; 3/23/2023
+1 ;;1.0;VETERANS DATA INTEGRATION AND FEDERATION;**1**;Dec 30, 1994;Build 19
+2 ;
+3 ; External Reference DBIA#
+4 ; ------------------ -----
+5 ; ^VA(200 10060
+6 ; XPDUTL 10141
+7 ; UPDATE^DIE 2053
+8 ; $$SHAHASH^XUSHSH() 6189
+9 ; Add new NPE user 7423
+10 ;
ENV ;do environment check
+1 SET XPDABORT=""
+2 DO PROGCHK(.XPDABORT)
IF XPDABORT=2
QUIT
+3 DO RQIDCHK(.XPDABORT)
IF XPDABORT=2
QUIT
+4 IF XPDABORT=""
KILL XPDABORT
+5 QUIT
+6 ;
PROGCHK(XPDABORT) ; checks for necessary programmer variables
+1 IF '$GET(DUZ)!($GET(DUZ(0))'="@")!('$GET(DT))!($GET(U)'="^")
Begin DoDot:1
+2 DO MES^XPDUTL("Your programming variables are not set up properly.")
+3 DO MES^XPDUTL("Installation aborted.")
+4 SET XPDABORT=2
End DoDot:1
+5 QUIT
+6 ;
RQIDCHK(XPDABORT) ; checks for additional required identifiers beyond .01 field
+1 ; loop through required identifier fields, if a field outside of our filing list, abort, alert user with message
+2 ; do not execute if run by load a distribution.
if +$GET(XPDENV)=0
QUIT
+3 NEW RQIDOUT,RQIDMSG,RQIDENT,RQIDNUM,RQIDNAM,RQIDABRT,RQIDVAL
+4 ;S XPDGREF="^XTMP(""VDI1P1"")"
+5 DO FILE^DID(200,,"REQUIRED IDENTIFIERS","RQIDOUT","RQIDMSG")
+6 SET RQIDENT=0
SET RQIDABRT=0
SET XPDABORT=""
+7 FOR
SET RQIDENT=$ORDER(RQIDOUT("REQUIRED IDENTIFIERS",RQIDENT))
if +RQIDENT=0
QUIT
Begin DoDot:1
+8 SET RQIDNUM=$GET(RQIDOUT("REQUIRED IDENTIFIERS",RQIDENT,"FIELD"))
+9 if RQIDNUM=""
QUIT
+10 if "^.01^2^11^7.2^205.1^205.2^205.3^205.4^205.5^"[(U_RQIDNUM_U)
QUIT
+11 SET RQIDABRT=1
+12 SET RQIDABRT(RQIDNUM)=""
+13 QUIT
End DoDot:1
+14 if RQIDABRT=0
QUIT
+15 DO BMES^XPDUTL("This site has required identifier fields for New Person file entries")
+16 DO MES^XPDUTL("which are not contained in the new entries being made for this patch.")
+17 DO MES^XPDUTL("Please supply the values for these fields at your facility.")
+18 DO BMES^XPDUTL("The fields are:")
+19 SET RQIDNUM=0
+20 FOR
SET RQIDNUM=$ORDER(RQIDABRT(RQIDNUM))
if +RQIDNUM=0!(XPDABORT=2)
QUIT
Begin DoDot:1
+21 NEW DIR,X,Y
+22 SET DIR(0)="200,"_RQIDNUM
+23 DO ^DIR
+24 IF $DATA(DIRUT)
SET XPDABORT=2
QUIT
+25 SET RQIDNAM=$$GET1^DID(200,RQIDNUM,"","LABEL","","RQIDMSG")
+26 SET RQIDVAL=$PIECE(Y,U,2)
+27 IF RQIDVAL=""
SET XPDABORT=2
QUIT
+28 MERGE @XPDGREF@("VDI1P1",RQIDNUM)=RQIDVAL
+29 DO MES^XPDUTL(" "_RQIDNUM_" "_RQIDNAM_" "_RQIDVAL_" added to filer array")
+30 QUIT
End DoDot:1
+31 if XPDABORT'=""
SET XPDABORT=2
+32 QUIT
+33 ;
HELP ; Help for ?? on Installation Question POS1 (use direct writes in env check routine)
+1 WRITE !,"Enter 1 if patch is being installed in a Pre-Production system."
+2 WRITE !,"Enter 2 if patch is being installed in a Software Quality Assurance system."
+3 WRITE !,"Enter 3 if patch is being installed in a Test system."
+4 WRITE !,"Enter 4 if patch is being installed in a Development system."
+5 QUIT
+6 ;
POST ; Post-init for VDI*1*1
+1 NEW VDIENV,VDITYPE
+2 SET VDITYPE=$GET(XPDQUES("POS1"))
+3 ;VDITYPE will be a value of 1-4 (pre-prod, sqa, test, development) if no value, this is a production system
+4 IF 'VDITYPE
SET VDITYPE=5
+5 SET VDIENV=$SELECT(VDITYPE=1:"PPD",VDITYPE=2:"SQA",VDITYPE=3:"TST",VDITYPE=4:"DEV",1:"PRD")
+6 ; for IZG
DO IZG(VDIENV)
+7 ; for MHV
DO MHV(VDIENV)
+8 QUIT
+9 ;
IZG(VDIENV) ; Create Non Person Entity (NPE) user
+1 ; look for type of VistA instance
+2 ; create NPE for type of instance
+3 NEW VDINPE,VDISECID,VDIUPN,VDIRSLT,VDIRSLT2,VDIERR,VDIERTXT
+4 SET VDINPE="OITAUSIZG"_VDIENV
+5 ; need SecID for dev
+6 SET VDISECID=$SELECT(VDIENV="PRD":1076035779,VDIENV="PPD":1017862488,VDIENV="SQA":1013776211,VDIENV="TST":1013776210,1:"")
+7 ;
SET VDIUPN="OITAUSIZG"_VDIENV_"@AAC.DVA.DOMAIN.EXT"
+8 SET VDIRSLT=$$ADD(VDINPE,VDINPE,VDISECID,VDIUPN,"VDIERR")
+9 IF +VDIRSLT>0
Begin DoDot:1
+10 DO BMES^XPDUTL(VDINPE_" NPE User created or updated")
+11 QUIT
End DoDot:1
QUIT
+12 DO BMES^XPDUTL(VDINPE_" NPE User not created or updated")
+13 SET VDIRSLT2=$PIECE(VDIRSLT,U,2)
+14 if VDIRSLT2'=""
DO MES^XPDUTL(VDIRSLT2)
+15 SET VDIERTXT=$GET(VDIERR("DIERR",1,"TEXT",1))
+16 if VDIERTXT'=""
DO MES^XPDUTL(VDIERTXT)
+17 QUIT
+18 ;
MHV(VDIENV) ; Create NPE user
+1 ; create NPE for type of instance
+2 NEW VDINPE,VDISECID,VDIUPN,VDIRSLT,VDIRSLT2,VDIERR,VDIERTXT
+3 IF VDIENV="PRD"!(VDIENV="PPD")
Begin DoDot:1
+4 SET VDINPE="OITSVCMHV"_VDIENV
+5 SET VDIUPN=VDINPE_"@DOMAIN.EXT"
+6 QUIT
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET VDINPE="OITAUSMHV"_VDIENV
+9 SET VDIUPN=VDINPE_"@AAC.DVA.DOMAIN.EXT"
+10 QUIT
End DoDot:1
+11 ; no names/secids for tst & dev defined
+12 SET VDISECID=$SELECT(VDIENV="PRD":1076218582,VDIENV="PPD":1017863107,VDIENV="SQA":1013775925,1:"")
+13 SET VDIRSLT=$$ADD(VDINPE,VDINPE,VDISECID,VDIUPN,"VDIERR")
+14 IF +VDIRSLT>0
Begin DoDot:1
+15 DO BMES^XPDUTL(VDINPE_" NPE User created or updated")
+16 QUIT
End DoDot:1
QUIT
+17 DO BMES^XPDUTL(VDINPE_" NPE User not created")
+18 SET VDIRSLT2=$PIECE(VDIRSLT,U,2)
+19 if VDIRSLT2'=""
DO MES^XPDUTL(VDIRSLT2)
+20 SET VDIERTXT=$GET(VDIERR("DIERR",1,"TEXT",1))
+21 if VDIERTXT'=""
DO MES^XPDUTL(VDIERTXT)
+22 QUIT
+23 ;
+24 ;
ADD(VDIFIRST,VDILAST,VDISECID,VDIEMAIL,VDIMSG) ;create new non-person user
+1 ;
+2 ;VDIFIRST - first name
+3 ;VDILAST - last name
+4 ;VDISECID (optional) - SECID
+5 ;VDIEMAIL (optional) - VA email address (UPN)
+6 ;VDIMSG (optional) - error message array from UPDATE^DIE
+7 ;
+8 ;return value: DUZ of user or a value < 0 on error:
+9 ;
+10 ; -1 - could not obtain lock
+11 ; -2 - FileMan signaled an error (see VDIMSG)
+12 ; -3 - User does not have DUZ(0)="@"
+13 ;
+14 NEW MYFDA,IROOT,MROOT,DIC,VDINAME,AC,VC,RQIDNUM,RQIDVAL
+15 if DUZ(0)'="@"
QUIT "-3^User must have DUZ(0)=""@"""
+16 ;ensure that succeive calls do not occur with the same value of $H.
HANG 1
+17 SET VDINAME=VDILAST_","_$GET(VDIFIRST)
+18 SET AC=$$SHAHASH^XUSHSH(256,$JOB_$HOROLOG,"B")
+19 SET VC=$$SHAHASH^XUSHSH(256,$JOB_$HOROLOG_1,"B")
+20 LOCK +^VA(200,0):5
IF '$TEST
QUIT "-1^Could not obtain lock on NEW PERSON file"
+21 ;required to avoid hard error in FileMan
SET DIC(0)=""
+22 SET MYFDA(200,"?+1,",.01)=VDINAME
+23 ;ACCESS CODE
SET MYFDA(200,"?+1,",2)=AC
+24 ;VERIFY CODE
SET MYFDA(200,"?+1,",11)=VC
+25 ;VERIFY CODE never expires
SET MYFDA(200,"?+1,",7.2)="Yes"
+26 ;USER CLASS
SET MYFDA(200.07,"?+2,?+1,",.01)="NON-PERSON"
+27 ;SECID
SET MYFDA(200,"?+1,",205.1)=$GET(VDISECID)
+28 ;SUBJECT ORGANIZATION
SET MYFDA(200,"?+1,",205.2)="Department of Veterans Affairs"
+29 ;SUBJECT ORGANIZATION ID
SET MYFDA(200,"?+1,",205.3)="urn:oid:2.16.840.1.113883.4.349"
+30 ;UNIQUE USER ID
SET MYFDA(200,"?+1,",205.4)=$GET(VDISECID)
+31 ;ADUPN
SET MYFDA(200,"?+1,",205.5)=$GET(VDIEMAIL)
+32 IF $GET(XPDGREF)'=""
if $DATA(@XPDGREF)
Begin DoDot:1
+33 SET RQIDNUM=0
+34 FOR
SET RQIDNUM=$ORDER(@XPDGREF@("VDI1P1",RQIDNUM))
if +RQIDNUM=0
QUIT
Begin DoDot:2
+35 SET RQIDVAL=$GET(@XPDGREF@("VDI1P1",RQIDNUM))
+36 if RQIDVAL=""
QUIT
+37 SET MYFDA(200,"?+1,",RQIDNUM)=RQIDVAL
+38 QUIT
End DoDot:2
+39 QUIT
End DoDot:1
+40 DO UPDATE^DIE("E","MYFDA","IROOT","MROOT")
+41 LOCK -^VA(200,0)
+42 SET VDIIEN=$GET(IROOT(1))
+43 if $DATA(VDIMSG)
MERGE @VDIMSG=MROOT
+44 QUIT $SELECT(VDIIEN="":"-2^FileMan signaled an error",1:VDIIEN)
+45 ;
