TIUSRVF1 ; SLC/JM - Server calls for Template Fields ; 02/06/2002
;;1.0;TEXT INTEGRATION UTILITIES;**105,127,132**;Jun 20, 1997
ISUNIQUE(TIUY,NAME,IEN) ; Is Name Unique?
N FLD
S FLD=+$O(^TIU(8927.1,"B",NAME,0))
I +FLD,FLD'=IEN S TIUY=0
E S TIUY=1
Q
LOCK(TIUY,TIUDA) ; Lock Template Field
L +^TIU(8927.1,TIUDA,0):1
S TIUY=$T
Q
UNLOCK(TIUY,TIUDA) ; Unlock Template Field
L -^TIU(8927.1,TIUDA,0)
S TIUY=1
Q
DELETE(TIUY,TIUDA) ; Call ^DIK to remove a Template Field
N DIK,DA
S DA=+TIUDA
D UNLOCK(.TIUY,.TIUDA)
S DIK="^TIU(8927.1," D ^DIK
S TIUY=1
Q
LIST(Y,FROM,DIR) ; Long list of Template Fields
; .Y=returned list, FROM=text to $O from, DIR=$O direction
N I,DA,CNT,TIUD0,NODE
S I=0,CNT=80,DIR=$G(DIR,1)
F Q:I'<CNT S FROM=$O(^TIU(8927.1,"B",FROM),DIR) Q:FROM="" D
. S DA=0
. F Q:I'<CNT S DA=$O(^TIU(8927.1,"B",FROM,DA)) Q:+DA'>0 D
.. S I=I+1,Y(I)=DA_U_FROM
.. S NODE=$G(^TIU(8927.1,DA,0))
.. I +$P(NODE,U,3) S Y(I)=Y(I)_" <Inactive>"
.. S Y(I)=Y(I)_U_$P(NODE,U,2)_U_$P(NODE,U,8)_U_$P(NODE,U,16)
Q
CANEDIT(TIUY) ; Returns TRUE if the current user can edit dialog fields
S TIUY=0
I '+DUZ Q
N TIUCLASS,TIUERR,IDX,SRV
S SRV=$P($G(^VA(200,DUZ,5)),U)
D GETLST^XPAR(.TIUCLASS,DUZ_";VA(200,^SRV.`"_+$G(SRV)_"^DIV^SYS^PKG","TIU FIELD EDITOR CLASSES","Q",.TIUERR)
I TIUERR>0 Q
S IDX=0
F S IDX=$O(TIUCLASS(IDX)) Q:'IDX D Q:+TIUY
.I $$ISA^USRLM(DUZ,$P(TIUCLASS(IDX),U,2),.TIUERR) S TIUY=1
Q
DOLMLINE(TIUX) ; finds Template Fields in a Line and replaces with LM Text
N I,J,OUT,NAME,LMTEXT,IDX
S OUT=TIUX
F S I=$F(OUT,"{FLD:") Q:'I D
. S J=$F(OUT,"}",I)
. I J>0 S NAME=$E(OUT,I,J-2)
. E S NAME="",J=I
. S LMTEXT=""
. I NAME'="" D
. . S IDX=$O(^TIU(8927.1,"B",NAME,0))
. . I +IDX S LMTEXT=$P($G(^TIU(8927.1,IDX,0)),U,6)
. S OUT=$E(OUT,1,I-6)_LMTEXT_$E(OUT,J,512)
Q OUT
DOLMTEXT(TIUY,TIULIST) ; finds Template Fields and replaces with LM Text
N I,LINE
S I=0
F S I=$O(TIULIST(I)) Q:'I D
. S TIUY(I)=$$DOLMLINE(TIULIST(I,0))
Q
CHKFLD(RESULT) ;Input: <None>
;Output: RESULT (see below for description)
;Similar to IMPORT^TIUSRVF; takes and parses XML fields to
;see if they have a matching field in the database. Also resolves self
;referencing fields, and updates the XML. Returns RESULT, which is a
;list of fields in format ORIGINAL_FIELD_NAME^CODE^NEW_FIELD_NAME.
;If the CODE is 1 or 2, then the NEW_FIELD_NAME is blank. If the CODE
;is 0, then the NEW_FIELD_NAME has the renamed field name. In that
;case, the XML has been updated with the new name where ever the
;original name had occurred.
N FIRST,RENAME,SAVESET,I,J,X,Y,OLD,ERR,CURS,CUR,RSET,K,FSET
S FIRST=1,RENAME=0,I=0,ERR=0,FSET="^TMP(""TIUFLDXML"",$J)"
;LOOP UNTIL THE XML FIELD NAMES DON'T NEED TO BE RENAMED AND THE
;XML NO LONGER NEEDS TO BE UPDATED
F D Q:ERR!('RENAME)
.D IMPORT2^TIUSRVF(.RSET,FSET,0)
.I FIRST S FIRST=0,I=0 F S I=$O(RSET(I)) Q:I'>0 S SAVESET(I)=$P(RSET(I),U,1)
.S I=0
.F S I=$O(RSET(I)) Q:(I'>0)!ERR I $P(RSET(I),U,3)="XML FORMAT ERROR" S ERR=1
.Q:ERR
.S I=0,RENAME=0
.;LOOP THROUGH THE NAMES AND RENAME DUPLICATE NAMES
.F S I=$O(RSET(I)) Q:I'>0 D
..S CURS=$P(RSET(I),U,2),X=1
..I CURS="0" S X=3,RENAME=1
..I $L(CURS)>1 D
...S CURS=$E(CURS,3,$L(CURS)),OLD=$P(RSET(I),U,1)
...I CURS=OLD S RSET(I)=CURS_U_2
...E S RSET(I)=OLD_U_0_U_CURS,X=3,RENAME=1
..S CUR=$P(RSET(I),U,X),J=0
..F S J=$O(RSET(J)) Q:(J'<I) D
...S K=$P(RSET(J),U,2),Y=1 I +K=0 S Y=3
...S OLD=$P(RSET(J),U,Y)
...I OLD=CUR D ;SAME NAME FOUND; RENAME CURRENT ITEM
....S Y=1
....I X=3 S Y=1+(+$E(CUR,$L($P(RSET(I),U,1))+1,$L(CUR)))
....S $P(RSET(I),U,2)=0,$P(RSET(I),U,3)=$P(RSET(I),U,1)_Y
....S X=3,J=0,CUR=$P(RSET(I),U,X),RENAME=1
.I RENAME D UPDTXML(.RSET,FSET)
I 'ERR D
.S I=0,J=0
.F S I=$O(SAVESET(I)) S J=$O(RSET(J)) Q:(I'>0)!(J'>0) D
..I SAVESET(I)'=$P(RSET(J),U,1) D
...S Y=$P(RSET(J),U,2)
...I +Y=1 S X=0 ; CHANGE THIS X=0 TO X=3 WHEN THE GUI IS READY
...E S X=0
...S $P(RSET(J),U,2)=X,$P(RSET(J),U,3)=$P(RSET(J),U,1),$P(RSET(J),U,1)=SAVESET(I)
S I=0,J=0
F S I=$O(RSET(I)),J=J+1 Q:I'>0 S RESULT(J)=RSET(I)
Q
UPDTXML(NAMESET,XSET) ; UPDATES THE XSET WITH UPDATED NAMES IN THE NAMESET
N FND,I,J,PA1,PA2,PB1,PB2,P1,P2,P3
S I=0,J=0
F S I=$O(NAMESET(I)) Q:I'>0 D
.I $P(NAMESET(I),U,2)="0" S J=J+1
.E K NAMESET(I)
Q:J'>0
S I=0
F S I=$O(NAMESET(I)) Q:I'>0 D
.S P1=$P(NAMESET(I),U,1),P2=$P(NAMESET(I),U,2),P3=$P(NAMESET(I),U,3)
.S NAMESET(I)=$$XMLCONV^TIUSRVF(P1,0,1)_U_P2_U_$$XMLCONV^TIUSRVF(P3,0,1)
S I=0
;MAIN LOOP - CURRENT XML LINE
F S I=$O(@XSET@(I)),FND=0,J=0 Q:I'>0 D
.S PA1=$F(@XSET@(I),"<FIELD NAME="""),PA2=$F(@XSET@(I),"""",PA1)
.S PB1=$F(@XSET@(I),"{FLD:"),PB2=$F(@XSET@(I),"}",PB1)
.I (PA1&PA2) S PA2=PA2-2,FND=1
.I (PB1&PB2) S PA1=PB1,PA2=PB2-2,FND=1
.I FND F S J=$O(NAMESET(J)) Q:J'>0 D Q:J'>0
..I $P(NAMESET(J),U,2)=0,$E(@XSET@(I),PA1,PA2)=$P(NAMESET(J),U,1) D
...S $E(@XSET@(I),PA1,PA2)=$P(NAMESET(J),U,3),J=0
Q
XFLDLD(RESULT,IN) ; RESETS/UPDATES THE TMP("TIUFLDXML",$J) GLOBAL
;WITH THE STRING PASSED IN "IN". IF THE 1ST LINE IS SUBSCRIPTED
;AS 1, THE PROGRAM CLEARS THE TMP GLOBAL FIRST. RETURNS "1" IF
;THIS CALL WAS SUCCESSFUL, "0" OTHERWISE.
N X
S X=0
S X=$O(IN(X))
I +X=1 K ^TMP("TIUFLDXML",$J)
M ^TMP("TIUFLDXML",$J)=IN
S RESULT(1)=1
Q
LIMPORT(RESULT) ; Calls the import process to import all of the fields in the
;^TMP global for this process. Result contains a list of NAME^X^RENAME
;strings.
D IMPORT2^TIUSRVF(.RESULT,"^TMP(""TIUFLDXML"",$J)",1)
Q
TIUSRVF1 ; SLC/JM - Server calls for Template Fields ; 02/06/2002
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**105,127,132**;Jun 20, 1997
ISUNIQUE(TIUY,NAME,IEN) ; Is Name Unique?
+1 NEW FLD
+2 SET FLD=+$ORDER(^TIU(8927.1,"B",NAME,0))
+3 IF +FLD
IF FLD'=IEN
SET TIUY=0
+4 IF '$TEST
SET TIUY=1
+5 QUIT
LOCK(TIUY,TIUDA) ; Lock Template Field
+1 LOCK +^TIU(8927.1,TIUDA,0):1
+2 SET TIUY=$TEST
+3 QUIT
UNLOCK(TIUY,TIUDA) ; Unlock Template Field
+1 LOCK -^TIU(8927.1,TIUDA,0)
+2 SET TIUY=1
+3 QUIT
DELETE(TIUY,TIUDA) ; Call ^DIK to remove a Template Field
+1 NEW DIK,DA
+2 SET DA=+TIUDA
+3 DO UNLOCK(.TIUY,.TIUDA)
+4 SET DIK="^TIU(8927.1,"
DO ^DIK
+5 SET TIUY=1
+6 QUIT
LIST(Y,FROM,DIR) ; Long list of Template Fields
+1 ; .Y=returned list, FROM=text to $O from, DIR=$O direction
+2 NEW I,DA,CNT,TIUD0,NODE
+3 SET I=0
SET CNT=80
SET DIR=$GET(DIR,1)
+4 FOR
IF I'<CNT
QUIT
SET FROM=$ORDER(^TIU(8927.1,"B",FROM),DIR)
IF FROM=""
QUIT
Begin DoDot:1
+5 SET DA=0
+6 FOR
IF I'<CNT
QUIT
SET DA=$ORDER(^TIU(8927.1,"B",FROM,DA))
IF +DA'>0
QUIT
Begin DoDot:2
+7 SET I=I+1
SET Y(I)=DA_U_FROM
+8 SET NODE=$GET(^TIU(8927.1,DA,0))
+9 IF +$PIECE(NODE,U,3)
SET Y(I)=Y(I)_" <Inactive>"
+10 SET Y(I)=Y(I)_U_$PIECE(NODE,U,2)_U_$PIECE(NODE,U,8)_U_$PIECE(NODE,U,16)
End DoDot:2
End DoDot:1
+11 QUIT
CANEDIT(TIUY) ; Returns TRUE if the current user can edit dialog fields
+1 SET TIUY=0
+2 IF '+DUZ
QUIT
+3 NEW TIUCLASS,TIUERR,IDX,SRV
+4 SET SRV=$PIECE($GET(^VA(200,DUZ,5)),U)
+5 DO GETLST^XPAR(.TIUCLASS,DUZ_";VA(200,^SRV.`"_+$GET(SRV)_"^DIV^SYS^PKG","TIU FIELD EDITOR CLASSES","Q",.TIUERR)
+6 IF TIUERR>0
QUIT
+7 SET IDX=0
+8 FOR
SET IDX=$ORDER(TIUCLASS(IDX))
IF 'IDX
QUIT
Begin DoDot:1
+9 IF $$ISA^USRLM(DUZ,$PIECE(TIUCLASS(IDX),U,2),.TIUERR)
SET TIUY=1
End DoDot:1
IF +TIUY
QUIT
+10 QUIT
DOLMLINE(TIUX) ; finds Template Fields in a Line and replaces with LM Text
+1 NEW I,J,OUT,NAME,LMTEXT,IDX
+2 SET OUT=TIUX
+3 FOR
SET I=$FIND(OUT,"{FLD:")
IF 'I
QUIT
Begin DoDot:1
+4 SET J=$FIND(OUT,"}",I)
+5 IF J>0
SET NAME=$EXTRACT(OUT,I,J-2)
+6 IF '$TEST
SET NAME=""
SET J=I
+7 SET LMTEXT=""
+8 IF NAME'=""
Begin DoDot:2
+9 SET IDX=$ORDER(^TIU(8927.1,"B",NAME,0))
+10 IF +IDX
SET LMTEXT=$PIECE($GET(^TIU(8927.1,IDX,0)),U,6)
End DoDot:2
+11 SET OUT=$EXTRACT(OUT,1,I-6)_LMTEXT_$EXTRACT(OUT,J,512)
End DoDot:1
+12 QUIT OUT
DOLMTEXT(TIUY,TIULIST) ; finds Template Fields and replaces with LM Text
+1 NEW I,LINE
+2 SET I=0
+3 FOR
SET I=$ORDER(TIULIST(I))
IF 'I
QUIT
Begin DoDot:1
+4 SET TIUY(I)=$$DOLMLINE(TIULIST(I,0))
End DoDot:1
+5 QUIT
CHKFLD(RESULT) ;Input: <None>
+1 ;Output: RESULT (see below for description)
+2 ;Similar to IMPORT^TIUSRVF; takes and parses XML fields to
+3 ;see if they have a matching field in the database. Also resolves self
+4 ;referencing fields, and updates the XML. Returns RESULT, which is a
+5 ;list of fields in format ORIGINAL_FIELD_NAME^CODE^NEW_FIELD_NAME.
+6 ;If the CODE is 1 or 2, then the NEW_FIELD_NAME is blank. If the CODE
+7 ;is 0, then the NEW_FIELD_NAME has the renamed field name. In that
+8 ;case, the XML has been updated with the new name where ever the
+9 ;original name had occurred.
+10 NEW FIRST,RENAME,SAVESET,I,J,X,Y,OLD,ERR,CURS,CUR,RSET,K,FSET
+11 SET FIRST=1
SET RENAME=0
SET I=0
SET ERR=0
SET FSET="^TMP(""TIUFLDXML"",$J)"
+12 ;LOOP UNTIL THE XML FIELD NAMES DON'T NEED TO BE RENAMED AND THE
+13 ;XML NO LONGER NEEDS TO BE UPDATED
+14 FOR
Begin DoDot:1
+15 DO IMPORT2^TIUSRVF(.RSET,FSET,0)
+16 IF FIRST
SET FIRST=0
SET I=0
FOR
SET I=$ORDER(RSET(I))
IF I'>0
QUIT
SET SAVESET(I)=$PIECE(RSET(I),U,1)
+17 SET I=0
+18 FOR
SET I=$ORDER(RSET(I))
IF (I'>0)!ERR
QUIT
IF $PIECE(RSET(I),U,3)="XML FORMAT ERROR"
SET ERR=1
+19 IF ERR
QUIT
+20 SET I=0
SET RENAME=0
+21 ;LOOP THROUGH THE NAMES AND RENAME DUPLICATE NAMES
+22 FOR
SET I=$ORDER(RSET(I))
IF I'>0
QUIT
Begin DoDot:2
+23 SET CURS=$PIECE(RSET(I),U,2)
SET X=1
+24 IF CURS="0"
SET X=3
SET RENAME=1
+25 IF $LENGTH(CURS)>1
Begin DoDot:3
+26 SET CURS=$EXTRACT(CURS,3,$LENGTH(CURS))
SET OLD=$PIECE(RSET(I),U,1)
+27 IF CURS=OLD
SET RSET(I)=CURS_U_2
+28 IF '$TEST
SET RSET(I)=OLD_U_0_U_CURS
SET X=3
SET RENAME=1
End DoDot:3
+29 SET CUR=$PIECE(RSET(I),U,X)
SET J=0
+30 FOR
SET J=$ORDER(RSET(J))
IF (J'<I)
QUIT
Begin DoDot:3
+31 SET K=$PIECE(RSET(J),U,2)
SET Y=1
IF +K=0
SET Y=3
+32 SET OLD=$PIECE(RSET(J),U,Y)
+33 ;SAME NAME FOUND; RENAME CURRENT ITEM
IF OLD=CUR
Begin DoDot:4
+34 SET Y=1
+35 IF X=3
SET Y=1+(+$EXTRACT(CUR,$LENGTH($PIECE(RSET(I),U,1))+1,$LENGTH(CUR)))
+36 SET $PIECE(RSET(I),U,2)=0
SET $PIECE(RSET(I),U,3)=$PIECE(RSET(I),U,1)_Y
+37 SET X=3
SET J=0
SET CUR=$PIECE(RSET(I),U,X)
SET RENAME=1
End DoDot:4
End DoDot:3
End DoDot:2
+38 IF RENAME
DO UPDTXML(.RSET,FSET)
End DoDot:1
IF ERR!('RENAME)
QUIT
+39 IF 'ERR
Begin DoDot:1
+40 SET I=0
SET J=0
+41 FOR
SET I=$ORDER(SAVESET(I))
SET J=$ORDER(RSET(J))
IF (I'>0)!(J'>0)
QUIT
Begin DoDot:2
+42 IF SAVESET(I)'=$PIECE(RSET(J),U,1)
Begin DoDot:3
+43 SET Y=$PIECE(RSET(J),U,2)
+44 ; CHANGE THIS X=0 TO X=3 WHEN THE GUI IS READY
IF +Y=1
SET X=0
+45 IF '$TEST
SET X=0
+46 SET $PIECE(RSET(J),U,2)=X
SET $PIECE(RSET(J),U,3)=$PIECE(RSET(J),U,1)
SET $PIECE(RSET(J),U,1)=SAVESET(I)
End DoDot:3
End DoDot:2
End DoDot:1
+47 SET I=0
SET J=0
+48 FOR
SET I=$ORDER(RSET(I))
SET J=J+1
IF I'>0
QUIT
SET RESULT(J)=RSET(I)
+49 QUIT
UPDTXML(NAMESET,XSET) ; UPDATES THE XSET WITH UPDATED NAMES IN THE NAMESET
+1 NEW FND,I,J,PA1,PA2,PB1,PB2,P1,P2,P3
+2 SET I=0
SET J=0
+3 FOR
SET I=$ORDER(NAMESET(I))
IF I'>0
QUIT
Begin DoDot:1
+4 IF $PIECE(NAMESET(I),U,2)="0"
SET J=J+1
+5 IF '$TEST
KILL NAMESET(I)
End DoDot:1
+6 IF J'>0
QUIT
+7 SET I=0
+8 FOR
SET I=$ORDER(NAMESET(I))
IF I'>0
QUIT
Begin DoDot:1
+9 SET P1=$PIECE(NAMESET(I),U,1)
SET P2=$PIECE(NAMESET(I),U,2)
SET P3=$PIECE(NAMESET(I),U,3)
+10 SET NAMESET(I)=$$XMLCONV^TIUSRVF(P1,0,1)_U_P2_U_$$XMLCONV^TIUSRVF(P3,0,1)
End DoDot:1
+11 SET I=0
+12 ;MAIN LOOP - CURRENT XML LINE
+13 FOR
SET I=$ORDER(@XSET@(I))
SET FND=0
SET J=0
IF I'>0
QUIT
Begin DoDot:1
+14 SET PA1=$FIND(@XSET@(I),"<FIELD NAME=""")
SET PA2=$FIND(@XSET@(I),"""",PA1)
+15 SET PB1=$FIND(@XSET@(I),"{FLD:")
SET PB2=$FIND(@XSET@(I),"}",PB1)
+16 IF (PA1&PA2)
SET PA2=PA2-2
SET FND=1
+17 IF (PB1&PB2)
SET PA1=PB1
SET PA2=PB2-2
SET FND=1
+18 IF FND
FOR
SET J=$ORDER(NAMESET(J))
IF J'>0
QUIT
Begin DoDot:2
+19 IF $PIECE(NAMESET(J),U,2)=0
IF $EXTRACT(@XSET@(I),PA1,PA2)=$PIECE(NAMESET(J),U,1)
Begin DoDot:3
+20 SET $EXTRACT(@XSET@(I),PA1,PA2)=$PIECE(NAMESET(J),U,3)
SET J=0
End DoDot:3
End DoDot:2
IF J'>0
QUIT
End DoDot:1
+21 QUIT
XFLDLD(RESULT,IN) ; RESETS/UPDATES THE TMP("TIUFLDXML",$J) GLOBAL
+1 ;WITH THE STRING PASSED IN "IN". IF THE 1ST LINE IS SUBSCRIPTED
+2 ;AS 1, THE PROGRAM CLEARS THE TMP GLOBAL FIRST. RETURNS "1" IF
+3 ;THIS CALL WAS SUCCESSFUL, "0" OTHERWISE.
+4 NEW X
+5 SET X=0
+6 SET X=$ORDER(IN(X))
+7 IF +X=1
KILL ^TMP("TIUFLDXML",$JOB)
+8 MERGE ^TMP("TIUFLDXML",$JOB)=IN
+9 SET RESULT(1)=1
+10 QUIT
LIMPORT(RESULT) ; Calls the import process to import all of the fields in the
+1 ;^TMP global for this process. Result contains a list of NAME^X^RENAME
+2 ;strings.
+3 DO IMPORT2^TIUSRVF(.RESULT,"^TMP(""TIUFLDXML"",$J)",1)
+4 QUIT
