- XUMVINPU ;MVI/DRI - Master Veteran Index New Person Utilities ;7/31/20 15:04
- ;;8.0;KERNEL;**691,711,710,732,733**;Jul 10, 1995;Build 0
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- ;**711, Story 977780 (jfw)
- ;**732, Story 1204309 (mko)
- ;**733, Story 1291666 (dri)
- ;
- 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),IENS=$O(^VA(200,XUDUZ,"NPISTATUS","C",NPI,""))_","_XUDUZ_",",XUFDA(200.042,IENS,.01)="@"
- . 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 19431 printed Feb 18, 2025@23:37:47 Page 2
- XUMVINPU ;MVI/DRI - Master Veteran Index New Person Utilities ;7/31/20 15:04
- +1 ;;8.0;KERNEL;**691,711,710,732,733**;Jul 10, 1995;Build 0
- +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 ;
- 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 SET ARR=$QUERY(@ARR)
- SET NPI=$PIECE(@ARR,"^",3)
- SET IENS=$ORDER(^VA(200,XUDUZ,"NPISTATUS","C",NPI,""))_","_XUDUZ_","
- SET XUFDA(200.042,IENS,.01)="@"
- End DoDot:2
- QUIT
- +65 SET XUFDA(FILENUM,$SELECT(FILENUM=200:+$GET(XUDUZ),1:+$GET(NCIEN))_",",FLDNUM)=IDATA
- End DoDot:1
- IF $GET(XURET(0))<0
- QUIT
- +66 if $GET(XURET(0))<0
- QUIT
- +67 IF '$GET(NPINEW)
- IF '$DATA(XUFDA)
- SET XURET(0)="-1^No data to file for record '"_XUDUZ_"' in file 200"
- QUIT
- +68 ;**732,Story 1204309 (mko): If NPI (#41.99) is not the NPI coming in, don't update NPI ENTRY STATUS (#41.98)
- +69 IF $GET(NPIIN)]""
- IF $PIECE($GET(^VA(200,XUDUZ,"NPI")),U)'=NPIIN
- KILL XUFDA(200,XUDUZ_",",41.98)
- +70 ;**732,Story 1204309 (mko): File the Name first (Within a FILE^DIE call,
- +71 ; 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)
- +72 IF $DATA(XUFDA(200,XUDUZ_",",.01))#2
- Begin DoDot:1
- +73 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
- +74 ;**732,Story 1204309 (mko): Move code to call Filer to subroutine
- +75 DO FILER(XUDUZ,.XUFDA,.XURET)
- if $GET(XURET(0))["Unable to lock record"
- QUIT
- +76 ;**732,Story 1204309 (mko): Add NPIERR to XURET(0)
- +77 if $GET(NPIERR)]""
- SET XURET(0)=$$ADDERR(XURET(0),NPIERR)
- +78 ;Return 1 in first piece to indicate Filer/Updater calls were made. If errors, also return -1^errMsg in 2nd and 3rd pieces.
- +79 SET XURET(0)=1_$SELECT($GET(XURET(0))<0:U_XURET(0),1:"")
- +80 QUIT
- +81 ;
- 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
