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