source: FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX1.m@ 636

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

WorldVistAEHR overlayed on FOIAVistA
File size: 7.5 KB
Line 
1IBXX1 ; COMPILED XREF FOR FILE #399 ; 12/27/07
2 ;
3 S DIKZK=2
4 S DIKZ(0)=$G(^DGCR(399,DA,0))
5 S X=$P(DIKZ(0),U,2)
6 I X'="" K ^DGCR(399,"C",$E(X,1,30),DA)
7 S X=$P(DIKZ(0),U,3)
8 I X'="" K ^DGCR(399,"D",$E(X,1,30),DA)
9 S X=$P(DIKZ(0),U,3)
10 I X'="" S IBN=$P(^DGCR(399,DA,0),"^",2) I $D(IBN) K ^DGCR(399,"APDT",IBN,DA,9999999-X),IBN
11 S X=$P(DIKZ(0),U,3)
12 I X'="" K ^DGCR(399,"ABNDT",DA,9999999-X)
13 S X=$P(DIKZ(0),U,5)
14 I X'="" K ^DGCR(399,"ABT",$E(X,1,30),DA)
15 S X=$P(DIKZ(0),U,7)
16 I X'="" D
17 .N DIK,DIV,DIU,DIN
18 .X ^DD(399,.07,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,.07,1,1,2.4)
19 S X=$P(DIKZ(0),U,7)
20 I X'="" K ^DGCR(399,"AD",$E(X,1,30),DA)
21 S DIKZ(0)=$G(^DGCR(399,DA,0))
22 S X=$P(DIKZ(0),U,8)
23 I X'="" D
24 .N DIK,DIV,DIU,DIN
25 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(399,.08,1,4,2.4)
26 S X=$P(DIKZ(0),U,8)
27 I X'="" K ^DGCR(399,"APTF",$E(X,1,30),DA)
28 S DIKZ(0)=$G(^DGCR(399,DA,0))
29 S X=$P(DIKZ(0),U,11)
30 I X'="" D DEL^IBCU5
31 S X=$P(DIKZ(0),U,11)
32 I X'="" S DGRVRCAL=2
33 S X=$P(DIKZ(0),U,11)
34 I X'="" D
35 .N DIK,DIV,DIU,DIN
36 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($P(^DGCR(399,DA,0),U,11)'="i":1,"PST"'[$P(^DGCR(399,DA,0),U,21):1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,21),X=X S DIU=X K Y S X="" X ^DD(399,.11,1,4,2.4)
37 S DIKZ(0)=$G(^DGCR(399,DA,0))
38 S X=$P(DIKZ(0),U,13)
39 I X'="" I $P(^DGCR(399,DA,0),U,2) K ^DGCR(399,"AOP",$P(^(0),U,2),DA)
40 S X=$P(DIKZ(0),U,13)
41 I X'="" K ^DGCR(399,"AST",+X,DA)
42 S X=$P(DIKZ(0),U,13)
43 I X'="" D
44 .N DIK,DIV,DIU,DIN
45 .X ^DD(399,.13,1,4,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X="0" S DIH=$G(^DGCR(399,DIV(0),"TX")),DIV=X S $P(^("TX"),U,5)=DIV,DIH=399,DIG=24 D ^DICR
46 S DIKZ(0)=$G(^DGCR(399,DA,0))
47 S X=$P(DIKZ(0),U,17)
48 I X'="" K ^DGCR(399,"AC",$E(X,1,30),DA)
49 S X=$P(DIKZ(0),U,19)
50 I X'="" S DGRVRCAL=2
51 S X=$P(DIKZ(0),U,19)
52 I X'="" D ALLID^IBCEP3(DA,.19,2)
53 S X=$P(DIKZ(0),U,19)
54 I X'="" D ATTREND^IBCU1(DA,"","")
55 S X=$P(DIKZ(0),U,21)
56 I X'="" D
57 .N DIK,DIV,DIU,DIN
58 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,1,2.4)
59 S X=$P(DIKZ(0),U,21)
60 I X'="" D
61 .N DIK,DIV,DIU,DIN
62 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMRA^IBEFUNC(DA)&$$NEEDMRA^IBEFUNC(DA)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,2,2.4)
63 S DIKZ(0)=$G(^DGCR(399,DA,0))
64 S X=$P(DIKZ(0),U,22)
65 I X'="" D
66 .N DIK,DIV,DIU,DIN
67 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"U3")):^("U3"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"U3")),DIV=X S $P(^("U3"),U,2)=DIV,DIH=399,DIG=243 D ^DICR
68 S DIKZ(0)=$G(^DGCR(399,DA,0))
69 S X=$P(DIKZ(0),U,25)
70 I X'="" D ALLID^IBCEP3(DA,.25,2)
71 S DIKZ("S")=$G(^DGCR(399,DA,"S"))
72 S X=$P(DIKZ("S"),U,1)
73 I X'="" K ^DGCR(399,"APD",$E(X,1,30),DA)
74 S X=$P(DIKZ("S"),U,7)
75 I X'="" K ^DGCR(399,"APM",$E(X,1,30),DA)
76 S X=$P(DIKZ("S"),U,10)
77 I X'="" K ^DGCR(399,"APD3",$E(X,1,30),DA)
78 S X=$P(DIKZ("S"),U,12)
79 I X'="" K ^DGCR(399,"AP",$E(X,1,30),DA)
80 S DIKZ("TX")=$G(^DGCR(399,DA,"TX"))
81 S X=$P(DIKZ("TX"),U,2)
82 I X'="" K ^DGCR(399,"ALEX",$E(X,1,30),DA)
83 S DIKZ("C")=$G(^DGCR(399,DA,"C"))
84 S X=$P(DIKZ("C"),U,14)
85 I X'="" D
86 .N DIK,DIV,DIU,DIN
87 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"C")):^("C"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"C")),DIV=X S $P(^("C"),U,10)=DIV,DIH=399,DIG=60 D ^DICR
88 S DIKZ("M")=$G(^DGCR(399,DA,"M"))
89 S X=$P(DIKZ("M"),U,1)
90 I X'="" D
91 .N DIK,DIV,DIU,DIN
92 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCEF(DA)=1 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" X ^DD(399,101,1,2,2.4)
93 S DIKZ("M")=$G(^DGCR(399,DA,"M"))
94 S X=$P(DIKZ("M"),U,2)
95 I X'="" D
96 .N DIK,DIV,DIU,DIN
97 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $$COBN^IBCEF(DA)=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X="" X ^DD(399,102,1,3,2.4)
98 S DIKZ("M")=$G(^DGCR(399,DA,"M"))
99 S X=$P(DIKZ("M"),U,11)
100 I X'="" D DEL^IBCU5
101 S X=$P(DIKZ("M"),U,11)
102 I X'="" S DGRVRCAL=2
103 S X=$P(DIKZ("M"),U,12)
104 I X'="" D
105 .N DIK,DIV,DIU,DIN
106 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(399,112,1,1,2.4)
107 S X=$P(DIKZ("M"),U,12)
108 I X'="" D KIX^IBCNS2(DA,"I1")
109 S X=$P(DIKZ("M"),U,12)
110 I X'="" D
111 .N DIK,DIV,DIU,DIN
112 .X ^DD(399,112,1,3,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399,112,1,3,2.4)
113 S DIKZ("M")=$G(^DGCR(399,DA,"M"))
114 S X=$P(DIKZ("M"),U,13)
115 I X'="" D
116 .N DIK,DIV,DIU,DIN
117 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399,113,1,1,2.4)
118 S X=$P(DIKZ("M"),U,13)
119 I X'="" D KIX^IBCNS2(DA,"I2")
120 S X=$P(DIKZ("M"),U,13)
121 I X'="" D
122 .N DIK,DIV,DIU,DIN
123 .X ^DD(399,113,1,3,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399,113,1,3,2.4)
124 S DIKZ("M")=$G(^DGCR(399,DA,"M"))
125 S X=$P(DIKZ("M"),U,14)
126 I X'="" D
127 .N DIK,DIV,DIU,DIN
128 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(399,114,1,1,2.4)
129 S X=$P(DIKZ("M"),U,14)
130 I X'="" D KIX^IBCNS2(DA,"I3")
131 S X=$P(DIKZ("M"),U,14)
132 I X'="" D
133 .N DIK,DIV,DIU,DIN
134 .X ^DD(399,114,1,3,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X="" X ^DD(399,114,1,3,2.4)
135 S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
136 S X=$P(DIKZ("M1"),U,2)
137 I X'="" D
138 .N DIK,DIV,DIU,DIN
139 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,10),X=X S DIU=X K Y S X="" X ^DD(399,122,1,1,2.4)
140 S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
141 S X=$P(DIKZ("M1"),U,3)
142 I X'="" D
143 .N DIK,DIV,DIU,DIN
144 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X="" X ^DD(399,123,1,1,2.4)
145 S DIKZ("M1")=$G(^DGCR(399,DA,"M1"))
146 S X=$P(DIKZ("M1"),U,4)
147 I X'="" D
148 .N DIK,DIV,DIU,DIN
149 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X="" X ^DD(399,124,1,1,2.4)
150 S DIKZ("MP")=$G(^DGCR(399,DA,"MP"))
151 S X=$P(DIKZ("MP"),U,1)
152 I X'="" D DEL^IBCU5
153 S X=$P(DIKZ("MP"),U,1)
154 I X'="" S DGRVRCAL=2
155 S X=$P(DIKZ("MP"),U,2)
156 I X'="" D
157 .N DIK,DIV,DIU,DIN
158 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X="" X ^DD(399,136,1,1,2.4)
159 S DIKZ("U")=$G(^DGCR(399,DA,"U"))
160 S X=$P(DIKZ("U"),U,1)
161 I X'="" S DGRVRCAL=2
162 S X=$P(DIKZ("U"),U,1)
163 I X'="" K:$P(^DGCR(399,DA,0),"^",2) ^DGCR(399,"APDS",$P(^(0),U,2),-X,DA)
164 S X=$P(DIKZ("U"),U,2)
165 I X'="" S DGRVRCAL=2
166 S DIKZ("U1")=$G(^DGCR(399,DA,"U1"))
167 S X=$P(DIKZ("U1"),U,2)
168 I X'="" D
169 .N DIK,DIV,DIU,DIN
170 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,2)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" X ^DD(399,202,1,1,2.4)
171 S DIKZ("U2")=$G(^DGCR(399,DA,"U2"))
172 S X=$P(DIKZ("U2"),U,4)
173END G ^IBXX2
Note: See TracBrowser for help on using the repository browser.