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

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

initial load of FOIAVistA 6/30/08 version

File size: 4.8 KB
Line 
1PXBPCPT1 ;ISL/JVS,ESW - PROMPT CPT ;3/22/05 9:23am
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,73,88,89,108,112,121,124**;Aug 12, 1996
3 ;
4 ;
5 ;
6 ;
7 ;
8ADDM ;--------If Multiple entries have been entered assume quantity 1
9 ;
10 ;
11 N OK,PXBLEN,BDATA,PXMDCNT
12 D WIN17^PXBCC(PXBCNT)
13 S NF=0,PXBLEN=0
14 D EDITMM
15 Q
16 I DATA[","&(DATA'["-")&($L($P(DATA,",",1))=5) S NF=1 D
17 .D HELP1^PXBUTL1("CPTMM"),HELP1^PXBUTL1("CON")
18 .R OK:DTIME
19 .S PXBLEN=$L(DATA,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
20 ..I $L($G(PXBPIECE))'=5 S BAD($G(PXBPIECE))="" Q
21 ..I $L(PXBPIECE)=5 S X=PXBPIECE,DIC=81,DIC(0)="Z",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
22 ..I Y=-1 S BAD(+$G(PXBPIECE))="" Q
23 ..S $P(REQI,"^",3)=+Y,$P(REQI,"^",4)=1
24 ..S PXBNCPT(PXBPIECE)=""
25 ..D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
26 ..D EN1^PXKMAIN
27 ..D RSET^PXBDREQ("CPT")
28BAD ;----BAD CPT CODES
29 N Y I $G(NF)&($D(BAD)) D Q
30 .S (BDATA,EDATA)=""
31 .F S BDATA=$O(BAD(BDATA)) Q:BDATA="" S EDATA=EDATA_BDATA_" "
32 .W ! D HELP^PXBUTL0("CPTM") W !
33 .S DIR(0)="E" D ^DIR K DIR,DIRUT
34 .S:Y=1 DATA="^C" S:Y=0!(Y="") DATA="^"
35 I $G(NF)&('$D(BAD)) S DATA="^C" Q
36 Q
37 ;
38BADD(PAR,EDATA) ;----BAD CPT CODES - DISPLAY
39 I $G(NF)&($D(BAD)) D Q
40 .W !,*7 D HELP^PXBUTL0(PAR) W !
41 Q
42EDITMM ;--ADD MULTIPLE ENTRIES
43 ;
44 N STOP,BAD,GONE,PXBLEN,PXBPIECE,BDATA,PX,PXI,YY,BAD
45 S STOP=0
46 I DATA[",",DATA'["-" D
47 .S PXBLEN=$L(DATA,",")
48 .S NF=1
49 .F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) Q:STOP=1 D
50 ..;----ADDED
51 ..I PXBPIECE="" Q
52 ..I $D(PXBKY(PXBPIECE)) S BAD(PXBPIECE)="" S NF=1 D BADD("CPTMDP",PXBPIECE) H 2 Q
53 ..I PXI>1 I ","_$P(DATA,",",1,PXI-1)_","[(","_PXBPIECE_",") W !!,*7,"PROCEDURE "_PXBPIECE_" was already processed." H 1 Q
54 ..S X=PXBPIECE,DIC=81,DIC(0)="ZB",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
55 ..I Y<1 S BAD(PXBPIECE)="" S NF=1 D BADD("CPTM",PXBPIECE) Q
56 ..S $P(REQI,U,3)=+Y
57 ..S $P(REQI,U,8)=""
58 ..W !!,"For the PROCEDURE: "_X_"--"_$P(Y(0),U,2)
59 ..;--Prompt for CPT Modifiers
60 ..D FULL0^PXBCC
61 ..S PXMDCNT=$$CODM^ICPTCOD($P(REQI,"^",3),"^TMP(""PXMODARR"",$J",PXBSOURC,PXBVSTDT)
62 ..K ^TMP("PXMODARR",$J)
63 ..D MOD^PXBPMOD(PXBVST,PXBPAT,$P(REQI,"^",3),"",$P(REQI,"^",8),IDATE,PXMDCNT,.PXMREQ)
64 ..S:EDATA["^C" STOP=1
65 ..Q:STOP
66 ..S CPTQUA=1
67 ..D QUA^PXBPQUA
68 ..S:EDATA["^C" STOP=1 S:EDATA["^P" STOP=1 Q:STOP=1
69 ..;--Get Provider for CPT
70 ..N PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR,FPRI
71 ..D PRV^PXBGPRV(PXBVST,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI) W IOSC
72 ..S FROM="CPT" D Q:STOP
73 ...N DATA D PRV^PXBPPRV I DATA["^P" D W IOCUU S STOP=1 Q
74 ....S $P(REQI,"^",1)="",$P(REQI,"^",2)="",$P(REQI,"^",7)=""
75 ....K PXBDPRV
76 ...S (PXBNCPT(PXBPIECE),DATA)=""
77TEST3O ...;ORDERING PROVIDER - PX124
78 ...D ORD^PXBPORD
79 ...I DATA["^O" D W IOCUU G TEST3O
80 ....S $P(REQI,U,22)=""
81TEST3D ...;UP TO 8 DIAGNOSES - PX124
82 ...S (PXBDXPRI,PX124)="",DATA=1
83 ...F S PX124=$O(^AUPNVPOV("AD",PXBVST,PX124)) Q:'PX124!PXBDXPRI D
84 ....I $P(^AUPNVPOV(PX124,0),U,12)="P" S PXBDXPRI=$P(^(0),U,1)
85 ...F PX124=1:1:8 Q:DATA=""!(DATA["^")&$$MORE(PX124) D DX(PX124)
86 ..D EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
87 ..D EN1^PXKMAIN
88 ..D RSET^PXBDREQ("CPT")
89 ..D RSET^PXBDREQ("PRV")
90 ..K PXMREQ
91 ..S $P(REQI,"^",7)=""
92 .S DATA="^C"
93 Q
94 ;
95DELM ;--------If Multiple deleting
96 N DELM,PXBJ,BAD,PXBPIECE,PXBLEN
97 S NF=0,PXBLEN=0 S $P(DELM,"^",2)=1
98 I $E(DATA,1)="@" D
99 .I '$$SURE^PXCEAE2 S DATA="^C" Q
100 .S DATA=$P(DATA,"@",2),NF=1
101 .S PXBLEN=$L(DATA,",")
102 .F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
103 ..I PXBPIECE'["-"&(PXBPIECE'>0!(PXBPIECE'<(PXBCNT+1))) S BAD(+$G(PXBPIECE))="" Q
104 ..I PXBPIECE'["-" D
105 ...I $D(GONE(PXBPIECE)) Q
106 ...Q:PXBPIECE'?.N
107 ...S $P(REQI,"^",8)=$O(PXBSKY(PXBPIECE,0)) ;-IEN
108 ...S X=$P(PXBSAM(PXBPIECE),"^",1),DIC=81,DIC(0)="ZM",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
109 ...S $P(REQI,"^",3)=+Y K Y
110 ...S $P(REQI,"^",4)=0 ;-QUANTITY
111 ...S GONE(PXBPIECE)=""
112 ...D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
113 ...D EN1^PXKMAIN
114 ..I PXBPIECE["-" D
115 ...F PXBJ=$P(PXBPIECE,"-",1):1:$P(PXBPIECE,"-",2) D
116 ....I $D(GONE(PXBJ)) Q
117 ....I PXBJ'>0!(PXBJ'<(PXBCNT+1)) S BAD(PXBJ)="" Q
118 ....S $P(REQI,"^",8)=$O(PXBSKY(PXBJ,0)) ;-IEN
119 ....S X=$P(PXBSAM(PXBJ),"^",1),DIC=81,DIC(0)="ZM",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
120 ....S $P(REQI,"^",3)=+Y K Y
121 ....S $P(REQI,"^",4)=0 ;-QUANTITY
122 ....S GONE(PXBJ)=""
123 ....D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
124 ....D EN1^PXKMAIN
125 K GONE
126 I $G(NF)&($D(BAD)) D Q
127 .S (BDATA,EDATA)=""
128 .F S BDATA=$O(BAD(BDATA)) Q:BDATA="" S EDATA=EDATA_BDATA_" "
129 .W ! D HELP^PXBUTL0("CPTMD") W !
130 .S DIR(0)="E" D ^DIR K DIR
131 .S:Y=1 DATA="^C" S:Y=0!(Y="") DATA="^" K Y
132 I $G(NF)&('$D(BAD)) S DATA="^C" Q
133 Q
134DX(PXC) ;GET DIAGNOSIS - PX124
135DX2 ;2nd entry
136 D CDX^PXBPCPT2(PXC)
137 I DATA["^D" D W IOCUU G DX2
138 .S $P(REQI,U,PXC+11)=""
139 Q:DATA["^"!(DATA["@")
140 D PRINT^PXBDREQ(PXC+5),WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1)
141 W IOSC,IOEDEOP,IORC
142 Q
143MORE(PXC) ;MORE DXs? - PX124
144 Q:PXC=19 0 ;last in list - NO More DXs
145 N PX,ANS
146 S ANS=0
147 F PX=PXC+1:1:19 I $P(REQI,U,PX) S ANS=1 Q
148 Q ANS
149 ;
Note: See TracBrowser for help on using the repository browser.