TIUFWRAP ;SPFO/AJB - Evaluate & Clean File #8927 ;04/06/22 12:5
;;1.0;TEXT INTEGRATION UTILITIES;**338,254**;Jun 20, 1997;Build 9
;
Q
;
EN ; main entry
N ANS,BU,C,OUTPUT,POP,X,Y
D HOME^%ZIS,PREP^XGF W IOCUON
D BACKUP^TIUFWRAP1(.BU,0) ; save a copy of #8927 in ^XTMP
S OUTPUT=$NA(^TMP($J,"OUTPUT")) K @OUTPUT
S ANS="" F D Q:ANS'=""
. N BROKEN,LONG,NOFLD,NOOBJ,UNLINKED
. F X="BROKEN","LONG","NOFLD","NOOBJ","UNLINKED" D
. . S @X@("COUNT")=0,@X=$NA(^TMP($J,X)) K ^TMP($J,X) ; reset counts, set temp global, clean temp global
. D DISPLAY^TIUFWRAP2("INFO")
. N DIR S DIR=$S(+BU:"SA^B:BACKUP;V:VIEW;P:PRINT;E:EMAIL;R:RESTORE;U:UPDATE;H:HELP;Q:QUIT",1:"SA^B:BACKUP;V:VIEW;P:PRINT;E:EMAIL;U:UPDATE;H:HELP;Q:QUIT")
. N PROMPT S PROMPT=$S(+BU:"VIEW, PRINT, EMAIL, RESTORE or UPDATE File #8927? ",1:"BACKUP, VIEW, PRINT, EMAIL or UPDATE File #8927? ")
. S ANS=$$FMR^TIUFWRAP2(DIR,PROMPT,"VIEW") Q:ANS=U!(ANS="Q")
. I ANS="B" D BACKUP^TIUFWRAP1(.BU,1) S ANS="" Q
. I ANS="R" D RESTORE^TIUFWRAP1 S ANS="" Q
. I ANS="U" D UPDATE^TIUFWRAP1(BU) S ANS="" Q
. I ANS="H" D HELP^TIUFWRAP2 S ANS="" Q
. I '$D(@OUTPUT) W !!,"Analyzing File #8927..." D
. . D GATHER^TIUFWRAP1(0,0) I $D(LONG)=1,$D(UNLINKED)=1,$D(BROKEN)=1,$D(NOFLD)=1 W !!,"No issues found...",! I $$FMR^TIUFWRAP2("EA","Press <Enter> to continue.")
. . D PREPOUT^TIUFWRAP1(.LONG,.OUTPUT,LONG("COUNT")_" Entries With Lines >80 Characters")
. . D PREPOUT^TIUFWRAP1(.UNLINKED,.OUTPUT,UNLINKED("COUNT")_" Entries With No Items, Pointers, or Text")
. . D PREPOUT^TIUFWRAP1(.BROKEN,.OUTPUT,BROKEN("COUNT")_" Entries With Broken Fields/Objects")
. . D PREPOUT^TIUFWRAP1(.NOFLD,.OUTPUT,NOFLD("COUNT")_" Entries With Broken/Missing Fields from #8927.1")
. . D PREPOUT^TIUFWRAP1(.NOOBJ,.OUTPUT,NOOBJ("COUNT")_" Entries With Missing Objects from #8925.1")
. I ANS="V" D VIEW^TIUFWRAP1 S ANS="" Q
. I ANS="P" D PRINT^TIUFWRAP1 S ANS="" Q
. I ANS="E" D EMAIL^TIUFWRAP1 S ANS="" Q
D CLEAN^XGF W !!
K @OUTPUT
Q
;
EE(IEN,LEVEL,PATH,LOD) ; evaluate entry
N NODE,NODE0,TYPE
S NODE0=$G(^TIU(8927,IEN,0)) ; zero node
S TYPE=$P(NODE0,U,3) ; type
S:LEVEL=0 PATH="" ; reset path
S $P(PATH,U,(LEVEL+1))=$P(NODE0,U) ; set path for traversing GUI Editor
F NODE=10,2 D ; items=10, boilerplate text=2
. N CNT,DATA,ITEM
. S (CNT,ITEM)=0 F S ITEM=$O(^TIU(8927,IEN,NODE,ITEM)) Q:'+ITEM D
. . I NODE=10 S CNT=CNT+1 ; increment count only for items
. . I CNT=1 S LEVEL=LEVEL+1 ; only increment LEVEL once/ien
. . ; value=item ien or value=line of boilerplate text
. . N VALUE S VALUE=^TIU(8927,IEN,NODE,ITEM,0),VALUE=$S(NODE=2:VALUE,1:$P(VALUE,U,2)) ; item ien is 2nd piece of 0 node
. . I NODE=10,'VALUE D:+UPDATE Q
. . . K ^TIU(8927,IEN,10,ITEM),^TIU(8927,IEN,10,"B",ITEM) ; remove broken item
. . ;
. . I NODE=10,'$$EE(VALUE,LEVEL,.PATH,LOD) D Q ; item not linked
. . . S PATH=$P(PATH,U,1,(LEVEL+1)) ; final path
. . . I +UPDATE D DEL(IEN,ITEM,VALUE) Q ; remove item and re-check entry
. . . S:'$D(@UNLINKED@(VALUE)) UNLINKED("COUNT")=$G(UNLINKED("COUNT"))+1 S @UNLINKED@(VALUE,"PATH")=PATH
. . I NODE=10 Q ; nothing more to do for items
. . ;
. . ; boilerplate text actions
. . I '+UPDATE D Q ; evaluate lines and quit
. . . S PATH=$P(PATH,U,1,(LEVEL+1)) ; final path
. . . N BENT S BENT=$$BROKEN(VALUE) ; broken entry?
. . . I +BENT D ; keep track of broken entries
. . . . S:'$D(@BROKEN@(IEN)) BROKEN("COUNT")=$G(BROKEN("COUNT"))+1,@BROKEN@(IEN,"PATH")=PATH
. . . . S:$G(@BROKEN@(IEN,"NODE"))'[ITEM @BROKEN@(IEN,"NODE")=$S($G(@BROKEN@(IEN,"NODE"))="":ITEM,1:@BROKEN@(IEN,"NODE")_U_ITEM)
. . . I '+BENT D CHKOF(VALUE) ; check object/fields for non-broken entries
. . . I '$$EX80(VALUE) Q ; exceed 80 characters after resolving fields? also checking for missing fields from #8927.1
. . . I $L(VALUE)'>80 Q ; length ok
. . . I '$$MERGE(VALUE) Q ; merge criteria?
. . . I '$$NXTLINE(IEN,ITEM) Q ; ok to merge with next line?
. . . S:'$D(@LONG@(IEN)) LONG("COUNT")=$G(LONG("COUNT"))+1,@LONG@(IEN,"PATH")=PATH
. . . S @LONG@(IEN,"NODE")=$S($G(@LONG@(IEN,"NODE"))="":ITEM,1:$G(@LONG@(IEN,"NODE"))_U_ITEM)
. . ;
. . ; update actions for boilerplate text
. . I $$BROKEN(VALUE) D FBF(IEN,ITEM,.VALUE) S VALUE=^TIU(8927,IEN,NODE,ITEM,0) ; fix broken fields & reset value
. . S VALUE=$$CLEAN(VALUE) ; clean the line of text
. . ;
. . N LAST S LAST=+$O(DATA(8927,IEN,NODE,""),-1) ; get last line of new data
. . S LAST=LAST+1 ; increment
. . S DATA(8927,IEN,NODE,LAST,0)=VALUE ; save the line for update
. . I LOD=1 Q ; basic update and quit
. . I $L(VALUE)'>80 Q ; length ok
. . I '$$MERGE(VALUE) Q ; merge criteria?
. . ; implement levels of wrapping aggression
. . I LOD=2 D WRAP(.DATA,IEN,NODE,.LAST) Q ; intermediate update and quit
. . ; advanced update
. . F Q:'$$NXTLINE(IEN,ITEM) D
. . . S ITEM=$O(^TIU(8927,IEN,NODE,ITEM))
. . . S VALUE=$$CLEAN(^TIU(8927,IEN,NODE,ITEM,0))
. . . S DATA(8927,IEN,NODE,LAST,0)=DATA(8927,IEN,NODE,LAST,0)_$S($E(VALUE)=" ":"",1:" ")_VALUE
. . D WRAP(.DATA,IEN,NODE,.LAST)
. ; set global with new data
. I NODE=2,+UPDATE,$D(DATA) D
. . N TOTAL S TOTAL=$O(DATA(8927,IEN,2,""),-1) ; total # of line
. . S DATA(8927,IEN,2,0)="^^"_TOTAL_"^"_TOTAL_"^"_DT_"^^" ; set the new 0 node
. . K ^TIU(8927,IEN,2) M ^TIU(8927,IEN,2)=DATA(8927,IEN,2) ; replace old with new text
; linked to REMINDER DIALOG or COM OBJECT or LINK or has BOILERPLATE TEXT or has ITEMS?
Q $S(+$P(NODE0,U,15):1,+$P(NODE0,U,17):1,+$P(NODE0,U,19):1,+$$HASBPTXT(IEN):1,+$$HASITEMS(IEN):1,1:0)
;
FBF(IEN,NODE,LINE) ; fix broken fields/objects
; only evaluates the current line and the next line
; case #1 - missing a single closing bracket at the end of a line
; either missing the bracket or wrapped
N CONT,FLD S CONT=1 F FLD="{FLD:","{FLD","{FL","{F" D
. I LINE[FLD,$P(LINE,FLD,$L(LINE,FLD))'["}" D
. . Q:'CONT ; continue only if line not fixed
. . N CL,FNAME,NL S FNAME=$P(LINE,FLD,$L(LINE,FLD))
. . S CL=LINE,NL=$O(^TIU(8927,IEN,2,NODE)) S:+NL NL=^TIU(8927,IEN,2,NL,0)
. . ; if name is good, fix and quit
. . I FNAME'="",+$O(^TIU(8927.1,"B",FNAME,"")) S ^TIU(8927,IEN,2,NODE,0)=CL_"}" Q
. . S FNAME=FNAME_$P(NL,"}") ; grab first piece of next line (name was wrapped?)
. . S CL=CL_$P(NL,"}")_"}" ; set the current line with the bracket
. . S NL=$P(NL,"}",2,999) ; remove first piece from next line and get everything else
. . I $$BROKEN(CL) Q ; quit if the line is still broken or the field doesn't exist
. . S ^TIU(8927,IEN,2,NODE,0)=CL ; set current line
. . S ^TIU(8927,IEN,2,$O(^TIU(8927,IEN,2,NODE)),0)=NL ; set next line
. . S CONT=0 ; don't continue, all done
; case #2 - missing a single closing | for objects at the end of a line
; either missing the | or wrapped
I '($L(LINE,"|")#2) D
. N CL,NL,ONOK,ONAME S ONOK=0,ONAME=$P(LINE,"|",$L(LINE,"|")) Q:ONAME="" ; quit if name is null
. S CL=LINE,NL=$O(^TIU(8927,IEN,2,NODE)) S:+NL NL=^TIU(8927,IEN,2,NL,0)
. ; if object name exists, fix and quit
. I +$$CHKOBJ(ONAME,"B") S ^TIU(8927,IEN,2,NODE,0)=CL_"|" Q
. S ONAME=ONAME_$P(NL,"|") ; grab the first piece of the next line (name was wrapped?)
. S CL=CL_$P(NL,"|")_"|" ; set the current line with the bracket
. S NL=$P(NL,"|",2,999) ; remove first piece from next line and get everything else
. I $$BROKEN(CL) Q ; sad
. I '$$CHKOBJ(ONAME,"B") D ; couldn't find the object name
. . S:'$D(@NOOBJ@(IEN)) NOOBJ("COUNT")=+$G(NOOBJ("COUNT"))+1,@NOOBJ@(IEN,"PATH")=$P($G(PATH),U,1,LEVEL+1)
. . S:$G(@NOOBJ@(IEN,"NODE"))'[ITEM @NOOBJ@(IEN,"NODE")=$S($G(@NOOBJ@(IEN,"NODE"))="":ITEM,1:$G(@NOOBJ@(IEN,"NODE"))_U_ITEM)
. S ^TIU(8927,IEN,2,NODE,0)=CL ; set current line
. S:+$O(^TIU(8927,IEN,2,NODE)) ^TIU(8927,IEN,2,$O(^TIU(8927,IEN,2,NODE)),0)=NL ; set next line
Q
;
CHKOF(DATA) ; check the object/fields in a non-broken line
N FLD,NUM,OBJ
I DATA'["FLD:",(DATA'["|") Q
I DATA["|" F NUM=2:1:$L(DATA,"|") D:'(NUM#2) ; check objects
. N ONAME S ONAME=$P(DATA,"|",NUM) I $$CHKOBJ(ONAME,"B") Q ; object exists
. S:'$D(@NOOBJ@(IEN)) NOOBJ("COUNT")=+$G(NOOBJ("COUNT"))+1,@NOOBJ@(IEN,"PATH")=$P($G(PATH),U,1,LEVEL+1)
. S:$G(@NOOBJ@(IEN,"NODE"))'[ITEM @NOOBJ@(IEN,"NODE")=$S($G(@NOOBJ@(IEN,"NODE"))="":ITEM,1:$G(@NOOBJ@(IEN,"NODE"))_U_ITEM)
I DATA["{FLD:" F NUM=2:1:$L(DATA,"{FLD:") D ; check fields
. N FNAME S FNAME=$P($P(DATA,"{FLD:",NUM),"}")
. I FNAME="" D Q
. . S:'$D(@NOFLD@(IEN)) NOFLD("COUNT")=$G(NOFLD("COUNT"))+1,@NOFLD@(IEN,"PATH")=PATH
. . S @NOFLD@(IEN,"NODE")=$S($G(@NOFLD@(IEN,"NODE"))="":ITEM,1:$G(@NOFLD@(IEN,"NODE"))_U_ITEM)
. I $O(^TIU(8927.1,"B",FNAME,"")) Q
. S:'$D(@NOFLD@(IEN)) NOFLD("COUNT")=+$G(NOFLD("COUNT"))+1,@NOFLD@(IEN,"PATH")=$P($G(PATH),U,1,LEVEL+1)
. S:$G(@NOFLD@(IEN,"NODE"))'[ITEM @NOFLD@(IEN,"NODE")=$S($G(@NOFLD@(IEN,"NODE"))="":ITEM,1:$G(@NOFLD@(IEN,"NODE"))_U_ITEM)
Q
;
CHKOBJ(NAME,XREF) ; check if object exists
Q:NAME="" 0
N ANS,TIUDA S TIUDA=0 F S TIUDA=$O(^TIU(8925.1,XREF,NAME,TIUDA)) Q:'TIUDA D
. I $D(^TIU(8925.1,"AT","O",TIUDA)) S ANS=1
Q +$G(ANS)
;
NXTLINE(IEN,ITEM) ; evaluate next line for suitability to merge
N LINE S LINE=$O(^TIU(8927,IEN,2,ITEM)) Q:'+LINE 0 ; quit if there isn't a next line
S LINE=$G(^TIU(8927,IEN,2,LINE,0)) ; set the next line
; criteria to disqualify a line
I LINE=""!(LINE["{FLD:")!(LINE["}")!(LINE["|")!(LINE["(")!(LINE[")") Q 0
Q 1
;
BROKEN(TEXT) ; check for broken field/object
N RESULT S RESULT=0
; assume any use of {F is a template field - might be too aggressive...
I TEXT["|",'($L(TEXT,"|")#2) S RESULT=1 Q RESULT
;N FLD F FLD="{FLD:","{FLD","{FL","{F" D
N FLD F FLD="{F" D
. I TEXT[FLD,$P(TEXT,FLD,$L(TEXT,FLD))'["}" D
. . N X F X=2:1:$L(TEXT,FLD) I $P(TEXT,FLD,X)'["}" S RESULT=1
Q RESULT
;
WRAP(DATA,IEN,NODE,LAST) ;
N LINE,NODE0,REP,REP2,TIUFT,X
S LAST("Start")=(LAST-1),NODE0=DATA(8927,IEN,NODE,LAST,0)
I '+$$EX80(NODE0) Q ; check fields to see if line needs to be wrapped
D WRAP^TIUFLD(NODE0,80) ; wrap
S LINE=0 F S LINE=$O(TIUFT(LINE)) Q:'+LINE D ; set the new line of data
. S DATA(8927,IEN,NODE,LAST,0)=TIUFT(LINE) S:+$O(TIUFT(LINE)) LAST=LAST+1 ; increment if more lines
Q
;
EX80(DATA) ; checks field(s) length
Q:DATA'["{FLD:" 1 ; no field
N FLD,LENGTH,RESULT S LENGTH=$L(DATA),RESULT=1
F FLD=2:1:$L(DATA,"{FLD:") D
. N FIEN,FNAME S FNAME=$P($P(DATA,"{FLD:",FLD),"}") Q:FNAME="" S FIEN=$O(^TIU(8927.1,"B",FNAME,""))
. I 'FIEN D Q ; field name missing from 8927.1
. . S:'$D(@NOFLD@(IEN)) NOFLD("COUNT")=+$G(NOFLD("COUNT"))+1,@NOFLD@(IEN,"PATH")=$P($G(PATH),U,1,LEVEL+1)
. . S:$G(@NOFLD@(IEN,"NODE"))'[ITEM @NOFLD@(IEN,"NODE")=$S($G(@NOFLD@(IEN,"NODE"))="":ITEM,1:$G(@NOFLD@(IEN,"NODE"))_U_ITEM)
. N NODE0 S NODE0=$G(^TIU(8927.1,FIEN,0))
. S LENGTH=LENGTH-($L(FNAME)+6) ; subtract the length of the name and brackets
. N MAXLEN ; maximum length
. S MAXLEN(+$P(NODE0,U,4))="" ; length of field
. S MAXLEN(+$P(NODE0,U,10))="" ; max length of field
. S MAXLEN(+$L($P(NODE0,U,6)))="" ; length of LM text
. S LENGTH=LENGTH+($O(MAXLEN(""),-1)) ; add the longest to the length
Q $S(LENGTH'>80:0,1:1)
;
MERGE(DATA) ; merge lines of text criteria
N RESULT S RESULT=1
Q:$E(DATA,$L(DATA))="}" 0 ; if the last character of the line is a field, do not merge
Q:$E(DATA,$L(DATA))="|" 0 ; if the last character of the line is an object, do not merge
Q RESULT
;
DEL(PARENT,ITEM,CHILD) ;
N TYPE S TYPE=$P($G(^TIU(8927,CHILD,0)),U,3)
Q:TYPE="R"!(TYPE="CF")!(TYPE="TF")!(TYPE="OF") ; NEVER delete root folders
N %,DA,DIK,X,Y
S DA=CHILD,DIK="^TIU(8927," D:+DA ^DIK ; delete entry
I +$G(PARENT)=0 Q
S DA=ITEM,DA(1)=PARENT,DIK="^TIU(8927,"_DA(1)_",10," D ^DIK ; delete entry from ITEM list of PARENT
Q
;
HASBPTXT(IEN) ; does entry have BOILERPLATE TEXT?
Q $O(^TIU(8927,IEN,2,0))
;
HASITEMS(IEN) ; does entry have ITEMS?
Q $O(^TIU(8927,IEN,10,0))
;
CLEAN(DATA) ;
; remove trailing spaces, replace characters, remove control characters
S DATA=$$RTS(DATA)
S DATA=$$REPLACE(DATA)
S DATA=$$CTRL(DATA)
Q DATA
;
RTS(X) ; remove trailing spaces
F Q:$E(X,$L(X))'=" " S X=$E(X,1,$L(X)-1)
Q X
;
REPLACE(DATA) ; replace characters
N REP S REP($C(9))=" ",REP($C(149))=" - ",REP("$c")="$C" ; setup replacment characters
S REP("{{")="{",REP("}}")="}" ; fix double field brackets
Q $$REPLACE^XLFSTR(DATA,.REP)
;
CTRL(X) ; remove all control characters
N I S I=1 F Q:X'?.E1C.E D
. F I=I:1 Q:$E(X,I)?1C
. S X=$E(X,1,I-1)_$E(X,I+1,999)
Q X
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUFWRAP 12675 printed Jan 18, 2025@03:42:33 Page 2
TIUFWRAP ;SPFO/AJB - Evaluate & Clean File #8927 ;04/06/22 12:5
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**338,254**;Jun 20, 1997;Build 9
+2 ;
+3 QUIT
+4 ;
EN ; main entry
+1 NEW ANS,BU,C,OUTPUT,POP,X,Y
+2 DO HOME^%ZIS
DO PREP^XGF
WRITE IOCUON
+3 ; save a copy of #8927 in ^XTMP
DO BACKUP^TIUFWRAP1(.BU,0)
+4 SET OUTPUT=$NAME(^TMP($JOB,"OUTPUT"))
KILL @OUTPUT
+5 SET ANS=""
FOR
Begin DoDot:1
+6 NEW BROKEN,LONG,NOFLD,NOOBJ,UNLINKED
+7 FOR X="BROKEN","LONG","NOFLD","NOOBJ","UNLINKED"
Begin DoDot:2
+8 ; reset counts, set temp global, clean temp global
SET @X@("COUNT")=0
SET @X=$NAME(^TMP($JOB,X))
KILL ^TMP($JOB,X)
End DoDot:2
+9 DO DISPLAY^TIUFWRAP2("INFO")
+10 NEW DIR
SET DIR=$SELECT(+BU:"SA^B:BACKUP;V:VIEW;P:PRINT;E:EMAIL;R:RESTORE;U:UPDATE;H:HELP;Q:QUIT",1:"SA^B:BACKUP;V:VIEW;P:PRINT;E:EMAIL;U:UPDATE;H:HELP;Q:QUIT")
+11 NEW PROMPT
SET PROMPT=$SELECT(+BU:"VIEW, PRINT, EMAIL, RESTORE or UPDATE File #8927? ",1:"BACKUP, VIEW, PRINT, EMAIL or UPDATE File #8927? ")
+12 SET ANS=$$FMR^TIUFWRAP2(DIR,PROMPT,"VIEW")
if ANS=U!(ANS="Q")
QUIT
+13 IF ANS="B"
DO BACKUP^TIUFWRAP1(.BU,1)
SET ANS=""
QUIT
+14 IF ANS="R"
DO RESTORE^TIUFWRAP1
SET ANS=""
QUIT
+15 IF ANS="U"
DO UPDATE^TIUFWRAP1(BU)
SET ANS=""
QUIT
+16 IF ANS="H"
DO HELP^TIUFWRAP2
SET ANS=""
QUIT
+17 IF '$DATA(@OUTPUT)
WRITE !!,"Analyzing File #8927..."
Begin DoDot:2
+18 DO GATHER^TIUFWRAP1(0,0)
IF $DATA(LONG)=1
IF $DATA(UNLINKED)=1
IF $DATA(BROKEN)=1
IF $DATA(NOFLD)=1
WRITE !!,"No issues found...",!
IF $$FMR^TIUFWRAP2("EA","Press <Enter> to continue.")
+19 DO PREPOUT^TIUFWRAP1(.LONG,.OUTPUT,LONG("COUNT")_" Entries With Lines >80 Characters")
+20 DO PREPOUT^TIUFWRAP1(.UNLINKED,.OUTPUT,UNLINKED("COUNT")_" Entries With No Items, Pointers, or Text")
+21 DO PREPOUT^TIUFWRAP1(.BROKEN,.OUTPUT,BROKEN("COUNT")_" Entries With Broken Fields/Objects")
+22 DO PREPOUT^TIUFWRAP1(.NOFLD,.OUTPUT,NOFLD("COUNT")_" Entries With Broken/Missing Fields from #8927.1")
+23 DO PREPOUT^TIUFWRAP1(.NOOBJ,.OUTPUT,NOOBJ("COUNT")_" Entries With Missing Objects from #8925.1")
End DoDot:2
+24 IF ANS="V"
DO VIEW^TIUFWRAP1
SET ANS=""
QUIT
+25 IF ANS="P"
DO PRINT^TIUFWRAP1
SET ANS=""
QUIT
+26 IF ANS="E"
DO EMAIL^TIUFWRAP1
SET ANS=""
QUIT
End DoDot:1
if ANS'=""
QUIT
+27 DO CLEAN^XGF
WRITE !!
+28 KILL @OUTPUT
+29 QUIT
+30 ;
EE(IEN,LEVEL,PATH,LOD) ; evaluate entry
+1 NEW NODE,NODE0,TYPE
+2 ; zero node
SET NODE0=$GET(^TIU(8927,IEN,0))
+3 ; type
SET TYPE=$PIECE(NODE0,U,3)
+4 ; reset path
if LEVEL=0
SET PATH=""
+5 ; set path for traversing GUI Editor
SET $PIECE(PATH,U,(LEVEL+1))=$PIECE(NODE0,U)
+6 ; items=10, boilerplate text=2
FOR NODE=10,2
Begin DoDot:1
+7 NEW CNT,DATA,ITEM
+8 SET (CNT,ITEM)=0
FOR
SET ITEM=$ORDER(^TIU(8927,IEN,NODE,ITEM))
if '+ITEM
QUIT
Begin DoDot:2
+9 ; increment count only for items
IF NODE=10
SET CNT=CNT+1
+10 ; only increment LEVEL once/ien
IF CNT=1
SET LEVEL=LEVEL+1
+11 ; value=item ien or value=line of boilerplate text
+12 ; item ien is 2nd piece of 0 node
NEW VALUE
SET VALUE=^TIU(8927,IEN,NODE,ITEM,0)
SET VALUE=$SELECT(NODE=2:VALUE,1:$PIECE(VALUE,U,2))
+13 IF NODE=10
IF 'VALUE
if +UPDATE
Begin DoDot:3
+14 ; remove broken item
KILL ^TIU(8927,IEN,10,ITEM),^TIU(8927,IEN,10,"B",ITEM)
End DoDot:3
QUIT
+15 ;
+16 ; item not linked
IF NODE=10
IF '$$EE(VALUE,LEVEL,.PATH,LOD)
Begin DoDot:3
+17 ; final path
SET PATH=$PIECE(PATH,U,1,(LEVEL+1))
+18 ; remove item and re-check entry
IF +UPDATE
DO DEL(IEN,ITEM,VALUE)
QUIT
+19 if '$DATA(@UNLINKED@(VALUE))
SET UNLINKED("COUNT")=$GET(UNLINKED("COUNT"))+1
SET @UNLINKED@(VALUE,"PATH")=PATH
End DoDot:3
QUIT
+20 ; nothing more to do for items
IF NODE=10
QUIT
+21 ;
+22 ; boilerplate text actions
+23 ; evaluate lines and quit
IF '+UPDATE
Begin DoDot:3
+24 ; final path
SET PATH=$PIECE(PATH,U,1,(LEVEL+1))
+25 ; broken entry?
NEW BENT
SET BENT=$$BROKEN(VALUE)
+26 ; keep track of broken entries
IF +BENT
Begin DoDot:4
+27 if '$DATA(@BROKEN@(IEN))
SET BROKEN("COUNT")=$GET(BROKEN("COUNT"))+1
SET @BROKEN@(IEN,"PATH")=PATH
+28 if $GET(@BROKEN@(IEN,"NODE"))'[ITEM
SET @BROKEN@(IEN,"NODE")=$SELECT($GET(@BROKEN@(IEN,"NODE"))="":ITEM,1:@BROKEN@(IEN,"NODE")_U_ITEM)
End DoDot:4
+29 ; check object/fields for non-broken entries
IF '+BENT
DO CHKOF(VALUE)
+30 ; exceed 80 characters after resolving fields? also checking for missing fields from #8927.1
IF '$$EX80(VALUE)
QUIT
+31 ; length ok
IF $LENGTH(VALUE)'>80
QUIT
+32 ; merge criteria?
IF '$$MERGE(VALUE)
QUIT
+33 ; ok to merge with next line?
IF '$$NXTLINE(IEN,ITEM)
QUIT
+34 if '$DATA(@LONG@(IEN))
SET LONG("COUNT")=$GET(LONG("COUNT"))+1
SET @LONG@(IEN,"PATH")=PATH
+35 SET @LONG@(IEN,"NODE")=$SELECT($GET(@LONG@(IEN,"NODE"))="":ITEM,1:$GET(@LONG@(IEN,"NODE"))_U_ITEM)
End DoDot:3
QUIT
+36 ;
+37 ; update actions for boilerplate text
+38 ; fix broken fields & reset value
IF $$BROKEN(VALUE)
DO FBF(IEN,ITEM,.VALUE)
SET VALUE=^TIU(8927,IEN,NODE,ITEM,0)
+39 ; clean the line of text
SET VALUE=$$CLEAN(VALUE)
+40 ;
+41 ; get last line of new data
NEW LAST
SET LAST=+$ORDER(DATA(8927,IEN,NODE,""),-1)
+42 ; increment
SET LAST=LAST+1
+43 ; save the line for update
SET DATA(8927,IEN,NODE,LAST,0)=VALUE
+44 ; basic update and quit
IF LOD=1
QUIT
+45 ; length ok
IF $LENGTH(VALUE)'>80
QUIT
+46 ; merge criteria?
IF '$$MERGE(VALUE)
QUIT
+47 ; implement levels of wrapping aggression
+48 ; intermediate update and quit
IF LOD=2
DO WRAP(.DATA,IEN,NODE,.LAST)
QUIT
+49 ; advanced update
+50 FOR
if '$$NXTLINE(IEN,ITEM)
QUIT
Begin DoDot:3
+51 SET ITEM=$ORDER(^TIU(8927,IEN,NODE,ITEM))
+52 SET VALUE=$$CLEAN(^TIU(8927,IEN,NODE,ITEM,0))
+53 SET DATA(8927,IEN,NODE,LAST,0)=DATA(8927,IEN,NODE,LAST,0)_$SELECT($EXTRACT(VALUE)=" ":"",1:" ")_VALUE
End DoDot:3
+54 DO WRAP(.DATA,IEN,NODE,.LAST)
End DoDot:2
+55 ; set global with new data
+56 IF NODE=2
IF +UPDATE
IF $DATA(DATA)
Begin DoDot:2
+57 ; total # of line
NEW TOTAL
SET TOTAL=$ORDER(DATA(8927,IEN,2,""),-1)
+58 ; set the new 0 node
SET DATA(8927,IEN,2,0)="^^"_TOTAL_"^"_TOTAL_"^"_DT_"^^"
+59 ; replace old with new text
KILL ^TIU(8927,IEN,2)
MERGE ^TIU(8927,IEN,2)=DATA(8927,IEN,2)
End DoDot:2
End DoDot:1
+60 ; linked to REMINDER DIALOG or COM OBJECT or LINK or has BOILERPLATE TEXT or has ITEMS?
+61 QUIT $SELECT(+$PIECE(NODE0,U,15):1,+$PIECE(NODE0,U,17):1,+$PIECE(NODE0,U,19):1,+$$HASBPTXT(IEN):1,+$$HASITEMS(IEN):1,1:0)
+62 ;
FBF(IEN,NODE,LINE) ; fix broken fields/objects
+1 ; only evaluates the current line and the next line
+2 ; case #1 - missing a single closing bracket at the end of a line
+3 ; either missing the bracket or wrapped
+4 NEW CONT,FLD
SET CONT=1
FOR FLD="{FLD:","{FLD","{FL","{F"
Begin DoDot:1
+5 IF LINE[FLD
IF $PIECE(LINE,FLD,$LENGTH(LINE,FLD))'["}"
Begin DoDot:2
+6 ; continue only if line not fixed
if 'CONT
QUIT
+7 NEW CL,FNAME,NL
SET FNAME=$PIECE(LINE,FLD,$LENGTH(LINE,FLD))
+8 SET CL=LINE
SET NL=$ORDER(^TIU(8927,IEN,2,NODE))
if +NL
SET NL=^TIU(8927,IEN,2,NL,0)
+9 ; if name is good, fix and quit
+10 IF FNAME'=""
IF +$ORDER(^TIU(8927.1,"B",FNAME,""))
SET ^TIU(8927,IEN,2,NODE,0)=CL_"}"
QUIT
+11 ; grab first piece of next line (name was wrapped?)
SET FNAME=FNAME_$PIECE(NL,"}")
+12 ; set the current line with the bracket
SET CL=CL_$PIECE(NL,"}")_"}"
+13 ; remove first piece from next line and get everything else
SET NL=$PIECE(NL,"}",2,999)
+14 ; quit if the line is still broken or the field doesn't exist
IF $$BROKEN(CL)
QUIT
+15 ; set current line
SET ^TIU(8927,IEN,2,NODE,0)=CL
+16 ; set next line
SET ^TIU(8927,IEN,2,$ORDER(^TIU(8927,IEN,2,NODE)),0)=NL
+17 ; don't continue, all done
SET CONT=0
End DoDot:2
End DoDot:1
+18 ; case #2 - missing a single closing | for objects at the end of a line
+19 ; either missing the | or wrapped
+20 IF '($LENGTH(LINE,"|")#2)
Begin DoDot:1
+21 ; quit if name is null
NEW CL,NL,ONOK,ONAME
SET ONOK=0
SET ONAME=$PIECE(LINE,"|",$LENGTH(LINE,"|"))
if ONAME=""
QUIT
+22 SET CL=LINE
SET NL=$ORDER(^TIU(8927,IEN,2,NODE))
if +NL
SET NL=^TIU(8927,IEN,2,NL,0)
+23 ; if object name exists, fix and quit
+24 IF +$$CHKOBJ(ONAME,"B")
SET ^TIU(8927,IEN,2,NODE,0)=CL_"|"
QUIT
+25 ; grab the first piece of the next line (name was wrapped?)
SET ONAME=ONAME_$PIECE(NL,"|")
+26 ; set the current line with the bracket
SET CL=CL_$PIECE(NL,"|")_"|"
+27 ; remove first piece from next line and get everything else
SET NL=$PIECE(NL,"|",2,999)
+28 ; sad
IF $$BROKEN(CL)
QUIT
+29 ; couldn't find the object name
IF '$$CHKOBJ(ONAME,"B")
Begin DoDot:2
+30 if '$DATA(@NOOBJ@(IEN))
SET NOOBJ("COUNT")=+$GET(NOOBJ("COUNT"))+1
SET @NOOBJ@(IEN,"PATH")=$PIECE($GET(PATH),U,1,LEVEL+1)
+31 if $GET(@NOOBJ@(IEN,"NODE"))'[ITEM
SET @NOOBJ@(IEN,"NODE")=$SELECT($GET(@NOOBJ@(IEN,"NODE"))="":ITEM,1:$GET(@NOOBJ@(IEN,"NODE"))_U_ITEM)
End DoDot:2
+32 ; set current line
SET ^TIU(8927,IEN,2,NODE,0)=CL
+33 ; set next line
if +$ORDER(^TIU(8927,IEN,2,NODE))
SET ^TIU(8927,IEN,2,$ORDER(^TIU(8927,IEN,2,NODE)),0)=NL
End DoDot:1
+34 QUIT
+35 ;
CHKOF(DATA) ; check the object/fields in a non-broken line
+1 NEW FLD,NUM,OBJ
+2 IF DATA'["FLD:"
IF (DATA'["|")
QUIT
+3 ; check objects
IF DATA["|"
FOR NUM=2:1:$LENGTH(DATA,"|")
if '(NUM#2)
Begin DoDot:1
+4 ; object exists
NEW ONAME
SET ONAME=$PIECE(DATA,"|",NUM)
IF $$CHKOBJ(ONAME,"B")
QUIT
+5 if '$DATA(@NOOBJ@(IEN))
SET NOOBJ("COUNT")=+$GET(NOOBJ("COUNT"))+1
SET @NOOBJ@(IEN,"PATH")=$PIECE($GET(PATH),U,1,LEVEL+1)
+6 if $GET(@NOOBJ@(IEN,"NODE"))'[ITEM
SET @NOOBJ@(IEN,"NODE")=$SELECT($GET(@NOOBJ@(IEN,"NODE"))="":ITEM,1:$GET(@NOOBJ@(IEN,"NODE"))_U_ITEM)
End DoDot:1
+7 ; check fields
IF DATA["{FLD:"
FOR NUM=2:1:$LENGTH(DATA,"{FLD:")
Begin DoDot:1
+8 NEW FNAME
SET FNAME=$PIECE($PIECE(DATA,"{FLD:",NUM),"}")
+9 IF FNAME=""
Begin DoDot:2
+10 if '$DATA(@NOFLD@(IEN))
SET NOFLD("COUNT")=$GET(NOFLD("COUNT"))+1
SET @NOFLD@(IEN,"PATH")=PATH
+11 SET @NOFLD@(IEN,"NODE")=$SELECT($GET(@NOFLD@(IEN,"NODE"))="":ITEM,1:$GET(@NOFLD@(IEN,"NODE"))_U_ITEM)
End DoDot:2
QUIT
+12 IF $ORDER(^TIU(8927.1,"B",FNAME,""))
QUIT
+13 if '$DATA(@NOFLD@(IEN))
SET NOFLD("COUNT")=+$GET(NOFLD("COUNT"))+1
SET @NOFLD@(IEN,"PATH")=$PIECE($GET(PATH),U,1,LEVEL+1)
+14 if $GET(@NOFLD@(IEN,"NODE"))'[ITEM
SET @NOFLD@(IEN,"NODE")=$SELECT($GET(@NOFLD@(IEN,"NODE"))="":ITEM,1:$GET(@NOFLD@(IEN,"NODE"))_U_ITEM)
End DoDot:1
+15 QUIT
+16 ;
CHKOBJ(NAME,XREF) ; check if object exists
+1 if NAME=""
QUIT 0
+2 NEW ANS,TIUDA
SET TIUDA=0
FOR
SET TIUDA=$ORDER(^TIU(8925.1,XREF,NAME,TIUDA))
if 'TIUDA
QUIT
Begin DoDot:1
+3 IF $DATA(^TIU(8925.1,"AT","O",TIUDA))
SET ANS=1
End DoDot:1
+4 QUIT +$GET(ANS)
+5 ;
NXTLINE(IEN,ITEM) ; evaluate next line for suitability to merge
+1 ; quit if there isn't a next line
NEW LINE
SET LINE=$ORDER(^TIU(8927,IEN,2,ITEM))
if '+LINE
QUIT 0
+2 ; set the next line
SET LINE=$GET(^TIU(8927,IEN,2,LINE,0))
+3 ; criteria to disqualify a line
+4 IF LINE=""!(LINE["{FLD:")!(LINE["}")!(LINE["|")!(LINE["(")!(LINE[")")
QUIT 0
+5 QUIT 1
+6 ;
BROKEN(TEXT) ; check for broken field/object
+1 NEW RESULT
SET RESULT=0
+2 ; assume any use of {F is a template field - might be too aggressive...
+3 IF TEXT["|"
IF '($LENGTH(TEXT,"|")#2)
SET RESULT=1
QUIT RESULT
+4 ;N FLD F FLD="{FLD:","{FLD","{FL","{F" D
+5 NEW FLD
FOR FLD="{F"
Begin DoDot:1
+6 IF TEXT[FLD
IF $PIECE(TEXT,FLD,$LENGTH(TEXT,FLD))'["}"
Begin DoDot:2
+7 NEW X
FOR X=2:1:$LENGTH(TEXT,FLD)
IF $PIECE(TEXT,FLD,X)'["}"
SET RESULT=1
End DoDot:2
End DoDot:1
+8 QUIT RESULT
+9 ;
WRAP(DATA,IEN,NODE,LAST) ;
+1 NEW LINE,NODE0,REP,REP2,TIUFT,X
+2 SET LAST("Start")=(LAST-1)
SET NODE0=DATA(8927,IEN,NODE,LAST,0)
+3 ; check fields to see if line needs to be wrapped
IF '+$$EX80(NODE0)
QUIT
+4 ; wrap
DO WRAP^TIUFLD(NODE0,80)
+5 ; set the new line of data
SET LINE=0
FOR
SET LINE=$ORDER(TIUFT(LINE))
if '+LINE
QUIT
Begin DoDot:1
+6 ; increment if more lines
SET DATA(8927,IEN,NODE,LAST,0)=TIUFT(LINE)
if +$ORDER(TIUFT(LINE))
SET LAST=LAST+1
End DoDot:1
+7 QUIT
+8 ;
EX80(DATA) ; checks field(s) length
+1 ; no field
if DATA'["{FLD
QUIT 1
+2 NEW FLD,LENGTH,RESULT
SET LENGTH=$LENGTH(DATA)
SET RESULT=1
+3 FOR FLD=2:1:$LENGTH(DATA,"{FLD:")
Begin DoDot:1
+4 NEW FIEN,FNAME
SET FNAME=$PIECE($PIECE(DATA,"{FLD:",FLD),"}")
if FNAME=""
QUIT
SET FIEN=$ORDER(^TIU(8927.1,"B",FNAME,""))
+5 ; field name missing from 8927.1
IF 'FIEN
Begin DoDot:2
+6 if '$DATA(@NOFLD@(IEN))
SET NOFLD("COUNT")=+$GET(NOFLD("COUNT"))+1
SET @NOFLD@(IEN,"PATH")=$PIECE($GET(PATH),U,1,LEVEL+1)
+7 if $GET(@NOFLD@(IEN,"NODE"))'[ITEM
SET @NOFLD@(IEN,"NODE")=$SELECT($GET(@NOFLD@(IEN,"NODE"))="":ITEM,1:$GET(@NOFLD@(IEN,"NODE"))_U_ITEM)
End DoDot:2
QUIT
+8 NEW NODE0
SET NODE0=$GET(^TIU(8927.1,FIEN,0))
+9 ; subtract the length of the name and brackets
SET LENGTH=LENGTH-($LENGTH(FNAME)+6)
+10 ; maximum length
NEW MAXLEN
+11 ; length of field
SET MAXLEN(+$PIECE(NODE0,U,4))=""
+12 ; max length of field
SET MAXLEN(+$PIECE(NODE0,U,10))=""
+13 ; length of LM text
SET MAXLEN(+$LENGTH($PIECE(NODE0,U,6)))=""
+14 ; add the longest to the length
SET LENGTH=LENGTH+($ORDER(MAXLEN(""),-1))
End DoDot:1
+15 QUIT $SELECT(LENGTH'>80:0,1:1)
+16 ;
MERGE(DATA) ; merge lines of text criteria
+1 NEW RESULT
SET RESULT=1
+2 ; if the last character of the line is a field, do not merge
if $EXTRACT(DATA,$LENGTH(DATA))="}"
QUIT 0
+3 ; if the last character of the line is an object, do not merge
if $EXTRACT(DATA,$LENGTH(DATA))="|"
QUIT 0
+4 QUIT RESULT
+5 ;
DEL(PARENT,ITEM,CHILD) ;
+1 NEW TYPE
SET TYPE=$PIECE($GET(^TIU(8927,CHILD,0)),U,3)
+2 ; NEVER delete root folders
if TYPE="R"!(TYPE="CF")!(TYPE="TF")!(TYPE="OF")
QUIT
+3 NEW %,DA,DIK,X,Y
+4 ; delete entry
SET DA=CHILD
SET DIK="^TIU(8927,"
if +DA
DO ^DIK
+5 IF +$GET(PARENT)=0
QUIT
+6 ; delete entry from ITEM list of PARENT
SET DA=ITEM
SET DA(1)=PARENT
SET DIK="^TIU(8927,"_DA(1)_",10,"
DO ^DIK
+7 QUIT
+8 ;
HASBPTXT(IEN) ; does entry have BOILERPLATE TEXT?
+1 QUIT $ORDER(^TIU(8927,IEN,2,0))
+2 ;
HASITEMS(IEN) ; does entry have ITEMS?
+1 QUIT $ORDER(^TIU(8927,IEN,10,0))
+2 ;
CLEAN(DATA) ;
+1 ; remove trailing spaces, replace characters, remove control characters
+2 SET DATA=$$RTS(DATA)
+3 SET DATA=$$REPLACE(DATA)
+4 SET DATA=$$CTRL(DATA)
+5 QUIT DATA
+6 ;
RTS(X) ; remove trailing spaces
+1 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,$LENGTH(X)-1)
+2 QUIT X
+3 ;
REPLACE(DATA) ; replace characters
+1 ; setup replacment characters
NEW REP
SET REP($CHAR(9))=" "
SET REP($CHAR(149))=" - "
SET REP("$c")="$C"
+2 ; fix double field brackets
SET REP("{{")="{"
SET REP("}}")="}"
+3 QUIT $$REPLACE^XLFSTR(DATA,.REP)
+4 ;
CTRL(X) ; remove all control characters
+1 NEW I
SET I=1
FOR
if X'?.E1C.E
QUIT
Begin DoDot:1
+2 FOR I=I:1
if $EXTRACT(X,I)?1C
QUIT
+3 SET X=$EXTRACT(X,1,I-1)_$EXTRACT(X,I+1,999)
End DoDot:1
+4 QUIT X
+5 ;
