Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XUESSO1

XUESSO1.m

Go to the documentation of this file.
  1. 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
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. GET(INDUZ) ;Gather identifying data from user's home site.
  1. ;Called by SETVISIT^XUSBSE1 (Get visitor info for TOKEN)
  1. ;Called by SNDQRY^DGROHLS (Retrieve user info) and SETUP^XWB2HL7 (Get visitor info)
  1. ;Called by (unknown) (VSA/VistA.js)
  1. ;To visit a remote site, user must have: Name, Access/Verify Codes, SSN (no pseudo), Station Name, Site Number
  1. ;The following data is optional: Phone, SecID, Network Username
  1. N %,NAME,SITE,SSN,PHONE,X,N,NETWORK
  1. I '$D(DUZ) Q "-1^Insufficient info to allow visiting: No DUZ"
  1. I '$D(DUZ(2)) Q "-1^Insufficient info to allow visiting: Missing DUZ(2)"
  1. S N=$G(^VA(200,DUZ,0))
  1. I '$L(N) Q "-1^Insufficient info to allow visiting: Missing NPF Zero Node"
  1. S %=$P(N,U,3) I $L(%)<1 Q "-1^Insufficient info to allow visiting: No Access Code"
  1. S %=$P($G(^VA(200,DUZ,.1)),U,2) I $L(%)<1 Q "-1^Insufficient info to allow visiting: No Verify Code"
  1. S %=$P(N,U,11) I $L(%)>1,(DT>%) Q "-1^Insufficient info to allow visiting: Terminated User"
  1. I $P($$ACTIVE^XUSER(DUZ),U,1)'=1 Q "-1^Insufficient info to allow visiting: Not an active user"
  1. ;I $G(DUZ("LOA"))<2 Q "-1^Insufficient Level of Assurance to allow visiting: User not authenticated"
  1. S NAME=$P(N,U)
  1. I '$L(NAME) Q "-1^Insufficient info to allow visiting: No User Name"
  1. ;
  1. S SITE=$$NS^XUAF4(DUZ(2)) ;Site is name^station#
  1. I $P(SITE,U,2)="" Q "-1^Insufficient info to allow visiting: Missing Station Number"
  1. ;
  1. S SSN=$P($G(^VA(200,DUZ,1)),U,9)
  1. I $$SPECIAL($P(SITE,"^",2)) S SSN=999999999 ;Manila RO doesn't need SSN
  1. I 'SSN Q "-1^Insufficient info to allow visiting: Missing SSN"
  1. I $E(SSN,10)="P" Q "-1^Insufficient info to allow visiting: User has a pseudo SSN"
  1. I '$$SSNCHECK(SSN) Q "-1^Insufficient info to allow visiting: User does not have a valid SSN"
  1. ;
  1. S PHONE=$$PH
  1. S X=SSN_U_NAME_U_SITE_U_DUZ
  1. I $L(PHONE)>2&($L(PHONE<20)) S X=X_U_PHONE
  1. S $P(X,U,7)=$P($G(^VA(200,DUZ,205.1)),U) ;p655 SecID
  1. S $P(X,U,8)=$P($G(^VA(200,DUZ,501)),U) ;p655 Network Username
  1. ;X=ssn^name^station name^station number^DUZ^phone^SecID^network username
  1. Q X
  1. ;
  1. PH() ; Try for a phone number or pager
  1. N %,X
  1. S %=""
  1. S X=$G(^VA(200,DUZ,.13))
  1. I '$L(X) Q ""
  1. S %=$P(X,U,5) I $L(%)>6 Q % ;Commercial #
  1. S %=$P(X,U,2) I $L(%)>2 Q % ;Office
  1. S %=$P(X,U,8) I $L(%)>6 Q % ;Digital Pager
  1. S %=$P(X,U,7) I $L(%)>6 Q % ;Pager
  1. S %=$P(X,U,3) I $L(%)>2 Q % ;Phone #3
  1. S %=$P(X,U,4) I $L(%)>2 Q % ;Phone #4
  1. S %=$P(X,U,1) I $L(%)>2 Q % ;Home Phone
  1. Q "" ;Couldn't find one.
  1. ;
  1. SPECIAL(SN) ;INTRINSIC. Special Manila RO site
  1. ; Returns 1 if SN is "358"
  1. Q 358=SN
  1. ;
  1. PUT(DATIN) ;;Setup data from authenticating site GET() at receiving site
  1. ;Called by OLDCAPRI^XUSBSE1 (Old Capri) and SETUP^XUSBSE1 (BSE)
  1. ;Called by DIQ^DGROHLU (Sensitive Patient access) and REMOTE^XWB2HL7 (Visitor access via HL7)
  1. ;Called by (unknown) (VSA/VistA.js)
  1. ;Return: 0=fail, 1=OK
  1. N NAME,NETWORK,NEWDUZ,PHONE,RMTDUZ,SECID,SITE,SITENUM,SSN,TODAY,XSITEIEN,XT,XUMF
  1. I $G(DUZ("LOA"))="" S DUZ("LOA")=1
  1. ;I $G(DUZ("LOA"))<2 Q 0 ;do not allow access if Level Of Assurance is low
  1. I $G(DUZ("AUTHENTICATION"))="" S DUZ("AUTHENTICATION")="UNKNOWN"
  1. S U="^",TODAY=$$HTFM^XLFDT($H),DT=$P(TODAY,"."),NEWDUZ=0
  1. K ^TMP("DIERR",$J)
  1. ;
  1. S SSN=$P(DATIN,U,1),NAME=$P(DATIN,U,2),SITE=$P(DATIN,U,3)
  1. S SITENUM=$P(DATIN,U,4),RMTDUZ=$P(DATIN,U,5),PHONE=$P(DATIN,U,6)
  1. S SECID=$P(DATIN,U,7) ;p655
  1. S NETWORK=$P(DATIN,U,8) ;p655
  1. ;Format checks
  1. I NAME'?1U.E1","1U.E Q 0
  1. I SSN'?9N Q 0
  1. I '$L(SITE)!('$L(SITENUM)) Q 0
  1. S XUMF=1 D CHK^DIE(4,99,,SITENUM,.XT) I XT=U Q 0 ;p533
  1. D CHK^DIE(200.06,1,,SITE,.XT) I XT=U Q 0 ;p533
  1. I RMTDUZ'>0 Q 0 ;p337
  1. ;Check if visitor is from a valid active site
  1. S XSITEIEN=$$IEN^XUAF4(SITENUM) I XSITEIEN="" H 1 ;Q 0 ;Quit if authenticating VistA not in INSTITUTION file (#4)
  1. ;I '$$ACTIVE^XUAF4(XSITEIEN) Q 0 ;Quit if authenticating VistA is not an active VA site (spoofed)
  1. ;I $P($$NS^XUAF4(XSITEIEN),"^",1)'=SITE Q 0 ;Quit if authenticating VistA name and station number mismatch (spoofed)
  1. ;Get a LOCK. Block if can't get.
  1. L +^VA(200,"HL7"):10 Q:'$T 0
  1. S XT=$$TALL($G(DUZ,0)) L -^VA(200,"HL7")
  1. I XT Q $$SET(NEWDUZ) ;Return 1 if OK.
  1. Q 0
  1. ;
  1. 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
  1. ; ZEXCEPT: NAME,NEWDUZ,PHONE,RMTDUZ,SITE,SITENUM,SSN,XSSN,TODAY,SECID,NETWORK ;global variables within this routine
  1. ; ZEXCEPT: DIC ;turn off DIC(0) for ^XUA4A7 (work around)
  1. N FLAG,NEWREC,XUIAM,RETRY
  1. S FLAG=0,DUZ(0)="@" ;Make sure we can add the entry
  1. S XUIAM=1 ;Do not trigger IAM updates
  1. ;See if match SECID. Only use for lookup. Do not load SECID's.
  1. S RETRY=1 ; p771 try MPI web service if not found
  1. FIND ;
  1. I $L(SECID) D
  1. . S NEWDUZ=+$$SECMATCH^XUESSO2(SECID) Q:NEWDUZ<1 ;p655
  1. . I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
  1. . D ADDW,UPDT
  1. . S FLAG=1,DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
  1. . Q
  1. I FLAG Q 1 ;Quit here if we found a match on SECID
  1. ;See if the SSN is in the NPF cross reference
  1. I $D(^VA(200,"SSN",SSN)),$$SSNCHECK(SSN),'$$SPECIAL(SITENUM) D
  1. . N XUEIEN,XUEAUSER
  1. . S XUEIEN=0,NEWDUZ=0
  1. . F S XUEIEN=$O(^VA(200,"SSN",SSN,XUEIEN)) Q:(XUEIEN="")!(NEWDUZ>0) D
  1. . . N XUENAME S XUENAME=$P($G(^VA(200,XUEIEN,0)),U)
  1. . . S NEWDUZ=XUEIEN
  1. . . ;Update name if names don't match, user has visited before, and user is not an active local user
  1. . . I (XUENAME'=NAME)&(XUEIEN=$O(^VA(200,"AVISIT",SITENUM,RMTDUZ,0)))&(('$$ACTIVE^XUSER(XUEIEN))) D ADDN
  1. . Q:NEWDUZ'>0
  1. . I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
  1. . D ADDW,ADDI,UPDT
  1. . S FLAG=1,DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
  1. . Q
  1. I FLAG Q 1 ;Quit here if we found a match for SSN
  1. ;See if in the AVISIT cross reference (Manila only)
  1. I $$SPECIAL(SITENUM) D
  1. . S NEWDUZ=$O(^VA(200,"AVISIT",SITENUM,RMTDUZ,0))
  1. . Q:NEWDUZ'>0 ;User must have visited from Manila at least once to be found by this test
  1. . D ADDW,ADDI,UPDT S FLAG=1,DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
  1. . Q
  1. I FLAG Q 1 ;Quit here if we found a match for AVISIT
  1. ;Try for a NAME match in "B"
  1. N XUEIEN,XUESSN
  1. S NAME=$$UP^XLFSTR(NAME)
  1. I $D(^VA(200,"B",NAME)) D
  1. . S XUEIEN=0,NEWDUZ=0
  1. . F S XUEIEN=$O(^VA(200,"B",NAME,XUEIEN)) Q:(XUEIEN="")!(NEWDUZ>0) D
  1. . . S XUESSN=$P($G(^VA(200,XUEIEN,1)),U,9)
  1. . . I (XUESSN'=SSN)&($L(XUESSN)>8) Q ;Do not use if name has a different SSN
  1. . . S NEWDUZ=XUEIEN
  1. . I NEWDUZ>0 D
  1. . . D ADDS
  1. . . I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
  1. . . D ADDW,ADDI,UPDT
  1. . . S FLAG=1,DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
  1. . Q
  1. I FLAG Q 1 ;Quit here if we found an exact match for NAME (w/o SSN)
  1. ;
  1. ;I DUZ("LOA")=1 Q 0 ;Do not add user if Level Of Assurance is low
  1. ;I $G(DUZ("REMAPP"))="^MDWS" Q 0 ;Do not add user if MDWS access
  1. I $G(DUZ("REMAPP"))="^MDWS" H $E(DT,1,3)-315 ;Discourage deprecated MDWS access
  1. ; p771 end of FIND. User not found, try MPI web service
  1. I RETRY S RETRY=0,SECID=$$MPISECID($G(NETWORK)) G:$G(SECID)]"" FIND
  1. ADD ;We didn't find anybody under SecID,SSN,VISITED FROM, or NAME so we add a new user
  1. S DIC(0)="" ;Turn off ^XUA4A7 (work around)
  1. ;Put the name in the .01 field first.
  1. D ADDU ;ADDU will set NEWDUZ
  1. I NEWDUZ=0 Q 0 ;If NEWDUZ is still 0, the User add didn't work so exit.
  1. D ADDS,ADDA ;(p337) Add SSN and "VISITOR" Alias.
  1. D ADDW,ADDI ; Add NETWORK USERNAME and SSO attributes
  1. D VISM,UPDT ; Fill in the VISITED FROM multiple
  1. I NEWDUZ=0 Q 0 ;Couldn't update user
  1. I $D(^TMP("DIERR",$J)) Q 0 ;FileMan Error
  1. I ($G(DUZ("REMAPP"))'="") D SETREMAP^XUESSO2(NEWDUZ,$P(DUZ("REMAPP"),"^")) ; p771
  1. ;
  1. S FLAG=$$BULL(NAME,NEWDUZ,SITE,SITENUM,RMTDUZ,PHONE,TODAY)
  1. S DUZ(0)=$P($G(^VA(200,NEWDUZ,0)),U,4)
  1. Q 1 ;Every thing OK
  1. ;
  1. SET(NEWDUZ) ;INTRINSIC. Set the user up to go
  1. ; ZEXCEPT: RMTDUZ,SITENUM ;global variables within this routine
  1. ;Return: 0=fail, 1=OK
  1. Q:NEWDUZ'>0 0
  1. N XUSER,XOPT
  1. S DUZ=NEWDUZ,U="^",DUZ("VISITOR")=SITENUM_U_RMTDUZ ;p533
  1. D DUZ^XUS1A
  1. Q 1
  1. ;
  1. ADDU ;SR. Add a new name to the New Person File
  1. ; ZEXCEPT: FDR,NAME,NEWDUZ,NEWREC ;global variables within this routine
  1. N DD,DO,DIC,DA,X,Y
  1. S NEWDUZ=0
  1. S DIC="^VA(200,",DIC(0)="F",X=NAME,NEWREC=1 ;p533
  1. D FILE^DICN
  1. S:Y>0 NEWDUZ=+Y
  1. Q
  1. ;
  1. ADDS ;SR. Add a SSN to the New Person File
  1. ; ZEXCEPT: FDR,NEWDUZ,SSN,SITENUM ;global variables within this routine
  1. N IEN
  1. Q:$$SPECIAL(SITENUM) ;don't add SSN if from Manila
  1. Q:$D(^VA(200,"SSN",SSN)) ;don't try to add a duplicate SSN
  1. Q:'$$SSNCHECK(SSN) ;only add a valid SSN
  1. S IEN=NEWDUZ_","
  1. S FDR(200,IEN,9)=SSN
  1. ;Do update for all data in UPDT
  1. Q
  1. ;
  1. ADDI ;SR. Add SSO attributes to the New Person File
  1. ; ZEXCEPT: FDR,NEWDUZ,SECID ;global variables within this routine
  1. N IEN
  1. Q:'$L(SECID) ;need SECID for SSO
  1. S IEN=NEWDUZ_","
  1. I $P($G(^VA(200,NEWDUZ,205)),U,1)="" S FDR(200,IEN,205.1)=SECID ;SECID
  1. 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
  1. 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
  1. I $P($G(^VA(200,NEWDUZ,205)),U,4)="" S FDR(200,IEN,205.4)=SECID ;Unique User ID
  1. ;Do update for all data in UPDT
  1. Q
  1. ;
  1. ADDN ;SR. Update the NAME in the New Person File
  1. ; ZEXCEPT: FDR,NEWDUZ,NAME,RMTDUZ,SITENUM ;global variables within this routine
  1. N IEN
  1. Q:NAME=$P($G(^VA(200,NEWDUZ,0)),U,1) ; name is unchanged, do nothing
  1. I NEWDUZ'=$O(^VA(200,"AVISIT",SITENUM,RMTDUZ,0)) Q ; user hasn't visited before, so this is not a valid name change
  1. S IEN=NEWDUZ_","
  1. S FDR(200,IEN,.01)=NAME
  1. ;Do update for all data in UPDT
  1. Q
  1. ;
  1. ADDA ;SR. Add a new Alias to file 200.04
  1. ; ZEXCEPT: FDR,NEWDUZ ;global variables within this routine
  1. N IEN
  1. Q:$D(^VA(200,NEWDUZ,3,"B","VISITOR")) ; Quit if user is already marked as visitor
  1. S IEN="+2,"_NEWDUZ_","
  1. S FDR(200.04,IEN,.01)="VISITOR"
  1. ;Do update for all data in UPDT
  1. Q
  1. ;
  1. ADDW ;SR. Add NETWORK USERNAME to the New Person File
  1. ; ZEXCEPT: FDR,NEWDUZ,NETWORK ;global variables within this routine
  1. N IEN
  1. Q:$G(^VA(200,NEWDUZ,501))'="" ; Quit if user already has a NETWORK USERNAME
  1. Q:$L($G(NETWORK))<12 ; Quit if NETWORK USERNAME is too short
  1. S IEN=NEWDUZ_","
  1. S FDR(200,IEN,501.1)=$G(NETWORK)
  1. ;Do update for all data in UPDT
  1. Q
  1. ;
  1. 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
  1. N IEN
  1. S IEN="+3,"_NEWDUZ_","
  1. S FDR(200.06,IEN,.01)=SITENUM
  1. S FDR(200.06,IEN,1)=SITE
  1. S FDR(200.06,IEN,2)=RMTDUZ
  1. S FDR(200.06,IEN,3)=TODAY
  1. ;Do update for all data in UPDT
  1. Q
  1. ;
  1. UPDT ;SR. Update all data fields
  1. ; Sets: NEWDUZ=0 if failed to complete update
  1. ; ZEXCEPT: FDR,NAME,NEWDUZ,SITE,SITENUM,PHONE,TODAY,DATIN,NEWREC ;global variables within this routine
  1. N IEN,FDQ
  1. I $D(FDR(200.06)) S IEN=$O(FDR(200.06,""))
  1. E S IEN=$O(^VA(200,NEWDUZ,8910,"B",SITENUM,0))_","_NEWDUZ_","
  1. S FDR(200.06,IEN,4)=TODAY
  1. I $D(PHONE),($L(PHONE)>4) S FDR(200.06,IEN,5)=PHONE ;p466 Update the phone each time
  1. I $D(SITE) S FDR(200.06,IEN,1)=SITE ;p655 Update the site each time (name changes in INSTITUTION file)
  1. ;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
  1. K IEN D UPDATE^DIE("E","FDR","IEN") ;File all the data
  1. I $D(^TMP("DIERR",$J)) D Q
  1. . N DIK,DA,Y
  1. . I $D(NEWREC) S DIK="^VA(200,",DA=NEWDUZ D ^DIK ;Remove partial entry ;p533
  1. . S NEWDUZ=0 ;Tell failed
  1. Q
  1. ;
  1. 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
  1. ; ZEXCEPT: XTMUNIT ;set for unit testing
  1. N XMB
  1. I ($G(NAME)="")!($G(NEWDUZ)="")!($G(SITE)="")!($G(SITENUM)="") Q 0
  1. I ($G(RMTDUZ)="")!($G(PHONE)="")!($G(TODAY)="") Q 0
  1. S XMB="XUVISIT"
  1. S XMB(1)=$$FMTE^XLFDT(TODAY)
  1. S XMB(2)=NAME,XMB(3)=NEWDUZ,XMB(4)=SITE
  1. S XMB(5)=SITENUM,XMB(6)=RMTDUZ,XMB(7)=PHONE
  1. I '$D(XTMUNIT) D ^XMB
  1. Q 1
  1. ;
  1. SSNCHECK(SSN) ;INTRINSIC. Check for valid SSN
  1. ; Input: SSN in format "nnnnnnnnn" or "nnn-nn-nnnn"
  1. ; Returns: 0 if SSN is invalid, 1 if success
  1. ; Valid SSN range 001-01-0001 to 899-99-9999 with exceptions (rule as of 2011)
  1. ; Valid Individual Taxpayer Identification Number range 900-01-0001 to 999-99-9999 with exceptions (rule as of 1966)
  1. N X
  1. I $$PROD^XUPROD()=0 Q 1 ;allow use of invalid SSNs in development accounts
  1. S X=$TR(SSN,"-")
  1. I $L(X)'=9 Q 0
  1. I $E(X,1,3)'>0 Q 0 ;1st 3 digits cannot be 000
  1. I $E(X,4,5)'>0 Q 0 ;digits 4-5 cannot be 00
  1. I $E(X,6,9)'>0 Q 0 ;digits 6-9 cannot be 0000
  1. I $E(X,1,3)=666 Q 0 ;1st 3 digits cannot be 666
  1. I (X>987654319)&(X<987654330) Q 0 ;SSN range reserved for advertising
  1. I ($E(X,1,3)>899)&($E(X,4,5)=89) Q 0 ;digits 4-5 of ITIN cannot be 89
  1. I ($E(X,1,3)>899)&($E(X,4,5)=93) Q 0 ;digits 4-5 of ITIN cannot be 93
  1. Q 1
  1. ;
  1. MPISECID(NETNAME) ; Return SECID from MPI
  1. ; Called from $$TALL
  1. N XMPI,XOUT
  1. S XMPI("samacctnm")=$G(NETNAME)
  1. D USER^XUIAMXML(.XOUT,.XMPI)
  1. Q $G(XOUT("secId"))
  1. ;