TIUASCU1 ; NA/AJB - ADDITIONAL SIGNER CLEANUP 2.0;11/02/23 11:17
;;1.0;TEXT INTEGRATION UTILITIES;**357**;Jun 20, 1997;Build 5
;
; Reference to $$GET1^DID supported by ICR #2052
; Reference to $$GET1^DIQ supported by ICR #2056
; Reference to $$DIV^XUSER supported by ICR #2533
; Reference to HOME^%ZIS supported by ICR #10086
; Reference to *^XGF supported by ICR #3173
; Reference to *^XLFDT supported by ICR #10103
; Reference to *^XLFSTR supported by ICR #10104
; Reference to ^%ZTLOAD supported by ICR #10063
; Reference to ^DIC supported by ICR #10006
; Reference to ^DIK supported by ICR #10013
; Reference to ^DIR supported by ICR #10026
; Reference to ^XMD supported by ICR #10070
; Reference to File ^DIC(49 supported by ICR #4330
; Reference to File ^DPT supported by ICR #10035
; Reference to File ^VA supported by ICR #10060
; Reference to EN^XUTMDEVQ supported by ICR #1519
; Reference to HASH^XUSHSHP supported by ICR #10045
; Reference to ^%ZOSF(*) supported by ICR #10096
; Reference to *^XGF supported by ICR #3173
;
Q
SETUP(SCR,DATE) ; ask user for type of search
LIST ;Date Range:DT^Additional Signer:200^Service/Section:49^^Division:4^Document Status:8925.6^DISUSER'D:DIS^^Terminated:TERM
N DIR,EXIT,I,J,LIST,SEL,VAL,X,Y
S DIR("A",1)="Select SEARCH CRITERIA:",DIR("A",2)="",EXIT=0
S (I,J)=0,LIST=$P($T(LIST),";",2),X=$O(DIR("A",""),-1)+1 F Y=1:1:$L(LIST,U) D
. I $P(LIST,U,Y)="" S I=0,X=X+1 Q
. S I=I+1,J=J+1 S DIR("A",X)=$$SETSTR(" "_J_" "_$P($P(LIST,U,Y),":"),$S('$D(DIR("A",X)):"",1:DIR("A",X)),$S(I=1:0,1:((I-1)*25)),$L($P(LIST,U,Y))+3)
. S LIST(J)=$P($P(LIST,U,Y),":",2)
S DIR("A",X+1)="",DIR("A")="Enter SELECTION: ",DIR("B")=1,DIR(0)="LAO^1:"_J S SEL=$$DIR(.DIR) Q:'SEL 0
F X=1:1:$L(SEL,",")-1 D Q:EXIT
. N DIC S Y=$P(SEL,",",X) I LIST(Y)="DT" D DATE(.DATE,.SCR) S:'SCR("Start")!('SCR("End")) EXIT=1 Q
. I LIST(Y)="TERM"!(LIST(Y)="DIS") S SCR($S(LIST(Y)="TERM":"Terminated",1:"DISUSER'd"))="1^YES" Q
. S DIC=LIST(Y),DIC("A")=$S(DIC=200:"Enter ADDITIONAL SIGNER: ",DIC=4:"Enter DIVISION: ",DIC=49:"Enter SERVICE/SECTION: ",DIC=8925.6:"Enter DOCUMENT STATUS: ")
. N VAL S VAL=$$DIC(.DIC) S:VAL=U EXIT=1 Q:EXIT S:+VAL SCR(LIST(Y))=VAL
Q $S(EXIT:0,1:1)
DATE(DATE,SCR) ;
S (SCR("Start"),SCR("End"))="" N X F X="Start","End" D Q:'SCR(X)
. N DIR S DIR(0)="DOA^"_DATE("Start")_":"_DATE("End"),DIR("?")="Enter a date from "_$$FMTE^XLFDT(DATE("Start"))_" to "_$$FMTE^XLFDT(DATE("End"))
. S DIR("?",1)="This date is the "_$S(X="Start":"earliest",1:"latest")_" date an outstanding additional signature is due.",DIR("?",2)=""
. S DIR("A")="Enter "_$S(X="Start":"STARTING",1:"ENDING")_" DATE: ",DIR("B")=$S(X="Start":$$FMTE^XLFDT(DATE("Start")),1:$$FMTE^XLFDT($$FMADD^XLFDT(DT,-30)))
. S SCR(X)=$$DIR(.DIR) I $E(SCR(X),6,7)="00" S SCR(X)=SCR(X)+$S(X="Start":1,1:101) S:X="End" SCR(X)=$$FMADD^XLFDT(SCR(X),-1)
. S $P(SCR(X),U,2)=$$FMTE^XLFDT(SCR(X)) S:+SCR(X)&(X="End") $P(SCR(X),U)=$P(SCR(X),U)+.24
I 'SCR("Start")!('SCR("End")) S (SCR("Start"),SCR("End"))=""
Q
DIC(DIC) ; basic lookup
N DIRUT,DTOUT,DUOUT,X,Y S DIC=$$GET1^DID(DIC,"","","GLOBAL NAME"),DIC(0)="AE" D ^DIC
Q $S(+Y>0:Y,X=U:U,+$G(DTOUT):U,Y'>0:0,1:Y)
DIR(DIR,PROMPT,DEFAULT,HELP,SCREEN) ; response reader
N DIROUT,DIRUT,DTOUT,DUOUT,X,Y S:'$D(DIR(0)) DIR(0)=$G(DIR) S:'$D(DIR("A"))&($G(PROMPT)'="") DIR("A")=PROMPT S:'$D(DIR("B"))&($G(DEFAULT)'="") DIR("B")=DEFAULT
S:'$D(DIR("S"))&($G(SCREEN)'="") DIR("S")=SCREEN S:'$D(DIR("?"))&($D(HELP)) DIR("?")=$S($G(HELP)'="":HELP,1:$G(HELP("?"))) M DIR=HELP D ^DIR
Q $S(X[U:U,+Y:Y,1:"")
MAIL(LOC) ;
N COL,DATA,X,XMDUN,XMDUZ,XMSUB,XMTEXT,XMY,XMZ S COL=24,XMTEXT($O(XMTEXT(""),-1)+1)="Task is complete. The completed report is available via the option.",XMTEXT($O(XMTEXT(""),-1)+1)=""
S DATA="User: ",DATA=$$SETSTR(DATA,"",COL-$L(DATA),$L(DATA))_$P(@LOC@("User"),U),XMTEXT($O(XMTEXT(""),-1)+1)=DATA
S DATA="Mode: ",DATA=$$SETSTR(DATA,"",COL-$L(DATA),$L(DATA))_@LOC@("Action"),XMTEXT($O(XMTEXT(""),-1)+1)=DATA
S DATA="Duration: ",DATA=$$SETSTR(DATA,"",COL-$L(DATA),$L(DATA))_@LOC@("Elapsed"),XMTEXT($O(XMTEXT(""),-1)+1)=DATA
S DATA="# Signatures: ",DATA=$$SETSTR(DATA,"",COL-$L(DATA),$L(DATA))_@LOC@("Total"),XMTEXT($O(XMTEXT(""),-1)+1)=DATA
S XMTEXT($O(XMTEXT(""),-1)+1)="",DATA="Search Criteria: ",DATA=$$SETSTR(DATA,"",COL-$L(DATA),$L(DATA)),XMTEXT($O(XMTEXT(""),-1)+1)=DATA,XMTEXT($O(XMTEXT(""),-1)+1)=""
S DATA="[Date Range] ",DATA=$$SETSTR(DATA,"",COL-$L(DATA),$L(DATA))_@LOC@("Start Date")_" to "_@LOC@("Stop Date"),XMTEXT($O(XMTEXT(""),-1)+1)=DATA
F X="DISUSER'd","Terminated",200,49,4,8925.6 D:+@LOC@(X)
. S DATA=$S(X=200:"[Additional Signer]",X=49:"[Service/Section]",X=4:"[Division]",X=8925.6:"[Status]",1:"["_X_"]")_" "
. S DATA=$$SETSTR(DATA,"",COL-$L(DATA),$L(DATA))_$P(@LOC@(X),U,2),XMTEXT($O(XMTEXT(""),-1)+1)=DATA
S XMDUZ=.5,XMSUB="Additional Signer Report Complete",XMTEXT="XMTEXT("
S XMY($P(@LOC@("User"),U))=""
D ^XMD
Q
SETSTR(S,V,X,L) ; insert text(S) into variable(V) at position (X) with length of (L)
Q $E(V_$J("",X-1),1,X-1)_$E(S_$J("",L),1,L)_$E(V,X+L,999)
R X ^%ZOSF("EOFF") R X:60 X ^%ZOSF("EON") S:'$T X="^" Q ; read input for signature code
SIG(ROW,COL) ; -1=no DUZ/signature code 0=verification failed 1=verified
S ROW=$G(ROW,0),COL=$G(COL,0)
N I,K,X,X1 S K=0,X1=$P($G(^VA(200,+$G(DUZ),20)),U,4) I X1="" D Q -1
. D SAY^XGF(ROW,COL,"No Electronic Signature Code to verify.")
S1 D SAY^XGF(ROW,COL,"Enter your current Signature Code: ")
D SAY^XGF(ROW+2,COL,"Please enter your Electronic Signature Code to acknowledge")
D SAY^XGF(ROW+3,COL,"data deletion from File #8925.7.")
D IOXY^XGF(ROW,47),R G:X=""!(X="^") EXIT
I X?1.2"?" G S1 D
. ;D SAY^XGF(ROW+2,COL,"Please enter your Electronic Signature Code to acknowledge")
. ;D SAY^XGF(ROW+3,COL,"potential data deletion from TIU MULTIPLE SIGNATURE File.")
S K=K+1 D HASH^XUSHSHP I X1'=X D SAY^XGF(,47,"??") H 1 D SAY^XGF(,47," ") S X="" G S1:K<3
EXIT D SAY^XGF(ROW,47,$S(X1=X:"SIGNATURE VERIFIED",1:"SIGNATURE NOT VERIFIED"))
N Y F Y=2,3 D SAY^XGF(ROW+Y,COL," ")
Q $S(X1=X:1,1:0)
INTRO F X=1:1 S Y=$P($T(INTRO+X),";;",2) Q:Y="EOM" W @Y,!,IOCUON
;;"VHA HANDBOOK 1907.01 defines the additional signer role as follows:"
;;""
;;"""Additional signer"" is a communication tool used to alert a clinician about"
;;"information pertaining to the patient. This functionality is designed to"
;;"allow clinicians to call attention to specific documents and the recipient to"
;;"acknowledge receipt of the information. Being identified as an additional"
;;"signer does not constitute a co-signature. This nomenclature in no way implies"
;;"responsibility for the content of, or concurrence with, the note."""
;;""
;;""
;;"This utility provides options to report and/or remove outstanding additional"
;;"signers and the associated alerts by either date range or additional signer."
;;""
;;$$CJ^XLFSTR("** WARNING **",IOM)
;;""
;;IOBON_IORVON_"Removing additional signers from a document is PERMANENT and cannot be undone."_IORVOFF_IOBOFF
;;""
;;$$CJ^XLFSTR("** WARNING **",IOM)
;;""
;;EOM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUASCU1 7247 printed Sep 23, 2025@20:15:12 Page 2
TIUASCU1 ; NA/AJB - ADDITIONAL SIGNER CLEANUP 2.0;11/02/23 11:17
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**357**;Jun 20, 1997;Build 5
+2 ;
+3 ; Reference to $$GET1^DID supported by ICR #2052
+4 ; Reference to $$GET1^DIQ supported by ICR #2056
+5 ; Reference to $$DIV^XUSER supported by ICR #2533
+6 ; Reference to HOME^%ZIS supported by ICR #10086
+7 ; Reference to *^XGF supported by ICR #3173
+8 ; Reference to *^XLFDT supported by ICR #10103
+9 ; Reference to *^XLFSTR supported by ICR #10104
+10 ; Reference to ^%ZTLOAD supported by ICR #10063
+11 ; Reference to ^DIC supported by ICR #10006
+12 ; Reference to ^DIK supported by ICR #10013
+13 ; Reference to ^DIR supported by ICR #10026
+14 ; Reference to ^XMD supported by ICR #10070
+15 ; Reference to File ^DIC(49 supported by ICR #4330
+16 ; Reference to File ^DPT supported by ICR #10035
+17 ; Reference to File ^VA supported by ICR #10060
+18 ; Reference to EN^XUTMDEVQ supported by ICR #1519
+19 ; Reference to HASH^XUSHSHP supported by ICR #10045
+20 ; Reference to ^%ZOSF(*) supported by ICR #10096
+21 ; Reference to *^XGF supported by ICR #3173
+22 ;
+23 QUIT
SETUP(SCR,DATE) ; ask user for type of search
LIST ;Date Range:DT^Additional Signer:200^Service/Section:49^^Division:4^Document Status:8925.6^DISUSER'D:DIS^^Terminated:TERM
+1 NEW DIR,EXIT,I,J,LIST,SEL,VAL,X,Y
+2 SET DIR("A",1)="Select SEARCH CRITERIA:"
SET DIR("A",2)=""
SET EXIT=0
+3 SET (I,J)=0
SET LIST=$PIECE($TEXT(LIST),";",2)
SET X=$ORDER(DIR("A",""),-1)+1
FOR Y=1:1:$LENGTH(LIST,U)
Begin DoDot:1
+4 IF $PIECE(LIST,U,Y)=""
SET I=0
SET X=X+1
QUIT
+5 SET I=I+1
SET J=J+1
SET DIR("A",X)=$$SETSTR(" "_J_" "_$PIECE($PIECE(LIST,U,Y),":"),$SELECT('$DATA(DIR("A",X)):"",1:DIR("A",X)),$SELECT(I=1:0,1:((I-1)*25)),$LENGTH($PIECE(LIST,U,Y))+3)
+6 SET LIST(J)=$PIECE($PIECE(LIST,U,Y),":",2)
End DoDot:1
+7 SET DIR("A",X+1)=""
SET DIR("A")="Enter SELECTION: "
SET DIR("B")=1
SET DIR(0)="LAO^1:"_J
SET SEL=$$DIR(.DIR)
if 'SEL
QUIT 0
+8 FOR X=1:1:$LENGTH(SEL,",")-1
Begin DoDot:1
+9 NEW DIC
SET Y=$PIECE(SEL,",",X)
IF LIST(Y)="DT"
DO DATE(.DATE,.SCR)
if 'SCR("Start")!('SCR("End"))
SET EXIT=1
QUIT
+10 IF LIST(Y)="TERM"!(LIST(Y)="DIS")
SET SCR($SELECT(LIST(Y)="TERM":"Terminated",1:"DISUSER'd"))="1^YES"
QUIT
+11 SET DIC=LIST(Y)
SET DIC("A")=$SELECT(DIC=200:"Enter ADDITIONAL SIGNER: ",DIC=4:"Enter DIVISION: ",DIC=49:"Enter SERVICE/SECTION: ",DIC=8925.6:"Enter DOCUMENT STATUS: ")
+12 NEW VAL
SET VAL=$$DIC(.DIC)
if VAL=U
SET EXIT=1
if EXIT
QUIT
if +VAL
SET SCR(LIST(Y))=VAL
End DoDot:1
if EXIT
QUIT
+13 QUIT $SELECT(EXIT:0,1:1)
DATE(DATE,SCR) ;
+1 SET (SCR("Start"),SCR("End"))=""
NEW X
FOR X="Start","End"
Begin DoDot:1
+2 NEW DIR
SET DIR(0)="DOA^"_DATE("Start")_":"_DATE("End")
SET DIR("?")="Enter a date from "_$$FMTE^XLFDT(DATE("Start"))_" to "_$$FMTE^XLFDT(DATE("End"))
+3 SET DIR("?",1)="This date is the "_$SELECT(X="Start":"earliest",1:"latest")_" date an outstanding additional signature is due."
SET DIR("?",2)=""
+4 SET DIR("A")="Enter "_$SELECT(X="Start":"STARTING",1:"ENDING")_" DATE: "
SET DIR("B")=$SELECT(X="Start":$$FMTE^XLFDT(DATE("Start")),1:$$FMTE^XLFDT($$FMADD^XLFDT(DT,-30)))
+5 SET SCR(X)=$$DIR(.DIR)
IF $EXTRACT(SCR(X),6,7)="00"
SET SCR(X)=SCR(X)+$SELECT(X="Start":1,1:101)
if X="End"
SET SCR(X)=$$FMADD^XLFDT(SCR(X),-1)
+6 SET $PIECE(SCR(X),U,2)=$$FMTE^XLFDT(SCR(X))
if +SCR(X)&(X="End")
SET $PIECE(SCR(X),U)=$PIECE(SCR(X),U)+.24
End DoDot:1
if 'SCR(X)
QUIT
+7 IF 'SCR("Start")!('SCR("End"))
SET (SCR("Start"),SCR("End"))=""
+8 QUIT
DIC(DIC) ; basic lookup
+1 NEW DIRUT,DTOUT,DUOUT,X,Y
SET DIC=$$GET1^DID(DIC,"","","GLOBAL NAME")
SET DIC(0)="AE"
DO ^DIC
+2 QUIT $SELECT(+Y>0:Y,X=U:U,+$GET(DTOUT):U,Y'>0:0,1:Y)
DIR(DIR,PROMPT,DEFAULT,HELP,SCREEN) ; response reader
+1 NEW DIROUT,DIRUT,DTOUT,DUOUT,X,Y
if '$DATA(DIR(0))
SET DIR(0)=$GET(DIR)
if '$DATA(DIR("A"))&($GET(PROMPT)'="")
SET DIR("A")=PROMPT
if '$DATA(DIR("B"))&($GET(DEFAULT)'="")
SET DIR("B")=DEFAULT
+2 if '$DATA(DIR("S"))&($GET(SCREEN)'="")
SET DIR("S")=SCREEN
if '$DATA(DIR("?"))&($DATA(HELP))
SET DIR("?")=$SELECT($GET(HELP)'="":HELP,1:$GET(HELP("?")))
MERGE DIR=HELP
DO ^DIR
+3 QUIT $SELECT(X[U:U,+Y:Y,1:"")
MAIL(LOC) ;
+1 NEW COL,DATA,X,XMDUN,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
SET COL=24
SET XMTEXT($ORDER(XMTEXT(""),-1)+1)="Task is complete. The completed report is available via the option."
SET XMTEXT($ORDER(XMTEXT(""),-1)+1)=""
+2 SET DATA="User: "
SET DATA=$$SETSTR(DATA,"",COL-$LENGTH(DATA),$LENGTH(DATA))_$PIECE(@LOC@("User"),U)
SET XMTEXT($ORDER(XMTEXT(""),-1)+1)=DATA
+3 SET DATA="Mode: "
SET DATA=$$SETSTR(DATA,"",COL-$LENGTH(DATA),$LENGTH(DATA))_@LOC@("Action")
SET XMTEXT($ORDER(XMTEXT(""),-1)+1)=DATA
+4 SET DATA="Duration: "
SET DATA=$$SETSTR(DATA,"",COL-$LENGTH(DATA),$LENGTH(DATA))_@LOC@("Elapsed")
SET XMTEXT($ORDER(XMTEXT(""),-1)+1)=DATA
+5 SET DATA="# Signatures: "
SET DATA=$$SETSTR(DATA,"",COL-$LENGTH(DATA),$LENGTH(DATA))_@LOC@("Total")
SET XMTEXT($ORDER(XMTEXT(""),-1)+1)=DATA
+6 SET XMTEXT($ORDER(XMTEXT(""),-1)+1)=""
SET DATA="Search Criteria: "
SET DATA=$$SETSTR(DATA,"",COL-$LENGTH(DATA),$LENGTH(DATA))
SET XMTEXT($ORDER(XMTEXT(""),-1)+1)=DATA
SET XMTEXT($ORDER(XMTEXT(""),-1)+1)=""
+7 SET DATA="[Date Range] "
SET DATA=$$SETSTR(DATA,"",COL-$LENGTH(DATA),$LENGTH(DATA))_@LOC@("Start Date")_" to "_@LOC@("Stop Date")
SET XMTEXT($ORDER(XMTEXT(""),-1)+1)=DATA
+8 FOR X="DISUSER'd","Terminated",200,49,4,8925.6
if +@LOC@(X)
Begin DoDot:1
+9 SET DATA=$SELECT(X=200:"[Additional Signer]",X=49:"[Service/Section]",X=4:"[Division]",X=8925.6:"[Status]",1:"["_X_"]")_" "
+10 SET DATA=$$SETSTR(DATA,"",COL-$LENGTH(DATA),$LENGTH(DATA))_$PIECE(@LOC@(X),U,2)
SET XMTEXT($ORDER(XMTEXT(""),-1)+1)=DATA
End DoDot:1
+11 SET XMDUZ=.5
SET XMSUB="Additional Signer Report Complete"
SET XMTEXT="XMTEXT("
+12 SET XMY($PIECE(@LOC@("User"),U))=""
+13 DO ^XMD
+14 QUIT
SETSTR(S,V,X,L) ; insert text(S) into variable(V) at position (X) with length of (L)
+1 QUIT $EXTRACT(V_$JUSTIFY("",X-1),1,X-1)_$EXTRACT(S_$JUSTIFY("",L),1,L)_$EXTRACT(V,X+L,999)
R ; read input for signature code
XECUTE ^%ZOSF("EOFF")
READ X:60
XECUTE ^%ZOSF("EON")
if '$TEST
SET X="^"
QUIT
SIG(ROW,COL) ; -1=no DUZ/signature code 0=verification failed 1=verified
+1 SET ROW=$GET(ROW,0)
SET COL=$GET(COL,0)
+2 NEW I,K,X,X1
SET K=0
SET X1=$PIECE($GET(^VA(200,+$GET(DUZ),20)),U,4)
IF X1=""
Begin DoDot:1
+3 DO SAY^XGF(ROW,COL,"No Electronic Signature Code to verify.")
End DoDot:1
QUIT -1
S1 DO SAY^XGF(ROW,COL,"Enter your current Signature Code: ")
+1 DO SAY^XGF(ROW+2,COL,"Please enter your Electronic Signature Code to acknowledge")
+2 DO SAY^XGF(ROW+3,COL,"data deletion from File #8925.7.")
+3 DO IOXY^XGF(ROW,47)
DO R
if X=""!(X="^")
GOTO EXIT
+4 IF X?1.2"?"
GOTO S1
Begin DoDot:1
+5 ;D SAY^XGF(ROW+2,COL,"Please enter your Electronic Signature Code to acknowledge")
+6 ;D SAY^XGF(ROW+3,COL,"potential data deletion from TIU MULTIPLE SIGNATURE File.")
End DoDot:1
+7 SET K=K+1
DO HASH^XUSHSHP
IF X1'=X
DO SAY^XGF(,47,"??")
HANG 1
DO SAY^XGF(,47," ")
SET X=""
if K<3
GOTO S1
EXIT DO SAY^XGF(ROW,47,$SELECT(X1=X:"SIGNATURE VERIFIED",1:"SIGNATURE NOT VERIFIED"))
+1 NEW Y
FOR Y=2,3
DO SAY^XGF(ROW+Y,COL," ")
+2 QUIT $SELECT(X1=X:1,1:0)
INTRO FOR X=1:1
SET Y=$PIECE($TEXT(INTRO+X),";;",2)
if Y="EOM"
QUIT
WRITE @Y,!,IOCUON
+1 ;;"VHA HANDBOOK 1907.01 defines the additional signer role as follows:"
+2 ;;""
+3 ;;"""Additional signer"" is a communication tool used to alert a clinician about"
+4 ;;"information pertaining to the patient. This functionality is designed to"
+5 ;;"allow clinicians to call attention to specific documents and the recipient to"
+6 ;;"acknowledge receipt of the information. Being identified as an additional"
+7 ;;"signer does not constitute a co-signature. This nomenclature in no way implies"
+8 ;;"responsibility for the content of, or concurrence with, the note."""
+9 ;;""
+10 ;;""
+11 ;;"This utility provides options to report and/or remove outstanding additional"
+12 ;;"signers and the associated alerts by either date range or additional signer."
+13 ;;""
+14 ;;$$CJ^XLFSTR("** WARNING **",IOM)
+15 ;;""
+16 ;;IOBON_IORVON_"Removing additional signers from a document is PERMANENT and cannot be undone."_IORVOFF_IOBOFF
+17 ;;""
+18 ;;$$CJ^XLFSTR("** WARNING **",IOM)
+19 ;;""
+20 ;;EOM
