XUSESIG ;SF/RWF - ROUTINE TO ENTER OR CHANGE ELECTRONIC SIGNATURE CODE ; 09 Mar 2017 10:17 AM
;;8.0;KERNEL;**14,55,437,679**;Jul 10, 1995;Build 27
;
; ^XUSEC read supported by ICR #10076.
;
A ;Called by others from the top. See DBIC #936
I $D(DUZ)[0 W "NO ACTION CAN BE TAKEN ON YOUR REQUEST " Q
S DA=DUZ
A2 N DIE,DR,X1,K
S:$D(^VA(200,DA,0))[0 DA=0
I DA'>0 W !,"You don't have an entry in the NEW PERSON file, See your site manager" G OUT
W !,"This option is designed to permit you to enter or change your Initials,",!
N XUSGBLK S XUSGBLK=0
I $$GET^XPAR("ALL","XU SIG BLOCK DISABLE") S XUSGBLK=1
I 'XUSGBLK W "Signature Block Information, "
W "Office Phone number, and Voice and Digital Pagers "
I 'XUSGBLK W !
W "numbers."
W !,"In addition, you are permitted to enter a new Electronic Signature Code"
W !,"or to change an existing code.",!!
S DIE="^VA(200,",DR="1;.132;.137;.138"
I 'XUSGBLK S DR="1;20.2;20.3;.132;.137;.138"
D ^DIE
I $P($G(^VA(200,DA,20)),U,2)="" W !,"You must have a SIGNATURE BLOCK PRINTED NAME before you can have",!,"an ELECTRONIC SIGNATURE CODE." G OUT1
S X1=$P($G(^VA(200,DA,20)),"^",4) I X1]"" S K=0 D S2 G:X1="" OUT1
S X1=$$NEW() W !,$S(X1:"DONE",1:" OPTION ABORTED."_$C(7))
G OUT1
;
NEW() ;Enter a NEW E-Sig code, return 0 for fail, 1 if done, 2 skip.
N K,X,X1 S K=0
W !!,"Your typing will not show."
N2 W !,"ENTER NEW SIGNATURE CODE: " D R Q:X=""!(X="^") 2
I X'?.UNP!($L(X)>20)!($L(X)<6) W *7,!,"Signature code must be 6 to 20 characters in length",!," With no control or lowercase characters.",! G N2
S X1=X W !,"RE-ENTER SIGNATURE CODE FOR VERIFICATION: " D R G:X=""!(X="^") N5
I X'=X1 W " CODE NOT VERIFIED, TRY AGAIN.",*7,! S K=K+1 G N5:K>3 G N2
D HASH^XUSHSHP
I X=$P(^VA(200,DA,20),U,4) W *7,!,"You can't use the same one.",! G N2
S $P(^VA(200,DA,20),"^",4)=X
F XUS=0:0 S XUS=$O(^DD(200,20.4,1,XUS)) Q:XUS'>0 X ^(XUS,1)
N4 Q 1 ;OK
N5 Q 0 ;FAIL
;
R X ^%ZOSF("EOFF") R X:60 X ^%ZOSF("EON") S:'$T X="^" Q
;
OUT W !," OPTION ABORTED.",*7
OUT1 K %,D,D0,DA,DIC,DIE,DQ,DR,X,X1,A,K,I,Z,XUSGBLK Q
;
SIG ;Call with DUZ; Return X1="" if fail else hashed ESC.
N X2,K
S X2=$G(^VA(200,+$G(DUZ),20)),X1=$P(X2,U,4) I X1="" W !,"No Electronic Signature code to check." Q
S K=0 D S2 Q:X1=""
Q ;Following code was to force code change
N LIFE S LIFE=$$KSP^XUPARAM("LIFETIME")
S X2=+X2 I X2>0,(X2+LIFE)'>(+$H) D I X1="" W !,*7,"Verification with held until new code entered.",!
. W !!,"Your Electronic Signature Code has expired, you need to create a new one."
. N DA S DA=DUZ S:$$NEW()'=1 X1=""
. Q
Q
;
S2 W !!,"Enter your Current Signature Code: " D R G:X=""!(X="^") S9
I X?1.2"?" W !,"Enter your current Electronic Signature Code so it can be verified.",! G S2
S K=K+1 D HASH^XUSHSHP I X1'=X W " ??",*7 S X="" G S2:K<3,S9
W " SIGNATURE VERIFIED"
S9 S:X=""!(X="^") X1=""
Q
TEXT ;;
CLEAR ;Clear (delete) a users ESC to allow entering a new one.
S DIC=200,DIC(0)="AEMQ" D ^DIC G OUT:Y'>0 S DA=+Y,DIR(0)="Y"
W !,"Clear SIGNATURE CODE from user ",$P(Y,U,2) D ^DIR G OUT1:Y'=1
S DIE=DIC,DR="20.4///@" D ^DIE G OUT1
Q
;;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSESIG 3172 printed Dec 13, 2024@02:12:26 Page 2
XUSESIG ;SF/RWF - ROUTINE TO ENTER OR CHANGE ELECTRONIC SIGNATURE CODE ; 09 Mar 2017 10:17 AM
+1 ;;8.0;KERNEL;**14,55,437,679**;Jul 10, 1995;Build 27
+2 ;
+3 ; ^XUSEC read supported by ICR #10076.
+4 ;
A ;Called by others from the top. See DBIC #936
+1 IF $DATA(DUZ)[0
WRITE "NO ACTION CAN BE TAKEN ON YOUR REQUEST "
QUIT
+2 SET DA=DUZ
A2 NEW DIE,DR,X1,K
+1 if $DATA(^VA(200,DA,0))[0
SET DA=0
+2 IF DA'>0
WRITE !,"You don't have an entry in the NEW PERSON file, See your site manager"
GOTO OUT
+3 WRITE !,"This option is designed to permit you to enter or change your Initials,",!
+4 NEW XUSGBLK
SET XUSGBLK=0
+5 IF $$GET^XPAR("ALL","XU SIG BLOCK DISABLE")
SET XUSGBLK=1
+6 IF 'XUSGBLK
WRITE "Signature Block Information, "
+7 WRITE "Office Phone number, and Voice and Digital Pagers "
+8 IF 'XUSGBLK
WRITE !
+9 WRITE "numbers."
+10 WRITE !,"In addition, you are permitted to enter a new Electronic Signature Code"
+11 WRITE !,"or to change an existing code.",!!
+12 SET DIE="^VA(200,"
SET DR="1;.132;.137;.138"
+13 IF 'XUSGBLK
SET DR="1;20.2;20.3;.132;.137;.138"
+14 DO ^DIE
+15 IF $PIECE($GET(^VA(200,DA,20)),U,2)=""
WRITE !,"You must have a SIGNATURE BLOCK PRINTED NAME before you can have",!,"an ELECTRONIC SIGNATURE CODE."
GOTO OUT1
+16 SET X1=$PIECE($GET(^VA(200,DA,20)),"^",4)
IF X1]""
SET K=0
DO S2
if X1=""
GOTO OUT1
+17 SET X1=$$NEW()
WRITE !,$SELECT(X1:"DONE",1:" OPTION ABORTED."_$CHAR(7))
+18 GOTO OUT1
+19 ;
NEW() ;Enter a NEW E-Sig code, return 0 for fail, 1 if done, 2 skip.
+1 NEW K,X,X1
SET K=0
+2 WRITE !!,"Your typing will not show."
N2 WRITE !,"ENTER NEW SIGNATURE CODE: "
DO R
if X=""!(X="^")
QUIT 2
+1 IF X'?.UNP!($LENGTH(X)>20)!($LENGTH(X)<6)
WRITE *7,!,"Signature code must be 6 to 20 characters in length",!," With no control or lowercase characters.",!
GOTO N2
+2 SET X1=X
WRITE !,"RE-ENTER SIGNATURE CODE FOR VERIFICATION: "
DO R
if X=""!(X="^")
GOTO N5
+3 IF X'=X1
WRITE " CODE NOT VERIFIED, TRY AGAIN.",*7,!
SET K=K+1
if K>3
GOTO N5
GOTO N2
+4 DO HASH^XUSHSHP
+5 IF X=$PIECE(^VA(200,DA,20),U,4)
WRITE *7,!,"You can't use the same one.",!
GOTO N2
+6 SET $PIECE(^VA(200,DA,20),"^",4)=X
+7 FOR XUS=0:0
SET XUS=$ORDER(^DD(200,20.4,1,XUS))
if XUS'>0
QUIT
XECUTE ^(XUS,1)
N4 ;OK
QUIT 1
N5 ;FAIL
QUIT 0
+1 ;
R XECUTE ^%ZOSF("EOFF")
READ X:60
XECUTE ^%ZOSF("EON")
if '$TEST
SET X="^"
QUIT
+1 ;
OUT WRITE !," OPTION ABORTED.",*7
OUT1 KILL %,D,D0,DA,DIC,DIE,DQ,DR,X,X1,A,K,I,Z,XUSGBLK
QUIT
+1 ;
SIG ;Call with DUZ; Return X1="" if fail else hashed ESC.
+1 NEW X2,K
+2 SET X2=$GET(^VA(200,+$GET(DUZ),20))
SET X1=$PIECE(X2,U,4)
IF X1=""
WRITE !,"No Electronic Signature code to check."
QUIT
+3 SET K=0
DO S2
if X1=""
QUIT
+4 ;Following code was to force code change
QUIT
+5 NEW LIFE
SET LIFE=$$KSP^XUPARAM("LIFETIME")
+6 SET X2=+X2
IF X2>0
IF (X2+LIFE)'>(+$HOROLOG)
Begin DoDot:1
+7 WRITE !!,"Your Electronic Signature Code has expired, you need to create a new one."
+8 NEW DA
SET DA=DUZ
if $$NEW()'=1
SET X1=""
+9 QUIT
End DoDot:1
IF X1=""
WRITE !,*7,"Verification with held until new code entered.",!
+10 QUIT
+11 ;
S2 WRITE !!,"Enter your Current Signature Code: "
DO R
if X=""!(X="^")
GOTO S9
+1 IF X?1.2"?"
WRITE !,"Enter your current Electronic Signature Code so it can be verified.",!
GOTO S2
+2 SET K=K+1
DO HASH^XUSHSHP
IF X1'=X
WRITE " ??",*7
SET X=""
if K<3
GOTO S2
GOTO S9
+3 WRITE " SIGNATURE VERIFIED"
S9 if X=""!(X="^")
SET X1=""
+1 QUIT
TEXT ;;
CLEAR ;Clear (delete) a users ESC to allow entering a new one.
+1 SET DIC=200
SET DIC(0)="AEMQ"
DO ^DIC
if Y'>0
GOTO OUT
SET DA=+Y
SET DIR(0)="Y"
+2 WRITE !,"Clear SIGNATURE CODE from user ",$PIECE(Y,U,2)
DO ^DIR
if Y'=1
GOTO OUT1
+3 SET DIE=DIC
SET DR="20.4///@"
DO ^DIE
GOTO OUT1
+4 QUIT
+5 ;;
