- 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 Jan 18, 2025@03:13:37 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 ;;