source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUDD.m@ 1078

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

initial load of WorldVistAEHR

File size: 3.7 KB
Line 
1TIUDD ; slc/KCM - Build menus in XUTL (file 8925.1) ;7/19/94 13:51 ;
2 ;;1.0;TEXT INTEGRATION UTILITIES;;Jun 20, 1997
3SET ;From: Cross reference in file 8925.1, field 99 Entry: DA Exit: DA
4 ;NOTE: Lock ^TIU(8925.1,DA) when calling
5 Q:$D(^TIU(8925.1,DA,0))[0
6 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
7 N TIUCOL,TIUCCOL,TIUROW,TIUCROW,TIUPOS,TIUTOT,S1,S2,X,X1
8 K ^TMP("XQORM",$J) D KILL
9 S TIUCOL=3
10 S ^XUTL("XQORM",DA_";TIU(8925.1,","COL")=TIUCOL,(TIUTOT,S2)=0
11 F S S2=$O(^TIU(8925.1,DA,10,S2)) Q:S2'>0 D
12 . S X=^TIU(8925.1,DA,10,S2,0) I '$D(^TIU(8925.1,+X,0)) Q
13 . 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))
14 . S ^TMP("XQORM",$J,X,S2)="",TIUTOT=TIUTOT+1
15 S TIUROW=TIUTOT\TIUCOL+$S(TIUTOT#TIUCOL:1,1:0),TIUCCOL=1,TIUCROW=0,S1=""
16 F S S1=$O(^TMP("XQORM",$J,S1)) Q:S1="" S S2=0 D ;S1 is sequence
17 . F S S2=$O(^TMP("XQORM",$J,S1,S2)) Q:S2'>0 D ;S2 is item subscript
18 . . S X=^TIU(8925.1,DA,10,S2,0) ; X is the item node
19 . . 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
20 . . S TIUCROW=TIUCROW+1 I TIUCROW>TIUROW S TIUCROW=1,TIUCCOL=TIUCCOL+1
21 . . S TIUPOS=TIUCROW+(TIUCCOL/10)
22 . . S X1=$S($L($P(X,"^",4)):$P(X,"^",4),1:$P(^TIU(8925.1,+X,0),"^",3))
23 . . S X1=$TR(X1,",=;-"," ") Q:'$L(X1)
24 . . S ^XUTL("XQORM",DA_";TIU(8925.1,",TIUPOS,0)=S2_"^"_+X_"^"_X1_"^"_$P(X,"^",2)
25 . . S ^XUTL("XQORM",DA_";TIU(8925.1,","B",$$UP(X1),TIUPOS)=""
26 . . I $L($P(X,"^",2)) S ^XUTL("XQORM",DA_";TIU(8925.1,","B",$$UP($P(X,"^",2)),TIUPOS)=1
27 S X=$H,^XUTL("XQORM",DA_";TIU(8925.1,",0)=X,^TIU(8925.1,DA,99)=X
28 K ^TMP("XQORM",$J)
29 Q
30UP(X) ; Convert X to upper case
31 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
32KILL ; From: File 8925.1, Field 99 Entry: DA Exit: DA
33 K ^XUTL("XQORM",DA_";TIU(8925.1,") Q
34REDO ; Update TIMESTAMP on self & parents when Print Name Changes
35 ; From: File 8925.1, Field .03 Entry: DA Exit: DA
36 N I,X S X=$H I $D(^TIU(8925.1,DA,0)) S ^(99)=X,I=0
37 F S I=$O(^TIU(8925.1,"AD",DA,I)) Q:I'>0 D
38 . I $D(^TIU(8925.1,I,0)) S ^(99)=X
39 Q
40REDOX ; From: Subfile 8925.14, Fields .01,2,3 Entry: DA(1) Exit: DA(1)
41 I $D(^TIU(8925.1,DA(1),0)) S ^(99)=$H Q
42TREE ; Look back up tree to make sure item is not ancestor (input xform)
43 ; From: 8925.14,.01 Entry: DA(1),X
44 S TIUDDA=DA(1) K:X=TIUDDA X D TREE1 K TIUDDA,TIUDD
45 Q
46TREE1 ; Traverse up tree
47 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
48 Q
49TREE2 ; Recurse one level
50 N TIUDDA S TIUDDA=TIUDD N TIUDD D TREE1
51 Q
52ASUBS(SUBJECT,TIUTYP,TIUSTAT,TIUIDT,DA) ; SET logic for "ASUB" X-ref
53 N TIUI,TIUWORD S TIUI=0
54 D PARSE^TIULS(SUBJECT,.TIUWORD)
55 F S TIUI=$O(TIUWORD(TIUI)) Q:+TIUI'>0 D
56 . S ^TIU(8925,"ASUB",TIUWORD(TIUI),+TIUTYP,+TIUSTAT,+TIUIDT,+DA)=""
57 Q
58ASUBK(SUBJECT,TIUTYP,TIUSTAT,TIUIDT,DA) ; SET logic for "ASUB" X-ref
59 N TIUI,TIUWORD S TIUI=0
60 D PARSE^TIULS(SUBJECT,.TIUWORD)
61 F S TIUI=$O(TIUWORD(TIUI)) Q:+TIUI'>0 D
62 . K ^TIU(8925,"ASUB",TIUWORD(TIUI),+TIUTYP,+TIUSTAT,+TIUIDT,+DA)
63 Q
64APRBS(TIUTYP,TIUSTAT,TIUIDT,DA,TIUPROB) ; SET logic for "APRB" X-ref
65 N TIUI
66 S TIUI=0 F S TIUI=+$O(^TIU(8925.9,"B",+DA,TIUI)) Q:+TIUI'>0 D
67 . S:$G(TIUPROB)']"" TIUPROB=$P($G(^TIU(8925.9,+TIUI,0)),U,5)
68 . I TIUPROB]"" D
69 . . S ^TIU(8925,"APRB",$$UPPER^TIULS(TIUPROB),+TIUTYP,+TIUSTAT,+TIUIDT,+DA)=""
70 Q
71APRBK(TIUTYP,TIUSTAT,TIUIDT,DA,TIUPROB) ; KILL logic for "APRB" X-ref
72 N TIUI
73 S TIUI=0 F S TIUI=+$O(^TIU(8925.9,"B",+DA,TIUI)) Q:+TIUI'>0 D
74 . S:$G(TIUPROB)']"" TIUPROB=$P($G(^TIU(8925.9,+TIUI,0)),U,5)
75 . I TIUPROB]"" D
76 . . K ^TIU(8925,"APRB",$$UPPER^TIULS(TIUPROB),+TIUTYP,+TIUSTAT,+TIUIDT,+DA)
77 Q
Note: See TracBrowser for help on using the repository browser.