TIUDD98 ; slc/KCM - Build menus in XUTL (file 8925.1) ;7/19/94 13:51 ;
;;1.0;TEXT INTEGRATION UTILITIES;;Jun 20, 1997
SET ;From: Cross reference in file 8925.98, field 99 Entry: DA Exit: DA
;NOTE: Lock ^TIU(8925.98,DA) when calling
Q:$D(^TIU(8925.98,DA,0))[0
I $D(^TIU(8925.98,DA,99)),$D(^XUTL("XQORM",DA_";TIU(8925.98,",0)),($P(^TIU(8925.98,DA,99),"^")=$P(^XUTL("XQORM",DA_";TIU(8925.98,",0),"^")) Q
N TIUCOL,TIUCCOL,TIUROW,TIUCROW,TIUPOS,TIUTOT,S1,S2,X,X1
K ^TMP("XQORM",$J) D KILL
S TIUCOL=3
S ^XUTL("XQORM",DA_";TIU(8925.98,","COL")=TIUCOL,(TIUTOT,S2)=0
F S S2=$O(^TIU(8925.98,DA,10,S2)) Q:S2'>0 D
. S X=^TIU(8925.98,DA,10,S2,0) I '$D(^TIU(8925.1,+$P(X,U),0)) Q
. S X=$S(+$P(X,"^",2):+$P(X,"^",2),$P(X,"^",3)]"":$P(X,"^",3),1:$P($G(^TIU(8925.1,+X,0)),U))
. S ^TMP("XQORM",$J,X,S2)="",TIUTOT=TIUTOT+1
S TIUROW=TIUTOT\TIUCOL+$S(TIUTOT#TIUCOL:1,1:0),TIUCCOL=1,TIUCROW=0,S1=""
F S S1=$O(^TMP("XQORM",$J,S1)) Q:S1="" S S2=0 D ;S1 is sequence
. F S S2=$O(^TMP("XQORM",$J,S1,S2)) Q:S2'>0 D ;S2 is item subscript
. . S X=^TIU(8925.98,DA,10,S2,0) ; X is the item node
. . I '$D(^TIU(8925.1,+$P(X,U),0)) D Q
. . . K ^TIU(8925.98,DA,10,S2),^TIU(8925.98,DA,10,"B",+X,S2)
. . . S $P(^TIU(8925.98,DA,10,0),"^",3,4)=S2_"^"_($P(^TIU(8925.98,DA,10,0),"^",4)-1)
. . S TIUCROW=TIUCROW+1 I TIUCROW>TIUROW S TIUCROW=1,TIUCCOL=TIUCCOL+1
. . S TIUPOS=TIUCROW+(TIUCCOL/10)
. . S X1=$S($L($P(X,"^",3)):$P(X,"^",3),1:$P(^TIU(8925.1,+$P(X,U),0),"^",3))
. . S X1=$E(X1,1,22) I $E(X1,$L(X1))=" " D
. . . N I F I=$L(X1):-1:1 Q:$E(X1,I)'=" " S X1=$E(X1,1,(I-1))
. . S X1=$TR(X1,",=;-"," ") Q:'$L(X1)
. . S ^XUTL("XQORM",DA_";TIU(8925.98,",TIUPOS,0)=S2_"^"_+$P(X,U)_"^"_X1_"^"_$P(X,"^",2)
. . S ^XUTL("XQORM",DA_";TIU(8925.98,","B",$$UP(X1),TIUPOS)=""
. . I $L($P(X,"^",2)) S ^XUTL("XQORM",DA_";TIU(8925.98,","B",$$UP($P(X,"^",2)),TIUPOS)=1
S X=$H,^XUTL("XQORM",DA_";TIU(8925.98,",0)=X,^TIU(8925.98,DA,99)=X
K ^TMP("XQORM",$J)
Q
UP(X) ; Convert X to upper case
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
KILL ; From: File 8925.98, Field 99 Entry: DA Exit: DA
K ^XUTL("XQORM",DA_";TIU(8925.98,") Q
REDO ; Update TIMESTAMP on self when Print Name Changes
; From: File 8925.9801, Field .03 Entry: DA Exit: DA
I $D(^TIU(8925.98,+$G(DA(1)),0)) S ^(99)=$H
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUDD98 2347 printed Apr 09, 2024@21:42:25 Page 2
TIUDD98 ; slc/KCM - Build menus in XUTL (file 8925.1) ;7/19/94 13:51 ;
+1 ;;1.0;TEXT INTEGRATION UTILITIES;;Jun 20, 1997
SET ;From: Cross reference in file 8925.98, field 99 Entry: DA Exit: DA
+1 ;NOTE: Lock ^TIU(8925.98,DA) when calling
+2 if $DATA(^TIU(8925.98,DA,0))[0
QUIT
+3 IF $DATA(^TIU(8925.98,DA,99))
IF $DATA(^XUTL("XQORM",DA_";TIU(8925.98,",0))
IF ($PIECE(^TIU(8925.98,DA,99),"^")=$PIECE(^XUTL("XQORM",DA_";TIU(8925.98,",0),"^"))
QUIT
+4 NEW TIUCOL,TIUCCOL,TIUROW,TIUCROW,TIUPOS,TIUTOT,S1,S2,X,X1
+5 KILL ^TMP("XQORM",$JOB)
DO KILL
+6 SET TIUCOL=3
+7 SET ^XUTL("XQORM",DA_";TIU(8925.98,","COL")=TIUCOL
SET (TIUTOT,S2)=0
+8 FOR
SET S2=$ORDER(^TIU(8925.98,DA,10,S2))
if S2'>0
QUIT
Begin DoDot:1
+9 SET X=^TIU(8925.98,DA,10,S2,0)
IF '$DATA(^TIU(8925.1,+$PIECE(X,U),0))
QUIT
+10 SET X=$SELECT(+$PIECE(X,"^",2):+$PIECE(X,"^",2),$PIECE(X,"^",3)]"":$PIECE(X,"^",3),1:$PIECE($GET(^TIU(8925.1,+X,0)),U))
+11 SET ^TMP("XQORM",$JOB,X,S2)=""
SET TIUTOT=TIUTOT+1
End DoDot:1
+12 SET TIUROW=TIUTOT\TIUCOL+$SELECT(TIUTOT#TIUCOL:1,1:0)
SET TIUCCOL=1
SET TIUCROW=0
SET S1=""
+13 ;S1 is sequence
FOR
SET S1=$ORDER(^TMP("XQORM",$JOB,S1))
if S1=""
QUIT
SET S2=0
Begin DoDot:1
+14 ;S2 is item subscript
FOR
SET S2=$ORDER(^TMP("XQORM",$JOB,S1,S2))
if S2'>0
QUIT
Begin DoDot:2
+15 ; X is the item node
SET X=^TIU(8925.98,DA,10,S2,0)
+16 IF '$DATA(^TIU(8925.1,+$PIECE(X,U),0))
Begin DoDot:3
+17 KILL ^TIU(8925.98,DA,10,S2),^TIU(8925.98,DA,10,"B",+X,S2)
+18 SET $PIECE(^TIU(8925.98,DA,10,0),"^",3,4)=S2_"^"_($PIECE(^TIU(8925.98,DA,10,0),"^",4)-1)
End DoDot:3
QUIT
+19 SET TIUCROW=TIUCROW+1
IF TIUCROW>TIUROW
SET TIUCROW=1
SET TIUCCOL=TIUCCOL+1
+20 SET TIUPOS=TIUCROW+(TIUCCOL/10)
+21 SET X1=$SELECT($LENGTH($PIECE(X,"^",3)):$PIECE(X,"^",3),1:$PIECE(^TIU(8925.1,+$PIECE(X,U),0),"^",3))
+22 SET X1=$EXTRACT(X1,1,22)
IF $EXTRACT(X1,$LENGTH(X1))=" "
Begin DoDot:3
+23 NEW I
FOR I=$LENGTH(X1):-1:1
if $EXTRACT(X1,I)'=" "
QUIT
SET X1=$EXTRACT(X1,1,(I-1))
End DoDot:3
+24 SET X1=$TRANSLATE(X1,",=;-"," ")
if '$LENGTH(X1)
QUIT
+25 SET ^XUTL("XQORM",DA_";TIU(8925.98,",TIUPOS,0)=S2_"^"_+$PIECE(X,U)_"^"_X1_"^"_$PIECE(X,"^",2)
+26 SET ^XUTL("XQORM",DA_";TIU(8925.98,","B",$$UP(X1),TIUPOS)=""
+27 IF $LENGTH($PIECE(X,"^",2))
SET ^XUTL("XQORM",DA_";TIU(8925.98,","B",$$UP($PIECE(X,"^",2)),TIUPOS)=1
End DoDot:2
End DoDot:1
+28 SET X=$HOROLOG
SET ^XUTL("XQORM",DA_";TIU(8925.98,",0)=X
SET ^TIU(8925.98,DA,99)=X
+29 KILL ^TMP("XQORM",$JOB)
+30 QUIT
UP(X) ; Convert X to upper case
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
KILL ; From: File 8925.98, Field 99 Entry: DA Exit: DA
+1 KILL ^XUTL("XQORM",DA_";TIU(8925.98,")
QUIT
REDO ; Update TIMESTAMP on self when Print Name Changes
+1 ; From: File 8925.9801, Field .03 Entry: DA Exit: DA
+2 IF $DATA(^TIU(8925.98,+$GET(DA(1)),0))
SET ^(99)=$HOROLOG
+3 QUIT
