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

XOBSCAV1.m

Go to the documentation of this file. 
  1. XOBSCAV1 ;oak/kec - VistaLink Access/Verify Security ;12/09/2002
  1.  ;;1.6;VistALink Security;**3**;May 08, 2009;Build 8
  1.  ;Per VHA Directive 6402, this routine should not be modified
  1.  QUIT
  1.  ; 
  1.  ; Access/Verify Security: Security Message Request Handler
  1.  ; specific message request/response pairs)  
  1.  ; 
  1.  ; ** Setting/Killing of DUZ covered by blanket SAC Kernel exemption for Foundations
  1.  ; 
  1.  ; ::AV.SetupAndIntroText.Request message processing
  1. SENDITXT ; Do Setup and send Intro Text
  1.  NEW XOBSTINF,XOBMSG,XOBTMP,XOBTMP1,XOBCCMSK,XOBI,XOBPROD
  1.  ;
  1.  ; define XWBTIP early so present in any error logs
  1.  ; NOTE: $$GETPEER^%ZOSV fails for TCP_SERVICES listeners if COM file doesn't set up VISTA$IP logical
  1.  ; 
  1.  SET XWBTIP=$$GETPEER^%ZOSV ; XWBTIP needed by SETUP^XUSRB. Use of GETPEER^%ZOSV: DBIA #4056
  1.  ; set ip from msg if not provided by OS
  1.  SET:'$LENGTH(XWBTIP) XWBTIP=XOBDATA("CLIENTIP")
  1.  ;
  1.  IF $$PRODMISM() DO  QUIT
  1.  . NEW XOBSPAR SET XOBSPAR(1)=$GET(XOBDATA("CLIENTISPRODUCTION")),XOBSPAR(2)=$SELECT($$PROD^XUPROD(0):"true",1:"false")
  1.  . DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Production-Test Mismatch",183007,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183007,.XOBSPAR)))
  1.  ;
  1.  IF $$STATMISM() DO  QUIT
  1.  . NEW XOBSPAR SET XOBSPAR(1)=$GET(XOBDATA("CLIENTPRIMARYSTATION")),XOBSPAR(2)=XOBSYS("PRIMARY STATION#")
  1.  . DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Primary Station Mismatch",183010,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183010,.XOBSPAR)))
  1.  ;
  1.  ; seq: SETUP^XUSRB, then INTRO^XUSRB
  1.  ; 
  1.  USE XOBNULL ; protect against direct writes to socket
  1.  ; note: SETUP^XUSRB sets current IO to null device
  1.  ; 
  1.  IF XOBSYS("ENV")="j2ee" DO
  1.  . DO SETUP^XUSRB(.XOBSTINF,"") ; use of SETUP^XUSRB: DBIA #4054
  1.  ELSE  DO  QUIT:$GET(DUZ)>0
  1.  . SET XWBVER=1.1 ; to allow VistaLink to contact client agent
  1.  . DO SETUP^XUSRB(.XOBSTINF,"") ; use of SETUP^XUSRB: DBIA #4054
  1.  . ; start of auto-signon support
  1.  . SET DUZ=$$AUTOXWB^XUS1B() IF DUZ<1 KILL DUZ ; use of $$AUTOXWB^XUS1B: DBIA #4060
  1.  . IF $GET(DUZ)>0 DO NOW^XUSRB SET XUMSG=$$POST^XUSRB(0) IF XUMSG>0 KILL DUZ ; XUSRB calls: DBIA #4061
  1.  . ; do autosignon and quit if DUZ is set
  1.  . IF $GET(DUZ)>0 DO  QUIT
  1.  . .USE XOBPORT ; restore current IO (the TCP port)
  1.  . .SET XOBRET(5)=0 DO LOGFIN
  1.  . .QUIT
  1.  . KILL XWBVER ; once auto-signon fails, don't need to contact client agent
  1.  . ; end of autosignon support
  1.  ;
  1.  ;if failed autosignon, continue w/intro text
  1.  ; ** use of USE command covered by blanket SAC Kernel exemption for Foundations
  1.  USE XOBPORT ; restore current IO (the TCP port)
  1.  ;
  1.  SET XOBMSG(1)="<SetupInfo serverName='"_$$CHARCHK^XOBVLIB(XOBSTINF(0))_"' volume='"
  1.  ; note: next line, "dtime" attribute value is not DTIME, but is the VistaLink heartbeat rate.
  1.  ;       this is used by the J2SE client code to time out the client dialogs.
  1.  ;       Value may be replaced w/a signon-specific site parameter later.
  1.  SET XOBMSG(1)=XOBMSG(1)_$$CHARCHK^XOBVLIB(XOBSTINF(1))_"' uci='"_$$CHARCHK^XOBVLIB(XOBSTINF(2))_"' device='"_$$CHARCHK^XOBVLIB(XOBSTINF(3))_"' numberAttempts='"_$$CHARCHK^XOBVLIB(XOBSTINF(4))_"' dtime='"_$$GETRATE^XOBVLIB()_"'/>"
  1.  ; add intro text
  1.  DO GETINTRO^XOBSCAV2("XOBMSG",2)
  1.  ;
  1.  DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGSETUP^XOBSCAV),";;",2),.XOBMSG,$$SUCCESS^XOBSCAV(),$PIECE($TEXT(SCHSETUP^XOBSCAV),";;",2))
  1.  QUIT
  1.  ; ::AV.Logon.Request message processing
  1. LOGON ; process login request
  1.  NEW XOBAC,XOBVC,XOBRET,XOBRETDV
  1.  ;
  1.  IF $$LOGGEDON^XOBSCAV DO  QUIT
  1.  .DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Server Partition State",183003,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183003)))
  1.  ;
  1.  KILL DUZ ; if DUZ is around, it shouldn't be.
  1.  USE XOBNULL ; protect against direct writes to socket
  1.  ; try to logon w/avcodes - PB - May 5, 2017 modified the code to check for either saml or av logon
  1.  DO:XOBDATA("XOB SECAV","SECURITYACTION")="SAML.Logon" CHXHDR,SAML^XOBVSAML(.XOBRET,$NAME(^XTMP($JOB,"SAML")))
  1.  DO:XOBDATA("XOB SECAV","SECURITYACTION")="AV.Logon" VALIDAV^XUSRB(.XOBRET,XOBDATA("XOB SECAV","AVCODE")) ; use of VALIDAV^XUSRB: DBIA#4054
  1.  ;DO VALIDAV^XUSRB(.XOBRET,XOBDATA("XOB SECAV","AVCODE")) ; use of VALIDAV^XUSRB: DBIA#4054
  1.  KILL XOBDATA("XOB SECAV","AVCODE")
  1.  USE XOBPORT ; restore current IO (the TCP port)
  1.  ;
  1.  ; if bad a/v code credentials
  1.  IF '+XOBRET(0),'+XOBRET(1),'+XOBRET(2) DO  QUIT
  1.  . ; look for particular error string which means IP is locked
  1.  . IF $GET(XOBRET(3))["Device/IP address is locked due" DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Logon Failed",182306,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(182306,$GET(XOBRET(3))))) QUIT
  1.  . IF XOBSYS("ENV")="j2ee" DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Connector Proxy User Error",183008,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183008,$GET(XOBRET(3))))) QUIT
  1.  . ELSE  DO LOGBADCD
  1.  ;
  1.  ; if Kernel says user needs to change verify code
  1.  IF '+XOBRET(0),'+XOBRET(1),XOBRET(2) DO LOGCVC QUIT
  1.  ;
  1.  IF '+XOBRET(0) DO  QUIT  ; there was an error
  1.  .NEW XOBSPAR
  1.  .SET XOBSPAR(1)=$GET(XOBRET(3))
  1.  .; look for particular error string which means too many invalid signon attempts
  1.  .IF XOBSPAR(1)["too many invalid sign" DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Logon Failed",183005,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183005,.XOBSPAR))) QUIT
  1.  .DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Logon Failed",183004,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183004,.XOBSPAR)))
  1.  ;
  1.  ; if user requested to change verify code
  1.  IF $GET(XOBDATA("XOB SECAV","REQUESTCVC"))="true" DO LOGCVC QUIT
  1.  ;
  1.  ; if j2ee, test for connector proxy user
  1.  IF XOBSYS("ENV")="j2ee" QUIT:'$$ISCPROXY()
  1.  ;
  1.  ; at this point login was successful
  1.  DO LOGFIN
  1.  KILL ^XTMP($JOB,"SAML")
  1.  QUIT
  1. LOGFIN ; check the divisions, finish login now
  1.  NEW XOBRETDV DO DIVGET^XUSRB2(.XOBRETDV,DUZ) ; use of DIVGET^XUSRB2: DBIA #4055
  1.  IF '+XOBRETDV(0) DO  QUIT
  1.  . DO LOGOK
  1.  . DO DUZSV^XOBVSYSI(.DUZ)
  1.  ; otherwise this is a multidivisional user
  1.  DO LOGSELDV(.XOBRETDV)
  1.  QUIT
  1. LOGBADCD ; response if bad a/v code pair
  1.  NEW XOBMSG
  1.  SET XOBMSG(1)="<"_$PIECE($TEXT(MSGTAG^XOBSCAV),";;",2)_">"_$$CHARCHK^XOBVLIB(XOBRET(3))_"</"_$PIECE($TEXT(MSGTAG^XOBSCAV),";;",2)_">"
  1.  DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGLGON^XOBSCAV),";;",2),.XOBMSG,$$FAILURE^XOBSCAV(),$PIECE($TEXT(SCHSIMPL^XOBSCAV),";;",2))
  1.  QUIT
  1. LOGCVC ; response if need to change vc
  1.  NEW XOBMSG,XOBLINE
  1.  SET XOBLINE=$$POSTTXT^XOBSCAV(.XOBRET,.XOBMSG)
  1.  SET XOBMSG(XOBLINE+1)="<"_$PIECE($TEXT(PARTTAG^XOBSCAV),";;",2)_" changeVerify=""true"" cvcHelpText="""_$$CHARCHK^XOBVLIB($$AVHLPTXT^XUS2())_""" />" ; use of AVHLPTXT^XUS2: DBIA #4057
  1.  SET XOBMSG(XOBLINE+2)="<"_$PIECE($TEXT(MSGTAG^XOBSCAV),";;",2)_">"_$$CHARCHK^XOBVLIB(XOBRET(3))_"</"_$PIECE($TEXT(MSGTAG^XOBSCAV),";;",2)_">"
  1.  DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGLGON^XOBSCAV),";;",2),.XOBMSG,$$PARTIAL^XOBSCAV(),$PIECE($TEXT(SCHPARTS^XOBSCAV),";;",2))
  1.  QUIT
  1. LOGSELDV(XOBDIVS) ; response if need to select division
  1.  ;XOBDIVS is in format of output from DIVGET^XUSRB2
  1.  NEW XOBMSG,XOBLINE
  1.  SET XOBLINE=$$POSTTXT^XOBSCAV(.XOBRET,.XOBMSG)
  1.  SET XOBLINE=$$ADDDIVS^XOBSCAV(.XOBDIVS,.XOBMSG)
  1.  DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGLGON^XOBSCAV),";;",2),.XOBMSG,$$PARTIAL^XOBSCAV(),$PIECE($TEXT(SCHPARTS^XOBSCAV),";;",2))
  1.  QUIT
  1. LOGOK ; response if everything's looking good
  1.  NEW XOBMSG,XOBLINE
  1.  SET XOBLINE=$$POSTTXT^XOBSCAV(.XOBRET,.XOBMSG)
  1.  DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGLGON^XOBSCAV),";;",2),.XOBMSG,$$SUCCESS^XOBSCAV(),$PIECE($TEXT(SCHLGON^XOBSCAV),";;",2))
  1.  QUIT
  1.  ; ::AV.Logout.Request message processing
  1. LOGOUT ; logout
  1.  USE XOBNULL ; protect against direct writes to socket
  1.  ; do the logout
  1.  DO CLEAN
  1.  USE XOBPORT ; restore current IO (the TCP port)
  1.  NEW XOBMSG
  1.  DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGLGOUT^XOBSCAV),";;",2),.XOBMSG,$$SUCCESS^XOBSCAV(),$PIECE($TEXT(SCHSIMPL^XOBSCAV),";;",2))
  1.  QUIT
  1.  ; ::Logout to call if connection has timed out
  1. CLEAN ; logout
  1.  DO LOGOUT^XUSRB ; use of LOGOUT^XUSRB: DBIA #4054
  1.  QUIT
  1.  ; ::AV.SelectDivision.Request message processing
  1. DIVSLCT ; select division
  1.  NEW XOBRET
  1.  ;
  1.  IF '+DUZ DO DIVSLCT0("User did not complete the access/verify code login process.") QUIT  ; need DUZ
  1.  DO DIVSET^XUSRB2(.XOBRET,"`"_XOBDATA("XOB SECAV","SELECTEDDIVISION")) ; use of DIVSET^XUSRB2: DBIA #4055
  1.  IF +XOBRET DO  QUIT
  1.  . DO DIVSLCT1
  1.  . DO DUZSV^XOBVSYSI(.DUZ)
  1.  DO DIVSLCT0("division not found for this user.")
  1.  QUIT
  1.  ;
  1. DIVSLCT0(XOBTEXT) ; send 
  1.  NEW XOBMSG
  1.  SET XOBMSG(1)="<"_$PIECE($TEXT(MSGTAG^XOBSCAV),";;",2)_">"_$$CHARCHK^XOBVLIB(XOBTEXT)_"</"_$PIECE($TEXT(MSGTAG^XOBSCAV),";;",2)_">"
  1.  DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGSELDV^XOBSCAV),";;",2),.XOBMSG,$$FAILURE^XOBSCAV(),$PIECE($TEXT(SCHSIMPL^XOBSCAV),";;",2))
  1.  QUIT
  1.  ;
  1. DIVSLCT1 ; success
  1.  NEW XOBMSG
  1.  DO SENDSEC^XOBSCAV(.XOBR,$PIECE($TEXT(RESTYPE^XOBSCAV),";;",2),$PIECE($TEXT(MSGSELDV^XOBSCAV),";;",2),.XOBMSG,$$SUCCESS^XOBSCAV(),$PIECE($TEXT(SCHSIMPL^XOBSCAV),";;",2))
  1.  QUIT
  1.  ;
  1. PRODMISM() ; returns 1 if production mismatch, 0 if not
  1.  IF XOBSYS("ENV")'="j2ee" QUIT 0 ; skip in c/s mode
  1.  SET XOBPROD=$SELECT($GET(XOBDATA("CLIENTISPRODUCTION"))="true":1,1:0)
  1.  IF '(XOBPROD=$$PROD^XUPROD(0)) QUIT 1
  1.  QUIT 0
  1.  ;
  1. STATMISM() ; return 1 if primary station mismatch, 0 if not
  1.  IF XOBSYS("ENV")'="j2ee" QUIT 0 ; no checking for c/s mode
  1.  NEW XOBSTAT
  1.  ; strip off suffix
  1.  SET XOBSTAT=$$STRPSUFF($GET(XOBDATA("CLIENTPRIMARYSTATION")))
  1.  ; compare w/KSP value
  1.  IF XOBSTAT'=XOBSYS("PRIMARY STATION#") QUIT 1 ;mismatch found
  1.  QUIT 0
  1.  ;
  1. STRPSUFF(XOBSTAT) ; strip alpha suffix from sta# e.g. AAC "200M"
  1.  SET XOBSTAT=$$TRUNCCH^XOBVSYSI(XOBSTAT)
  1.  ; nursing home, treat 9 as suffix
  1.  IF $LENGTH(XOBSTAT)=4,$EXTRACT(XOBSTAT,4)=9 SET XOBSTAT=$EXTRACT(XOBSTAT,1,3)
  1.  QUIT XOBSTAT
  1.  ;
  1. ISCPROXY() ; c/proxy check
  1.  ; returns 1 if c/proxy user, 0 if not
  1.  NEW XOBCPCHK,XOBOK
  1.  SET XOBOK=1
  1.  SET XOBCPCHK=$$CPCHK^XUSAP(+XOBRET(0))
  1.  IF 'XOBCPCHK DO  SET XOBOK=0
  1.  . DO ERROR^XOBSCAV(.XOBR,$PIECE($TEXT(FSERVER^XOBSCAV),";;",2),"Connector Proxy User Error",183008,$$CHARCHK^XOBVLIB($$EZBLD^DIALOG(183008,$PIECE($GET(XOBCPCHK),U,2))))
  1.  QUIT XOBOK
  1.  ;
  1. CHXHDR ; Check the xml header and add to the saml token temp global if not there.
  1.  IF '$DATA(^XTMP($JOB,"SAML")),$EXTRACT($GET(^XTMP($JOB,"SAML",$ORDER(^XTMP($JOB,"SAML",0)))),1,14)="<?xml version=" QUIT  ;Quit if header is there or no ^XTMP node
  1.  KILL ^TMP($JOB,"SAML")
  1.  NEW N,CNT,END
  1.  SET N=0,CNT=1,END=0 FOR  SET N=$ORDER(^XTMP($JOB,"SAML",N)) QUIT:N'>0  SET ^TMP($JOB,"SAML",CNT)=$GET(^XTMP($JOB,"SAML",N)),CNT=CNT+1
  1.  NEW TXT
  1.  SET TXT="<?xml version=""1.0"" encoding=""UTF-8""?>"_$GET(^TMP($JOB,"SAML",1)),^TMP($JOB,"SAML",1)=$GET(TXT)
  1.  KILL ^XTMP($JOB,"SAML")
  1.  NEW XX SET (END,XX)=0 FOR  SET XX=$ORDER(^TMP($JOB,"SAML",XX)) QUIT:XX'>0!END=1  DO
  1.  . QUIT:$GET(END)=1
  1.  . SET NODE=$GET(^TMP($JOB,"SAML",XX))
  1.  . SET:NODE["]]" END=1
  1.  . SET ^XTMP($JOB,"SAML",XX)=$PIECE(^TMP($JOB,"SAML",XX),"]]",1)
  1.  KILL ^TMP($JOB,"SAML")
  1.  QUIT
  1.  ;