source: FOIAVistA/trunk/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDFRPC6.m@ 770

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

initial load of FOIAVistA 6/30/08 version

File size: 7.6 KB
Line 
1IBDFRPC6 ;ALB/AAS - AICS Pass data to PCE, Broker Call ; 24-FEB-96
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**3,25,38**;APR 24, 1997
3 ;
4FINDALL(RESULT) ; -- loop through all entries for data
5 ; -- called from ibdfrpc5, ONLY call if data in ^tmp
6 N IBDI
7 S RESULT(0)="The following data was found: "
8 F IBDI="VST","PRV","POV","CPT","HF","PED","XAM","SK","IMM","TRT" D @(IBDI)
9 K ^TMP("PXKENC",$J)
10 Q
11 ;
12PRV ; -- Expand Provider Entry
13 N IBDY,IBDJ,IEN,X,Y
14 F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
15 .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"PRV",IEN)) Q:'IEN D
16 ..D GETY(.Y,IBDY,"PRV",IEN)
17 ..I $G(IBDATA("UNFORMAT")) D
18 ...S X=$S($P(Y,"^",4)="P":"Primary",1:"Secondary")_"^Provider^"_$P($G(^VA(200,+Y,0)),"^")
19 ...S $P(X,"^",5)=$$SOURCE(9000010.06)
20 ..I '$G(IBDATA("UNFORMAT")) D
21 ...S X=$S($P(Y,"^",4)="P":" Primary",1:" Secondary")_" Provider: "_$P($G(^VA(200,+Y,0)),"^")
22 ..D INC(X,.CNT)
23 Q
24 ;
25POV ; -- Expand POV entry, (9000010.07)
26 N IBDY,IBDJ,IEN,X,Y
27 F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
28 .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"POV",IEN)) Q:'IEN D
29 ..D GETY(.Y,IBDY,"POV",IEN)
30 ..I '$G(IBDATA("UNFORMAT")) D
31 ...S X=$S($P(Y,"^",12)="P":" Primary",1:"Secondary")_" Diagnosis: "
32 ...S X=X_$E($P($G(^ICD9(+Y,0)),"^")_" ",1,6)_" - "
33 ...IF $P(Y,"^",4) S X=X_$$EXTERNAL^DILFD(9000010.07,.04,"",$P(Y,"^",4))
34 ...ELSE S X=X_$E($G(^ICD9(+Y,1)),1,80)
35 ..;
36 ..I $G(IBDATA("UNFORMAT")) D
37 ...S X=$S($P(Y,"^",12)="P":"Primary",1:"Secondary")_"^Diagnosis^"
38 ...IF $P(Y,"^",4) S X=X_$$EXTERNAL^DILFD(9000010.07,.04,"",$P(Y,"^",4))
39 ...ELSE S X=X_$E($G(^ICD9(+Y,1)),1,80)
40 ...S X=X_"^"_$E($P($G(^ICD9(+Y,0)),"^")_" ",1,6)
41 ...S $P(X,"^",5)=$$SOURCE(9000010.07)
42 ..D INC(X,.CNT)
43 Q
44 ;
45CPT ; -- Expand CPT entry
46 N IBDY,IBDJ,IEN,QUAN,X,Y,CODE
47 F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
48 .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"CPT",IEN)) Q:'IEN D
49 ..D GETY(.Y,IBDY,"CPT",IEN)
50 ..S QUAN=$P(Y,"^",16)
51 ..;;-----change to api cpt; dhh
52 ..S CODE=$$CPT^ICPTCOD(+Y)
53 ..I '$G(IBDATA("UNFORMAT")) D
54 ...I +CODE=-1 S CODE=""
55 ...E S CODE=$P(CODE,U,2)
56 ...S X=" Procedure: "_CODE_" - "
57 ...IF $P(Y,"^",4) S X=X_$$EXTERNAL^DILFD(9000010.18,.04,"",$P(Y,"^",4))
58 ...ELSE S X=X_$P(CODE,"^",3)
59 ...S X=X_" Quantity: "_QUAN
60 ..I $G(IBDATA("UNFORMAT")) D
61 ...S X="^Procedure^"
62 ...IF $P(Y,"^",4) S X=X_$$EXTERNAL^DILFD(9000010.18,.04,"",$P(Y,"^",4))
63 ...ELSE S X=X_$P(CODE,"^",3)
64 ...S X=X_"^"_$P(CODE,"^",2)_"^"_$$SOURCE(9000010.18)_"^"_QUAN
65 ..D INC(X,.CNT)
66 Q
67 ;
68HF ; -- Expand Health Factors
69 N IBDY,IBDJ,IEN,X,Y,Z
70 F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
71 .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"HF",IEN)) Q:'IEN D
72 ..D GETY(.Y,IBDY,"HF",IEN)
73 ..I '$G(IBDATA("UNFORMAT")) D
74 ...S X=" Health Factor: "_$E($$EXTERNAL^DILFD(9000010.23,.01,"",+Y)_L,1,25)
75 ...I $P(Y,"^",4)'="" S X=X_" Severity="_$$EXTERNAL^DILFD(9000010.23,.04,"",$P(Y,"^",4))
76 ..;
77 ..I $G(IBDATA("UNFORMAT")) D
78 ...S X=""
79 ...I $P(Y,"^",4)'="" S X=$$EXTERNAL^DILFD(9000010.23,.04,"",$P(Y,"^",4))
80 ...S X=X_"^Health Factor^"_$E($$EXTERNAL^DILFD(9000010.23,.01,"",+Y),1,25)
81 ...S $P(X,"^",5)=$$SOURCE(9000010.23)
82 ..D INC(X,.CNT)
83 Q
84 ;
85IMM ; -- Expand Immunizations
86 N IBDY,IBDJ,IEN,X,Y
87 F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
88 .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"IMM",IEN)) Q:'IEN D
89 ..D GETY(.Y,IBDY,"IMM",IEN)
90 ..I '$G(IBDATA("UNFORMAT")) D
91 ...S X=" Immunization: "_$$EXTERNAL^DILFD(9000010.11,.01,"",+Y)
92 ...I $P(Y,"^",7) S X=X_" Contraindicated!"
93 ..;
94 ..I $G(IBDATA("UNFORMAT")) D
95 ...S X="" I $P(Y,"^",7) S X="Contraindicated"
96 ...S X=X_"^Immunization^"_$$EXTERNAL^DILFD(9000010.11,.01,"",+Y)
97 ...S $P(X,"^",5)=$$SOURCE(9000010.11)
98 ..D INC(X,.CNT)
99 Q
100 ;
101PED ; -- Expand Patient Education
102 N IBDY,IBDJ,IEN,X,Y
103 F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
104 .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"PED",IEN)) Q:'IEN D
105 ..D GETY(.Y,IBDY,"PED",IEN)
106 ..I '$G(IBDATA("UNFORMAT")) D
107 ...S X=" Education Topic: "_$E($$EXTERNAL^DILFD(9000010.16,.01,"",+Y)_L,1,25)
108 ...I $P(Y,"^",6)'="" S X=X_" Understanding="_$$EXTERNAL^DILFD(9000010.16,.06,"",$P(Y,"^",6))
109 ..;
110 ..I $G(IBDATA("UNFORMAT")) D
111 ...S X=""
112 ...I $P(Y,"^",6)'="" S X=$$EXTERNAL^DILFD(9000010.16,.06,"",$P(Y,"^",6))
113 ...S X=X_"^Education Topic^"_$E($$EXTERNAL^DILFD(9000010.16,.01,"",+Y),1,25)
114 ...S $P(X,"^",5)=$$SOURCE(9000010.16)
115 ..D INC(X,.CNT)
116 Q
117 ;
118SK ; -- Expand Skin Tests
119 N IBDY,IBDJ,IEN,X,Y,Z
120 F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
121 .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"SK",IEN)) Q:'IEN D
122 ..D GETY(.Y,IBDY,"SK",IEN)
123 ..I '$G(IBDATA("UNFORMAT")) D
124 ...S X=" Skin Test: "_$E($$EXTERNAL^DILFD(9000010.12,.01,"",+Y)_L,1,25)
125 ...I $P(Y,"^",4)'="" S X=X_" Result="_$$EXTERNAL^DILFD(9000010.12,.04,"",$P(Y,"^",4))
126 ..;
127 ..I $G(IBDATA("UNFORMAT")) D
128 ...S X=$$EXTERNAL^DILFD(9000010.12,.04,"",$P(Y,"^",4))
129 ...S X=X_"^Skin Test^"_$E($$EXTERNAL^DILFD(9000010.12,.01,"",+Y),1,25)
130 ...S $P(X,"^",5)=$$SOURCE(9000010.12)
131 ..D INC(X,.CNT)
132 Q
133 ;
134TRT ; -- Expand Treatments
135 N IBDY,IBDJ,IEN,X,Y,TRT
136 F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
137 .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"TRT",IEN)) Q:'IEN D
138 ..D GETY(.Y,IBDY,"TRT",IEN)
139 ..S TRT=$$EXTERNAL^DILFD(9000010.15,.01,"",+Y)
140 ..I TRT="OTHER" S TRT=$$EXTERNAL^DILFD(9000010.15,.06,"",$P(Y,"^",6))
141 ..I '$G(IBDATA("UNFORMAT")) D
142 ...S X=" Treatment: "_TRT
143 ..I $G(IBDATA("UNFORMAT")) D
144 ...S X="^Treatment^"_TRT
145 ...S $P(X,"^",5)=$$SOURCE(9000010.15)
146 ..D INC(X,.CNT)
147 Q
148 ;
149XAM ; -- Expand Exams
150 N IBDY,IBDJ,IEN,X,Y
151 F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
152 .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"XAM",IEN)) Q:'IEN D
153 ..D GETY(.Y,IBDY,"XAM",IEN)
154 ..I '$G(IBDATA("UNFORMAT")) D
155 ...S X=" Exam: "_$E($$EXTERNAL^DILFD(9000010.13,.01,"",+Y)_L,1,25)
156 ...S X=X_" Result="_$$EXTERNAL^DILFD(9000010.13,.04,"",$P(Y,"^",4))
157 ..;
158 ..I $G(IBDATA("UNFORMAT")) D
159 ...S X=$$EXTERNAL^DILFD(9000010.13,.04,"",$P(Y,"^",4))
160 ...S X=X_"^Exam^"_$E($$EXTERNAL^DILFD(9000010.13,.01,"",+Y),1,25)
161 ...S $P(X,"^",5)=$$SOURCE(9000010.13)
162 ..D INC(X,.CNT)
163 Q
164 ;
165VST ; -- Expand visit entry
166 N IBDY,IBDJ,IBDZ,IEN,X,Y
167 F IBDJ=1:1 S IBDY=$P(ENCTRS,"^",IBDJ) Q:'IBDY D
168 .S IEN=0 F S IEN=$O(^TMP("PXKENC",$J,IBDY,"VST",IEN)) Q:'IEN D
169 ..D GETY(.Y,IBDY,"VST",IEN)
170 ..I '$G(IBDATA("UNFORMAT")) D
171 ...S X=" Encounter Info: "_$$EXTERNAL^DILFD(9000010,.22,"",$P(Y,"^",22))_" - "_$$FMTE^XLFDT(+Y)_" - "_$$EXTERNAL^DILFD(9000010,15003,"",$P(Y(150),"^",3))_" Encounter"
172 ...D INC(X,.CNT)
173 ...S X=""
174 ...S X=$$SOURCE(9000010) I X'="" S X=$E(L,1,22)_"Source - "_X
175 ...I $P(Y(800),"^",1)'="" S X=X_", SC := "_$S($P(Y(800),"^",1):"Yes",1:"No")
176 ...I $P(Y(800),"^",2)'="" S X=X_", AO:="_$S($P(Y(800),"^",2):"Yes",1:"No")
177 ...I $P(Y(800),"^",3)'="" S X=X_", IR:="_$S($P(Y(800),"^",3):"Yes",1:"No")
178 ...I $P(Y(800),"^",4)'="" S X=X_", EC:="_$S($P(Y(800),"^",4):"Yes",1:"No")
179 ..;
180 ..I $G(IBDATA("UNFORMAT")) D
181 ...S X=$$EXTERNAL^DILFD(9000010,15003,"",$P(Y(150),"^",3))_"^Encounter^"
182 ...S X=X_$$EXTERNAL^DILFD(9000010,.22,"",$P(Y,"^",22))_"^"_$$FMTE^XLFDT(+Y)_"^"
183 ...S X=X_$$SOURCE(9000010)
184 ...F IBDZ=1:1:4 I $P(Y(800),"^",IBDZ)'="" S $P(X,"^",(6+IBDZ))=$P(Y(800),"^",IBDZ)
185 ..I X'="" D INC(X,.CNT)
186 Q
187 ;
188INC(X,CNT) ; -- increment results array
189 S CNT=CNT+1
190 S RESULT(CNT)=X
191 Q
192 ;
193GETY(Y,IBDY,TYPE,IEN) ; -- return y array
194 S Y=$G(^TMP("PXKENC",$J,IBDY,TYPE,IEN,0))
195 S Y(150)=$G(^TMP("PXKENC",$J,IBDY,TYPE,IEN,150))
196 S Y(812)=$G(^TMP("PXKENC",$J,IBDY,TYPE,IEN,812))
197 I TYPE="VST" S Y(800)=$G(^TMP("PXKENC",$J,IBDY,TYPE,IEN,800))
198 Q
199 ;
200SOURCE(FILE) ; -- return source of data
201 N X S X=""
202 I $P(Y(812),"^",3)'="" S X=$$EXTERNAL^DILFD(FILE,81203,"",$P(Y(812),"^",3))
203 I X="",$P(Y(812),"^",2)'="" S X=$$EXTERNAL^DILFD(FILE,81202,"",$P(Y(812),"^",2))
204 Q X
205 ;
206TEST G TEST^IBDFRPC5
207TESTW G TESTW^IBDFRPC5
Note: See TracBrowser for help on using the repository browser.