source: FOIAVistA/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBPCPT.m@ 677

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1PXBPCPT ;ISL/JVS,ESW - PROMPT CPT ;3/18/05 12:55pm
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,89,112,121,132,149,124**;Aug 12, 1996
3 ;
4 ;
5 ;
6CPT ;--CPT CODE
7 ;SELINE=LINE NUMBER OF SELECTED ITEM
8 N TIMED,PXBUT,EDATA,DIC,LINE,XFLAG,SELINE
9 N I,X,Y,Q,DOUBLEQQ,NF,BAD,OK,CPT,PXEDIT
10 I '$D(^DISV(DUZ,"PXBCPT-1")) S ^DISV(DUZ,"PXBCPT-1")=" "
11 I '$D(IOSC) D TERM^PXBCC
12 S DOUBLEQQ=0,PXEDIT=""
13 S TIMED="I '$T!(DATA[""^"")!(DATA="""")"
14 S DIC("S")="I $$CPTSCREN^PXBUTL(Y,IDATE)"
15C ;--SECOND ENTRY POINT
16 W IOSC
17 ;---DYNAMIC HEADER-----------------
18 I '$D(CYCL) D
19 .I PXBCNT=0,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There are "_$G(PXBCNT)_" PROCEDURES associated with this encounter.",IOUOFF,IOELEOL
20 .I PXBCNT=1,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There is "_$G(PXBCNT)_" PROCEDURE associated with this encounter.",IOUOFF,IOELEOL
21 .I PXBCNT>1,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There are "_$G(PXBCNT)_" PROCEDURES associated with this encounter.",IOUOFF,IOELEOL
22 ;
23 D LOC^PXBCC(15,0)
24 ;I PXBCNT>30
25 ;W IOCUU,IOELEOL,
26 W:PXTLNS>10 !,"Enter '+' for next page, '-' for last page." ;,IORC
27 D WIN17^PXBCC(PXBCNT)
28 I '$D(^TMP("PXK",$J,"CPT")) W !,"Enter PROCEDURE (CPT CODE): "
29 I $D(^TMP("PXK",$J,"CPT")) W !,"Enter ",IOINHI,"NEXT",IOINLOW," PROCEDURE (CPT CODE): "
30 W IOELEOL R DATA:DTIME S EDATA=DATA
31C1 ;----Third entry point
32 X TIMED I S PXBUT=1 S:DATA="^^" PXBEXIT=0 S:DATA="^^^" PXBRRR="" G CPTX
33 I DATA?1.N1"E".NAP S DATA=" "_DATA
34 I $L(DATA)>200 S (DATA,EDATA)=$E(DATA,1,199)
35 I DATA?24.N S (DATA,EDATA)=$E(DATA,1,24)
36 D CASE^PXBUTL
37 ;----SPACE BAR---
38 I DATA=" ",$D(^DISV(DUZ,"PXBCPT-1")) S DATA=^DISV(DUZ,"PXBCPT-1") W DATA
39 ;---------------
40 I DATA["^P" G CPTX
41 I DATA["^C" G CPTX
42 ;
43 I ((DATA="+")!(DATA="-")) D DISCPT4^PXBDCPT(DATA) G C
44 ;
45M ;--------If Multiple entries have been entered
46 D ADDM^PXBPCPT1
47 I $G(NF) G C1
48 ;
49DEL ;--------If Multiple deleting
50 D DELM^PXBPCPT1
51 I DATA["^C" G CPTX
52 I $G(NF) G C1
53 ;
54 D MOD
55 ;
56LI ;--------If picked a line number display
57 ;
58 I (DATA>0)&(DATA<(PXBCNT+1))&($L(DATA)'>$L(PXBCNT)) D
59 .S XFLAG=1
60 .D DISCPT4^PXBDCPT(PXBSAM(DATA,"LINE"))
61 .D REVCPT^PXBCC(DATA,1)
62 .S SELINE=DATA
63 .F I=1:1:$L(DATA) W IOCUB,IOECH
64 .S CPTQUA=$P($G(PXBSAM(DATA)),"^",2)
65 .S DATA=$P($G(PXBSAM(DATA)),"^",1)
66 .;I $G(Q)'>1 W DATA
67 I $D(XFLAG),XFLAG=1 S Y=DATA G FIN
68 ;
69 ;
70 ;--------If CPT is already in the file
71 I $D(PXBKY(DATA)) D I +PXEDIT<0 S DATA="^C" G C1
72 .D DISCPT4^PXBDCPT(PXBSAM($O(PXBKY(DATA,0)),"LINE"))
73 .K Q
74 .D TIMES^PXBUTL(DATA)
75 .S PXEDIT=$$MULTI(DATA) Q:+PXEDIT<0
76 .I Q=1 D
77 ..S LINE=$O(PXBKY(DATA,0))
78 ..S XFLAG=1
79 ..Q:PXEDIT="A"
80 ..D REVCPT^PXBCC(LINE,1)
81 ..S CPTQUA=$P($G(PXBSAM(LINE)),"^",2)
82 ..S SELINE=$O(Q(0))
83 .I Q>1,PXEDIT="E" D
84 ..N PXPG
85 ..S NLINE=0
86 ..S PXPG=+$G(^TMP("PXBDCPT",$J,"START"))+10
87 ..F S NLINE=$O(Q(NLINE)) Q:NLINE="" Q:PXBSAM(NLINE,"LINE")>PXPG D
88 ...D REVCPT^PXBCC(NLINE,1)
89 I '$G(Q) K SELINE
90 I PXEDIT="E",$D(Q),Q>1 D G:DATA="^C" C1 G LI
91 .D WHICH^PXBPWCH S:DATA["^" DATA="^C"
92 I $D(XFLAG),XFLAG=1 S Y=DATA G FIN
93 ;
94 ;--------Need to do a DIC lookup on data
95 I DATA'="??" D G:DATA="^C" C I DATA="?" G C
96 .D:DATA="?" EN1^PXBHLP0("PXB","CPT",1,"",1)
97 I DATA="??" D G:UDATA="^C" C1 G FIN
98 .S DOUBLEQQ=1
99 .D EN1^PXBHLP0("PXB","CPT","",1,2)
100 .I $L(DATA,"^")>1 D
101 ..S DATA=+$P(DATA,"^",2)_$S($P(DATA,U,3)]"":"-"_$P(DATA,U,3),1:"")
102 ..D MOD
103 ..S Y=DATA
104 .S:$G(UDATA)="" UDATA="^C"
105 .S:UDATA="^C" (DATA,EDATA,Y)=UDATA
106 ;
107 ;--If a "?" is NOT entered during lookup
108 S FROM="CPT",(VAL,Y)=$P($P($$DOUBLE1^PXBGCPT2(FROM),"^",2),"--",1)
109 S (X,DATA,EDATA)=VAL,DIC=81,DIC(0)="MZ",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
110 I Y<1 S DATA="^C" G C1
111 ;
112 ;--If Y is good and already in file...
113 I $D(Y),$D(PXBKY(Y)) W IORC,IOCUU,IOEDEOP,! D
114 .D DISCPT4^PXBDCPT($O(PXBKY($P(Y,"^",2),0)))
115 .S LINE=$O(PXBKY($P(Y,"^",2),0)) D REVCPT^PXBCC(LINE,1)
116 .S CPTQUA=$P($G(PXBSAM(LINE)),"^",2)
117 ;
118 ;
119FIN ;--FINISH CPT
120 I $G(SELINE) S $P(REQE,"^",1)=$P($G(PXBSAM(SELINE)),"^",3)
121 I $P(REQE,"^",1)="" S $P(REQE,"^",1)="...No Provider Selected..."
122 I $L(Y,"^")'>1 S X=Y,DIC=81,DIC(0)="ZM",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
123 I Y<0 D HELP^PXBUTL0("CPTM") G C
124 S OK=$$CPTOK^PXBUTL(+Y,IDATE) D G:+OK=0 C
125 .I +OK=0 W IOCUF,IOCUF,IORVON,"INACTIVE!--",IORVOFF D HELP1^PXBUTL1("CPTI") ;--HELP
126 S CPT=Y(0)
127 N PXINF S PXINF=$$CPT^ICPTCOD(+Y,IDATE),$P(CPT,U,2)=$P(PXINF,U,3)
128 S ^DISV(DUZ,"PXBCPT-1")=$P(CPT,"^",1)
129 I $D(PXBNCPT) S PXBNCPTF=1
130 I $D(PXBKY(Y(0,0))),$G(SELINE) D
131 .S $P(REQI,"^",8)=$O(PXBSKY(SELINE,0))
132 .S PREDOC=$P(PXBSAM(SELINE),"^",3)
133 .I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
134 ..Q:$P(REQI,"^",8)]""
135 ..S $P(REQI,"^",8)=$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0))
136 .I $D(PXBPRV($P(REQE,"^",1))) D
137 ..S CPTQUA=$P(PXBSAM($O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0)),0))),"^",2)
138 I $D(PXBKY(Y(0,0))),'$G(SELINE) D
139 .;S $P(REQI,"^",8)=$O(PXBSKY($O(PXBKY(Y(0,0),0)),0))
140 .S PREDOC=$P(PXBSAM($O(PXBKY(Y(0,0),0))),"^",3)
141 .I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
142 ..S $P(REQI,"^",8)=$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0))
143 .I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
144 ..S CPTQUA=$P(PXBSAM($O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0)),0))),"^",2)
145 S $P(REQI,"^",3)=+Y
146 S $P(REQE,"^",3)=$P(CPT,"^",1)_"-- "_$P(CPT,"^",2)
147 S PXBNCPT($P(CPT,"^",1))=$P(REQI,"^",8)
148 S:$P(REQI,"^",8)]"" PXBNCPT($P(CPT,"^",1),$P(REQI,"^",8))=""
149 ;PX124 adds to REQ*
150REST I $P(REQI,U,8) D
151 .N CTR,VAL,IEN
152 .S IEN=$P(REQI,U,8)
153 .S $P(REQI,U,13,19)=$P($G(^AUPNVCPT(IEN,0)),U,9,15)
154 .S $P(REQI,U,12)=$P($G(^AUPNVCPT(IEN,0)),U,5)
155 .F CTR=12:1:19 D
156 ..S VAL=$P(REQI,U,CTR)
157 ..S:VAL VAL=$$ICDDX^ICDCODE(VAL,IDATE),$P(REQE,U,CTR)=$P($G(VAL),U,2)_" --"_$P($G(VAL),U,4)
158 .S VAL=$P($G(^AUPNVCPT(IEN,12)),U,2),$P(REQI,U,22)=VAL
159 .S:VAL $P(REQE,U,22)=$P($G(^VA(200,VAL,0)),U,1)
160 ;
161CPTX ;--CPT Exit and cleanup
162 I $P(REQE,"^",1)="" S $P(REQE,"^",1)="...No Provider Selected..."
163 I $G(WHAT)="INTV",DATA="^" S PXBEXIT="^^"
164 I $D(PXBRRR) S DATA="^"
165 I $D(PREDOC) D
166 .I PREDOC]""&($P(REQE,"^",1)'[PREDOC) W !,IOINHI,"--WARNING!",IOINLOW," Currently stored Provider of service:-",IOINHI,PREDOC,IOINLOW D
167 ..I '$D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) S $P(REQI,"^",8)=""
168 K PXBDPRV,PREDOC
169 W IOEDEOP
170 Q
171MOD ;---Separate CPT modifiers from CPT codes in entry string, if entered
172 I DATA?1.N1"-".NE D
173 .S PXMODSTR=$P(DATA,"-",2)
174 .S (DATA,EDATA)=$P(DATA,"-",1)
175 Q
176 ;
177MULTI(CPTCD) ;--Prompt user to Edit existing CPT code or Add as new entry
178 ;
179 N DIR,DA,X,Y
180 S DIR(0)="SB^E:EDIT;A:ADD"
181 S DIR("A")="Do you wish to (E)dit or (A)dd"
182 ;PX*2.0*132
183 I (($E(CPTCD)?1N)&($D(^IBE(357.69,+CPTCD))))!(($E(CPTCD)?1A)&($D(^IBE(357.69,CPTCD)))) D
184 .S DIR(0)="SB^E:EDIT",DIR("A")="You may only (E)dit this code, no duplicate E&M codes allowed."
185 S DIR("A",1)="CPT "_CPTCD_" already on file for this Encounter"
186 D ^DIR
187 I Y']""!(Y="^") Q -1
188 Q Y
Note: See TracBrowser for help on using the repository browser.