- XUSKAAJ ;;12/15/15 08:54;08/24/2006
- ;;8.0;KERNEL;**329,430,659**;Jul 10, 1995;Build 22
- ;Per VA Directive 6402, this routine should not be modified.
- ;;
- QUIT
- ;
- ; ------------------------------------------------------------------------
- ; SSO/UC KAAJEE RPCs
- ; ------------------------------------------------------------------------
- ;
- USERINFO(RET,CLIENTIP,SERVERNM) ; called by XUS KAAJEE GET USER INFO rpc
- ;
- ; INPUT:
- ; CLIENTIP is IP address of the client workstation, used for logging (signon log) and IP blocking (failed access attempts).
- ; SERVERNM is Identifying name for the calling application or server, used for logging (signon log).
- ; OUTPUT:
- ; Result(0) is the users DUZ.
- ; Result(1) is the user name from the .01 field.
- ; Result(2) is the users full name from the name standard file.
- ; Result(3) is the FAMILY (LAST) NAME
- ; Result(4) is the GIVEN (FIRST) NAME
- ; Result(5) is the MIDDLE NAME
- ; Result(6) is the PREFIX
- ; Result(7) is the SUFFIX
- ; Result(8) is the DEGREE
- ; Result(9) is station # of the division that the user is working in.
- ; Result(10) is the station # of the parent facility for the login division
- ; Result(11) is the station # from the KSP site parameters, the parent "computer system"
- ; Result(12) is the signon log entry IEN
- ; Result(13) = # of permissible divisions
- ; Result(14-n) are the permissible divisions for user login, in the format:
- ; IEN of file 4^Station Name^Station Number^default? (1 or 0)
- ;
- N I,XUNC,XUNC1,XUKERR,XUKRET,XUDIVS,XUKI,XULINE,XUPARENT,XUDIVLIN,XUKDEF
- ;
- ; initialize return array
- S RET(0)=DUZ
- F I=1:1:13 S RET(I)=""
- ;
- ; get ptr to Name Components file
- D GETS^DIQ(200,DUZ_",","10.1","I","XUNC","XUKERR")
- I '$D(XUKERR) D
- .S XUNC=XUNC(200,DUZ_",",10.1,"I")
- .; get name components
- .D GETS^DIQ(20,XUNC_",","1:6","","XUNC1","XUKERR")
- .I '$D(XUKERR) D
- ..S RET(3)=XUNC1(20,XUNC_",",1) S:'$L(RET(3)) RET(3)="^"
- ..S RET(4)=XUNC1(20,XUNC_",",2) S:'$L(RET(4)) RET(4)="^"
- ..S RET(5)=XUNC1(20,XUNC_",",3) S:'$L(RET(5)) RET(5)="^"
- ..S RET(6)=XUNC1(20,XUNC_",",4) S:'$L(RET(6)) RET(6)="^"
- ..S RET(7)=XUNC1(20,XUNC_",",5) S:'$L(RET(7)) RET(7)="^"
- ..S RET(8)=XUNC1(20,XUNC_",",6) S:'$L(RET(8)) RET(8)="^"
- ;
- ; get .01 New Person name, Name components name, and login division info
- D USERINFO^XUSRB2(.XUKRET)
- S RET(1)=XUKRET(1) S:'$L(RET(1)) RET(1)="^"
- S RET(2)=XUKRET(2) S:'$L(RET(2)) RET(2)="^"
- S RET(9)=$P(XUKRET(3),U,3) S:'$L(RET(9)) RET(9)="0"
- ;
- ; get parent facility station#
- S XUPARENT=$$PRNT^XUAF4(RET(9))
- S RET(10)=$S(($P(XUPARENT,U)<1):XUPARENT,1:$$STA^XUAF4($P(XUPARENT,U)))
- S:'$L(RET(10)) RET(10)="^"
- ;
- ; get the computer system station#
- S RET(11)=$$STA^XUAF4($$KSP^XUPARAM("INST"))
- S:'$L(RET(11)) RET(11)="0"
- ;
- ; make signon log entry, get IEN
- S RET(12)=$$SIGNLOG^XUSKAAJ(CLIENTIP,SERVERNM)
- ;
- ; get permitted divisions
- S XUDIVLIN=13 ; return array subscript counter for division start point
- D DIVGET^XUSRB2(.XUDIVS,DUZ)
- I '+XUDIVS(0) S RET(XUDIVLIN)=1,RET(XUDIVLIN+1)=XUKRET(3)_"^1" ; only 1 division, so use login division.
- I +XUDIVS(0) S RET(XUDIVLIN)=+XUDIVS(0) D
- .S XUKDEF=$O(^VA(200,DUZ,2,"AX1",1,"")) ; default division if any. Should only be 1.
- .S XUKI=0,XULINE=XUDIVLIN F S XUKI=$O(XUDIVS(XUKI)) Q:XUKI']"" D
- ..S XULINE=XULINE+1,RET(XULINE)=XUDIVS(XUKI)
- ..S $P(RET(XULINE),U,4)=$S($P(XUDIVS(XUKI),U)=XUKDEF:1,1:0)
- ;
- Q
- ;
- SIGNOFF(RET,DA) ; kill entry in sign-on log. Called by XUS KAAJEE LOGOUT rpc.
- D LOUT^XUSCLEAN(DA)
- S RET=1 Q
- ;
- SIGNLOG(CLIENTIP,SERVERNM) ; make a signon log entry for KAAJEE user
- ; todo: expand size of server name field?
- N XP1,XPIP,XPCLNM,Y
- S:$D(IO("IP")) XPIP=IO("IP") S IO("IP")=CLIENTIP
- S:$D(IO("CLNM")) XPCLNM=IO("CLNM") S IO("CLNM")=$E(SERVERNM,1,20)
- ;
- D GETENV^%ZOSV
- S XP1=$$SLOG^XUS1($P(Y,U,2),,,$P(Y,U),$P(Y,U,3),"KAAJEE","")
- ;
- S:$D(XPIP) IO("IP")=XPIP
- S:$D(XPCLNM) IO("CLNM")=XPCLNM
- Q XP1
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSKAAJ 3989 printed Feb 18, 2025@23:39 Page 2
- XUSKAAJ ;;12/15/15 08:54;08/24/2006
- +1 ;;8.0;KERNEL;**329,430,659**;Jul 10, 1995;Build 22
- +2 ;Per VA Directive 6402, this routine should not be modified.
- +3 ;;
- +4 QUIT
- +5 ;
- +6 ; ------------------------------------------------------------------------
- +7 ; SSO/UC KAAJEE RPCs
- +8 ; ------------------------------------------------------------------------
- +9 ;
- USERINFO(RET,CLIENTIP,SERVERNM) ; called by XUS KAAJEE GET USER INFO rpc
- +1 ;
- +2 ; INPUT:
- +3 ; CLIENTIP is IP address of the client workstation, used for logging (signon log) and IP blocking (failed access attempts).
- +4 ; SERVERNM is Identifying name for the calling application or server, used for logging (signon log).
- +5 ; OUTPUT:
- +6 ; Result(0) is the users DUZ.
- +7 ; Result(1) is the user name from the .01 field.
- +8 ; Result(2) is the users full name from the name standard file.
- +9 ; Result(3) is the FAMILY (LAST) NAME
- +10 ; Result(4) is the GIVEN (FIRST) NAME
- +11 ; Result(5) is the MIDDLE NAME
- +12 ; Result(6) is the PREFIX
- +13 ; Result(7) is the SUFFIX
- +14 ; Result(8) is the DEGREE
- +15 ; Result(9) is station # of the division that the user is working in.
- +16 ; Result(10) is the station # of the parent facility for the login division
- +17 ; Result(11) is the station # from the KSP site parameters, the parent "computer system"
- +18 ; Result(12) is the signon log entry IEN
- +19 ; Result(13) = # of permissible divisions
- +20 ; Result(14-n) are the permissible divisions for user login, in the format:
- +21 ; IEN of file 4^Station Name^Station Number^default? (1 or 0)
- +22 ;
- +23 NEW I,XUNC,XUNC1,XUKERR,XUKRET,XUDIVS,XUKI,XULINE,XUPARENT,XUDIVLIN,XUKDEF
- +24 ;
- +25 ; initialize return array
- +26 SET RET(0)=DUZ
- +27 FOR I=1:1:13
- SET RET(I)=""
- +28 ;
- +29 ; get ptr to Name Components file
- +30 DO GETS^DIQ(200,DUZ_",","10.1","I","XUNC","XUKERR")
- +31 IF '$DATA(XUKERR)
- Begin DoDot:1
- +32 SET XUNC=XUNC(200,DUZ_",",10.1,"I")
- +33 ; get name components
- +34 DO GETS^DIQ(20,XUNC_",","1:6","","XUNC1","XUKERR")
- +35 IF '$DATA(XUKERR)
- Begin DoDot:2
- +36 SET RET(3)=XUNC1(20,XUNC_",",1)
- if '$LENGTH(RET(3))
- SET RET(3)="^"
- +37 SET RET(4)=XUNC1(20,XUNC_",",2)
- if '$LENGTH(RET(4))
- SET RET(4)="^"
- +38 SET RET(5)=XUNC1(20,XUNC_",",3)
- if '$LENGTH(RET(5))
- SET RET(5)="^"
- +39 SET RET(6)=XUNC1(20,XUNC_",",4)
- if '$LENGTH(RET(6))
- SET RET(6)="^"
- +40 SET RET(7)=XUNC1(20,XUNC_",",5)
- if '$LENGTH(RET(7))
- SET RET(7)="^"
- +41 SET RET(8)=XUNC1(20,XUNC_",",6)
- if '$LENGTH(RET(8))
- SET RET(8)="^"
- End DoDot:2
- End DoDot:1
- +42 ;
- +43 ; get .01 New Person name, Name components name, and login division info
- +44 DO USERINFO^XUSRB2(.XUKRET)
- +45 SET RET(1)=XUKRET(1)
- if '$LENGTH(RET(1))
- SET RET(1)="^"
- +46 SET RET(2)=XUKRET(2)
- if '$LENGTH(RET(2))
- SET RET(2)="^"
- +47 SET RET(9)=$PIECE(XUKRET(3),U,3)
- if '$LENGTH(RET(9))
- SET RET(9)="0"
- +48 ;
- +49 ; get parent facility station#
- +50 SET XUPARENT=$$PRNT^XUAF4(RET(9))
- +51 SET RET(10)=$SELECT(($PIECE(XUPARENT,U)<1):XUPARENT,1:$$STA^XUAF4($PIECE(XUPARENT,U)))
- +52 if '$LENGTH(RET(10))
- SET RET(10)="^"
- +53 ;
- +54 ; get the computer system station#
- +55 SET RET(11)=$$STA^XUAF4($$KSP^XUPARAM("INST"))
- +56 if '$LENGTH(RET(11))
- SET RET(11)="0"
- +57 ;
- +58 ; make signon log entry, get IEN
- +59 SET RET(12)=$$SIGNLOG^XUSKAAJ(CLIENTIP,SERVERNM)
- +60 ;
- +61 ; get permitted divisions
- +62 ; return array subscript counter for division start point
- SET XUDIVLIN=13
- +63 DO DIVGET^XUSRB2(.XUDIVS,DUZ)
- +64 ; only 1 division, so use login division.
- IF '+XUDIVS(0)
- SET RET(XUDIVLIN)=1
- SET RET(XUDIVLIN+1)=XUKRET(3)_"^1"
- +65 IF +XUDIVS(0)
- SET RET(XUDIVLIN)=+XUDIVS(0)
- Begin DoDot:1
- +66 ; default division if any. Should only be 1.
- SET XUKDEF=$ORDER(^VA(200,DUZ,2,"AX1",1,""))
- +67 SET XUKI=0
- SET XULINE=XUDIVLIN
- FOR
- SET XUKI=$ORDER(XUDIVS(XUKI))
- if XUKI']""
- QUIT
- Begin DoDot:2
- +68 SET XULINE=XULINE+1
- SET RET(XULINE)=XUDIVS(XUKI)
- +69 SET $PIECE(RET(XULINE),U,4)=$SELECT($PIECE(XUDIVS(XUKI),U)=XUKDEF:1,1:0)
- End DoDot:2
- End DoDot:1
- +70 ;
- +71 QUIT
- +72 ;
- SIGNOFF(RET,DA) ; kill entry in sign-on log. Called by XUS KAAJEE LOGOUT rpc.
- +1 DO LOUT^XUSCLEAN(DA)
- +2 SET RET=1
- QUIT
- +3 ;
- SIGNLOG(CLIENTIP,SERVERNM) ; make a signon log entry for KAAJEE user
- +1 ; todo: expand size of server name field?
- +2 NEW XP1,XPIP,XPCLNM,Y
- +3 if $DATA(IO("IP"))
- SET XPIP=IO("IP")
- SET IO("IP")=CLIENTIP
- +4 if $DATA(IO("CLNM"))
- SET XPCLNM=IO("CLNM")
- SET IO("CLNM")=$EXTRACT(SERVERNM,1,20)
- +5 ;
- +6 DO GETENV^%ZOSV
- +7 SET XP1=$$SLOG^XUS1($PIECE(Y,U,2),,,$PIECE(Y,U),$PIECE(Y,U,3),"KAAJEE","")
- +8 ;
- +9 if $DATA(XPIP)
- SET IO("IP")=XPIP
- +10 if $DATA(XPCLNM)
- SET IO("CLNM")=XPCLNM
- +11 QUIT XP1
- +12 ;