XUESSO4 ;ISD/HGW Enhanced Single Sign-On Utilities ;03/23/2020 08:58
;;8.0;KERNEL;**659,630,701,727**;Jul 10, 1995;Build 0
;Per VA Directive 6402, this routine should not be modified.
;
Q
;
IAMBU(Y,SECID,AUTHCODE,ADUPN) ;RPC. XUS IAM BIND USER - ICR #6294
;Identity and Access Management Edit User RPC for SSOi binding
; Input: SECID = unique Security ID [SecID, assigned by Identity and Access Management]
; AUTHCODE = Security Phrase for IAM Binding Application
; ADUPN = Active Directory UPN
; Return: Fail Y = "-1^Error Message"
; Success Y = DUZ
;
; ZEXCEPT: DIERR ;FileMan special variables
N DUZZERO,FDR,IEN,XARRY,XRESULT,XUENTRY,XUIAM
I DUZ'>1 S Y="-1^Unauthorized access" Q
I $G(SECID)="" S Y="-1^Missing Security ID (SecID)" Q
I $G(AUTHCODE)="" S Y="-1^Missing Security Phrase" Q
S XUENTRY=$$GETCNTXT^XUESSO2($G(AUTHCODE)) I +XUENTRY<0 S Y=XUENTRY Q
I $P($G(^XWB(8994.5,XUENTRY,0)),U,1)'="IAM BINDING" S Y="-1^Unauthorized access" Q
S XUIAM=1 ;Do not trigger IAM updates
S XARRY(7)=$G(SECID) ;SecID
I $G(SECID)'="" S XRESULT=$$FINDUSER^XUESSO2(.XARRY)
I (+XRESULT>0)&(XRESULT'=DUZ) S Y="-1^This SecID has already been assigned to another user" Q
;Use FM calls to edit the user
K ^TMP("DIERR",$J)
S IEN=DUZ_","
S FDR(200,IEN,205.1)=$TR($E($G(SECID),1,40),"^","%") ;SecID
S FDR(200,IEN,205.2)=$P($G(^XTV(8989.3,1,200)),U,2) ;Subject Organization
S FDR(200,IEN,205.3)=$P($G(^XTV(8989.3,1,200)),U,3) ;Subject Organization ID
S FDR(200,IEN,205.4)=$TR($E($G(SECID),1,40),"^","%") ;Unique User ID
I $D(ADUPN) S FDR(200,IEN,205.5)=$$LOW^XLFSTR($E($G(ADUPN),1,50)) ;ADUPN
; Apply all the changes: File valid values and reject invalid values (no "T" flag).
S DUZZERO=DUZ(0),DUZ(0)="@" ;Make sure we can update the entry
I $D(FDR) D FILE^DIE("ET","FDR") ;File all the data
S DUZ(0)=DUZZERO ;Restore original FM access
I $D(DIERR) S Y="-1^Error binding VistA user to IAM" Q
S Y=DUZ
Q
;
VACAA(INARRAY,AUTHCODE) ; Veterans Access, Choice, and Accountability Act of 2014 (VACAA)
; Bulk-load non-VA provider information.
; This interface is available under a private Integration Agreement (#6230) for support
; of VACAA only, and should not be used under any other circumstances.
; Input: INARRAY(0) = VISN
; INARRAY(1) = NAME
; INARRAY(2) = DEGREE
; INARRAY(3) = SEX
; INARRAY(4) = STREET ADDRESS 1
; INARRAY(5) = STREET ADDRESS 2
; INARRAY(6) = STREET ADDRESS 3
; INARRAY(7) = CITY
; INARRAY(8) = STATE
; INARRAY(9) = ZIP
; INARRAY(10) = NPI
; INARRAY(11) = (Optional) TAX ID
; INARRAY(12) = DEA #
; INARRAY(13) = Subject Organization
; INARRAY(14) = Subject Organization ID
; Return: Fail = "-1^Error Message"
; Neutral = 0 (not an error, but entry should not be made at this site)
; Success = IEN of NEW PERSON file (#200) entry
;
; ZEXCEPT: DA,DD,DIC,DIE,DINUM,DLAYGO,DO,DR
N FADA,FDR,IEN,VIEN,VISN,X,XATTRIB,XDUZ,XIP,XSEC,XSTATE,XTAXID,XUIAM,XUVISN,Y
I $$SHAHASH^XUSHSH(256,AUTHCODE)'="69AB5CA7FF413ACA7422D52E466B0C1220BE64C25AFB354E2915A572E251E560" Q "-1^Unauthorized access"
I '$$PROD^XUPROD Q "-1^Not a production account"
I $G(INARRAY(0))="" Q "-1^Missing VISN"
I $G(INARRAY(1))="" Q "-1^Missing Name"
I $G(INARRAY(4))="" Q "-1^Missing Street Addr"
I $G(INARRAY(7))="" Q "-1^Missing City"
I $G(INARRAY(8))="" Q "-1^Missing State"
I $G(INARRAY(9))="" Q "-1^Missing Zip Code"
I $G(INARRAY(10))="" Q "-1^Missing NPI"
I $G(INARRAY(13))="" Q "-1^Missing Subject Organization"
I $G(INARRAY(14))="" Q "-1^Missing Subject Organization ID"
I '$$CHKDGT^XUSNPI($G(INARRAY(10))) Q "-1^Invalid NPI"
D PARENT^XUAF4("XUVISN","`"_DUZ(2),"VISN") ;Returns XUVISN("P",pien)="VISN #^"
S VIEN=$O(XUVISN("P",0)) S VISN=$TR($P($G(XUVISN("P",VIEN)),U),"VISN ") ;Return VISN number (no text)
I VISN'=INARRAY(0) Q 0 ; Only load data appropriate for the site's VISN (not an error)
S DUZ(0)="@",XUIAM=1 ;Temporary high-level access to edit NPF, do not trigger IAM updates
S XATTRIB(8)=INARRAY(10) ; NPI
S XDUZ=$$FINDUSER^XUESSO2(.XATTRIB) ; First find user based on NPI alone
;Set minimum 4 attributes
S XATTRIB(1)=INARRAY(13) ; Subject Organization
S XATTRIB(2)=INARRAY(14) ; Subject Organization ID
S XATTRIB(3)=XATTRIB(8) ; Unique User ID = NPI per NHIN standard
S XATTRIB(4)=INARRAY(1) ; Subject ID = NAME
I (+XDUZ>0)&('+$$ACTIVE^XUSER(XDUZ)) S XDUZ=$$FINDUSER^XUESSO2(.XATTRIB) ; If not active user, lookup on NPI again, update M4A
I +XDUZ<1 S XDUZ=$$ADDUSER^XUESSO2(.XATTRIB) ;Add the new user with M4A
I +XDUZ<1 Q XDUZ ;Quit with error code from ^XUESSO2
S IEN=XDUZ_","
I $G(INARRAY(2))'="" S FDR(200,IEN,10.6)=$E($G(INARRAY(2)),1,10) ; DEGREE
I (($G(INARRAY(3))="M")!($G(INARRAY(3))="F")) S FDR(200,IEN,4)=$E($G(INARRAY(3)),1,1) ; SEX
I $L($G(INARRAY(4)))>2 S FDR(200,IEN,.111)=$E($G(INARRAY(4)),1,50) ; STREET ADDRESS 1
I $L($G(INARRAY(5)))>2 S FDR(200,IEN,.112)=$E($G(INARRAY(5)),1,50) ; STREET ADDRESS 2
I $L($G(INARRAY(6)))>2 S FDR(200,IEN,.113)=$E($G(INARRAY(6)),1,50) ; STREET ADDRESS 3
I $L($G(INARRAY(7)))>2 S FDR(200,IEN,.114)=$E($G(INARRAY(7)),1,30) ; CITY
I $G(INARRAY(8))'="" D
. I $L($G(INARRAY(8)))>2 S XSTATE="" S XSTATE=$O(^DIC(5,"B",$G(INARRAY(8)),XSTATE))
. I $L($G(INARRAY(8)))=2 D
. . S XIP=""
. . D POSTAL^XIPUTIL($G(INARRAY(9)),.XIP)
. . S XSTATE=$G(XIP("STATE POINTER"))
. I XSTATE'="" S FDR(200,IEN,.115)=XSTATE ; STATE (pointer to ^DIC(5))
I $G(INARRAY(9))'="" S FDR(200,IEN,.116)=$G(INARRAY(9)) ; ZIP CODE
D APPLY(.FDR,IEN) K FDR S IEN=XDUZ_","
S XTAXID=$TR($G(INARRAY(11)),"-","")
I XTAXID'="" D
. S XTAXID=$E(XTAXID,1,2)_"-"_$E(XTAXID,3,9)
. S XTAXID=$TR(XTAXID," ","0")
I (XTAXID'="")&($P($G(^VA(200,XDUZ,"TPB")),U,2)="") S FDR(200,IEN,53.92)=XTAXID ; TAX ID
D APPLY(.FDR,IEN) K FDR S IEN=XDUZ_","
I $P($G(^VA(200,XDUZ,"TPB")),U,1)="" S FDR(200,IEN,53.91)=1 ; NON-VA PRESCRIBER: (1=YES)
I $P($G(^VA(200,XDUZ,"PS")),U,6)="" S FDR(200,IEN,53.6)=4 ; PROVIDER TYPE: (4=FEE BASIS)
D APPLY(.FDR,IEN) K FDR S IEN=XDUZ_","
I '+$$ACTIVE^XUSER(XDUZ)'="" D ;Could not get UPDATE^DIE to work consistently for these fields
. I $G(INARRAY(12))'="" D
. . S FDR(200,IEN,53.1)=1 ; AUTHORIZED TO WRITE MED ORDERS: (1=YES)
. . D APPLY(.FDR,IEN)
. . S DIE="^VA(200,",DA=XDUZ,DR="53.2////"_INARRAY(12) ; DEA # (stuff, due to duplicate DEA#s and user name changes)
. . L +^VA(200,XDUZ):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) D ^DIE L -^VA(200,XDUZ)
. I $D(^VA(200,XDUZ,"PS")) D
. . I '$P(^VA(200,XDUZ,"PS"),"^",4)!($P(^VA(200,XDUZ,"PS"),"^",4)>DT) D ;Give user "XUORES" key if not an active user
. . . S DA=XDUZ
. . . K DIC S DIC="^DIC(19.1,",DIC(0)="MZ",X="XUORES" D ^DIC
. . . K DIC S FADA=XDUZ
. . . I +Y>0 S X=+Y D
. . . . S:'$D(^VA(200,FADA,51,0)) ^VA(200,FADA,51,0)="^"_$P(^DD(200,51,0),"^",2)_"^^"
. . . . S DIC="^VA(200,"_FADA_",51,",DIC(0)="LM",DIC("DR")="1////"_$S($G(DUZ):DUZ,1:"")_";2///"_DT,DLAYGO=200.051,DINUM=X,DA(1)=FADA
. . . . L +^VA(200,FADA):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) K DD,DO D FILE^DICN L -^VA(200,FADA) K DIC,DR,X,Y
. . I $P($G(^VA(200,XDUZ,"PS")),"^",5)="" D ; PROVIDER CLASS (pointer to ^DIC(7))
. . . S X=0
. . . S X=$O(^DIC(7,"B","PHYSICIAN",X))
. . . I X>0 D
. . . . S DIE="^VA(200,",DA=XDUZ,DR="53.5////"_X
. . . . L +^VA(200,XDUZ):$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) D ^DIE L -^VA(200,XDUZ)
S DUZ(0)=$P($G(^VA(200,DUZ,0)),U,4)
Q XDUZ
;
APPLY(FDR,IEN) ; Apply the changes, used by "VACAA"
;ZEXCEPT: DIC
K ^TMP("DIERR",$J)
S DIC(0)=""
I $D(FDR) K IEN D UPDATE^DIE("E","FDR","IEN") ;File all the data
Q
;
ESSO(RET,DOC) ; RPC. XUS ESSO VALIDATE - IA #6295
;This API/RPC uses the VA Identity and Access Management (IAM) SAML token definition version 1.2 attributes
; from a STS SAML token for user sign-on.
; Input: DOC = Closed reference to global root containing XML document (loaded STS SAML Token).
; See $$EN^MXMLDOM instructions in the VistA Kernel Developers Guide for required
; format of the DOC global.
; Return: RET(0) = DUZ if sign-on was OK, zero if not OK.
; RET(1) = (0=OK, 1,2...=Can't sign on for some reason).
; RET(2) = 0
; RET(3) = Message.
; RET(4) = 0
; RET(5) = count of the number of lines of text, zero if none.
; RET(5+n) = message text.
;
N VCCH,XARRY,XDIV,XDIVA,XOPT,XUDEV,XUF,XUHOME,XOPTION,XUM,XUMSG,XUVOL,X,Y
S U="^",RET(0)=0,RET(5)=0,XUF=$G(XUF,0),XUM=0,XUMSG=0,XUDEV=0
; Begin user sign-on
S DUZ=0,DUZ(0)="" D NOW^XUSRB
S VCCH=0 ;VC not needed per: Password Policy When Alternate Authentication Is Available (VAIQ #7781071)
S XOPT=$$STATE^XWBSEC("XUS XOPT")
S XUVOL=^%ZOSF("VOL")
S XUMSG=$$INHIBIT^XUSRB() I XUMSG S XUM=1 G VAX^XUSRB ;Logon inhibited
;3 Strikes
I $$LKCHECK^XUSTZIP($G(IO("IP"))) S XUMSG=7 G VAX^XUSRB ;IP locked
S DUZ=$$EN^XUSAML(DOC) ;Process SAML token
I DUZ'>0 D G VAX^XUSRB ; p701 failure already recorded in $$EN^XUSAML
. S XUM=1,XUMSG=63
D USER^XUS(DUZ) ;Build USER
S XUMSG=$$UVALID^XUS() ;Check user's status: locked out, terminated, disusered, verify code
I XUMSG>0 S:$$REMOTEOK(.DUZ) XUMSG=0 ; p727
G:XUMSG VAX^XUSRB
I DUZ>0 S XUMSG=$$POST^XUSRB(1)
I XUMSG>0,'$$REMOTEOK(.DUZ) S DUZ=0 ; p727
D:DUZ>0 POST2^XUSRB
I +$G(DUZ("REMAPP"))>0 D ;Role-based access
. S XOPTION=$P($G(^XWB(8994.5,+DUZ("REMAPP"),0)),U,2)
. I XOPTION>0 D SETCNTXT^XUSBSE1(XOPTION)
S RET(0)=DUZ,RET(1)=XUM,RET(2)=0,RET(3)=$S(XUMSG:$$TXT^XUS3(XUMSG),1:""),RET(4)=0
Q
;
REMOTEOK(DUZ) ;
N AUTH,REMOTE
S REMOTE=+$G(DUZ("REMAPP"))>0
S AUTH=$G(DUZ("AUTHENTICATION"))
I REMOTE,(AUTH="SSOI")!(AUTH="SSOE")!(AUTH="NHIN") Q 1
Q 0
;
ACTIVE(RES,XUIEN) ; XUS ACTIVE USER RPC #6294
;Check if user in XUIEN is active or if no XUIEN if current user is active
S XUIEN=$G(XUIEN,DUZ)
S RES=$$ACTIVE^XUSER(XUIEN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUESSO4 10254 printed Apr 09, 2024@21:12:49 Page 2
XUESSO4 ;ISD/HGW Enhanced Single Sign-On Utilities ;03/23/2020 08:58
+1 ;;8.0;KERNEL;**659,630,701,727**;Jul 10, 1995;Build 0
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
IAMBU(Y,SECID,AUTHCODE,ADUPN) ;RPC. XUS IAM BIND USER - ICR #6294
+1 ;Identity and Access Management Edit User RPC for SSOi binding
+2 ; Input: SECID = unique Security ID [SecID, assigned by Identity and Access Management]
+3 ; AUTHCODE = Security Phrase for IAM Binding Application
+4 ; ADUPN = Active Directory UPN
+5 ; Return: Fail Y = "-1^Error Message"
+6 ; Success Y = DUZ
+7 ;
+8 ; ZEXCEPT: DIERR ;FileMan special variables
+9 NEW DUZZERO,FDR,IEN,XARRY,XRESULT,XUENTRY,XUIAM
+10 IF DUZ'>1
SET Y="-1^Unauthorized access"
QUIT
+11 IF $GET(SECID)=""
SET Y="-1^Missing Security ID (SecID)"
QUIT
+12 IF $GET(AUTHCODE)=""
SET Y="-1^Missing Security Phrase"
QUIT
+13 SET XUENTRY=$$GETCNTXT^XUESSO2($GET(AUTHCODE))
IF +XUENTRY<0
SET Y=XUENTRY
QUIT
+14 IF $PIECE($GET(^XWB(8994.5,XUENTRY,0)),U,1)'="IAM BINDING"
SET Y="-1^Unauthorized access"
QUIT
+15 ;Do not trigger IAM updates
SET XUIAM=1
+16 ;SecID
SET XARRY(7)=$GET(SECID)
+17 IF $GET(SECID)'=""
SET XRESULT=$$FINDUSER^XUESSO2(.XARRY)
+18 IF (+XRESULT>0)&(XRESULT'=DUZ)
SET Y="-1^This SecID has already been assigned to another user"
QUIT
+19 ;Use FM calls to edit the user
+20 KILL ^TMP("DIERR",$JOB)
+21 SET IEN=DUZ_","
+22 ;SecID
SET FDR(200,IEN,205.1)=$TRANSLATE($EXTRACT($GET(SECID),1,40),"^","%")
+23 ;Subject Organization
SET FDR(200,IEN,205.2)=$PIECE($GET(^XTV(8989.3,1,200)),U,2)
+24 ;Subject Organization ID
SET FDR(200,IEN,205.3)=$PIECE($GET(^XTV(8989.3,1,200)),U,3)
+25 ;Unique User ID
SET FDR(200,IEN,205.4)=$TRANSLATE($EXTRACT($GET(SECID),1,40),"^","%")
+26 ;ADUPN
IF $DATA(ADUPN)
SET FDR(200,IEN,205.5)=$$LOW^XLFSTR($EXTRACT($GET(ADUPN),1,50))
+27 ; Apply all the changes: File valid values and reject invalid values (no "T" flag).
+28 ;Make sure we can update the entry
SET DUZZERO=DUZ(0)
SET DUZ(0)="@"
+29 ;File all the data
IF $DATA(FDR)
DO FILE^DIE("ET","FDR")
+30 ;Restore original FM access
SET DUZ(0)=DUZZERO
+31 IF $DATA(DIERR)
SET Y="-1^Error binding VistA user to IAM"
QUIT
+32 SET Y=DUZ
+33 QUIT
+34 ;
VACAA(INARRAY,AUTHCODE) ; Veterans Access, Choice, and Accountability Act of 2014 (VACAA)
+1 ; Bulk-load non-VA provider information.
+2 ; This interface is available under a private Integration Agreement (#6230) for support
+3 ; of VACAA only, and should not be used under any other circumstances.
+4 ; Input: INARRAY(0) = VISN
+5 ; INARRAY(1) = NAME
+6 ; INARRAY(2) = DEGREE
+7 ; INARRAY(3) = SEX
+8 ; INARRAY(4) = STREET ADDRESS 1
+9 ; INARRAY(5) = STREET ADDRESS 2
+10 ; INARRAY(6) = STREET ADDRESS 3
+11 ; INARRAY(7) = CITY
+12 ; INARRAY(8) = STATE
+13 ; INARRAY(9) = ZIP
+14 ; INARRAY(10) = NPI
+15 ; INARRAY(11) = (Optional) TAX ID
+16 ; INARRAY(12) = DEA #
+17 ; INARRAY(13) = Subject Organization
+18 ; INARRAY(14) = Subject Organization ID
+19 ; Return: Fail = "-1^Error Message"
+20 ; Neutral = 0 (not an error, but entry should not be made at this site)
+21 ; Success = IEN of NEW PERSON file (#200) entry
+22 ;
+23 ; ZEXCEPT: DA,DD,DIC,DIE,DINUM,DLAYGO,DO,DR
+24 NEW FADA,FDR,IEN,VIEN,VISN,X,XATTRIB,XDUZ,XIP,XSEC,XSTATE,XTAXID,XUIAM,XUVISN,Y
+25 IF $$SHAHASH^XUSHSH(256,AUTHCODE)'="69AB5CA7FF413ACA7422D52E466B0C1220BE64C25AFB354E2915A572E251E560"
QUIT "-1^Unauthorized access"
+26 IF '$$PROD^XUPROD
QUIT "-1^Not a production account"
+27 IF $GET(INARRAY(0))=""
QUIT "-1^Missing VISN"
+28 IF $GET(INARRAY(1))=""
QUIT "-1^Missing Name"
+29 IF $GET(INARRAY(4))=""
QUIT "-1^Missing Street Addr"
+30 IF $GET(INARRAY(7))=""
QUIT "-1^Missing City"
+31 IF $GET(INARRAY(8))=""
QUIT "-1^Missing State"
+32 IF $GET(INARRAY(9))=""
QUIT "-1^Missing Zip Code"
+33 IF $GET(INARRAY(10))=""
QUIT "-1^Missing NPI"
+34 IF $GET(INARRAY(13))=""
QUIT "-1^Missing Subject Organization"
+35 IF $GET(INARRAY(14))=""
QUIT "-1^Missing Subject Organization ID"
+36 IF '$$CHKDGT^XUSNPI($GET(INARRAY(10)))
QUIT "-1^Invalid NPI"
+37 ;Returns XUVISN("P",pien)="VISN #^"
DO PARENT^XUAF4("XUVISN","`"_DUZ(2),"VISN")
+38 ;Return VISN number (no text)
SET VIEN=$ORDER(XUVISN("P",0))
SET VISN=$TRANSLATE($PIECE($GET(XUVISN("P",VIEN)),U),"VISN ")
+39 ; Only load data appropriate for the site's VISN (not an error)
IF VISN'=INARRAY(0)
QUIT 0
+40 ;Temporary high-level access to edit NPF, do not trigger IAM updates
SET DUZ(0)="@"
SET XUIAM=1
+41 ; NPI
SET XATTRIB(8)=INARRAY(10)
+42 ; First find user based on NPI alone
SET XDUZ=$$FINDUSER^XUESSO2(.XATTRIB)
+43 ;Set minimum 4 attributes
+44 ; Subject Organization
SET XATTRIB(1)=INARRAY(13)
+45 ; Subject Organization ID
SET XATTRIB(2)=INARRAY(14)
+46 ; Unique User ID = NPI per NHIN standard
SET XATTRIB(3)=XATTRIB(8)
+47 ; Subject ID = NAME
SET XATTRIB(4)=INARRAY(1)
+48 ; If not active user, lookup on NPI again, update M4A
IF (+XDUZ>0)&('+$$ACTIVE^XUSER(XDUZ))
SET XDUZ=$$FINDUSER^XUESSO2(.XATTRIB)
+49 ;Add the new user with M4A
IF +XDUZ<1
SET XDUZ=$$ADDUSER^XUESSO2(.XATTRIB)
+50 ;Quit with error code from ^XUESSO2
IF +XDUZ<1
QUIT XDUZ
+51 SET IEN=XDUZ_","
+52 ; DEGREE
IF $GET(INARRAY(2))'=""
SET FDR(200,IEN,10.6)=$EXTRACT($GET(INARRAY(2)),1,10)
+53 ; SEX
IF (($GET(INARRAY(3))="M")!($GET(INARRAY(3))="F"))
SET FDR(200,IEN,4)=$EXTRACT($GET(INARRAY(3)),1,1)
+54 ; STREET ADDRESS 1
IF $LENGTH($GET(INARRAY(4)))>2
SET FDR(200,IEN,.111)=$EXTRACT($GET(INARRAY(4)),1,50)
+55 ; STREET ADDRESS 2
IF $LENGTH($GET(INARRAY(5)))>2
SET FDR(200,IEN,.112)=$EXTRACT($GET(INARRAY(5)),1,50)
+56 ; STREET ADDRESS 3
IF $LENGTH($GET(INARRAY(6)))>2
SET FDR(200,IEN,.113)=$EXTRACT($GET(INARRAY(6)),1,50)
+57 ; CITY
IF $LENGTH($GET(INARRAY(7)))>2
SET FDR(200,IEN,.114)=$EXTRACT($GET(INARRAY(7)),1,30)
+58 IF $GET(INARRAY(8))'=""
Begin DoDot:1
+59 IF $LENGTH($GET(INARRAY(8)))>2
SET XSTATE=""
SET XSTATE=$ORDER(^DIC(5,"B",$GET(INARRAY(8)),XSTATE))
+60 IF $LENGTH($GET(INARRAY(8)))=2
Begin DoDot:2
+61 SET XIP=""
+62 DO POSTAL^XIPUTIL($GET(INARRAY(9)),.XIP)
+63 SET XSTATE=$GET(XIP("STATE POINTER"))
End DoDot:2
+64 ; STATE (pointer to ^DIC(5))
IF XSTATE'=""
SET FDR(200,IEN,.115)=XSTATE
End DoDot:1
+65 ; ZIP CODE
IF $GET(INARRAY(9))'=""
SET FDR(200,IEN,.116)=$GET(INARRAY(9))
+66 DO APPLY(.FDR,IEN)
KILL FDR
SET IEN=XDUZ_","
+67 SET XTAXID=$TRANSLATE($GET(INARRAY(11)),"-","")
+68 IF XTAXID'=""
Begin DoDot:1
+69 SET XTAXID=$EXTRACT(XTAXID,1,2)_"-"_$EXTRACT(XTAXID,3,9)
+70 SET XTAXID=$TRANSLATE(XTAXID," ","0")
End DoDot:1
+71 ; TAX ID
IF (XTAXID'="")&($PIECE($GET(^VA(200,XDUZ,"TPB")),U,2)="")
SET FDR(200,IEN,53.92)=XTAXID
+72 DO APPLY(.FDR,IEN)
KILL FDR
SET IEN=XDUZ_","
+73 ; NON-VA PRESCRIBER: (1=YES)
IF $PIECE($GET(^VA(200,XDUZ,"TPB")),U,1)=""
SET FDR(200,IEN,53.91)=1
+74 ; PROVIDER TYPE: (4=FEE BASIS)
IF $PIECE($GET(^VA(200,XDUZ,"PS")),U,6)=""
SET FDR(200,IEN,53.6)=4
+75 DO APPLY(.FDR,IEN)
KILL FDR
SET IEN=XDUZ_","
+76 ;Could not get UPDATE^DIE to work consistently for these fields
IF '+$$ACTIVE^XUSER(XDUZ)'=""
Begin DoDot:1
+77 IF $GET(INARRAY(12))'=""
Begin DoDot:2
+78 ; AUTHORIZED TO WRITE MED ORDERS: (1=YES)
SET FDR(200,IEN,53.1)=1
+79 DO APPLY(.FDR,IEN)
+80 ; DEA # (stuff, due to duplicate DEA#s and user name changes)
SET DIE="^VA(200,"
SET DA=XDUZ
SET DR="53.2////"_INARRAY(12)
+81 LOCK +^VA(200,XDUZ):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
DO ^DIE
LOCK -^VA(200,XDUZ)
End DoDot:2
+82 IF $DATA(^VA(200,XDUZ,"PS"))
Begin DoDot:2
+83 ;Give user "XUORES" key if not an active user
IF '$PIECE(^VA(200,XDUZ,"PS"),"^",4)!($PIECE(^VA(200,XDUZ,"PS"),"^",4)>DT)
Begin DoDot:3
+84 SET DA=XDUZ
+85 KILL DIC
SET DIC="^DIC(19.1,"
SET DIC(0)="MZ"
SET X="XUORES"
DO ^DIC
+86 KILL DIC
SET FADA=XDUZ
+87 IF +Y>0
SET X=+Y
Begin DoDot:4
+88 if '$DATA(^VA(200,FADA,51,0))
SET ^VA(200,FADA,51,0)="^"_$PIECE(^DD(200,51,0),"^",2)_"^^"
+89 SET DIC="^VA(200,"_FADA_",51,"
SET DIC(0)="LM"
SET DIC("DR")="1////"_$SELECT($GET(DUZ):DUZ,1:"")_";2///"_DT
SET DLAYGO=200.051
SET DINUM=X
SET DA(1)=FADA
+90 LOCK +^VA(200,FADA):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
KILL DD,DO
DO FILE^DICN
LOCK -^VA(200,FADA)
KILL DIC,DR,X,Y
End DoDot:4
End DoDot:3
+91 ; PROVIDER CLASS (pointer to ^DIC(7))
IF $PIECE($GET(^VA(200,XDUZ,"PS")),"^",5)=""
Begin DoDot:3
+92 SET X=0
+93 SET X=$ORDER(^DIC(7,"B","PHYSICIAN",X))
+94 IF X>0
Begin DoDot:4
+95 SET DIE="^VA(200,"
SET DA=XDUZ
SET DR="53.5////"_X
+96 LOCK +^VA(200,XDUZ):$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
DO ^DIE
LOCK -^VA(200,XDUZ)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+97 SET DUZ(0)=$PIECE($GET(^VA(200,DUZ,0)),U,4)
+98 QUIT XDUZ
+99 ;
APPLY(FDR,IEN) ; Apply the changes, used by "VACAA"
+1 ;ZEXCEPT: DIC
+2 KILL ^TMP("DIERR",$JOB)
+3 SET DIC(0)=""
+4 ;File all the data
IF $DATA(FDR)
KILL IEN
DO UPDATE^DIE("E","FDR","IEN")
+5 QUIT
+6 ;
ESSO(RET,DOC) ; RPC. XUS ESSO VALIDATE - IA #6295
+1 ;This API/RPC uses the VA Identity and Access Management (IAM) SAML token definition version 1.2 attributes
+2 ; from a STS SAML token for user sign-on.
+3 ; Input: DOC = Closed reference to global root containing XML document (loaded STS SAML Token).
+4 ; See $$EN^MXMLDOM instructions in the VistA Kernel Developers Guide for required
+5 ; format of the DOC global.
+6 ; Return: RET(0) = DUZ if sign-on was OK, zero if not OK.
+7 ; RET(1) = (0=OK, 1,2...=Can't sign on for some reason).
+8 ; RET(2) = 0
+9 ; RET(3) = Message.
+10 ; RET(4) = 0
+11 ; RET(5) = count of the number of lines of text, zero if none.
+12 ; RET(5+n) = message text.
+13 ;
+14 NEW VCCH,XARRY,XDIV,XDIVA,XOPT,XUDEV,XUF,XUHOME,XOPTION,XUM,XUMSG,XUVOL,X,Y
+15 SET U="^"
SET RET(0)=0
SET RET(5)=0
SET XUF=$GET(XUF,0)
SET XUM=0
SET XUMSG=0
SET XUDEV=0
+16 ; Begin user sign-on
+17 SET DUZ=0
SET DUZ(0)=""
DO NOW^XUSRB
+18 ;VC not needed per: Password Policy When Alternate Authentication Is Available (VAIQ #7781071)
SET VCCH=0
+19 SET XOPT=$$STATE^XWBSEC("XUS XOPT")
+20 SET XUVOL=^%ZOSF("VOL")
+21 ;Logon inhibited
SET XUMSG=$$INHIBIT^XUSRB()
IF XUMSG
SET XUM=1
GOTO VAX^XUSRB
+22 ;3 Strikes
+23 ;IP locked
IF $$LKCHECK^XUSTZIP($GET(IO("IP")))
SET XUMSG=7
GOTO VAX^XUSRB
+24 ;Process SAML token
SET DUZ=$$EN^XUSAML(DOC)
+25 ; p701 failure already recorded in $$EN^XUSAML
IF DUZ'>0
Begin DoDot:1
+26 SET XUM=1
SET XUMSG=63
End DoDot:1
GOTO VAX^XUSRB
+27 ;Build USER
DO USER^XUS(DUZ)
+28 ;Check user's status: locked out, terminated, disusered, verify code
SET XUMSG=$$UVALID^XUS()
+29 ; p727
IF XUMSG>0
if $$REMOTEOK(.DUZ)
SET XUMSG=0
+30 if XUMSG
GOTO VAX^XUSRB
+31 IF DUZ>0
SET XUMSG=$$POST^XUSRB(1)
+32 ; p727
IF XUMSG>0
IF '$$REMOTEOK(.DUZ)
SET DUZ=0
+33 if DUZ>0
DO POST2^XUSRB
+34 ;Role-based access
IF +$GET(DUZ("REMAPP"))>0
Begin DoDot:1
+35 SET XOPTION=$PIECE($GET(^XWB(8994.5,+DUZ("REMAPP"),0)),U,2)
+36 IF XOPTION>0
DO SETCNTXT^XUSBSE1(XOPTION)
End DoDot:1
+37 SET RET(0)=DUZ
SET RET(1)=XUM
SET RET(2)=0
SET RET(3)=$SELECT(XUMSG:$$TXT^XUS3(XUMSG),1:"")
SET RET(4)=0
+38 QUIT
+39 ;
REMOTEOK(DUZ) ;
+1 NEW AUTH,REMOTE
+2 SET REMOTE=+$GET(DUZ("REMAPP"))>0
+3 SET AUTH=$GET(DUZ("AUTHENTICATION"))
+4 IF REMOTE
IF (AUTH="SSOI")!(AUTH="SSOE")!(AUTH="NHIN")
QUIT 1
+5 QUIT 0
+6 ;
ACTIVE(RES,XUIEN) ; XUS ACTIVE USER RPC #6294
+1 ;Check if user in XUIEN is active or if no XUIEN if current user is active
+2 SET XUIEN=$GET(XUIEN,DUZ)
+3 SET RES=$$ACTIVE^XUSER(XUIEN)
+4 QUIT
