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