source: WorldVistAEHR/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUXRC4.m@ 613

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

initial load of WorldVistAEHR
File size: 8.7 KB
Line 
1TIUXRC4 ; COMPILED XREF FOR FILE #8925 ; 11/08/09
2 ;
3END G ^TIUXRC4
4 S X=$P(DIKZ(0),U,5)
5 I X'="" I +$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,4) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+X,(9999999-$P(^TIU(8925,+DA,13),U)),DA)=""
6 S X=$P(DIKZ(0),U,5)
7 I X'="" D SACLPT^TIUDD0(.05,X)
8 S X=$P(DIKZ(0),U,5)
9 I X'="" D SACLEC^TIUDD0(.05,X)
10 S X=$P(DIKZ(0),U,5)
11 I X'="" D SACLAU^TIUDD0(.05,X),SACLAU1^TIUDD0(.05,X)
12 S X=$P(DIKZ(0),U,6)
13 I X'="" S ^TIU(8925,"DAD",$E(X,1,30),DA)=""
14 S X=$P(DIKZ(0),U,7)
15 I X'="" D SAPTLD^TIUDD0(.07,X)
16 S X=$P(DIKZ(0),U,12)
17 I X'="" S ^TIU(8925,"FIX",$E(X,1,30),DA)=""
18 S X=$P(DIKZ(0),U,13)
19 I X'="" D SAPTLD^TIUDD0(.13,X)
20 S DIKZ(12)=$G(^TIU(8925,DA,12))
21 S X=$P(DIKZ(12),U,1)
22 I X'="" S ^TIU(8925,"F",$E(X,1,30),DA)=""
23 S X=$P(DIKZ(12),U,2)
24 I X'="" S ^TIU(8925,"CA",$E(X,1,30),DA)=""
25 S X=$P(DIKZ(12),U,2)
26 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P(^TIU(8925,+DA,13),U)),+DA)=""
27 S X=$P(DIKZ(12),U,2)
28 I X'="" I +$$AAUP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"AAUP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)=""
29 S X=$P(DIKZ(12),U,2)
30 I X'="" D SACLAU^TIUDD0(1202,X)
31 S X=$P(DIKZ(12),U,2)
32 I X'="" D
33 .N DIK,DIV,DIU,DIN
34 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I '+$$ISDS^TIULX(+$G(^TIU(8925,+DA,0))) I X S X=DIV S Y(1)=$S($D(^TIU(8925,D0,14)):^(14),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y X ^DD(8925,1202,1,5,1.1) X ^DD(8925,1202,1,5,1.4)
35 S DIKZ(12)=$G(^TIU(8925,DA,12))
36 S X=$P(DIKZ(12),U,5)
37 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""
38 S X=$P(DIKZ(12),U,5)
39 I X'="" I +$$ALOCP^TIULX(+DA),+$P($G(^TIU(8925,+DA,15)),U) S ^TIU(8925,"ALOCP",+X,+$P($G(^TIU(8925,+DA,15)),U),+DA)=""
40 S X=$P(DIKZ(12),U,7)
41 I X'="" D:$D(^AUPNVSIT(+X)) ADD^AUPNVSIT
42 S X=$P(DIKZ(12),U,8)
43 I X'="" S ^TIU(8925,"CS",$E(X,1,30),DA)=""
44 S X=$P(DIKZ(12),U,8)
45 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+X,+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""
46 S X=$P(DIKZ(12),U,8)
47 I X'="" D SACLEC^TIUDD0(1208,X)
48 S X=$P(DIKZ(12),U,11)
49 I X'="" D SAPTLD^TIUDD0(1211,X)
50 S DIKZ(13)=$G(^TIU(8925,DA,13))
51 S X=$P(DIKZ(13),U,1)
52 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AAU",+$P(^TIU(8925,+DA,12),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""
53 S X=$P(DIKZ(13),U,1)
54 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,8),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASUP",+$P(^TIU(8925,+DA,12),U,8),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""
55 S X=$P(DIKZ(13),U,1)
56 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"APT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""
57 S X=$P(DIKZ(13),U,1)
58 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+$P(^TIU(8925,+DA,14),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""
59 S X=$P(DIKZ(13),U,1)
60 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+$P(^TIU(8925,+DA,13),U,2),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""
61 S X=$P(DIKZ(13),U,1)
62 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALL","ANY",+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""
63 S X=$P(DIKZ(13),U,1)
64 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),$L($P($G(^TIU(8925,+DA,17)),U)) D ASUBS^TIUDD($P($G(^TIU(8925,+DA,17)),U),+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA)
65 S X=$P(DIKZ(13),U,1)
66 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,14)),U,4),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+$P(^TIU(8925,+DA,14),U,4),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""
67 S X=$P(DIKZ(13),U,1)
68 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$O(^TIU(8925.9,"B",+DA,0)) D APRBS^TIUDD(+$G(^TIU(8925,+DA,0)),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-+X),DA)
69 S X=$P(DIKZ(13),U,1)
70 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,3),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"AVSIT",+$P(^TIU(8925,+DA,0),U,3),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)=""
71 S X=$P(DIKZ(13),U,1)
72 I X'="" I +$P($G(^TIU(8925,+DA,0)),U,4),+$P($G(^TIU(8925,+DA,0)),U,2),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ADCPT",+$P(^TIU(8925,+DA,0),U,2),+$P(^TIU(8925,+DA,0),U,4),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),DA)=""
73 S X=$P(DIKZ(13),U,1)
74 I X'="" S ^TIU(8925,"D",$E(X,1,30),DA)=""
75 S X=$P(DIKZ(13),U,1)
76 I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),+$$CLINDOC^TIULC1(+$P(^TIU(8925,+DA,0),U),+DA),(9999999-X),DA)=""
77 S X=$P(DIKZ(13),U,1)
78 I X'="" I +$P(^TIU(8925,+DA,0),U),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTCL",+$P(^TIU(8925,+DA,0),U,2),38,(9999999-X),DA)=""
79 S X=$P(DIKZ(13),U,1)
80 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,12)),U,5),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ALOC",+$P(^TIU(8925,+DA,12),U,5),+$P(^TIU(8925,+DA,0),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-X),+DA)=""
81 S X=$P(DIKZ(13),U,1)
82 I X'="" D SACLPT^TIUDD0(1301,X)
83 S X=$P(DIKZ(13),U,1)
84 I X'="" D SACLAU^TIUDD0(1301,X),SACLAU1^TIUDD0(1301,X)
85 S X=$P(DIKZ(13),U,1)
86 I X'="" D SACLEC^TIUDD0(1301,X)
87 S X=$P(DIKZ(13),U,1)
88 I X'="" D SACLSB^TIUDD0(1301,X)
89 S X=$P(DIKZ(13),U,2)
90 I X'="" S ^TIU(8925,"TC",$E(X,1,30),DA)=""
91 S X=$P(DIKZ(13),U,2)
92 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P(^TIU(8925,+DA,0),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""
93 S X=$P(DIKZ(13),U,2)
94 I X'="" D SACLAU1^TIUDD0(1302,X)
95 S X=$P(DIKZ(13),U,4)
96 I X'="" S ^TIU(8925,"E",$E(X,1,30),DA)=""
97 S DIKZ(14)=$G(^TIU(8925,DA,14))
98 S X=$P(DIKZ(14),U,2)
99 I X'="" S ^TIU(8925,"TS",$E(X,1,30),DA)=""
100 S X=$P(DIKZ(14),U,2)
101 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ATS",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""
102 S X=$P(DIKZ(14),U,4)
103 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,13)),U),+$P($G(^TIU(8925,+DA,0)),U,5) S ^TIU(8925,"ASVC",+X,+$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),(9999999-$P($G(^TIU(8925,+DA,13)),U)),DA)=""
104 S X=$P(DIKZ(14),U,4)
105 I X'="" S ^TIU(8925,"SVC",$E(X,1,30),DA)=""
106 S X=$P(DIKZ(14),U,5)
107 I X'="" S ^TIU(8925,"G",$E(X,1,30),DA)=""
108 S DIKZ(15)=$G(^TIU(8925,DA,15))
109 S X=$P(DIKZ(15),U,1)
110 I X'="" I +$$ALOCP^TIULX(+DA),+$P($G(^TIU(8925,+DA,12)),U,5) S ^TIU(8925,"ALOCP",+$P($G(^TIU(8925,+DA,12)),U,5),+X,+DA)=""
111 S X=$P(DIKZ(15),U,1)
112 I X'="" I +$$APTP^TIULX(+DA),+$P($G(^TIU(8925,+DA,0)),U,2) S ^TIU(8925,"APTP",+$P($G(^TIU(8925,+DA,0)),U,2),+X,+DA)=""
113 S X=$P(DIKZ(15),U,1)
114 I X'="" I +$$AAUP^TIULX(+DA),+$P($G(^TIU(8925,+DA,12)),U,2) S ^TIU(8925,"AAUP",+$P($G(^TIU(8925,+DA,12)),U,2),+X,+DA)=""
115 S X=$P(DIKZ(15),U,1)
116 I X'="" D SACLPT^TIUDD0(1501,X)
117 S X=$P(DIKZ(15),U,1)
118 I X'="" D SACLEC^TIUDD0(1501,X)
119 S X=$P(DIKZ(15),U,1)
120 I X'="" D KACLAU^TIUDD01(1501,X),KACLAU1^TIUDD01(1501,X)
121 S X=$P(DIKZ(15),U,2)
122 I X'="" D SACLSB^TIUDD0(1502,X)
123 S X=$P(DIKZ(15),U,7)
124 I X'="" D KACLEC^TIUDD01(1507,X)
125 S X=$P(DIKZ(15),U,7)
126 I X'="" D SACLPT^TIUDD0(1507,X)
127 S DIKZ(17)=$G(^TIU(8925,DA,17))
128 S X=$P(DIKZ(17),U,1)
129 I X'="" I +$P($G(^TIU(8925,+DA,0)),U),+$P($G(^TIU(8925,+DA,0)),U,5),+$P($G(^TIU(8925,+DA,13)),U) D ASUBS^TIUDD($G(X),+$G(^TIU(8925,+DA,0)),+$P(^TIU(8925,+DA,0),U,5),(9999999-+$G(^TIU(8925,+DA,13))),DA)
130 S DIKZ(21)=$G(^TIU(8925,DA,21))
131 S X=$P(DIKZ(21),U,1)
132 I X'="" S ^TIU(8925,"GDAD",$E(X,1,30),DA)=""
133 S DIKZ(150)=$G(^TIU(8925,DA,150))
134 S X=$P(DIKZ(150),U,1)
135 I X'="" S ^TIU(8925,"VID",$E(X,1,30),DA)=""
136CR1 S DIXR=247
137 K X
138 S X(1)=$P(DIKZ(12),U,12)
139 S DIKZ(0)=$G(^TIU(8925,DA,0))
140 S X(2)=$P(DIKZ(0),U,1)
141 S X(3)=$P(DIKZ(0),U,5)
142 S X=$P(DIKZ(13),U,1)
143 I $G(X)]"" S X=9999999-X
144 S:$D(X)#2 X(4)=X
145 S X=$G(X(1))
146 I $G(X(1))]"",$G(X(2))]"",$G(X(3))]"",$G(X(4))]"" D
147 . K X1,X2 M X1=X,X2=X
148 . S ^TIU(8925,"ADIV",X(1),X(2),X(3),X(4),DA)=""
149CR2 S DIXR=413
150 K X
151 S DIKZ(12)=$G(^TIU(8925,DA,12))
152 S X(1)=$P(DIKZ(12),U,7)
153 S X=$G(X(1))
154 I $G(X(1))]"" D
155 . K X1,X2 M X1=X,X2=X
156 . S ^TIU(8925,"VS",X,DA)=""
157CR3 K X
158END Q
Note: See TracBrowser for help on using the repository browser.