source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUSRVF1.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.4 KB
Line 
1TIUSRVF1 ; SLC/JM - Server calls for Template Fields ; 02/06/2002
2 ;;1.0;TEXT INTEGRATION UTILITIES;**105,127,132**;Jun 20, 1997
3ISUNIQUE(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
9LOCK(TIUY,TIUDA) ; Lock Template Field
10 L +^TIU(8927.1,TIUDA,0):1
11 S TIUY=$T
12 Q
13UNLOCK(TIUY,TIUDA) ; Unlock Template Field
14 L -^TIU(8927.1,TIUDA,0)
15 S TIUY=1
16 Q
17DELETE(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
24LIST(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
36CANEDIT(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
47DOLMLINE(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
60DOLMTEXT(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
66CHKFLD(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
116UPDTXML(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
138XFLDLD(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
149LIMPORT(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
Note: See TracBrowser for help on using the repository browser.