source: FOIAVistA/trunk/r/VISTALINK_SECURITY-XOBS/XOBSCAV1.m@ 1801

XOBSCAV1 ;; kec/oak - VistaLink Access/Verify Security ; [6/28/06 2:26pm]
 ;;1.5;VistALink Security;**1**;Sep 09, 2005;Build 3
 ;;Foundations Toolbox Release v1.5 [Build: 1.5.1.001]
 ;;
 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,XOBITINF,XOBMSG,XOBTMP,XOBTMP1,XOBCCMSK,XOBI,XOBPROD
 ;
 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)))
 ;
 ; Do SETUP^XUSRB to setup, then INTRO^XUSRB to get intro text
 ; 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
 ;
 USE XOBNULL ; protect against direct writes to socket
 ; note: SETUP/INTRO^XUSRB set 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
 DO INTRO^XUSRB(.XOBITINF) ; use of INTRO^XUSRB: DBIA #4054
 ; ** 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
 DO VALIDAV^XUSRB(.XOBRET,XOBDATA("XOB SECAV","AVCODE")) ; use of VALIDAV^XUSRB: DBIA#4054
 USE XOBPORT ; restore current IO (the TCP port)
 ;
 ; if bad a/v code credentials
 IF '+XOBRET(0),'+XOBRET(1),'+XOBRET(2) DO  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)))))
 . ; 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
 . 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 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
 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=+XOBSTAT
 ; nursing home, treat 9 as suffix
 IF $LENGTH(XOBSTAT)=4,$E(XOBSTAT,4)=9 SET XOBSTAT=$E(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
 ;