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 ;12/02/14  13:29
  1.  ;;8.0;KERNEL;**404,439,523,595,522,638**;Jul 10, 1995;Build 16
  1.  ;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. SETVISIT(RES) ; .RPC "XUS SET VISITOR"
  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"
  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. OLDCAPRI(XWBUSRNM) ; Intrinsic. The old CAPRI code, disable with system parameter XU522.
  1.  ; Return 1 if a valid user, else 0.
  1.  ; ZEXCEPT: DTIME - Kernel exemption
  1.  N XVAL,XOPTION,XVAL522
  1.  S XVAL522=$$GET^XPAR("SYS","XU522",1,"Q")  ; p522 system parameter XU522 controls CAPRI login disabling, logging
  1.  D:(XVAL522="E"!(XVAL522="L")) APPERROR^%ZTER("OLDCAPRI LOGIN ATTEMPT")  ; p522 record CAPRI login attempt if XU522 = E or L
  1.  Q:(XVAL522'="L")&(XVAL522'="N") 0  ; p522 fully activate BSE unless param XU522 = N or L
  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) S DTIME=$$DTIME^XUP(DUZ),DUZ(0)="",DUZ("REMAPP")="^Old CAPRI"
  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 $$OLDCAPRI(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 XUCODE=$$EN^XUSHSH($P(XUCODE,U))
  1.  S XUENTRY=$$FIND1^DIC(8994.5,"","X",XUCODE,"ACODE")
  1.  I XUENTRY'>0 S X=$$LOGERR("BSE LOGIN ERROR - REMAPP") Q 0  ; invalid remote application
  1.  S DUZ("REMAPP")=XUENTRY_U_$$GET1^DIQ(8994.5,XUENTRY_",",.01)
  1.  S XUTOKEN=$P($$DECRYP^XUSRB1(INPUTSTR),U,2)
  1.  S XUSTR=$P($$DECRYP^XUSRB1(INPUTSTR),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)="M" S XUDEMOG=$$M2M($P(XVAL,U,3),$P(XVAL,U,2),TOKEN) D CLOSE^XWBM2MC() Q  ; M2M-Broker 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)="S" S XUDEMOG=$$HOME(TOKEN,XVAL,STR) Q  ; Station-number 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) X=$$LOGERR("BSE LOGIN ERROR") ;p595
  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,XUCACHE,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:'+STNPRNT STNPRNT=STN ; Convert subdivision to parent station
  1.  S XUCACHE=$G(^XTMP("XUSBSE1",STNPRNT))
  1.  I ($D(XUCACHE))&($$HDIFF^XLFDT($H,$P(XUCACHE,U,2),2)<1800) S IP=$P(XUCACHE,U,1)
  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:'+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") ; IA# 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:'+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.  ;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,"+1,"_DUZ_",",.01)=XUCONTXT
  1.  . D UPDATE^DIE("E","XARR") ; Give context option as a secondary menu item
  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 - Kernel exemption
  1.  ; ZEXCEPT: XUDEMOG - Kernel exemption
  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