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