TIUFHA1 ; SLC/MAM - LM Templates H,A Actn Delete. CANTDEL(FILEDA,USED),ASKOK(OLDLNO,IFLAG,USED) ;1/19/06
;;1.0;TEXT INTEGRATION UTILITIES;**2,13,43,184**;Jun 20, 1997
;
;$$HASAS^USRLFF - IA 2329
;$$FNDTITLE^DGPFAPI1 - IA 4383
DELETE ; Templates H and A Action Delete Entries
; Requires TIUFTMPL.
; Requires TIUFWHO, set in Options TIUF/A/C/H EDIT/SORT/CREATE DDEFS CLIN/MGR/NATL.
; Not on Clinician menu: don't worry about TIUFWHO="C".
N OLDLNO,TIUFDA,FILEDA,USED,IFLAG,PFILEDA,SHARED,ANCQUIT,MSG1
N ASKOK,ITEMDA,LINENO,INFO,PINFO,MSG,TIUFXNOD,TIUI,ANCESTOR,NODE0,NATL
N DTOUT,DIRUT,DIROUT
S VALMBCK="",TIUFXNOD=$G(XQORNOD(0))
D EN^VALM2(TIUFXNOD,"O")
I '$O(VALMY(0)) G DELEX
S OLDLNO=0
F S OLDLNO=$O(VALMY(OLDLNO)) Q:'OLDLNO D
. S TIUFDA(OLDLNO)=$P(^TMP("TIUF1IDX",$J,OLDLNO),U,2)
. Q
S OLDLNO=0 K DIRUT
F S OLDLNO=$O(TIUFDA(OLDLNO)) Q:'OLDLNO!$D(DIRUT) D L -^TIU(8925.1,+$G(FILEDA))
. S MSG=" Processing Entry "_OLDLNO_"..." W !!,MSG
. S FILEDA=TIUFDA(OLDLNO)
. I $G(TIUFCDA) D Q:$G(ANCQUIT)
. . D ANCESTOR^TIUFLF4(TIUFCDA,^TIU(8925.1,TIUFCDA,0),.ANCESTOR) S ANCQUIT=0
. . F TIUI=0:1 Q:'$G(ANCESTOR(TIUI)) I FILEDA=ANCESTOR(TIUI) D Q
. . . S ANCQUIT=1
. . . I TIUI=0 S MSG=" This is your Current Position in the Hierarchy; Can't delete" W !!,MSG,! D PAUSE^TIUFXHLX Q
. . . S MSG=" This entry is ABOVE your Current Position in the Hierarchy; Can't delete" W !!,MSG,! D PAUSE^TIUFXHLX
. S NODE0=^TIU(8925.1,FILEDA,0),NATL=$P(NODE0,U,13),SHARED=$P(NODE0,U,10)
. I SHARED S MSG=" Shared Components cannot be deleted; if they do not have multiple parents,",MSG1="they can be edited to NOT SHARED and then deleted" W !!,MSG,!,MSG1 D PAUSE^TIUFXHLX Q
. I $P(^TIU(8925.1,FILEDA,0),U,13) S MSG=" National Entry; Can't delete" W MSG,! D PAUSE^TIUFXHLX Q
. I $P(NODE0,U,4)="O" W !,"To delete an Object, please select action Detailed Display.",! D PAUSE^TIUFXHLX Q
. I ($L($P(NODE0,U,5))!$L($P(NODE0,U,6))),'$$PERSOWNS^TIUFLF2(FILEDA,DUZ) S MSG=" Only an Owner can delete a file entry" W MSG,! D PAUSE^TIUFXHLX Q
. L +^TIU(8925.1,FILEDA):1 I '$T W !!," Another user is editing this entry; Please try later" H 2 Q
. S USED=$S($P(NODE0,U,4)="O":$$OBJUSED^TIUFLJ(FILEDA),1:$$DDEFUSED^TIUFLF(FILEDA))
. Q:$$CANTDEL(FILEDA,USED)
. S IFLAG=+$O(^TIU(8925.1,"AD",FILEDA,0))
. I TIUFTMPL="A",IFLAG D D PAUSE^TIUFXHLX Q:$D(DIRUT)
. . H 1 W !!," Entry "_OLDLNO_" has Parent:"
. . S PFILEDA=0 F D Q:'PFILEDA
. . . S PFILEDA=$O(^TIU(8925.1,"AD",FILEDA,PFILEDA)) Q:'PFILEDA
. . . W !?5,$P(^TIU(8925.1,PFILEDA,0),U)
. H 1 S ASKOK=$$ASKOK(OLDLNO,IFLAG,USED) I 'ASKOK S MSG=" ... Entry "_OLDLNO_" not deleted!" W MSG,! D PAUSE^TIUFXHLX Q
. I 'IFLAG G DELENTY
. ; If FILEDA is used as an item, delete it as an item:
. N DA,DIK
. S PFILEDA=$O(^TIU(8925.1,"AD",FILEDA,0)) Q:'PFILEDA
. S ITEMDA=$O(^TIU(8925.1,"AD",FILEDA,PFILEDA,0)) Q:'ITEMDA
. I TIUFTMPL="A",$E(TIUFATTR)="P" S TIUFREDO=1
. S DA(1)=PFILEDA,DA=ITEMDA,DIK="^TIU(8925.1,DA(1),10," D ^DIK
DELENTY . ; Delete FILEDA as Docmt Def entry in file 8925.1:
. N DA,DIK
. I TIUFTMPL="A",$E(TIUFATTR)="P" S TIUFREDO=1 ;Delete affects parentage globally.
. S DA=FILEDA,DIK="^TIU(8925.1," D ^DIK
. S LINENO=$O(^TMP("TIUF1IDX",$J,"DAF",FILEDA,0))
. G:'LINENO MSG ; not there since parent was already deleted
. I "AJ"[TIUFTMPL D G MSG
. . I '$G(TIUFREDO) D UPDATE^TIUFLLM1(TIUFTMPL,-1,LINENO-1) S VALMCNT=VALMCNT-1
. ; Update LM Template H: collapse and then delete FILEDA's LINENO.
. S INFO=^TMP("TIUF1IDX",$J,LINENO) D PARSE^TIUFLLM(.INFO)
. I INFO("XPDLCNT") S VALMCNT=VALMCNT-INFO("XPDLCNT") D COLLAPSE^TIUFH1(.INFO)
. S PINFO=^TMP("TIUF1IDX",$J,INFO("PLINENO")) D PARSE^TIUFLLM(.PINFO)
. D UPDATE^TIUFLLM1("H",-1,LINENO-1,.PINFO) S VALMCNT=VALMCNT-1
MSG . S MSG=" ... Entry "_OLDLNO_" Deleted!" W MSG,! H 1 S VALMBCK="R"
. Q
I TIUFTMPL="C" K TIUFCMSG D
. S TIUFCMSG(1)=" Select "_$S(TIUFCTYP="DC":"TITLE",1:"CLASS/DOCUMENTCLASS")_" to create a new "_TIUFCNM
. S TIUFCMSG(2)="or to Go Down a Level, Select NEXT LEVEL."
. I VALMCNT>VALM("LINES") S TIUFCMSG(2)="or to Go Down a Level, Screen to (+/-) Desired ",TIUFCMSG(3)=TIUFCNM_" Item, and Select NEXT LEVEL."
DELEX I $D(DTOUT) S VALMBCK="Q" Q
I "AJ"[TIUFTMPL,VALMBCK="R",TIUFREDO D INIT^TIUFA S:$D(DTOUT) VALMBCK="Q"
Q
;
ASKOK(OLDLNO,IFLAG,USED) ; Function warns user, asks if OK to continue delete. 1/OK; 0/not OK
N DIR,X,Y,ANS
S ANS=0
I USED=0 S DIR("A")="Object has not been embedded in Boilerplate Text. Delete" G ASKOX
S DIR("A",1)="Entry "_OLDLNO_" is not presently used by any documents. If entry is deleted,"
I IFLAG S DIR("A",2)="any items UNDER it will be Orphans. I will delete entry as an item under its",DIR("A")="parent AND as a Document Definition. It will no longer exist. OK"
E S DIR("A",2)="any items UNDER it will be Orphans. I will delete entry as a Document",DIR("A")="Definition. It will no longer exist. OK"
ASKOX S DIR(0)="Y",DIR("B")="NO" D ^DIR S ANS=Y W !
Q ANS
;
CANTDEL(FILEDA,USED) ; Function returns 1 if FILEDA can't be deleted, else 0.
N ANS,MSG
S ANS=0
I USED="YES" S MSG="Entry In Use by documents; Can't delete" W MSG,! S ANS=1 G CANTX
I USED S MSG="Object embedded in boilerplate text; Can't delete" W !,MSG,! S ANS=1 G CANTX
I $$HASAS^USRLFF(FILEDA) S MSG=" Entry has Authorizations/Subscriptions; Can't delete." W !!,MSG,! S ANS=1 G CANTX ;**43**
I $$FNDTITLE^DGPFAPI1(FILEDA)>0 S MSG="Entry Associated with PRF Flag; Can't delete" W MSG,! S ANS=1 G CANTX
I '$D(^TIU(8925.1,"AS",+^TMP("TIUF",$J,"STATI"),FILEDA)),$P(^TIU(8925.1,FILEDA,0),U,7) D G CANTX
. S MSG=" Status not INACTIVE; Can't delete" W MSG,! S ANS=1
CANTX ;
I $D(MSG) D PAUSE^TIUFXHLX
Q ANS
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUFHA1 5779 printed Dec 13, 2024@02:40:44 Page 2
TIUFHA1 ; SLC/MAM - LM Templates H,A Actn Delete. CANTDEL(FILEDA,USED),ASKOK(OLDLNO,IFLAG,USED) ;1/19/06
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**2,13,43,184**;Jun 20, 1997
+2 ;
+3 ;$$HASAS^USRLFF - IA 2329
+4 ;$$FNDTITLE^DGPFAPI1 - IA 4383
DELETE ; Templates H and A Action Delete Entries
+1 ; Requires TIUFTMPL.
+2 ; Requires TIUFWHO, set in Options TIUF/A/C/H EDIT/SORT/CREATE DDEFS CLIN/MGR/NATL.
+3 ; Not on Clinician menu: don't worry about TIUFWHO="C".
+4 NEW OLDLNO,TIUFDA,FILEDA,USED,IFLAG,PFILEDA,SHARED,ANCQUIT,MSG1
+5 NEW ASKOK,ITEMDA,LINENO,INFO,PINFO,MSG,TIUFXNOD,TIUI,ANCESTOR,NODE0,NATL
+6 NEW DTOUT,DIRUT,DIROUT
+7 SET VALMBCK=""
SET TIUFXNOD=$GET(XQORNOD(0))
+8 DO EN^VALM2(TIUFXNOD,"O")
+9 IF '$ORDER(VALMY(0))
GOTO DELEX
+10 SET OLDLNO=0
+11 FOR
SET OLDLNO=$ORDER(VALMY(OLDLNO))
if 'OLDLNO
QUIT
Begin DoDot:1
+12 SET TIUFDA(OLDLNO)=$PIECE(^TMP("TIUF1IDX",$JOB,OLDLNO),U,2)
+13 QUIT
End DoDot:1
+14 SET OLDLNO=0
KILL DIRUT
+15 FOR
SET OLDLNO=$ORDER(TIUFDA(OLDLNO))
if 'OLDLNO!$DATA(DIRUT)
QUIT
Begin DoDot:1
+16 SET MSG=" Processing Entry "_OLDLNO_"..."
WRITE !!,MSG
+17 SET FILEDA=TIUFDA(OLDLNO)
+18 IF $GET(TIUFCDA)
Begin DoDot:2
+19 DO ANCESTOR^TIUFLF4(TIUFCDA,^TIU(8925.1,TIUFCDA,0),.ANCESTOR)
SET ANCQUIT=0
+20 FOR TIUI=0:1
if '$GET(ANCESTOR(TIUI))
QUIT
IF FILEDA=ANCESTOR(TIUI)
Begin DoDot:3
+21 SET ANCQUIT=1
+22 IF TIUI=0
SET MSG=" This is your Current Position in the Hierarchy; Can't delete"
WRITE !!,MSG,!
DO PAUSE^TIUFXHLX
QUIT
+23 SET MSG=" This entry is ABOVE your Current Position in the Hierarchy; Can't delete"
WRITE !!,MSG,!
DO PAUSE^TIUFXHLX
End DoDot:3
QUIT
End DoDot:2
if $GET(ANCQUIT)
QUIT
+24 SET NODE0=^TIU(8925.1,FILEDA,0)
SET NATL=$PIECE(NODE0,U,13)
SET SHARED=$PIECE(NODE0,U,10)
+25 IF SHARED
SET MSG=" Shared Components cannot be deleted; if they do not have multiple parents,"
SET MSG1="they can be edited to NOT SHARED and then deleted"
WRITE !!,MSG,!,MSG1
DO PAUSE^TIUFXHLX
QUIT
+26 IF $PIECE(^TIU(8925.1,FILEDA,0),U,13)
SET MSG=" National Entry; Can't delete"
WRITE MSG,!
DO PAUSE^TIUFXHLX
QUIT
+27 IF $PIECE(NODE0,U,4)="O"
WRITE !,"To delete an Object, please select action Detailed Display.",!
DO PAUSE^TIUFXHLX
QUIT
+28 IF ($LENGTH($PIECE(NODE0,U,5))!$LENGTH($PIECE(NODE0,U,6)))
IF '$$PERSOWNS^TIUFLF2(FILEDA,DUZ)
SET MSG=" Only an Owner can delete a file entry"
WRITE MSG,!
DO PAUSE^TIUFXHLX
QUIT
+29 LOCK +^TIU(8925.1,FILEDA):1
IF '$TEST
WRITE !!," Another user is editing this entry; Please try later"
HANG 2
QUIT
+30 SET USED=$SELECT($PIECE(NODE0,U,4)="O":$$OBJUSED^TIUFLJ(FILEDA),1:$$DDEFUSED^TIUFLF(FILEDA))
+31 if $$CANTDEL(FILEDA,USED)
QUIT
+32 SET IFLAG=+$ORDER(^TIU(8925.1,"AD",FILEDA,0))
+33 IF TIUFTMPL="A"
IF IFLAG
Begin DoDot:2
+34 HANG 1
WRITE !!," Entry "_OLDLNO_" has Parent:"
+35 SET PFILEDA=0
FOR
Begin DoDot:3
+36 SET PFILEDA=$ORDER(^TIU(8925.1,"AD",FILEDA,PFILEDA))
if 'PFILEDA
QUIT
+37 WRITE !?5,$PIECE(^TIU(8925.1,PFILEDA,0),U)
End DoDot:3
if 'PFILEDA
QUIT
End DoDot:2
DO PAUSE^TIUFXHLX
if $DATA(DIRUT)
QUIT
+38 HANG 1
SET ASKOK=$$ASKOK(OLDLNO,IFLAG,USED)
IF 'ASKOK
SET MSG=" ... Entry "_OLDLNO_" not deleted!"
WRITE MSG,!
DO PAUSE^TIUFXHLX
QUIT
+39 IF 'IFLAG
GOTO DELENTY
+40 ; If FILEDA is used as an item, delete it as an item:
+41 NEW DA,DIK
+42 SET PFILEDA=$ORDER(^TIU(8925.1,"AD",FILEDA,0))
if 'PFILEDA
QUIT
+43 SET ITEMDA=$ORDER(^TIU(8925.1,"AD",FILEDA,PFILEDA,0))
if 'ITEMDA
QUIT
+44 IF TIUFTMPL="A"
IF $EXTRACT(TIUFATTR)="P"
SET TIUFREDO=1
+45 SET DA(1)=PFILEDA
SET DA=ITEMDA
SET DIK="^TIU(8925.1,DA(1),10,"
DO ^DIK
DELENTY ; Delete FILEDA as Docmt Def entry in file 8925.1:
+1 NEW DA,DIK
+2 ;Delete affects parentage globally.
IF TIUFTMPL="A"
IF $EXTRACT(TIUFATTR)="P"
SET TIUFREDO=1
+3 SET DA=FILEDA
SET DIK="^TIU(8925.1,"
DO ^DIK
+4 SET LINENO=$ORDER(^TMP("TIUF1IDX",$JOB,"DAF",FILEDA,0))
+5 ; not there since parent was already deleted
if 'LINENO
GOTO MSG
+6 IF "AJ"[TIUFTMPL
Begin DoDot:2
+7 IF '$GET(TIUFREDO)
DO UPDATE^TIUFLLM1(TIUFTMPL,-1,LINENO-1)
SET VALMCNT=VALMCNT-1
End DoDot:2
GOTO MSG
+8 ; Update LM Template H: collapse and then delete FILEDA's LINENO.
+9 SET INFO=^TMP("TIUF1IDX",$JOB,LINENO)
DO PARSE^TIUFLLM(.INFO)
+10 IF INFO("XPDLCNT")
SET VALMCNT=VALMCNT-INFO("XPDLCNT")
DO COLLAPSE^TIUFH1(.INFO)
+11 SET PINFO=^TMP("TIUF1IDX",$JOB,INFO("PLINENO"))
DO PARSE^TIUFLLM(.PINFO)
+12 DO UPDATE^TIUFLLM1("H",-1,LINENO-1,.PINFO)
SET VALMCNT=VALMCNT-1
MSG SET MSG=" ... Entry "_OLDLNO_" Deleted!"
WRITE MSG,!
HANG 1
SET VALMBCK="R"
+1 QUIT
End DoDot:1
LOCK -^TIU(8925.1,+$GET(FILEDA))
+2 IF TIUFTMPL="C"
KILL TIUFCMSG
Begin DoDot:1
+3 SET TIUFCMSG(1)=" Select "_$SELECT(TIUFCTYP="DC":"TITLE",1:"CLASS/DOCUMENTCLASS")_" to create a new "_TIUFCNM
+4 SET TIUFCMSG(2)="or to Go Down a Level, Select NEXT LEVEL."
+5 IF VALMCNT>VALM("LINES")
SET TIUFCMSG(2)="or to Go Down a Level, Screen to (+/-) Desired "
SET TIUFCMSG(3)=TIUFCNM_" Item, and Select NEXT LEVEL."
End DoDot:1
DELEX IF $DATA(DTOUT)
SET VALMBCK="Q"
QUIT
+1 IF "AJ"[TIUFTMPL
IF VALMBCK="R"
IF TIUFREDO
DO INIT^TIUFA
if $DATA(DTOUT)
SET VALMBCK="Q"
+2 QUIT
+3 ;
ASKOK(OLDLNO,IFLAG,USED) ; Function warns user, asks if OK to continue delete. 1/OK; 0/not OK
+1 NEW DIR,X,Y,ANS
+2 SET ANS=0
+3 IF USED=0
SET DIR("A")="Object has not been embedded in Boilerplate Text. Delete"
GOTO ASKOX
+4 SET DIR("A",1)="Entry "_OLDLNO_" is not presently used by any documents. If entry is deleted,"
+5 IF IFLAG
SET DIR("A",2)="any items UNDER it will be Orphans. I will delete entry as an item under its"
SET DIR("A")="parent AND as a Document Definition. It will no longer exist. OK"
+6 IF '$TEST
SET DIR("A",2)="any items UNDER it will be Orphans. I will delete entry as a Document"
SET DIR("A")="Definition. It will no longer exist. OK"
ASKOX SET DIR(0)="Y"
SET DIR("B")="NO"
DO ^DIR
SET ANS=Y
WRITE !
+1 QUIT ANS
+2 ;
CANTDEL(FILEDA,USED) ; Function returns 1 if FILEDA can't be deleted, else 0.
+1 NEW ANS,MSG
+2 SET ANS=0
+3 IF USED="YES"
SET MSG="Entry In Use by documents; Can't delete"
WRITE MSG,!
SET ANS=1
GOTO CANTX
+4 IF USED
SET MSG="Object embedded in boilerplate text; Can't delete"
WRITE !,MSG,!
SET ANS=1
GOTO CANTX
+5 ;**43**
IF $$HASAS^USRLFF(FILEDA)
SET MSG=" Entry has Authorizations/Subscriptions; Can't delete."
WRITE !!,MSG,!
SET ANS=1
GOTO CANTX
+6 IF $$FNDTITLE^DGPFAPI1(FILEDA)>0
SET MSG="Entry Associated with PRF Flag; Can't delete"
WRITE MSG,!
SET ANS=1
GOTO CANTX
+7 IF '$DATA(^TIU(8925.1,"AS",+^TMP("TIUF",$JOB,"STATI"),FILEDA))
IF $PIECE(^TIU(8925.1,FILEDA,0),U,7)
Begin DoDot:1
+8 SET MSG=" Status not INACTIVE; Can't delete"
WRITE MSG,!
SET ANS=1
End DoDot:1
GOTO CANTX
CANTX ;
+1 IF $DATA(MSG)
DO PAUSE^TIUFXHLX
+2 QUIT ANS
+3 ;
