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

XUS2.m

Go to the documentation of this file.
  1. XUS2 ;SF/RWF - TO CHECK OR RETURN USER ATTRIBUTES ;2/1/2012
  1. ;;8.0;KERNEL;**59,180,313,419,437,574**;Jul 10, 1995;Build 5
  1. ;Per VHA Directive 2004-038, this routine should not be modified
  1. Q
  1. ;
  1. ACCED ; ACCESS CODE EDIT from DD
  1. I "Nn"[$E(X,1) S X="" Q
  1. I "Yy"'[$E(X,1) K X Q
  1. N DIR,DIR0,XUAUTO,XUK
  1. S XUAUTO=($P($G(^XTV(8989.3,1,3)),U,1)="y"),XUH=""
  1. AC1 D CLR,AAUTO:XUAUTO,AASK:'XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),AC1:'XUK D CLR,AST(XUH)
  1. G OUT
  1. ;
  1. AASK ;Ask for Access code
  1. N X,XUU,XUEX X ^%ZOSF("EOFF")
  1. S XUEX=0
  1. F D AASK1 Q:XUEX!($D(DIRUT))
  1. Q
  1. ;
  1. AASK1 ;
  1. W "Enter a new ACCESS CODE <Hidden>: " D GET Q:$D(DIRUT)
  1. I X="@" D DEL D:Y'=1 DIRUT S XUH="",XUEX=1 Q
  1. I X[$C(34)!(X[";")!(X["^")!(X[":")!(X'?.UNP)!($L(X)>20)!($L(X)<6)!(X="MAIL-BOX") D CLR W $C(7),$$AVHLPTXT(1) D AHELP Q
  1. I 'XUAUTO,((X?6.20A)!(X?6.20N)) D CLR W $C(7),$$AVHLPTXT(1),! Q
  1. S XUU=X,X=$$EN^XUSHSH(X),XUH=X,XMB(1)=$O(^VA(200,"A",XUH,0)) I XMB(1),XMB(1)'=DA S XMB="XUS ACCESS CODE VIOLATION",XMB(1)=$P(^VA(200,XMB(1),0),"^"),XMDUN="Security" D ^XMB
  1. I $D(^VA(200,"AOLD",XUH))!$D(^VA(200,"A",XUH)) D CLR W $C(7),"This has been used previously as an ACCESS CODE.",! Q
  1. S XUEX=1 ;Now we can quit
  1. Q
  1. ;
  1. REASK S XUK=1 Q:XUH="" D CLR X ^%ZOSF("EOFF")
  1. F XUK=3:-1:1 W "Please re-type the new code to show that I have it right: " D GET G:$D(DIRUT) DIRUT D ^XUSHSH Q:(XUH=X) D CLR W "This doesn't match. Try again!",!,$C(7)
  1. S:XUH'=X XUK=0
  1. Q
  1. ;
  1. AST(XUH) ;Change ACCESS CODE and index.
  1. W "OK, Access code has been changed!"
  1. N FDA,IEN,ERR
  1. S IEN=DA_","
  1. S FDA(200,IEN,2)=XUH D FILE^DIE("","FDA","ERR")
  1. W !,"The VERIFY CODE has been deleted as a security measure.",!,"You will need to enter a new VERIFY code so the user can sign-on.",$C(7)
  1. D VST("",1)
  1. I $D(^XMB(3.7,DA,0))[0 S Y=DA D NEW^XM ;Make sure has a Mailbox
  1. Q
  1. ;
  1. GET ;Get the user input and convert case.
  1. S X=$$ACCEPT^XUS I (X["^")!('$L(X)) D DIRUT
  1. S X=$$UP^XLFSTR(X)
  1. Q
  1. ;
  1. DIRUT S DIRUT=1
  1. Q
  1. ;
  1. CLR ;New line or Clear screenman area
  1. I '$D(DDS) W ! Q
  1. N DX,DY
  1. D CLRMSG^DDS S DX=0,DY=DDSHBX+1 X IOXY
  1. Q
  1. ;
  1. NEWCODE D REASK I XUK W !,"OK, remember this code for next time!"
  1. G OUT
  1. ;
  1. CVC ;From XUS1
  1. N DA,X
  1. S DA=DUZ,X="Y"
  1. W !,"You must change your VERIFY CODE at this time."
  1. ;Fall into next code
  1. VERED ; VERIFY CODE EDIT From DD
  1. N DIR,DIR0,XUAUTO,XUSVCMIN,XUSVCACCT S XUSVCACCT=$$SVCACCT(DA),XUSVCMIN=$S(+XUSVCACCT:12,1:8)
  1. I "Nn"[$E(X,1) S X="" Q
  1. I "Yy"'[$E(X,1) K X Q
  1. S XUH="",XUAUTO=($P($G(^XTV(8989.3,1,3)),U,3)="y") S:DUZ=DA XUAUTO="n" ;Auto only for admin
  1. VC1 D CLR,VASK:'XUAUTO,VAUTO:XUAUTO G OUT:$D(DIRUT) D REASK G OUT:$D(DIRUT),VC1:'XUK D CLR,VST(XUH,1)
  1. D CALL^XUSERP(DA,2)
  1. G OUT
  1. ;
  1. VASK ;Ask for Verify Code
  1. N X,XUU X ^%ZOSF("EOFF") G:'$$CHKCUR() DIRUT D CLR
  1. VASK1 W "Enter a new VERIFY CODE: " D GET Q:$D(DIRUT)
  1. I '$D(XUNC),(X="@") D DEL G:Y'=1 DIRUT S XUH="" Q
  1. D CLR S XUU=X,X=$$EN^XUSHSH(X),XUH=X,Y=$$VCHK(XUU,XUH) I +Y W $C(7),$P(Y,U,2,9),! D:+Y=1 VHELP G VASK1
  1. Q
  1. ;
  1. VCHK(S,EC) ;Call with String and Encrypted versions
  1. ;Updated per VHA directive 6210 Strong Passwords
  1. N PUNC,NA,XUPAT S PUNC="~`!@#$%&*()_-+=|\{}[]'<>,.?/"
  1. S NA("FILE")=200,NA("FIELD")=.01,NA("IENS")=DA_",",NA=$$HLNAME^XLFNAME(.NA),XUPAT=XUSVCMIN_".20"
  1. I ($L(S)<XUSVCMIN)!($L(S)>20)!(S'?.UNP)!(S[";")!(S["^")!(S[":") Q "1^"_$$AVHLPTXT
  1. I (S?@(XUPAT_"A"))!(S?@(XUPAT_"N"))!(S?@(XUPAT_"P"))!(S?@(XUPAT_"AN"))!(S?@(XUPAT_"AP"))!(S?@(XUPAT_"NP")) Q "2^VERIFY CODE must be a mix of alpha and numerics and punctuation."
  1. I $D(^VA(200,DA,.1)),EC=$P(^(.1),U,2) Q "3^This code is the same as the current one."
  1. I $D(^VA(200,DA,"VOLD",EC)) Q "4^This has been used previously as the VERIFY CODE."
  1. I EC=$P(^VA(200,DA,0),U,3) Q "5^VERIFY CODE must be different than the ACCESS CODE."
  1. I S[$P(NA,"^")!(S[$P(NA,"^",2)) Q "6^Name cannot be part of code."
  1. Q 0
  1. ;
  1. VST(XUH,%) ;
  1. W:$L(XUH)&% !,"OK, Verify code has been changed!"
  1. N FDA,IEN,ERR S IEN=DA_","
  1. S:XUH="" XUH="@" ;11.2 get triggerd
  1. S FDA(200,IEN,11)=XUH D FILE^DIE("","FDA","ERR")
  1. I $D(ERR) D ^%ZTER
  1. I (DUZ'=(+IEN))&$$SVCACCT(+IEN)&(XUH'="@") D ;override trigger of 11.2 by 11 for svc accts
  1. .K FDA,ERR S FDA(200,IEN,11.2)=$H D FILE^DIE("","FDA","ERR")
  1. .I $D(ERR) D ^%ZTER
  1. S:DA=DUZ DUZ("NEWCODE")=XUH Q
  1. ;
  1. DEL ;
  1. X ^%ZOSF("EON") W $C(7) S DIR(0)="Y",DIR("A")="Sure you want to delete" D ^DIR I Y'=1 W:$X>55 !?9 W $C(7)," <Nothing Deleted>"
  1. Q
  1. ;
  1. AAUTO ;Auto-get Access codes
  1. N XUK,Y
  1. X ^%ZOSF("EON") F XUK=1:1:3 D AGEN Q:(Y=1)!($D(DIRUT))
  1. Q
  1. ;
  1. AGEN ;Generate a ACCESS code
  1. S XUU=$$AC^XUS4 S (X,XUH)=$$EN^XUSHSH(XUU) I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AGEN
  1. D CLR W "The new ACCESS CODE is: ",XUU," This is ",XUK," of 3 tries."
  1. D YN
  1. Q
  1. ;
  1. AHELP S XUU=$$AC^XUS4 S X=$$EN^XUSHSH(XUU) I $D(^VA(200,"A",X))!$D(^VA(200,"AOLD",X)) G AHELP
  1. W !,"Here is an example of an acceptable Access Code: ",XUU,!
  1. Q
  1. ;
  1. VHELP S XUU=$$VC^XUS4 S X=$$EN^XUSHSH(XUU) I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VHELP
  1. W !,"Here is an example of an acceptable Verify Code: ",XUU,!
  1. Q
  1. ;
  1. VAUTO ;Auto-get Access codes
  1. N XUK
  1. X ^%ZOSF("EON") F XUK=1:1:3 D VGEN Q:(Y=1)!($D(DIRUT))
  1. Q
  1. ;
  1. VGEN ;Generate a VERIFY code
  1. S XUU=$$VC^XUS4 S (X,XUH)=$$EN^XUSHSH(XUU) I ($P($G(^VA(200,DA,0)),U,3)=X)!$D(^VA(200,DA,"VOLD",X)) G VGEN
  1. D CLR W "The new VERIFY CODE is: ",XUU," This is ",XUK," of 3 tries."
  1. D YN
  1. Q
  1. YN ;Ask if want to keep
  1. N DIR
  1. S Y=1,DIR(0)="YA",DIR("A")=" Do you want to keep this one? ",DIR("B")="YES",DIR("?",1)="If you don't like this code, we can auto-generate another.",DIR("?")="Remember you only get 3 tries!"
  1. S:XUK=3 DIR("A")="This is your final choice. "_DIR("A")
  1. D ^DIR Q:(Y=1)!$D(DIRUT) I XUK=2 W !,"O.K. You'll have to keep the next one!",! H 2
  1. I (XUK=3)&(Y'=1) W !,"Lets stop and you can try later." H 3 D DIRUT
  1. D CLR
  1. Q
  1. ;
  1. OUT ;
  1. K DUOUT S:$D(DIRUT) DUOUT=1
  1. X ^%ZOSF("EON") W !
  1. K DIR,DIRUT,XUKO,XUAUTO,XUU,XUH,XUK,XUI S X=""
  1. Q
  1. ;
  1. CHKCUR() ;Check user knows current code, Return 1 if OK to continue
  1. Q:DA'=DUZ 1 ;Only ask user
  1. Q:$P($G(^VA(200,DA,.1)),U,2)="" 1 ;Must have an old one
  1. S XUK=0 D CLR
  1. CHK1 W "Please enter your CURRENT verify code: " D GET Q:$D(DIRUT) 0
  1. I $P(^VA(200,DA,.1),U,2)=$$EN^XUSHSH(X) Q 1
  1. D CLR W "Sorry that is not correct!",!
  1. S XUK=XUK+1 G:XUK<3 CHK1
  1. Q 0
  1. ;
  1. BRCVC(XV1,XV2) ;Broker change VC, return 0 if good, '1^msg' if bad.
  1. N XUU,XUH,XUSVCMIN S XUSVCMIN=8
  1. Q:$G(DUZ)'>0 "1^Bad DUZ" S DA=DUZ,XUH=$$EN^XUSHSH(XV2)
  1. I $P($G(^VA(200,DUZ,.1)),"^",2)'=$$EN^XUSHSH(XV1) Q "1^Sorry that isn't the correct current code"
  1. S Y=$$VCHK(XV2,XUH) Q:Y Y
  1. D VST(XUH,0),CALL^XUSERP(DA,2)
  1. Q 0
  1. ;
  1. SVCACCT(XUSDUZ) ;return 1^CONNECTOR PROXY if CP svc acct; 0 if not svc acct
  1. Q:$$ISUSERCP^XUSAP1(XUSDUZ) "1^CONNECTOR PROXY"
  1. Q 0
  1. ;
  1. AVHLPTXT(%) ;
  1. Q "Enter "_$S($G(%):"6-20",+$G(XUSVCMIN):XUSVCMIN_"-20",1:"8-20")_" characters mixed alphanumeric and punctuation (except '^', ';', ':')"
  1. ;
  1. ;Left over code, Don't think it is called anymore.
  1. G XUS2^XUVERIFY ;All check or return user attributes moved to XUVERIFY
  1. USER G USER^XUVERIFY
  1. EDIT G EDIT^XUVERIFY