TIUFT1 ; SLC/MAM - LM Template I (Items) Actions Delete, Edit/All, Mnemonic, Sequence, Menu Text, MTXTCHEC(DA,FILEDA,SILENT) ;4/17/97 11:02
;;1.0;TEXT INTEGRATION UTILITIES;**17,27,43,64**;Jun 20, 1997
;
MTXTCHEC(DA,FILEDA,SILENT,OLDMTXT,NEWMTXT) ; Check/Stuff/Inform Menu Text. **43**
; If no MTXT, or MTXT starts w space, or MTXT starts with ALL, stuff
;MTXT with first 20 chars of NAME (or, if NAME begins with ALL, begin
;MTXT w/ ALX instead of ALL).
; Requires array DA, i.e. DA(1) and DA, FILEDA, and SILENT.
; Returns OLD menu text (or NOTEN) in OLDMTXT if received.
; Returns NEW menu text (or NOENTRY) in NEWMTXT if received.
N NAMEOK
I $$MTXTOK(.DA,.OLDMTXT) S NEWMTXT=OLDMTXT G CHECX
S NAMEOK=1,NEWMTXT=$G(^TIU(8925.1,FILEDA,0),"NOENTRY^"),NEWMTXT=$P(NEWMTXT,U),NEWMTXT=$E(NEWMTXT,1,20)
I NEWMTXT="NOENTRY" G CHECX
I $E(NEWMTXT,1,3)="ALL" S NAMEOK=0
S NEWMTXT=$$MIXED^TIULS(NEWMTXT)
I 'NAMEOK S $E(NEWMTXT,3)="X"
D STUFF(.DA,NEWMTXT)
D:'SILENT MSG(NEWMTXT)
CHECX Q
;
MTXTOK(DA,MTXT) ; Function returns 0 if Menu Text begins with space or all (any case) or if there is no Menu Text. Menu Text (or NOTEN if no ten node) is returned in MTXT.
; Requires DA, DA(1)
N MTXTOK S MTXTOK=1
S MTXT=$G(^TIU(8925.1,DA(1),10,DA,0),"NOTEN")
I MTXT="NOTEN" S MTXTOK=0 G OKX
S MTXT=$P(MTXT,U,4)
I (MTXT="")!($E(MTXT)=" ")!($$UPPER^TIULS($E(MTXT,1,3))="ALL") S MTXTOK=0
OKX Q MTXTOK
;
STUFF(DA,MTXT) ; Stuff MTXT
N DIE,DR
S DR="4///"_MTXT,DIE="^TIU(8925.1,DA(1),10," D ^DIE
Q
;
MSG(MTXT) ; Inform user
I MTXT="NOTEN" W !!,"Item is missing from TIU DOCUMENT DEFINITION file. See IRM.",! Q
W !!,"Since item's Menu Text was bad or did not exist, item has been given Menu Text:",!,?5,MTXT,!
I $G(TIUFSTMP)'="T" W "To edit, select 'Detailed Display' for the PARENT, then select 'Items'.",!
H 3
Q
;
EDDEL ; Template T (Items for Entry) Actions DELETE, EDIT/ ALL, MNEMONIC, SEQUENCE, MENU TEXT
; Action Delete Items deletes item as an item only, NOT as a file entry.
; No need to update original screen since entry collapsed, will reexpand
; Requires arrays TIUFINFO, TIUFNOD0
N OLDLNO,SHIFT,TIUFDA10,LINENO,NODE0,NAME,INFO,TIUFERR,QUIT,TENDA
N DA,DIE,DR,DIR,DIK,X,Y,FILEDA,IFILEDA,DDEFUSED,INODE0,ITYPE,TIUFFULL
N ISTATUS,TIUFY,INATLFLG,TIUFXNOD,ISHARED,DTOUT,DIRUT,DIROUT
S TIUFXNOD=$G(XQORNOD(0)),VALMBCK="",TIUFFULL=0
S FILEDA=TIUFINFO("FILEDA")
I $P(TIUFXNOD,U,3)["Delete",$P(TIUFNOD0,U,13),TIUFWHO'="N",$P(TIUFNOD0,U,4)="DOC"!($P(TIUFNOD0,U,4)="CO") W !!," Parent is National, of Type TL or CO; Can't add or delete Items" D PAUSE^TIUFXHLX G EDDEX
L +^TIU(8925.1,FILEDA):1 I '$T W !!," Another user is editing this entry; Please try later",! H 2 G EDDEX
D EN^VALM2(TIUFXNOD,"O")
I '$O(VALMY(0)) G EDDEX
S OLDLNO=0,VALMBCK="R"
F S OLDLNO=$O(VALMY(OLDLNO)) Q:'OLDLNO D
. S TIUFDA10(OLDLNO)=$P(^TMP("TIUF2IDX",$J,OLDLNO),U,6)
. Q
S (OLDLNO,QUIT)=0,DA(1)=FILEDA
; Delete Items
I $P(TIUFXNOD,U,3)["Delete" D G EDDEX
. S DIR(0)="Y",DIR("A")="Sure you want to delete items",DIR("B")="NO"
. S DIR("?",1)="Delete on Items Screen deletes entries as items from the parent ONLY; they are"
. S DIR("?",2)="NOT deleted from the file itself. For more, enter ?? at the Select Action"
. S DIR("?")="prompt and see DELETE."
. D ^DIR S TIUFY=Y K DIR,X,Y,DUOUT I TIUFY'=1 S VALMBCK="" W !!,"NOT Deleted!",! H 1 Q
. N DIRUT
. F S OLDLNO=$O(TIUFDA10(OLDLNO)) Q:'OLDLNO D Q:$D(DIRUT)
. . S TENDA=TIUFDA10(OLDLNO)
. . S IFILEDA=+^TIU(8925.1,DA(1),10,TENDA,0)
. . S INODE0=$G(^TIU(8925.1,IFILEDA,0)),ISHARED=+$P(INODE0,U,10)
. . I INODE0="" W !!," Entry ",OLDLNO," does not exist in File; See IRM",! D PAUSE^TIUFXHLX Q
. . S INATLFLG=+$P(INODE0,U,13),ITYPE=$P(INODE0,U,4),ISTATUS=$$STATWORD^TIUFLF5($P(INODE0,U,7)) ;e.g INACTIVE
. . I INATLFLG,ITYPE'="CO",TIUFWHO'="N" W !!," Entry ",OLDLNO," can't be deleted from parent: Entry is National",! D PAUSE^TIUFXHLX Q ;P64 prohibit deletion of natl entries as items except for natl components
. . I TIUFWHO="C",'ISHARED W !!," Entry ",OLDLNO," can't be deleted from parent:",!,"Only Shared Components can be added/deleted.",! D PAUSE^TIUFXHLX Q
. . ; If not CO, don't permit Item delete if Used by Docmts
. . I ITYPE'="CO" D I DDEFUSED="YES",'$$OVERRIDE^TIUFHA2("delete entry "_OLDLNO_" from parent even though it is IN USE by documents") W !," Entry ",OLDLNO," NOT deleted" H 3 Q
. . . S DDEFUSED=$$DDEFUSED^TIUFLF(IFILEDA)
. . . I DDEFUSED="YES" W !!," Entry ",OLDLNO," can't be deleted from parent: In Use by documents",! I TIUFWHO="N" D FULL^VALM1,OVERWARN^TIUFHA2 S TIUFFULL=1
. . I ISTATUS'="INACTIVE" W !!," Entry ",OLDLNO," can't be deleted from parent: not INACTIVE",! D PAUSE^TIUFXHLX Q
. . I TIUFTMPL="A",$E(TIUFATTR)="P",$$ORPHAN^TIUFLF4(FILEDA,TIUFNOD0)="NO" S TIUFREDO=1 ;orphaning items below item
. . S DA=TENDA,DIK="^TIU(8925.1,DA(1),10," D ^DIK
. . W !!," Entry ",OLDLNO," Deleted from parent",! H 2
. . S LINENO=$O(^TMP("TIUF2IDX",$J,"DA10",TENDA,0))
. . S SHIFT=-1
. . D UPDATE^TIUFLLM1("T",SHIFT,LINENO-1) S VALMCNT=VALMCNT+SHIFT
. . I $G(TIUFERR) S QUIT=1
. . ; D screen will be updated when return from T to D.
. . Q
. D NODE0ARR^TIUFLF(FILEDA,.TIUFNOD0)
. Q
; Edit Items
D FULL^VALM1 S TIUFFULL=1
F S OLDLNO=$O(TIUFDA10(OLDLNO)) Q:'OLDLNO!QUIT D
. S QUIT=0
. S TENDA=TIUFDA10(OLDLNO)
. S LINENO=$O(^TMP("TIUF2IDX",$J,"DA10",TENDA,0))
. S INFO=^TMP("TIUF2IDX",$J,LINENO)
. S IFILEDA=$P(INFO,U,2),INODE0=$G(^TIU(8925.1,IFILEDA,0))
. I INODE0="" W !!," Item ",OLDLNO," Not in File! See IRM.",! D PAUSE^TIUFXHLX Q
. S ITYPE=$P(INODE0,U,4)
. W !!," Editing Entry ",OLDLNO
. I $P(TIUFXNOD,U,3)="Mnemonic" S DR="2"
. I $P(TIUFXNOD,U,3)="Sequence" S DR="3"
. I $P(TIUFXNOD,U,3)="Menu Text" S DR="4"
. I $P(TIUFXNOD,U,3)["All" S DR="3;2;4" I ITYPE'="CL",ITYPE'="DC" S DR="3;4"
. S DA=TENDA
. S DIE="^TIU(8925.1,DA(1),10," D ^DIE I $D(Y)!$D(DTOUT) S QUIT=1
. D MTXTCHEC(.DA,IFILEDA,0) H 4 ;If user left bad Menu Text by accepting bad existing value, stuff and inform user.
. Q
G:$D(DTOUT) EDDEX
D INIT^TIUFT
EDDEX I $D(DTOUT) S VALMBCK="Q"
L -^TIU(8925.1,+$G(FILEDA))
I $G(TIUFFULL) S VALMBCK="R" D RESET^TIUFXHLX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUFT1 6285 printed Apr 09, 2024@21:48:32 Page 2
TIUFT1 ; SLC/MAM - LM Template I (Items) Actions Delete, Edit/All, Mnemonic, Sequence, Menu Text, MTXTCHEC(DA,FILEDA,SILENT) ;4/17/97 11:02
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**17,27,43,64**;Jun 20, 1997
+2 ;
MTXTCHEC(DA,FILEDA,SILENT,OLDMTXT,NEWMTXT) ; Check/Stuff/Inform Menu Text. **43**
+1 ; If no MTXT, or MTXT starts w space, or MTXT starts with ALL, stuff
+2 ;MTXT with first 20 chars of NAME (or, if NAME begins with ALL, begin
+3 ;MTXT w/ ALX instead of ALL).
+4 ; Requires array DA, i.e. DA(1) and DA, FILEDA, and SILENT.
+5 ; Returns OLD menu text (or NOTEN) in OLDMTXT if received.
+6 ; Returns NEW menu text (or NOENTRY) in NEWMTXT if received.
+7 NEW NAMEOK
+8 IF $$MTXTOK(.DA,.OLDMTXT)
SET NEWMTXT=OLDMTXT
GOTO CHECX
+9 SET NAMEOK=1
SET NEWMTXT=$GET(^TIU(8925.1,FILEDA,0),"NOENTRY^")
SET NEWMTXT=$PIECE(NEWMTXT,U)
SET NEWMTXT=$EXTRACT(NEWMTXT,1,20)
+10 IF NEWMTXT="NOENTRY"
GOTO CHECX
+11 IF $EXTRACT(NEWMTXT,1,3)="ALL"
SET NAMEOK=0
+12 SET NEWMTXT=$$MIXED^TIULS(NEWMTXT)
+13 IF 'NAMEOK
SET $EXTRACT(NEWMTXT,3)="X"
+14 DO STUFF(.DA,NEWMTXT)
+15 if 'SILENT
DO MSG(NEWMTXT)
CHECX QUIT
+1 ;
MTXTOK(DA,MTXT) ; Function returns 0 if Menu Text begins with space or all (any case) or if there is no Menu Text. Menu Text (or NOTEN if no ten node) is returned in MTXT.
+1 ; Requires DA, DA(1)
+2 NEW MTXTOK
SET MTXTOK=1
+3 SET MTXT=$GET(^TIU(8925.1,DA(1),10,DA,0),"NOTEN")
+4 IF MTXT="NOTEN"
SET MTXTOK=0
GOTO OKX
+5 SET MTXT=$PIECE(MTXT,U,4)
+6 IF (MTXT="")!($EXTRACT(MTXT)=" ")!($$UPPER^TIULS($EXTRACT(MTXT,1,3))="ALL")
SET MTXTOK=0
OKX QUIT MTXTOK
+1 ;
STUFF(DA,MTXT) ; Stuff MTXT
+1 NEW DIE,DR
+2 SET DR="4///"_MTXT
SET DIE="^TIU(8925.1,DA(1),10,"
DO ^DIE
+3 QUIT
+4 ;
MSG(MTXT) ; Inform user
+1 IF MTXT="NOTEN"
WRITE !!,"Item is missing from TIU DOCUMENT DEFINITION file. See IRM.",!
QUIT
+2 WRITE !!,"Since item's Menu Text was bad or did not exist, item has been given Menu Text:",!,?5,MTXT,!
+3 IF $GET(TIUFSTMP)'="T"
WRITE "To edit, select 'Detailed Display' for the PARENT, then select 'Items'.",!
+4 HANG 3
+5 QUIT
+6 ;
EDDEL ; Template T (Items for Entry) Actions DELETE, EDIT/ ALL, MNEMONIC, SEQUENCE, MENU TEXT
+1 ; Action Delete Items deletes item as an item only, NOT as a file entry.
+2 ; No need to update original screen since entry collapsed, will reexpand
+3 ; Requires arrays TIUFINFO, TIUFNOD0
+4 NEW OLDLNO,SHIFT,TIUFDA10,LINENO,NODE0,NAME,INFO,TIUFERR,QUIT,TENDA
+5 NEW DA,DIE,DR,DIR,DIK,X,Y,FILEDA,IFILEDA,DDEFUSED,INODE0,ITYPE,TIUFFULL
+6 NEW ISTATUS,TIUFY,INATLFLG,TIUFXNOD,ISHARED,DTOUT,DIRUT,DIROUT
+7 SET TIUFXNOD=$GET(XQORNOD(0))
SET VALMBCK=""
SET TIUFFULL=0
+8 SET FILEDA=TIUFINFO("FILEDA")
+9 IF $PIECE(TIUFXNOD,U,3)["Delete"
IF $PIECE(TIUFNOD0,U,13)
IF TIUFWHO'="N"
IF $PIECE(TIUFNOD0,U,4)="DOC"!($PIECE(TIUFNOD0,U,4)="CO")
WRITE !!," Parent is National, of Type TL or CO; Can't add or delete Items"
DO PAUSE^TIUFXHLX
GOTO EDDEX
+10 LOCK +^TIU(8925.1,FILEDA):1
IF '$TEST
WRITE !!," Another user is editing this entry; Please try later",!
HANG 2
GOTO EDDEX
+11 DO EN^VALM2(TIUFXNOD,"O")
+12 IF '$ORDER(VALMY(0))
GOTO EDDEX
+13 SET OLDLNO=0
SET VALMBCK="R"
+14 FOR
SET OLDLNO=$ORDER(VALMY(OLDLNO))
if 'OLDLNO
QUIT
Begin DoDot:1
+15 SET TIUFDA10(OLDLNO)=$PIECE(^TMP("TIUF2IDX",$JOB,OLDLNO),U,6)
+16 QUIT
End DoDot:1
+17 SET (OLDLNO,QUIT)=0
SET DA(1)=FILEDA
+18 ; Delete Items
+19 IF $PIECE(TIUFXNOD,U,3)["Delete"
Begin DoDot:1
+20 SET DIR(0)="Y"
SET DIR("A")="Sure you want to delete items"
SET DIR("B")="NO"
+21 SET DIR("?",1)="Delete on Items Screen deletes entries as items from the parent ONLY; they are"
+22 SET DIR("?",2)="NOT deleted from the file itself. For more, enter ?? at the Select Action"
+23 SET DIR("?")="prompt and see DELETE."
+24 DO ^DIR
SET TIUFY=Y
KILL DIR,X,Y,DUOUT
IF TIUFY'=1
SET VALMBCK=""
WRITE !!,"NOT Deleted!",!
HANG 1
QUIT
+25 NEW DIRUT
+26 FOR
SET OLDLNO=$ORDER(TIUFDA10(OLDLNO))
if 'OLDLNO
QUIT
Begin DoDot:2
+27 SET TENDA=TIUFDA10(OLDLNO)
+28 SET IFILEDA=+^TIU(8925.1,DA(1),10,TENDA,0)
+29 SET INODE0=$GET(^TIU(8925.1,IFILEDA,0))
SET ISHARED=+$PIECE(INODE0,U,10)
+30 IF INODE0=""
WRITE !!," Entry ",OLDLNO," does not exist in File; See IRM",!
DO PAUSE^TIUFXHLX
QUIT
+31 ;e.g INACTIVE
SET INATLFLG=+$PIECE(INODE0,U,13)
SET ITYPE=$PIECE(INODE0,U,4)
SET ISTATUS=$$STATWORD^TIUFLF5($PIECE(INODE0,U,7))
+32 ;P64 prohibit deletion of natl entries as items except for natl components
IF INATLFLG
IF ITYPE'="CO"
IF TIUFWHO'="N"
WRITE !!," Entry ",OLDLNO," can't be deleted from parent: Entry is National",!
DO PAUSE^TIUFXHLX
QUIT
+33 IF TIUFWHO="C"
IF 'ISHARED
WRITE !!," Entry ",OLDLNO," can't be deleted from parent:",!,"Only Shared Components can be added/deleted.",!
DO PAUSE^TIUFXHLX
QUIT
+34 ; If not CO, don't permit Item delete if Used by Docmts
+35 IF ITYPE'="CO"
Begin DoDot:3
+36 SET DDEFUSED=$$DDEFUSED^TIUFLF(IFILEDA)
+37 IF DDEFUSED="YES"
WRITE !!," Entry ",OLDLNO," can't be deleted from parent: In Use by documents",!
IF TIUFWHO="N"
DO FULL^VALM1
DO OVERWARN^TIUFHA2
SET TIUFFULL=1
End DoDot:3
IF DDEFUSED="YES"
IF '$$OVERRIDE^TIUFHA2("delete entry "_OLDLNO_" from parent even though it is IN USE by documents")
WRITE !," Entry ",OLDLNO," NOT deleted"
HANG 3
QUIT
+38 IF ISTATUS'="INACTIVE"
WRITE !!," Entry ",OLDLNO," can't be deleted from parent: not INACTIVE",!
DO PAUSE^TIUFXHLX
QUIT
+39 ;orphaning items below item
IF TIUFTMPL="A"
IF $EXTRACT(TIUFATTR)="P"
IF $$ORPHAN^TIUFLF4(FILEDA,TIUFNOD0)="NO"
SET TIUFREDO=1
+40 SET DA=TENDA
SET DIK="^TIU(8925.1,DA(1),10,"
DO ^DIK
+41 WRITE !!," Entry ",OLDLNO," Deleted from parent",!
HANG 2
+42 SET LINENO=$ORDER(^TMP("TIUF2IDX",$JOB,"DA10",TENDA,0))
+43 SET SHIFT=-1
+44 DO UPDATE^TIUFLLM1("T",SHIFT,LINENO-1)
SET VALMCNT=VALMCNT+SHIFT
+45 IF $GET(TIUFERR)
SET QUIT=1
+46 ; D screen will be updated when return from T to D.
+47 QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
+48 DO NODE0ARR^TIUFLF(FILEDA,.TIUFNOD0)
+49 QUIT
End DoDot:1
GOTO EDDEX
+50 ; Edit Items
+51 DO FULL^VALM1
SET TIUFFULL=1
+52 FOR
SET OLDLNO=$ORDER(TIUFDA10(OLDLNO))
if 'OLDLNO!QUIT
QUIT
Begin DoDot:1
+53 SET QUIT=0
+54 SET TENDA=TIUFDA10(OLDLNO)
+55 SET LINENO=$ORDER(^TMP("TIUF2IDX",$JOB,"DA10",TENDA,0))
+56 SET INFO=^TMP("TIUF2IDX",$JOB,LINENO)
+57 SET IFILEDA=$PIECE(INFO,U,2)
SET INODE0=$GET(^TIU(8925.1,IFILEDA,0))
+58 IF INODE0=""
WRITE !!," Item ",OLDLNO," Not in File! See IRM.",!
DO PAUSE^TIUFXHLX
QUIT
+59 SET ITYPE=$PIECE(INODE0,U,4)
+60 WRITE !!," Editing Entry ",OLDLNO
+61 IF $PIECE(TIUFXNOD,U,3)="Mnemonic"
SET DR="2"
+62 IF $PIECE(TIUFXNOD,U,3)="Sequence"
SET DR="3"
+63 IF $PIECE(TIUFXNOD,U,3)="Menu Text"
SET DR="4"
+64 IF $PIECE(TIUFXNOD,U,3)["All"
SET DR="3;2;4"
IF ITYPE'="CL"
IF ITYPE'="DC"
SET DR="3;4"
+65 SET DA=TENDA
+66 SET DIE="^TIU(8925.1,DA(1),10,"
DO ^DIE
IF $DATA(Y)!$DATA(DTOUT)
SET QUIT=1
+67 ;If user left bad Menu Text by accepting bad existing value, stuff and inform user.
DO MTXTCHEC(.DA,IFILEDA,0)
HANG 4
+68 QUIT
End DoDot:1
+69 if $DATA(DTOUT)
GOTO EDDEX
+70 DO INIT^TIUFT
EDDEX IF $DATA(DTOUT)
SET VALMBCK="Q"
+1 LOCK -^TIU(8925.1,+$GET(FILEDA))
+2 IF $GET(TIUFFULL)
SET VALMBCK="R"
DO RESET^TIUFXHLX
+3 QUIT
