Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIUSRVF

TIUSRVF.m

Go to the documentation of this file.
  1. 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
  1. LOAD(TIUY,FLD) ; Load Template Field by Name
  1. N FLDIEN S FLDIEN=""
  1. Q:$G(FLD)']""
  1. D GETFLD(.TIUY,FLD,0,.FLDIEN)
  1. I +FLDIEN S TIUY(.05)=FLDIEN
  1. Q
  1. LOADIEN(TIUY,FLDIEN) ; Load Template Field by IEN
  1. D GETFLD(.TIUY,"",0,.FLDIEN)
  1. I +FLDIEN S TIUY(.05)=FLDIEN
  1. Q
  1. GETCONV(DIR,L1,L2,COUNT,DOQ) ; Returns a list of XML conversions
  1. S L1(1)="&",L2(1)="&" ; Keep "&" first
  1. S L1(2)=">",L2(2)=">"
  1. S L1(3)="<",L2(3)="<"
  1. S COUNT=3
  1. I $G(DOQ) D
  1. .S L1(4)="'",L2(4)="'"
  1. .S L1(5)="""",L2(5)="""
  1. .S COUNT=5
  1. I +DIR D ; If Going from L2 to L1, make "&" last entry
  1. .N TMP
  1. .S TMP=L1(1),L1(1)=L1(COUNT),L1(COUNT)=TMP
  1. .S TMP=L2(1),L2(1)=L2(COUNT),L2(COUNT)=TMP
  1. Q
  1. XMLCONV(INPUT,DIR,DOQ) ; Returns Valid XML Text
  1. N IFROM,ITO,COUNT,OUTPUT,CNT,IDX,LEN,TMP
  1. I DIR D GETCONV(DIR,.ITO,.IFROM,.COUNT,$G(DOQ)) I 1
  1. E D GETCONV(DIR,.IFROM,.ITO,.COUNT,$G(DOQ))
  1. S OUTPUT=INPUT
  1. F CNT=1:1:COUNT D
  1. .S LEN=$L(IFROM(CNT))+1
  1. .S IDX=0
  1. .F S IDX=$F(OUTPUT,IFROM(CNT),IDX) Q:IDX=0 D
  1. .. S OUTPUT=$E(OUTPUT,1,IDX-LEN)_ITO(CNT)_$E(OUTPUT,IDX,250)
  1. .. S IDX=IDX-(LEN-2)
  1. Q OUTPUT
  1. ;
  1. XMLTXT(INPUT,FLDNAME,DOQ) ; Returns Valid XML Text
  1. N OUTPUT
  1. S OUTPUT=$$XMLCONV(INPUT,0,$G(DOQ))
  1. I $G(FLDNAME)'="" S OUTPUT="<"_FLDNAME_">"_OUTPUT_"</"_FLDNAME_">"
  1. Q OUTPUT
  1. ;
  1. TRUETXT(INPUT,DOQ) ; Returns True text from XML
  1. Q $$XMLCONV(INPUT,1,$G(DOQ))
  1. ;
  1. GETFLD(TIUY,FLD,ASXML,FLDIEN) ; Load Template Field into TIUY
  1. N I,J,FNUM,ID,NODE,FIRST,FLDN,FP,NODE3
  1. I '$G(FLDIEN) Q:'$D(^TIU(8927.1,"B",FLD)) S FLDIEN=$O(^TIU(8927.1,"B",FLD,0))
  1. S FLD=FLDIEN
  1. I +FLD'>0 Q
  1. S NODE=$G(^TIU(8927.1,FLD,0))
  1. S NODE3=$G(^TIU(8927.1,FLD,3))
  1. I 'ASXML D I 1
  1. . S I=1,TIUY(1)=NODE,ID="D"
  1. . I NODE3'="" S I=2,TIUY(2)="U"_U_NODE3
  1. E D
  1. . D ADD(.TIUY,"<FIELD NAME="""_$$XMLTXT($P(NODE,U,1),"",1)_""">",2)
  1. . F FNUM=.02:.01:.16 D
  1. . . S FLDN=$$FLDNAME(FNUM),FP=+$E(FNUM_"0",2,3)
  1. . . I $P(NODE,U,FP)'="" D ADD(.TIUY,$$XMLTXT($P(NODE,U,FP),FLDN),4)
  1. . I NODE3'="" D
  1. . . S FLDN=$$FLDNAME(3)
  1. . . D ADD(.TIUY,$$XMLTXT(NODE3,FLDN),4)
  1. F FNUM=2,10 S:FNUM=10 ID="I" D
  1. . S J=0,FIRST=1
  1. . F S J=$O(^TIU(8927.1,FLD,FNUM,J)) Q:J'>0 D
  1. . . I 'ASXML D I 1
  1. . . . S I=I+1
  1. . . . S TIUY(I)=ID_U_^TIU(8927.1,FLD,FNUM,J,0)
  1. . . E D
  1. . . . I FIRST D
  1. . . . . S FIRST=0
  1. . . . . D ADD(.TIUY,"<"_$$FLDNAME(FNUM)_">",4)
  1. . . . D ADD(.TIUY,$$XMLTXT(^TIU(8927.1,FLD,FNUM,J,0),"p"),6)
  1. . I ASXML,'FIRST D ADD(.TIUY,"</"_$$FLDNAME(FNUM)_">",4)
  1. I ASXML D ADD(.TIUY,"</FIELD>",2)
  1. Q
  1. SAVE(SUCCESS,TIUDA,TIUX) ; Save Template Field
  1. ; Input:
  1. ; TIUDA=IEN of TEMPLATE record
  1. ; TIUX(SEQ)=IEN of item
  1. ; Output:
  1. ; SUCCESS=IEN of item if successful, or
  1. ; 0^ Explanatory message if not
  1. N FLD,TMP
  1. S SUCCESS=""
  1. I (+TIUDA'>0)!($G(TIUX(.01))'="") D Q:$P(SUCCESS,U,1)="0"
  1. . I $L($G(TIUX(.01)))<3 D Q
  1. . . S SUCCESS="0^Template Field name must be at least 3 characters"
  1. . S TIUX(.01)=$$UPPER^TIULS(TIUX(.01))
  1. . N FOUNDIEN
  1. . S FOUNDIEN=$O(^TIU(8927.1,"B",TIUX(.01),0))
  1. . I FOUNDIEN>0,FOUNDIEN'=TIUDA D Q
  1. . . S SUCCESS="0^"_TIUX(.01)_" is not a unique name"
  1. . I +TIUDA'>0 D
  1. . . S TIUDA=$$CREATE($G(TIUX(.01)))
  1. S SUCCESS=TIUDA Q:'+SUCCESS
  1. D LOCK^TIUSRVF1(.TMP,TIUDA)
  1. I TMP=0 D Q
  1. . S SUCCESS="0^Template Field currently being edited by another user"
  1. F FLD=2,10 D
  1. . I +$O(TIUX(FLD,0)) D Q:$D(TIUX)'>9
  1. . . K ^TIU(8927.1,TIUDA,FLD)
  1. . . I $G(TIUX(FLD,1))="@" K TIUX(FLD) Q
  1. . . M ^TIU(8927.1,TIUDA,FLD)=TIUX(FLD) K TIUX(FLD)
  1. . . D SETXT0(TIUDA,FLD)
  1. I $D(TIUX)>9 D FILE(.SUCCESS,""""_TIUDA_",""",.TIUX)
  1. D UNLOCK^TIUSRVF1(.TMP,TIUDA)
  1. Q
  1. CREATE(NAME) ; Get or create Template Field record
  1. N DIC,DLAYGO,DR,X,Y
  1. S (DIC,DLAYGO)=8927.1,DIC(0)="FL"
  1. S X=""""_NAME_"""" D ^DIC
  1. I +Y'>0 Q "0^Error Creating New Template Field."
  1. Q +Y
  1. SETXT0(TIUDA,FLD) ; Set the root node of the WP-field
  1. N TIUC,TIUI S (TIUC,TIUI)=0
  1. I '+$G(FLD) S FLD=2
  1. F S TIUI=$O(^TIU(8927.1,TIUDA,FLD,TIUI)) Q:+TIUI'>0 D
  1. . S:$D(^TIU(8927.1,TIUDA,FLD,TIUI,0)) TIUC=TIUC+1
  1. S ^TIU(8927.1,TIUDA,FLD,0)="^^"_TIUC_U_TIUC_U_DT_"^^"
  1. Q
  1. FILE(SUCCESS,IENS,TIUX) ; Call FM Filer to commit updates to DB
  1. N FDA,FDARR,FLAGS,TIUMSG
  1. S FDARR="FDA(8927.1,"_IENS_")",FLAGS=""
  1. M @FDARR=TIUX
  1. D FILE^DIE(FLAGS,"FDA","TIUMSG") ; File record
  1. I $D(TIUMSG)>9 S SUCCESS=0_U_$G(TIUMSG("DIERR",1,"TEXT",1))
  1. Q
  1. EXPORT(TIUXML,FLDS) ; Exports Template Fields as XML
  1. ; FLDS should be an array of Template Field names, not IENs
  1. N I,IEN
  1. K TIUXML
  1. D ADD(.TIUXML,"<TEMPLATE_FIELDS>",0)
  1. S I=0
  1. F S I=$O(FLDS(I)) Q:I'>0 D
  1. . S IEN=$O(^TIU(8927.1,"B",FLDS(I),0))
  1. . I +IEN D ADDXML(.TIUXML,IEN)
  1. D ADD(.TIUXML,"</TEMPLATE_FIELDS>",0)
  1. Q
  1. ADDXML(TIUXML,IEN) ; Add a single Template Field to the XML list
  1. D GETFLD(.TIUXML,"",1,IEN)
  1. Q
  1. FLDNAME(FLDNUM) ; Returns Field Name from it's number (DBIA 1412)
  1. Q $TR($P(^DD(8927.1,FLDNUM,0),U,1)," ","_")
  1. FLDNUM(FLDNAME) ; Returns Field Number from it's name (DBIA 1412)
  1. Q $O(^DD(8927.1,"B",$TR(FLDNAME,"_"," "),0))
  1. ADD(XML,TXT,INDENT) ; Add text to XML
  1. N IND
  1. S $P(IND," ",INDENT+1)=""
  1. S XML($O(XML(999999),-1)+1)=IND_TXT
  1. Q
  1. STRIP(INPUT) ;Strips leading and trailing spaces
  1. N TIULEN,TIUI,TIUIDX
  1. S TIULEN=$L(INPUT)
  1. I TIULEN>0 D
  1. . S TIUIDX=0
  1. . F TIUI=1:1:TIULEN S:($E(INPUT,TIUI)=" ") TIUIDX=TIUI Q:(TIUIDX'=TIUI)
  1. . S INPUT=$E(INPUT,TIUIDX+1,TIULEN)
  1. . S TIULEN=$L(INPUT)
  1. . I TIULEN>0 D
  1. . . S TIUIDX=TIULEN+1
  1. . . F TIUI=TIULEN:-1:1 S:($E(INPUT,TIUI)=" ") TIUIDX=TIUI Q:(TIUIDX'=TIUI)
  1. . . S INPUT=$E(INPUT,1,TIUIDX-1)
  1. Q
  1. STRIPLST(LIST) ; Strip spaces from all list entries
  1. N TIUIDX,TIUTEMP
  1. S TIUIDX=0
  1. F S TIUIDX=$O(@LIST@(TIUIDX)) Q:(TIUIDX'>0) D
  1. . S TIUTEMP=@LIST@(TIUIDX)
  1. . D STRIP(.TIUTEMP)
  1. . S @LIST@(TIUIDX)=TIUTEMP
  1. Q
  1. UPDATE(REPORT,SIDX,STATUS,REQNAME,TRUENAME) ; Update Status
  1. I STATUS'="0" D
  1. .N END
  1. .S SIDX=SIDX+1
  1. .I +STATUS D I 1
  1. ..I REQNAME=TRUENAME S END=1
  1. ..E S END=0_U_TRUENAME
  1. .E S END=$P(STATUS,U,2)
  1. .S REPORT(SIDX)=REQNAME_U_END
  1. .S STATUS=0
  1. Q
  1. IMPORT(REPORT,XMLTMP) ;Call layer for IMPORT2; created to maintain backward
  1. ;compatibility and extend the IMPORT function to optionally
  1. ;specify saving the template field.
  1. D IMPORT2(.REPORT,"XMLTMP",1)
  1. Q
  1. IMPORT2(REPORT,XML,SAVEIT) ; Imports Template Fields from XML
  1. ; REPORT returns a status for each Template Field
  1. ; Template Field Created Successfully REQUESTED NAME^1
  1. ; Template Field Renamed to New Field REQUESTED NAME^0^NEW NAME
  1. N PL,PG,PS,PE,I,SIDX,LINE,ITEM,ENDTAG,LEVEL,LEVELS,TAG,ERROR,SKIP
  1. N OK2ADD,IEN,INITNAME,REQNAME,TRUENAME,SAVE,DATA,DIDX,DFLDNUM,STATUS
  1. D STRIPLST(XML)
  1. S (I,SIDX,LEVEL,ERROR,OK2ADD,DIDX,STATUS)=0
  1. S (REQNAME,TRUENAME)=""
  1. F S I=$O(@XML@(I)) Q:(I'>0)!ERROR D
  1. .D UPDATE(.REPORT,.SIDX,.STATUS,REQNAME,TRUENAME)
  1. .S LINE=@XML@(I)
  1. .F D Q:(LINE="")!ERROR
  1. ..S PL=$F(LINE,"<")
  1. ..S PG=$F(LINE,">",PL)
  1. ..I (PL=0)!(PG'>PL) S ERROR=1 Q
  1. ..S ITEM=$E(LINE,PL,PG-2)
  1. ..I ITEM="" S ERROR=1 Q
  1. ..S LINE=$E(LINE,1,PL-2)_$E(LINE,PG,$L(LINE))
  1. ..S PL=$F(LINE,"<")
  1. ..I PL>2 D
  1. ...S DATA=$$TRUETXT($E(LINE,1,PL-2))
  1. ...S LINE=$E(LINE,PL-1,$L(LINE))
  1. ..E S DATA=""
  1. ..S ENDTAG=($E(ITEM)="/")
  1. ..I ENDTAG S ITEM=$E(ITEM,2,$L(ITEM))
  1. ..S PS=$F(ITEM," ")
  1. ..I ENDTAG,(PS>0)!(LEVEL<1)!($G(LEVELS(LEVEL))'=ITEM) S ERROR=1 Q
  1. ..I PS S TAG=$E(ITEM,1,PS-2)
  1. ..E S TAG=ITEM
  1. ..I TAG="" S ERROR=1 Q
  1. ..I ENDTAG D Q
  1. ...K LEVELS(LEVEL)
  1. ...S LEVEL=LEVEL-1
  1. ...I TAG'="p" S DIDX=0
  1. ...I TAG="FIELD" S OK2ADD=0 D
  1. ....I $D(SAVE) D
  1. .....N SUCCESS
  1. .....I SAVEIT D SAVE(.SUCCESS,0,.SAVE) I 1
  1. .....E S SUCCESS=0_U_"0~"_TRUENAME
  1. .....K SAVE
  1. .....S STATUS=SUCCESS
  1. ..S LEVEL=LEVEL+1
  1. ..S LEVELS(LEVEL)=TAG
  1. ..I PS,TAG'="FIELD" S ERROR=1 Q
  1. ..I TAG="TEMPLATE_FIELDS" Q
  1. ..S SKIP=0
  1. ..I 'PS,OK2ADD,((DATA'="")!(TAG="p")) D
  1. ...I TAG'="p" S SAVE($$FLDNUM(TAG))=DATA
  1. ...E D
  1. ....I DIDX=0 S DFLDNUM=$$FLDNUM(LEVELS(LEVEL-1))
  1. ....S DIDX=DIDX+1
  1. ....S SAVE(DFLDNUM,DIDX,0)=DATA
  1. ..I PS D Q:(ERROR!SKIP)
  1. ...N NAMEIDX
  1. ...I ($E(ITEM,PS,PS+5)'="NAME=""")!($E(ITEM,$L(ITEM))'="""") S ERROR=1 Q
  1. ...S REQNAME=$E(ITEM,PS+6,$L(ITEM)-1)
  1. ...I REQNAME="" S ERROR=1 Q
  1. ...S REQNAME=$$TRUETXT(REQNAME,1),INITNAME=REQNAME
  1. ...S TRUENAME=REQNAME,NAMEIDX=0
  1. ...I $E(INITNAME,1,8)="WORDFLD_" D
  1. ....S INITNAME=$E(INITNAME,1,13),TRUENAME=INITNAME_"1",NAMEIDX=1
  1. ...F S IEN=+$O(^TIU(8927.1,"B",TRUENAME,0)) D:+IEN Q:(SKIP!('IEN))
  1. ....N TMPXML,IDX,J,NO,LASTJ
  1. ....D ADDXML(.TMPXML,IEN)
  1. ....D STRIPLST("TMPXML")
  1. ....S (NO,IDX,LASTJ)=0,J=I,IDX=1
  1. ....F S IDX=$O(TMPXML(IDX)) Q:(IDX'>0) S J=$O(@XML@(J)) Q:(J'>0) D Q:NO
  1. .....S LASTJ=J
  1. .....I TMPXML(IDX)'=@XML@(J) S NO=1
  1. ....I 'NO S I=LASTJ-1,LINE="",SKIP=1,STATUS=1 Q
  1. ....S NAMEIDX=NAMEIDX+1
  1. ....S TRUENAME=$E(INITNAME,1,30-$L(NAMEIDX))_NAMEIDX
  1. ...I 'IEN S OK2ADD=1
  1. ...Q:SKIP
  1. ...S SAVE(.01)=TRUENAME
  1. D UPDATE(.REPORT,.SIDX,.STATUS,REQNAME,TRUENAME)
  1. I ERROR!(LEVEL>0) D
  1. .S SIDX=SIDX+1
  1. .S REPORT(SIDX)=U_0_U_"XML FORMAT ERROR"
  1. Q