XUMVINPB ;MVI/DRI - Master Veteran Index New Person Bulk Pull RPC ;7/29/20 13:59
;;8.0;KERNEL;**710,725,733,819**;Jul 10, 1995;Build 1
;Per VA Directive 6402, this routine should not be modified.
;
;**710 - STORY_952862 (dri) new routine
;**725 - STORY_1238392 (dri) add fields 7, 8, 9.2, 29, 205.1, 205.5, 8910
; sort by Active, Disuser/Terminate, Visitor or All
;**733 - STORY 1291666 (dri) add field 101.13
;**819 - STORY VAMPI-29086 (jfw) See below for new fields
;
;Reference to ^XWB2HL7 supported by IA #3144
;
;
; This functionality is called by option 'MPI BULK NEW PERSON DATA PULL'
; (^MPINPBLK) on the MPI.
;
BULKGET(XURET,XUDUZ,XUTYPE) ;rpc to retrieve bulk pull of new person file data
;
; called from rpc: XUS MVI NEW PERSON BULK GET
;
; Input:
; XUDUZ = NEW PERSON IEN TO BEGIN LOOPING ON
; XUTYPE = TYPE OF EXTRACT ('A'ctive, 'D'isuser/Terminated, 'V'isitor or 'ALL')
;
; Output:
; Success:
; XURET = ^TMP("XUMVINPB",$J)
; @XURET@(#) = FILE #;FIELD #<SUBFIELD #><FILE POINTER>^FIELD NAME^<COUNTER #>^INTERNAL VALUE^EXTERNAL VALUE
; If Counter populated, denotes multiple value <1 to n>.
; If multiple Subfield's, Internal and External Values will be sub-delimited by '~'.
; @XURET@(#)="200;IEN^DUZ^^^"
; @XURET@(#)="200;.01^NAME^^^"
; @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;.151^EMAIL ADDRESS^^^"
; @XURET@(#)="200;4^SEX^^^"
; @XURET@(#)="200;5^DOB^^^"
; @XURET@(#)="200;7^DISUSER^^^"
; @XURET@(#)="200;8^TITLE^^^"
; @XURET@(#)="200;9^SSN^^^"
; @XURET@(#)="200;9.2^TERMINATION DATE^^^"
; @XURET@(#)="200;16;.01^DIVISION^<1 to 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;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;41.99^NPI^^^"
; @XURET@(#)="200;53.2^DEA#^^^"
; @XURET@(#)="200;747.44^DEA EXPIRATION DATE^^^"
; @XURET@(#)="200;201^PRIMARY MENU OPTION^^^"
; @XURET@(#)="200;203;.01^SECONDARY MENU OPTIONS^<1 to n>^^"
; @XURET@(#)="200;51;.01^KEY^<1 to n>^^"
; @XURET@(#)="200;8910;.01~2^KEY^<1 to n>^~^~"
; @XURET@(#)="200;8910;.01~2^VISITED FROM~DUZ AT HOME SITE^<1 to n)^~^~1"
; @XURET@(#)="200;101.13;.01~.02~.03^CPRS TAB~EFFECTIVE DATE~EXPIRATION DATE^<1 to n>^~~^~~"
;
;**819 VAMPI-29086 (jfw) - Add the following new fields
; @XURET@(#)="200;8932.1;.01~2~3~[5]^PERSON CLASS~EFFECTIVE DATE~EXPIRATION DATE~[VA CODE]^<1-n>^~~^~~"
; @XURET@(#)="200;53.1^AUTHORIZED TO WRITE MED ORDERS^^^"
; @XURET@(#)="200;53.11^DETOX/MAINTENANCE ID NUMBER^^^"
; @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 fields are returned ONLY if Patch XU*8.0*688 is installed!
; @XURET@(#)="200;9001^DETOX CALCULATED^^^"
; @XURET@(#)="200;53.21;.01~.02^DEA NUMBER~ INDIVIDUAL DEA SUFFIX^<1-n>^~~^~~"
; *Only returned if there is a DEA NUMBER (200.5321) value!
; Immediately follows DEA NUMBER and <#> will match DEA NUMBER Subscript*
; @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^<#>^^"
; @XURET@(#)="200;20.2^SIGNATURE BLOCK PRINTED NAME^^^"
; @XURET@(#)="200;20.3^SIGNATURE BLOCK TITLE^^^"
;**819 VAMPI-29086 (jfw) - END CHANGES
;
; @XURET@(#)="200;EOF^EOF^" - if end of new person file reached
;
; Fail:
; XURET = ^TMP("XUMVINPB",$J)
; @XURET@(1)="-1^No Data to Retrieve"
;
; Example calling rpc from VistA:
; >D BULKGET^XUMVINPB(.XURET,12595,"A")
; >ZW XURET
; >XURET="^TMP(""XUMVINPB"",17226)"
;
; D ^%G would return:
; ^TMP("XUMVINPB",17226,1)="200;IEN^DUZ^12596^12596"
; 2)="200;.01^NAME^LAST,FIRST MIDDLE SUFFIX^LAST,FIRST MIDDLE SUFFIX"
; 3)="200;.111^STREET ADDRESS 1^^STREET ADDRESS 1^STREET ADDRESS 1"
; 4)="200;.112^STREET ADDRESS 2^^STREET ADDRESS 2^STREET ADDRESS 2"
; #)=continuation of returned data
;
; Example calling rpc from MVI:
; D DIRECT^XWB2HL7(.XURET,SITE,"XUS MVI NEW PERSON BULK GET","",$G(XUDUZ),$G(XUTYPE))
;
;
K XURET
N I,CNT,FILE,FLD,FLDS,FLDNM,LINETAG,RETURN,SFILE,SFLD,XUGBL,DFLD,DFLDS,DFLDNM
;
S XUGBL="^TMP("_"""XUMVINPB"""_","_$J_")"
K @XUGBL
;
I '$D(XUDUZ) S XUDUZ=.9 ;skip over postmaster and shared mail
S LINETAG=$$LINETAG() ;get line label for type of extract requested
;
;lets only get the labels once per bulk run
S FILE=200
S FLDS=".01;.111;.112;.113;.114;.115;.116;.132;.151;4;5;7;8;9;9.2;16*;10.1;29;205.1;205.2;205.3;205.4;205.5;501.1;41.99;53.2;747.44;201;203*;51*;8910*;101.13*"
;**819 STORY VAMPI-29086 (jfw) - Additional Fields | DBIA #10141 Supported (PATCH^XPDUTL)
S FLDS=FLDS_";8932.1*;53.1;53.11;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"):";9001;53.21*",1:"")_";20.2;20.3"
F I=1:1:$L(FLDS,";") S FLD=$P($P(FLDS,";",I),"*") D
.D FIELD^DID(FILE,FLD,"","LABEL","FLDNM(FILE,FLD)")
.I FLD=16 S SFILE=200.02,SFLD=.01 D FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)") ;division multiple
.I FLD=10.1 S SFILE=20 F SFLD=1,2,3,4,5,6 D FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)") ;name components
.I FLD=51 S SFILE=200.051,SFLD=.01 D FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)") ;keys
.I FLD=101.13 S SFILE=200.010113 F SFLD=.01,.02,.03 D FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)") ;cprs tab multiple
.I FLD=203 S SFILE=200.03,SFLD=.01 D FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)") ;secondary menu options multiple
.I FLD=8910 S SFILE=200.06 F SFLD=.01,2 D FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)") ;visited from multiple
.;**819 STORY VAMPI-29086 (jfw) - New multiples added
.I FLD=8932.1 S SFILE=200.05 F SFLD=.01,2,3 D FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)") ;person class multiple
.I FLD=53.21 S SFILE=200.5321 F SFLD=.01,.02,.03 D FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)") ;dea multiple
;
;**819 STORY VAMPI-29086 (jfw) - additional dea field labels from 8991.9 to be used only if DEA NUMBER exists
S DFLDS=".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"
F I=1:1:$L(DFLDS,";") S DFLD=$P(DFLDS,";",I) D FIELD^DID(8991.9,DFLD,"","LABEL","DFLDNM(8991.9,DFLD)")
;
S CNT=1
F S XUDUZ=$O(^VA(200,XUDUZ)) Q:(('XUDUZ)!(XUDUZ'=+XUDUZ)) D @(LINETAG_"(.RETURN,"_XUDUZ_")") I RETURN D Q ;get next new person for type of extract
.N XUARR
.D GETS^DIQ(FILE,+XUDUZ_",",FLDS,"EI","XUARR") ;retrieve data
.;
.S @XUGBL@(CNT)=FILE_";IEN^DUZ^^"_XUDUZ_"^"_XUDUZ S CNT=CNT+1
.;
.F I=1:1:$L(FLDS,";") S FLD=$P($P(FLDS,";",I),"*") D
..I $S(FLD=16:1,FLD=51:1,FLD=203:1,1:0) D Q ;division, keys, secondary menu options multiple
...N IENS,MCNT,SFILE,SFLD
...S MCNT=1,SFILE=$S(FLD=16:200.02,FLD=51:200.051,FLD=203:200.03),SFLD=.01
...I '$D(XUARR(SFILE)) S @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"^"_$G(FLDNM(SFILE,SFLD,"LABEL"))_"^"_MCNT_"^^" S CNT=CNT+1 Q
...S IENS="" F S IENS=$O(XUARR(SFILE,IENS)) Q:IENS="" S @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"^"_$G(FLDNM(SFILE,SFLD,"LABEL"))_"^"_MCNT_"^"_$G(XUARR(SFILE,IENS,SFLD,"I"))_"^"_$G(XUARR(SFILE,IENS,SFLD,"E")) S MCNT=MCNT+1,CNT=CNT+1
..;
..I FLD=10.1 D Q ;name components
...S @XUGBL@(CNT)=FILE_";"_FLD_"^"_$G(FLDNM(FILE,FLD,"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
....S @XUGBL@(CNT)=NCFILE_";"_NCFLD_"^"_$G(FLDNM(NCFILE,NCFLD,"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=101.13 D Q ;cprs tab/person class multiple
...N IENS,MCNT,SFILE,SFLD,SFLD2,SFLD3
...S MCNT=1,SFILE=200.010113,SFLD=.01,SFLD2=.02,SFLD3=.03
...I '$D(XUARR(SFILE)) S @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"~"_SFLD3_"^"_$G(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$G(FLDNM(SFILE,SFLD2,"LABEL"))_"~"_$G(FLDNM(SFILE,SFLD3,"LABEL"))_"^"_MCNT_"^~~^~~",CNT=CNT+1 Q
...S IENS="" F S IENS=$O(XUARR(SFILE,IENS)) Q:IENS="" D
....S @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"~"_SFLD3_"^"_$G(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$G(FLDNM(SFILE,SFLD2,"LABEL"))_"~"_$G(FLDNM(SFILE,SFLD3,"LABEL"))
....S @XUGBL@(CNT)=@XUGBL@(CNT)_"^"_MCNT_"^"_$G(XUARR(SFILE,IENS,SFLD,"I"))_"~"_$G(XUARR(SFILE,IENS,SFLD2,"I"))_"~"_$G(XUARR(SFILE,IENS,SFLD3,"I"))
....S @XUGBL@(CNT)=@XUGBL@(CNT)_"^"_$G(XUARR(SFILE,IENS,SFLD,"E"))_"~"_$G(XUARR(SFILE,IENS,SFLD2,"E"))_"~"_$G(XUARR(SFILE,IENS,SFLD3,"E")),MCNT=MCNT+1,CNT=CNT+1
..;
..I FLD=8932.1 D Q ;**819 STORY VAMPI-29086 (jfw) - Person Class Multiple
...N IENS,MCNT,SFILE,SFLD,SFLD2,SFLD3,SFLD4,XUVAL
...D FIELD^DID(8932.1,5,"","LABEL","SFLD4")
...S MCNT=1,SFILE=200.05,SFLD=.01,SFLD2=2,SFLD3=3,SFLD4=5
...I '$D(XUARR(SFILE)) D
....S @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"~"_SFLD3_"~["_SFLD4_"]^"_$G(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$G(FLDNM(SFILE,SFLD2,"LABEL"))_"~"_$G(FLDNM(SFILE,SFLD3,"LABEL"))_"~["_$G(SFLD4("LABEL"))_"]^"_MCNT_"^~~~^~~~",CNT=CNT+1 Q
...S IENS="" F S IENS=$O(XUARR(SFILE,IENS)) Q:IENS="" D
....S @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"~"_SFLD3_"~["_SFLD4_"]^"_$G(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$G(FLDNM(SFILE,SFLD2,"LABEL"))_"~"_$G(FLDNM(SFILE,SFLD3,"LABEL"))_"~["_$G(SFLD4("LABEL"))_"]"
....S:(XUARR(SFILE,IENS,.01,"I")]"") XUVAL=$$GET1^DIQ(8932.1,XUARR(SFILE,IENS,.01,"I")_",",SFLD4) ;Retrieve VA CODE value (Fld #5) from 8932.1
....S @XUGBL@(CNT)=@XUGBL@(CNT)_"^"_MCNT_"^"_$G(XUARR(SFILE,IENS,SFLD,"I"))_"~"_$G(XUARR(SFILE,IENS,SFLD2,"I"))_"~"_$G(XUARR(SFILE,IENS,SFLD3,"I"))_"~"_$G(XUVAL)
....S @XUGBL@(CNT)=@XUGBL@(CNT)_"^"_$G(XUARR(SFILE,IENS,SFLD,"E"))_"~"_$G(XUARR(SFILE,IENS,SFLD2,"E"))_"~"_$G(XUARR(SFILE,IENS,SFLD3,"E"))_"~"_$G(XUVAL),MCNT=MCNT+1,CNT=CNT+1
..;
..I FLD=8910 D Q ;visited from multiple
...N IENS,MCNT,SFILE,SFLD,SFLD2
...S MCNT=1,SFILE=200.06,SFLD=.01,SFLD2=2
...I '$D(XUARR(SFILE)) S @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"^"_$G(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$G(FLDNM(SFILE,SFLD2,"LABEL"))_"^"_MCNT_"^~^~",CNT=CNT+1 Q
...S IENS="" F S IENS=$O(XUARR(SFILE,IENS)) Q:IENS="" D
....S @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"^"_$G(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$G(FLDNM(SFILE,SFLD2,"LABEL"))
....S @XUGBL@(CNT)=@XUGBL@(CNT)_"^"_MCNT_"^"_$G(XUARR(SFILE,IENS,SFLD,"I"))_"~"_$G(XUARR(SFILE,IENS,SFLD2,"I"))_"^"_$G(XUARR(SFILE,IENS,SFLD,"E"))_"~"_$G(XUARR(SFILE,IENS,SFLD2,"E")),MCNT=MCNT+1,CNT=CNT+1
..;
..I FLD=53.21 D Q ;**819 STORY VAMPI-29086 (jfw) - dea multiple
...N IENS,MCNT,SFILE,SFLD,SFLD2,SFLD3,DXUARR,XIENS
...S MCNT=1,SFILE=200.5321,SFLD=.01,SFLD2=.02
...I '$D(XUARR(SFILE)) S @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"^"_$G(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$G(FLDNM(SFILE,SFLD2,"LABEL"))_"^"_MCNT_"^~^~",CNT=CNT+1 Q
...S IENS="" F S IENS=$O(XUARR(SFILE,IENS)) Q:IENS="" D
....S @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"^"_$G(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$G(FLDNM(SFILE,SFLD2,"LABEL"))
....S @XUGBL@(CNT)=@XUGBL@(CNT)_"^"_MCNT_"^"_$G(XUARR(SFILE,IENS,SFLD,"I"))_"~"_$G(XUARR(SFILE,IENS,SFLD2,"I"))_"^"_$G(XUARR(SFILE,IENS,SFLD,"E"))_"~"_$G(XUARR(SFILE,IENS,SFLD2,"E")),CNT=CNT+1
....;if dea number exists then get additional dea data from 8991.9
....S XIENS=$G(XUARR(SFILE,IENS,.03,"I")) I ('+XIENS) S MCNT=MCNT+1 Q
....D GETS^DIQ(8991.9,XIENS_",",DFLDS,"EI","DXUARR") ;retrieve data
....N DI F DI=1:1:$L(DFLDS,";") S DFLD=$P(DFLDS,";",DI),@XUGBL@(CNT)=8991.9_";"_DFLD_"^"_$G(DFLDNM(8991.9,DFLD,"LABEL"))_"^"_MCNT_"^"_$G(DXUARR(8991.9,XIENS_",",DFLD,"I"))_"^"_$G(DXUARR(8991.9,XIENS_",",DFLD,"E")) S CNT=CNT+1
....S MCNT=MCNT+1
..;
..S @XUGBL@(CNT)=FILE_";"_FLD_"^"_$G(FLDNM(FILE,FLD,"LABEL"))_"^^"_$G(XUARR(FILE,XUDUZ_",",FLD,"I"))_"^"_$G(XUARR(FILE,XUDUZ_",",FLD,"E")) S CNT=CNT+1 ;all other fields
;
I 'XUDUZ S @XUGBL@(CNT)=FILE_";EOF^EOF^" ;end of file, no more new persons
I '$D(@XUGBL) S @XUGBL@(CNT)="-1^No Data to Retrieve"
;
S XURET=$NA(@XUGBL)
Q
;
LINETAG() ;return line tag for type of extract requested
Q $S(XUTYPE="A":"ACTIVE",XUTYPE="D":"DISTERM",XUTYPE="V":"VISITOR",XUTYPE="ALL":"ALL",1:"UNKNOWN")
;
ACTIVE(RETURN,XUDUZ) ;person is not disuser'd, not terminated, has primary menu option
N FILE,FLDS,XUARR
K RETURN
S RETURN=0
S FILE=200,FLDS="7;9.2;201" ;disuser; termination date; primary menu option
D GETS^DIQ(FILE,+XUDUZ_",",FLDS,"EI","XUARR") ;retrieve data
I $G(XUARR(FILE,+XUDUZ_",",7,"I"))'=1,($G(XUARR(FILE,+XUDUZ_",",9.2,"I"))=""!($G(XUARR(FILE,+XUDUZ_",",9.2,"I"))>DT)),($G(XUARR(FILE,+XUDUZ_",",201,"I"))'="") S RETURN=1 Q
Q
;
DISTERM(RETURN,XUDUZ) ;person is disuser'd or terminated
N FILE,FLDS,XUARR
K RETURN
S RETURN=0
S FILE=200,FLDS="7;9.2" ;disuser; termination date
D GETS^DIQ(FILE,+XUDUZ_",",FLDS,"EI","XUARR") ;retrieve data
I $S($G(XUARR(FILE,+XUDUZ_",",7,"I"))=1:1,($G(XUARR(FILE,+XUDUZ_",",9.2,"I"))'=""&($G(XUARR(FILE,+XUDUZ_",",9.2,"I"))'>DT)):1,1:0) S RETURN=1 Q
Q
;
VISITOR(RETURN,XUDUZ) ;person has visitor records
K RETURN
S RETURN=0
;I $O(^VA(200,XUDUZ,8910,0)),$P($G(^VA(200,XUDUZ,201)),"^",1)'="" S RETURN=1 Q ;must have visitor records and a primary menu option (currently not utilized)
I $O(^VA(200,XUDUZ,8910,0)) S RETURN=1 Q
Q
ALL(RETURN,XUDUZ) ;retrieve all persons
K RETURN
S RETURN=0
I XUDUZ S RETURN=1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUMVINPB 16127 printed Sep 23, 2025@19:47:33 Page 2
XUMVINPB ;MVI/DRI - Master Veteran Index New Person Bulk Pull RPC ;7/29/20 13:59
+1 ;;8.0;KERNEL;**710,725,733,819**;Jul 10, 1995;Build 1
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**710 - STORY_952862 (dri) new routine
+5 ;**725 - STORY_1238392 (dri) add fields 7, 8, 9.2, 29, 205.1, 205.5, 8910
+6 ; sort by Active, Disuser/Terminate, Visitor or All
+7 ;**733 - STORY 1291666 (dri) add field 101.13
+8 ;**819 - STORY VAMPI-29086 (jfw) See below for new fields
+9 ;
+10 ;Reference to ^XWB2HL7 supported by IA #3144
+11 ;
+12 ;
+13 ; This functionality is called by option 'MPI BULK NEW PERSON DATA PULL'
+14 ; (^MPINPBLK) on the MPI.
+15 ;
BULKGET(XURET,XUDUZ,XUTYPE) ;rpc to retrieve bulk pull of new person file data
+1 ;
+2 ; called from rpc: XUS MVI NEW PERSON BULK GET
+3 ;
+4 ; Input:
+5 ; XUDUZ = NEW PERSON IEN TO BEGIN LOOPING ON
+6 ; XUTYPE = TYPE OF EXTRACT ('A'ctive, 'D'isuser/Terminated, 'V'isitor or 'ALL')
+7 ;
+8 ; Output:
+9 ; Success:
+10 ; XURET = ^TMP("XUMVINPB",$J)
+11 ; @XURET@(#) = FILE #;FIELD #<SUBFIELD #><FILE POINTER>^FIELD NAME^<COUNTER #>^INTERNAL VALUE^EXTERNAL VALUE
+12 ; If Counter populated, denotes multiple value <1 to n>.
+13 ; If multiple Subfield's, Internal and External Values will be sub-delimited by '~'.
+14 ; @XURET@(#)="200;IEN^DUZ^^^"
+15 ; @XURET@(#)="200;.01^NAME^^^"
+16 ; @XURET@(#)="200;.111^STREET ADDRESS 1^^^"
+17 ; @XURET@(#)="200;.112^STREET ADDRESS 2^^^"
+18 ; @XURET@(#)="200;.113^STREET ADDRESS 3^^^"
+19 ; @XURET@(#)="200;.114^CITY^^^"
+20 ; @XURET@(#)="200;.115^STATE^^^"
+21 ; @XURET@(#)="200;.116^ZIP CODE^^^"
+22 ; @XURET@(#)="200;.132^OFFICE PHONE^^^"
+23 ; @XURET@(#)="200;.151^EMAIL ADDRESS^^^"
+24 ; @XURET@(#)="200;4^SEX^^^"
+25 ; @XURET@(#)="200;5^DOB^^^"
+26 ; @XURET@(#)="200;7^DISUSER^^^"
+27 ; @XURET@(#)="200;8^TITLE^^^"
+28 ; @XURET@(#)="200;9^SSN^^^"
+29 ; @XURET@(#)="200;9.2^TERMINATION DATE^^^"
+30 ; @XURET@(#)="200;16;.01^DIVISION^<1 to n>^^"
+31 ; @XURET@(#)="200;10.1^NAME COMPONENTS^^^"
+32 ; @XURET@(#)="20;1^FAMILY (LAST) NAME^^^"
+33 ; @XURET@(#)="20;2^GIVEN (FIRST) NAME^^^"
+34 ; @XURET@(#)="20;3^MIDDLE NAME^^^"
+35 ; @XURET@(#)="20;4^PREFIX^^^"
+36 ; @XURET@(#)="20;5^SUFFIX^^^"
+37 ; @XURET@(#)="20;6^DEGREE^^^"
+38 ; @XURET@(#)="200;29^SERVICE/SECTION^^^"
+39 ; @XURET@(#)="200;205.1^SECID^^^"
+40 ; @XURET@(#)="200;205.2^SUBJECT ORGANIZATION^^^"
+41 ; @XURET@(#)="200;205.3^SUBJECT ORGANIZATION ID^^^"
+42 ; @XURET@(#)="200;205.4^UNIQUE USER ID^^^"
+43 ; @XURET@(#)="200;205.5^ADUPN^^^"
+44 ; @XURET@(#)="200;501.1^NETWORK USERNAME^^^"
+45 ; @XURET@(#)="200;41.99^NPI^^^"
+46 ; @XURET@(#)="200;53.2^DEA#^^^"
+47 ; @XURET@(#)="200;747.44^DEA EXPIRATION DATE^^^"
+48 ; @XURET@(#)="200;201^PRIMARY MENU OPTION^^^"
+49 ; @XURET@(#)="200;203;.01^SECONDARY MENU OPTIONS^<1 to n>^^"
+50 ; @XURET@(#)="200;51;.01^KEY^<1 to n>^^"
+51 ; @XURET@(#)="200;8910;.01~2^KEY^<1 to n>^~^~"
+52 ; @XURET@(#)="200;8910;.01~2^VISITED FROM~DUZ AT HOME SITE^<1 to n)^~^~1"
+53 ; @XURET@(#)="200;101.13;.01~.02~.03^CPRS TAB~EFFECTIVE DATE~EXPIRATION DATE^<1 to n>^~~^~~"
+54 ;
+55 ;**819 VAMPI-29086 (jfw) - Add the following new fields
+56 ; @XURET@(#)="200;8932.1;.01~2~3~[5]^PERSON CLASS~EFFECTIVE DATE~EXPIRATION DATE~[VA CODE]^<1-n>^~~^~~"
+57 ; @XURET@(#)="200;53.1^AUTHORIZED TO WRITE MED ORDERS^^^"
+58 ; @XURET@(#)="200;53.11^DETOX/MAINTENANCE ID NUMBER^^^"
+59 ; @XURET@(#)="200;53.4^INACTIVE DATE^^^"
+60 ; @XURET@(#)="200;53.5^PROVIDER CLASS^^^"
+61 ; @XURET@(#)="200;53.6^PROVIDER TYPE^^^"
+62 ; @XURET@(#)="200;53.9^REMARKS^^^"
+63 ; @XURET@(#)="200;53.91^NON-VA PRESCRIBER^^^"
+64 ; @XURET@(#)="200;53.92^TAX ID^^^"
+65 ; @XURET@(#)="200;55.1^SCHEDULE II NARCOTIC^^^"
+66 ; @XURET@(#)="200;55.2^SCHEDULE II NON-NARCOTIC^^^"
+67 ; @XURET@(#)="200;55.3^SCHEDULE III NARCOTIC^^^"
+68 ; @XURET@(#)="200;55.4^SCHEDULE III NON-NARCOTIC^^^"
+69 ; @XURET@(#)="200;55.5^SCHEDULE IV^^^"
+70 ; @XURET@(#)="200;55.6^SCHEDULE V^^^"
+71 ; The following fields are returned ONLY if Patch XU*8.0*688 is installed!
+72 ; @XURET@(#)="200;9001^DETOX CALCULATED^^^"
+73 ; @XURET@(#)="200;53.21;.01~.02^DEA NUMBER~ INDIVIDUAL DEA SUFFIX^<1-n>^~~^~~"
+74 ; *Only returned if there is a DEA NUMBER (200.5321) value!
+75 ; Immediately follows DEA NUMBER and <#> will match DEA NUMBER Subscript*
+76 ; @XURET@(#)="8991.9;.02^BUSINESS ACTIVITY CODE^<#>^^"
+77 ; @XURET@(#)="8991.9;.03^DETOX NUMBER^<#>^^"
+78 ; @XURET@(#)="8991.9;.04^EXPIRATION DATE^<#>^^"
+79 ; @XURET@(#)="8991.9;.06^USE FOR INPATIENT ORDERS?<#>^"
+80 ; @XURET@(#)="8991.9;.07^TYPE^<#>^^"
+81 ; @XURET@(#)="8991.9;1.1^NAME (PROVIDER OR INSTITUTION)<#>^"
+82 ; @XURET@(#)="8991.9;1.2^STREET ADDRESS 1^<#>^^"
+83 ; @XURET@(#)="8991.9;1.3^STREET ADDRESS 2^<#>^^"
+84 ; @XURET@(#)="8991.9;1.4^STREET ADDRESS 3^<#>^^"
+85 ; @XURET@(#)="8991.9;1.5^CITY^<#>^^"
+86 ; @XURET@(#)="8991.9;1.6^STATE^<#>^^"
+87 ; @XURET@(#)="8991.9;1.7^ZIP CODE^<#>^^"
+88 ; @XURET@(#)="8991.9;2.1^SCHEDULE II NARCOTIC?<#>^"
+89 ; @XURET@(#)="8991.9;2.2^SCHEDULE II NON-NARCOTIC?<#>^"
+90 ; @XURET@(#)="8991.9;2.3^SCHEDULE III NARCOTIC?<#>^"
+91 ; @XURET@(#)="8991.9;2.4^SCHEDULE III NON-NARCOTIC?<#>^"
+92 ; @XURET@(#)="8991.9;2.5^SCHEDULE IV<#>^"
+93 ; @XURET@(#)="8991.9;2.6^SCHEDULE V<#>^"
+94 ; @XURET@(#)="8991.9;10.1^LAST UPDATED BY^<#>^^"
+95 ; @XURET@(#)="8991.9;10.2^LAST UPDATED DATE/TIME^<#>^^"
+96 ; @XURET@(#)="8991.9;10.3^LAST DOJ UPDATE DATE/TIME^<#>^^"
+97 ; @XURET@(#)="200;20.2^SIGNATURE BLOCK PRINTED NAME^^^"
+98 ; @XURET@(#)="200;20.3^SIGNATURE BLOCK TITLE^^^"
+99 ;**819 VAMPI-29086 (jfw) - END CHANGES
+100 ;
+101 ; @XURET@(#)="200;EOF^EOF^" - if end of new person file reached
+102 ;
+103 ; Fail:
+104 ; XURET = ^TMP("XUMVINPB",$J)
+105 ; @XURET@(1)="-1^No Data to Retrieve"
+106 ;
+107 ; Example calling rpc from VistA:
+108 ; >D BULKGET^XUMVINPB(.XURET,12595,"A")
+109 ; >ZW XURET
+110 ; >XURET="^TMP(""XUMVINPB"",17226)"
+111 ;
+112 ; D ^%G would return:
+113 ; ^TMP("XUMVINPB",17226,1)="200;IEN^DUZ^12596^12596"
+114 ; 2)="200;.01^NAME^LAST,FIRST MIDDLE SUFFIX^LAST,FIRST MIDDLE SUFFIX"
+115 ; 3)="200;.111^STREET ADDRESS 1^^STREET ADDRESS 1^STREET ADDRESS 1"
+116 ; 4)="200;.112^STREET ADDRESS 2^^STREET ADDRESS 2^STREET ADDRESS 2"
+117 ; #)=continuation of returned data
+118 ;
+119 ; Example calling rpc from MVI:
+120 ; D DIRECT^XWB2HL7(.XURET,SITE,"XUS MVI NEW PERSON BULK GET","",$G(XUDUZ),$G(XUTYPE))
+121 ;
+122 ;
+123 KILL XURET
+124 NEW I,CNT,FILE,FLD,FLDS,FLDNM,LINETAG,RETURN,SFILE,SFLD,XUGBL,DFLD,DFLDS,DFLDNM
+125 ;
+126 SET XUGBL="^TMP("_"""XUMVINPB"""_","_$JOB_")"
+127 KILL @XUGBL
+128 ;
+129 ;skip over postmaster and shared mail
IF '$DATA(XUDUZ)
SET XUDUZ=.9
+130 ;get line label for type of extract requested
SET LINETAG=$$LINETAG()
+131 ;
+132 ;lets only get the labels once per bulk run
+133 SET FILE=200
+134 SET FLDS=".01;.111;.112;.113;.114;.115;.116;.132;.151;4;5;7;8;9;9.2;16*;10.1;29;205.1;205.2;205.3;205.4;205.5;501.1;41.99;53.2;747.44;201;203*;51*;8910*;101.13*"
+135 ;**819 STORY VAMPI-29086 (jfw) - Additional Fields | DBIA #10141 Supported (PATCH^XPDUTL)
+136 SET FLDS=FLDS_";8932.1*;53.1;53.11;53.4;53.5;53.6;53.9;53.91;53.92;55.1;55.2;55.3;55.4;55.5;55.6"_$SELECT($$PATCH^XPDUTL("XU*8.0*688"):";9001;53.21*",1:"")_";20.2;20.3"
+137 FOR I=1:1:$LENGTH(FLDS,";")
SET FLD=$PIECE($PIECE(FLDS,";",I),"*")
Begin DoDot:1
+138 DO FIELD^DID(FILE,FLD,"","LABEL","FLDNM(FILE,FLD)")
+139 ;division multiple
IF FLD=16
SET SFILE=200.02
SET SFLD=.01
DO FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)")
+140 ;name components
IF FLD=10.1
SET SFILE=20
FOR SFLD=1,2,3,4,5,6
DO FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)")
+141 ;keys
IF FLD=51
SET SFILE=200.051
SET SFLD=.01
DO FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)")
+142 ;cprs tab multiple
IF FLD=101.13
SET SFILE=200.010113
FOR SFLD=.01,.02,.03
DO FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)")
+143 ;secondary menu options multiple
IF FLD=203
SET SFILE=200.03
SET SFLD=.01
DO FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)")
+144 ;visited from multiple
IF FLD=8910
SET SFILE=200.06
FOR SFLD=.01,2
DO FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)")
+145 ;**819 STORY VAMPI-29086 (jfw) - New multiples added
+146 ;person class multiple
IF FLD=8932.1
SET SFILE=200.05
FOR SFLD=.01,2,3
DO FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)")
+147 ;dea multiple
IF FLD=53.21
SET SFILE=200.5321
FOR SFLD=.01,.02,.03
DO FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)")
End DoDot:1
+148 ;
+149 ;**819 STORY VAMPI-29086 (jfw) - additional dea field labels from 8991.9 to be used only if DEA NUMBER exists
+150 SET DFLDS=".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"
+151 FOR I=1:1:$LENGTH(DFLDS,";")
SET DFLD=$PIECE(DFLDS,";",I)
DO FIELD^DID(8991.9,DFLD,"","LABEL","DFLDNM(8991.9,DFLD)")
+152 ;
+153 SET CNT=1
+154 ;get next new person for type of extract
FOR
SET XUDUZ=$ORDER(^VA(200,XUDUZ))
if (('XUDUZ)!(XUDUZ'=+XUDUZ))
QUIT
DO @(LINETAG_"(.RETURN,"_XUDUZ_")")
IF RETURN
Begin DoDot:1
+155 NEW XUARR
+156 ;retrieve data
DO GETS^DIQ(FILE,+XUDUZ_",",FLDS,"EI","XUARR")
+157 ;
+158 SET @XUGBL@(CNT)=FILE_";IEN^DUZ^^"_XUDUZ_"^"_XUDUZ
SET CNT=CNT+1
+159 ;
+160 FOR I=1:1:$LENGTH(FLDS,";")
SET FLD=$PIECE($PIECE(FLDS,";",I),"*")
Begin DoDot:2
+161 ;division, keys, secondary menu options multiple
IF $SELECT(FLD=16:1,FLD=51:1,FLD=203:1,1:0)
Begin DoDot:3
+162 NEW IENS,MCNT,SFILE,SFLD
+163 SET MCNT=1
SET SFILE=$SELECT(FLD=16:200.02,FLD=51:200.051,FLD=203:200.03)
SET SFLD=.01
+164 IF '$DATA(XUARR(SFILE))
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"^"_$GET(FLDNM(SFILE,SFLD,"LABEL"))_"^"_MCNT_"^^"
SET CNT=CNT+1
QUIT
+165 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SFILE,IENS))
if IENS=""
QUIT
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"^"_$GET(FLDNM(SFILE,SFLD,"LABEL"))_"^"_MCNT_"^"_$GET(XUARR(SFILE,IENS,SFLD,"I"))_"^"_$GET(XUARR(SFILE,IENS,SFLD,"E"))
SET MCNT=MCNT+1
SET CNT=CNT+1
End DoDot:3
QUIT
+166 ;
+167 ;name components
IF FLD=10.1
Begin DoDot:3
+168 SET @XUGBL@(CNT)=FILE_";"_FLD_"^"_$GET(FLDNM(FILE,FLD,"LABEL"))_"^^"_$GET(XUARR(FILE,XUDUZ_",",FLD,"I"))_"^"_$GET(XUARR(FILE,XUDUZ_",",FLD,"E"))
SET CNT=CNT+1
+169 NEW NCFILE,NCFLD
+170 SET NCFILE=20
+171 ;retrieve name component data
DO GETS^DIQ(NCFILE,+$GET(XUARR(FILE,XUDUZ_",",FLD,"I"))_",","1;2;3;4;5;6","EI","XUARR")
+172 FOR NCFLD=1,2,3,4,5,6
Begin DoDot:4
+173 SET @XUGBL@(CNT)=NCFILE_";"_NCFLD_"^"_$GET(FLDNM(NCFILE,NCFLD,"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:4
End DoDot:3
QUIT
+174 ;
+175 ;cprs tab/person class multiple
IF FLD=101.13
Begin DoDot:3
+176 NEW IENS,MCNT,SFILE,SFLD,SFLD2,SFLD3
+177 SET MCNT=1
SET SFILE=200.010113
SET SFLD=.01
SET SFLD2=.02
SET SFLD3=.03
+178 IF '$DATA(XUARR(SFILE))
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"~"_SFLD3_"^"_$GET(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD2,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD3,"LABEL"))_"^"_MCNT_"^~~^~~"
SET CNT=CNT+1
QUIT
+179 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SFILE,IENS))
if IENS=""
QUIT
Begin DoDot:4
+180 SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"~"_SFLD3_"^"_$GET(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD2,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD3,"LABEL"))
+181 SET @XUGBL@(CNT)=@XUGBL@(CNT)_"^"_MCNT_"^"_$GET(XUARR(SFILE,IENS,SFLD,"I"))_"~"_$GET(XUARR(SFILE,IENS,SFLD2,"I"))_"~"_$GET(XUARR(SFILE,IENS,SFLD3,"I"))
+182 SET @XUGBL@(CNT)=@XUGBL@(CNT)_"^"_$GET(XUARR(SFILE,IENS,SFLD,"E"))_"~"_$GET(XUARR(SFILE,IENS,SFLD2,"E"))_"~"_$GET(XUARR(SFILE,IENS,SFLD3,"E"))
SET MCNT=MCNT+1
SET CNT=CNT+1
End DoDot:4
End DoDot:3
QUIT
+183 ;
+184 ;**819 STORY VAMPI-29086 (jfw) - Person Class Multiple
IF FLD=8932.1
Begin DoDot:3
+185 NEW IENS,MCNT,SFILE,SFLD,SFLD2,SFLD3,SFLD4,XUVAL
+186 DO FIELD^DID(8932.1,5,"","LABEL","SFLD4")
+187 SET MCNT=1
SET SFILE=200.05
SET SFLD=.01
SET SFLD2=2
SET SFLD3=3
SET SFLD4=5
+188 IF '$DATA(XUARR(SFILE))
Begin DoDot:4
+189 SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"~"_SFLD3_"~["_SFLD4_"]^"_$GET(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD2,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD3,"LABEL"))_"~["_$GET(SFLD4("LABEL"))_"
]^"_MCNT_"^~~~^~~~"
SET CNT=CNT+1
QUIT
End DoDot:4
+190 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SFILE,IENS))
if IENS=""
QUIT
Begin DoDot:4
+191 SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"~"_SFLD3_"~["_SFLD4_"]^"_$GET(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD2,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD3,"LABEL"))_"~["_$GET(SFLD4("LABEL"))_"
]"
+192 ;Retrieve VA CODE value (Fld #5) from 8932.1
if (XUARR(SFILE,IENS,.01,"I")]"")
SET XUVAL=$$GET1^DIQ(8932.1,XUARR(SFILE,IENS,.01,"I")_",",SFLD4)
+193 SET @XUGBL@(CNT)=@XUGBL@(CNT)_"^"_MCNT_"^"_$GET(XUARR(SFILE,IENS,SFLD,"I"))_"~"_$GET(XUARR(SFILE,IENS,SFLD2,"I"))_"~"_$GET(XUARR(SFILE,IENS,SFLD3,"I"))_"~"_$GET(XUVAL)
+194 SET @XUGBL@(CNT)=@XUGBL@(CNT)_"^"_$GET(XUARR(SFILE,IENS,SFLD,"E"))_"~"_$GET(XUARR(SFILE,IENS,SFLD2,"E"))_"~"_$GET(XUARR(SFILE,IENS,SFLD3,"E"))_"~"_$GET(XUVAL)
SET MCNT=MCNT+1
SET CNT=CNT+1
End DoDot:4
End DoDot:3
QUIT
+195 ;
+196 ;visited from multiple
IF FLD=8910
Begin DoDot:3
+197 NEW IENS,MCNT,SFILE,SFLD,SFLD2
+198 SET MCNT=1
SET SFILE=200.06
SET SFLD=.01
SET SFLD2=2
+199 IF '$DATA(XUARR(SFILE))
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"^"_$GET(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD2,"LABEL"))_"^"_MCNT_"^~^~"
SET CNT=CNT+1
QUIT
+200 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SFILE,IENS))
if IENS=""
QUIT
Begin DoDot:4
+201 SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"^"_$GET(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD2,"LABEL"))
+202 SET @XUGBL@(CNT)=@XUGBL@(CNT)_"^"_MCNT_"^"_$GET(XUARR(SFILE,IENS,SFLD,"I"))_"~"_$GET(XUARR(SFILE,IENS,SFLD2,"I"))_"^"_$GET(XUARR(SFILE,IENS,SFLD,"E"))_"~"_$GET(XUARR(SFILE,IENS,SFLD2,"E"))
SET MCNT=MCNT+1
SET CNT=CNT+1
End DoDot:4
End DoDot:3
QUIT
+203 ;
+204 ;**819 STORY VAMPI-29086 (jfw) - dea multiple
IF FLD=53.21
Begin DoDot:3
+205 NEW IENS,MCNT,SFILE,SFLD,SFLD2,SFLD3,DXUARR,XIENS
+206 SET MCNT=1
SET SFILE=200.5321
SET SFLD=.01
SET SFLD2=.02
+207 IF '$DATA(XUARR(SFILE))
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"^"_$GET(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD2,"LABEL"))_"^"_MCNT_"^~^~"
SET CNT=CNT+1
QUIT
+208 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SFILE,IENS))
if IENS=""
QUIT
Begin DoDot:4
+209 SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"^"_$GET(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD2,"LABEL"))
+210 SET @XUGBL@(CNT)=@XUGBL@(CNT)_"^"_MCNT_"^"_$GET(XUARR(SFILE,IENS,SFLD,"I"))_"~"_$GET(XUARR(SFILE,IENS,SFLD2,"I"))_"^"_$GET(XUARR(SFILE,IENS,SFLD,"E"))_"~"_$GET(XUARR(SFILE,IENS,SFLD2,"E"))
SET CNT=CNT+1
+211 ;if dea number exists then get additional dea data from 8991.9
+212 SET XIENS=$GET(XUARR(SFILE,IENS,.03,"I"))
IF ('+XIENS)
SET MCNT=MCNT+1
QUIT
+213 ;retrieve data
DO GETS^DIQ(8991.9,XIENS_",",DFLDS,"EI","DXUARR")
+214 NEW DI
FOR DI=1:1:$LENGTH(DFLDS,";")
SET DFLD=$PIECE(DFLDS,";",DI)
SET @XUGBL@(CNT)=8991.9_";"_DFLD_"^"_$GET(DFLDNM(8991.9,DFLD,"LABEL"))_"^"_MCNT_"^"_$GET(DXUARR(8991.9,XIENS_",",DFLD,"I"))_"^"_$GET(DXUARR(8991.9,XIENS_",",DFLD,"E"))
SET CNT=CNT+1
+215 SET MCNT=MCNT+1
End DoDot:4
End DoDot:3
QUIT
+216 ;
+217 ;all other fields
SET @XUGBL@(CNT)=FILE_";"_FLD_"^"_$GET(FLDNM(FILE,FLD,"LABEL"))_"^^"_$GET(XUARR(FILE,XUDUZ_",",FLD,"I"))_"^"_$GET(XUARR(FILE,XUDUZ_",",FLD,"E"))
SET CNT=CNT+1
End DoDot:2
End DoDot:1
QUIT
+218 ;
+219 ;end of file, no more new persons
IF 'XUDUZ
SET @XUGBL@(CNT)=FILE_";EOF^EOF^"
+220 IF '$DATA(@XUGBL)
SET @XUGBL@(CNT)="-1^No Data to Retrieve"
+221 ;
+222 SET XURET=$NAME(@XUGBL)
+223 QUIT
+224 ;
LINETAG() ;return line tag for type of extract requested
+1 QUIT $SELECT(XUTYPE="A":"ACTIVE",XUTYPE="D":"DISTERM",XUTYPE="V":"VISITOR",XUTYPE="ALL":"ALL",1:"UNKNOWN")
+2 ;
ACTIVE(RETURN,XUDUZ) ;person is not disuser'd, not terminated, has primary menu option
+1 NEW FILE,FLDS,XUARR
+2 KILL RETURN
+3 SET RETURN=0
+4 ;disuser; termination date; primary menu option
SET FILE=200
SET FLDS="7;9.2;201"
+5 ;retrieve data
DO GETS^DIQ(FILE,+XUDUZ_",",FLDS,"EI","XUARR")
+6 IF $GET(XUARR(FILE,+XUDUZ_",",7,"I"))'=1
IF ($GET(XUARR(FILE,+XUDUZ_",",9.2,"I"))=""!($GET(XUARR(FILE,+XUDUZ_",",9.2,"I"))>DT))
IF ($GET(XUARR(FILE,+XUDUZ_",",201,"I"))'="")
SET RETURN=1
QUIT
+7 QUIT
+8 ;
DISTERM(RETURN,XUDUZ) ;person is disuser'd or terminated
+1 NEW FILE,FLDS,XUARR
+2 KILL RETURN
+3 SET RETURN=0
+4 ;disuser; termination date
SET FILE=200
SET FLDS="7;9.2"
+5 ;retrieve data
DO GETS^DIQ(FILE,+XUDUZ_",",FLDS,"EI","XUARR")
+6 IF $SELECT($GET(XUARR(FILE,+XUDUZ_",",7,"I"))=1:1,($GET(XUARR(FILE,+XUDUZ_",",9.2,"I"))'=""&($GET(XUARR(FILE,+XUDUZ_",",9.2,"I"))'>DT)):1,1:0)
SET RETURN=1
QUIT
+7 QUIT
+8 ;
VISITOR(RETURN,XUDUZ) ;person has visitor records
+1 KILL RETURN
+2 SET RETURN=0
+3 ;I $O(^VA(200,XUDUZ,8910,0)),$P($G(^VA(200,XUDUZ,201)),"^",1)'="" S RETURN=1 Q ;must have visitor records and a primary menu option (currently not utilized)
+4 IF $ORDER(^VA(200,XUDUZ,8910,0))
SET RETURN=1
QUIT
+5 QUIT
ALL(RETURN,XUDUZ) ;retrieve all persons
+1 KILL RETURN
+2 SET RETURN=0
+3 IF XUDUZ
SET RETURN=1
+4 QUIT
+5 ;
