XUESSO1 ;SEA/LUKE - Single Sign-on Utilities ; Apr 08, 2022@13:58
;;8.0;KERNEL;**165,183,196,245,254,269,337,395,466,523,655,659,771**;Jul 10, 1995;Build 8
;Per VA Directive 6402, this routine should not be modified.
;
GET(INDUZ) ;Gather identifying data from user's home site.
;Called by SETVISIT^XUSBSE1 (Get visitor info for TOKEN)
;Called by SNDQRY^DGROHLS (Retrieve user info) and SETUP^XWB2HL7 (Get visitor info)
;Called by (unknown) (VSA/VistA.js)
;To visit a remote site, user must have: Name, Access/Verify Codes, SSN (no pseudo), Station Name, Site Number
;The following data is optional: Phone, SecID, Network Username
N %,NAME,SITE,SSN,PHONE,X,N,NETWORK
I '$D(DUZ) Q "-1^Insufficient info to allow visiting: No DUZ"
I '$D(DUZ(2)) Q "-1^Insufficient info to allow visiting: Missing DUZ(2)"
S N=$G(^VA(200,DUZ,0))
I '$L(N) Q "-1^Insufficient info to allow visiting: Missing NPF Zero Node"
S %=$P(N,U,3) I $L(%)<1 Q "-1^Insufficient info to allow visiting: No Access Code"
S %=$P($G(^VA(200,DUZ,.1)),U,2) I $L(%)<1 Q "-1^Insufficient info to allow visiting: No Verify Code"
S %=$P(N,U,11) I $L(%)>1,(DT>%) Q "-1^Insufficient info to allow visiting: Terminated User"
I $P($$ACTIVE^XUSER(DUZ),U,1)'=1 Q "-1^Insufficient info to allow visiting: Not an active user"
;I $G(DUZ("LOA"))<2 Q "-1^Insufficient Level of Assurance to allow visiting: User not authenticated"
S NAME=$P(N,U)
I '$L(NAME) Q "-1^Insufficient info to allow visiting: No User Name"
;
S SITE=$$NS^XUAF4(DUZ(2)) ;Site is name^station#
I $P(SITE,U,2)="" Q "-1^Insufficient info to allow visiting: Missing Station Number"
;
S SSN=$P($G(^VA(200,DUZ,1)),U,9)
I $$SPECIAL($P(SITE,"^",2)) S SSN=999999999 ;Manila RO doesn't need SSN
I 'SSN Q "-1^Insufficient info to allow visiting: Missing SSN"
I $E(SSN,10)="P" Q "-1^Insufficient info to allow visiting: User has a pseudo SSN"
I '$$SSNCHECK(SSN) Q "-1^Insufficient info to allow visiting: User does not have a valid SSN"
;
S PHONE=$$PH
S X=SSN_U_NAME_U_SITE_U_DUZ
I $L(PHONE)>2&($L(PHONE<20)) S X=X_U_PHONE
S $P(X,U,7)=$P($G(^VA(200,DUZ,205.1)),U) ;p655 SecID
S $P(X,U,8)=$P($G(^VA(200,DUZ,501)),U) ;p655 Network Username
;X=ssn^name^station name^station number^DUZ^phone^SecID^network username
Q X
;
PH() ; Try for a phone number or pager
N %,X
S %=""
S X=$G(^VA(200,DUZ,.13))
I '$L(X) Q ""
S %=$P(X,U,5) I $L(%)>6 Q % ;Commercial #
S %=$P(X,U,2) I $L(%)>2 Q % ;Office
S %=$P(X,U,8) I $L(%)>6 Q % ;Digital Pager
S %=$P(X,U,7) I $L(%)>6 Q % ;Pager
S %=$P(X,U,3) I $L(%)>2 Q % ;Phone #3
S %=$P(X,U,4) I $L(%)>2 Q % ;Phone #4
S %=$P(X,U,1) I $L(%)>2 Q % ;Home Phone
Q "" ;Couldn't find one.
;
SPECIAL(SN) ;INTRINSIC. Special Manila RO site
; Returns 1 if SN is "358"
Q 358=SN
;
PUT(DATIN) ;;Setup data from authenticating site GET() at receiving site
;Called by OLDCAPRI^XUSBSE1 (Old Capri) and SETUP^XUSBSE1 (BSE)
;Called by DIQ^DGROHLU (Sensitive Patient access) and REMOTE^XWB2HL7 (Visitor access via HL7)
;Called by (unknown) (VSA/VistA.js)
;Return: 0=fail, 1=OK
N NAME,NETWORK,NEWDUZ,PHONE,RMTDUZ,SECID,SITE,SITENUM,SSN,TODAY,XSITEIEN,XT,XUMF
I $G(DUZ("LOA"))="" S DUZ("LOA")=1
;I $G(DUZ("LOA"))<2 Q 0 ;do not allow access if Level Of Assurance is low
I $G(DUZ("AUTHENTICATION"))="" S DUZ("AUTHENTICATION")="UNKNOWN"
S U="^",TODAY=$$HTFM^XLFDT($H),DT=$P(TODAY,"."),NEWDUZ=0
K ^TMP("DIERR",$J)
;
S SSN=$P(DATIN,U,1),NAME=$P(DATIN,U,2),SITE=$P(DATIN,U,3)
S SITENUM=$P(DATIN,U,4),RMTDUZ=$P(DATIN,U,5),PHONE=$P(DATIN,U,6)
S SECID=$P(DATIN,U,7) ;p655
S NETWORK=$P(DATIN,U,8) ;p655
;Format checks
I NAME'?1U.E1","1U.E Q 0
I SSN'?9N Q 0
I '$L(SITE)!('$L(SITENUM)) Q 0
S XUMF=1 D CHK^DIE(4,99,,SITENUM,.XT) I XT=U Q 0 ;p533
D CHK^DIE(200.06,1,,SITE,.XT) I XT=U Q 0 ;p533
I RMTDUZ'>0 Q 0 ;p337
;Check if visitor is from a valid active site
S XSITEIEN=$$IEN^XUAF4(SITENUM) I XSITEIEN="" H 1 ;Q 0 ;Quit if authenticating VistA not in INSTITUTION file (#4)
;I '$$ACTIVE^XUAF4(XSITEIEN) Q 0 ;Quit if authenticating VistA is not an active VA site (spoofed)
;I $P($$NS^XUAF4(XSITEIEN),"^",1)'=SITE Q 0 ;Quit if authenticating VistA name and station number mismatch (spoofed)
;Get a LOCK. Block if can't get.
L +^VA(200,"HL7"):10 Q:'$T 0
S XT=$$TALL($G(DUZ,0)) L -^VA(200,"HL7")
I XT Q $$SET(NEWDUZ) ;Return 1 if OK.
Q 0
;
TALL(XUDUZ) ;INTRINSIC. Test for existing user or adds a new one
; p771 replace parameter DUZ with XUDUZ to not hide DUZ nodes being used in function
; ZEXCEPT: NAME,NEWDUZ,PHONE,RMTDUZ,SITE,SITENUM,SSN,XSSN,TODAY,SECID,NETWORK ;global variables within this routine
; ZEXCEPT: DIC ;turn off DIC(0) for ^XUA4A7 (work around)
N FLAG,NEWREC,XUIAM,RETRY
S FLAG=0,DUZ(0)="@" ;Make sure we can add the entry
S XUIAM=1 ;Do not trigger IAM updates
;See if match SECID. Only use for lookup. Do not load SECID's.
S RETRY=1 ; p771 try MPI web service if not found
FIND ;
I $L(SECID) D
. S NEWDUZ=+$$SECMATCH^XUESSO2(SECID) Q:NEWDUZ<1 ;p655
. I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
. D ADDW,UPDT
. S FLAG=1,DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
. Q
I FLAG Q 1 ;Quit here if we found a match on SECID
;See if the SSN is in the NPF cross reference
I $D(^VA(200,"SSN",SSN)),$$SSNCHECK(SSN),'$$SPECIAL(SITENUM) D
. N XUEIEN,XUEAUSER
. S XUEIEN=0,NEWDUZ=0
. F S XUEIEN=$O(^VA(200,"SSN",SSN,XUEIEN)) Q:(XUEIEN="")!(NEWDUZ>0) D
. . N XUENAME S XUENAME=$P($G(^VA(200,XUEIEN,0)),U)
. . S NEWDUZ=XUEIEN
. . ;Update name if names don't match, user has visited before, and user is not an active local user
. . I (XUENAME'=NAME)&(XUEIEN=$O(^VA(200,"AVISIT",SITENUM,RMTDUZ,0)))&(('$$ACTIVE^XUSER(XUEIEN))) D ADDN
. Q:NEWDUZ'>0
. I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
. D ADDW,ADDI,UPDT
. S FLAG=1,DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
. Q
I FLAG Q 1 ;Quit here if we found a match for SSN
;See if in the AVISIT cross reference (Manila only)
I $$SPECIAL(SITENUM) D
. S NEWDUZ=$O(^VA(200,"AVISIT",SITENUM,RMTDUZ,0))
. Q:NEWDUZ'>0 ;User must have visited from Manila at least once to be found by this test
. D ADDW,ADDI,UPDT S FLAG=1,DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
. Q
I FLAG Q 1 ;Quit here if we found a match for AVISIT
;Try for a NAME match in "B"
N XUEIEN,XUESSN
S NAME=$$UP^XLFSTR(NAME)
I $D(^VA(200,"B",NAME)) D
. S XUEIEN=0,NEWDUZ=0
. F S XUEIEN=$O(^VA(200,"B",NAME,XUEIEN)) Q:(XUEIEN="")!(NEWDUZ>0) D
. . S XUESSN=$P($G(^VA(200,XUEIEN,1)),U,9)
. . I (XUESSN'=SSN)&($L(XUESSN)>8) Q ;Do not use if name has a different SSN
. . S NEWDUZ=XUEIEN
. I NEWDUZ>0 D
. . D ADDS
. . I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
. . D ADDW,ADDI,UPDT
. . S FLAG=1,DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
. Q
I FLAG Q 1 ;Quit here if we found an exact match for NAME (w/o SSN)
;
;I DUZ("LOA")=1 Q 0 ;Do not add user if Level Of Assurance is low
;I $G(DUZ("REMAPP"))="^MDWS" Q 0 ;Do not add user if MDWS access
I $G(DUZ("REMAPP"))="^MDWS" H $E(DT,1,3)-315 ;Discourage deprecated MDWS access
; p771 end of FIND. User not found, try MPI web service
I RETRY S RETRY=0,SECID=$$MPISECID($G(NETWORK)) G:$G(SECID)]"" FIND
ADD ;We didn't find anybody under SecID,SSN,VISITED FROM, or NAME so we add a new user
S DIC(0)="" ;Turn off ^XUA4A7 (work around)
;Put the name in the .01 field first.
D ADDU ;ADDU will set NEWDUZ
I NEWDUZ=0 Q 0 ;If NEWDUZ is still 0, the User add didn't work so exit.
D ADDS,ADDA ;(p337) Add SSN and "VISITOR" Alias.
D ADDW,ADDI ; Add NETWORK USERNAME and SSO attributes
D VISM,UPDT ; Fill in the VISITED FROM multiple
I NEWDUZ=0 Q 0 ;Couldn't update user
I $D(^TMP("DIERR",$J)) Q 0 ;FileMan Error
I ($G(DUZ("REMAPP"))'="") D SETREMAP^XUESSO2(NEWDUZ,$P(DUZ("REMAPP"),"^")) ; p771
;
S FLAG=$$BULL(NAME,NEWDUZ,SITE,SITENUM,RMTDUZ,PHONE,TODAY)
S DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
Q 1 ;Every thing OK
;
SET(NEWDUZ) ;INTRINSIC. Set the user up to go
; ZEXCEPT: RMTDUZ,SITENUM ;global variables within this routine
;Return: 0=fail, 1=OK
Q:NEWDUZ'>0 0
N XUSER,XOPT
S DUZ=NEWDUZ,U="^",DUZ("VISITOR")=SITENUM_U_RMTDUZ ;p533
D DUZ^XUS1A
Q 1
;
ADDU ;SR. Add a new name to the New Person File
; ZEXCEPT: FDR,NAME,NEWDUZ,NEWREC ;global variables within this routine
N DD,DO,DIC,DA,X,Y
S NEWDUZ=0
S DIC="^VA(200,",DIC(0)="F",X=NAME,NEWREC=1 ;p533
D FILE^DICN
S:Y>0 NEWDUZ=+Y
Q
;
ADDS ;SR. Add a SSN to the New Person File
; ZEXCEPT: FDR,NEWDUZ,SSN,SITENUM ;global variables within this routine
N IEN
Q:$$SPECIAL(SITENUM) ;don't add SSN if from Manila
Q:$D(^VA(200,"SSN",SSN)) ;don't try to add a duplicate SSN
Q:'$$SSNCHECK(SSN) ;only add a valid SSN
S IEN=NEWDUZ_","
S FDR(200,IEN,9)=SSN
;Do update for all data in UPDT
Q
;
ADDI ;SR. Add SSO attributes to the New Person File
; ZEXCEPT: FDR,NEWDUZ,SECID ;global variables within this routine
N IEN
Q:'$L(SECID) ;need SECID for SSO
S IEN=NEWDUZ_","
I $P($G(^VA(200,NEWDUZ,205)),U,1)="" S FDR(200,IEN,205.1)=SECID ;SECID
I $P($G(^VA(200,NEWDUZ,205)),U,2)="" S FDR(200,IEN,205.2)=$P($G(^XTV(8989.3,1,200)),U,2) ;Subject Organization
I $P($G(^VA(200,NEWDUZ,205)),U,3)="" S FDR(200,IEN,205.3)=$P($G(^XTV(8989.3,1,200)),U,3) ;Subject Organization ID
I $P($G(^VA(200,NEWDUZ,205)),U,4)="" S FDR(200,IEN,205.4)=SECID ;Unique User ID
;Do update for all data in UPDT
Q
;
ADDN ;SR. Update the NAME in the New Person File
; ZEXCEPT: FDR,NEWDUZ,NAME,RMTDUZ,SITENUM ;global variables within this routine
N IEN
Q:NAME=$P($G(^VA(200,NEWDUZ,0)),U,1) ; name is unchanged, do nothing
I NEWDUZ'=$O(^VA(200,"AVISIT",SITENUM,RMTDUZ,0)) Q ; user hasn't visited before, so this is not a valid name change
S IEN=NEWDUZ_","
S FDR(200,IEN,.01)=NAME
;Do update for all data in UPDT
Q
;
ADDA ;SR. Add a new Alias to file 200.04
; ZEXCEPT: FDR,NEWDUZ ;global variables within this routine
N IEN
Q:$D(^VA(200,NEWDUZ,3,"B","VISITOR")) ; Quit if user is already marked as visitor
S IEN="+2,"_NEWDUZ_","
S FDR(200.04,IEN,.01)="VISITOR"
;Do update for all data in UPDT
Q
;
ADDW ;SR. Add NETWORK USERNAME to the New Person File
; ZEXCEPT: FDR,NEWDUZ,NETWORK ;global variables within this routine
N IEN
Q:$G(^VA(200,NEWDUZ,501))'="" ; Quit if user already has a NETWORK USERNAME
Q:$L($G(NETWORK))<12 ; Quit if NETWORK USERNAME is too short
S IEN=NEWDUZ_","
S FDR(200,IEN,501.1)=$G(NETWORK)
;Do update for all data in UPDT
Q
;
VISM ;SR. Create a multiple for this site number in the VISITED FROM file
; ZEXCEPT: FDR,NEWDUZ,RMTDUZ,SITE,SITENUM,TODAY ;global variables within this routine
N IEN
S IEN="+3,"_NEWDUZ_","
S FDR(200.06,IEN,.01)=SITENUM
S FDR(200.06,IEN,1)=SITE
S FDR(200.06,IEN,2)=RMTDUZ
S FDR(200.06,IEN,3)=TODAY
;Do update for all data in UPDT
Q
;
UPDT ;SR. Update all data fields
; Sets: NEWDUZ=0 if failed to complete update
; ZEXCEPT: FDR,NAME,NEWDUZ,SITE,SITENUM,PHONE,TODAY,DATIN,NEWREC ;global variables within this routine
N IEN,FDQ
I $D(FDR(200.06)) S IEN=$O(FDR(200.06,""))
E S IEN=$O(^VA(200,NEWDUZ,8910,"B",SITENUM,0))_","_NEWDUZ_","
S FDR(200.06,IEN,4)=TODAY
I $D(PHONE),($L(PHONE)>4) S FDR(200.06,IEN,5)=PHONE ;p466 Update the phone each time
I $D(SITE) S FDR(200.06,IEN,1)=SITE ;p655 Update the site each time (name changes in INSTITUTION file)
;I ($G(DUZ("REMAPP"))'=""),'$P($G(^VA(200,NEWDUZ,1.1)),"^",6) S FDR(200,NEWDUZ_",",202.06)=$P(DUZ("REMAPP"),U) ; p771 label user as REMOTE
K IEN D UPDATE^DIE("E","FDR","IEN") ;File all the data
I $D(^TMP("DIERR",$J)) D Q
. N DIK,DA,Y
. I $D(NEWREC) S DIK="^VA(200,",DA=NEWDUZ D ^DIK ;Remove partial entry ;p533
. S NEWDUZ=0 ;Tell failed
Q
;
BULL(NAME,NEWDUZ,SITE,SITENUM,RMTDUZ,PHONE,TODAY) ;INTRINSIC. Send local bulletin if user added
; Returns: 0 if failed to send bulletin, 1 if success
; ZEXCEPT: XTMUNIT ;set for unit testing
N XMB
I ($G(NAME)="")!($G(NEWDUZ)="")!($G(SITE)="")!($G(SITENUM)="") Q 0
I ($G(RMTDUZ)="")!($G(PHONE)="")!($G(TODAY)="") Q 0
S XMB="XUVISIT"
S XMB(1)=$$FMTE^XLFDT(TODAY)
S XMB(2)=NAME,XMB(3)=NEWDUZ,XMB(4)=SITE
S XMB(5)=SITENUM,XMB(6)=RMTDUZ,XMB(7)=PHONE
I '$D(XTMUNIT) D ^XMB
Q 1
;
SSNCHECK(SSN) ;INTRINSIC. Check for valid SSN
; Input: SSN in format "nnnnnnnnn" or "nnn-nn-nnnn"
; Returns: 0 if SSN is invalid, 1 if success
; Valid SSN range 001-01-0001 to 899-99-9999 with exceptions (rule as of 2011)
; Valid Individual Taxpayer Identification Number range 900-01-0001 to 999-99-9999 with exceptions (rule as of 1966)
N X
I $$PROD^XUPROD()=0 Q 1 ;allow use of invalid SSNs in development accounts
S X=$TR(SSN,"-")
I $L(X)'=9 Q 0
I $E(X,1,3)'>0 Q 0 ;1st 3 digits cannot be 000
I $E(X,4,5)'>0 Q 0 ;digits 4-5 cannot be 00
I $E(X,6,9)'>0 Q 0 ;digits 6-9 cannot be 0000
I $E(X,1,3)=666 Q 0 ;1st 3 digits cannot be 666
I (X>987654319)&(X<987654330) Q 0 ;SSN range reserved for advertising
I ($E(X,1,3)>899)&($E(X,4,5)=89) Q 0 ;digits 4-5 of ITIN cannot be 89
I ($E(X,1,3)>899)&($E(X,4,5)=93) Q 0 ;digits 4-5 of ITIN cannot be 93
Q 1
;
MPISECID(NETNAME) ; Return SECID from MPI
; Called from $$TALL
N XMPI,XOUT
S XMPI("samacctnm")=$G(NETNAME)
D USER^XUIAMXML(.XOUT,.XMPI)
Q $G(XOUT("secId"))
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUESSO1 13372 printed Sep 23, 2025@19:45:32 Page 2
XUESSO1 ;SEA/LUKE - Single Sign-on Utilities ; Apr 08, 2022@13:58
+1 ;;8.0;KERNEL;**165,183,196,245,254,269,337,395,466,523,655,659,771**;Jul 10, 1995;Build 8
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
GET(INDUZ) ;Gather identifying data from user's home site.
+1 ;Called by SETVISIT^XUSBSE1 (Get visitor info for TOKEN)
+2 ;Called by SNDQRY^DGROHLS (Retrieve user info) and SETUP^XWB2HL7 (Get visitor info)
+3 ;Called by (unknown) (VSA/VistA.js)
+4 ;To visit a remote site, user must have: Name, Access/Verify Codes, SSN (no pseudo), Station Name, Site Number
+5 ;The following data is optional: Phone, SecID, Network Username
+6 NEW %,NAME,SITE,SSN,PHONE,X,N,NETWORK
+7 IF '$DATA(DUZ)
QUIT "-1^Insufficient info to allow visiting: No DUZ"
+8 IF '$DATA(DUZ(2))
QUIT "-1^Insufficient info to allow visiting: Missing DUZ(2)"
+9 SET N=$GET(^VA(200,DUZ,0))
+10 IF '$LENGTH(N)
QUIT "-1^Insufficient info to allow visiting: Missing NPF Zero Node"
+11 SET %=$PIECE(N,U,3)
IF $LENGTH(%)<1
QUIT "-1^Insufficient info to allow visiting: No Access Code"
+12 SET %=$PIECE($GET(^VA(200,DUZ,.1)),U,2)
IF $LENGTH(%)<1
QUIT "-1^Insufficient info to allow visiting: No Verify Code"
+13 SET %=$PIECE(N,U,11)
IF $LENGTH(%)>1
IF (DT>%)
QUIT "-1^Insufficient info to allow visiting: Terminated User"
+14 IF $PIECE($$ACTIVE^XUSER(DUZ),U,1)'=1
QUIT "-1^Insufficient info to allow visiting: Not an active user"
+15 ;I $G(DUZ("LOA"))<2 Q "-1^Insufficient Level of Assurance to allow visiting: User not authenticated"
+16 SET NAME=$PIECE(N,U)
+17 IF '$LENGTH(NAME)
QUIT "-1^Insufficient info to allow visiting: No User Name"
+18 ;
+19 ;Site is name^station#
SET SITE=$$NS^XUAF4(DUZ(2))
+20 IF $PIECE(SITE,U,2)=""
QUIT "-1^Insufficient info to allow visiting: Missing Station Number"
+21 ;
+22 SET SSN=$PIECE($GET(^VA(200,DUZ,1)),U,9)
+23 ;Manila RO doesn't need SSN
IF $$SPECIAL($PIECE(SITE,"^",2))
SET SSN=999999999
+24 IF 'SSN
QUIT "-1^Insufficient info to allow visiting: Missing SSN"
+25 IF $EXTRACT(SSN,10)="P"
QUIT "-1^Insufficient info to allow visiting: User has a pseudo SSN"
+26 IF '$$SSNCHECK(SSN)
QUIT "-1^Insufficient info to allow visiting: User does not have a valid SSN"
+27 ;
+28 SET PHONE=$$PH
+29 SET X=SSN_U_NAME_U_SITE_U_DUZ
+30 IF $LENGTH(PHONE)>2&($LENGTH(PHONE<20))
SET X=X_U_PHONE
+31 ;p655 SecID
SET $PIECE(X,U,7)=$PIECE($GET(^VA(200,DUZ,205.1)),U)
+32 ;p655 Network Username
SET $PIECE(X,U,8)=$PIECE($GET(^VA(200,DUZ,501)),U)
+33 ;X=ssn^name^station name^station number^DUZ^phone^SecID^network username
+34 QUIT X
+35 ;
PH() ; Try for a phone number or pager
+1 NEW %,X
+2 SET %=""
+3 SET X=$GET(^VA(200,DUZ,.13))
+4 IF '$LENGTH(X)
QUIT ""
+5 ;Commercial #
SET %=$PIECE(X,U,5)
IF $LENGTH(%)>6
QUIT %
+6 ;Office
SET %=$PIECE(X,U,2)
IF $LENGTH(%)>2
QUIT %
+7 ;Digital Pager
SET %=$PIECE(X,U,8)
IF $LENGTH(%)>6
QUIT %
+8 ;Pager
SET %=$PIECE(X,U,7)
IF $LENGTH(%)>6
QUIT %
+9 ;Phone #3
SET %=$PIECE(X,U,3)
IF $LENGTH(%)>2
QUIT %
+10 ;Phone #4
SET %=$PIECE(X,U,4)
IF $LENGTH(%)>2
QUIT %
+11 ;Home Phone
SET %=$PIECE(X,U,1)
IF $LENGTH(%)>2
QUIT %
+12 ;Couldn't find one.
QUIT ""
+13 ;
SPECIAL(SN) ;INTRINSIC. Special Manila RO site
+1 ; Returns 1 if SN is "358"
+2 QUIT 358=SN
+3 ;
PUT(DATIN) ;;Setup data from authenticating site GET() at receiving site
+1 ;Called by OLDCAPRI^XUSBSE1 (Old Capri) and SETUP^XUSBSE1 (BSE)
+2 ;Called by DIQ^DGROHLU (Sensitive Patient access) and REMOTE^XWB2HL7 (Visitor access via HL7)
+3 ;Called by (unknown) (VSA/VistA.js)
+4 ;Return: 0=fail, 1=OK
+5 NEW NAME,NETWORK,NEWDUZ,PHONE,RMTDUZ,SECID,SITE,SITENUM,SSN,TODAY,XSITEIEN,XT,XUMF
+6 IF $GET(DUZ("LOA"))=""
SET DUZ("LOA")=1
+7 ;I $G(DUZ("LOA"))<2 Q 0 ;do not allow access if Level Of Assurance is low
+8 IF $GET(DUZ("AUTHENTICATION"))=""
SET DUZ("AUTHENTICATION")="UNKNOWN"
+9 SET U="^"
SET TODAY=$$HTFM^XLFDT($HOROLOG)
SET DT=$PIECE(TODAY,".")
SET NEWDUZ=0
+10 KILL ^TMP("DIERR",$JOB)
+11 ;
+12 SET SSN=$PIECE(DATIN,U,1)
SET NAME=$PIECE(DATIN,U,2)
SET SITE=$PIECE(DATIN,U,3)
+13 SET SITENUM=$PIECE(DATIN,U,4)
SET RMTDUZ=$PIECE(DATIN,U,5)
SET PHONE=$PIECE(DATIN,U,6)
+14 ;p655
SET SECID=$PIECE(DATIN,U,7)
+15 ;p655
SET NETWORK=$PIECE(DATIN,U,8)
+16 ;Format checks
+17 IF NAME'?1U.E1","1U.E
QUIT 0
+18 IF SSN'?9N
QUIT 0
+19 IF '$LENGTH(SITE)!('$LENGTH(SITENUM))
QUIT 0
+20 ;p533
SET XUMF=1
DO CHK^DIE(4,99,,SITENUM,.XT)
IF XT=U
QUIT 0
+21 ;p533
DO CHK^DIE(200.06,1,,SITE,.XT)
IF XT=U
QUIT 0
+22 ;p337
IF RMTDUZ'>0
QUIT 0
+23 ;Check if visitor is from a valid active site
+24 ;Q 0 ;Quit if authenticating VistA not in INSTITUTION file (#4)
SET XSITEIEN=$$IEN^XUAF4(SITENUM)
IF XSITEIEN=""
HANG 1
+25 ;I '$$ACTIVE^XUAF4(XSITEIEN) Q 0 ;Quit if authenticating VistA is not an active VA site (spoofed)
+26 ;I $P($$NS^XUAF4(XSITEIEN),"^",1)'=SITE Q 0 ;Quit if authenticating VistA name and station number mismatch (spoofed)
+27 ;Get a LOCK. Block if can't get.
+28 LOCK +^VA(200,"HL7"):10
if '$TEST
QUIT 0
+29 SET XT=$$TALL($GET(DUZ,0))
LOCK -^VA(200,"HL7")
+30 ;Return 1 if OK.
IF XT
QUIT $$SET(NEWDUZ)
+31 QUIT 0
+32 ;
TALL(XUDUZ) ;INTRINSIC. Test for existing user or adds a new one
+1 ; p771 replace parameter DUZ with XUDUZ to not hide DUZ nodes being used in function
+2 ; ZEXCEPT: NAME,NEWDUZ,PHONE,RMTDUZ,SITE,SITENUM,SSN,XSSN,TODAY,SECID,NETWORK ;global variables within this routine
+3 ; ZEXCEPT: DIC ;turn off DIC(0) for ^XUA4A7 (work around)
+4 NEW FLAG,NEWREC,XUIAM,RETRY
+5 ;Make sure we can add the entry
SET FLAG=0
SET DUZ(0)="@"
+6 ;Do not trigger IAM updates
SET XUIAM=1
+7 ;See if match SECID. Only use for lookup. Do not load SECID's.
+8 ; p771 try MPI web service if not found
SET RETRY=1
FIND ;
+1 IF $LENGTH(SECID)
Begin DoDot:1
+2 ;p655
SET NEWDUZ=+$$SECMATCH^XUESSO2(SECID)
if NEWDUZ<1
QUIT
+3 IF '$DATA(^VA(200,NEWDUZ,8910,"B",SITENUM))
DO VISM
+4 DO ADDW
DO UPDT
+5 SET FLAG=1
SET DUZ(0)=$PIECE($GET(^VA(200,NEWDUZ,0)),U,4)
+6 QUIT
End DoDot:1
+7 ;Quit here if we found a match on SECID
IF FLAG
QUIT 1
+8 ;See if the SSN is in the NPF cross reference
+9 IF $DATA(^VA(200,"SSN",SSN))
IF $$SSNCHECK(SSN)
IF '$$SPECIAL(SITENUM)
Begin DoDot:1
+10 NEW XUEIEN,XUEAUSER
+11 SET XUEIEN=0
SET NEWDUZ=0
+12 FOR
SET XUEIEN=$ORDER(^VA(200,"SSN",SSN,XUEIEN))
if (XUEIEN="")!(NEWDUZ>0)
QUIT
Begin DoDot:2
+13 NEW XUENAME
SET XUENAME=$PIECE($GET(^VA(200,XUEIEN,0)),U)
+14 SET NEWDUZ=XUEIEN
+15 ;Update name if names don't match, user has visited before, and user is not an active local user
+16 IF (XUENAME'=NAME)&(XUEIEN=$ORDER(^VA(200,"AVISIT",SITENUM,RMTDUZ,0)))&(('$$ACTIVE^XUSER(XUEIEN)))
DO ADDN
End DoDot:2
+17 if NEWDUZ'>0
QUIT
+18 IF '$DATA(^VA(200,NEWDUZ,8910,"B",SITENUM))
DO VISM
+19 DO ADDW
DO ADDI
DO UPDT
+20 SET FLAG=1
SET DUZ(0)=$PIECE($GET(^VA(200,NEWDUZ,0)),U,4)
+21 QUIT
End DoDot:1
+22 ;Quit here if we found a match for SSN
IF FLAG
QUIT 1
+23 ;See if in the AVISIT cross reference (Manila only)
+24 IF $$SPECIAL(SITENUM)
Begin DoDot:1
+25 SET NEWDUZ=$ORDER(^VA(200,"AVISIT",SITENUM,RMTDUZ,0))
+26 ;User must have visited from Manila at least once to be found by this test
if NEWDUZ'>0
QUIT
+27 DO ADDW
DO ADDI
DO UPDT
SET FLAG=1
SET DUZ(0)=$PIECE($GET(^VA(200,NEWDUZ,0)),U,4)
+28 QUIT
End DoDot:1
+29 ;Quit here if we found a match for AVISIT
IF FLAG
QUIT 1
+30 ;Try for a NAME match in "B"
+31 NEW XUEIEN,XUESSN
+32 SET NAME=$$UP^XLFSTR(NAME)
+33 IF $DATA(^VA(200,"B",NAME))
Begin DoDot:1
+34 SET XUEIEN=0
SET NEWDUZ=0
+35 FOR
SET XUEIEN=$ORDER(^VA(200,"B",NAME,XUEIEN))
if (XUEIEN="")!(NEWDUZ>0)
QUIT
Begin DoDot:2
+36 SET XUESSN=$PIECE($GET(^VA(200,XUEIEN,1)),U,9)
+37 ;Do not use if name has a different SSN
IF (XUESSN'=SSN)&($LENGTH(XUESSN)>8)
QUIT
+38 SET NEWDUZ=XUEIEN
End DoDot:2
+39 IF NEWDUZ>0
Begin DoDot:2
+40 DO ADDS
+41 IF '$DATA(^VA(200,NEWDUZ,8910,"B",SITENUM))
DO VISM
+42 DO ADDW
DO ADDI
DO UPDT
+43 SET FLAG=1
SET DUZ(0)=$PIECE($GET(^VA(200,NEWDUZ,0)),U,4)
End DoDot:2
+44 QUIT
End DoDot:1
+45 ;Quit here if we found an exact match for NAME (w/o SSN)
IF FLAG
QUIT 1
+46 ;
+47 ;I DUZ("LOA")=1 Q 0 ;Do not add user if Level Of Assurance is low
+48 ;I $G(DUZ("REMAPP"))="^MDWS" Q 0 ;Do not add user if MDWS access
+49 ;Discourage deprecated MDWS access
IF $GET(DUZ("REMAPP"))="^MDWS"
HANG $EXTRACT(DT,1,3)-315
+50 ; p771 end of FIND. User not found, try MPI web service
+51 IF RETRY
SET RETRY=0
SET SECID=$$MPISECID($GET(NETWORK))
if $GET(SECID)]""
GOTO FIND
ADD ;We didn't find anybody under SecID,SSN,VISITED FROM, or NAME so we add a new user
+1 ;Turn off ^XUA4A7 (work around)
SET DIC(0)=""
+2 ;Put the name in the .01 field first.
+3 ;ADDU will set NEWDUZ
DO ADDU
+4 ;If NEWDUZ is still 0, the User add didn't work so exit.
IF NEWDUZ=0
QUIT 0
+5 ;(p337) Add SSN and "VISITOR" Alias.
DO ADDS
DO ADDA
+6 ; Add NETWORK USERNAME and SSO attributes
DO ADDW
DO ADDI
+7 ; Fill in the VISITED FROM multiple
DO VISM
DO UPDT
+8 ;Couldn't update user
IF NEWDUZ=0
QUIT 0
+9 ;FileMan Error
IF $DATA(^TMP("DIERR",$JOB))
QUIT 0
+10 ; p771
IF ($GET(DUZ("REMAPP"))'="")
DO SETREMAP^XUESSO2(NEWDUZ,$PIECE(DUZ("REMAPP"),"^"))
+11 ;
+12 SET FLAG=$$BULL(NAME,NEWDUZ,SITE,SITENUM,RMTDUZ,PHONE,TODAY)
+13 SET DUZ(0)=$PIECE($GET(^VA(200,NEWDUZ,0)),U,4)
+14 ;Every thing OK
QUIT 1
+15 ;
SET(NEWDUZ) ;INTRINSIC. Set the user up to go
+1 ; ZEXCEPT: RMTDUZ,SITENUM ;global variables within this routine
+2 ;Return: 0=fail, 1=OK
+3 if NEWDUZ'>0
QUIT 0
+4 NEW XUSER,XOPT
+5 ;p533
SET DUZ=NEWDUZ
SET U="^"
SET DUZ("VISITOR")=SITENUM_U_RMTDUZ
+6 DO DUZ^XUS1A
+7 QUIT 1
+8 ;
ADDU ;SR. Add a new name to the New Person File
+1 ; ZEXCEPT: FDR,NAME,NEWDUZ,NEWREC ;global variables within this routine
+2 NEW DD,DO,DIC,DA,X,Y
+3 SET NEWDUZ=0
+4 ;p533
SET DIC="^VA(200,"
SET DIC(0)="F"
SET X=NAME
SET NEWREC=1
+5 DO FILE^DICN
+6 if Y>0
SET NEWDUZ=+Y
+7 QUIT
+8 ;
ADDS ;SR. Add a SSN to the New Person File
+1 ; ZEXCEPT: FDR,NEWDUZ,SSN,SITENUM ;global variables within this routine
+2 NEW IEN
+3 ;don't add SSN if from Manila
if $$SPECIAL(SITENUM)
QUIT
+4 ;don't try to add a duplicate SSN
if $DATA(^VA(200,"SSN",SSN))
QUIT
+5 ;only add a valid SSN
if '$$SSNCHECK(SSN)
QUIT
+6 SET IEN=NEWDUZ_","
+7 SET FDR(200,IEN,9)=SSN
+8 ;Do update for all data in UPDT
+9 QUIT
+10 ;
ADDI ;SR. Add SSO attributes to the New Person File
+1 ; ZEXCEPT: FDR,NEWDUZ,SECID ;global variables within this routine
+2 NEW IEN
+3 ;need SECID for SSO
if '$LENGTH(SECID)
QUIT
+4 SET IEN=NEWDUZ_","
+5 ;SECID
IF $PIECE($GET(^VA(200,NEWDUZ,205)),U,1)=""
SET FDR(200,IEN,205.1)=SECID
+6 ;Subject Organization
IF $PIECE($GET(^VA(200,NEWDUZ,205)),U,2)=""
SET FDR(200,IEN,205.2)=$PIECE($GET(^XTV(8989.3,1,200)),U,2)
+7 ;Subject Organization ID
IF $PIECE($GET(^VA(200,NEWDUZ,205)),U,3)=""
SET FDR(200,IEN,205.3)=$PIECE($GET(^XTV(8989.3,1,200)),U,3)
+8 ;Unique User ID
IF $PIECE($GET(^VA(200,NEWDUZ,205)),U,4)=""
SET FDR(200,IEN,205.4)=SECID
+9 ;Do update for all data in UPDT
+10 QUIT
+11 ;
ADDN ;SR. Update the NAME in the New Person File
+1 ; ZEXCEPT: FDR,NEWDUZ,NAME,RMTDUZ,SITENUM ;global variables within this routine
+2 NEW IEN
+3 ; name is unchanged, do nothing
if NAME=$PIECE($GET(^VA(200,NEWDUZ,0)),U,1)
QUIT
+4 ; user hasn't visited before, so this is not a valid name change
IF NEWDUZ'=$ORDER(^VA(200,"AVISIT",SITENUM,RMTDUZ,0))
QUIT
+5 SET IEN=NEWDUZ_","
+6 SET FDR(200,IEN,.01)=NAME
+7 ;Do update for all data in UPDT
+8 QUIT
+9 ;
ADDA ;SR. Add a new Alias to file 200.04
+1 ; ZEXCEPT: FDR,NEWDUZ ;global variables within this routine
+2 NEW IEN
+3 ; Quit if user is already marked as visitor
if $DATA(^VA(200,NEWDUZ,3,"B","VISITOR"))
QUIT
+4 SET IEN="+2,"_NEWDUZ_","
+5 SET FDR(200.04,IEN,.01)="VISITOR"
+6 ;Do update for all data in UPDT
+7 QUIT
+8 ;
ADDW ;SR. Add NETWORK USERNAME to the New Person File
+1 ; ZEXCEPT: FDR,NEWDUZ,NETWORK ;global variables within this routine
+2 NEW IEN
+3 ; Quit if user already has a NETWORK USERNAME
if $GET(^VA(200,NEWDUZ,501))'=""
QUIT
+4 ; Quit if NETWORK USERNAME is too short
if $LENGTH($GET(NETWORK))<12
QUIT
+5 SET IEN=NEWDUZ_","
+6 SET FDR(200,IEN,501.1)=$GET(NETWORK)
+7 ;Do update for all data in UPDT
+8 QUIT
+9 ;
VISM ;SR. Create a multiple for this site number in the VISITED FROM file
+1 ; ZEXCEPT: FDR,NEWDUZ,RMTDUZ,SITE,SITENUM,TODAY ;global variables within this routine
+2 NEW IEN
+3 SET IEN="+3,"_NEWDUZ_","
+4 SET FDR(200.06,IEN,.01)=SITENUM
+5 SET FDR(200.06,IEN,1)=SITE
+6 SET FDR(200.06,IEN,2)=RMTDUZ
+7 SET FDR(200.06,IEN,3)=TODAY
+8 ;Do update for all data in UPDT
+9 QUIT
+10 ;
UPDT ;SR. Update all data fields
+1 ; Sets: NEWDUZ=0 if failed to complete update
+2 ; ZEXCEPT: FDR,NAME,NEWDUZ,SITE,SITENUM,PHONE,TODAY,DATIN,NEWREC ;global variables within this routine
+3 NEW IEN,FDQ
+4 IF $DATA(FDR(200.06))
SET IEN=$ORDER(FDR(200.06,""))
+5 IF '$TEST
SET IEN=$ORDER(^VA(200,NEWDUZ,8910,"B",SITENUM,0))_","_NEWDUZ_","
+6 SET FDR(200.06,IEN,4)=TODAY
+7 ;p466 Update the phone each time
IF $DATA(PHONE)
IF ($LENGTH(PHONE)>4)
SET FDR(200.06,IEN,5)=PHONE
+8 ;p655 Update the site each time (name changes in INSTITUTION file)
IF $DATA(SITE)
SET FDR(200.06,IEN,1)=SITE
+9 ;I ($G(DUZ("REMAPP"))'=""),'$P($G(^VA(200,NEWDUZ,1.1)),"^",6) S FDR(200,NEWDUZ_",",202.06)=$P(DUZ("REMAPP"),U) ; p771 label user as REMOTE
+10 ;File all the data
KILL IEN
DO UPDATE^DIE("E","FDR","IEN")
+11 IF $DATA(^TMP("DIERR",$JOB))
Begin DoDot:1
+12 NEW DIK,DA,Y
+13 ;Remove partial entry ;p533
IF $DATA(NEWREC)
SET DIK="^VA(200,"
SET DA=NEWDUZ
DO ^DIK
+14 ;Tell failed
SET NEWDUZ=0
End DoDot:1
QUIT
+15 QUIT
+16 ;
BULL(NAME,NEWDUZ,SITE,SITENUM,RMTDUZ,PHONE,TODAY) ;INTRINSIC. Send local bulletin if user added
+1 ; Returns: 0 if failed to send bulletin, 1 if success
+2 ; ZEXCEPT: XTMUNIT ;set for unit testing
+3 NEW XMB
+4 IF ($GET(NAME)="")!($GET(NEWDUZ)="")!($GET(SITE)="")!($GET(SITENUM)="")
QUIT 0
+5 IF ($GET(RMTDUZ)="")!($GET(PHONE)="")!($GET(TODAY)="")
QUIT 0
+6 SET XMB="XUVISIT"
+7 SET XMB(1)=$$FMTE^XLFDT(TODAY)
+8 SET XMB(2)=NAME
SET XMB(3)=NEWDUZ
SET XMB(4)=SITE
+9 SET XMB(5)=SITENUM
SET XMB(6)=RMTDUZ
SET XMB(7)=PHONE
+10 IF '$DATA(XTMUNIT)
DO ^XMB
+11 QUIT 1
+12 ;
SSNCHECK(SSN) ;INTRINSIC. Check for valid SSN
+1 ; Input: SSN in format "nnnnnnnnn" or "nnn-nn-nnnn"
+2 ; Returns: 0 if SSN is invalid, 1 if success
+3 ; Valid SSN range 001-01-0001 to 899-99-9999 with exceptions (rule as of 2011)
+4 ; Valid Individual Taxpayer Identification Number range 900-01-0001 to 999-99-9999 with exceptions (rule as of 1966)
+5 NEW X
+6 ;allow use of invalid SSNs in development accounts
IF $$PROD^XUPROD()=0
QUIT 1
+7 SET X=$TRANSLATE(SSN,"-")
+8 IF $LENGTH(X)'=9
QUIT 0
+9 ;1st 3 digits cannot be 000
IF $EXTRACT(X,1,3)'>0
QUIT 0
+10 ;digits 4-5 cannot be 00
IF $EXTRACT(X,4,5)'>0
QUIT 0
+11 ;digits 6-9 cannot be 0000
IF $EXTRACT(X,6,9)'>0
QUIT 0
+12 ;1st 3 digits cannot be 666
IF $EXTRACT(X,1,3)=666
QUIT 0
+13 ;SSN range reserved for advertising
IF (X>987654319)&(X<987654330)
QUIT 0
+14 ;digits 4-5 of ITIN cannot be 89
IF ($EXTRACT(X,1,3)>899)&($EXTRACT(X,4,5)=89)
QUIT 0
+15 ;digits 4-5 of ITIN cannot be 93
IF ($EXTRACT(X,1,3)>899)&($EXTRACT(X,4,5)=93)
QUIT 0
+16 QUIT 1
+17 ;
MPISECID(NETNAME) ; Return SECID from MPI
+1 ; Called from $$TALL
+2 NEW XMPI,XOUT
+3 SET XMPI("samacctnm")=$GET(NETNAME)
+4 DO USER^XUIAMXML(.XOUT,.XMPI)
+5 QUIT $GET(XOUT("secId"))
+6 ;
