TIUSRVF ; SLC/JM - Server calls for Template Fields ; 3/23/12 10:23am
;;1.0;TEXT INTEGRATION UTILITIES;**105,127,132,272**;Jun 20, 1997;Build 5
LOAD(TIUY,FLD) ; Load Template Field by Name
N FLDIEN S FLDIEN=""
Q:$G(FLD)']""
D GETFLD(.TIUY,FLD,0,.FLDIEN)
I +FLDIEN S TIUY(.05)=FLDIEN
Q
LOADIEN(TIUY,FLDIEN) ; Load Template Field by IEN
D GETFLD(.TIUY,"",0,.FLDIEN)
I +FLDIEN S TIUY(.05)=FLDIEN
Q
GETCONV(DIR,L1,L2,COUNT,DOQ) ; Returns a list of XML conversions
S L1(1)="&",L2(1)="&" ; Keep "&" first
S L1(2)=">",L2(2)=">"
S L1(3)="<",L2(3)="<"
S COUNT=3
I $G(DOQ) D
.S L1(4)="'",L2(4)="'"
.S L1(5)="""",L2(5)="""
.S COUNT=5
I +DIR D ; If Going from L2 to L1, make "&" last entry
.N TMP
.S TMP=L1(1),L1(1)=L1(COUNT),L1(COUNT)=TMP
.S TMP=L2(1),L2(1)=L2(COUNT),L2(COUNT)=TMP
Q
XMLCONV(INPUT,DIR,DOQ) ; Returns Valid XML Text
N IFROM,ITO,COUNT,OUTPUT,CNT,IDX,LEN,TMP
I DIR D GETCONV(DIR,.ITO,.IFROM,.COUNT,$G(DOQ)) I 1
E D GETCONV(DIR,.IFROM,.ITO,.COUNT,$G(DOQ))
S OUTPUT=INPUT
F CNT=1:1:COUNT D
.S LEN=$L(IFROM(CNT))+1
.S IDX=0
.F S IDX=$F(OUTPUT,IFROM(CNT),IDX) Q:IDX=0 D
.. S OUTPUT=$E(OUTPUT,1,IDX-LEN)_ITO(CNT)_$E(OUTPUT,IDX,250)
.. S IDX=IDX-(LEN-2)
Q OUTPUT
;
XMLTXT(INPUT,FLDNAME,DOQ) ; Returns Valid XML Text
N OUTPUT
S OUTPUT=$$XMLCONV(INPUT,0,$G(DOQ))
I $G(FLDNAME)'="" S OUTPUT="<"_FLDNAME_">"_OUTPUT_"</"_FLDNAME_">"
Q OUTPUT
;
TRUETXT(INPUT,DOQ) ; Returns True text from XML
Q $$XMLCONV(INPUT,1,$G(DOQ))
;
GETFLD(TIUY,FLD,ASXML,FLDIEN) ; Load Template Field into TIUY
N I,J,FNUM,ID,NODE,FIRST,FLDN,FP,NODE3
I '$G(FLDIEN) Q:'$D(^TIU(8927.1,"B",FLD)) S FLDIEN=$O(^TIU(8927.1,"B",FLD,0))
S FLD=FLDIEN
I +FLD'>0 Q
S NODE=$G(^TIU(8927.1,FLD,0))
S NODE3=$G(^TIU(8927.1,FLD,3))
I 'ASXML D I 1
. S I=1,TIUY(1)=NODE,ID="D"
. I NODE3'="" S I=2,TIUY(2)="U"_U_NODE3
E D
. D ADD(.TIUY,"<FIELD NAME="""_$$XMLTXT($P(NODE,U,1),"",1)_""">",2)
. F FNUM=.02:.01:.16 D
. . S FLDN=$$FLDNAME(FNUM),FP=+$E(FNUM_"0",2,3)
. . I $P(NODE,U,FP)'="" D ADD(.TIUY,$$XMLTXT($P(NODE,U,FP),FLDN),4)
. I NODE3'="" D
. . S FLDN=$$FLDNAME(3)
. . D ADD(.TIUY,$$XMLTXT(NODE3,FLDN),4)
F FNUM=2,10 S:FNUM=10 ID="I" D
. S J=0,FIRST=1
. F S J=$O(^TIU(8927.1,FLD,FNUM,J)) Q:J'>0 D
. . I 'ASXML D I 1
. . . S I=I+1
. . . S TIUY(I)=ID_U_^TIU(8927.1,FLD,FNUM,J,0)
. . E D
. . . I FIRST D
. . . . S FIRST=0
. . . . D ADD(.TIUY,"<"_$$FLDNAME(FNUM)_">",4)
. . . D ADD(.TIUY,$$XMLTXT(^TIU(8927.1,FLD,FNUM,J,0),"p"),6)
. I ASXML,'FIRST D ADD(.TIUY,"</"_$$FLDNAME(FNUM)_">",4)
I ASXML D ADD(.TIUY,"</FIELD>",2)
Q
SAVE(SUCCESS,TIUDA,TIUX) ; Save Template Field
; Input:
; TIUDA=IEN of TEMPLATE record
; TIUX(SEQ)=IEN of item
; Output:
; SUCCESS=IEN of item if successful, or
; 0^ Explanatory message if not
N FLD,TMP
S SUCCESS=""
I (+TIUDA'>0)!($G(TIUX(.01))'="") D Q:$P(SUCCESS,U,1)="0"
. I $L($G(TIUX(.01)))<3 D Q
. . S SUCCESS="0^Template Field name must be at least 3 characters"
. S TIUX(.01)=$$UPPER^TIULS(TIUX(.01))
. N FOUNDIEN
. S FOUNDIEN=$O(^TIU(8927.1,"B",TIUX(.01),0))
. I FOUNDIEN>0,FOUNDIEN'=TIUDA D Q
. . S SUCCESS="0^"_TIUX(.01)_" is not a unique name"
. I +TIUDA'>0 D
. . S TIUDA=$$CREATE($G(TIUX(.01)))
S SUCCESS=TIUDA Q:'+SUCCESS
D LOCK^TIUSRVF1(.TMP,TIUDA)
I TMP=0 D Q
. S SUCCESS="0^Template Field currently being edited by another user"
F FLD=2,10 D
. I +$O(TIUX(FLD,0)) D Q:$D(TIUX)'>9
. . K ^TIU(8927.1,TIUDA,FLD)
. . I $G(TIUX(FLD,1))="@" K TIUX(FLD) Q
. . M ^TIU(8927.1,TIUDA,FLD)=TIUX(FLD) K TIUX(FLD)
. . D SETXT0(TIUDA,FLD)
I $D(TIUX)>9 D FILE(.SUCCESS,""""_TIUDA_",""",.TIUX)
D UNLOCK^TIUSRVF1(.TMP,TIUDA)
Q
CREATE(NAME) ; Get or create Template Field record
N DIC,DLAYGO,DR,X,Y
S (DIC,DLAYGO)=8927.1,DIC(0)="FL"
S X=""""_NAME_"""" D ^DIC
I +Y'>0 Q "0^Error Creating New Template Field."
Q +Y
SETXT0(TIUDA,FLD) ; Set the root node of the WP-field
N TIUC,TIUI S (TIUC,TIUI)=0
I '+$G(FLD) S FLD=2
F S TIUI=$O(^TIU(8927.1,TIUDA,FLD,TIUI)) Q:+TIUI'>0 D
. S:$D(^TIU(8927.1,TIUDA,FLD,TIUI,0)) TIUC=TIUC+1
S ^TIU(8927.1,TIUDA,FLD,0)="^^"_TIUC_U_TIUC_U_DT_"^^"
Q
FILE(SUCCESS,IENS,TIUX) ; Call FM Filer to commit updates to DB
N FDA,FDARR,FLAGS,TIUMSG
S FDARR="FDA(8927.1,"_IENS_")",FLAGS=""
M @FDARR=TIUX
D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
I $D(TIUMSG)>9 S SUCCESS=0_U_$G(TIUMSG("DIERR",1,"TEXT",1))
Q
EXPORT(TIUXML,FLDS) ; Exports Template Fields as XML
; FLDS should be an array of Template Field names, not IENs
N I,IEN
K TIUXML
D ADD(.TIUXML,"<TEMPLATE_FIELDS>",0)
S I=0
F S I=$O(FLDS(I)) Q:I'>0 D
. S IEN=$O(^TIU(8927.1,"B",FLDS(I),0))
. I +IEN D ADDXML(.TIUXML,IEN)
D ADD(.TIUXML,"</TEMPLATE_FIELDS>",0)
Q
ADDXML(TIUXML,IEN) ; Add a single Template Field to the XML list
D GETFLD(.TIUXML,"",1,IEN)
Q
FLDNAME(FLDNUM) ; Returns Field Name from it's number (DBIA 1412)
Q $TR($P(^DD(8927.1,FLDNUM,0),U,1)," ","_")
FLDNUM(FLDNAME) ; Returns Field Number from it's name (DBIA 1412)
Q $O(^DD(8927.1,"B",$TR(FLDNAME,"_"," "),0))
ADD(XML,TXT,INDENT) ; Add text to XML
N IND
S $P(IND," ",INDENT+1)=""
S XML($O(XML(999999),-1)+1)=IND_TXT
Q
STRIP(INPUT) ;Strips leading and trailing spaces
N TIULEN,TIUI,TIUIDX
S TIULEN=$L(INPUT)
I TIULEN>0 D
. S TIUIDX=0
. F TIUI=1:1:TIULEN S:($E(INPUT,TIUI)=" ") TIUIDX=TIUI Q:(TIUIDX'=TIUI)
. S INPUT=$E(INPUT,TIUIDX+1,TIULEN)
. S TIULEN=$L(INPUT)
. I TIULEN>0 D
. . S TIUIDX=TIULEN+1
. . F TIUI=TIULEN:-1:1 S:($E(INPUT,TIUI)=" ") TIUIDX=TIUI Q:(TIUIDX'=TIUI)
. . S INPUT=$E(INPUT,1,TIUIDX-1)
Q
STRIPLST(LIST) ; Strip spaces from all list entries
N TIUIDX,TIUTEMP
S TIUIDX=0
F S TIUIDX=$O(@LIST@(TIUIDX)) Q:(TIUIDX'>0) D
. S TIUTEMP=@LIST@(TIUIDX)
. D STRIP(.TIUTEMP)
. S @LIST@(TIUIDX)=TIUTEMP
Q
UPDATE(REPORT,SIDX,STATUS,REQNAME,TRUENAME) ; Update Status
I STATUS'="0" D
.N END
.S SIDX=SIDX+1
.I +STATUS D I 1
..I REQNAME=TRUENAME S END=1
..E S END=0_U_TRUENAME
.E S END=$P(STATUS,U,2)
.S REPORT(SIDX)=REQNAME_U_END
.S STATUS=0
Q
IMPORT(REPORT,XMLTMP) ;Call layer for IMPORT2; created to maintain backward
;compatibility and extend the IMPORT function to optionally
;specify saving the template field.
D IMPORT2(.REPORT,"XMLTMP",1)
Q
IMPORT2(REPORT,XML,SAVEIT) ; Imports Template Fields from XML
; REPORT returns a status for each Template Field
; Template Field Created Successfully REQUESTED NAME^1
; Template Field Renamed to New Field REQUESTED NAME^0^NEW NAME
N PL,PG,PS,PE,I,SIDX,LINE,ITEM,ENDTAG,LEVEL,LEVELS,TAG,ERROR,SKIP
N OK2ADD,IEN,INITNAME,REQNAME,TRUENAME,SAVE,DATA,DIDX,DFLDNUM,STATUS
D STRIPLST(XML)
S (I,SIDX,LEVEL,ERROR,OK2ADD,DIDX,STATUS)=0
S (REQNAME,TRUENAME)=""
F S I=$O(@XML@(I)) Q:(I'>0)!ERROR D
.D UPDATE(.REPORT,.SIDX,.STATUS,REQNAME,TRUENAME)
.S LINE=@XML@(I)
.F D Q:(LINE="")!ERROR
..S PL=$F(LINE,"<")
..S PG=$F(LINE,">",PL)
..I (PL=0)!(PG'>PL) S ERROR=1 Q
..S ITEM=$E(LINE,PL,PG-2)
..I ITEM="" S ERROR=1 Q
..S LINE=$E(LINE,1,PL-2)_$E(LINE,PG,$L(LINE))
..S PL=$F(LINE,"<")
..I PL>2 D
...S DATA=$$TRUETXT($E(LINE,1,PL-2))
...S LINE=$E(LINE,PL-1,$L(LINE))
..E S DATA=""
..S ENDTAG=($E(ITEM)="/")
..I ENDTAG S ITEM=$E(ITEM,2,$L(ITEM))
..S PS=$F(ITEM," ")
..I ENDTAG,(PS>0)!(LEVEL<1)!($G(LEVELS(LEVEL))'=ITEM) S ERROR=1 Q
..I PS S TAG=$E(ITEM,1,PS-2)
..E S TAG=ITEM
..I TAG="" S ERROR=1 Q
..I ENDTAG D Q
...K LEVELS(LEVEL)
...S LEVEL=LEVEL-1
...I TAG'="p" S DIDX=0
...I TAG="FIELD" S OK2ADD=0 D
....I $D(SAVE) D
.....N SUCCESS
.....I SAVEIT D SAVE(.SUCCESS,0,.SAVE) I 1
.....E S SUCCESS=0_U_"0~"_TRUENAME
.....K SAVE
.....S STATUS=SUCCESS
..S LEVEL=LEVEL+1
..S LEVELS(LEVEL)=TAG
..I PS,TAG'="FIELD" S ERROR=1 Q
..I TAG="TEMPLATE_FIELDS" Q
..S SKIP=0
..I 'PS,OK2ADD,((DATA'="")!(TAG="p")) D
...I TAG'="p" S SAVE($$FLDNUM(TAG))=DATA
...E D
....I DIDX=0 S DFLDNUM=$$FLDNUM(LEVELS(LEVEL-1))
....S DIDX=DIDX+1
....S SAVE(DFLDNUM,DIDX,0)=DATA
..I PS D Q:(ERROR!SKIP)
...N NAMEIDX
...I ($E(ITEM,PS,PS+5)'="NAME=""")!($E(ITEM,$L(ITEM))'="""") S ERROR=1 Q
...S REQNAME=$E(ITEM,PS+6,$L(ITEM)-1)
...I REQNAME="" S ERROR=1 Q
...S REQNAME=$$TRUETXT(REQNAME,1),INITNAME=REQNAME
...S TRUENAME=REQNAME,NAMEIDX=0
...I $E(INITNAME,1,8)="WORDFLD_" D
....S INITNAME=$E(INITNAME,1,13),TRUENAME=INITNAME_"1",NAMEIDX=1
...F S IEN=+$O(^TIU(8927.1,"B",TRUENAME,0)) D:+IEN Q:(SKIP!('IEN))
....N TMPXML,IDX,J,NO,LASTJ
....D ADDXML(.TMPXML,IEN)
....D STRIPLST("TMPXML")
....S (NO,IDX,LASTJ)=0,J=I,IDX=1
....F S IDX=$O(TMPXML(IDX)) Q:(IDX'>0) S J=$O(@XML@(J)) Q:(J'>0) D Q:NO
.....S LASTJ=J
.....I TMPXML(IDX)'=@XML@(J) S NO=1
....I 'NO S I=LASTJ-1,LINE="",SKIP=1,STATUS=1 Q
....S NAMEIDX=NAMEIDX+1
....S TRUENAME=$E(INITNAME,1,30-$L(NAMEIDX))_NAMEIDX
...I 'IEN S OK2ADD=1
...Q:SKIP
...S SAVE(.01)=TRUENAME
D UPDATE(.REPORT,.SIDX,.STATUS,REQNAME,TRUENAME)
I ERROR!(LEVEL>0) D
.S SIDX=SIDX+1
.S REPORT(SIDX)=U_0_U_"XML FORMAT ERROR"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUSRVF 9162 printed Nov 22, 2024@17:55:41 Page 2
TIUSRVF ; SLC/JM - Server calls for Template Fields ; 3/23/12 10:23am
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**105,127,132,272**;Jun 20, 1997;Build 5
LOAD(TIUY,FLD) ; Load Template Field by Name
+1 NEW FLDIEN
SET FLDIEN=""
+2 if $GET(FLD)']""
QUIT
+3 DO GETFLD(.TIUY,FLD,0,.FLDIEN)
+4 IF +FLDIEN
SET TIUY(.05)=FLDIEN
+5 QUIT
LOADIEN(TIUY,FLDIEN) ; Load Template Field by IEN
+1 DO GETFLD(.TIUY,"",0,.FLDIEN)
+2 IF +FLDIEN
SET TIUY(.05)=FLDIEN
+3 QUIT
GETCONV(DIR,L1,L2,COUNT,DOQ) ; Returns a list of XML conversions
+1 ; Keep "&" first
SET L1(1)="&"
SET L2(1)="&"
+2 SET L1(2)=">"
SET L2(2)=">"
+3 SET L1(3)="<"
SET L2(3)="<"
+4 SET COUNT=3
+5 IF $GET(DOQ)
Begin DoDot:1
+6 SET L1(4)="'"
SET L2(4)="'"
+7 SET L1(5)=""""
SET L2(5)="""
+8 SET COUNT=5
End DoDot:1
+9 ; If Going from L2 to L1, make "&" last entry
IF +DIR
Begin DoDot:1
+10 NEW TMP
+11 SET TMP=L1(1)
SET L1(1)=L1(COUNT)
SET L1(COUNT)=TMP
+12 SET TMP=L2(1)
SET L2(1)=L2(COUNT)
SET L2(COUNT)=TMP
End DoDot:1
+13 QUIT
XMLCONV(INPUT,DIR,DOQ) ; Returns Valid XML Text
+1 NEW IFROM,ITO,COUNT,OUTPUT,CNT,IDX,LEN,TMP
+2 IF DIR
DO GETCONV(DIR,.ITO,.IFROM,.COUNT,$GET(DOQ))
IF 1
+3 IF '$TEST
DO GETCONV(DIR,.IFROM,.ITO,.COUNT,$GET(DOQ))
+4 SET OUTPUT=INPUT
+5 FOR CNT=1:1:COUNT
Begin DoDot:1
+6 SET LEN=$LENGTH(IFROM(CNT))+1
+7 SET IDX=0
+8 FOR
SET IDX=$FIND(OUTPUT,IFROM(CNT),IDX)
if IDX=0
QUIT
Begin DoDot:2
+9 SET OUTPUT=$EXTRACT(OUTPUT,1,IDX-LEN)_ITO(CNT)_$EXTRACT(OUTPUT,IDX,250)
+10 SET IDX=IDX-(LEN-2)
End DoDot:2
End DoDot:1
+11 QUIT OUTPUT
+12 ;
XMLTXT(INPUT,FLDNAME,DOQ) ; Returns Valid XML Text
+1 NEW OUTPUT
+2 SET OUTPUT=$$XMLCONV(INPUT,0,$GET(DOQ))
+3 IF $GET(FLDNAME)'=""
SET OUTPUT="<"_FLDNAME_">"_OUTPUT_"</"_FLDNAME_">"
+4 QUIT OUTPUT
+5 ;
TRUETXT(INPUT,DOQ) ; Returns True text from XML
+1 QUIT $$XMLCONV(INPUT,1,$GET(DOQ))
+2 ;
GETFLD(TIUY,FLD,ASXML,FLDIEN) ; Load Template Field into TIUY
+1 NEW I,J,FNUM,ID,NODE,FIRST,FLDN,FP,NODE3
+2 IF '$GET(FLDIEN)
if '$DATA(^TIU(8927.1,"B",FLD))
QUIT
SET FLDIEN=$ORDER(^TIU(8927.1,"B",FLD,0))
+3 SET FLD=FLDIEN
+4 IF +FLD'>0
QUIT
+5 SET NODE=$GET(^TIU(8927.1,FLD,0))
+6 SET NODE3=$GET(^TIU(8927.1,FLD,3))
+7 IF 'ASXML
Begin DoDot:1
+8 SET I=1
SET TIUY(1)=NODE
SET ID="D"
+9 IF NODE3'=""
SET I=2
SET TIUY(2)="U"_U_NODE3
End DoDot:1
IF 1
+10 IF '$TEST
Begin DoDot:1
+11 DO ADD(.TIUY,"<FIELD NAME="""_$$XMLTXT($PIECE(NODE,U,1),"",1)_""">",2)
+12 FOR FNUM=.02:.01:.16
Begin DoDot:2
+13 SET FLDN=$$FLDNAME(FNUM)
SET FP=+$EXTRACT(FNUM_"0",2,3)
+14 IF $PIECE(NODE,U,FP)'=""
DO ADD(.TIUY,$$XMLTXT($PIECE(NODE,U,FP),FLDN),4)
End DoDot:2
+15 IF NODE3'=""
Begin DoDot:2
+16 SET FLDN=$$FLDNAME(3)
+17 DO ADD(.TIUY,$$XMLTXT(NODE3,FLDN),4)
End DoDot:2
End DoDot:1
+18 FOR FNUM=2,10
if FNUM=10
SET ID="I"
Begin DoDot:1
+19 SET J=0
SET FIRST=1
+20 FOR
SET J=$ORDER(^TIU(8927.1,FLD,FNUM,J))
if J'>0
QUIT
Begin DoDot:2
+21 IF 'ASXML
Begin DoDot:3
+22 SET I=I+1
+23 SET TIUY(I)=ID_U_^TIU(8927.1,FLD,FNUM,J,0)
End DoDot:3
IF 1
+24 IF '$TEST
Begin DoDot:3
+25 IF FIRST
Begin DoDot:4
+26 SET FIRST=0
+27 DO ADD(.TIUY,"<"_$$FLDNAME(FNUM)_">",4)
End DoDot:4
+28 DO ADD(.TIUY,$$XMLTXT(^TIU(8927.1,FLD,FNUM,J,0),"p"),6)
End DoDot:3
End DoDot:2
+29 IF ASXML
IF 'FIRST
DO ADD(.TIUY,"</"_$$FLDNAME(FNUM)_">",4)
End DoDot:1
+30 IF ASXML
DO ADD(.TIUY,"</FIELD>",2)
+31 QUIT
SAVE(SUCCESS,TIUDA,TIUX) ; Save Template Field
+1 ; Input:
+2 ; TIUDA=IEN of TEMPLATE record
+3 ; TIUX(SEQ)=IEN of item
+4 ; Output:
+5 ; SUCCESS=IEN of item if successful, or
+6 ; 0^ Explanatory message if not
+7 NEW FLD,TMP
+8 SET SUCCESS=""
+9 IF (+TIUDA'>0)!($GET(TIUX(.01))'="")
Begin DoDot:1
+10 IF $LENGTH($GET(TIUX(.01)))<3
Begin DoDot:2
+11 SET SUCCESS="0^Template Field name must be at least 3 characters"
End DoDot:2
QUIT
+12 SET TIUX(.01)=$$UPPER^TIULS(TIUX(.01))
+13 NEW FOUNDIEN
+14 SET FOUNDIEN=$ORDER(^TIU(8927.1,"B",TIUX(.01),0))
+15 IF FOUNDIEN>0
IF FOUNDIEN'=TIUDA
Begin DoDot:2
+16 SET SUCCESS="0^"_TIUX(.01)_" is not a unique name"
End DoDot:2
QUIT
+17 IF +TIUDA'>0
Begin DoDot:2
+18 SET TIUDA=$$CREATE($GET(TIUX(.01)))
End DoDot:2
End DoDot:1
if $PIECE(SUCCESS,U,1)="0"
QUIT
+19 SET SUCCESS=TIUDA
if '+SUCCESS
QUIT
+20 DO LOCK^TIUSRVF1(.TMP,TIUDA)
+21 IF TMP=0
Begin DoDot:1
+22 SET SUCCESS="0^Template Field currently being edited by another user"
End DoDot:1
QUIT
+23 FOR FLD=2,10
Begin DoDot:1
+24 IF +$ORDER(TIUX(FLD,0))
Begin DoDot:2
+25 KILL ^TIU(8927.1,TIUDA,FLD)
+26 IF $GET(TIUX(FLD,1))="@"
KILL TIUX(FLD)
QUIT
+27 MERGE ^TIU(8927.1,TIUDA,FLD)=TIUX(FLD)
KILL TIUX(FLD)
+28 DO SETXT0(TIUDA,FLD)
End DoDot:2
if $DATA(TIUX)'>9
QUIT
End DoDot:1
+29 IF $DATA(TIUX)>9
DO FILE(.SUCCESS,""""_TIUDA_",""",.TIUX)
+30 DO UNLOCK^TIUSRVF1(.TMP,TIUDA)
+31 QUIT
CREATE(NAME) ; Get or create Template Field record
+1 NEW DIC,DLAYGO,DR,X,Y
+2 SET (DIC,DLAYGO)=8927.1
SET DIC(0)="FL"
+3 SET X=""""_NAME_""""
DO ^DIC
+4 IF +Y'>0
QUIT "0^Error Creating New Template Field."
+5 QUIT +Y
SETXT0(TIUDA,FLD) ; Set the root node of the WP-field
+1 NEW TIUC,TIUI
SET (TIUC,TIUI)=0
+2 IF '+$GET(FLD)
SET FLD=2
+3 FOR
SET TIUI=$ORDER(^TIU(8927.1,TIUDA,FLD,TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+4 if $DATA(^TIU(8927.1,TIUDA,FLD,TIUI,0))
SET TIUC=TIUC+1
End DoDot:1
+5 SET ^TIU(8927.1,TIUDA,FLD,0)="^^"_TIUC_U_TIUC_U_DT_"^^"
+6 QUIT
FILE(SUCCESS,IENS,TIUX) ; Call FM Filer to commit updates to DB
+1 NEW FDA,FDARR,FLAGS,TIUMSG
+2 SET FDARR="FDA(8927.1,"_IENS_")"
SET FLAGS=""
+3 MERGE @FDARR=TIUX
+4 ; File record
DO FILE^DIE(FLAGS,"FDA","TIUMSG")
+5 IF $DATA(TIUMSG)>9
SET SUCCESS=0_U_$GET(TIUMSG("DIERR",1,"TEXT",1))
+6 QUIT
EXPORT(TIUXML,FLDS) ; Exports Template Fields as XML
+1 ; FLDS should be an array of Template Field names, not IENs
+2 NEW I,IEN
+3 KILL TIUXML
+4 DO ADD(.TIUXML,"<TEMPLATE_FIELDS>",0)
+5 SET I=0
+6 FOR
SET I=$ORDER(FLDS(I))
if I'>0
QUIT
Begin DoDot:1
+7 SET IEN=$ORDER(^TIU(8927.1,"B",FLDS(I),0))
+8 IF +IEN
DO ADDXML(.TIUXML,IEN)
End DoDot:1
+9 DO ADD(.TIUXML,"</TEMPLATE_FIELDS>",0)
+10 QUIT
ADDXML(TIUXML,IEN) ; Add a single Template Field to the XML list
+1 DO GETFLD(.TIUXML,"",1,IEN)
+2 QUIT
FLDNAME(FLDNUM) ; Returns Field Name from it's number (DBIA 1412)
+1 QUIT $TRANSLATE($PIECE(^DD(8927.1,FLDNUM,0),U,1)," ","_")
FLDNUM(FLDNAME) ; Returns Field Number from it's name (DBIA 1412)
+1 QUIT $ORDER(^DD(8927.1,"B",$TRANSLATE(FLDNAME,"_"," "),0))
ADD(XML,TXT,INDENT) ; Add text to XML
+1 NEW IND
+2 SET $PIECE(IND," ",INDENT+1)=""
+3 SET XML($ORDER(XML(999999),-1)+1)=IND_TXT
+4 QUIT
STRIP(INPUT) ;Strips leading and trailing spaces
+1 NEW TIULEN,TIUI,TIUIDX
+2 SET TIULEN=$LENGTH(INPUT)
+3 IF TIULEN>0
Begin DoDot:1
+4 SET TIUIDX=0
+5 FOR TIUI=1:1:TIULEN
if ($EXTRACT(INPUT,TIUI)=" ")
SET TIUIDX=TIUI
if (TIUIDX'=TIUI)
QUIT
+6 SET INPUT=$EXTRACT(INPUT,TIUIDX+1,TIULEN)
+7 SET TIULEN=$LENGTH(INPUT)
+8 IF TIULEN>0
Begin DoDot:2
+9 SET TIUIDX=TIULEN+1
+10 FOR TIUI=TIULEN:-1:1
if ($EXTRACT(INPUT,TIUI)=" ")
SET TIUIDX=TIUI
if (TIUIDX'=TIUI)
QUIT
+11 SET INPUT=$EXTRACT(INPUT,1,TIUIDX-1)
End DoDot:2
End DoDot:1
+12 QUIT
STRIPLST(LIST) ; Strip spaces from all list entries
+1 NEW TIUIDX,TIUTEMP
+2 SET TIUIDX=0
+3 FOR
SET TIUIDX=$ORDER(@LIST@(TIUIDX))
if (TIUIDX'>0)
QUIT
Begin DoDot:1
+4 SET TIUTEMP=@LIST@(TIUIDX)
+5 DO STRIP(.TIUTEMP)
+6 SET @LIST@(TIUIDX)=TIUTEMP
End DoDot:1
+7 QUIT
UPDATE(REPORT,SIDX,STATUS,REQNAME,TRUENAME) ; Update Status
+1 IF STATUS'="0"
Begin DoDot:1
+2 NEW END
+3 SET SIDX=SIDX+1
+4 IF +STATUS
Begin DoDot:2
+5 IF REQNAME=TRUENAME
SET END=1
+6 IF '$TEST
SET END=0_U_TRUENAME
End DoDot:2
IF 1
+7 IF '$TEST
SET END=$PIECE(STATUS,U,2)
+8 SET REPORT(SIDX)=REQNAME_U_END
+9 SET STATUS=0
End DoDot:1
+10 QUIT
IMPORT(REPORT,XMLTMP) ;Call layer for IMPORT2; created to maintain backward
+1 ;compatibility and extend the IMPORT function to optionally
+2 ;specify saving the template field.
+3 DO IMPORT2(.REPORT,"XMLTMP",1)
+4 QUIT
IMPORT2(REPORT,XML,SAVEIT) ; Imports Template Fields from XML
+1 ; REPORT returns a status for each Template Field
+2 ; Template Field Created Successfully REQUESTED NAME^1
+3 ; Template Field Renamed to New Field REQUESTED NAME^0^NEW NAME
+4 NEW PL,PG,PS,PE,I,SIDX,LINE,ITEM,ENDTAG,LEVEL,LEVELS,TAG,ERROR,SKIP
+5 NEW OK2ADD,IEN,INITNAME,REQNAME,TRUENAME,SAVE,DATA,DIDX,DFLDNUM,STATUS
+6 DO STRIPLST(XML)
+7 SET (I,SIDX,LEVEL,ERROR,OK2ADD,DIDX,STATUS)=0
+8 SET (REQNAME,TRUENAME)=""
+9 FOR
SET I=$ORDER(@XML@(I))
if (I'>0)!ERROR
QUIT
Begin DoDot:1
+10 DO UPDATE(.REPORT,.SIDX,.STATUS,REQNAME,TRUENAME)
+11 SET LINE=@XML@(I)
+12 FOR
Begin DoDot:2
+13 SET PL=$FIND(LINE,"<")
+14 SET PG=$FIND(LINE,">",PL)
+15 IF (PL=0)!(PG'>PL)
SET ERROR=1
QUIT
+16 SET ITEM=$EXTRACT(LINE,PL,PG-2)
+17 IF ITEM=""
SET ERROR=1
QUIT
+18 SET LINE=$EXTRACT(LINE,1,PL-2)_$EXTRACT(LINE,PG,$LENGTH(LINE))
+19 SET PL=$FIND(LINE,"<")
+20 IF PL>2
Begin DoDot:3
+21 SET DATA=$$TRUETXT($EXTRACT(LINE,1,PL-2))
+22 SET LINE=$EXTRACT(LINE,PL-1,$LENGTH(LINE))
End DoDot:3
+23 IF '$TEST
SET DATA=""
+24 SET ENDTAG=($EXTRACT(ITEM)="/")
+25 IF ENDTAG
SET ITEM=$EXTRACT(ITEM,2,$LENGTH(ITEM))
+26 SET PS=$FIND(ITEM," ")
+27 IF ENDTAG
IF (PS>0)!(LEVEL<1)!($GET(LEVELS(LEVEL))'=ITEM)
SET ERROR=1
QUIT
+28 IF PS
SET TAG=$EXTRACT(ITEM,1,PS-2)
+29 IF '$TEST
SET TAG=ITEM
+30 IF TAG=""
SET ERROR=1
QUIT
+31 IF ENDTAG
Begin DoDot:3
+32 KILL LEVELS(LEVEL)
+33 SET LEVEL=LEVEL-1
+34 IF TAG'="p"
SET DIDX=0
+35 IF TAG="FIELD"
SET OK2ADD=0
Begin DoDot:4
+36 IF $DATA(SAVE)
Begin DoDot:5
+37 NEW SUCCESS
+38 IF SAVEIT
DO SAVE(.SUCCESS,0,.SAVE)
IF 1
+39 IF '$TEST
SET SUCCESS=0_U_"0~"_TRUENAME
+40 KILL SAVE
+41 SET STATUS=SUCCESS
End DoDot:5
End DoDot:4
End DoDot:3
QUIT
+42 SET LEVEL=LEVEL+1
+43 SET LEVELS(LEVEL)=TAG
+44 IF PS
IF TAG'="FIELD"
SET ERROR=1
QUIT
+45 IF TAG="TEMPLATE_FIELDS"
QUIT
+46 SET SKIP=0
+47 IF 'PS
IF OK2ADD
IF ((DATA'="")!(TAG="p"))
Begin DoDot:3
+48 IF TAG'="p"
SET SAVE($$FLDNUM(TAG))=DATA
+49 IF '$TEST
Begin DoDot:4
+50 IF DIDX=0
SET DFLDNUM=$$FLDNUM(LEVELS(LEVEL-1))
+51 SET DIDX=DIDX+1
+52 SET SAVE(DFLDNUM,DIDX,0)=DATA
End DoDot:4
End DoDot:3
+53 IF PS
Begin DoDot:3
+54 NEW NAMEIDX
+55 IF ($EXTRACT(ITEM,PS,PS+5)'="NAME=""")!($EXTRACT(ITEM,$LENGTH(ITEM))'="""")
SET ERROR=1
QUIT
+56 SET REQNAME=$EXTRACT(ITEM,PS+6,$LENGTH(ITEM)-1)
+57 IF REQNAME=""
SET ERROR=1
QUIT
+58 SET REQNAME=$$TRUETXT(REQNAME,1)
SET INITNAME=REQNAME
+59 SET TRUENAME=REQNAME
SET NAMEIDX=0
+60 IF $EXTRACT(INITNAME,1,8)="WORDFLD_"
Begin DoDot:4
+61 SET INITNAME=$EXTRACT(INITNAME,1,13)
SET TRUENAME=INITNAME_"1"
SET NAMEIDX=1
End DoDot:4
+62 FOR
SET IEN=+$ORDER(^TIU(8927.1,"B",TRUENAME,0))
if +IEN
Begin DoDot:4
+63 NEW TMPXML,IDX,J,NO,LASTJ
+64 DO ADDXML(.TMPXML,IEN)
+65 DO STRIPLST("TMPXML")
+66 SET (NO,IDX,LASTJ)=0
SET J=I
SET IDX=1
+67 FOR
SET IDX=$ORDER(TMPXML(IDX))
if (IDX'>0)
QUIT
SET J=$ORDER(@XML@(J))
if (J'>0)
QUIT
Begin DoDot:5
+68 SET LASTJ=J
+69 IF TMPXML(IDX)'=@XML@(J)
SET NO=1
End DoDot:5
if NO
QUIT
+70 IF 'NO
SET I=LASTJ-1
SET LINE=""
SET SKIP=1
SET STATUS=1
QUIT
+71 SET NAMEIDX=NAMEIDX+1
+72 SET TRUENAME=$EXTRACT(INITNAME,1,30-$LENGTH(NAMEIDX))_NAMEIDX
End DoDot:4
if (SKIP!('IEN))
QUIT
+73 IF 'IEN
SET OK2ADD=1
+74 if SKIP
QUIT
+75 SET SAVE(.01)=TRUENAME
End DoDot:3
if (ERROR!SKIP)
QUIT
End DoDot:2
if (LINE="")!ERROR
QUIT
End DoDot:1
+76 DO UPDATE(.REPORT,.SIDX,.STATUS,REQNAME,TRUENAME)
+77 IF ERROR!(LEVEL>0)
Begin DoDot:1
+78 SET SIDX=SIDX+1
+79 SET REPORT(SIDX)=U_0_U_"XML FORMAT ERROR"
End DoDot:1
+80 QUIT
