- XUS4 ;SEA/FDS - ACCESS CODE GENERATOR ;2/1/2012 08:45
- ;;8.0;KERNEL;**180,574**;Jul 10, 1995;Build 5
- ;Per VHA Directive 2004-038, this routine should not be modified
- S G 2 ;Change to select auto generate style.
- ;
- 1 S XUG=$R(4)+5,XUL=0,XUA="" F XUW=0:0 S XUD=XUG-XUL Q:XUD=0 S:XUD=5 XUD=$R(2)+2 S:XUD>5 XUD=$R(3)+2 D A
- S %=$R(1000),XUW=$R(2),XUU=$S(XUW=0:XUA_%,XUW=1:%_XUA) K XUA,%,XUX3,XUW,XUG,XUL,XUD Q
- A S XUL=XUL+XUD S:XUD=2 XUC="TC1",XUV="TV1" S:XUD=4 XUC="TC2",XUV="TV2" I XUD=3 S XUW=$R(2) S:XUW=0 XUC="TC1",XUV="TV2" S:XUW=1 XUC="TC2",XUV="TV1"
- S XUA=XUA_$P($T(@XUC),";",($R($P($T(@XUC),";",3))+4))_$P($T(@XUV),";",($R($P($T(@XUV),";",3))+4)) Q
- TC1 ;;16;B;D;F;L;H;J;K;M;N;P;R;S;T;V;W;Z
- TC2 ;;26;CH;PH;SH;TH;WH;BL;CL;FL;GL;KL;PL;BR;CR;DR;FR;GR;KR;PR;TR;SC;SK;SM;SN;SP;ST;SW
- TV1 ;;6;A;E;I;O;U;Y
- TV2 ;;51;EA;OA;AE;EE;IE;OE;UE;AF;EF;IF;OF;UF;AH;EH;IH;OH;UH;AI;EI;OI;UI;AL;EL;IL;OL;UL;AM;EM;IM;OM;UM;AN;EN;IN;ON;UN;OO;AR;ER;IR;OR;UR;AS;ES;IS;OS;US;OU;AY;EY;OY
- ;
- AC() ;Do 2
- N XUU,% D 2 Q XUU
- 2 ;Generate 3.4 alpha 3.4 numeric, random order
- S XUU="",%=$P($H,",",2)#10
- D @$S(%>6:"A2(1),N2(0)",1:"N2(1),A2(0)") K %
- Q
- VC() ;Generate a 8 char alpha, numeric, punctuation
- ; INPUT VAR XUSVCMIN: if defined and =12, generated code will be length 12
- N XUU,%,%1
- S XUU="",%1=$P($H,",",2)#12
- D @$S(%1<3:"P2,A2(1),N2(0)",%1<6:"A2(1),P2,N2(0)",%1<9:"A2(0),P2,N2(1)",1:"N2(1),A2(0),P2")
- D:($G(XUSVCMIN)=12) A2(1) ;make length 12 for svc accts
- Q XUU
- ;
- A2(F) S %=$R(100000000)+100000000,XUU=XUU_$C($E(%,2,3)#26+65)_$C($E(%,4,5)#26+65)_$C($E(%,6,7)#26+65)_$S(F:$C($E(%,8,9)#26+65),1:"") Q
- N2(F) S XUU=XUU_$E($R(100000)+100000,3,$S(F:6,1:5)) Q
- P2 S XUU=XUU_$S($G(XUSVCACCT)="1^CONNECTOR PROXY":$E("~`!@#$%*()_-+=|\{}[],.?/",$R(24)+1),1:$E("~`!@#$%&*()_-+=|\{}[]'<>,.?/",$R(28)+1)) Q ;no XML sp. chars for VL
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUS4 1840 printed Feb 18, 2025@23:38:24 Page 2
- XUS4 ;SEA/FDS - ACCESS CODE GENERATOR ;2/1/2012 08:45
- +1 ;;8.0;KERNEL;**180,574**;Jul 10, 1995;Build 5
- +2 ;Per VHA Directive 2004-038, this routine should not be modified
- S ;Change to select auto generate style.
- GOTO 2
- +1 ;
- 1 SET XUG=$RANDOM(4)+5
- SET XUL=0
- SET XUA=""
- FOR XUW=0:0
- SET XUD=XUG-XUL
- if XUD=0
- QUIT
- if XUD=5
- SET XUD=$RANDOM(2)+2
- if XUD>5
- SET XUD=$RANDOM(3)+2
- DO A
- +1 SET %=$RANDOM(1000)
- SET XUW=$RANDOM(2)
- SET XUU=$SELECT(XUW=0:XUA_%,XUW=1:%_XUA)
- KILL XUA,%,XUX3,XUW,XUG,XUL,XUD
- QUIT
- A SET XUL=XUL+XUD
- if XUD=2
- SET XUC="TC1"
- SET XUV="TV1"
- if XUD=4
- SET XUC="TC2"
- SET XUV="TV2"
- IF XUD=3
- SET XUW=$RANDOM(2)
- if XUW=0
- SET XUC="TC1"
- SET XUV="TV2"
- if XUW=1
- SET XUC="TC2"
- SET XUV="TV1"
- +1 SET XUA=XUA_$PIECE($TEXT(@XUC),";",($RANDOM($PIECE($TEXT(@XUC),";",3))+4))_$PIECE($TEXT(@XUV),";",($RANDOM($PIECE($TEXT(@XUV),";",3))+4))
- QUIT
- TC1 ;;16;B;D;F;L;H;J;K;M;N;P;R;S;T;V;W;Z
- TC2 ;;26;CH;PH;SH;TH;WH;BL;CL;FL;GL;KL;PL;BR;CR;DR;FR;GR;KR;PR;TR;SC;SK;SM;SN;SP;ST;SW
- TV1 ;;6;A;E;I;O;U;Y
- TV2 ;;51;EA;OA;AE;EE;IE;OE;UE;AF;EF;IF;OF;UF;AH;EH;IH;OH;UH;AI;EI;OI;UI;AL;EL;IL;OL;UL;AM;EM;IM;OM;UM;AN;EN;IN;ON;UN;OO;AR;ER;IR;OR;UR;AS;ES;IS;OS;US;OU;AY;EY;OY
- +1 ;
- AC() ;Do 2
- +1 NEW XUU,%
- DO 2
- QUIT XUU
- 2 ;Generate 3.4 alpha 3.4 numeric, random order
- +1 SET XUU=""
- SET %=$PIECE($HOROLOG,",",2)#10
- +2 DO @$SELECT(%>6:"A2(1),N2(0)",1:"N2(1),A2(0)")
- KILL %
- +3 QUIT
- VC() ;Generate a 8 char alpha, numeric, punctuation
- +1 ; INPUT VAR XUSVCMIN: if defined and =12, generated code will be length 12
- +2 NEW XUU,%,%1
- +3 SET XUU=""
- SET %1=$PIECE($HOROLOG,",",2)#12
- +4 DO @$SELECT(%1<3:"P2,A2(1),N2(0)",%1<6:"A2(1),P2,N2(0)",%1<9:"A2(0),P2,N2(1)",1:"N2(1),A2(0),P2")
- +5 ;make length 12 for svc accts
- if ($GET(XUSVCMIN)=12)
- DO A2(1)
- +6 QUIT XUU
- +7 ;
- A2(F) SET %=$RANDOM(100000000)+100000000
- SET XUU=XUU_$CHAR($EXTRACT(%,2,3)#26+65)_$CHAR($EXTRACT(%,4,5)#26+65)_$CHAR($EXTRACT(%,6,7)#26+65)_$SELECT(F:$CHAR($EXTRACT(%,8,9)#26+65),1:"")
- QUIT
- N2(F) SET XUU=XUU_$EXTRACT($RANDOM(100000)+100000,3,$SELECT(F:6,1:5))
- QUIT
- P2 ;no XML sp. chars for VL
- SET XUU=XUU_$SELECT($GET(XUSVCACCT)="1^CONNECTOR PROXY":$EXTRACT("~`!@#$%*()_-+=|\{}[],.?/",$RANDOM(24)+1),1:$EXTRACT("~`!@#$%&*()_-+=|\{}[]'<>,.?/",$RANDOM(28)+1))
- QUIT