XUS1A ;SF-ISC/STAFF - SIGNON overflow from XUS1 ;12/02/14 13:26
;;8.0;KERNEL;**153,149,183,258,265,638**;Jul 10, 1995;Build 15
;Per VA Directive 6402, this routine should not be modified.
Q
USER() ;
N %B,%E,%T,I1,X1,X2
S XUTEXT=0,DUZ(2)=$G(DUZ(2),0)
F I=0:0 S I=$O(^XTV(8989.3,1,"POST",I)) Q:I'>0 D SET("!"_$G(^(I,0)))
D SET("!"),XOPT
S %H=$P($H,",",2)
D SET("!Good "_$S(%H<43200:"morning ",%H<61200:"afternoon ",1:"evening ")_$S($P(XUSER(1),U,4)]"":$P(XUSER(1),U,4),1:$P(XUSER(0),U,1)))
S I1=$G(^VA(200,DUZ,1.1)),X=(+I1_"0000")
I X D SET("! You last signed on "_$S(X\1=DT:"today",X\1+1=DT:"yesterday",1:$$FMTE^XLFDT(X,"1D"))_" at "_$E(X,9,10)_":"_$E(X,11,12))
I $P(I1,"^",2) S I=$P(I1,"^",2) D SET("!There "_$S(I>1:"were ",1:"was ")_I_" unsuccessful attempt"_$S(I>1:"s",1:"")_" since you last signed on.")
I $P(XUSER(0),U,12),$$PH(%H,$P(XUSER(0),U,12)) Q 17 ;Time frame
I +$P(XOPT,U,15) S %=$P(XOPT,U,15)-($H-XUSER(1)) I %<6,%>0 D SET("! Your Verify code will expire in "_%_" days")
;Report new Mail
N XUXM S %=$$NU^XMGAPI4(1,1,"XUXM") I $G(XUXM) F %=0:0 S %=$O(XUXM(%)) Q:%'>0 D SET("!"_XUXM(%))
S:$P(XOPT,"^",5) XUTT=1 S DTIME=$P(XOPT,U,10)
;Check Multiple Sign-on allowed, X1 signed on flag, X2 0=No,1=Yes,2=1IP
S X1=$P($G(^VA(200,DUZ,1.1)),U,3),X2=$P(XOPT,U,4)
I 'X2,X1 Q 9 ;Multi Sign-on not allowed
I X2=2 D Q:%B>0 %B ;Only from one IP
. S %B=0 I '$D(IO("IP")) S:X1 %B=9 Q ;Can't tell IP,
. S X1=$$COUNT(DUZ,IO("IP")),%B=$S(X1<0:9,(X1+1)>$P(XOPT,U,19):9,1:0)
USX S $P(^VA(200,DUZ,1.1),U,3)=1
;Call XQOR to handle SIGN-ON protocall.
N XUSER,XUSQUIT ;Protect ourself.
S DIC="^DIC(19,",X="XU USER SIGN-ON",XUSQUIT=0
D EN^XQOR
K X,DIC
Q XUSQUIT ;If protocol set XUSQUIT will stop sign-on.
;
SET(V) ;Set into XUTEXT(XUTEXT), Called from XU USER SIGN-ON protocol.
S XUTEXT=$G(XUTEXT)+1,XUTEXT(XUTEXT)=V
Q
;
DUZ ;setup duz, also see XUS5
;Called from XUSRB, XUESSO1
S:'$D(XUSER(0)) XUSER(0)=^VA(200,DUZ,0) D:$D(XOPT)[0 XOPT
S DUZ(0)=$P(XUSER(0),U,4),DUZ(1)="",DUZ("AUTO")=$P(XOPT,"^",6)
S DUZ(2)=$S($G(DUZ(2))>0:DUZ(2),1:+$P(XOPT,U,17))
S X=$P($G(^DIC(4,DUZ(2),99)),U,5),DUZ("AG")=$S(X]"":X,1:$P(^XTV(8989.3,1,0),U,8))
S DUZ("BUF")=($P(XOPT,U,9)="Y"),DUZ("LANG")=$P(XOPT,U,7)
Q
XOPT ;Build the XOPT string
N X,I
S:'$D(XOPT) XOPT=$G(^XTV(8989.3,1,"XUS"))
S X=$G(^VA(200,DUZ,200))
F I=4:1:7,9,10,19 I $P(X,U,I)]"" S $P(XOPT,"^",I)=$P(X,U,I)
Q
;
COUNT(IEN,IP) ;Count sign-on log active connect from this IP
N CNT,IX,IP6
S CNT="",IX=0,IP6=$$FORCEIP6^XLFIPV(IP) ;p638 use IPv6 xref
I '$D(^XUSEC(0,"AS5",IEN)) Q 0 ;First sign-on
I $O(^XUSEC(0,"AS5",IEN,""))'=IP6 Q -1 ;Diff IP
I $O(^XUSEC(0,"AS5",IEN,""),-1)'=IP6 Q -1 ;Diff IP
F S IX=$O(^XUSEC(0,"AS5",IEN,IP6,IX)) Q:'IX S CNT=CNT+1
Q CNT ;Return Count
;
INTRO(WNM) ;
Q:'$D(^XTV(8989.3,1,"INTRO",0))
F I=0:0 S I=$O(^XTV(8989.3,1,"INTRO",I)) Q:I'>0 S X=^(I,0) D
. I $D(WNM) S @WNM@(I)=X
. I '$D(WNM) W X,!
. Q
Q
;
DD(Y) Q $$FMTE^XLFDT(X,"1D")
;
PH(%T,%R) ;Check Prohibited time for R/S
N MSG S MSG=$$PROHIBIT(%T,%R)
I MSG S XUM(0)=$P(MSG,U,2) Q 1
D SET("!"),SET("! "_$$EZBLD^DIALOG(30810.62)_" "_$P(MSG,U,2))
Q 0
;
PROHIBIT(%T,%R) ;See if a prohibited time, (Time from $H, restrict range)
N XMSG,%B,%E
S %T=%T\60#60+(%T\3600*100),%B=$P(%R,"-",1),%E=$P(%R,"-",2)
S XMSG=$P($$FMTE^XLFDT(DT_"."_%B,"2P")," ",2,3)_" "_$$EZBLD^DIALOG(30810.61)_" "_$P($$FMTE^XLFDT(DT_"."_%E,"2P")," ",2,3)
I $S(%E'<%B:%T'>%E&(%T'<%B),1:%T>%B!(%T<%E)) Q "1^"_XMSG ;No
Q "0^"_XMSG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUS1A 3572 printed Dec 13, 2024@02:11:53 Page 2
XUS1A ;SF-ISC/STAFF - SIGNON overflow from XUS1 ;12/02/14 13:26
+1 ;;8.0;KERNEL;**153,149,183,258,265,638**;Jul 10, 1995;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
USER() ;
+1 NEW %B,%E,%T,I1,X1,X2
+2 SET XUTEXT=0
SET DUZ(2)=$GET(DUZ(2),0)
+3 FOR I=0:0
SET I=$ORDER(^XTV(8989.3,1,"POST",I))
if I'>0
QUIT
DO SET("!"_$GET(^(I,0)))
+4 DO SET("!")
DO XOPT
+5 SET %H=$PIECE($HOROLOG,",",2)
+6 DO SET("!Good "_$SELECT(%H<43200:"morning ",%H<61200:"afternoon ",1:"evening ")_$SELECT($PIECE(XUSER(1),U,4)]"":$PIECE(XUSER(1),U,4),1:$PIECE(XUSER(0),U,1)))
+7 SET I1=$GET(^VA(200,DUZ,1.1))
SET X=(+I1_"0000")
+8 IF X
DO SET("! You last signed on "_$SELECT(X\1=DT:"today",X\1+1=DT:"yesterday",1:$$FMTE^XLFDT(X,"1D"))_" at "_$EXTRACT(X,9,10)_":"_$EXTRACT(X,11,12))
+9 IF $PIECE(I1,"^",2)
SET I=$PIECE(I1,"^",2)
DO SET("!There "_$SELECT(I>1:"were ",1:"was ")_I_" unsuccessful attempt"_$SELECT(I>1:"s",1:"")_" since you last signed on.")
+10 ;Time frame
IF $PIECE(XUSER(0),U,12)
IF $$PH(%H,$PIECE(XUSER(0),U,12))
QUIT 17
+11 IF +$PIECE(XOPT,U,15)
SET %=$PIECE(XOPT,U,15)-($HOROLOG-XUSER(1))
IF %<6
IF %>0
DO SET("! Your Verify code will expire in "_%_" days")
+12 ;Report new Mail
+13 NEW XUXM
SET %=$$NU^XMGAPI4(1,1,"XUXM")
IF $GET(XUXM)
FOR %=0:0
SET %=$ORDER(XUXM(%))
if %'>0
QUIT
DO SET("!"_XUXM(%))
+14 if $PIECE(XOPT,"^",5)
SET XUTT=1
SET DTIME=$PIECE(XOPT,U,10)
+15 ;Check Multiple Sign-on allowed, X1 signed on flag, X2 0=No,1=Yes,2=1IP
+16 SET X1=$PIECE($GET(^VA(200,DUZ,1.1)),U,3)
SET X2=$PIECE(XOPT,U,4)
+17 ;Multi Sign-on not allowed
IF 'X2
IF X1
QUIT 9
+18 ;Only from one IP
IF X2=2
Begin DoDot:1
+19 ;Can't tell IP,
SET %B=0
IF '$DATA(IO("IP"))
if X1
SET %B=9
QUIT
+20 SET X1=$$COUNT(DUZ,IO("IP"))
SET %B=$SELECT(X1<0:9,(X1+1)>$PIECE(XOPT,U,19):9,1:0)
End DoDot:1
if %B>0
QUIT %B
USX SET $PIECE(^VA(200,DUZ,1.1),U,3)=1
+1 ;Call XQOR to handle SIGN-ON protocall.
+2 ;Protect ourself.
NEW XUSER,XUSQUIT
+3 SET DIC="^DIC(19,"
SET X="XU USER SIGN-ON"
SET XUSQUIT=0
+4 DO EN^XQOR
+5 KILL X,DIC
+6 ;If protocol set XUSQUIT will stop sign-on.
QUIT XUSQUIT
+7 ;
SET(V) ;Set into XUTEXT(XUTEXT), Called from XU USER SIGN-ON protocol.
+1 SET XUTEXT=$GET(XUTEXT)+1
SET XUTEXT(XUTEXT)=V
+2 QUIT
+3 ;
DUZ ;setup duz, also see XUS5
+1 ;Called from XUSRB, XUESSO1
+2 if '$DATA(XUSER(0))
SET XUSER(0)=^VA(200,DUZ,0)
if $DATA(XOPT)[0
DO XOPT
+3 SET DUZ(0)=$PIECE(XUSER(0),U,4)
SET DUZ(1)=""
SET DUZ("AUTO")=$PIECE(XOPT,"^",6)
+4 SET DUZ(2)=$SELECT($GET(DUZ(2))>0:DUZ(2),1:+$PIECE(XOPT,U,17))
+5 SET X=$PIECE($GET(^DIC(4,DUZ(2),99)),U,5)
SET DUZ("AG")=$SELECT(X]"":X,1:$PIECE(^XTV(8989.3,1,0),U,8))
+6 SET DUZ("BUF")=($PIECE(XOPT,U,9)="Y")
SET DUZ("LANG")=$PIECE(XOPT,U,7)
+7 QUIT
XOPT ;Build the XOPT string
+1 NEW X,I
+2 if '$DATA(XOPT)
SET XOPT=$GET(^XTV(8989.3,1,"XUS"))
+3 SET X=$GET(^VA(200,DUZ,200))
+4 FOR I=4:1:7,9,10,19
IF $PIECE(X,U,I)]""
SET $PIECE(XOPT,"^",I)=$PIECE(X,U,I)
+5 QUIT
+6 ;
COUNT(IEN,IP) ;Count sign-on log active connect from this IP
+1 NEW CNT,IX,IP6
+2 ;p638 use IPv6 xref
SET CNT=""
SET IX=0
SET IP6=$$FORCEIP6^XLFIPV(IP)
+3 ;First sign-on
IF '$DATA(^XUSEC(0,"AS5",IEN))
QUIT 0
+4 ;Diff IP
IF $ORDER(^XUSEC(0,"AS5",IEN,""))'=IP6
QUIT -1
+5 ;Diff IP
IF $ORDER(^XUSEC(0,"AS5",IEN,""),-1)'=IP6
QUIT -1
+6 FOR
SET IX=$ORDER(^XUSEC(0,"AS5",IEN,IP6,IX))
if 'IX
QUIT
SET CNT=CNT+1
+7 ;Return Count
QUIT CNT
+8 ;
INTRO(WNM) ;
+1 if '$DATA(^XTV(8989.3,1,"INTRO",0))
QUIT
+2 FOR I=0:0
SET I=$ORDER(^XTV(8989.3,1,"INTRO",I))
if I'>0
QUIT
SET X=^(I,0)
Begin DoDot:1
+3 IF $DATA(WNM)
SET @WNM@(I)=X
+4 IF '$DATA(WNM)
WRITE X,!
+5 QUIT
End DoDot:1
+6 QUIT
+7 ;
DD(Y) QUIT $$FMTE^XLFDT(X,"1D")
+1 ;
PH(%T,%R) ;Check Prohibited time for R/S
+1 NEW MSG
SET MSG=$$PROHIBIT(%T,%R)
+2 IF MSG
SET XUM(0)=$PIECE(MSG,U,2)
QUIT 1
+3 DO SET("!")
DO SET("! "_$$EZBLD^DIALOG(30810.62)_" "_$PIECE(MSG,U,2))
+4 QUIT 0
+5 ;
PROHIBIT(%T,%R) ;See if a prohibited time, (Time from $H, restrict range)
+1 NEW XMSG,%B,%E
+2 SET %T=%T\60#60+(%T\3600*100)
SET %B=$PIECE(%R,"-",1)
SET %E=$PIECE(%R,"-",2)
+3 SET XMSG=$PIECE($$FMTE^XLFDT(DT_"."_%B,"2P")," ",2,3)_" "_$$EZBLD^DIALOG(30810.61)_" "_$PIECE($$FMTE^XLFDT(DT_"."_%E,"2P")," ",2,3)
+4 ;No
IF $SELECT(%E'<%B:%T'>%E&(%T'<%B),1:%T>%B!(%T<%E))
QUIT "1^"_XMSG
+5 QUIT "0^"_XMSG
