source: FOIAVistA/tag/r/AUTOMATED_INFO_COLLECTION_SYS-IBD/IBDF18A.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 8.3 KB
Line 
1IBDF18A ;ALB/CJM/AAS - ENCOUNTER FORM - utilities for PCE ;12-AUG-94
2 ;;3.0;AUTOMATED INFO COLLECTION SYS;**34,38,51**;APR 24, 1997
3 ;
4GLL(CLINIC,INTRFACE,ARY,FILTER,PAR5,PAR6,ENCDATE) ; -- get lots of lists in one call
5 ; -- input see GETLST but pass interface by reference expects
6 ; intrface(n) = name of select list in package interface file
7 ;
8 ; -- PAR5 => not currently used
9 ; -- PAR6 => not currently used
10 ;
11 ; -- output see GETLST
12 N X,COUNT
13 S COUNT=0
14 S X="" F S X=$O(INTRFACE(X)) Q:X="" D GETLST(CLINIC,INTRFACE(X),ARY,$G(FILTER),.COUNT,$G(PAR6),ENCDATE)
15 Q
16 ;
17GETLST(CLINIC,INTRFACE,ARY,FILTER,COUNT,MODIFIER,ENCDATE) ; -- returns any specified selection list for a clinic
18 ; -- input CLINIC = pointer to hospital location file for clinic
19 ; INTRFACE = name of selection list in package interface file
20 ; ARY = name of array to return list in
21 ; FILTER = predefined filters (optional, default = 1)
22 ; 1 = must be selection list
23 ; 2 = only visit cpts on list
24 ; ENCDATE = encounter date
25 ; MODIFIER = if modifiers are to be passed, 1=yes send modifiers
26 ;
27 ; -- output The format of the returned array is as follows
28 ; @ARY@(0) = count of array element (0 of nothing found)
29 ; @ARY@(1) = ^group header
30 ; @ARY@(2) = P1 := cpt or icd code / ien of other items
31 ; P2 := user defined text
32 ; p6 := user defined expanded text to send to PCE
33 ; p7 := second code or item defined for line item
34 ; p8 := third code or item defined for line item
35 ; p9 := associated clinical lexicon term
36 ;
37 ; @ARY@(2,"MODIFIER",0)=count of CPT Modifiers for entry
38 ; @ARY@(2,"MODIFIER",1)=2 character CPT Modifier value
39 ; @ARY@(2,"MODIFIER",2)=2 character CPT Modifier value
40 ; @ARY@(2,"MODIFIER",k+1)=2 character CPT Modifier value
41 ;
42 ; @ARY@(k) = ^next group header
43 ; @ARY@(k+1) = problem ien or cpt or icd code^user define text
44 ;
45 ; -- output modification for patch 34:
46 ; Narrative to Send to PCE (instead of printed text)
47 ; field (2.01) in file 357.3, added as piece 6 of @ary@(n)
48 ;
49 ; if additional codes for an item (diagnosis) are added to
50 ; item, they are added as pieces 7 and/or 8 of @ary@(n).
51 ;
52 ; if a type of visit code is requested and none found, will
53 ; automatically look first for blocks named type of visit and
54 ; second for filtered codes using regular cpt blocks.
55 ;
56 ; if a diagnosis block it requested and none found will
57 ; automagically look for Clinic Common Problem List and
58 ; then convert it to look like a diagnosis list
59 ;
60 N I,J,X,Y,INUM,IBQUIT,FORM,SETUP,LIST,BLOCK,OLDARY,IBDTMP,ROW,COL,BLK
61 N LIST1,PACKAGE
62 K ^TMP("IBDUP",$J)
63 S (IBQUIT,LIST)=0
64 S PACKAGE=$E(INTRFACE,1,30)
65 ;
66 ;Setup array containing NAME of the Package Interface file
67 ;This is the second paramenter passed by PCE, TIU, & CPRS
68 S LIST1("DG SELECT CPT PROCEDURE CODES")=""
69 S LIST1("DG SELECT ICD-9 DIAGNOSIS CODE")=""
70 S LIST1("DG SELECT VISIT TYPE CPT PROCE")=""
71 S LIST1("GMP INPUT CLINIC COMMON PROBLE")=""
72 S LIST1("GMP PATIENT ACTIVE PROBLEMS")=""
73 ;
74 S COUNT=$G(COUNT,0)
75 I $G(FILTER)<1 S FILTER=1 ;default value=1
76 I FILTER>1 S OLDARY=ARY,ARY="IBDTMP"
77 S @ARY@(0)=+$G(@ARY@(0))
78 I $G(CLINIC)="" G GETLSTQ
79 I $G(^SC(CLINIC,0))="" G GETLSTQ
80 I $G(INTRFACE)="" G GETLSTQ
81 S INUM=$O(^IBE(357.6,"B",$E(INTRFACE,1,30),0))
82 ;
83 ; -- find forms defined for clinic
84 ; piece 2 = basic form
85 ; piece 3,4,6 = supplemental forms
86 S SETUP=$G(^SD(409.95,+$O(^SD(409.95,"B",CLINIC,0)),0))
87 G:SETUP="" GETLSTQ
88 F I=2,3,4,6,8,9 S FORM=$P(SETUP,"^",I) D Q:IBQUIT
89 .;
90 .; -- find blocks on forms
91 .Q:'FORM
92 . D GETBLKS Q:'$O(BLK(0))
93 . S (ROW,COL)=""
94 . F S ROW=$O(BLK(ROW)) Q:ROW="" S COL="" F S COL=$O(BLK(ROW,COL)) Q:COL="" S BLOCK=$G(BLK(+ROW,+COL)) D
95 ..;
96 ..; -- see if package interface defined for blocks
97 ..S LIST=0
98 ..F S LIST=$O(^IBE(357.2,"C",BLOCK,LIST)) Q:'LIST I $P($G(^IBE(357.2,LIST,0)),"^",11)=INUM D COPYLIST^IBDF18A1(LIST,ARY,.COUNT)
99 ;I COUNT D URH^IBDF18A1
100 S @ARY@(0)=COUNT
101 I FILTER=2 D F2^IBDF18A1(OLDARY)
102 ;
103 I COUNT=0 D
104 .I $E(INTRFACE,1,30)=$E("DG SELECT VISIT TYPE CPT PROCEDURES",1,30) D TOV
105 ;
106 ; -- always check for both diagnosis and clinic common problems when
107 ; looking for diagnosis, return in diagnosis format
108 I $E(INTRFACE,1,30)=$E("DG SELECT ICD-9 DIAGNOSIS CODES",1,30) D CCP(COUNT)
109 ;This routine checks list that have CPT & ICD codes for CSV.
110 D CHKLST^IBDF18A2:$D(LIST1(PACKAGE))
111 ;
112 K ^TMP("IBDUP",$J)
113 ;
114GETLSTQ Q
115 ;
116GETBLKS ; -- get the blocks for a form in row,column order
117 K BLK
118 N ROW,COL
119 S BLK=0
120 F S BLK=$O(^IBE(357.1,"C",FORM,BLK)) Q:'BLK D
121 . S ROW=$P($G(^IBE(357.1,+BLK,0)),"^",4),COL=$P(^(0),"^",5)
122 . Q:ROW=""!(COL="")
123 . S BLK(ROW,COL)=BLK
124 Q
125 ;
126CCP(COUNT) ; -- no diagnosis, look for common problems and convert
127 N I,X,OLDCNT
128 S OLDCNT=COUNT
129 ;
130 ; -- get the clinic common problem list
131 D GETLST(CLINIC,"GMP SELECT CLINIC COMMON PROBLEMS",ARY,"",COUNT)
132 ;
133 ; -- now convert it to primary icd code save lexicon pointer in piece 6
134 S I=OLDCNT
135 F S I=$O(VAR(I)) Q:I="" D
136 .S X=+VAR(I)
137 . S:X $P(VAR(I),"^",9)=X,$P(VAR(I),"^",1)=$$ICDONE^LEXU(X)
138 . I $P(VAR(I),"^",7) S $P(VAR(I),"^",7)=$$ICDONE^LEXU($P(VAR(I),"^",7))
139 . I $P(VAR(I),"^",8) S $P(VAR(I),"^",8)=$$ICDONE^LEXU($P(VAR(I),"^",8))
140 Q
141 ;
142TOV ; -- if trying to find Type of Visit codes but list on form
143 ; uses another interface try this
144 ;
145 N INUM
146 S INUM=0
147 F S INUM=$O(^IBE(357.6,"B","DG SELECT CPT PROCEDURE CODES",INUM)) Q:'INUM S INUM(INUM)=""
148 D TOV1
149 I COUNT=0 D TOV2
150 Q
151 ;
152TOV1 ; -- first get all lists for blocks named Type of Visit or E&M
153 N NM,HD
154 F I=2,3,4,6,8,9 S FORM=$P(SETUP,"^",I) D:+FORM Q:IBQUIT
155 . ;
156 . ; -- find blocks on forms
157 . D GETBLKS Q:'$O(BLK(0))
158 . S (ROW,COL)=""
159 . F S ROW=$O(BLK(ROW)) Q:ROW="" S COL="" F S COL=$O(BLK(ROW,COL)) Q:COL="" S BLOCK=$G(BLK(+ROW,+COL)) D
160 .. ;
161 .. S NM=$P($G(^IBE(357.1,BLOCK,0)),"^",1)
162 .. S NM=$TR(NM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
163 .. S HD=$P($G(^IBE(357.1,BLOCK,0)),"^",11)
164 .. S HD=$TR(HD,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
165 .. I NM["TYPE OF VISIT"!(NM["VISIT TYPE")!(HD["TYPE OF VISIT")!(HD["VISIT TYPE")!(NM["E&M")!(NM["E & M")!(HD["E&M")!(HD["E & M") D
166 ... S LIST=0
167 ... F S LIST=$O(^IBE(357.2,"C",BLOCK,LIST)) Q:'LIST D
168 .... I $D(INUM($P($G(^IBE(357.2,LIST,0)),"^",11))) D COPYLIST^IBDF18A1(LIST,ARY,.COUNT) K BLK(ROW,COL)
169 Q
170 ;
171TOV2 ; -- get the type of visit codes from cpt lists using filter
172 S OLDARY=ARY,ARY="IBDTMP"
173 S @ARY@(0)=+$G(@ARY@(0))
174 ;
175 F I=2,3,4,6,8,9 S FORM=$P(SETUP,"^",I) D:+FORM Q:IBQUIT
176 . ;
177 . ; -- find blocks on forms
178 . S (ROW,COL)=""
179 . F S ROW=$O(BLK(ROW)) Q:ROW="" S COL="" F S COL=$O(BLK(ROW,COL)) Q:COL="" S BLOCK=$G(BLK(+ROW,+COL)) D
180 .. ;
181 .. ; -- see if package interface defined for blocks
182 .. S LIST=0
183 .. F S LIST=$O(^IBE(357.2,"C",BLOCK,LIST)) Q:'LIST I $D(INUM($P($G(^IBE(357.2,LIST,0)),"^",11))) D COPYLIST^IBDF18A1(LIST,ARY,.COUNT)
184 D F2^IBDF18A1(OLDARY)
185 Q
186 ;
187 ; -- here are some sample tests for different lists
188TEST1 K VAR D GETLST(573,"DG SELECT ICD-9 DIAGNOSIS CODES","VAR",1,"","",DT)
189 X "ZW VAR"
190 Q
191 ;
192TEST2 K VAR D GETLST(301,"DG SELECT ICD-9 DIAGNOSIS CODES","VAR",1,"","",DT)
193 X "ZW VAR"
194 Q
195 ;
196TEST4 K VAR D GETLST(300,"DG SELECT VISIT TYPE CPT PROCEDURES","VAR",1,"",1,DT)
197 X "ZW VAR"
198 Q
199 ;
200TEST5 K VAR D GETLST(300,"PX SELECT IMMUNIZATIONS","VAR",1,DT)
201 X "ZW VAR"
202 Q
203 ;
204TEST5A K VAR D GETLST(300,"PX SELECT SKIN TESTS","VAR",1,DT)
205 X "ZW VAR"
206 Q
207 ;
208TEST6 K VAR D GETLST(573,"DG SELECT CPT PROCEDURE CODES","VAR",1,"",1,DT)
209 X "ZW VAR"
210 Q
211 ;
212TEST7 K VAR D GETLST(573,"DG SELECT VISIT TYPE CPT PROCEDURES","VAR",1,"",1,DT)
213 X "ZW VAR"
214 Q
215 ;
216TEST8 ; -- use this to test CPRS ability to retrieve type of visit
217 ; set clinic := name or internal entry number of clinic or change
218 ; value for specific clinic
219 K VAR
220 I $G(CLINIC)="" S CLINIC=300
221 I CLINIC'=+CLINIC W !,"Using Clinic: ",CLINIC S CLINIC=$O(^SC("B",CLINIC,0)) W !,"IEN: ",CLINIC,! H 5
222 X "D VISIT^ORWPCE(.VAR,CLINIC) ZW VAR"
223 Q
224 ;
225TEST9 K VAR D GETLST(301,"GMP SELECT CLINIC COMMON PROBLEMS","VAR",1)
226 X "ZW VAR"
227 Q
Note: See TracBrowser for help on using the repository browser.