- 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 Feb 18, 2025@23:35:50 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 ;