[613] | 1 | TIUSRVF1 ; SLC/JM - Server calls for Template Fields ; 02/06/2002
|
---|
| 2 | ;;1.0;TEXT INTEGRATION UTILITIES;**105,127,132**;Jun 20, 1997
|
---|
| 3 | ISUNIQUE(TIUY,NAME,IEN) ; Is Name Unique?
|
---|
| 4 | N FLD
|
---|
| 5 | S FLD=+$O(^TIU(8927.1,"B",NAME,0))
|
---|
| 6 | I +FLD,FLD'=IEN S TIUY=0
|
---|
| 7 | E S TIUY=1
|
---|
| 8 | Q
|
---|
| 9 | LOCK(TIUY,TIUDA) ; Lock Template Field
|
---|
| 10 | L +^TIU(8927.1,TIUDA,0):1
|
---|
| 11 | S TIUY=$T
|
---|
| 12 | Q
|
---|
| 13 | UNLOCK(TIUY,TIUDA) ; Unlock Template Field
|
---|
| 14 | L -^TIU(8927.1,TIUDA,0)
|
---|
| 15 | S TIUY=1
|
---|
| 16 | Q
|
---|
| 17 | DELETE(TIUY,TIUDA) ; Call ^DIK to remove a Template Field
|
---|
| 18 | N DIK,DA
|
---|
| 19 | S DA=+TIUDA
|
---|
| 20 | D UNLOCK(.TIUY,.TIUDA)
|
---|
| 21 | S DIK="^TIU(8927.1," D ^DIK
|
---|
| 22 | S TIUY=1
|
---|
| 23 | Q
|
---|
| 24 | LIST(Y,FROM,DIR) ; Long list of Template Fields
|
---|
| 25 | ; .Y=returned list, FROM=text to $O from, DIR=$O direction
|
---|
| 26 | N I,DA,CNT,TIUD0,NODE
|
---|
| 27 | S I=0,CNT=80,DIR=$G(DIR,1)
|
---|
| 28 | F Q:I'<CNT S FROM=$O(^TIU(8927.1,"B",FROM),DIR) Q:FROM="" D
|
---|
| 29 | . S DA=0
|
---|
| 30 | . F Q:I'<CNT S DA=$O(^TIU(8927.1,"B",FROM,DA)) Q:+DA'>0 D
|
---|
| 31 | .. S I=I+1,Y(I)=DA_U_FROM
|
---|
| 32 | .. S NODE=$G(^TIU(8927.1,DA,0))
|
---|
| 33 | .. I +$P(NODE,U,3) S Y(I)=Y(I)_" <Inactive>"
|
---|
| 34 | .. S Y(I)=Y(I)_U_$P(NODE,U,2)_U_$P(NODE,U,8)_U_$P(NODE,U,16)
|
---|
| 35 | Q
|
---|
| 36 | CANEDIT(TIUY) ; Returns TRUE if the current user can edit dialog fields
|
---|
| 37 | S TIUY=0
|
---|
| 38 | I '+DUZ Q
|
---|
| 39 | N TIUCLASS,TIUERR,IDX,SRV
|
---|
| 40 | S SRV=$P($G(^VA(200,DUZ,5)),U)
|
---|
| 41 | D GETLST^XPAR(.TIUCLASS,DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","TIU FIELD EDITOR CLASSES","Q",.TIUERR)
|
---|
| 42 | I TIUERR>0 Q
|
---|
| 43 | S IDX=0
|
---|
| 44 | F S IDX=$O(TIUCLASS(IDX)) Q:'IDX D Q:+TIUY
|
---|
| 45 | .I $$ISA^USRLM(DUZ,$P(TIUCLASS(IDX),U,2),.TIUERR) S TIUY=1
|
---|
| 46 | Q
|
---|
| 47 | DOLMLINE(TIUX) ; finds Template Fields in a Line and replaces with LM Text
|
---|
| 48 | N I,J,OUT,NAME,LMTEXT,IDX
|
---|
| 49 | S OUT=TIUX
|
---|
| 50 | F S I=$F(OUT,"{FLD:") Q:'I D
|
---|
| 51 | . S J=$F(OUT,"}",I)
|
---|
| 52 | . I J>0 S NAME=$E(OUT,I,J-2)
|
---|
| 53 | . E S NAME="",J=I
|
---|
| 54 | . S LMTEXT=""
|
---|
| 55 | . I NAME'="" D
|
---|
| 56 | . . S IDX=$O(^TIU(8927.1,"B",NAME,0))
|
---|
| 57 | . . I +IDX S LMTEXT=$P($G(^TIU(8927.1,IDX,0)),U,6)
|
---|
| 58 | . S OUT=$E(OUT,1,I-6)_LMTEXT_$E(OUT,J,512)
|
---|
| 59 | Q OUT
|
---|
| 60 | DOLMTEXT(TIUY,TIULIST) ; finds Template Fields and replaces with LM Text
|
---|
| 61 | N I,LINE
|
---|
| 62 | S I=0
|
---|
| 63 | F S I=$O(TIULIST(I)) Q:'I D
|
---|
| 64 | . S TIUY(I)=$$DOLMLINE(TIULIST(I,0))
|
---|
| 65 | Q
|
---|
| 66 | CHKFLD(RESULT) ;Input: <None>
|
---|
| 67 | ;Output: RESULT (see below for description)
|
---|
| 68 | ;Similar to IMPORT^TIUSRVF; takes and parses XML fields to
|
---|
| 69 | ;see if they have a matching field in the database. Also resolves self
|
---|
| 70 | ;referencing fields, and updates the XML. Returns RESULT, which is a
|
---|
| 71 | ;list of fields in format ORIGINAL_FIELD_NAME^CODE^NEW_FIELD_NAME.
|
---|
| 72 | ;If the CODE is 1 or 2, then the NEW_FIELD_NAME is blank. If the CODE
|
---|
| 73 | ;is 0, then the NEW_FIELD_NAME has the renamed field name. In that
|
---|
| 74 | ;case, the XML has been updated with the new name where ever the
|
---|
| 75 | ;original name had occurred.
|
---|
| 76 | N FIRST,RENAME,SAVESET,I,J,X,Y,OLD,ERR,CURS,CUR,RSET,K,FSET
|
---|
| 77 | S FIRST=1,RENAME=0,I=0,ERR=0,FSET="^TMP(""TIUFLDXML"",$J)"
|
---|
| 78 | ;LOOP UNTIL THE XML FIELD NAMES DON'T NEED TO BE RENAMED AND THE
|
---|
| 79 | ;XML NO LONGER NEEDS TO BE UPDATED
|
---|
| 80 | F D Q:ERR!('RENAME)
|
---|
| 81 | .D IMPORT2^TIUSRVF(.RSET,FSET,0)
|
---|
| 82 | .I FIRST S FIRST=0,I=0 F S I=$O(RSET(I)) Q:I'>0 S SAVESET(I)=$P(RSET(I),U,1)
|
---|
| 83 | .S I=0
|
---|
| 84 | .F S I=$O(RSET(I)) Q:(I'>0)!ERR I $P(RSET(I),U,3)="XML FORMAT ERROR" S ERR=1
|
---|
| 85 | .Q:ERR
|
---|
| 86 | .S I=0,RENAME=0
|
---|
| 87 | .;LOOP THROUGH THE NAMES AND RENAME DUPLICATE NAMES
|
---|
| 88 | .F S I=$O(RSET(I)) Q:I'>0 D
|
---|
| 89 | ..S CURS=$P(RSET(I),U,2),X=1
|
---|
| 90 | ..I CURS="0" S X=3,RENAME=1
|
---|
| 91 | ..I $L(CURS)>1 D
|
---|
| 92 | ...S CURS=$E(CURS,3,$L(CURS)),OLD=$P(RSET(I),U,1)
|
---|
| 93 | ...I CURS=OLD S RSET(I)=CURS_U_2
|
---|
| 94 | ...E S RSET(I)=OLD_U_0_U_CURS,X=3,RENAME=1
|
---|
| 95 | ..S CUR=$P(RSET(I),U,X),J=0
|
---|
| 96 | ..F S J=$O(RSET(J)) Q:(J'<I) D
|
---|
| 97 | ...S K=$P(RSET(J),U,2),Y=1 I +K=0 S Y=3
|
---|
| 98 | ...S OLD=$P(RSET(J),U,Y)
|
---|
| 99 | ...I OLD=CUR D ;SAME NAME FOUND; RENAME CURRENT ITEM
|
---|
| 100 | ....S Y=1
|
---|
| 101 | ....I X=3 S Y=1+(+$E(CUR,$L($P(RSET(I),U,1))+1,$L(CUR)))
|
---|
| 102 | ....S $P(RSET(I),U,2)=0,$P(RSET(I),U,3)=$P(RSET(I),U,1)_Y
|
---|
| 103 | ....S X=3,J=0,CUR=$P(RSET(I),U,X),RENAME=1
|
---|
| 104 | .I RENAME D UPDTXML(.RSET,FSET)
|
---|
| 105 | I 'ERR D
|
---|
| 106 | .S I=0,J=0
|
---|
| 107 | .F S I=$O(SAVESET(I)) S J=$O(RSET(J)) Q:(I'>0)!(J'>0) D
|
---|
| 108 | ..I SAVESET(I)'=$P(RSET(J),U,1) D
|
---|
| 109 | ...S Y=$P(RSET(J),U,2)
|
---|
| 110 | ...I +Y=1 S X=0 ; CHANGE THIS X=0 TO X=3 WHEN THE GUI IS READY
|
---|
| 111 | ...E S X=0
|
---|
| 112 | ...S $P(RSET(J),U,2)=X,$P(RSET(J),U,3)=$P(RSET(J),U,1),$P(RSET(J),U,1)=SAVESET(I)
|
---|
| 113 | S I=0,J=0
|
---|
| 114 | F S I=$O(RSET(I)),J=J+1 Q:I'>0 S RESULT(J)=RSET(I)
|
---|
| 115 | Q
|
---|
| 116 | UPDTXML(NAMESET,XSET) ; UPDATES THE XSET WITH UPDATED NAMES IN THE NAMESET
|
---|
| 117 | N FND,I,J,PA1,PA2,PB1,PB2,P1,P2,P3
|
---|
| 118 | S I=0,J=0
|
---|
| 119 | F S I=$O(NAMESET(I)) Q:I'>0 D
|
---|
| 120 | .I $P(NAMESET(I),U,2)="0" S J=J+1
|
---|
| 121 | .E K NAMESET(I)
|
---|
| 122 | Q:J'>0
|
---|
| 123 | S I=0
|
---|
| 124 | F S I=$O(NAMESET(I)) Q:I'>0 D
|
---|
| 125 | .S P1=$P(NAMESET(I),U,1),P2=$P(NAMESET(I),U,2),P3=$P(NAMESET(I),U,3)
|
---|
| 126 | .S NAMESET(I)=$$XMLCONV^TIUSRVF(P1,0,1)_U_P2_U_$$XMLCONV^TIUSRVF(P3,0,1)
|
---|
| 127 | S I=0
|
---|
| 128 | ;MAIN LOOP - CURRENT XML LINE
|
---|
| 129 | F S I=$O(@XSET@(I)),FND=0,J=0 Q:I'>0 D
|
---|
| 130 | .S PA1=$F(@XSET@(I),"<FIELD NAME="""),PA2=$F(@XSET@(I),"""",PA1)
|
---|
| 131 | .S PB1=$F(@XSET@(I),"{FLD:"),PB2=$F(@XSET@(I),"}",PB1)
|
---|
| 132 | .I (PA1&PA2) S PA2=PA2-2,FND=1
|
---|
| 133 | .I (PB1&PB2) S PA1=PB1,PA2=PB2-2,FND=1
|
---|
| 134 | .I FND F S J=$O(NAMESET(J)) Q:J'>0 D Q:J'>0
|
---|
| 135 | ..I $P(NAMESET(J),U,2)=0,$E(@XSET@(I),PA1,PA2)=$P(NAMESET(J),U,1) D
|
---|
| 136 | ...S $E(@XSET@(I),PA1,PA2)=$P(NAMESET(J),U,3),J=0
|
---|
| 137 | Q
|
---|
| 138 | XFLDLD(RESULT,IN) ; RESETS/UPDATES THE TMP("TIUFLDXML",$J) GLOBAL
|
---|
| 139 | ;WITH THE STRING PASSED IN "IN". IF THE 1ST LINE IS SUBSCRIPTED
|
---|
| 140 | ;AS 1, THE PROGRAM CLEARS THE TMP GLOBAL FIRST. RETURNS "1" IF
|
---|
| 141 | ;THIS CALL WAS SUCCESSFUL, "0" OTHERWISE.
|
---|
| 142 | N X
|
---|
| 143 | S X=0
|
---|
| 144 | S X=$O(IN(X))
|
---|
| 145 | I +X=1 K ^TMP("TIUFLDXML",$J)
|
---|
| 146 | M ^TMP("TIUFLDXML",$J)=IN
|
---|
| 147 | S RESULT(1)=1
|
---|
| 148 | Q
|
---|
| 149 | LIMPORT(RESULT) ; Calls the import process to import all of the fields in the
|
---|
| 150 | ;^TMP global for this process. Result contains a list of NAME^X^RENAME
|
---|
| 151 | ;strings.
|
---|
| 152 | D IMPORT2^TIUSRVF(.RESULT,"^TMP(""TIUFLDXML"",$J)",1)
|
---|
| 153 | Q
|
---|