- 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 Jan 18, 2025@03:46:54 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