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 ;LUKE/SEA Single Sign-on utilities;02/11/10  14:57;08/18/09  14:29
  1.  ;;8.0;KERNEL;**165,183,196,245,254,269,337,395,466,523**;Jul 10, 1995;Build 19
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1. GET(INDUZ) ;Gather identifying data from user's home site.
  1.  ;Must have Name, Access&Verify codes, SSN (no pseudo), station name&number
  1.  N %,NAME,SITE,SSN,PHONE,X,N,VPID
  1.  I '$D(DUZ) G BOMB
  1.  I '$D(DUZ(2)) G BOMB
  1.  ;I '$D(INDUZ) S INDUZ=DUZ
  1.  S N=$G(^VA(200,DUZ,0))
  1.  I '$L(N) G BOMB
  1.  S %=$P(N,U,3) I $L(%)<1 G BOMB ;No Access Code
  1.  S %=$P($G(^VA(200,DUZ,.1)),U,2) I $L(%)<1 G BOMB ;No Verify Code
  1.  S %=$P(N,U,11) I $L(%)>1,(DT>%) G BOMB ;Terminated
  1.  S NAME=$P(N,U)
  1.  I '$L(NAME) G BOMB
  1.  ;
  1.  S SITE=$$NS^XUAF4(DUZ(2)) ;Site is name^station#
  1.  I $P(SITE,U,2)="" G BOMB ;Need a station number
  1.  ;
  1.  S SSN=$P($G(^VA(200,DUZ,1)),U,9)
  1.  I $$SPECIAL($P(SITE,"^",2)) S SSN=999999999 G G4 ;Manila RO doesn't need SSN
  1.  I 'SSN G BOMB
  1.  ;Don't allow if the SSN is pseudo
  1.  I $E(SSN,10)="P" G BOMB
  1.  ;Don't allow if the SSN is not real, (e.g. 00000NNNN)
  1.  I $E(SSN,1,5)="00000" G BOMB
  1.  ;
  1. G4 S PHONE=$$PH
  1.  S VPID=$$VPID^XUPS(DUZ) ;(p337)
  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)=VPID ;(p337)
  1.  ;ssn^name^station name^station number^DUZ^phone^vpid
  1.  Q X
  1.  ;
  1.  ;
  1. BOMB ;Insufficient information to allow visiting
  1.  S X="-1^Insufficient User Information On File.  ssn,name,station name,station number,DUZ,phone"
  1.  Q X
  1.  ;
  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.  ;
  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) ;Special Manila RO site
  1.  Q 358=SN
  1.  ;
  1.  ;
  1. PUT(DATIN) ;;Setup data from authenticating site GET() at receiving site
  1.  ;Return: 0=fail, 1=OK
  1.  N NEWDUZ,FDR,TODAY,IEN,DIC,USER,X,%T
  1.  N SSN,NAME,SITE,SITENUM,RMTDUZ,PHONE,VPID,XUMF
  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 VPID=$P(DATIN,U,7) ;(p337)
  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,.%T) I %T=U Q 0 ;p533
  1.  D CHK^DIE(200.06,1,,SITE,.%T) I %T=U Q 0 ;p533
  1.  I RMTDUZ'>0 Q 0 ;p337
  1.  ;
  1.  ;Get a LOCK. Block if can't get.
  1.  L +^VA(200,"HL7"):10 Q:'$T 0
  1.  S %T=$$TALL($G(DUZ,0)) L -^VA(200,"HL7")
  1.  I %T Q $$SET(NEWDUZ) ;Return 1 if OK.
  1.  Q 0
  1.  ;
  1.  ;Per PSIM don't load VPID's, Only done by PSIM.
  1.  ;Code for adding VPID removed in p466.
  1. TALL(DUZ) ;Test for existing user or adds a new one
  1.  N FLAG,NEWREC
  1.  S FLAG=0,DUZ(0)="@" ;Make sure we can add the entry
  1.  ;See if match VPID, Per PSIM only use for lookup.
  1.  I $L(VPID) D
  1.  . S NEWDUZ=+$$IEN^XUPS(VPID) Q:NEWDUZ<1
  1.  . I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
  1.  . D UPDT S FLAG=1
  1.  . Q
  1.  I FLAG Q 1 ;Quit here if we found a match on VPID
  1.  ;See if the SSN is in the NPF cross reference
  1.  I '$$SPECIAL(SITENUM),$D(^VA(200,"SSN",SSN)) D
  1.  .S NEWDUZ=$O(^VA(200,"SSN",SSN,0))
  1.  .I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
  1.  .D UPDT
  1.  .S FLAG=1
  1.  .Q
  1.  ;See if in the AVISIT cross reference
  1.  I 'FLAG,$$SPECIAL(SITENUM) D
  1.  . S NEWDUZ=$O(^VA(200,"AVISIT",SITENUM,RMTDUZ,0))
  1.  . Q:NEWDUZ'>0
  1.  . D UPDT S FLAG=1
  1.  . Q
  1.  I FLAG Q 1 ;Quit here if we found a match for SSN or AVISIT
  1.  ;
  1.  ;
  1.  ;There is no matching SSN, try for a NAME match in "B"
  1.  S FLAG=0,NAME=$$UP^XLFSTR(NAME)
  1.  I $D(^VA(200,"B",NAME)) D
  1.  .N %,USER,USER2
  1.  .S NEWDUZ=$O(^VA(200,"B",NAME,0))
  1.  .S USER2=$O(^VA(200,"B",NAME,NEWDUZ)) ;More then one?
  1.  .Q:$L(USER2)>0
  1.  .;
  1.  .S %=$P($G(^VA(200,NEWDUZ,1)),U,9)
  1.  .Q:%'=SSN  ;Don't use this name if it has a different SSN
  1.  .;
  1.  .I '$L($P(^VA(200,NEWDUZ,1),U,9)) D ADDS
  1.  .I '$D(^VA(200,NEWDUZ,8910,"B",SITENUM)) D VISM
  1.  .D UPDT S FLAG=1
  1.  .Q
  1.  I FLAG Q 1 ;Quit here if we found an exact match for NAME (w/o SSN)
  1.  ;
  1. NEWU ;We didn't find anybody under SSN or NAME so we add a new user
  1.  ;
  1.  S DIC(0)="" ;Turn off ^XUA4A7 (work around)
  1.  ;
  1.  ;Put the name in the .01 field first.
  1.  D ADDU ;ADDU will set NEWDUZ
  1.  ;If NEWDUZ is still 0, the User add didn't work so exit.
  1.  I NEWDUZ=0 Q 0
  1.  ; Add SSN and Alias.
  1.  D ADDS,ADDA ;(p337)
  1.  ; Fill in the  VISITED FROM multiple
  1.  D VISM,UPDT ;Do update for all data in UPDT
  1.  ;
  1.  I $D(^TMP("DIERR",$J)) Q 0  ;FileMan Error
  1.  ;
  1.  I NEWDUZ D BULL Q 1  ;Every thing OK
  1.  Q 0  ;Couldn't add user
  1.  ;
  1.  ;
  1.  ;              *****Subroutines*****
  1.  ;
  1.  ;
  1. SET(NEWDUZ) ;Set the user up to go
  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 ;Add a new name to the New Person File
  1.  N DD,DO,DIC,DA,X,Y
  1.  S DIC="^VA(200,",DIC(0)="L",X=NAME,NEWREC=1 ;p533
  1.  D FILE^DICN
  1.  S:Y>0 NEWDUZ=+Y
  1.  Q
  1.  ;
  1. ADDS ;Add a SSN to the file
  1.  Q:$$SPECIAL(SITENUM)
  1.  S IEN=NEWDUZ_","
  1.  S FDR(200,IEN,9)=SSN
  1.  ;Do update for all data in UPDT
  1.  Q
  1.  ;
  1. ADDA ;Add a new Alias to file 200.04
  1.  Q:$D(^VA(200,NEWDUZ,3,"B","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. VISM ;Create a multiple for this site number in the VISTED FROM file
  1.  S IEN="+3,"_NEWDUZ_","
  1.  S FDR("200.06",IEN,.01)=SITENUM
  1.  ;
  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.  ;I $D(PHONE),($L(PHONE)>2) S FDR("200.06",IEN,5)=PHONE
  1.  ;Do update for all data in UPDT
  1.  Q
  1.  ;
  1. UPDT ;Update the LAST VISIT field
  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.  ;Update the phone each time
  1.  I $D(PHONE),($L(PHONE)>2) S FDR("200.06",IEN,5)=PHONE ;p466
  1.  K IEN D UPDATE^DIE("E","FDR","IEN") ;File all the data
  1.  I $D(^TMP("DIERR",$J)) D
  1.  . N DIK,DA
  1.  . D FAIL
  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 ;Set up the bulletin and fire it off, Let MM see if bulletin is there
  1.  N XMB
  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.  D ^XMB
  1.  Q
  1.  ;
  1. FAIL ;Send bulletin if fail to add user.
  1.  N I,XMTEXT,XMY,XUTEXT,XMSUB,XMZ,XMMG,ZTQUEUED
  1.  S XMSUB="XUESSO-VISIT ADD FAILED",ZTQUEUED=1
  1.  D MSG^DIALOG("AEST",.XMTEXT)
  1.  S XUTEXT(1)="Attempting to add "_NAME_" from "_SITE
  1.  S XUTEXT(2)=$G(DATIN),XUTEXT(3)=" ",XUTEXT=3,I=0
  1.  F  S I=$O(XMTEXT(I)) Q:'I  S XUTEXT=XUTEXT+1,XUTEXT(XUTEXT)=XMTEXT(I)
  1.  S XMTEXT="XUTEXT(",XMY("G.XUSVISITFAIL@FO-OAKLAND.MED.VA.GOV")=""
  1.  D ^XMD
  1.  Q