MHVXUSR ;WAS/DLF/MJK - User extract ; 5/6/10 4:12pm
;;1.0;My HealtheVet;**6,29**;July 10, 2017;Build 73
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q
; Integration Agreements:
; 10060 : New Person file #200
; 2343 : $$ACTIVE^XUSER(Y)
; 10103 : $$DT^XLFDT
; $$NOW^XLFDT
; 10076 : Read ^XUSEC("PROVIDER",DUZ
; 1625 : PERSON CLASS- PROVIDER TYPE - CLASSIFICATION (File #8932.1)
; $$GET^XUA4A72(USRIEN) - Patch 29
; 10093 : SERVICE/SECTION file #49
; 2533 : $$DIV4^XUSER(.ZZ[,duz])- DIVISIONS - Patch 29
;
USERS(QRY,ERR,DATAROOT) ; return users from file 200
;
; Primary Care Management Module interface
; return user data in DATAROOT
; QRY, ERR passed by ref.
;
; Input:
; QRY - Query array
; ERR - Variable to hold error conditions
; DATAROOT - Root of array to hold extract data
; Output:
; DATAROOT - Populated data array
; includes number of hits and timestamp
; ERR - Errors during extraction, zero on success
;
;
;
D LOG^MHVUL2("USERS~MHVXUSR","BEGIN","S","TRACE")
;
K @DATAROOT,^TMP("MHXUSR",$J) ; clean up residue
;
N NXT,IIEN,NODE,TEAM,OUT,MHVPURPA,MHVROLEA,MHVLIST,MHVERR
N DIERR,DT,EXTIME,HIT,LOGND,RTN,TMIEN,NM,U,X
N USRNAME,USROUT,USRFNAME,OUT,PPHONE,SSECTION,USRIEN,PRV,TTITLE
N PRVCLS,REQSIG,NETWKID
N PERSCLS,PCEFDT,PCEXDT,PROVSPEC,PROVDIVS,USERCLS,DATARSTR,I,RETST,SUB
;
S U="^",DT=$$DT^XLFDT,ERR=0,EXTIME=$$NOW^XLFDT,HIT=0
;
S OUT=$NA(^TMP("MHVXUSR",$J))
S NXT=0,IIEN=0
K @OUT
;
;FIND ALL ACTIVE NEW PERSONS THAT MATCH ENTRY
;
I QRY("IEN")="" D ; Name lookup
. ;JAZZ#409966-Fix Names with Space in SM queries;and more User Fields - existing issue
. ;retrieve only active user patrial match - if Name passed in
. D LIST^DIC(200,"","","",,QRY("LNAME"),QRY("LNAME"),"B","I $$ACTIVE^XUSER(Y)","",OUT)
E D ; Lookup by IEN
. ;JAZZ#409966-Fix Names with Space in SM queries;and more User Fields - existing issue
. ;retrieve both active and inactive user for exact DUZ match -
. S @OUT@("DILIST",2,1)=QRY("IEN")
;
;$O through the OUT array to get the IEN to check for roles
;
S IIEN="",HIT=0
F S IIEN=$O(@OUT@("DILIST",2,IIEN)) Q:IIEN="" D
.S USRIEN=@OUT@("DILIST",2,IIEN)
. ; Fieds extracted pre-patch 29:
. ; - #.01 NAME - AI#10060 New Person file #200
. ; - #.132 OFFICE PHONE - AI#10060 New Person file #200
. ; - #8 TITLE - AI#10060 New Person file #200
. ; - #29 SERVICE/SECTION - AI#10093 SERVICE/SECTION file #49
. ;-----------------------------------------------------------------------------------------
. ;JAZZ#409966-Fix Names with Space in SM queries- existing issue;and more User Fields;ADDED:
. ; - #53.5-PROVIDER CLASS - POINTER TO #7 PROVIDER CLASS FILE - AI#10060
. ; - #53.7 REQUIRES COSIGNER - AI#10060
. ; - #501.1 NETWORK ID - AI#10060
. ; - #8932.1-PERSON CLASS-PROVIDER TYPE-CLASSIFICATION -today's active-AI#1625
. ; .01 Person Class (*P8932.1'a), [0;1]
. ; 2 Effective Date (RDXa), [0;2]
. ; 3 Expiration Date (Da), [0;3]
. ; - #747.111-SPECIALTY -[pointer to SPECIALTY file (#747.9)]-today's active-above call- AI#1625
. ; - #16- DIVISION (multiple) [pointer to INSTITUTION FILE (#4)] - AI#2533
. ; $$DIV4^XUSER(.ZZ[,duz])- DIVISIONS
. ;-----------------------------------------------------------------------------------------
.;D GETS^DIQ(200,USRIEN_",",".01;.132;8;29","E","USROUT","DIERR")
.K DIERR
.D GETS^DIQ(200,USRIEN_",",".01;.132;8;29;53.5;53.7;501.1","E","USROUT","DIERR")
.Q:$G(DIERR)
.S USRNAME=$G(USROUT(200,USRIEN_",",.01,"E"))
.S USRFNAME=$P(USRNAME,",",2)
.Q:$E(USRFNAME,1,$L(QRY("FNAME")))'=QRY("FNAME")
.S PPHONE=$G(USROUT(200,USRIEN_",",.132,"E"))
.S TTITLE=$G(USROUT(200,USRIEN_",",8,"E"))
.S SSECTION=$G(USROUT(200,USRIEN_",",29,"E"))
.S PRV="",PRVCLS="",REQSIG="",NETWKID=""
.I $D(^XUSEC("PROVIDER",USRIEN)) S PRV="PROVIDER"
.S PRVCLS=$G(USROUT(200,USRIEN_",",53.5,"E"))
.S REQSIG=$G(USROUT(200,USRIEN_",",53.7,"E"))
.S NETWKID=$G(USROUT(200,USRIEN_",",501.1,"E"))
.;PERSON CLASS-EFFECTIVE DATE;EXPIRATION DATE; SPECIALTY(multiple)-only there is an active entry -#1625
.S RETST="",PERSCLS="",PCEFDT="",PCEXDT="",PROVSPEC=""
.S RETST=$$GET^XUA4A72(USRIEN)
.;PERSON CLASS; EFFECTIVE DATE; EXPIRATION DATE;SPECIALTY- AI#1625
.I RETST>0 D
.. S PERSCLS=$P(RETST,"^",2)
.. S PCEFDT=$P(RETST,"^",5),PCEXDT=$P(RETST,"^",6)
.. S PROVSPEC=$P(RETST,"^",3)
.I RETST<=0 D
.. I RETST=-1 S PERSCLS="Person Class never assigned"
.. I RETST=-2 S PERSCLS="No active Person Class"
.;DIVISION (multiple)
.K DIERR
.D GETS^DIQ(200,USRIEN_",","16*","E","USROUT","DIERR")
.S PROVDIVS=""
.S SUB="0,"_USRIEN_","
.F S SUB=$O(USROUT(200.02,SUB)) Q:SUB'[USRIEN_"," D
.. I $D(USROUT(200.02,SUB))>1 D
... S PROVDIVS=PROVDIVS_$G(USROUT(200.02,SUB,.01,"E"))_"~"_$G(USROUT(200.02,SUB,1,"E"))_"_"
.S HIT=HIT+1
.;JAZZ#409966-Fix Names with Space in SM queries- existing issue;and more User Fields
.;S @DATAROOT@(HIT)=USRIEN_U_USRNAME_U_PRV_U_U_U_U_PPHONE_U_SSECTION_U_TTITLE
.S DATARSTR=USRIEN_U_USRNAME_U_PRV_U_PRVCLS_U_PROVSPEC_U_REQSIG_U_PPHONE_U_SSECTION_U_TTITLE_U_NETWKID
.S DATARSTR=DATARSTR_U_PERSCLS_U_PCEFDT_U_PCEXDT_U_PROVDIVS
.S @DATAROOT@(HIT)=DATARSTR
;
; Update dataroot with number of hits and
; write to the log
;
K @OUT
S @DATAROOT=HIT_U_EXTIME ; count of hits ^ time
D LOG^MHVUL2("USERS~MHVXUSR",HIT_" HITS","S","TRACE")
D LOG^MHVUL2("USERS~MHVXUSR","END","S","TRACE")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMHVXUSR 5719 printed Apr 09, 2024@21:17:41 Page 2
MHVXUSR ;WAS/DLF/MJK - User extract ; 5/6/10 4:12pm
+1 ;;1.0;My HealtheVet;**6,29**;July 10, 2017;Build 73
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ; Integration Agreements:
+6 ; 10060 : New Person file #200
+7 ; 2343 : $$ACTIVE^XUSER(Y)
+8 ; 10103 : $$DT^XLFDT
+9 ; $$NOW^XLFDT
+10 ; 10076 : Read ^XUSEC("PROVIDER",DUZ
+11 ; 1625 : PERSON CLASS- PROVIDER TYPE - CLASSIFICATION (File #8932.1)
+12 ; $$GET^XUA4A72(USRIEN) - Patch 29
+13 ; 10093 : SERVICE/SECTION file #49
+14 ; 2533 : $$DIV4^XUSER(.ZZ[,duz])- DIVISIONS - Patch 29
+15 ;
USERS(QRY,ERR,DATAROOT) ; return users from file 200
+1 ;
+2 ; Primary Care Management Module interface
+3 ; return user data in DATAROOT
+4 ; QRY, ERR passed by ref.
+5 ;
+6 ; Input:
+7 ; QRY - Query array
+8 ; ERR - Variable to hold error conditions
+9 ; DATAROOT - Root of array to hold extract data
+10 ; Output:
+11 ; DATAROOT - Populated data array
+12 ; includes number of hits and timestamp
+13 ; ERR - Errors during extraction, zero on success
+14 ;
+15 ;
+16 ;
+17 DO LOG^MHVUL2("USERS~MHVXUSR","BEGIN","S","TRACE")
+18 ;
+19 ; clean up residue
KILL @DATAROOT,^TMP("MHXUSR",$JOB)
+20 ;
+21 NEW NXT,IIEN,NODE,TEAM,OUT,MHVPURPA,MHVROLEA,MHVLIST,MHVERR
+22 NEW DIERR,DT,EXTIME,HIT,LOGND,RTN,TMIEN,NM,U,X
+23 NEW USRNAME,USROUT,USRFNAME,OUT,PPHONE,SSECTION,USRIEN,PRV,TTITLE
+24 NEW PRVCLS,REQSIG,NETWKID
+25 NEW PERSCLS,PCEFDT,PCEXDT,PROVSPEC,PROVDIVS,USERCLS,DATARSTR,I,RETST,SUB
+26 ;
+27 SET U="^"
SET DT=$$DT^XLFDT
SET ERR=0
SET EXTIME=$$NOW^XLFDT
SET HIT=0
+28 ;
+29 SET OUT=$NAME(^TMP("MHVXUSR",$JOB))
+30 SET NXT=0
SET IIEN=0
+31 KILL @OUT
+32 ;
+33 ;FIND ALL ACTIVE NEW PERSONS THAT MATCH ENTRY
+34 ;
+35 ; Name lookup
IF QRY("IEN")=""
Begin DoDot:1
+36 ;JAZZ#409966-Fix Names with Space in SM queries;and more User Fields - existing issue
+37 ;retrieve only active user patrial match - if Name passed in
+38 DO LIST^DIC(200,"","","",,QRY("LNAME"),QRY("LNAME"),"B","I $$ACTIVE^XUSER(Y)","",OUT)
End DoDot:1
+39 ; Lookup by IEN
IF '$TEST
Begin DoDot:1
+40 ;JAZZ#409966-Fix Names with Space in SM queries;and more User Fields - existing issue
+41 ;retrieve both active and inactive user for exact DUZ match -
+42 SET @OUT@("DILIST",2,1)=QRY("IEN")
End DoDot:1
+43 ;
+44 ;$O through the OUT array to get the IEN to check for roles
+45 ;
+46 SET IIEN=""
SET HIT=0
+47 FOR
SET IIEN=$ORDER(@OUT@("DILIST",2,IIEN))
if IIEN=""
QUIT
Begin DoDot:1
+48 SET USRIEN=@OUT@("DILIST",2,IIEN)
+49 ; Fieds extracted pre-patch 29:
+50 ; - #.01 NAME - AI#10060 New Person file #200
+51 ; - #.132 OFFICE PHONE - AI#10060 New Person file #200
+52 ; - #8 TITLE - AI#10060 New Person file #200
+53 ; - #29 SERVICE/SECTION - AI#10093 SERVICE/SECTION file #49
+54 ;-----------------------------------------------------------------------------------------
+55 ;JAZZ#409966-Fix Names with Space in SM queries- existing issue;and more User Fields;ADDED:
+56 ; - #53.5-PROVIDER CLASS - POINTER TO #7 PROVIDER CLASS FILE - AI#10060
+57 ; - #53.7 REQUIRES COSIGNER - AI#10060
+58 ; - #501.1 NETWORK ID - AI#10060
+59 ; - #8932.1-PERSON CLASS-PROVIDER TYPE-CLASSIFICATION -today's active-AI#1625
+60 ; .01 Person Class (*P8932.1'a), [0;1]
+61 ; 2 Effective Date (RDXa), [0;2]
+62 ; 3 Expiration Date (Da), [0;3]
+63 ; - #747.111-SPECIALTY -[pointer to SPECIALTY file (#747.9)]-today's active-above call- AI#1625
+64 ; - #16- DIVISION (multiple) [pointer to INSTITUTION FILE (#4)] - AI#2533
+65 ; $$DIV4^XUSER(.ZZ[,duz])- DIVISIONS
+66 ;-----------------------------------------------------------------------------------------
+67 ;D GETS^DIQ(200,USRIEN_",",".01;.132;8;29","E","USROUT","DIERR")
+68 KILL DIERR
+69 DO GETS^DIQ(200,USRIEN_",",".01;.132;8;29;53.5;53.7;501.1","E","USROUT","DIERR")
+70 if $GET(DIERR)
QUIT
+71 SET USRNAME=$GET(USROUT(200,USRIEN_",",.01,"E"))
+72 SET USRFNAME=$PIECE(USRNAME,",",2)
+73 if $EXTRACT(USRFNAME,1,$LENGTH(QRY("FNAME")))'=QRY("FNAME")
QUIT
+74 SET PPHONE=$GET(USROUT(200,USRIEN_",",.132,"E"))
+75 SET TTITLE=$GET(USROUT(200,USRIEN_",",8,"E"))
+76 SET SSECTION=$GET(USROUT(200,USRIEN_",",29,"E"))
+77 SET PRV=""
SET PRVCLS=""
SET REQSIG=""
SET NETWKID=""
+78 IF $DATA(^XUSEC("PROVIDER",USRIEN))
SET PRV="PROVIDER"
+79 SET PRVCLS=$GET(USROUT(200,USRIEN_",",53.5,"E"))
+80 SET REQSIG=$GET(USROUT(200,USRIEN_",",53.7,"E"))
+81 SET NETWKID=$GET(USROUT(200,USRIEN_",",501.1,"E"))
+82 ;PERSON CLASS-EFFECTIVE DATE;EXPIRATION DATE; SPECIALTY(multiple)-only there is an active entry -#1625
+83 SET RETST=""
SET PERSCLS=""
SET PCEFDT=""
SET PCEXDT=""
SET PROVSPEC=""
+84 SET RETST=$$GET^XUA4A72(USRIEN)
+85 ;PERSON CLASS; EFFECTIVE DATE; EXPIRATION DATE;SPECIALTY- AI#1625
+86 IF RETST>0
Begin DoDot:2
+87 SET PERSCLS=$PIECE(RETST,"^",2)
+88 SET PCEFDT=$PIECE(RETST,"^",5)
SET PCEXDT=$PIECE(RETST,"^",6)
+89 SET PROVSPEC=$PIECE(RETST,"^",3)
End DoDot:2
+90 IF RETST<=0
Begin DoDot:2
+91 IF RETST=-1
SET PERSCLS="Person Class never assigned"
+92 IF RETST=-2
SET PERSCLS="No active Person Class"
End DoDot:2
+93 ;DIVISION (multiple)
+94 KILL DIERR
+95 DO GETS^DIQ(200,USRIEN_",","16*","E","USROUT","DIERR")
+96 SET PROVDIVS=""
+97 SET SUB="0,"_USRIEN_","
+98 FOR
SET SUB=$ORDER(USROUT(200.02,SUB))
if SUB'[USRIEN_","
QUIT
Begin DoDot:2
+99 IF $DATA(USROUT(200.02,SUB))>1
Begin DoDot:3
+100 SET PROVDIVS=PROVDIVS_$GET(USROUT(200.02,SUB,.01,"E"))_"~"_$GET(USROUT(200.02,SUB,1,"E"))_"_"
End DoDot:3
End DoDot:2
+101 SET HIT=HIT+1
+102 ;JAZZ#409966-Fix Names with Space in SM queries- existing issue;and more User Fields
+103 ;S @DATAROOT@(HIT)=USRIEN_U_USRNAME_U_PRV_U_U_U_U_PPHONE_U_SSECTION_U_TTITLE
+104 SET DATARSTR=USRIEN_U_USRNAME_U_PRV_U_PRVCLS_U_PROVSPEC_U_REQSIG_U_PPHONE_U_SSECTION_U_TTITLE_U_NETWKID
+105 SET DATARSTR=DATARSTR_U_PERSCLS_U_PCEFDT_U_PCEXDT_U_PROVDIVS
+106 SET @DATAROOT@(HIT)=DATARSTR
End DoDot:1
+107 ;
+108 ; Update dataroot with number of hits and
+109 ; write to the log
+110 ;
+111 KILL @OUT
+112 ; count of hits ^ time
SET @DATAROOT=HIT_U_EXTIME
+113 DO LOG^MHVUL2("USERS~MHVXUSR",HIT_" HITS","S","TRACE")
+114 DO LOG^MHVUL2("USERS~MHVXUSR","END","S","TRACE")
+115 QUIT
