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 Apr 09, 2024@21:11:50 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
