XUMVINPU ;MVI/DRI - Master Veteran Index New Person Utilities ;10/23/20 16:40
;;8.0;KERNEL;**691,711,710,732,733,799**;Jul 10, 1995;Build 3
;Per VA Directive 6402, this routine should not be modified.
;
;**711, Story 977780 (jfw)
;**732, Story 1204309 (mko)
;**733, Story 1291666 (dri)
;**799 VAMPI-22625
;
GET(XURET,XUDUZ,SECID,NPI,SSN) ;rpc to retrieve new person file data
; called from rpc: XUS MVI NEW PERSON GET
; Input (ONE of the following):
; XUDUZ = NEW PERSON IEN SECID=SECURITY ID NPI=NATIONAL PROVIDER IDENTIFIER SSN=SOCIAL SECURITY NUMBER
; Output:
; Success: XURET = ^TMP("XUMVINPU",$J)
; @XURET@(#) = FILE #;FIELD #<SUBFIELD #><FILE POINTER>^FIELD NAME^<COUNTER #>^INTERNAL VALUE^EXTERNAL VALUE
; <> Denotes optional values. If Counter populated, denotes multiple value <1-n>.
; @XURET@(#)="200;IEN^DUZ^^^"
; @XURET@(#)="200;.01^NAME^^^"
; @XURET@(#)="200;4^SEX^^^"
; @XURET@(#)="200;5^DOB^^^" ;**732,1204309 (mko): Return DOB
; @XURET@(#)="200;8^TITLE^^^"
; @XURET@(#)="200;7^DISUSER^^^"
; @XURET@(#)="200;9.2^TERMINATION DATE^^^"
; @XURET@(#)="200;9.4^Termination Reason^^^"
; @XURET@(#)="200;15^PROHIBITED TIMES FOR SIGN-ON^^^"
; @XURET@(#)="200;11.2^DATE VERIFY CODE LAST CHANGED^^^"
; @XURET@(#)="200;.111^STREET ADDRESS 1^^^"
; @XURET@(#)="200;.112^STREET ADDRESS 2^^^"
; @XURET@(#)="200;.113^STREET ADDRESS 3^^^"
; @XURET@(#)="200;.114^CITY^^^"
; @XURET@(#)="200;.115^STATE^^^"
; @XURET@(#)="200;.116^ZIP CODE^^^"
; @XURET@(#)="200;.132^OFFICE PHONE^^^"
; @XURET@(#)="200;.136^FAX NUMBER^^^"
; @XURET@(#)="200;.151^EMAIL ADDRESS^^^"
; @XURET@(#)="200;30^DATE ENTERED^^^"
; @XURET@(#)="200;31^CREATOR^^^"
; @XURET@(#)="200;41.98^NPI ENTRY STATUS^^"
; @XURET@(#)="200;41.99^NPI^^^"
; @XURET@(#)="200;9^SSN^^^"
; @XURET@(#)="200;42;.01^EFFECTIVE DATE/TIME^<#>^^"
; @XURET@(#)="200;42;.02^STATUS^<#>^^"
; @XURET@(#)="200;42;.03^NPI^<#>^^"
; @XURET@(#)="200;101.13;.01^CPRS TAB^<#>^^"
; @XURET@(#)="200;101.13;.02^EFFECTIVE DATE^<#>^^"
; @XURET@(#)="200;101.13;.03^EXPIRATION DATE^<#>^^"
; @XURET@(#)="200;202^LAST SIGN-ON DATE/TIME^^^"
; @XURET@(#)="200;202.02^XUS Logon Attempt Count^^^"
; @XURET@(#)="200;202.03^XUS Active User^^^"
; @XURET@(#)="200;202.04^Entry Last Edit Date^^^"
; @XURET@(#)="200;202.05^LOCKOUT USER UNTIL^^^"
; @XURET@(#)="200;16;.01^DIVISION^<1-n>^^"
; @XURET@(#)="200;10.1^NAME COMPONENTS^^^"
; @XURET@(#)="20;1^FAMILY (LAST) NAME^^^"
; @XURET@(#)="20;2^GIVEN (FIRST) NAME^^^"
; @XURET@(#)="20;3^MIDDLE NAME^^^"
; @XURET@(#)="20;4^PREFIX^^^"
; @XURET@(#)="20;5^SUFFIX^^^"
; @XURET@(#)="20;6^DEGREE^^^"
; @XURET@(#)="200;29^SERVICE/SECTION^^^"
; @XURET@(#)="200;201^PRIMARY MENU OPTION^^^"
; @XURET@(#)="200;203;.01^SECONDARY MENU OPTIONS^<1-n>^^"
; @XURET@(#)="200;51;.01^KEYS^<1-n>^^"
; @XURET@(#)="200;205.1^SECID^^^"
; @XURET@(#)="200;205.2^SUBJECT ORGANIZATION^^^"
; @XURET@(#)="200;205.3^SUBJECT ORGANIZATION ID^^^"
; @XURET@(#)="200;205.4^UNIQUE USER ID^^^"
; @XURET@(#)="200;205.5^ADUPN^^^"
; @XURET@(#)="200;501.1^NETWORK USERNAME^^^"
; @XURET@(#)="200;8932.1;.01^PERSON CLASS^<1-n>^^"
; @XURET@(#)="200;8932.1;2^EFFECTIVE DATE^<#>^^"
; @XURET@(#)="200;8932.1;3^EXPIRATION DATE^<#>^^"
; @XURET@(#)="200;53.1^AUTHORIZED TO WRITE MED ORDERS^^^"
; @XURET@(#)="200;53.11^DETOX/MAINTENANCE ID NUMBER^^^"
; @XURET@(#)="200;53.2^DEA#^^^"
; @XURET@(#)="200;747.44^DEA EXPIRATION DATE^^^"
; @XURET@(#)="200;53.4^INACTIVE DATE^^^"
; @XURET@(#)="200;53.5^PROVIDER CLASS^^^"
; @XURET@(#)="200;53.6^PROVIDER TYPE^^^"
; @XURET@(#)="200;53.9^REMARKS^^^"
; @XURET@(#)="200;53.91^NON-VA PRESCRIBER^^^"
; @XURET@(#)="200;53.92^TAX ID^^^"
; @XURET@(#)="200;55.1^SCHEDULE II NARCOTIC^^^"
; @XURET@(#)="200;55.2^SCHEDULE II NON-NARCOTIC^^^"
; @XURET@(#)="200;55.3^SCHEDULE III NARCOTIC^^^"
; @XURET@(#)="200;55.4^SCHEDULE III NON-NARCOTIC^^^"
; @XURET@(#)="200;55.5^SCHEDULE IV^^^"
; @XURET@(#)="200;55.6^SCHEDULE V^^^"
;
; **The following are ONLY returned if patch
; **XU*8.0*688 has been installed.
; **Subscript Counter (#) will denote the DEA Data that belongs to the DEA NUMBER subscript
; ** New DEA Data will always follow the DEA NUMBER entry!
; @XURET@(#)="200;9001^DETOX CALCULATED^^^"
; @XURET@(#)="200;53.21;.01;8991.9^DEA NUMBER^<1-n>^^"
; @XURET@(#)="200;53.21;.02^INDIVIDUAL DEA SUFFIX^<#>^^"
; **Only returned if there is a DEA NUMBER (200.5321) value!!**
; @XURET@(#)="8991.9;.02^BUSINESS ACTIVITY CODE^<#>^^"
; @XURET@(#)="8991.9;.03^DETOX NUMBER^<#>^^"
; @XURET@(#)="8991.9;.04^EXPIRATION DATE^<#>^^"
; @XURET@(#)="8991.9;.06^USE FOR INPATIENT ORDERS?^<#>^^"
; @XURET@(#)="8991.9;.07^TYPE^<#>^^"
; @XURET@(#)="8991.9;1.1^NAME (PROVIDER OR INSTITUTION)^<#>^^"
; @XURET@(#)="8991.9;1.2^STREET ADDRESS 1^<#>^^"
; @XURET@(#)="8991.9;1.3^STREET ADDRESS 2^<#>^^"
; @XURET@(#)="8991.9;1.4^STREET ADDRESS 3^<#>^^"
; @XURET@(#)="8991.9;1.5^CITY^<#>^^"
; @XURET@(#)="8991.9;1.6^STATE^<#>^^"
; @XURET@(#)="8991.9;1.7^ZIP CODE^<#>^^"
; @XURET@(#)="8991.9;2.1^SCHEDULE II NARCOTIC?^<#>^^"
; @XURET@(#)="8991.9;2.2^SCHEDULE II NON-NARCOTIC?^<#>^^"
; @XURET@(#)="8991.9;2.3^SCHEDULE III NARCOTIC?^<#>^^"
; @XURET@(#)="8991.9;2.4^SCHEDULE III NON-NARCOTIC?^<#>^^"
; @XURET@(#)="8991.9;2.5^SCHEDULE IV?^<#>^^"
; @XURET@(#)="8991.9;2.6^SCHEDULE V?^<#>^^"
; @XURET@(#)="8991.9;10.1^LAST UPDATED BY^<#>^^"
; @XURET@(#)="8991.9;10.2^LAST UPDATED DATE/TIME^<#>^^"
; @XURET@(#)="8991.9;10.3^LAST DOJ UPDATE DATE/TIME^<#>^^"
;
; Fail:
; XURET = ^TMP("XUMVINPU",$J)
; @XURET@(1)="-1^Invalid User"
; or
; @XURET@(1)="-1^No Data for User: ######"
;
; Example calling rpc from VistA:
; >D GET^XUMVINPU(.XURET,12596)
; >ZW XURET
; >XURET="^TMP(""XUMVINPU"",17226)"
;
; D ^%G would return:
; ^TMP("XUMVINPU",17226,1)="200;IEN^DUZ^12596^12596"
; 2)="200;.01^NAME^LAST,FIRST^LAST,FIRST"
; 3)="200;7^DISUSER^^"
; #)=continuation of returned data
;
; Example calling rpc from MVI:
; D DIRECT^XWB2HL7(.XURET,SITE,"XUS MVI NEW PERSON GET","",$G(XUDUZ),$G(SECID),$G(NPI),$G(SSN))
;
N I,CNT,FILE,FLD,FLDS,FLDCNT,FLDNM,XUARR,XUGBL S XUGBL="^TMP("_"""XUMVINPU"""_","_$J_")",CNT=1,FILE=200 K @XUGBL,XURET
I $G(SECID)'="" S XUDUZ=$O(^VA(FILE,"ASECID",SECID,0))
I $G(NPI)'="" S XUDUZ=$O(^VA(FILE,"ANPI",NPI,0))
I $G(SSN)'="" S XUDUZ=$O(^VA(FILE,"SSN",SSN,0))
I $G(XUDUZ)="" S @XUGBL@(CNT)="-1^Invalid User" S XURET=$NA(@XUGBL) Q
I '$D(^VA(FILE,XUDUZ)) S @XUGBL@(CNT)="-1^No Data for User: "_XUDUZ S XURET=$NA(@XUGBL) Q
S @XUGBL@(CNT)=FILE_";IEN^DUZ^^"_XUDUZ_"^"_XUDUZ S CNT=CNT+1
S FLDS=".01;4;5;8;7;9.2;9.4;15;11.2;.111;.112;.113;.114;.115;.116;.132;.136;.151;30;31;41.98;41.99;9;42*;101.13*;202;202.02;202.03;"
S FLDS=FLDS_"202.04;202.05;16*;10.1;29;201;203*;51*;205.1;205.2;205.3;205.4;205.5;501.1;8932.1*;53.1;53.11;53.2;"
S FLDS=FLDS_"747.44;53.4;53.5;53.6;53.9;53.91;53.92;55.1;55.2;55.3;55.4;55.5;55.6"
S:($$PATCH^XPDUTL("XU*8.0*688")) FLDS=FLDS_";9001;53.21*" ;NEW DETOX CALCULATED and DEA #'S multiple | DBIA #10141 (Supported)
S FLDCNT=$L(FLDS,";") D GETS^DIQ(FILE,+XUDUZ_",",FLDS,"EI","XUARR") ;retrieve data
F I=1:1:FLDCNT D
.S FLD=$P($P(FLDS,";",I),"*") D FIELD^DID(FILE,FLD,"","LABEL","FLDNM")
.I FLD=16 D Q ;division multiple
..N IENS,MCNT,SUBFILE,SUBFLD S MCNT=1,SUBFILE=200.02,SUBFLD=.01 D FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
..I '$D(XUARR(SUBFILE)) S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^^" S CNT=CNT+1 Q
..S IENS="" F S IENS=$O(XUARR(SUBFILE,IENS)) Q:IENS="" S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$G(XUARR(SUBFILE,IENS,SUBFLD,"I"))_"^"_$G(XUARR(SUBFILE,IENS,SUBFLD,"E")) S MCNT=MCNT+1,CNT=CNT+1
.I FLD=10.1 D Q ;name components
..S @XUGBL@(CNT)=FILE_";"_FLD_"^"_(FLDNM("LABEL"))_"^^"_$G(XUARR(FILE,XUDUZ_",",FLD,"I"))_"^"_$G(XUARR(FILE,XUDUZ_",",FLD,"E")) S CNT=CNT+1
..N NCFILE,NCFLD S NCFILE=20 D GETS^DIQ(NCFILE,+$G(XUARR(FILE,XUDUZ_",",FLD,"I"))_",","1;2;3;4;5;6","EI","XUARR") ;retrieve name component data
..F NCFLD=1,2,3,4,5,6 D
...D FIELD^DID(NCFILE,NCFLD,"","LABEL","FLDNM")
...S @XUGBL@(CNT)=NCFILE_";"_NCFLD_"^"_(FLDNM("LABEL"))_"^^"_$G(XUARR(NCFILE,+$G(XUARR(FILE,XUDUZ_",",FLD,"I"))_",",NCFLD,"I"))_"^"_$G(XUARR(NCFILE,+$G(XUARR(FILE,XUDUZ_",",FLD,"I"))_",",NCFLD,"E")) S CNT=CNT+1
.I FLD=42 D Q ;**732,Story 1204309 (mko): EFFECTIVE DATE/TIME (#42) (Multiple-200.042)
..N IENS,MCNT,SUBFILE,SUBFLD S MCNT=1,SUBFILE=200.042
..I '$D(XUARR(SUBFILE)) D Q ;No EFFECTIVE DATE/TIME
...F SUBFLD=.01,.02,.03 D
....D FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM") S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_FLDNM("LABEL")_"^"_MCNT_"^^",CNT=CNT+1
..S IENS="" F S IENS=$O(XUARR(SUBFILE,IENS)) Q:IENS="" D
...F SUBFLD=.01,.02,.03 D
....D FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
....S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_FLDNM("LABEL")_"^"_MCNT_"^"_$G(XUARR(SUBFILE,IENS,SUBFLD,"I"))_"^"_$G(XUARR(SUBFILE,IENS,SUBFLD,"E")),CNT=CNT+1
...S MCNT=MCNT+1
.I FLD=51 D Q ;KEYS multiple
..N IENS,MCNT,SUBFILE,SUBFLD S MCNT=1,SUBFILE=200.051,SUBFLD=.01 D FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
..I '$D(XUARR(SUBFILE)) S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^^",CNT=CNT+1 Q
..S IENS="" F S IENS=$O(XUARR(SUBFILE,IENS)) Q:IENS="" S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$G(XUARR(SUBFILE,IENS,SUBFLD,"I"))_"^"_$G(XUARR(SUBFILE,IENS,SUBFLD,"E")),MCNT=MCNT+1,CNT=CNT+1
.I FLD=53.21 D Q ;NEW DEA #'s multiple
..N I,IEN,IENS,MCNT,SUBFILE,SUBFLD,DEAARR,DEAFILE,DEAFLD,DEAFLDS,DEAFLDCNT S MCNT=1,SUBFILE=200.5321,SUBFLD=.01,DEAFILE=8991.9
..D FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
..I '$D(XUARR(SUBFILE)) D Q
...S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_";8991.9^"_(FLDNM("LABEL"))_"^"_MCNT_"^^",CNT=CNT+1 D FIELD^DID(SUBFILE,.02,"","LABEL","FLDNM")
...S @XUGBL@(CNT)=FILE_";"_FLD_";"_.02_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^^",CNT=CNT+1
..S DEAFLDS=".02;.03;.04;.06;.07;1.1;1.2;1.3;1.4;1.5;1.6;1.7;2.1;2.2;2.3;2.4;2.5;2.6;10.1;10.2;10.3",DEAFLDCNT=$L(DEAFLDS,";")
..S IENS="" F S IENS=$O(XUARR(SUBFILE,IENS)) Q:IENS="" D
...S IEN=$G(XUARR(SUBFILE,IENS,.03,"I")) D FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
...S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_";8991.9^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_IEN_"^"_$G(XUARR(SUBFILE,IENS,.03,"E")),CNT=CNT+1
...D FIELD^DID(SUBFILE,.02,"","LABEL","FLDNM")
...S @XUGBL@(CNT)=FILE_";"_FLD_";.02^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$G(XUARR(SUBFILE,IENS,.02,"I"))_"^"_$G(XUARR(SUBFILE,IENS,.02,"E")),CNT=CNT+1
...D GETS^DIQ(DEAFILE,IEN_",",DEAFLDS,"EI","DEAARR") ;retrieve DEA data
...F I=1:1:DEAFLDCNT D
....S DEAFLD=$P(DEAFLDS,";",I) D FIELD^DID(DEAFILE,DEAFLD,"","LABEL","FLDNM")
....S @XUGBL@(CNT)=DEAFILE_";"_DEAFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$G(DEAARR(DEAFILE,IEN_",",DEAFLD,"I"))_"^"_$G(DEAARR(DEAFILE,IEN_",",DEAFLD,"E")),CNT=CNT+1
...S MCNT=MCNT+1
.I FLD=101.13 D Q ;CPRS TAB multiple ;**733 - STORY 1291666 (dri) add field 101.13
..N IENS,MCNT,SUBFILE,SUBFLD S MCNT=1,SUBFILE=200.010113 I '$D(XUARR(SUBFILE)) D Q ;No CPRS TAB
...F SUBFLD=.01,.03,.03 D
....D FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM") S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^^",CNT=CNT+1
..S IENS="" F S IENS=$O(XUARR(SUBFILE,IENS)) Q:IENS="" D
...F SUBFLD=.01,.02,.03 D
....D FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
....S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$G(XUARR(SUBFILE,IENS,SUBFLD,"I"))_"^"_$G(XUARR(SUBFILE,IENS,SUBFLD,"E")),CNT=CNT+1
...S MCNT=MCNT+1
.I FLD=203 D Q ;secondary menu options multiple
..N IENS,MCNT,SUBFILE,SUBFLD S MCNT=1,SUBFILE=200.03,SUBFLD=.01 D FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
..I '$D(XUARR(SUBFILE)) S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^^" S CNT=CNT+1 Q
..S IENS="" F S IENS=$O(XUARR(SUBFILE,IENS)) Q:IENS="" S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$G(XUARR(SUBFILE,IENS,SUBFLD,"I"))_"^"_$G(XUARR(SUBFILE,IENS,SUBFLD,"E")) S MCNT=MCNT+1,CNT=CNT+1
.I FLD=8932.1 D Q ;PERSON CLASS multiple
..N IENS,MCNT,SUBFILE,SUBFLD S MCNT=1,SUBFILE=200.05 I '$D(XUARR(SUBFILE)) D Q ;No Person Class(es)
...F SUBFLD=.01,2,3 D
....D FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM") S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^^",CNT=CNT+1
..S IENS="" F S IENS=$O(XUARR(SUBFILE,IENS)) Q:IENS="" D
...F SUBFLD=.01,2,3 D
....D FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
....S @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$G(XUARR(SUBFILE,IENS,SUBFLD,"I"))_"^"_$G(XUARR(SUBFILE,IENS,SUBFLD,"E")),CNT=CNT+1
...S MCNT=MCNT+1
.S @XUGBL@(CNT)=FILE_";"_FLD_"^"_(FLDNM("LABEL"))_"^^"_XUARR(FILE,XUDUZ_",",FLD,"I")_"^"_XUARR(FILE,XUDUZ_",",FLD,"E") S CNT=CNT+1 ;all other fields
S XURET=$NA(@XUGBL)
Q
;
UPDATE(XURET,XUARR) ;rpc to update new person file data
; called from rpc: XUS MVI NEW PERSON UPDATE
; Input:
; XUARR(#) = FILE #;FIELD #<SUBFIELD #><FILE POINTER>^FIELD NAME^<COUNTER #>^INTERNAL VALUE^EXTERNAL VALUE
; <> Denotes optional values. If Counter populated, denotes multiple value <1-n>.
; XUARR(0)="200;IEN^DUZ^^^"
; XUARR(#)="200;.01^NAME^^^"
; XUARR(#)="200;205.1^SECID^^"
; XUARR(#)="200;205.2^SUBJECT ORGANIZATION^^^"
; XUARR(#)="200;205.3^SUBJECT ORGANIZATION ID^^^"
; XUARR(#)="200;205.4^UNIQUE USER ID^^^"
; XUARR(#)="200;205.5^ADUPN^^^"
; **711, Story 977821 (jfw) - Allow additional fields to be updated.
; XUARR(#)="200;.151^EMAIL ADDRESS^^^"
; XUARR(#)="200;501.1^NETWORK USERNAME^^^"
; **710, Story 1100018 (jfw) - Add NPI field to be updated.
; XUARR(#)="200;41.99^NPI^^^"
; **732,Story 1204309 (mko): Add NPI ENTRY STATUS (#41.98)
; XUARR(#)=200;41.98^NPI ENTRY STATUS^^<value>
; **732, story 1278983 (cmc) add EFFECTIVE DATE (#42) MULTIPLE
; XUARR(#)="200;42;.01^EFFECTIVE DATE/TIME^<#>^^"
; XUARR(#)="200;42;.02^STATUS^<#>^^"
; XUARR(#)="200;42;.03^NPI^<#>^^"
; Success:
; XURET(0) = 1
; Fail:
; XURET(0) = "-1^No data passed"
; XURET(0) = "-1^Invalid User DUZ (null)"
; XURET(0) = "-1^User '"_XUDUZ_"' does not exist"
; XURET(0) = "-1^Invalid Name Component IEN"
; XURET(0) = "-1^No Data for Name Component IEN: "_NCIEN
; XURET(0) = "-1^No data to file for record '"_XUDUZ_"' in file 200"
; XURET(0) = "-1^Unable to lock record '"_XUDUZ_"' in file 200"
; XURET(0) = "-1^"_$G(XUERR("DIERR",1,"TEXT",1))
;
; Example calling rpc from VistA:
; >D UPDATE^XUMVINPU(.XURET,.XUARR)
; >ZW XURET
; >XURET(0)=1
; Example calling rpc from MVI:
; D DIRECT^XWB2HL7(.XURET,SITE,"XUS MVI NEW PERSON UPDATE","",.XUARR)
K XURET N ARR,FILENUM,FLDNAM,FLDNUM,IDATA,NCIEN,NPIIN,NPIERR,NPINEW,XUDUZ,XUERR,XUFDA S ARR="XUARR"
I '$D(XUARR) S XURET(0)="-1^No data passed" Q
F S ARR=$Q(@ARR) Q:ARR="" S FILENUM=+$P($P(@ARR,"^",1),";",1),FLDNUM=+$P($P(@ARR,"^",1),";",2),FLDNAM=$P(@ARR,"^",2),IDATA=$P(@ARR,"^",4) D I $G(XURET(0))<0 Q
. I FLDNAM="DUZ" D Q ;first parameter passed
. . S XUDUZ=IDATA ;duz ien
. . I $G(XUDUZ)="" S XURET(0)="-1^Invalid User DUZ (null)" Q
. . I '$D(^VA(FILENUM,XUDUZ,0)) S XURET(0)="-1^User '"_XUDUZ_"' does not exist" Q
. I FLDNAM="NAME COMPONENTS" D Q
. . S NCIEN=IDATA ;name component ien
. . I $G(NCIEN)="" S XURET(0)="-1^Invalid Name Component IEN"
. . I '$D(^VA(20,NCIEN,0)) S XURET(0)="-1^No Data for Name Components IEN: "_NCIEN
. ;**732,Story 1204309 (mko): If NPI is passed, not null, and doesn't yet exist
. ; in the EFFECTIVE DATE/TIME multiple, add it, and let the "AC" xref update
. ; the single-valued fields AUTHORIZE RELEASE OF NPI (#41.97), NPI ENTRY STATUS (#41.98), and NPI (#41.99) at the top file level.
. ; IF NPI IS NOT BEING DELETED BUT ADDING A VALUE
. I FLDNAM="NPI",IDATA'="@" D Q
. . N IENS,ERR,XUFDA,DIERR,DIHELP,DIMSG S NPIIN=IDATA
. . Q:IDATA="" Q:$O(^VA(200,XUDUZ,"NPISTATUS","C",IDATA,""))
. . S NPINEW=1,IENS="+1,"_XUDUZ_",",XUFDA(200.042,IENS,.01)="NOW",XUFDA(200.042,IENS,.02)=1,XUFDA(200.042,IENS,.03)=IDATA
. . D UPDATE^DIE("E","XUFDA","","ERR") S:$G(DIERR) NPIERR=$$BLDERR("ERR")
. I FLDNAM="NPI",IDATA="@" D Q
. . S XUFDA(200,XUDUZ_",",41.99)=IDATA,XUFDA(200,XUDUZ_",",41.98)=IDATA
. . ;GET NPI TO BE DELETED FROM ARR(X+1)
. . S ARR=$Q(@ARR) S NPI=$P(@ARR,"^",3) I $O(^VA(200,XUDUZ,"NPISTATUS","C",NPI,"")) S IENS=$O(^VA(200,XUDUZ,"NPISTATUS","C",NPI,""))_","_XUDUZ_",",XUFDA(200.042,IENS,.01)="@" ;**663 - STORY 783347 (dri) add check of npi in effective date mult
. . ;**799 VAMPI-22625
. S XUFDA(FILENUM,$S(FILENUM=200:+$G(XUDUZ),1:+$G(NCIEN))_",",FLDNUM)=IDATA
Q:$G(XURET(0))<0
I '$G(NPINEW),'$D(XUFDA) S XURET(0)="-1^No data to file for record '"_XUDUZ_"' in file 200" Q
;**732,Story 1204309 (mko): If NPI (#41.99) is not the NPI coming in, don't update NPI ENTRY STATUS (#41.98)
I $G(NPIIN)]"",$P($G(^VA(200,XUDUZ,"NPI")),U)'=NPIIN K XUFDA(200,XUDUZ_",",41.98)
;**732,Story 1204309 (mko): File the Name first (Within a FILE^DIE call,
; triggers on the .01 that in turn call FILE^DIE may cause the Filer flag to change from "E", to "". FDA must be also be namespaced)
I $D(XUFDA(200,XUDUZ_",",.01))#2 D Q:$G(XURET(0))["Unable to lock record"
. N NAMEFDA S NAMEFDA(200,XUDUZ_",",.01)=XUFDA(200,XUDUZ_",",.01) D FILER(XUDUZ,.NAMEFDA,.XURET) K XUFDA(200,XUDUZ_",",.01)
;**732,Story 1204309 (mko): Move code to call Filer to subroutine
D FILER(XUDUZ,.XUFDA,.XURET) Q:$G(XURET(0))["Unable to lock record"
;**732,Story 1204309 (mko): Add NPIERR to XURET(0)
S:$G(NPIERR)]"" XURET(0)=$$ADDERR(XURET(0),NPIERR)
;Return 1 in first piece to indicate Filer/Updater calls were made. If errors, also return -1^errMsg in 2nd and 3rd pieces.
S XURET(0)=1_$S($G(XURET(0))<0:U_XURET(0),1:"")
Q
;
FILER(XUDUZ,XUMVIFDA,XURET) ;Call the Filer
;**732,Story 1204309 (mko): Move the code to call the Filer into a separate subroutine, since it is called multiple times.
N DIERR,DIHELP,DIMSG,XUERR
Q:'$G(XUDUZ) Q:'$D(XUMVIFDA)
L +^VA(200,XUDUZ):10 I '$T S XURET(0)="-1^Unable to lock record '"_XUDUZ_"' in file 200" Q
;**710, Story 1100018 (jfw) - Process fields as External Values now so Input Transform checks fire
;**732,Story 1204309 (mko): Unlock the record before checking for DIERR
D FILE^DIE("E","XUMVIFDA","XUERR") L -^VA(200,XUDUZ)
;**732,Story 1204309 (mko): Put all error messages into XURET(0)
S:$G(DIERR) XURET(0)=$$ADDERR($G(XURET(0)),$$BLDERR("XUERR"))
Q
;
ADDERR(RET,MSG) ;Return RET with MSG appended to it, and 1st piece equal to -1
Q:$G(MSG)="" $G(RET)
Q $S($G(RET)]"":RET_" ",1:"-1^")_MSG
;
BLDERR(INROOT) ;Build a string containing error messages returned by FileMan
N ERRSTR,I,XUERMSGS D MSG^DIALOG("AE",.XUERMSGS,"","",$G(INROOT))
S ERRSTR="",I=0 F S I=$O(XUERMSGS(I)) Q:'I S:XUERMSGS(I)]"" ERRSTR=ERRSTR_$E(" ",ERRSTR]"")_XUERMSGS(I)
Q ERRSTR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMVINPU 19596 printed Sep 23, 2025@19:47:34 Page 2
XUMVINPU ;MVI/DRI - Master Veteran Index New Person Utilities ;10/23/20 16:40
+1 ;;8.0;KERNEL;**691,711,710,732,733,799**;Jul 10, 1995;Build 3
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**711, Story 977780 (jfw)
+5 ;**732, Story 1204309 (mko)
+6 ;**733, Story 1291666 (dri)
+7 ;**799 VAMPI-22625
+8 ;
GET(XURET,XUDUZ,SECID,NPI,SSN) ;rpc to retrieve new person file data
+1 ; called from rpc: XUS MVI NEW PERSON GET
+2 ; Input (ONE of the following):
+3 ; XUDUZ = NEW PERSON IEN SECID=SECURITY ID NPI=NATIONAL PROVIDER IDENTIFIER SSN=SOCIAL SECURITY NUMBER
+4 ; Output:
+5 ; Success: XURET = ^TMP("XUMVINPU",$J)
+6 ; @XURET@(#) = FILE #;FIELD #<SUBFIELD #><FILE POINTER>^FIELD NAME^<COUNTER #>^INTERNAL VALUE^EXTERNAL VALUE
+7 ; <> Denotes optional values. If Counter populated, denotes multiple value <1-n>.
+8 ; @XURET@(#)="200;IEN^DUZ^^^"
+9 ; @XURET@(#)="200;.01^NAME^^^"
+10 ; @XURET@(#)="200;4^SEX^^^"
+11 ; @XURET@(#)="200;5^DOB^^^" ;**732,1204309 (mko): Return DOB
+12 ; @XURET@(#)="200;8^TITLE^^^"
+13 ; @XURET@(#)="200;7^DISUSER^^^"
+14 ; @XURET@(#)="200;9.2^TERMINATION DATE^^^"
+15 ; @XURET@(#)="200;9.4^Termination Reason^^^"
+16 ; @XURET@(#)="200;15^PROHIBITED TIMES FOR SIGN-ON^^^"
+17 ; @XURET@(#)="200;11.2^DATE VERIFY CODE LAST CHANGED^^^"
+18 ; @XURET@(#)="200;.111^STREET ADDRESS 1^^^"
+19 ; @XURET@(#)="200;.112^STREET ADDRESS 2^^^"
+20 ; @XURET@(#)="200;.113^STREET ADDRESS 3^^^"
+21 ; @XURET@(#)="200;.114^CITY^^^"
+22 ; @XURET@(#)="200;.115^STATE^^^"
+23 ; @XURET@(#)="200;.116^ZIP CODE^^^"
+24 ; @XURET@(#)="200;.132^OFFICE PHONE^^^"
+25 ; @XURET@(#)="200;.136^FAX NUMBER^^^"
+26 ; @XURET@(#)="200;.151^EMAIL ADDRESS^^^"
+27 ; @XURET@(#)="200;30^DATE ENTERED^^^"
+28 ; @XURET@(#)="200;31^CREATOR^^^"
+29 ; @XURET@(#)="200;41.98^NPI ENTRY STATUS^^"
+30 ; @XURET@(#)="200;41.99^NPI^^^"
+31 ; @XURET@(#)="200;9^SSN^^^"
+32 ; @XURET@(#)="200;42;.01^EFFECTIVE DATE/TIME^<#>^^"
+33 ; @XURET@(#)="200;42;.02^STATUS^<#>^^"
+34 ; @XURET@(#)="200;42;.03^NPI^<#>^^"
+35 ; @XURET@(#)="200;101.13;.01^CPRS TAB^<#>^^"
+36 ; @XURET@(#)="200;101.13;.02^EFFECTIVE DATE^<#>^^"
+37 ; @XURET@(#)="200;101.13;.03^EXPIRATION DATE^<#>^^"
+38 ; @XURET@(#)="200;202^LAST SIGN-ON DATE/TIME^^^"
+39 ; @XURET@(#)="200;202.02^XUS Logon Attempt Count^^^"
+40 ; @XURET@(#)="200;202.03^XUS Active User^^^"
+41 ; @XURET@(#)="200;202.04^Entry Last Edit Date^^^"
+42 ; @XURET@(#)="200;202.05^LOCKOUT USER UNTIL^^^"
+43 ; @XURET@(#)="200;16;.01^DIVISION^<1-n>^^"
+44 ; @XURET@(#)="200;10.1^NAME COMPONENTS^^^"
+45 ; @XURET@(#)="20;1^FAMILY (LAST) NAME^^^"
+46 ; @XURET@(#)="20;2^GIVEN (FIRST) NAME^^^"
+47 ; @XURET@(#)="20;3^MIDDLE NAME^^^"
+48 ; @XURET@(#)="20;4^PREFIX^^^"
+49 ; @XURET@(#)="20;5^SUFFIX^^^"
+50 ; @XURET@(#)="20;6^DEGREE^^^"
+51 ; @XURET@(#)="200;29^SERVICE/SECTION^^^"
+52 ; @XURET@(#)="200;201^PRIMARY MENU OPTION^^^"
+53 ; @XURET@(#)="200;203;.01^SECONDARY MENU OPTIONS^<1-n>^^"
+54 ; @XURET@(#)="200;51;.01^KEYS^<1-n>^^"
+55 ; @XURET@(#)="200;205.1^SECID^^^"
+56 ; @XURET@(#)="200;205.2^SUBJECT ORGANIZATION^^^"
+57 ; @XURET@(#)="200;205.3^SUBJECT ORGANIZATION ID^^^"
+58 ; @XURET@(#)="200;205.4^UNIQUE USER ID^^^"
+59 ; @XURET@(#)="200;205.5^ADUPN^^^"
+60 ; @XURET@(#)="200;501.1^NETWORK USERNAME^^^"
+61 ; @XURET@(#)="200;8932.1;.01^PERSON CLASS^<1-n>^^"
+62 ; @XURET@(#)="200;8932.1;2^EFFECTIVE DATE^<#>^^"
+63 ; @XURET@(#)="200;8932.1;3^EXPIRATION DATE^<#>^^"
+64 ; @XURET@(#)="200;53.1^AUTHORIZED TO WRITE MED ORDERS^^^"
+65 ; @XURET@(#)="200;53.11^DETOX/MAINTENANCE ID NUMBER^^^"
+66 ; @XURET@(#)="200;53.2^DEA#^^^"
+67 ; @XURET@(#)="200;747.44^DEA EXPIRATION DATE^^^"
+68 ; @XURET@(#)="200;53.4^INACTIVE DATE^^^"
+69 ; @XURET@(#)="200;53.5^PROVIDER CLASS^^^"
+70 ; @XURET@(#)="200;53.6^PROVIDER TYPE^^^"
+71 ; @XURET@(#)="200;53.9^REMARKS^^^"
+72 ; @XURET@(#)="200;53.91^NON-VA PRESCRIBER^^^"
+73 ; @XURET@(#)="200;53.92^TAX ID^^^"
+74 ; @XURET@(#)="200;55.1^SCHEDULE II NARCOTIC^^^"
+75 ; @XURET@(#)="200;55.2^SCHEDULE II NON-NARCOTIC^^^"
+76 ; @XURET@(#)="200;55.3^SCHEDULE III NARCOTIC^^^"
+77 ; @XURET@(#)="200;55.4^SCHEDULE III NON-NARCOTIC^^^"
+78 ; @XURET@(#)="200;55.5^SCHEDULE IV^^^"
+79 ; @XURET@(#)="200;55.6^SCHEDULE V^^^"
+80 ;
+81 ; **The following are ONLY returned if patch
+82 ; **XU*8.0*688 has been installed.
+83 ; **Subscript Counter (#) will denote the DEA Data that belongs to the DEA NUMBER subscript
+84 ; ** New DEA Data will always follow the DEA NUMBER entry!
+85 ; @XURET@(#)="200;9001^DETOX CALCULATED^^^"
+86 ; @XURET@(#)="200;53.21;.01;8991.9^DEA NUMBER^<1-n>^^"
+87 ; @XURET@(#)="200;53.21;.02^INDIVIDUAL DEA SUFFIX^<#>^^"
+88 ; **Only returned if there is a DEA NUMBER (200.5321) value!!**
+89 ; @XURET@(#)="8991.9;.02^BUSINESS ACTIVITY CODE^<#>^^"
+90 ; @XURET@(#)="8991.9;.03^DETOX NUMBER^<#>^^"
+91 ; @XURET@(#)="8991.9;.04^EXPIRATION DATE^<#>^^"
+92 ; @XURET@(#)="8991.9;.06^USE FOR INPATIENT ORDERS?^<#>^^"
+93 ; @XURET@(#)="8991.9;.07^TYPE^<#>^^"
+94 ; @XURET@(#)="8991.9;1.1^NAME (PROVIDER OR INSTITUTION)^<#>^^"
+95 ; @XURET@(#)="8991.9;1.2^STREET ADDRESS 1^<#>^^"
+96 ; @XURET@(#)="8991.9;1.3^STREET ADDRESS 2^<#>^^"
+97 ; @XURET@(#)="8991.9;1.4^STREET ADDRESS 3^<#>^^"
+98 ; @XURET@(#)="8991.9;1.5^CITY^<#>^^"
+99 ; @XURET@(#)="8991.9;1.6^STATE^<#>^^"
+100 ; @XURET@(#)="8991.9;1.7^ZIP CODE^<#>^^"
+101 ; @XURET@(#)="8991.9;2.1^SCHEDULE II NARCOTIC?^<#>^^"
+102 ; @XURET@(#)="8991.9;2.2^SCHEDULE II NON-NARCOTIC?^<#>^^"
+103 ; @XURET@(#)="8991.9;2.3^SCHEDULE III NARCOTIC?^<#>^^"
+104 ; @XURET@(#)="8991.9;2.4^SCHEDULE III NON-NARCOTIC?^<#>^^"
+105 ; @XURET@(#)="8991.9;2.5^SCHEDULE IV?^<#>^^"
+106 ; @XURET@(#)="8991.9;2.6^SCHEDULE V?^<#>^^"
+107 ; @XURET@(#)="8991.9;10.1^LAST UPDATED BY^<#>^^"
+108 ; @XURET@(#)="8991.9;10.2^LAST UPDATED DATE/TIME^<#>^^"
+109 ; @XURET@(#)="8991.9;10.3^LAST DOJ UPDATE DATE/TIME^<#>^^"
+110 ;
+111 ; Fail:
+112 ; XURET = ^TMP("XUMVINPU",$J)
+113 ; @XURET@(1)="-1^Invalid User"
+114 ; or
+115 ; @XURET@(1)="-1^No Data for User: ######"
+116 ;
+117 ; Example calling rpc from VistA:
+118 ; >D GET^XUMVINPU(.XURET,12596)
+119 ; >ZW XURET
+120 ; >XURET="^TMP(""XUMVINPU"",17226)"
+121 ;
+122 ; D ^%G would return:
+123 ; ^TMP("XUMVINPU",17226,1)="200;IEN^DUZ^12596^12596"
+124 ; 2)="200;.01^NAME^LAST,FIRST^LAST,FIRST"
+125 ; 3)="200;7^DISUSER^^"
+126 ; #)=continuation of returned data
+127 ;
+128 ; Example calling rpc from MVI:
+129 ; D DIRECT^XWB2HL7(.XURET,SITE,"XUS MVI NEW PERSON GET","",$G(XUDUZ),$G(SECID),$G(NPI),$G(SSN))
+130 ;
+131 NEW I,CNT,FILE,FLD,FLDS,FLDCNT,FLDNM,XUARR,XUGBL
SET XUGBL="^TMP("_"""XUMVINPU"""_","_$JOB_")"
SET CNT=1
SET FILE=200
KILL @XUGBL,XURET
+132 IF $GET(SECID)'=""
SET XUDUZ=$ORDER(^VA(FILE,"ASECID",SECID,0))
+133 IF $GET(NPI)'=""
SET XUDUZ=$ORDER(^VA(FILE,"ANPI",NPI,0))
+134 IF $GET(SSN)'=""
SET XUDUZ=$ORDER(^VA(FILE,"SSN",SSN,0))
+135 IF $GET(XUDUZ)=""
SET @XUGBL@(CNT)="-1^Invalid User"
SET XURET=$NAME(@XUGBL)
QUIT
+136 IF '$DATA(^VA(FILE,XUDUZ))
SET @XUGBL@(CNT)="-1^No Data for User: "_XUDUZ
SET XURET=$NAME(@XUGBL)
QUIT
+137 SET @XUGBL@(CNT)=FILE_";IEN^DUZ^^"_XUDUZ_"^"_XUDUZ
SET CNT=CNT+1
+138 SET FLDS=".01;4;5;8;7;9.2;9.4;15;11.2;.111;.112;.113;.114;.115;.116;.132;.136;.151;30;31;41.98;41.99;9;42*;101.13*;202;202.02;202.03;"
+139 SET FLDS=FLDS_"202.04;202.05;16*;10.1;29;201;203*;51*;205.1;205.2;205.3;205.4;205.5;501.1;8932.1*;53.1;53.11;53.2;"
+140 SET FLDS=FLDS_"747.44;53.4;53.5;53.6;53.9;53.91;53.92;55.1;55.2;55.3;55.4;55.5;55.6"
+141 ;NEW DETOX CALCULATED and DEA #'S multiple | DBIA #10141 (Supported)
if ($$PATCH^XPDUTL("XU*8.0*688"))
SET FLDS=FLDS_";9001;53.21*"
+142 ;retrieve data
SET FLDCNT=$LENGTH(FLDS,";")
DO GETS^DIQ(FILE,+XUDUZ_",",FLDS,"EI","XUARR")
+143 FOR I=1:1:FLDCNT
Begin DoDot:1
+144 SET FLD=$PIECE($PIECE(FLDS,";",I),"*")
DO FIELD^DID(FILE,FLD,"","LABEL","FLDNM")
+145 ;division multiple
IF FLD=16
Begin DoDot:2
+146 NEW IENS,MCNT,SUBFILE,SUBFLD
SET MCNT=1
SET SUBFILE=200.02
SET SUBFLD=.01
DO FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
+147 IF '$DATA(XUARR(SUBFILE))
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^^"
SET CNT=CNT+1
QUIT
+148 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SUBFILE,IENS))
if IENS=""
QUIT
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$GET(XUARR(SUBFILE,IENS,SUBFLD,"I"))_"^"_$GET(XUARR(SUBFILE,IENS,SUBFLD,"E"))
SET MCNT=MCNT+1
SET CNT=CNT+1
End DoDot:2
QUIT
+149 ;name components
IF FLD=10.1
Begin DoDot:2
+150 SET @XUGBL@(CNT)=FILE_";"_FLD_"^"_(FLDNM("LABEL"))_"^^"_$GET(XUARR(FILE,XUDUZ_",",FLD,"I"))_"^"_$GET(XUARR(FILE,XUDUZ_",",FLD,"E"))
SET CNT=CNT+1
+151 ;retrieve name component data
NEW NCFILE,NCFLD
SET NCFILE=20
DO GETS^DIQ(NCFILE,+$GET(XUARR(FILE,XUDUZ_",",FLD,"I"))_",","1;2;3;4;5;6","EI","XUARR")
+152 FOR NCFLD=1,2,3,4,5,6
Begin DoDot:3
+153 DO FIELD^DID(NCFILE,NCFLD,"","LABEL","FLDNM")
+154 SET @XUGBL@(CNT)=NCFILE_";"_NCFLD_"^"_(FLDNM("LABEL"))_"^^"_$GET(XUARR(NCFILE,+$GET(XUARR(FILE,XUDUZ_",",FLD,"I"))_",",NCFLD,"I"))_"^"_$GET(XUARR(NCFILE,+$GET(XUARR(FILE,XUDUZ_",",FLD,"I"))_",",NCFLD,"E"))
SET CNT=CNT+1
End DoDot:3
End DoDot:2
QUIT
+155 ;**732,Story 1204309 (mko): EFFECTIVE DATE/TIME (#42) (Multiple-200.042)
IF FLD=42
Begin DoDot:2
+156 NEW IENS,MCNT,SUBFILE,SUBFLD
SET MCNT=1
SET SUBFILE=200.042
+157 ;No EFFECTIVE DATE/TIME
IF '$DATA(XUARR(SUBFILE))
Begin DoDot:3
+158 FOR SUBFLD=.01,.02,.03
Begin DoDot:4
+159 DO FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_FLDNM("LABEL")_"^"_MCNT_"^^"
SET CNT=CNT+1
End DoDot:4
End DoDot:3
QUIT
+160 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SUBFILE,IENS))
if IENS=""
QUIT
Begin DoDot:3
+161 FOR SUBFLD=.01,.02,.03
Begin DoDot:4
+162 DO FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
+163 SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_FLDNM("LABEL")_"^"_MCNT_"^"_$GET(XUARR(SUBFILE,IENS,SUBFLD,"I"))_"^"_$GET(XUARR(SUBFILE,IENS,SUBFLD,"E"))
SET CNT=CNT+1
End DoDot:4
+164 SET MCNT=MCNT+1
End DoDot:3
End DoDot:2
QUIT
+165 ;KEYS multiple
IF FLD=51
Begin DoDot:2
+166 NEW IENS,MCNT,SUBFILE,SUBFLD
SET MCNT=1
SET SUBFILE=200.051
SET SUBFLD=.01
DO FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
+167 IF '$DATA(XUARR(SUBFILE))
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^^"
SET CNT=CNT+1
QUIT
+168 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SUBFILE,IENS))
if IENS=""
QUIT
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$GET(XUARR(SUBFILE,IENS,SUBFLD,"I"))_"^"_$GET(XUARR(SUBFILE,IENS,SUBFLD,"E"))
SET MCNT=MCNT+1
SET CNT=CNT+1
End DoDot:2
QUIT
+169 ;NEW DEA #'s multiple
IF FLD=53.21
Begin DoDot:2
+170 NEW I,IEN,IENS,MCNT,SUBFILE,SUBFLD,DEAARR,DEAFILE,DEAFLD,DEAFLDS,DEAFLDCNT
SET MCNT=1
SET SUBFILE=200.5321
SET SUBFLD=.01
SET DEAFILE=8991.9
+171 DO FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
+172 IF '$DATA(XUARR(SUBFILE))
Begin DoDot:3
+173 SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_";8991.9^"_(FLDNM("LABEL"))_"^"_MCNT_"^^"
SET CNT=CNT+1
DO FIELD^DID(SUBFILE,.02,"","LABEL","FLDNM")
+174 SET @XUGBL@(CNT)=FILE_";"_FLD_";"_.02_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^^"
SET CNT=CNT+1
End DoDot:3
QUIT
+175 SET DEAFLDS=".02;.03;.04;.06;.07;1.1;1.2;1.3;1.4;1.5;1.6;1.7;2.1;2.2;2.3;2.4;2.5;2.6;10.1;10.2;10.3"
SET DEAFLDCNT=$LENGTH(DEAFLDS,";")
+176 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SUBFILE,IENS))
if IENS=""
QUIT
Begin DoDot:3
+177 SET IEN=$GET(XUARR(SUBFILE,IENS,.03,"I"))
DO FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
+178 SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_";8991.9^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_IEN_"^"_$GET(XUARR(SUBFILE,IENS,.03,"E"))
SET CNT=CNT+1
+179 DO FIELD^DID(SUBFILE,.02,"","LABEL","FLDNM")
+180 SET @XUGBL@(CNT)=FILE_";"_FLD_";.02^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$GET(XUARR(SUBFILE,IENS,.02,"I"))_"^"_$GET(XUARR(SUBFILE,IENS,.02,"E"))
SET CNT=CNT+1
+181 ;retrieve DEA data
DO GETS^DIQ(DEAFILE,IEN_",",DEAFLDS,"EI","DEAARR")
+182 FOR I=1:1:DEAFLDCNT
Begin DoDot:4
+183 SET DEAFLD=$PIECE(DEAFLDS,";",I)
DO FIELD^DID(DEAFILE,DEAFLD,"","LABEL","FLDNM")
+184 SET @XUGBL@(CNT)=DEAFILE_";"_DEAFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$GET(DEAARR(DEAFILE,IEN_",",DEAFLD,"I"))_"^"_$GET(DEAARR(DEAFILE,IEN_",",DEAFLD,"E"))
SET CNT=CNT+1
End DoDot:4
+185 SET MCNT=MCNT+1
End DoDot:3
End DoDot:2
QUIT
+186 ;CPRS TAB multiple ;**733 - STORY 1291666 (dri) add field 101.13
IF FLD=101.13
Begin DoDot:2
+187 ;No CPRS TAB
NEW IENS,MCNT,SUBFILE,SUBFLD
SET MCNT=1
SET SUBFILE=200.010113
IF '$DATA(XUARR(SUBFILE))
Begin DoDot:3
+188 FOR SUBFLD=.01,.03,.03
Begin DoDot:4
+189 DO FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^^"
SET CNT=CNT+1
End DoDot:4
End DoDot:3
QUIT
+190 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SUBFILE,IENS))
if IENS=""
QUIT
Begin DoDot:3
+191 FOR SUBFLD=.01,.02,.03
Begin DoDot:4
+192 DO FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
+193 SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$GET(XUARR(SUBFILE,IENS,SUBFLD,"I"))_"^"_$GET(XUARR(SUBFILE,IENS,SUBFLD,"E"))
SET CNT=CNT+1
End DoDot:4
+194 SET MCNT=MCNT+1
End DoDot:3
End DoDot:2
QUIT
+195 ;secondary menu options multiple
IF FLD=203
Begin DoDot:2
+196 NEW IENS,MCNT,SUBFILE,SUBFLD
SET MCNT=1
SET SUBFILE=200.03
SET SUBFLD=.01
DO FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
+197 IF '$DATA(XUARR(SUBFILE))
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^^"
SET CNT=CNT+1
QUIT
+198 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SUBFILE,IENS))
if IENS=""
QUIT
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$GET(XUARR(SUBFILE,IENS,SUBFLD,"I"))_"^"_$GET(XUARR(SUBFILE,IENS,SUBFLD,"E"))
SET MCNT=MCNT+1
SET CNT=CNT+1
End DoDot:2
QUIT
+199 ;PERSON CLASS multiple
IF FLD=8932.1
Begin DoDot:2
+200 ;No Person Class(es)
NEW IENS,MCNT,SUBFILE,SUBFLD
SET MCNT=1
SET SUBFILE=200.05
IF '$DATA(XUARR(SUBFILE))
Begin DoDot:3
+201 FOR SUBFLD=.01,2,3
Begin DoDot:4
+202 DO FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^^"
SET CNT=CNT+1
End DoDot:4
End DoDot:3
QUIT
+203 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SUBFILE,IENS))
if IENS=""
QUIT
Begin DoDot:3
+204 FOR SUBFLD=.01,2,3
Begin DoDot:4
+205 DO FIELD^DID(SUBFILE,SUBFLD,"","LABEL","FLDNM")
+206 SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SUBFLD_"^"_(FLDNM("LABEL"))_"^"_MCNT_"^"_$GET(XUARR(SUBFILE,IENS,SUBFLD,"I"))_"^"_$GET(XUARR(SUBFILE,IENS,SUBFLD,"E"))
SET CNT=CNT+1
End DoDot:4
+207 SET MCNT=MCNT+1
End DoDot:3
End DoDot:2
QUIT
+208 ;all other fields
SET @XUGBL@(CNT)=FILE_";"_FLD_"^"_(FLDNM("LABEL"))_"^^"_XUARR(FILE,XUDUZ_",",FLD,"I")_"^"_XUARR(FILE,XUDUZ_",",FLD,"E")
SET CNT=CNT+1
End DoDot:1
+209 SET XURET=$NAME(@XUGBL)
+210 QUIT
+211 ;
UPDATE(XURET,XUARR) ;rpc to update new person file data
+1 ; called from rpc: XUS MVI NEW PERSON UPDATE
+2 ; Input:
+3 ; XUARR(#) = FILE #;FIELD #<SUBFIELD #><FILE POINTER>^FIELD NAME^<COUNTER #>^INTERNAL VALUE^EXTERNAL VALUE
+4 ; <> Denotes optional values. If Counter populated, denotes multiple value <1-n>.
+5 ; XUARR(0)="200;IEN^DUZ^^^"
+6 ; XUARR(#)="200;.01^NAME^^^"
+7 ; XUARR(#)="200;205.1^SECID^^"
+8 ; XUARR(#)="200;205.2^SUBJECT ORGANIZATION^^^"
+9 ; XUARR(#)="200;205.3^SUBJECT ORGANIZATION ID^^^"
+10 ; XUARR(#)="200;205.4^UNIQUE USER ID^^^"
+11 ; XUARR(#)="200;205.5^ADUPN^^^"
+12 ; **711, Story 977821 (jfw) - Allow additional fields to be updated.
+13 ; XUARR(#)="200;.151^EMAIL ADDRESS^^^"
+14 ; XUARR(#)="200;501.1^NETWORK USERNAME^^^"
+15 ; **710, Story 1100018 (jfw) - Add NPI field to be updated.
+16 ; XUARR(#)="200;41.99^NPI^^^"
+17 ; **732,Story 1204309 (mko): Add NPI ENTRY STATUS (#41.98)
+18 ; XUARR(#)=200;41.98^NPI ENTRY STATUS^^<value>
+19 ; **732, story 1278983 (cmc) add EFFECTIVE DATE (#42) MULTIPLE
+20 ; XUARR(#)="200;42;.01^EFFECTIVE DATE/TIME^<#>^^"
+21 ; XUARR(#)="200;42;.02^STATUS^<#>^^"
+22 ; XUARR(#)="200;42;.03^NPI^<#>^^"
+23 ; Success:
+24 ; XURET(0) = 1
+25 ; Fail:
+26 ; XURET(0) = "-1^No data passed"
+27 ; XURET(0) = "-1^Invalid User DUZ (null)"
+28 ; XURET(0) = "-1^User '"_XUDUZ_"' does not exist"
+29 ; XURET(0) = "-1^Invalid Name Component IEN"
+30 ; XURET(0) = "-1^No Data for Name Component IEN: "_NCIEN
+31 ; XURET(0) = "-1^No data to file for record '"_XUDUZ_"' in file 200"
+32 ; XURET(0) = "-1^Unable to lock record '"_XUDUZ_"' in file 200"
+33 ; XURET(0) = "-1^"_$G(XUERR("DIERR",1,"TEXT",1))
+34 ;
+35 ; Example calling rpc from VistA:
+36 ; >D UPDATE^XUMVINPU(.XURET,.XUARR)
+37 ; >ZW XURET
+38 ; >XURET(0)=1
+39 ; Example calling rpc from MVI:
+40 ; D DIRECT^XWB2HL7(.XURET,SITE,"XUS MVI NEW PERSON UPDATE","",.XUARR)
+41 KILL XURET
NEW ARR,FILENUM,FLDNAM,FLDNUM,IDATA,NCIEN,NPIIN,NPIERR,NPINEW,XUDUZ,XUERR,XUFDA
SET ARR="XUARR"
+42 IF '$DATA(XUARR)
SET XURET(0)="-1^No data passed"
QUIT
+43 FOR
SET ARR=$QUERY(@ARR)
if ARR=""
QUIT
SET FILENUM=+$PIECE($PIECE(@ARR,"^",1),";",1)
SET FLDNUM=+$PIECE($PIECE(@ARR,"^",1),";",2)
SET FLDNAM=$PIECE(@ARR,"^",2)
SET IDATA=$PIECE(@ARR,"^",4)
Begin DoDot:1
+44 ;first parameter passed
IF FLDNAM="DUZ"
Begin DoDot:2
+45 ;duz ien
SET XUDUZ=IDATA
+46 IF $GET(XUDUZ)=""
SET XURET(0)="-1^Invalid User DUZ (null)"
QUIT
+47 IF '$DATA(^VA(FILENUM,XUDUZ,0))
SET XURET(0)="-1^User '"_XUDUZ_"' does not exist"
QUIT
End DoDot:2
QUIT
+48 IF FLDNAM="NAME COMPONENTS"
Begin DoDot:2
+49 ;name component ien
SET NCIEN=IDATA
+50 IF $GET(NCIEN)=""
SET XURET(0)="-1^Invalid Name Component IEN"
+51 IF '$DATA(^VA(20,NCIEN,0))
SET XURET(0)="-1^No Data for Name Components IEN: "_NCIEN
End DoDot:2
QUIT
+52 ;**732,Story 1204309 (mko): If NPI is passed, not null, and doesn't yet exist
+53 ; in the EFFECTIVE DATE/TIME multiple, add it, and let the "AC" xref update
+54 ; the single-valued fields AUTHORIZE RELEASE OF NPI (#41.97), NPI ENTRY STATUS (#41.98), and NPI (#41.99) at the top file level.
+55 ; IF NPI IS NOT BEING DELETED BUT ADDING A VALUE
+56 IF FLDNAM="NPI"
IF IDATA'="@"
Begin DoDot:2
+57 NEW IENS,ERR,XUFDA,DIERR,DIHELP,DIMSG
SET NPIIN=IDATA
+58 if IDATA=""
QUIT
if $ORDER(^VA(200,XUDUZ,"NPISTATUS","C",IDATA,""))
QUIT
+59 SET NPINEW=1
SET IENS="+1,"_XUDUZ_","
SET XUFDA(200.042,IENS,.01)="NOW"
SET XUFDA(200.042,IENS,.02)=1
SET XUFDA(200.042,IENS,.03)=IDATA
+60 DO UPDATE^DIE("E","XUFDA","","ERR")
if $GET(DIERR)
SET NPIERR=$$BLDERR("ERR")
End DoDot:2
QUIT
+61 IF FLDNAM="NPI"
IF IDATA="@"
Begin DoDot:2
+62 SET XUFDA(200,XUDUZ_",",41.99)=IDATA
SET XUFDA(200,XUDUZ_",",41.98)=IDATA
+63 ;GET NPI TO BE DELETED FROM ARR(X+1)
+64 ;**663 - STORY 783347 (dri) add check of npi in effective date mult
SET ARR=$QUERY(@ARR)
SET NPI=$PIECE(@ARR,"^",3)
IF $ORDER(^VA(200,XUDUZ,"NPISTATUS","C",NPI,""))
SET IENS=$ORDER(^VA(200,XUDUZ,"NPISTATUS","C",NPI,""))_","_XUDUZ_","
SET XUFDA(200.042,IENS,.01)="@"
+65 ;**799 VAMPI-22625
End DoDot:2
QUIT
+66 SET XUFDA(FILENUM,$SELECT(FILENUM=200:+$GET(XUDUZ),1:+$GET(NCIEN))_",",FLDNUM)=IDATA
End DoDot:1
IF $GET(XURET(0))<0
QUIT
+67 if $GET(XURET(0))<0
QUIT
+68 IF '$GET(NPINEW)
IF '$DATA(XUFDA)
SET XURET(0)="-1^No data to file for record '"_XUDUZ_"' in file 200"
QUIT
+69 ;**732,Story 1204309 (mko): If NPI (#41.99) is not the NPI coming in, don't update NPI ENTRY STATUS (#41.98)
+70 IF $GET(NPIIN)]""
IF $PIECE($GET(^VA(200,XUDUZ,"NPI")),U)'=NPIIN
KILL XUFDA(200,XUDUZ_",",41.98)
+71 ;**732,Story 1204309 (mko): File the Name first (Within a FILE^DIE call,
+72 ; triggers on the .01 that in turn call FILE^DIE may cause the Filer flag to change from "E", to "". FDA must be also be namespaced)
+73 IF $DATA(XUFDA(200,XUDUZ_",",.01))#2
Begin DoDot:1
+74 NEW NAMEFDA
SET NAMEFDA(200,XUDUZ_",",.01)=XUFDA(200,XUDUZ_",",.01)
DO FILER(XUDUZ,.NAMEFDA,.XURET)
KILL XUFDA(200,XUDUZ_",",.01)
End DoDot:1
if $GET(XURET(0))["Unable to lock record"
QUIT
+75 ;**732,Story 1204309 (mko): Move code to call Filer to subroutine
+76 DO FILER(XUDUZ,.XUFDA,.XURET)
if $GET(XURET(0))["Unable to lock record"
QUIT
+77 ;**732,Story 1204309 (mko): Add NPIERR to XURET(0)
+78 if $GET(NPIERR)]""
SET XURET(0)=$$ADDERR(XURET(0),NPIERR)
+79 ;Return 1 in first piece to indicate Filer/Updater calls were made. If errors, also return -1^errMsg in 2nd and 3rd pieces.
+80 SET XURET(0)=1_$SELECT($GET(XURET(0))<0:U_XURET(0),1:"")
+81 QUIT
+82 ;
FILER(XUDUZ,XUMVIFDA,XURET) ;Call the Filer
+1 ;**732,Story 1204309 (mko): Move the code to call the Filer into a separate subroutine, since it is called multiple times.
+2 NEW DIERR,DIHELP,DIMSG,XUERR
+3 if '$GET(XUDUZ)
QUIT
if '$DATA(XUMVIFDA)
QUIT
+4 LOCK +^VA(200,XUDUZ):10
IF '$TEST
SET XURET(0)="-1^Unable to lock record '"_XUDUZ_"' in file 200"
QUIT
+5 ;**710, Story 1100018 (jfw) - Process fields as External Values now so Input Transform checks fire
+6 ;**732,Story 1204309 (mko): Unlock the record before checking for DIERR
+7 DO FILE^DIE("E","XUMVIFDA","XUERR")
LOCK -^VA(200,XUDUZ)
+8 ;**732,Story 1204309 (mko): Put all error messages into XURET(0)
+9 if $GET(DIERR)
SET XURET(0)=$$ADDERR($GET(XURET(0)),$$BLDERR("XUERR"))
+10 QUIT
+11 ;
ADDERR(RET,MSG) ;Return RET with MSG appended to it, and 1st piece equal to -1
+1 if $GET(MSG)=""
QUIT $GET(RET)
+2 QUIT $SELECT($GET(RET)]"":RET_" ",1:"-1^")_MSG
+3 ;
BLDERR(INROOT) ;Build a string containing error messages returned by FileMan
+1 NEW ERRSTR,I,XUERMSGS
DO MSG^DIALOG("AE",.XUERMSGS,"","",$GET(INROOT))
+2 SET ERRSTR=""
SET I=0
FOR
SET I=$ORDER(XUERMSGS(I))
if 'I
QUIT
if XUERMSGS(I)]""
SET ERRSTR=ERRSTR_$EXTRACT(" ",ERRSTR]"")_XUERMSGS(I)
+3 QUIT ERRSTR
