XUS4.m

XUS4 ;SEA/FDS - ACCESS CODE GENERATOR ;2/1/2012  08:45

 ;;8.0;KERNEL;**180,574**;Jul 10, 1995;Build 8

 ;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

XUS4      ;SEA/FDS - ACCESS CODE GENERATOR ;2/1/2012  08:45

 +1       ;;8.0;KERNEL;**180,574**;Jul 10, 1995;Build 8

 +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