source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBDCPT.m@ 1704

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

initial load of WorldVistAEHR
File size: 6.4 KB
Line 
1PXBDCPT ;ISL/JVS,ESW - DISPLAY CPT ;3/5/04 10:39am
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,89,108,121,124**;Aug 12, 1996
3 ;
4 ;
5EN0 ;---Main entry point
6 ;
7 ;
8HEAD ;--HEADER ON LIST
9 S HEAD="- - E N C O U N T E R P R O C E D U R E S (CPT CODES) - -"
10 W IOINHI,!,IOCUU,?(IOM-$L(HEAD))\2,HEAD,IOINLOW
11 W IOELEOL K HEAD
12 ;
13 I $D(CLINIC) D PRV^PXBUTL2(CLINIC)
14 ;
15 ;I PXBCNT<11 D DISCPT1^PXBDCPT
16 ;I PXBCNT<21&(PXBCNT>10) D DISCPT2^PXBDCPT
17 ;I PXBCNT>20&(PXBCNT<31) D DISCPT3^PXBDCPT
18 ;I PXBCNT>30&('$D(PXBNCPT))
19 D DISCPT4^PXBDCPT("BEGIN")
20 ;I PXBCNT>30&($D(PXBNCPT)) D DISCPT4^PXBDCPT("SAME")
21 Q
22 ;
23 ;
24 ;
25ARRAY ;Set all CPT codes and modifiers into ^TMP("PXBDCPT",$J,"DSP"
26 ;for display
27 ;
28 N PXSQ,ENTRY,PXMD,PXDESC,PX124,PXC,PXD
29 S PXTMP="^TMP(""PXBDCPT"""_","_$J_","_"""DSP"")"
30 K @PXTMP
31 S (PXTLNS,PXSQ)=0
32 F S PXSQ=$O(PXBSAM(PXSQ)) Q:'PXSQ D
33 .S PXTLNS=PXTLNS+1
34 .S ENTRY=PXBSAM(PXSQ)
35 .S PXBSAM(PXSQ,"LINE")=PXTLNS
36 .I $D(PXBNCPT($P(ENTRY,U))) D
37 ..;I PXBNCPT($P(ENTRY,U))]"",'$D(PXBSKY(PXSQ,PXBNCPT($P(ENTRY,U)))) Q
38 ..Q:'$D(PXBNCPT($P(ENTRY,U),$O(PXBSKY(PXSQ,0))))
39 ..S $P(ENTRY,U)=$P(ENTRY,U)_"*"
40 .S @PXTMP@(PXTLNS,0)=PXSQ_U_$P(ENTRY,U)_U_$P(ENTRY,U,2)_U_$P(ENTRY,U,4)_U_$E($P(ENTRY,U,3),1,24)
41 .S PXMD=""
42 .F S PXMD=$O(PXBSAM(PXSQ,"MOD",PXMD)) Q:'PXMD D
43 ..S PXTLNS=PXTLNS+1
44 ..S PXMOD=PXBSAM(PXSQ,"MOD",PXMD)
45 ..S PXDESC=$P($$MODP^ICPTMOD($E(ENTRY,1,5),PXMOD,"E",IDATE),U,2) ;PX*108
46 ..S @PXTMP@(PXTLNS,0)=0_U_PXMOD_U_$E(PXDESC,1,54)
47 .S PXTLNS=PXTLNS+1
48 .S @PXTMP@(PXTLNS,0)="-22^"_$P(ENTRY,U,22)
49 .F PX124=5:1:12 D
50 ..S PXC=$P(ENTRY,U,PX124) Q:PXC=""
51 ..S PXD=$$ICDDX^ICDCODE(PXC) Q:PXD<1
52 ..S PXC=PXC_" "_$P(PXD,U,4)
53 ..S PXTLNS=PXTLNS+1,@PXTMP@(PXTLNS,0)=-PX124_U_PXC
54 ..I $G(PXBREQ(+PXD,"I"))="" S PXBREQ(+PXD,"I")=$P($$XLATE^PXBGPOV(PXBVST,+PXD),U,4,20)
55 ..S PXTLNS=PXTLNS+1,@PXTMP@(PXTLNS,0)="I^"_PXBREQ(+PXD,"I")
56 Q
57DISCPT1 ;--Display the CPT Data
58 ;
59 N ENTRY,J
60 D UNDON^PXBCC
61 W !,"No.",?4,"CPT CODE",?14,"QUANTITY",?25,"DESCRIPTION",?55,"PROVIDER",?75,$C(32)
62 W IOEDEOP
63 D UNDOFF^PXBCC
64 ;
65 ;
66 S J=0
67 F S J=$O(PXBSAM(J)) Q:J="" D
68 .S ENTRY=$G(PXBSAM(J))
69 .I $D(PXBNCPT($P(ENTRY,U,1))) S $P(ENTRY,U,1)=$P(ENTRY,U,1)_"*"
70 .W !,J,?4,$P(ENTRY,U,1),?15,$P(ENTRY,U,2)
71 .W ?25,$P(ENTRY,U,4),?55,$E($P(ENTRY,U,3),1,24)
72 .;---Display associated modifiers
73 .S PXSIEN=""
74 .F S PXSIEN=$O(PXBSAM(J,"MOD",PXSIEN)) Q:PXSIEN="" D
75 ..N PXWRAP,PXMOD,PXDESC,PXLN
76 ..S PXMOD=PXBSAM(J,"MOD",PXSIEN)
77 ..S PXDESC=$P($$MOD^ICPTMOD(PXMOD,"E",IDATE),U,3)
78 ..D WRAP^PXCEVFI4(PXDESC,58,.PXWRAP)
79 ..F PXLN=1:1 Q:$G(PXWRAP(PXLN))="" D
80 ...W:PXLN=1 !,?4,"CPT Modifier: "_PXMOD
81 ...W:PXLN>1 !
82 ...W ?22,PXWRAP(PXLN)
83 ;---Write no entries if none exsist
84 I '$D(PXBSAM) D NONE^PXBUTL(2)
85 Q
86 ;
87DISCPT2 ;--display of cpt data two columns more that 10 entries.
88 ;
89 N ENTRY,J,PXA
90 D GSET^%ZISS
91 D UNDON^PXBCC W IOG1
92 W !,"NO",?4,"CPT",?10,"QUA",?14,"DESCRIPTION",?39,IOVL
93 W ?40,"NO",?44,"CPT",?50,"QUA",?54,"NARRATIVE"
94 W IOEDEOP
95 D UNDOFF^PXBCC
96 ;
97 ;
98 ;
99 S J=0 F S J=$O(PXBSAM(J)) Q:J="" D
100 .S ENTRY(J)=$G(PXBSAM(J)) I $D(PXBNCPT($P(ENTRY(J),U,1))) S $P(ENTRY(J),U,1)=$P(ENTRY(J),U,1)_"*"
101 F J=1:1:10 D
102 .W !,J,?4,$P(ENTRY(J),U,1),?11,$P(ENTRY(J),U,2),?14,$E($P(ENTRY(J),U,4),1,24)
103 .D BAWRITE(ENTRY(J))
104 .I $D(ENTRY(J+10)) D
105 ..W ?39,IOVL,(J+10),?44,$P(ENTRY(J+10),U,1),?51,$P(ENTRY(J+10),U,2),?54,$E($P(ENTRY(J+10),U,4),1,24)
106 ..D BAWRITE(ENTRY(J))
107 W IOG0
108 Q
109 ;
110DISCPT3 ;--display of cpt data three colums more that 20 entries.
111 N ENTRY,J,PXA
112 D GSET^%ZISS
113 D UNDON^PXBCC W IOG1
114 W !,"NO",?4,"CPT",?10,"QUA",?14,"NARRATIVE",?25,IOVL
115 W ?26,"NO",?30,"CPT",?36,"QUA",?40,"NARRATIVE",?51,IOVL
116 W ?52,"NO",?56,"CPT",?62,"QUA",?66,"NARRATIVE"
117 W IOEDEOP
118 D UNDOFF^PXBCC
119 ;
120 S J=0 F S J=$O(PXBSAM(J)) Q:J="" D
121 .S ENTRY(J)=$G(PXBSAM(J)) I $D(PXBNCPT($P(ENTRY(J),U,1))) S $P(ENTRY(J),U,1)=$P(ENTRY(J),U,1)_"*"
122 F J=1:1:10 D
123 .W !,J,?4,$P(ENTRY(J),U,1),?11,$P(ENTRY(J),U,2),?14,$E($P(ENTRY(J),U,4),1,10)
124 .D BAWRITE(ENTRY(J))
125 .I $D(ENTRY(J+10)) D
126 ..W ?25,IOVL,(J+10),?30,$P(ENTRY(J+10),U,1),?37,$P(ENTRY(J+10),U,2),?40,$E($P(ENTRY(J+10),U,4),1,10)
127 ..D BAWRITE(ENTRY(J+10))
128 .I $D(ENTRY(J+20)) D
129 ..W ?51,IOVL,(J+20),?56,$P(ENTRY(J+20),U,1),?63,$P(ENTRY(J+20),U,2),?66,$E($P(ENTRY(J+20),U,4),1,10)
130 ..D BAWRITE(ENTRY(J+20))
131 W IOG0
132 Q
133 ;
134DISCPT4(SIGN) ;--Display the CPT Data
135 ;
136 ;SIGN=
137 ; '+' add 10 to the starting point in ^TMP("PXBDCPT",$J)
138 ; '-' subtract 10 from the starting point but not less that 0
139 ; 'BEGIN' start at the beginning
140 ; 'SAME' start stays where it's at
141 ; '3'--any number set start to that number
142 ;
143 N PXBSTART,PXTMP
144 D ARRAY
145 I SIGN="BEGIN" S ^TMP("PXBDCPT",$J,"START")=0,PXBSTART=0
146 I SIGN="SAME" S PXBSTART=^TMP("PXBDCPT",$J,"START")
147 I SIGN="+" D
148 .S PXBSTART=($G(^TMP("PXBDCPT",$J,"START"))+10)
149 .I PXBSTART'<PXTLNS S PXBSTART=PXBSTART-10
150 .S ^TMP("PXBDCPT",$J,"START")=PXBSTART
151 I SIGN="-" D
152 .S PXBSTART=$G(^TMP("PXBDCPT",$J,"START"))-10
153 .S ^TMP("PXBDCPT",$J,"START")=PXBSTART
154 .I PXBSTART<0 S PXBSTART=0 S ^TMP("PXBDCPT",$J,"START")=0
155 I +SIGN>0&(SIGN#10) D Q:^TMP("PXBDCPT",$J,"START")=PXBSTART S ^TMP("PXBDCPT",$J,"START")=PXBSTART
156 .S PXBSTART=$P((SIGN/10),".")*10
157 .S:PXBSTART<10 PXBSTART=0
158 I +SIGN>0&'(SIGN#10) D Q:^TMP("PXBDCPT",$J,"START")=PXBSTART S ^TMP("PXBDCPT",$J,"START")=PXBSTART
159 .S PXBSTART=(($P((SIGN/10),".")*10)-10)
160 .S:PXBSTART<10 PXBSTART=0
161 ;
162 ;
163 I SIGN'="BEGIN" D LOC^PXBCC(3,0) W IOEDEOP
164 ;
165HEAD4 ;--HEADER ON LIST
166 S HEAD="- - E N C O U N T E R P R O C E D U R E S (CPT CODES) - -"
167 W IOINHI,!,IOCUU,?(IOM-$L(HEAD))\2,HEAD,IOINLOW
168 W IOELEOL K HEAD
169 ;
170 ;
171 N ENTRY,J
172 D UNDON^PXBCC
173 W !,"No.",?4,"CPT CODE",?14,"QUANTITY",?25,"DESCRIPTION",?55,"PROVIDER",?75,$C(32)
174 W IOEDEOP
175 D UNDOFF^PXBCC
176 ;
177 ;
178 N PXSIEN,PXDESC,PXMOD,PXQ,PXLNS,PX,PL
179 S J=PXBSTART,PXQ=""
180 S PXLNS=0
181 F S J=$O(@PXTMP@(J)) Q:J="" D Q:PXQ
182 .S PXLNS=PXLNS+1
183 .I '(PXLNS#11) D Q
184 ..S ^TMP("PXBDCPT",$J,"START")=PXBSTART
185 ..S PXQ=1
186 .I +@PXTMP@(J,0)>0 D Q
187 ..W !,$P(^(0),U),?4,$P(^(0),U,2),?15,$P(^(0),U,3)
188 ..W ?25,$P(^(0),U,4),?55,$P(^(0),U,5)
189 .I +@PXTMP@(J,0)<0 D Q
190 ..S PX=-$P(^(0),U,1)
191 ..I PX=22 W !?4,"Ordering Provider: ",$P(^(0),U,2) Q
192 ..I PX<20 W !?4,"Diagnosis "_(PX-4)_": ",$P(^(0),U,2) Q
193 .I $P(@PXTMP@(J,0),U)="I" D CIA^PXBDPOV($P(^(0),U,2,16)) Q
194 .I $P(@PXTMP@(J,0),U)=0 D
195 ..W !?4,"CPT Modifier: "_$P(^(0),U,2)_" "_$P(^(0),U,3)
196 I SIGN'="BEGIN" W !!
197 Q
198 ;
199BAWRITE(PXD) ;WRITE BA INFO
200 N PX,PD,PP
201 W !?4,"Ordering Provider: ",$P(PXD,U,22)
202 F PX=1:1:8 D
203 .S PD=$P(PXD,U,PX+5),PP=$$XLATE^PXBGPOV(PXBVST,PD)
204 .Q:'PD!'PP
205 .W:PD !?4,"Diagnosis: ",PD
206 .D CIA^PXBDPOV($P(PP,U,4,16))
207 Q
208 ;
Note: See TracBrowser for help on using the repository browser.