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

INHULOG.m

Go to the documentation of this file. 
  1. INHULOG ; JC Hrubovcak ; 23 Aug 95 18:35 
  1.  ;;3.01;BHL IHS Interfaces with GIS;;JUL 01, 2001
  1.  ;COPYRIGHT 1991-2000 SAIC
  1.  ; GIS logon utilities. These utilities are used by the LOGON server
  1.  ;functionality. They are called from the INHVCR* routines and are
  1.  ;specific to a CHCS environment. If the IHS needs to use the 
  1.  ;logon servers, some of the logic must be revised.
  1.  Q
  1. GETDUZ(AC,VC,ZN) ; function, returns User IEN and ^DIC(3,IEN,0), or false on failure
  1.  ; input: AC=Access, VC=Verify, hashed codes (required), ZN=zero node, returned by reference
  1.  S ZN="",AC=$G(AC),VC=$G(VC) Q:'$L(AC)!'$L(VC) "^Required data missing"
  1.  Q:'$D(^DIC(3,"A",AC)) "^Access code not found."
  1.  N A,D,V S D=+$O(^DIC(3,"A",AC,0)) Q:D'>0 "^User not found."
  1.  D SETDT^UTDT S A=$G(^DIC(3,D,0)),V=$G(^(.1)) Q:$P(V,U,2)'=VC "^Verify code mismatch."
  1.  I $P(A,U,11),$P(A,U,11)<DT Q "^Beyond termination date."
  1.  ;
  1.  ; check prohibited times
  1.  S V=$P(A,U,12) I $L(V) S V=$$PROHBTM(V) Q:V "^Prohibited time"
  1.  ;
  1.  S ZN=A Q D   ; success, put zero node into ZN
  1.  ;
  1. SETENV(NEWDUZ,NEWDIV) ; function, setup environment variables, returns false on success
  1.  ; NEWDUZ= User IEN (required), NEWDIV = Division IEN (optional) - Not used.
  1.  S U="^",DUZ=+$G(DUZ)   ; initialization
  1.  Q:$G(NEWDUZ)'>0!(NEWDUZ'=+NEWDUZ) "2^Invalid User IEN"
  1.  Q:DUZ=NEWDUZ 0   ; no action needed
  1.  ; validity checks, user is already "logged on"
  1.  ; The ^XMB7(duz,100,$I) nodes should be defined
  1.  D SETDT^UTDT N %,X S X=$G(^DIC(3,NEWDUZ,0)) Q:'$L(X) "2^User not found"
  1.  S %=$P(X,U,3) Q:'$L(%) "2^No Access Code."
  1.  S %=$P(X,U,4) I %,%<DT Q:"2^Past termination date."
  1.  ; ensure call to XUDIV avoids terminal I/O
  1.  S %=$$DIVCHK(NEWDUZ) Q:'% "2^"_%
  1.  ; now we clean up all the old stuff
  1.  K DUZ,XMDUZ S DUZ=NEWDUZ,DUZ(0)=$P(X,U,4)
  1.  S DTIME=$$DTIME(DUZ) Q:'$L(DTIME) "2^Incomplete User record"
  1.  ;;folloing two lines must definitely be changed for IHS
  1.  ;D DUZAG^XUS1   ; set up agency codes, no user prompts
  1.  ;D ^XUDIV   ; set up division, BEWARE: possible user prompts
  1.  ; set up device variables,if needed
  1.  I '$L($G(IO(0)))!'$L($G(IO)) S IOP="NL:" D ^%ZIS
  1.  K ^DIJUSV(DUZ)
  1.  ; success
  1.  Q 0
  1.  ;
  1. DTIME(INUSR,INDEF) ; function, returns timed-read (in seconds) for INUSR.
  1.  ; Default=300.  For remote systems, result represents the # of seconds
  1.  ; to wait for remote system to communicate before connection is closed.
  1.  ; Input: INUSR  - (req) USER IEN
  1.  ;        INDEF  - (opt) customized default (e.g. for remote systems)
  1.  Q:'$D(^DIC(3,INUSR,0)) ""
  1.  N A S A=+$P($G(^(200)),U,10) Q:A>0 A
  1.  ; use KERNEL SITE PARAMETERS
  1.  S A=+$P($G(^XMB(1,1,"XUS")),U,10)
  1.  Q $S(A>0:A,$G(INDEF):INDEF,1:300)
  1.  ;
  1. DIVCHK(USR,REQDIV) ; $$function - Division validation for USR.
  1.  ; Verify:
  1.  ; - default division exists for USR
  1.  ; - default division is one of USR's allowable divisions (if allowables
  1.  ;   are specified)
  1.  ; - if REQDIV is passed in, verify that requested division:
  1.  ;   - is a valid MEDICAL CENTER DIVISION IEN
  1.  ;   - is one of USR's allowables (if allowables are specified)
  1.  ;
  1.  ; Input:
  1.  ; USR    = (req) USER IEN
  1.  ; REQDIV = (opt) >0 - Requested division
  1.  ;                 0 - ignore all "requested division" validation (not passed in)
  1.  ;
  1.  ; Output:  1 = successful division validation
  1.  ;          Error msg = failed division validation
  1.  ;
  1.  N ALLOWDIV,DEFDIV,DEFOK,REQOK,X
  1.  I $D(REQDIV),$S($G(REQDIV)<1:1,1:'$D(^DG(40.8,REQDIV,0))) Q "Invalid Medical Center Division requested"
  1.  S DEFDIV=$P($G(^DIC(3,USR,0)),U,16),REQDIV=+$G(REQDIV)
  1.  Q:DEFDIV'>0 "Default division is missing for user '"_USR_"'"
  1.  ; ck if allowable divisions exist for USR
  1.  I $O(^DIC(3,USR,2,0)) D  Q:'DEFOK "Default division does not match allowable divisions for user '"_USR_"'"  Q:'REQOK "Requested division '"_REQDIV_"' does not match allowable divisions for user '"_USR_"'"
  1.  . S DEFOK=0,REQOK='REQDIV ; do not ck requested div if not passed in
  1.  . M ALLOWDIV=^DIC(3,USR,2)
  1.  . S X=0 F  S X=$O(ALLOWDIV(X)) Q:'X  S:'DEFOK DEFOK=(DEFDIV=ALLOWDIV(X,0)) S:(REQDIV&'REQOK) REQOK=(REQDIV=ALLOWDIV(X,0)) Q:(DEFOK&REQOK)
  1.  Q 1
  1.  ;
  1. PROHBTM(T) ; boolean function, check for prohibited signon time
  1.  ;return true if prohibited, null if invalid time passed in
  1.  ;T = (required) military time in format: HHMM-HHMM
  1.  Q:T'?4N1"-"4N ""
  1.  ;B=beginning time, E=ending time, H=current time
  1.  N B,E,H S B=$P(T,"-"),E=$P(T,"-",2),H=$P($H,",",2),H=H\60#60+(H\3600*100)
  1.  Q:E=B H=E
  1.  Q:E<B $S(H<B&(H>E):0,1:1)
  1.  Q $S(H>E&(H<B):0,1:1)
  1.  ;
  1. VALIDIP(INBPN,INADDR) ; $$function - Validate remote system IP address.
  1.  ; Verify:
  1.  ; - minimum length
  1.  ; - format = 1-3N.1-3N.1-3N.1-3N
  1.  ; - exists on authorized address list (BACKGROUND PROCESS CONTROL file, 
  1.  ;   Client IP Address multiple)
  1.  ;
  1.  ; Input:
  1.  ; INBPN    - BACKGROUND PROCESS CONTROL IEN
  1.  ; INADDR   - IP Address to be validated
  1.  ;
  1.  ; Output:
  1.  ; 0 = successful validation
  1.  ; "1^Error msg" = failure
  1.  ;
  1.  N X
  1.  Q:$L(INADDR)<3 "1^Fails minimum length requirements"
  1.  Q:INADDR'?1.3N1"."1.3N1"."1.3N1"."1.3N "1^Invalid IP address format"
  1.  ; verify IP adrs is in authorized address list
  1.  S X=$O(^INTHPC(INBPN,6,"B",INADDR,0))
  1.  Q:'X "1^Not found in authorized address list"
  1.  Q:'($G(^INTHPC(INBPN,6,X,0))=INADDR) "1^Inconsistent authorized address list"
  1.  Q 0
  1.  ;
  1. LGNLOG(USR) ; Logon log subroutine, USR=userIEN, T=date&time, D=device ID
  1.  Q:$G(USR)'>0  N D,T  S D=$$DEVID^%ZTOS S:'$L(D) D=$P
  1.  ; one second HANG ensures uniqueness
  1.  F  D SETDT^UTDT S T=$P($H,",",2),T=DT_(T\60#60/100+(T\3600)+(T#60/10000)/100) L +^XUSEC(0,T):0 Q:$T&'$D(^XUSEC(0,T,0))  H 1
  1.  S ^XUSEC(0,T,0)=USR_"^"_D_"^"_$J_"^^"_$G(^%ZOSF("VOL"))_"^"_$S($L($G(ION)):ION,1:$I) L -^XUSEC(0,T)
  1.  K ^ZUTL("XQ",$J) S ^($J,0)=T  ; we use this at Logoff
  1.  S ^XMB7(USR,.1)=T,^(100,D,0)=D_" "_$G(^%ZOSF("VOL"))_" ^"_$J   ; space after ^%ZOSF("VOL") is intended
  1.  Q
  1.  ;
  1. CLRSTOR ; Clear out scratch storage, similar to K2^XUS
  1.  K ^UTILITY("NSR",+$O(^UTILITY($J,"NST",""))),^UTILITY($J),^ZUTL("XQ",$J)
  1.  S %=$C(1) F  K ^UTILITY(%,$J) S %=$O(^UTILITY(%)) Q:'$L(%)  K ^(%,$J)   ; clear all namespaces
  1.  I $G(ORDFN) K ^ORB("AMA",+ORDFN),^ORB("ANEW",+ORDFN)
  1.  K:$L($G(DUZ)) ^DIJUSV(DUZ) K ^DIJUSV($I),^($P)   ; "spacebar return"
  1.  Q
  1.  ;
  1. TICKET() ; function, returns access ticket, 6 to 10 alphanumerics
  1.  N C,L,K,V S V=$H+$P($H,",",2),V=$$RV(.V),V=$$RV(.V),L=$R(V)#5+6,V=$$RV(.V),K=$C($R(V)#26+65)
  1.  F  Q:$L(K)=L  S V=$$RV(.V),V=$$RV(.V),C=$C(V+$E(V,$L(V)-2,255)#127) S:C?1U!(C?1N) K=K_C
  1.  Q K
  1. RV(V) ; random value increment
  1.  Q V+$R(V)+$H+$P($H,",",2)+$E(V,$L(V)-4,99)