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

XUSBSE1.m

Go to the documentation of this file.
  1. XUSBSE1 ;ISF/JLI,ISD/HGW - MODIFICATIONS FOR BSE ;03/24/2020
  1. ;;8.0;KERNEL;**404,439,523,595,522,638,659,630,727**;Jul 10, 1995;Build 4
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. Q
  1. SETVISIT(RES) ; RPC. XUS SET VISITOR - ICR #5501
  1. ;Returns a BSE TOKEN
  1. N TOKEN,O,X
  1. S X=$$ACTIVE^XUSER(DUZ) I $P(X,U)<1 S RES=X Q ;User must be active
  1. S TOKEN=$$HANDLE^XUSRB4("XUSBSE",1)
  1. S ^XTMP(TOKEN,1)=$$ENCRYP^XUSRB1($$GET^XUESSO1(DUZ))
  1. S ^XTMP(TOKEN,3)=+$H ;Set expiration day
  1. L -^XTMP(TOKEN) ;Lock set in $$HANDLE^XUSRB4
  1. S RES=TOKEN
  1. Q
  1. ;
  1. GETVISIT(RES,TOKEN) ; RPC. XUS GET VISITOR - ICR #5532
  1. ;Returns demographics for user indicated by TOKEN
  1. ; or "-1^error message" if user is not permitted to visit
  1. ; input - TOKEN - token value returned by remote site
  1. ; output - RES - passed by reference, contains user demographics on return
  1. N O,X
  1. S RES="",O=0
  1. I TOKEN="" S X=$$LOGERR("BSE NULL TOKEN") Q ;Shouldn't come in with a null token
  1. L +^XTMP(TOKEN):10 I '$T Q ; If ^XTMP is purged, token context will be lost
  1. I ($G(^XTMP(TOKEN,3))-$H) K ^XTMP(TOKEN) Q ;Check expiration time, and if it has passed
  1. S RES=$G(^XTMP(TOKEN,1)) S:$L(RES) RES=$$DECRYP^XUSRB1(RES)
  1. L -^XTMP(TOKEN) ;Lock set in $$HANDLE^XUSRB4
  1. S:'$L(RES) X=$$LOGERR("BSE GET USER ID") ;p595
  1. Q
  1. ;
  1. MDWS(XWBUSRNM) ; Intrinsic. Old CAPRI code, currently used by MDWS: Disable with system parameter XU522.
  1. ; Return 1 if a valid user, else 0.
  1. ;**********************************************************************************************************************
  1. ;***** This interface is deprecated as of patch XU*8.0*522 and will be permanently disabled with patch XU*8.0*617 *****
  1. ;**********************************************************************************************************************
  1. ; ZEXCEPT: DTIME - Kernel exemption
  1. N XVAL,XOPTION,XVAL522,XAPP
  1. S XVAL522=$$GET^XPAR("SYS","XU522",1,"Q") ; p522 system parameter XU522 controls MDWS login disabling, logging
  1. D:(XVAL522="E"!(XVAL522="L")) APPERROR^%ZTER("MDWS LOGIN ATTEMPT") ; p522 record MDWS login attempt if XU522 = E or L
  1. Q:(XVAL522'="L")&(XVAL522'="N") 0 ; p522 fully activate BSE unless parameter XU522 = N or L
  1. S DUZ("LOA")=1,DUZ("AUTHENTICATION")="NONE"
  1. S XAPP=+$$FIND1^DIC(8994.5,,"B","MEDICAL DOMAIN WEB SERVICES") I XAPP<1 S XAPP=""
  1. S DUZ("REMAPP")=XAPP_"^MEDICAL DOMAIN WEB SERVICES" ;p630
  1. S XVAL=$$PUT^XUESSO1($P(XWBUSRNM,U,3,99)) ; Sign in as Visitor
  1. I XVAL D
  1. . S XOPTION=$$FIND1^DIC(19,"","X","DVBA CAPRI GUI")
  1. . D SETCNTXT(XOPTION)
  1. . S DTIME=$$DTIME^XUP(DUZ)
  1. . S DUZ(0)=""
  1. . I $$USERTYPE^XUSAP(DUZ,"APPLICATION PROXY") H $R(5)
  1. Q $S(XVAL>0:1,1:0)
  1. ;
  1. CHKUSER(INPUTSTR) ; Extrinsic. Determines if a BSE sign-on is valid - called from XUSRB
  1. ; INPUTSTR - input - String of characters from client
  1. ; return value - 1 if a valid user and application, else 0
  1. ; ZEXCEPT: DTIME - Kernel exemption
  1. N X,XUCODE,XUENTRY,XUSTR,XUTOKEN
  1. ;I +INPUTSTR=-31,INPUTSTR["DVBA_" Q 0 ; permanently shut down MDWS visitor interface
  1. I +INPUTSTR=-31,INPUTSTR["DVBA_" Q $$MDWS(INPUTSTR)
  1. I +INPUTSTR'=-35 S X=$$LOGERR("BSE LOGIN ERROR") Q 0 ; not a BSE login
  1. S INPUTSTR=$P(INPUTSTR,U,2,99)
  1. K ^TMP("XUSBSE1",$J)
  1. S XUCODE=$$DECRYP^XUSRB1(INPUTSTR)
  1. S XUENTRY=$$GETCNTXT^XUESSO2($P(XUCODE,U))
  1. I XUENTRY'>0 S X=$$LOGERR("BSE LOGIN ERROR - REMAPP") Q 0 ; invalid remote application
  1. S DUZ("LOA")=2,DUZ("AUTHENTICATION")="BSETOKEN"
  1. S DUZ("REMAPP")=XUENTRY_U_$$GET1^DIQ(8994.5,XUENTRY_",",.01)
  1. S XUTOKEN=$P(XUCODE,U,2)
  1. S XUSTR=$P(XUCODE,U,3,4)
  1. S XUENTRY=$$BSEUSER(XUENTRY,XUTOKEN,XUSTR)
  1. S DTIME=$$DTIME^XUP(DUZ)
  1. I XUENTRY'>0 S X=$$LOGERR("BSE LOGIN ERROR - USER") Q 0 ; invalid user
  1. Q XUENTRY
  1. ;
  1. BSEUSER(ENTRY,TOKEN,STR) ; Intrinsic. Returns internal entry number for authenticated user
  1. ; ENTRY - input - internal entry number in REMOTE APPLICATION file
  1. ; TOKEN - input - token from authenticating site
  1. ; STR - input - remainder of input string (station #^TCP/IP port for station-based authentication)
  1. ; returns - IEN for authenticated user, or 0 if not authenticated
  1. ; ZEXCEPT: XWBSEC - Kernel exemption, contains error message returned to GUI application
  1. N X,XUIEN,XUCONTXT,XUDEMOG,XCNT,XVAL,ARRAY,XUCACHE,XUCONTXT
  1. S XUIEN=0,XUDEMOG="",XUCONTXT=0
  1. ; Check for cached user authentication (p638)
  1. I $D(^XTMP("XUSBSE1",TOKEN)) D
  1. . S XUCACHE=$G(^XTMP("XUSBSE1",TOKEN)) ; Retrieve cached values
  1. . I $P($P(XUCACHE,U,1),".",1)<$$DT^XLFDT() K ^XTMP("XUSBSE1",TOKEN) Q ; Do not use if expired (not from today)
  1. . I $P(XUCACHE,U,1)=$$HADD^XLFDT($$NOW^XLFDT(),0,0,0,600) K ^XTMP("XUSBSE1",TOKEN) Q ; Do not use if expired (older than 600s)
  1. . S XUDEMOG=$P(XUCACHE,U,3,99) ; Get demographics of authenticated user
  1. . I '$$PUT^XUESSO1(XUDEMOG) Q ; Set VISITOR entry, quit if failed
  1. . S XUIEN=$G(DUZ)
  1. . S XUCONTXT=$P(XUCACHE,U,2),^XUTL("XQ",$J,"DUZ(BSE)")=XUCONTXT ; Set Context Option
  1. . S:(XUIEN>0) ^XTMP("XUSBSE1",TOKEN)=$$NOW^XLFDT()_"^"_$G(XUCONTXT)_"^"_XUDEMOG ; Reset cache to keep authentication alive
  1. I (XUIEN>0)&(XUCONTXT>0) Q XUIEN ; p638 Use cached authentication
  1. ;
  1. S XCNT=0 F S XCNT=$O(^XWB(8994.5,ENTRY,1,XCNT)) Q:XCNT'>0 S XVAL=^(XCNT,0) D Q:XUDEMOG'=""
  1. . ; CODE TO HANDLE CONNECTION TYPE AND CONNECTIONS
  1. . I $P(XVAL,U)="S" S XUDEMOG=$$HOME(TOKEN,XVAL,STR) Q ; Station-number authentication
  1. . I $P(XVAL,U)="R" S XUDEMOG=$$XWB($P(XVAL,U,3),$P(XVAL,U,2),TOKEN) Q ; RPC-Broker authentication
  1. . I $P(XVAL,U)="H" S XUDEMOG=$$POST1^XUSBSE2(.ARRAY,$P(XVAL,U,3),$P(XVAL,U,2),$P(XVAL,U,4),"xVAL="_TOKEN) Q ; HTTP authentication
  1. . I $P(XVAL,U)="M" S XUDEMOG=$$M2M($P(XVAL,U,3),$P(XVAL,U,2),TOKEN) D CLOSE^XWBM2MC() Q ; M2M-Broker authentication
  1. . Q
  1. ; if invalid set XWBSEC so an error is reported in the GUI application
  1. I +XUDEMOG=-1 S XWBSEC="BSE ERROR - "_$P(XUDEMOG,"^",2)
  1. I $L(XUDEMOG,"^")>2 D
  1. . S XUCONTXT=$P($G(^XWB(8994.5,ENTRY,0)),U,2)
  1. . S XUIEN=$$SETUP(XUDEMOG,XUCONTXT)
  1. S:(XUIEN>0) ^XTMP("XUSBSE1",TOKEN)=$$NOW^XLFDT()_"^"_$G(XUCONTXT)_"^"_XUDEMOG ; p638 Cache user authentication
  1. Q $S(XUIEN'>0:0,1:XUIEN)
  1. ;
  1. XWB(SERVER,PORT,TOKEN) ; Special Broker service
  1. N DEMOSTR,IO,XWBTDEV,XWBRBUF
  1. Q $$CALLBSE^XWBTCPM2(SERVER,PORT,TOKEN)
  1. ;
  1. M2M(SERVER,PORT,TOKEN) ; M2M Broker
  1. N DEMOGSTR,XWBCRLFL,RETRNVAL,XUSBSARR
  1. S DEMOGSTR=""
  1. N XWBSTAT,XWBPARMS,XWBTDEV,XWBNULL
  1. S XWBPARMS("ADDRESS")=SERVER,XWBPARMS("PORT")=PORT
  1. S XWBPARMS("RETRIES")=3 ;Retries 3 times to open
  1. ;
  1. I '$$OPEN^XWBRL(.XWBPARMS) Q "NO OPEN"
  1. S XWBPARMS("URI")="XUS GET VISITOR"
  1. D CLEARP^XWBM2MEZ
  1. D SETPARAM^XWBM2MEZ(1,"STRING",TOKEN)
  1. S XWBPARMS("URI")="XUS GET VISITOR"
  1. S XWBPARMS("RESULTS")=$NA(^TMP("XUSBSE1",$J))
  1. S XWBCRLFL=0
  1. D REQUEST^XWBRPCC(.XWBPARMS)
  1. I XWBCRLFL S RETRNVAL="XWBCRLFL IS TRUE" G M2MEXIT
  1. ;
  1. I '$$EXECUTE^XWBVLC(.XWBPARMS) S RETRNVAL="FAILURE ON EXECUTE" G M2MEXIT ;Run RPC and place raw XML results in ^TMP("XWBM2MVLC"
  1. D PARSE^XWBRPC(.XWBPARMS,"XUSBSARR") ;Parse out raw XML and place results in ^TMP("XWBM2MRPC"
  1. S RETRNVAL=$G(XUSBSARR(1))
  1. M2MEXIT ;
  1. D CLOSE^XWBM2MEZ
  1. Q RETRNVAL
  1. ;
  1. HOME(TOKEN,RAD,BSE) ; Call home station for token.
  1. ; input TOKEN - token to identify user to authenticating server
  1. ; input RAD - Zero node of application data from REMOTE APPLICATION file (#8994.5)
  1. ; input BSE - Station #^TCP/IP port
  1. ; returns - string of demographic characteristics or "-1^error message"
  1. N X,XUESSO,PORT,STN,IP,STNIEN,STNPRNT
  1. D:$G(XWBDEBUG) LOG^XWBDLOG("ENTERED HOME BSE: "_BSE) ; DEBUG
  1. Q:$P(RAD,U,2)'=-1 "" ;Not setup right
  1. ;Set Station #, port from passed in data
  1. S STN=$P(BSE,U),PORT=$P(BSE,U,2),XUESSO=""
  1. ; Check if STN is a valid station number in the INSTITUTION file (security check)
  1. S STNIEN=$$LKUP^XUAF4(STN) I STNIEN=0 S XUESSO="-1^"_STN_" WAS NOT FOUND IN FILE 4" Q XUESSO
  1. ; Check if STN is an active facility (security check)
  1. I '$$ACTIVE^XUAF4(STNIEN) S XUESSO="-1^"_STN_" IS NOT AN ACTIVE VA FACILITY" Q XUESSO
  1. S IP=""
  1. ; Look for a valid cached DNS address (less than 1800 seconds old)
  1. S STNPRNT=$P($$PRNT^XUAF4(STN),U,2) S:'+$G(STNPRNT) STNPRNT=STN ; Convert subdivision to parent station
  1. S XUCACHE=$G(^XTMP("XUSBSE1",STNPRNT))
  1. I '$L(IP) S IP=$$IPFLOC(STNPRNT) ; Get the IP address from HL LOGICAL LINK file (#870)
  1. I '$L(IP) S IP=$$SITESVC(STNPRNT) ; Get the IP address from VASITESERVICE
  1. I '$L(IP) S XUESSO="-1^ADDRESS FOR STN "_STN_" NOT FOUND"
  1. D:$G(XWBDEBUG) LOG^XWBDLOG("HOME BSE IP: "_IP_" PORT:"_PORT)
  1. I $L(IP) S XUESSO=$$CALLBSE^XWBTCPM2(IP,PORT,TOKEN,STN)
  1. D:$G(XWBDEBUG) LOG^XWBDLOG("LEAVING HOME XUESSO: "_XUESSO)
  1. I XUESSO="Didn't open connection." S XUESSO="-1^COULD NOT CONNECT TO STN "_STN_" USING PORT "_PORT
  1. I XUESSO="No Response" S XUESSO="-1^BSE TOKEN EXPIRED"
  1. Q XUESSO
  1. ;
  1. IPFLOC(STN) ;Get the address from the station number from HL LOGICAL LINK file (#870)
  1. ; input STN - station number
  1. ; returns - IP address or null
  1. N XUSBSE,I,RET,ADD,IP,STNPRNT
  1. S STNPRNT=$P($$PRNT^XUAF4(STN),U,2) S:'+$G(STNPRNT) STNPRNT=STN ; Convert subdivision to parent station
  1. ; Look for station number in HL LOGICAL LINK file (#870)
  1. D FIND^DIC(870,,".03;.08","X",STNPRNT,,"C",,,"XUSBSE") ; ICR# 5449 "C" index lookup
  1. Q:+$G(XUSBSE("DILIST",0))=0 ""
  1. S I=0,ADD="",IP=""
  1. F S I=$O(XUSBSE("DILIST","ID",I)) Q:'I D Q:IP
  1. . ;HL LOGICAL LINK file (#870) DNS DOMAIN field (#.08)
  1. . S ADD=XUSBSE("DILIST","ID",I,.08) I $L(ADD) D Q:IP'=""
  1. . . I $$VALIDATE^XLFIPV(ADD) S IP=ADD Q ;ICR #5844
  1. . . S IP=$$ADDRESS^XLFNSLK(ADD) S:IP="" IP=$$ADDRESS^XLFNSLK(ADD,"A") ; Make 2 attempts to get IP, force IPv4 on second attempt
  1. . . Q
  1. . ;HL LOGICAL LINK file (#870) MAILMAIN DOMAIN field (#.03)
  1. . S ADD=XUSBSE("DILIST","ID",I,.03) I $L(ADD) D Q:IP'=""
  1. . . I $$VALIDATE^XLFIPV(ADD) S IP=ADD Q ;ICR #5844
  1. . . S IP=$$ADDRESS^XLFNSLK("VISTA."_ADD) S:IP="" IP=$$ADDRESS^XLFNSLK("VISTA."_ADD,"A") ; Make 2 attempts to get IP, force IPv4 on second attempt
  1. . . Q
  1. I $L(IP) S ^XTMP("XUSBSE1",STNPRNT)=IP_"^"_$H ; Cache the IP address
  1. Q IP
  1. ;
  1. SITESVC(STN) ;Get IP from the stn# from VISTASITESERVICE
  1. ; input STN - station number
  1. ; returns - IP address or null
  1. N DNSADD,IP,STNPRNT
  1. S IP=""
  1. S STNPRNT=$P($$PRNT^XUAF4(STN),U,2) S:'+$G(STNPRNT) STNPRNT=STN ; Convert subdivision to parent station
  1. S DNSADD=$$WEBADDRS(STNPRNT)
  1. I $L(DNSADD) S IP=$$ADDRESS^XLFNSLK(DNSADD) S:IP="" IP=$$ADDRESS^XLFNSLK(DNSADD,"A") ; Make 2 attempts to get IP, force IPv4 on second attempt
  1. I $L(IP) S ^XTMP("XUSBSE1",STNPRNT)=IP_"^"_$H ; Cache the IP address
  1. Q IP
  1. ;
  1. WEBADDRS(STNNUM) ;
  1. N IP,URL,XUSBSE,RESULTS,I,X,POP
  1. D FIND^DIC(2005.2,,"1","MO","VISTASITESERVICE",,,,,"XUSBSE")
  1. S URL=$G(XUSBSE("DILIST","ID",1,1))
  1. D EN1^XUSBSE2(URL_"/getSite?siteID="_STNNUM,.RESULTS)
  1. S X="" F I=1:1 Q:'$D(RESULTS(I)) I RESULTS(I)["hostname>" S X=$P($P(RESULTS(I),"<hostname>",2),"</hostname>") Q
  1. Q X
  1. ;
  1. SETUP(XUDEMOG,XUCONTXT) ; Setup user as visitor, add context option
  1. ; input XUDEMOG - string of demographic characteristics
  1. ; input XUCONTXT - context option to be given to user
  1. ; return value = internal entry number for user, or 0
  1. I '$$PUT^XUESSO1(XUDEMOG) Q 0
  1. I $G(DUZ)'>0 Q 0
  1. D SETCNTXT(XUCONTXT)
  1. Q DUZ
  1. ;
  1. SETCNTXT(XOPT) ;
  1. N OPT,XUCONTXT,X
  1. S XUCONTXT="`"_XOPT
  1. I $$FIND1^DIC(19,"","X",XUCONTXT)'>0 S X=$$LOGERR("BSE LOGIN ERROR - CONTEXT") Q ;Context option not in option file
  1. I $G(DUZ("LOA"))=1 H $R(5)
  1. ;Have to use $D because of screen in 200.03 keeps FIND1^DIC from working.
  1. I '$D(^VA(200,DUZ,203,"B",XOPT)) D
  1. . ; Have to give the user a delegated option
  1. . N XARR S XARR(200.19,"+1,"_DUZ_",",.01)=XUCONTXT
  1. . D UPDATE^DIE("E","XARR")
  1. . ; And now she can give himself the context option
  1. . K XARR S XARR(200.03,"?+2,"_DUZ_",",.01)=XOPT ;p727
  1. . D UPDATE^DIE("","XARR") ; Give context option as a secondary menu item ;p727
  1. . S ^XUTL("XQ",$J,"DUZ(BSE)")=XUCONTXT
  1. . ; But now we have to remove the delegated option
  1. . S OPT=$$FIND1^DIC(200.19,","_DUZ_",","X",XUCONTXT)
  1. . I OPT>0 D
  1. . . K XARR S XARR(200.19,(OPT_","_DUZ_","),.01)="@"
  1. . . D FILE^DIE("E","XARR")
  1. . . Q
  1. . Q
  1. Q
  1. ;
  1. STNTEST ; tests station#-to-IP conversion (IPFLOC,WEBADDRS) used by HOME station#-based callback
  1. N XUSLSTI,XUSLSTV,XUSSTN,XUSIP1,XUSIP2,XUSBSE
  1. W !,"Broker Security Enhancement (BSE) Station Number-to-IP conversion test (for BSE"
  1. W !,"callbacks to home system). Note: It is not necessarily wrong if results differ"
  1. W !,"or are blank. 2 methods' results are listed: HL LOGICAL LINK/VISTASITESERVICE"
  1. ;
  1. D FIND^DIC(2005.2,,"1","MO","VISTASITESERVICE",,,,,"XUSBSE")
  1. W !!," local VISTASITESERVICE server:",!," ",$G(XUSBSE("DILIST","ID",1,1)),"",!
  1. K ^TMP($J,"XUSBSE1")
  1. DO LIST^DIC(4,,"@;.01;11;99;101","IP",,,,"D",,,$NA(^TMP($J,"XUSBSE1")))
  1. S XUSLSTI=0 F S XUSLSTI=$O(^TMP($J,"XUSBSE1","DILIST",XUSLSTI)) Q:'+XUSLSTI D
  1. . S XUSLSTV=^TMP($J,"XUSBSE1","DILIST",XUSLSTI,0)
  1. . Q:+$P(XUSLSTV,U,5)
  1. . S XUSSTN=$P(XUSLSTV,U,4) Q:'$$TF^XUAF4(XUSSTN)
  1. . S XUSIP1=$$IPFLOC(XUSSTN),XUSIP2=$$SITESVC(XUSSTN)
  1. . I $L(XUSIP1)!$L(XUSIP2) D
  1. . . W !,XUSSTN,?8,"(",$P(XUSLSTV,U,2),"): " W $S($L(XUSIP1):XUSIP1,1:"blank"),"/",$S($L(XUSIP2):XUSIP2,1:"blank")
  1. . . I $L(XUSIP1),$L(XUSIP2),(XUSIP1'=XUSIP2) W " ***DIFFERENT***"
  1. K ^TMP($J,"XUSBSE1")
  1. Q
  1. LOGERR(XUSETXT) ; log an error in error trap for failed login attempts ; p595
  1. ; XUSETXT is the error subject line $ZE
  1. ; The function returns 0 if the error was screened, and 1 if an error was trapped
  1. N XUSAPP
  1. ; ZEXCEPT: XWBSEC,XUDEMOG - Kernel global variables
  1. S XUSAPP=$P($G(DUZ("REMAPP")),U,2)
  1. I $P($G(XUDEMOG),U,2)="BSE TOKEN EXPIRED" Q 0 ; screen out "TOKEN EXPIRED" errors
  1. I $G(XWBSEC)="BSE ERROR - BSE TOKEN EXPIRED" Q 0 ; screen out "TOKEN EXPIRED" errors
  1. I XUSAPP'="" S XUSETXT=XUSETXT_" ("_XUSAPP_")"
  1. D APPERROR^%ZTER($E(XUSETXT,1,32))
  1. Q 1
  1. BSETOKEN(RET,XPHRASE) ; RPC. XUS BSE TOKEN - IA #6695
  1. ;Returns a string that can be passed as the XUBUSRNM parameter to the
  1. ;XUS SIGNON SETUP rpc to authenticate a user on a remote system. The input
  1. ;is an application identifier (pass phrase) that, when hashed,
  1. ;matches the stored hash of an authorized application in the REMOTE
  1. ;APPLICATION file (#8994.5) APPLICATIONCODE field (#.03)
  1. ; - Input - Application pass phrase
  1. N XAPP,XPORT,XSTA,XSTATION,XSTRING,XTOKEN
  1. S XAPP=$G(XPHRASE)
  1. I XAPP="" S RET="-1^NOT AUTHENTICATED" Q ;Application must be authenticated
  1. S XAPP=$$GETCNTXT^XUESSO2(XPHRASE)
  1. I +XAPP=-1 S RET="-1^NOT AUTHENTICATED" Q ;Application must be authenticated
  1. S XAPP=XPHRASE
  1. D SETVISIT(.XTOKEN)
  1. I +$G(XTOKEN)=-1 S RET="-1^NOT AUTHENTICATED" Q ;User must be authenticated
  1. I $G(DUZ(2))="" S RET="-1^HOME STATION NOT IDENTIFIED" Q ;User must be authenticated on valid home station
  1. S XSTA=$$NS^XUAF4(DUZ(2))
  1. S XSTATION=$P(XSTA,U,2)
  1. I XSTA="" S RET="-1^HOME STATION NOT IDENTIFIED" Q ;User must be authenticated on valid home station
  1. S XPORT=$G(^XTMP("XUSBSE1","RPCBrokerPort"))
  1. I XPORT="" D
  1. . ; Do a VistA Exchange Site Service lookup for current station (once daily)
  1. . N IP,URL,XUSBSE,RESULTS,I,X,POP
  1. . D FIND^DIC(2005.2,,"1","MO","VISTASITESERVICE",,,,,"XUSBSE")
  1. . S URL=$G(XUSBSE("DILIST","ID",1,1))
  1. . D EN1^XUSBSE2(URL_"/getSite?siteID="_XSTATION,.RESULTS)
  1. . S X="" F I=1:1 Q:'$D(RESULTS(I)) I RESULTS(I)["port>" S X=$P($P(RESULTS(I),"<port>",2),"</port>") Q
  1. . S XPORT=X
  1. . I XPORT'="" S ^XTMP("XUSBSE1","RPCBrokerPort")=X
  1. I XPORT="" S RET="-1^RPC BROKER PORT NOT AVAILABLE" Q ;Could not obtain port from VistA Exchange Site Service lookup
  1. S XSTRING=XAPP_"^"_XTOKEN_"^"_XSTATION_"^"_XPORT
  1. S RET="-35^"_$$ENCRYP^XUSRB1(XSTRING)
  1. Q
  1. ;