TIUSRVT3 ; SLC/PKS - Remove a user's non-shared Templates. ; Sep 22, 2025@15:36:20
;;1.0;TEXT INTEGRATION UTILITIES;**110,369**;Jun 20, 1997;Build 4
;
; Reference to ^DIR in ICR #10026
; Reference to $$GET^XPAR in ICR #2263
; Reference to ^VA(200 in ICR #10060
;
; Variables used herein:
;
; DIR = FM call varible.
; TIUARY = Array holder.
; TIUCNT = Returned array counter.
; TIUGET = Holder for returned array $O command.
; TIUIDX = X-ref holder.
; TIUIEN = Template IEN holder.
; TIUNM = Holder variable for name of user.
; TIUNUM = Loop counter from this routine.
; TIUPAR = Current setting of auto-cleanup parameter.
; TIURARY = Returned array; zero node will contain user's DUZ and
; AROOT IEN (if any) or error message (RPC use only).
; TIUSR = DUZ of user to process.
; TIUTMP = Call return array values holder.
; TIUTPLT = Template IEN.
; X,Y = Variables for FM call.
;
Q
;
SELUSR ; Call here for manual selection of TIUSR from NEW PERSON file.
;
N DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ; New all potential ^DIR variables
N TIUCNT,TIUGET,TIUIDX,TIUNM,TIUNUM,TIUTPLT,TIURARY,TIUSR
;
; Get input for user:
S TIUSR="" ; Default.
S DIR(0)="PAO^200,:AEMNQ"
S DIR("A")=" Enter/select user for whom templates will be deleted: "
S DIR("?")="Specify user for template cleanup."
D ^DIR
S TIUSR=+Y ; Selected user's DUZ.
S TIUNM=$P(Y,U,2) ; Selected user's NAME.
I TIUSR<1 Q ; No acceptable entry.
K DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ; Clean up from FM call.
;
; Confirm before deletion:
S DIR("T")=120 ; Two minute maximum timeout for response.
S DIR("A")=" Delete all non-shared templates for user "_TIUNM_" (Y/N)"
S DIR("?")=" Non-shared templates for this user will be permanently lost..."
S DIR("B")="NO" ; Default.
;
; Define DIR input requirements:
S DIR(0)="YO^1:2:0"
;
; Call DIR for user choice:
W !! ; Spacing for screen display.
D ^DIR
;
; Check user response:
I '$L($G(Y)) Q ; Skip if Y isn't assigned.
I Y="" Q ; Skip if Y is null.
I Y="^" Q ; Skip if Y is "^" character.
I Y<1 Q ; Skip if Y is less than one.
I Y>2 Q ; "No" choice.
K DIR,X,Y ; Clean up from FM call.
;
; Proceed with clean up:
D CTRL
K TIURARY ; Array not returned under manual functionality.
;
Q
;
KUSER ; Get USER from Kernel - called by option: TIU TEMPLATE USER DELETE.
;
; See if this function is "active" by checking Parameter:
;
N TIUCNT,TIUGET,TIUIDX,TIUNUM,TIUTPLT,TIUPAR,TIURARY,TIUSR
S TIUPAR=$$GET^XPAR("DIV^SYS^PKG","TIU TEMPLATE USER AUTO DELETE",1,"E")
I TIUPAR'="YES" Q
I TIUPAR="" Q
;
; Parameter set to activate auto-cleanup - proceed:
S TIUSR=$GET(XUIFN) ; Assign TIUSR variable.
I TIUSR="" Q ; Punt here if there's a problem.
D CTRL
K TIURARY ; Array not returned when triggered by Kernel.
;
Q
;
CLEAN(TIUSR,TIURARY) ; Call here as an RPC: Dump templates for one user.
;
N TIUCNT,TIUGET,TIUIDX,TIUNUM,TIUTPLT
I 'TIUSR>0 S TIURARY(0)="No user DUZ passed." Q
;
CTRL ; Main control code for actual cleanup process.
;
S TIUCNT=0
;
; See if there is an AROOT x-ref entry for this user:
I '$D(^TIU(8927,"AROOT",TIUSR)) S TIURARY(0)="No AROOT record." Q
;
; Get parent record for user's templates:
S TIUTPLT=0
F D Q:'TIUTPLT
.S TIUTPLT=$O(^TIU(8927,"AROOT",TIUSR,TIUTPLT))
.I 'TIUTPLT Q
.;
.; Compile an array of applicable templates:
.D DEL(TIUTPLT)
;
Q
;
DEL(TIUIEN) ; Pass root node of AROOT x-ref of <^TIU(8927,> file.
;
N TIUARY,TIUTMP
;
S TIURARY(TIUCNT)=TIUSR_U_TIUIEN ; 0-node: "UserDUZ^ARootIEN" format.
D BLD(TIUIEN,.TIUARY) ; Recursive array builder.
;
; Create or add to return array:
S (TIUGET,TIUNUM)=0
F D Q:'TIUGET
.S TIUNUM=TIUNUM+1
.S TIUGET=$G(TIUARY(TIUNUM))
.I 'TIUGET Q
.S TIUCNT=TIUCNT+1
.S TIURARY(TIUCNT)=TIUGET
;
; Using the array of templates, make call that kills only orphans:
D DELETE^TIUSRVT(.TIUTMP,.TIUARY)
;
Q
;
BLD(TIUIEN,TIUARY) ; Recursively build an array of templates.
;
N TIUIDX
;
I +TIUIEN'>0 Q
S TIUIDX=$O(TIUARY(" "),-1)+1
S TIUARY(TIUIDX)=TIUIEN
S TIUIDX=0
F S TIUIDX=$O(^TIU(8927,TIUIEN,10,TIUIDX)) Q:'TIUIDX D
.D BLD($P(^TIU(8927,TIUIEN,10,TIUIDX,0),U,2),.TIUARY)
;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUSRVT3 4666 printed Jul 11, 2026@02:43:29 Page 2
TIUSRVT3 ; SLC/PKS - Remove a user's non-shared Templates. ; Sep 22, 2025@15:36:20
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**110,369**;Jun 20, 1997;Build 4
+2 ;
+3 ; Reference to ^DIR in ICR #10026
+4 ; Reference to $$GET^XPAR in ICR #2263
+5 ; Reference to ^VA(200 in ICR #10060
+6 ;
+7 ; Variables used herein:
+8 ;
+9 ; DIR = FM call varible.
+10 ; TIUARY = Array holder.
+11 ; TIUCNT = Returned array counter.
+12 ; TIUGET = Holder for returned array $O command.
+13 ; TIUIDX = X-ref holder.
+14 ; TIUIEN = Template IEN holder.
+15 ; TIUNM = Holder variable for name of user.
+16 ; TIUNUM = Loop counter from this routine.
+17 ; TIUPAR = Current setting of auto-cleanup parameter.
+18 ; TIURARY = Returned array; zero node will contain user's DUZ and
+19 ; AROOT IEN (if any) or error message (RPC use only).
+20 ; TIUSR = DUZ of user to process.
+21 ; TIUTMP = Call return array values holder.
+22 ; TIUTPLT = Template IEN.
+23 ; X,Y = Variables for FM call.
+24 ;
+25 QUIT
+26 ;
SELUSR ; Call here for manual selection of TIUSR from NEW PERSON file.
+1 ;
+2 ; New all potential ^DIR variables
NEW DA,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+3 NEW TIUCNT,TIUGET,TIUIDX,TIUNM,TIUNUM,TIUTPLT,TIURARY,TIUSR
+4 ;
+5 ; Get input for user:
+6 ; Default.
SET TIUSR=""
+7 SET DIR(0)="PAO^200,:AEMNQ"
+8 SET DIR("A")=" Enter/select user for whom templates will be deleted: "
+9 SET DIR("?")="Specify user for template cleanup."
+10 DO ^DIR
+11 ; Selected user's DUZ.
SET TIUSR=+Y
+12 ; Selected user's NAME.
SET TIUNM=$PIECE(Y,U,2)
+13 ; No acceptable entry.
IF TIUSR<1
QUIT
+14 ; Clean up from FM call.
KILL DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+15 ;
+16 ; Confirm before deletion:
+17 ; Two minute maximum timeout for response.
SET DIR("T")=120
+18 SET DIR("A")=" Delete all non-shared templates for user "_TIUNM_" (Y/N)"
+19 SET DIR("?")=" Non-shared templates for this user will be permanently lost..."
+20 ; Default.
SET DIR("B")="NO"
+21 ;
+22 ; Define DIR input requirements:
+23 SET DIR(0)="YO^1:2:0"
+24 ;
+25 ; Call DIR for user choice:
+26 ; Spacing for screen display.
WRITE !!
+27 DO ^DIR
+28 ;
+29 ; Check user response:
+30 ; Skip if Y isn't assigned.
IF '$LENGTH($GET(Y))
QUIT
+31 ; Skip if Y is null.
IF Y=""
QUIT
+32 ; Skip if Y is "^" character.
IF Y="^"
QUIT
+33 ; Skip if Y is less than one.
IF Y<1
QUIT
+34 ; "No" choice.
IF Y>2
QUIT
+35 ; Clean up from FM call.
KILL DIR,X,Y
+36 ;
+37 ; Proceed with clean up:
+38 DO CTRL
+39 ; Array not returned under manual functionality.
KILL TIURARY
+40 ;
+41 QUIT
+42 ;
KUSER ; Get USER from Kernel - called by option: TIU TEMPLATE USER DELETE.
+1 ;
+2 ; See if this function is "active" by checking Parameter:
+3 ;
+4 NEW TIUCNT,TIUGET,TIUIDX,TIUNUM,TIUTPLT,TIUPAR,TIURARY,TIUSR
+5 SET TIUPAR=$$GET^XPAR("DIV^SYS^PKG","TIU TEMPLATE USER AUTO DELETE",1,"E")
+6 IF TIUPAR'="YES"
QUIT
+7 IF TIUPAR=""
QUIT
+8 ;
+9 ; Parameter set to activate auto-cleanup - proceed:
+10 ; Assign TIUSR variable.
SET TIUSR=$GET(XUIFN)
+11 ; Punt here if there's a problem.
IF TIUSR=""
QUIT
+12 DO CTRL
+13 ; Array not returned when triggered by Kernel.
KILL TIURARY
+14 ;
+15 QUIT
+16 ;
CLEAN(TIUSR,TIURARY) ; Call here as an RPC: Dump templates for one user.
+1 ;
+2 NEW TIUCNT,TIUGET,TIUIDX,TIUNUM,TIUTPLT
+3 IF 'TIUSR>0
SET TIURARY(0)="No user DUZ passed."
QUIT
+4 ;
CTRL ; Main control code for actual cleanup process.
+1 ;
+2 SET TIUCNT=0
+3 ;
+4 ; See if there is an AROOT x-ref entry for this user:
+5 IF '$DATA(^TIU(8927,"AROOT",TIUSR))
SET TIURARY(0)="No AROOT record."
QUIT
+6 ;
+7 ; Get parent record for user's templates:
+8 SET TIUTPLT=0
+9 FOR
Begin DoDot:1
+10 SET TIUTPLT=$ORDER(^TIU(8927,"AROOT",TIUSR,TIUTPLT))
+11 IF 'TIUTPLT
QUIT
+12 ;
+13 ; Compile an array of applicable templates:
+14 DO DEL(TIUTPLT)
End DoDot:1
if 'TIUTPLT
QUIT
+15 ;
+16 QUIT
+17 ;
DEL(TIUIEN) ; Pass root node of AROOT x-ref of <^TIU(8927,> file.
+1 ;
+2 NEW TIUARY,TIUTMP
+3 ;
+4 ; 0-node: "UserDUZ^ARootIEN" format.
SET TIURARY(TIUCNT)=TIUSR_U_TIUIEN
+5 ; Recursive array builder.
DO BLD(TIUIEN,.TIUARY)
+6 ;
+7 ; Create or add to return array:
+8 SET (TIUGET,TIUNUM)=0
+9 FOR
Begin DoDot:1
+10 SET TIUNUM=TIUNUM+1
+11 SET TIUGET=$GET(TIUARY(TIUNUM))
+12 IF 'TIUGET
QUIT
+13 SET TIUCNT=TIUCNT+1
+14 SET TIURARY(TIUCNT)=TIUGET
End DoDot:1
if 'TIUGET
QUIT
+15 ;
+16 ; Using the array of templates, make call that kills only orphans:
+17 DO DELETE^TIUSRVT(.TIUTMP,.TIUARY)
+18 ;
+19 QUIT
+20 ;
BLD(TIUIEN,TIUARY) ; Recursively build an array of templates.
+1 ;
+2 NEW TIUIDX
+3 ;
+4 IF +TIUIEN'>0
QUIT
+5 SET TIUIDX=$ORDER(TIUARY(" "),-1)+1
+6 SET TIUARY(TIUIDX)=TIUIEN
+7 SET TIUIDX=0
+8 FOR
SET TIUIDX=$ORDER(^TIU(8927,TIUIEN,10,TIUIDX))
if 'TIUIDX
QUIT
Begin DoDot:1
+9 DO BLD($PIECE(^TIU(8927,TIUIEN,10,TIUIDX,0),U,2),.TIUARY)
End DoDot:1
+10 ;
+11 QUIT
+12 ;
