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