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

XUS1A.m

Go to the documentation of this file.
  1. 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
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. Q
  1. USER() ;
  1. N %B,%E,%T,I1,X1,X2
  1. S XUTEXT=0,DUZ(2)=$G(DUZ(2),0)
  1. F I=0:0 S I=$O(^XTV(8989.3,1,"POST",I)) Q:I'>0 D SET("!"_$G(^(I,0)))
  1. D SET("!"),XOPT
  1. S %H=$P($H,",",2)
  1. 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)))
  1. S I1=$G(^VA(200,DUZ,1.1)),X=(+I1_"0000")
  1. 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))
  1. 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.")
  1. I $P(XUSER(0),U,12),$$PH(%H,$P(XUSER(0),U,12)) Q 17 ;Time frame
  1. 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")
  1. ;Report new Mail
  1. N XUXM S %=$$NU^XMGAPI4(1,1,"XUXM") I $G(XUXM) F %=0:0 S %=$O(XUXM(%)) Q:%'>0 D SET("!"_XUXM(%))
  1. S:$P(XOPT,"^",5) XUTT=1 S DTIME=$P(XOPT,U,10)
  1. ;Check Multiple Sign-on allowed, X1 signed on flag, X2 0=No,1=Yes,2=1IP
  1. S X1=$P($G(^VA(200,DUZ,1.1)),U,3),X2=$P(XOPT,U,4)
  1. I 'X2,X1 Q 9 ;Multi Sign-on not allowed
  1. I X2=2 D Q:%B>0 %B ;Only from one IP
  1. . S %B=0 I '$D(IO("IP")) S:X1 %B=9 Q ;Can't tell IP,
  1. . S X1=$$COUNT(DUZ,IO("IP")),%B=$S(X1<0:9,(X1+1)>$P(XOPT,U,19):9,1:0)
  1. USX S $P(^VA(200,DUZ,1.1),U,3)=1
  1. ;Call XQOR to handle SIGN-ON protocall.
  1. N XUSER,XUSQUIT ;Protect ourself.
  1. S DIC="^DIC(19,",X="XU USER SIGN-ON",XUSQUIT=0
  1. D EN^XQOR
  1. K X,DIC
  1. Q XUSQUIT ;If protocol set XUSQUIT will stop sign-on.
  1. ;
  1. SET(V) ;Set into XUTEXT(XUTEXT), Called from XU USER SIGN-ON protocol.
  1. S XUTEXT=$G(XUTEXT)+1,XUTEXT(XUTEXT)=V
  1. Q
  1. ;
  1. DUZ ;setup duz, also see XUS5
  1. ;Called from XUSRB, XUESSO1
  1. S:'$D(XUSER(0)) XUSER(0)=^VA(200,DUZ,0) D:$D(XOPT)[0 XOPT
  1. S DUZ(0)=$P(XUSER(0),U,4),DUZ(1)="",DUZ("AUTO")=$P(XOPT,"^",6)
  1. S DUZ(2)=$S($G(DUZ(2))>0:DUZ(2),1:+$P(XOPT,U,17))
  1. 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))
  1. S DUZ("BUF")=($P(XOPT,U,9)="Y"),DUZ("LANG")=$P(XOPT,U,7)
  1. Q
  1. XOPT ;Build the XOPT string
  1. N X,I
  1. S:'$D(XOPT) XOPT=$G(^XTV(8989.3,1,"XUS"))
  1. S X=$G(^VA(200,DUZ,200))
  1. F I=4:1:7,9,10,19 I $P(X,U,I)]"" S $P(XOPT,"^",I)=$P(X,U,I)
  1. Q
  1. ;
  1. COUNT(IEN,IP) ;Count sign-on log active connect from this IP
  1. N CNT,IX,IP6
  1. S CNT="",IX=0,IP6=$$FORCEIP6^XLFIPV(IP) ;p638 use IPv6 xref
  1. I '$D(^XUSEC(0,"AS5",IEN)) Q 0 ;First sign-on
  1. I $O(^XUSEC(0,"AS5",IEN,""))'=IP6 Q -1 ;Diff IP
  1. I $O(^XUSEC(0,"AS5",IEN,""),-1)'=IP6 Q -1 ;Diff IP
  1. F S IX=$O(^XUSEC(0,"AS5",IEN,IP6,IX)) Q:'IX S CNT=CNT+1
  1. Q CNT ;Return Count
  1. ;
  1. INTRO(WNM) ;
  1. Q:'$D(^XTV(8989.3,1,"INTRO",0))
  1. F I=0:0 S I=$O(^XTV(8989.3,1,"INTRO",I)) Q:I'>0 S X=^(I,0) D
  1. . I $D(WNM) S @WNM@(I)=X
  1. . I '$D(WNM) W X,!
  1. . Q
  1. Q
  1. ;
  1. DD(Y) Q $$FMTE^XLFDT(X,"1D")
  1. ;
  1. PH(%T,%R) ;Check Prohibited time for R/S
  1. N MSG S MSG=$$PROHIBIT(%T,%R)
  1. I MSG S XUM(0)=$P(MSG,U,2) Q 1
  1. D SET("!"),SET("! "_$$EZBLD^DIALOG(30810.62)_" "_$P(MSG,U,2))
  1. Q 0
  1. ;
  1. PROHIBIT(%T,%R) ;See if a prohibited time, (Time from $H, restrict range)
  1. N XMSG,%B,%E
  1. S %T=%T\60#60+(%T\3600*100),%B=$P(%R,"-",1),%E=$P(%R,"-",2)
  1. S XMSG=$P($$FMTE^XLFDT(DT_"."_%B,"2P")," ",2,3)_" "_$$EZBLD^DIALOG(30810.61)_" "_$P($$FMTE^XLFDT(DT_"."_%E,"2P")," ",2,3)
  1. I $S(%E'<%B:%T'>%E&(%T'<%B),1:%T>%B!(%T<%E)) Q "1^"_XMSG ;No
  1. Q "0^"_XMSG