XUMVINPB ;MVI/DRI - Master Veteran Index New Person Bulk Pull RPC ;7/29/20 13:59
;;8.0;KERNEL;**710,725,733**;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
;
;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>^~~^~~"
;
; @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
;
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*"
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
;
S CNT=1
F S XUDUZ=$O(^VA(200,XUDUZ)) Q:'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 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=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
..;
..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 10056 printed Nov 22, 2024@17:21:28 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**;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 ;
+9 ;Reference to ^XWB2HL7 supported by IA #3144
+10 ;
+11 ;
+12 ; This functionality is called by option 'MPI BULK NEW PERSON DATA PULL'
+13 ; (^MPINPBLK) on the MPI.
+14 ;
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 ; @XURET@(#)="200;EOF^EOF^" - if end of new person file reached
+56 ;
+57 ; Fail:
+58 ; XURET = ^TMP("XUMVINPB",$J)
+59 ; @XURET@(1)="-1^No Data to Retrieve"
+60 ;
+61 ; Example calling rpc from VistA:
+62 ; >D BULKGET^XUMVINPB(.XURET,12595,"A")
+63 ; >ZW XURET
+64 ; >XURET="^TMP(""XUMVINPB"",17226)"
+65 ;
+66 ; D ^%G would return:
+67 ; ^TMP("XUMVINPB",17226,1)="200;IEN^DUZ^12596^12596"
+68 ; 2)="200;.01^NAME^LAST,FIRST MIDDLE SUFFIX^LAST,FIRST MIDDLE SUFFIX"
+69 ; 3)="200;.111^STREET ADDRESS 1^^STREET ADDRESS 1^STREET ADDRESS 1"
+70 ; 4)="200;.112^STREET ADDRESS 2^^STREET ADDRESS 2^STREET ADDRESS 2"
+71 ; #)=continuation of returned data
+72 ;
+73 ; Example calling rpc from MVI:
+74 ; D DIRECT^XWB2HL7(.XURET,SITE,"XUS MVI NEW PERSON BULK GET","",$G(XUDUZ),$G(XUTYPE))
+75 ;
+76 ;
+77 KILL XURET
+78 NEW I,CNT,FILE,FLD,FLDS,FLDNM,LINETAG,RETURN,SFILE,SFLD,XUGBL
+79 ;
+80 SET XUGBL="^TMP("_"""XUMVINPB"""_","_$JOB_")"
+81 KILL @XUGBL
+82 ;
+83 ;skip over postmaster and shared mail
IF '$DATA(XUDUZ)
SET XUDUZ=.9
+84 ;get line label for type of extract requested
SET LINETAG=$$LINETAG()
+85 ;
+86 ;lets only get the labels once per bulk run
+87 SET FILE=200
+88 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*"
+89 FOR I=1:1:$LENGTH(FLDS,";")
SET FLD=$PIECE($PIECE(FLDS,";",I),"*")
Begin DoDot:1
+90 DO FIELD^DID(FILE,FLD,"","LABEL","FLDNM(FILE,FLD)")
+91 ;division multiple
IF FLD=16
SET SFILE=200.02
SET SFLD=.01
DO FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)")
+92 ;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)")
+93 ;keys
IF FLD=51
SET SFILE=200.051
SET SFLD=.01
DO FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)")
+94 ;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)")
+95 ;secondary menu options multiple
IF FLD=203
SET SFILE=200.03
SET SFLD=.01
DO FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)")
+96 ;visited from multiple
IF FLD=8910
SET SFILE=200.06
FOR SFLD=.01,2
DO FIELD^DID(SFILE,SFLD,"","LABEL","FLDNM(SFILE,SFLD)")
End DoDot:1
+97 ;
+98 SET CNT=1
+99 ;get next new person for type of extract
FOR
SET XUDUZ=$ORDER(^VA(200,XUDUZ))
if 'XUDUZ
QUIT
DO @(LINETAG_"(.RETURN,"_XUDUZ_")")
IF RETURN
Begin DoDot:1
+100 NEW XUARR
+101 ;retrieve data
DO GETS^DIQ(FILE,+XUDUZ_",",FLDS,"EI","XUARR")
+102 ;
+103 SET @XUGBL@(CNT)=FILE_";IEN^DUZ^^"_XUDUZ_"^"_XUDUZ
SET CNT=CNT+1
+104 ;
+105 FOR I=1:1:$LENGTH(FLDS,";")
SET FLD=$PIECE($PIECE(FLDS,";",I),"*")
Begin DoDot:2
+106 ;division, keys, secondary menu options multiple
IF $SELECT(FLD=16:1,FLD=51:1,FLD=203:1,1:0)
Begin DoDot:3
+107 NEW IENS,MCNT,SFILE,SFLD
+108 SET MCNT=1
SET SFILE=$SELECT(FLD=16:200.02,FLD=51:200.051,FLD=203:200.03)
SET SFLD=.01
+109 IF '$DATA(XUARR(SFILE))
SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"^"_$GET(FLDNM(SFILE,SFLD,"LABEL"))_"^"_MCNT_"^^"
SET CNT=CNT+1
QUIT
+110 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
+111 ;
+112 ;name components
IF FLD=10.1
Begin DoDot:3
+113 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
+114 NEW NCFILE,NCFLD
+115 SET NCFILE=20
+116 ;retrieve name component data
DO GETS^DIQ(NCFILE,+$GET(XUARR(FILE,XUDUZ_",",FLD,"I"))_",","1;2;3;4;5;6","EI","XUARR")
+117 FOR NCFLD=1,2,3,4,5,6
Begin DoDot:4
+118 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
+119 ;
+120 ;cprs tab multiple
IF FLD=101.13
Begin DoDot:3
+121 NEW IENS,MCNT,SFILE,SFLD,SFLD2,SFLD3
+122 SET MCNT=1
SET SFILE=200.010113
SET SFLD=.01
SET SFLD2=.02
SET SFLD3=.03
+123 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
+124 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SFILE,IENS))
if IENS=""
QUIT
Begin DoDot:4
+125 SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"~"_SFLD3_"^"_$GET(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD2,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD3,"LABEL"))
+126 SET @XUGBL@(CNT)=@XUGBL@(CNT)_"^"_MCNT_"^"_$GET(XUARR(SFILE,IENS,SFLD,"I"))_"~"_$GET(XUARR(SFILE,IENS,SFLD2,"I"))_"~"_$GET(XUARR(SFILE,IENS,SFLD3,"I"))
+127 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
+128 ;
+129 ;visited from multiple
IF FLD=8910
Begin DoDot:3
+130 NEW IENS,MCNT,SFILE,SFLD,SFLD2
+131 SET MCNT=1
SET SFILE=200.06
SET SFLD=.01
SET SFLD2=2
+132 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
+133 SET IENS=""
FOR
SET IENS=$ORDER(XUARR(SFILE,IENS))
if IENS=""
QUIT
Begin DoDot:4
+134 SET @XUGBL@(CNT)=FILE_";"_FLD_";"_SFLD_"~"_SFLD2_"^"_$GET(FLDNM(SFILE,SFLD,"LABEL"))_"~"_$GET(FLDNM(SFILE,SFLD2,"LABEL"))
+135 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
+136 ;
+137 ;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
+138 ;
+139 ;end of file, no more new persons
IF 'XUDUZ
SET @XUGBL@(CNT)=FILE_";EOF^EOF^"
+140 IF '$DATA(@XUGBL)
SET @XUGBL@(CNT)="-1^No Data to Retrieve"
+141 ;
+142 SET XURET=$NAME(@XUGBL)
+143 QUIT
+144 ;
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 ;
