- 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 Jan 18, 2025@03:13:04 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