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

TIUDD.m

Go to the documentation of this file.
  1. TIUDD ; slc/KCM - Build menus in XUTL (file 8925.1) ;7/19/94 13:51 ;
  1. ;;1.0;TEXT INTEGRATION UTILITIES;;Jun 20, 1997
  1. SET ;From: Cross reference in file 8925.1, field 99 Entry: DA Exit: DA
  1. ;NOTE: Lock ^TIU(8925.1,DA) when calling
  1. Q:$D(^TIU(8925.1,DA,0))[0
  1. I $D(^TIU(8925.1,DA,99)),$D(^XUTL("XQORM",DA_";TIU(8925.1,",0)),($P(^TIU(8925.1,DA,99),"^")=$P(^XUTL("XQORM",DA_";TIU(8925.1,",0),"^")) Q
  1. N TIUCOL,TIUCCOL,TIUROW,TIUCROW,TIUPOS,TIUTOT,S1,S2,X,X1
  1. K ^TMP("XQORM",$J) D KILL
  1. S TIUCOL=3
  1. S ^XUTL("XQORM",DA_";TIU(8925.1,","COL")=TIUCOL,(TIUTOT,S2)=0
  1. F S S2=$O(^TIU(8925.1,DA,10,S2)) Q:S2'>0 D
  1. . S X=^TIU(8925.1,DA,10,S2,0) I '$D(^TIU(8925.1,+X,0)) Q
  1. . S X=$S(+$P(X,"^",3):+$P(X,"^",3),+$P(X,"^",2):+$P(X,"^",2),$L($P(X,"^",2)):"M"_$P(X,"^",2),1:"Z"_$P(^TIU(8925.1,+X,0),"^",2))
  1. . S ^TMP("XQORM",$J,X,S2)="",TIUTOT=TIUTOT+1
  1. S TIUROW=TIUTOT\TIUCOL+$S(TIUTOT#TIUCOL:1,1:0),TIUCCOL=1,TIUCROW=0,S1=""
  1. F S S1=$O(^TMP("XQORM",$J,S1)) Q:S1="" S S2=0 D ;S1 is sequence
  1. . F S S2=$O(^TMP("XQORM",$J,S1,S2)) Q:S2'>0 D ;S2 is item subscript
  1. . . S X=^TIU(8925.1,DA,10,S2,0) ; X is the item node
  1. . . I '$D(^TIU(8925.1,+X,0)) K ^TIU(8925.1,DA,10,S2),^("B",+X,S2) S $P(^TIU(8925.1,DA,10,0),"^",3,4)=S2_"^"_($P(^TIU(8925.1,DA,10,0),"^",4)-1) Q
  1. . . S TIUCROW=TIUCROW+1 I TIUCROW>TIUROW S TIUCROW=1,TIUCCOL=TIUCCOL+1
  1. . . S TIUPOS=TIUCROW+(TIUCCOL/10)
  1. . . S X1=$S($L($P(X,"^",4)):$P(X,"^",4),1:$P(^TIU(8925.1,+X,0),"^",3))
  1. . . S X1=$TR(X1,",=;-"," ") Q:'$L(X1)
  1. . . S ^XUTL("XQORM",DA_";TIU(8925.1,",TIUPOS,0)=S2_"^"_+X_"^"_X1_"^"_$P(X,"^",2)
  1. . . S ^XUTL("XQORM",DA_";TIU(8925.1,","B",$$UP(X1),TIUPOS)=""
  1. . . I $L($P(X,"^",2)) S ^XUTL("XQORM",DA_";TIU(8925.1,","B",$$UP($P(X,"^",2)),TIUPOS)=1
  1. S X=$H,^XUTL("XQORM",DA_";TIU(8925.1,",0)=X,^TIU(8925.1,DA,99)=X
  1. K ^TMP("XQORM",$J)
  1. Q
  1. UP(X) ; Convert X to upper case
  1. Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. KILL ; From: File 8925.1, Field 99 Entry: DA Exit: DA
  1. K ^XUTL("XQORM",DA_";TIU(8925.1,") Q
  1. REDO ; Update TIMESTAMP on self & parents when Print Name Changes
  1. ; From: File 8925.1, Field .03 Entry: DA Exit: DA
  1. N I,X S X=$H I $D(^TIU(8925.1,DA,0)) S ^(99)=X,I=0
  1. F S I=$O(^TIU(8925.1,"AD",DA,I)) Q:I'>0 D
  1. . I $D(^TIU(8925.1,I,0)) S ^(99)=X
  1. Q
  1. REDOX ; From: Subfile 8925.14, Fields .01,2,3 Entry: DA(1) Exit: DA(1)
  1. I $D(^TIU(8925.1,DA(1),0)) S ^(99)=$H Q
  1. TREE ; Look back up tree to make sure item is not ancestor (input xform)
  1. ; From: 8925.14,.01 Entry: DA(1),X
  1. S TIUDDA=DA(1) K:X=TIUDDA X D TREE1 K TIUDDA,TIUDD
  1. Q
  1. TREE1 ; Traverse up tree
  1. S TIUDD=0 F Q:'$D(X) S TIUDD=$O(^TIU(8925.1,"AD",TIUDDA,TIUDD)) Q:TIUDD'>0 K:TIUDD=X X Q:'$D(X) D TREE2
  1. Q
  1. TREE2 ; Recurse one level
  1. N TIUDDA S TIUDDA=TIUDD N TIUDD D TREE1
  1. Q
  1. ASUBS(SUBJECT,TIUTYP,TIUSTAT,TIUIDT,DA) ; SET logic for "ASUB" X-ref
  1. N TIUI,TIUWORD S TIUI=0
  1. D PARSE^TIULS(SUBJECT,.TIUWORD)
  1. F S TIUI=$O(TIUWORD(TIUI)) Q:+TIUI'>0 D
  1. . S ^TIU(8925,"ASUB",TIUWORD(TIUI),+TIUTYP,+TIUSTAT,+TIUIDT,+DA)=""
  1. Q
  1. ASUBK(SUBJECT,TIUTYP,TIUSTAT,TIUIDT,DA) ; SET logic for "ASUB" X-ref
  1. N TIUI,TIUWORD S TIUI=0
  1. D PARSE^TIULS(SUBJECT,.TIUWORD)
  1. F S TIUI=$O(TIUWORD(TIUI)) Q:+TIUI'>0 D
  1. . K ^TIU(8925,"ASUB",TIUWORD(TIUI),+TIUTYP,+TIUSTAT,+TIUIDT,+DA)
  1. Q
  1. APRBS(TIUTYP,TIUSTAT,TIUIDT,DA,TIUPROB) ; SET logic for "APRB" X-ref
  1. N TIUI
  1. S TIUI=0 F S TIUI=+$O(^TIU(8925.9,"B",+DA,TIUI)) Q:+TIUI'>0 D
  1. . S:$G(TIUPROB)']"" TIUPROB=$P($G(^TIU(8925.9,+TIUI,0)),U,5)
  1. . I TIUPROB]"" D
  1. . . S ^TIU(8925,"APRB",$$UPPER^TIULS(TIUPROB),+TIUTYP,+TIUSTAT,+TIUIDT,+DA)=""
  1. Q
  1. APRBK(TIUTYP,TIUSTAT,TIUIDT,DA,TIUPROB) ; KILL logic for "APRB" X-ref
  1. N TIUI
  1. S TIUI=0 F S TIUI=+$O(^TIU(8925.9,"B",+DA,TIUI)) Q:+TIUI'>0 D
  1. . S:$G(TIUPROB)']"" TIUPROB=$P($G(^TIU(8925.9,+TIUI,0)),U,5)
  1. . I TIUPROB]"" D
  1. . . K ^TIU(8925,"APRB",$$UPPER^TIULS(TIUPROB),+TIUTYP,+TIUSTAT,+TIUIDT,+DA)
  1. Q