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

XOBSRA.m

Go to the documentation of this file. 
  1. XOBSRA ;mjk,esd/alb - VistALink Reauthentication Code ; 05/22/2003  07:00
  1.  ;;1.6;VistALink Security;**2**;May 08, 2009;Build 3
  1.  ;;Per VA Directive 6402, this routine should not be modified
  1.  QUIT
  1.  ;
  1.  ; ------------------------------------------------------------------------
  1.  ;             RPC Server: Reauthentication based on VPID, DUZ, and AV
  1.  ; ------------------------------------------------------------------------
  1.  ;
  1. SETUPDUZ() ; -- get DUZ context and division
  1.  ;
  1.  NEW XOBERR,XOBID,XOBTYPE
  1.  SET (XOBERR,XOBID)=0
  1.  ;
  1.  ; -- if already authenticated quit
  1.  IF $GET(XOBDATA("XOB RPC","SECURITY","STATE"))="authenticated" D KILL^XOBSRA1 GOTO SUDQ ;*2
  1.  ; -- switch to null device
  1.  DO NULL
  1.  ; -- initialize partition
  1.  DO INIT
  1.  ;
  1.  ; -- check if logons are enabled
  1.  SET XOBERR=$$LOGINH()
  1.  IF XOBERR DO SOCKET GOTO SUDQ
  1.  ;
  1.  ; -- reauthenticate user based on type
  1.  SET XOBTYPE=$GET(XOBDATA("XOB RPC","SECURITY","TYPE")),XOBTYPE=$$UP^XLFSTR(XOBTYPE)
  1.  IF XOBTYPE="DUZ"!(XOBTYPE="AV")!(XOBTYPE="VPID")!(XOBTYPE="CCOW")!(XOBTYPE="APPPROXY") DO
  1.  . DO @(XOBTYPE_"(.XOBID,.XOBERR)")
  1.  ELSE  DO
  1.  . SET XOBERR=182301_U_XOBTYPE_U_"  [Erroneous reauthentication type]"
  1.  ;
  1.  ; -- check division
  1.  IF XOBID SET XOBERR=$$DUZENV(XOBID,XOBTYPE)
  1.  ;
  1.  ; -- switch back to socket device
  1.  DO SOCKET
  1. SUDQ ;
  1.  ;LOG:: Log error in trap or elsewhere if appropriate. May want to log 'no match' event for security reasons.
  1.  IF 'XOBERR DO FINAL
  1.  QUIT XOBERR
  1.  ;
  1. NULL ; switch to null device
  1.  USE XOBNULL
  1.  QUIT
  1.  ;
  1. SOCKET ; -- switch back to socket device
  1.  ; -- empty write buffer of null device
  1.  USE XOBNULL SET DX=0,DY=0 XECUTE ^%ZOSF("XY")
  1.  ; -- reset to use tcp port device to send results
  1.  USE XOBPORT
  1.  QUIT
  1.  ;
  1. AV(XOBID,XOBERR) ; -- AV (SSO/UC KAAJEE) reauth type
  1.  ;
  1.  ; More checks performed here; assume this would be called ONCE when user authenticates
  1.  ; to application via KAAJEE or FatKAAT
  1.  ;
  1.  DO AV^XOBSRAKJ(.XOBID,.XOBERR)
  1.  QUIT
  1.  ;
  1. DUZ(XOBID,XOBERR) ; -- DUZ reauth type
  1.  ;
  1.  NEW XOBCTYPE
  1.  SET XOBCTYPE="DUZ"
  1.  SET XOBID=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","VALUE"))
  1.  ;
  1.  ; Active user status check performed here; assume heavier-duty checks done by application
  1.  ; when user authenticated to application via KAAJEE, FatKAAT or equivalent.
  1.  ;
  1.  DO ACTUSR(.XOBID,.XOBERR,XOBCTYPE)
  1.  QUIT
  1.  ;
  1. VPID(XOBID,XOBERR) ; -- VPID reauth type
  1.  NEW VPID,XOBCTYPE
  1.  SET XOBID=0
  1.  SET XOBCTYPE="VPID"
  1.  ;
  1.  SET VPID=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","VALUE"))
  1.  IF VPID]"" SET XOBID=$$IEN^XUPS(VPID)
  1.  ;
  1.  IF '+XOBID DO  QUIT
  1.  . SET XOBERR=182301_U_XOBTYPE_U_"["_XOBCTYPE_" Value: '"_VPID_"']"
  1.  . SET XOBID=0
  1.  ;
  1.  ; Active user status check performed here; assume heavier-duty checks done by application
  1.  ; when user authenticated to application via KAAJEE, FatKAAT or equivalent.
  1.  ;
  1.  DO ACTUSR(.XOBID,.XOBERR,XOBCTYPE)
  1.  QUIT
  1.  ;
  1. APPPROXY(XOBID,XOBERR) ; -- application proxy reauth type
  1.  ;
  1.  NEW XOBANAME,XOBCTYPE,XOBAPFND
  1.  SET XOBID=0,XOBCTYPE="APPPROXY"
  1.  SET XOBANAME=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","VALUE"))
  1.  ;
  1.  ; APFIND^XUSAP(name) -> returns ien^vpid, or (failure) -int^reason
  1.  IF XOBANAME]"" SET XOBAPFND=$$APFIND^XUSAP(XOBANAME),XOBID=$PIECE(XOBAPFND,U)
  1.  ; file #200 division mult checking not necessary for app proxy user
  1.  IF (+XOBID)<1 DO
  1.  . SET XOBERR=182307_U_XOBANAME_U_"["_$P(XOBAPFND,U,2)_"]",XOBID=0
  1.  QUIT
  1.  ;
  1. CCOW(XOBID,XOBERR) ; -- CCOW reauth type
  1.  ; 
  1.  ; Very few checks performed here; assume heavier duty checks done by application when originally
  1.  ; authenticated and created Kernel CCOW token. User would need to be reauthenticated (and perform
  1.  ; heavier-duty checks) upon Kernel CCOW token expiration.
  1.  ;
  1.  DO CCOW^XOBSRAKJ(.XOBID,.XOBERR)
  1.  QUIT
  1.  ;
  1. ACTUSR(XOBID,XOBERR,XOBCTYPE) ; -- user active status check & error processing
  1.  ;
  1.  NEW XOBACTIV
  1.  SET XOBACTIV=0
  1.  SET XOBID=$GET(XOBID),XOBCTYPE=$GET(XOBCTYPE)
  1.  ;
  1.  ;-- returns active status indicator of user
  1.  SET XOBACTIV=$$ACTIVE^XUSER(XOBID)
  1.  IF +XOBACTIV<1 DO
  1.  . ;
  1.  . ;-- get dialog entry for error
  1.  . SET XOBERR=$$GETERR(XOBACTIV,XOBID,XOBCTYPE)
  1.  . SET XOBID=0
  1.  QUIT
  1.  ;
  1. DUZENV(XOBDUZ,XOBTYPE) ; -- build DUZ and check division
  1.  ;
  1.  ; QUIT 0 if OK, DialogErrorNumber^DialogErrorParameter1^... if bad
  1.  ;
  1.  NEW XOBDVARY,XOBDIV,XOBDIVEX,XOBDIVRQ,XOBDUZSV,XOBERR,XOBI,XOBOK
  1.  SET XOBOK=0,(XOBERR,XOBDIVEX)=""
  1.  ;
  1.  ; -- preserve previous DUZ value, restore if needed
  1.  MERGE XOBDUZSV=DUZ KILL DUZ
  1.  ;
  1.  ; -- set up info on passed in user
  1.  SET DUZ=XOBDUZ
  1.  SET XOBDIVRQ("STATIONNUMBER")=$GET(XOBDATA("XOB RPC","SECURITY","DIV"))
  1.  ;
  1.  DO  ; checks
  1.  .;
  1.  .; -- if no division passed in
  1.  . IF XOBDIVRQ("STATIONNUMBER")']"" DO  QUIT
  1.  . . SET XOBERR=182308_U_"no division passed"_U_XOBTYPE_U_XOBDUZ_U_"null"
  1.  . ;
  1.  . ; -- is division supported at the site?
  1.  . SET XOBDIVRQ("IEN")=$$SITECHK(XOBDIVRQ("STATIONNUMBER"))
  1.  . IF '+XOBDIVRQ("IEN") DO  QUIT
  1.  . . SET XOBERR=182308_U_$P(XOBDIVRQ("IEN"),U,2)_U_XOBTYPE_U_XOBDUZ_U_XOBDIVRQ("STATIONNUMBER")
  1.  . . KILL XOBDIVRQ("IEN")
  1.  .;
  1.  .; -- build DUZ
  1.  . DO DUZ^XUP(DUZ)
  1.  .;
  1.  .; -- don't do user-based checks if reauth type is APPPROXY
  1.  .IF XOBTYPE="APPPROXY" SET XOBOK=1 QUIT
  1.  .;
  1.  .; -- do check for user-permitted divisions
  1.  . DO DIVGET^XUSRB2(.XOBDIV,DUZ)
  1.  .;
  1.  .; -- DIVGET^XUSRB2 return value: if no divisions or one (matching) division, it's good
  1.  . IF '$GET(XOBDIV(0)) DO  QUIT
  1.  .. IF $GET(DUZ(2))=XOBDIVRQ("IEN") SET XOBOK=1 QUIT  ; OK
  1.  ..;
  1.  ..; -- if got here, did not match division
  1.  .. SET XOBERR=182302_U_XOBTYPE_U_XOBDUZ_U_XOBDIVRQ("STATIONNUMBER")
  1.  .;
  1.  .; -- DIVGET^XUSRB2 return value: if >1 divisions to select, attempt to set DUZ(2) to div passed in
  1.  . DO DIVSET^XUSRB2(.XOBOK,"`"_XOBDIVRQ("IEN")) I 'XOBOK DO
  1.  .. SET XOBERR=182302_U_XOBTYPE_U_XOBDUZ_U_XOBDIVRQ("STATIONNUMBER")
  1.  ;
  1.  IF 'XOBOK DO  ; A check failed. Clean up partition.
  1.  .;
  1.  .; -- reset DUZ
  1.  . KILL DUZ
  1.  . MERGE DUZ=XOBDUZSV
  1.  ;
  1.  ; -- send back error
  1.  QUIT $SELECT(XOBOK:0,1:XOBERR)
  1.  ;
  1. LOGINH() ; -- Check if system is currently allowing logins
  1.  ; Return:
  1.  ;   181004 : if logins are disabled
  1.  ;        0 : if logins are allowed
  1.  ;
  1.  NEW XQVOL,XUCI,XUENV,XUVOL,X,Y
  1.  ;
  1.  ; -- Setup XUENV, XUCI,XQVOL,XUVOL
  1.  DO XUVOL^XUS
  1.  ;
  1.  ; -- Check whether logins are disabled
  1.  QUIT $SELECT($$INHIB1^XUSRB():181004,1:0)
  1.  ;
  1. NOACCESS(XOBID) ; -- Determine if user is allowed access via user active status & prohibited times checks
  1.  ;
  1.  NEW XOBERR,XOBNOACC,XOBRANGE
  1.  SET (XOBERR,XOBNOACC)=0
  1.  ;
  1.  ; -- user active status check & error processing
  1.  DO ACTUSR(.XOBID,.XOBERR)
  1.  ;
  1.  ; -- check if sign-on is attempted during prohibited times
  1.  IF 'XOBERR DO
  1.  . SET XOBRANGE=$$GET1^DIQ(200,XOBID,15)
  1.  . IF XOBRANGE DO
  1.  .. SET XOBNOACC=$$PROHIBIT^XUS1A($P($HOROLOG,",",2),XOBRANGE)
  1.  .. IF XOBNOACC SET XOBERR=182304_U_XOBID_U_"Prohibited time: "_$PIECE(XOBNOACC,U,2)
  1.  QUIT XOBERR
  1.  ;
  1. VCHG(XOBID) ; -- Check if verify code needs to be changed
  1.  ; Return:
  1.  ;   182303^XOBID : if verify code is undefined or expired
  1.  ;              0 : verify code is current
  1.  NEW DUZ,I,VCHG,XOPT
  1.  SET DUZ=+$GET(XOBID),VCHG=0
  1.  ;
  1.  ; -- set up XOPT
  1.  DO XOPT^XUS
  1.  ;
  1.  ; -- check if verify code is current
  1.  IF $$VCVALID^XUSRB() DO
  1.  . SET VCHG=182303_U_DUZ
  1.  QUIT VCHG
  1.  ;
  1. INIT ; -- VL-specific or general partition setup before reauthentication process starts
  1.  ;
  1.  LOCK
  1.  SET:$DATA(IO)[0 IO=$IO SET IO(0)=IO
  1.  KILL ^UTILITY($JOB),^TMP($JOB)
  1.  KILL ^XUTL("XQ",$JOB)
  1.  ; -- clean up partition's local symbol table
  1.  DO KILL^XOBSRA1
  1.  QUIT
  1.  ;
  1. FINAL ; -- Final setup needed after a re-authentication is performed successfully.
  1.  ; -- Save DUZ and IO variables in ^XUTL("XQ",$JOB)
  1.  DO SAVE^XUS1
  1.  ;
  1.  ; Change in XUSRB: calls POST2^XUSRB calls CLRFAC^XUS3 to clear Failed Signon Attempts
  1.  ; file of entry with given IP. Need IO("IP") obtained from ZIO^%ZIS4.
  1.  ; 
  1.  K XQY,XQY0 ;*2
  1.  QUIT
  1.  ;
  1. GETERR(XOBACT,XOBID,XOBCONN) ;-- Get appropriate DIALOG file error
  1.  ;
  1.  NEW XOBERR
  1.  SET XOBERR=0
  1.  SET XOBACT=$GET(XOBACT),XOBID=$GET(XOBID),XOBCONN=$GET(XOBCONN)
  1.  ;
  1.  ;- error indicates that user can't sign on, is DISUSER'd, or is TERMINATED
  1.  IF $PIECE(XOBACT,U)=0 SET XOBERR=182304_U_XOBID_U_$SELECT($PIECE(XOBACT,U,2)'="":$PIECE(XOBACT,U,2),1:"Unable to Sign On")
  1.  ;
  1.  ;- error indicates no user record found
  1.  IF $PIECE(XOBACT,U)="" DO
  1.  . SET:XOBCONN="" XOBCONN="Unknown Reauthentication Type"
  1.  . SET XOBERR=182301_U_XOBCONN_U_"  ["_XOBCONN_" reauthentication type, DUZ Value: '"_XOBID_"']"
  1.  QUIT XOBERR
  1.  ;
  1. SITECHK(XOBSTATN) ; check if valid division for this site
  1.  ; input: station#
  1.  ; output: IEN of station# in institution file (if valid for this site)
  1.  ;         0^error message (if not valid for this site)
  1.  N XOBSTIEN,XOBSTRIP
  1.  SET XOBSTRIP=$$STRPSUFF^XOBSCAV1(XOBSTATN)
  1.  ; note: AAC 200M truncated to 200 in both sides of comparison below
  1.  QUIT:(XOBSTRIP'=XOBSYS("PRIMARY STATION#")) "0^STATION '"_XOBSTATN_"' is not supported by this M system."
  1.  S XOBSTIEN=$$IEN^XUAF4(XOBSTATN)
  1.  QUIT:'+XOBSTIEN "0^STATION '"_XOBSTATN_"' is not a known station number."
  1.  QUIT:'$$ACTIVE^XUAF4(XOBSTIEN) "0^STATION '"_XOBSTATN_"' is not active on this M system."
  1.  QUIT XOBSTIEN