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

PXBPCPT1 ;ISL/JVS,ESW - PROMPT CPT ;3/22/05 9:23am
 ;;1.0;PCE PATIENT CARE ENCOUNTER;**7,73,88,89,108,112,121,124**;Aug 12, 1996
 ;
 ;
 ;
 ;
 ;
ADDM ;--------If Multiple entries have been entered assume quantity 1
 ;
 ;
 N OK,PXBLEN,BDATA,PXMDCNT
 D WIN17^PXBCC(PXBCNT)
 S NF=0,PXBLEN=0
 D EDITMM
 Q
 I DATA[","&(DATA'["-")&($L($P(DATA,",",1))=5) S NF=1 D
 .D HELP1^PXBUTL1("CPTMM"),HELP1^PXBUTL1("CON")
 .R OK:DTIME
 .S PXBLEN=$L(DATA,",") F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
 ..I $L($G(PXBPIECE))'=5 S BAD($G(PXBPIECE))="" Q
 ..I $L(PXBPIECE)=5 S X=PXBPIECE,DIC=81,DIC(0)="Z",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
 ..I Y=-1 S BAD(+$G(PXBPIECE))="" Q
 ..S $P(REQI,"^",3)=+Y,$P(REQI,"^",4)=1
 ..S PXBNCPT(PXBPIECE)=""
 ..D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
 ..D EN1^PXKMAIN
 ..D RSET^PXBDREQ("CPT")
BAD ;----BAD CPT CODES
 N Y I $G(NF)&($D(BAD)) D  Q
 .S (BDATA,EDATA)=""
 .F  S BDATA=$O(BAD(BDATA)) Q:BDATA=""  S EDATA=EDATA_BDATA_"  "
 .W ! D HELP^PXBUTL0("CPTM") W !
 .S DIR(0)="E" D ^DIR K DIR,DIRUT
 .S:Y=1 DATA="^C" S:Y=0!(Y="") DATA="^"
 I $G(NF)&('$D(BAD)) S DATA="^C" Q
 Q
 ;
BADD(PAR,EDATA) ;----BAD CPT CODES - DISPLAY
 I $G(NF)&($D(BAD)) D  Q
 .W !,*7 D HELP^PXBUTL0(PAR) W !
 Q
EDITMM ;--ADD MULTIPLE ENTRIES
 ;
 N STOP,BAD,GONE,PXBLEN,PXBPIECE,BDATA,PX,PXI,YY,BAD
 S STOP=0
 I DATA[",",DATA'["-" D
 .S PXBLEN=$L(DATA,",")
 .S NF=1
 .F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) Q:STOP=1  D
 ..;----ADDED
 ..I PXBPIECE="" Q
 ..I $D(PXBKY(PXBPIECE)) S BAD(PXBPIECE)="" S NF=1 D BADD("CPTMDP",PXBPIECE) H 2 Q
 ..I PXI>1 I ","_$P(DATA,",",1,PXI-1)_","[(","_PXBPIECE_",") W !!,*7,"PROCEDURE "_PXBPIECE_" was already processed." H 1 Q
 ..S X=PXBPIECE,DIC=81,DIC(0)="ZB",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
 ..I Y<1 S BAD(PXBPIECE)="" S NF=1 D BADD("CPTM",PXBPIECE) Q
 ..S $P(REQI,U,3)=+Y
 ..S $P(REQI,U,8)=""
 ..W !!,"For the PROCEDURE: "_X_"--"_$P(Y(0),U,2)
 ..;--Prompt for CPT Modifiers
 ..D FULL0^PXBCC
 ..S PXMDCNT=$$CODM^ICPTCOD($P(REQI,"^",3),"^TMP(""PXMODARR"",$J",PXBSOURC,PXBVSTDT)
 ..K ^TMP("PXMODARR",$J)
 ..D MOD^PXBPMOD(PXBVST,PXBPAT,$P(REQI,"^",3),"",$P(REQI,"^",8),IDATE,PXMDCNT,.PXMREQ)
 ..S:EDATA["^C" STOP=1
 ..Q:STOP
 ..S CPTQUA=1
 ..D QUA^PXBPQUA
 ..S:EDATA["^C" STOP=1 S:EDATA["^P" STOP=1 Q:STOP=1
 ..;--Get Provider for CPT
 ..N PXBSKY,PXBKY,PXBSAM,PXBCNT,PRVDR,FPRI
 ..D PRV^PXBGPRV(PXBVST,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI) W IOSC
 ..S FROM="CPT" D  Q:STOP
 ...N DATA D PRV^PXBPPRV I DATA["^P" D  W IOCUU S STOP=1 Q
 ....S $P(REQI,"^",1)="",$P(REQI,"^",2)="",$P(REQI,"^",7)=""
 ....K PXBDPRV
 ...S (PXBNCPT(PXBPIECE),DATA)=""
TEST3O ...;ORDERING PROVIDER - PX124
 ...D ORD^PXBPORD
 ...I DATA["^O" D  W IOCUU G TEST3O
 ....S $P(REQI,U,22)=""
TEST3D ...;UP TO 8 DIAGNOSES - PX124
 ...S (PXBDXPRI,PX124)="",DATA=1
 ...F  S PX124=$O(^AUPNVPOV("AD",PXBVST,PX124)) Q:'PX124!PXBDXPRI  D
 ....I $P(^AUPNVPOV(PX124,0),U,12)="P" S PXBDXPRI=$P(^(0),U,1)
 ...F PX124=1:1:8 Q:DATA=""!(DATA["^")&$$MORE(PX124)  D DX(PX124)
 ..D EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
 ..D EN1^PXKMAIN
 ..D RSET^PXBDREQ("CPT")
 ..D RSET^PXBDREQ("PRV")
 ..K PXMREQ
 ..S $P(REQI,"^",7)=""
 .S DATA="^C"
 Q
 ;
DELM ;--------If Multiple deleting
 N DELM,PXBJ,BAD,PXBPIECE,PXBLEN
 S NF=0,PXBLEN=0 S $P(DELM,"^",2)=1
 I $E(DATA,1)="@" D
 .I '$$SURE^PXCEAE2 S DATA="^C" Q
 .S DATA=$P(DATA,"@",2),NF=1
 .S PXBLEN=$L(DATA,",")
 .F PXI=1:1:PXBLEN S PXBPIECE=$P(DATA,",",PXI) D
 ..I PXBPIECE'["-"&(PXBPIECE'>0!(PXBPIECE'<(PXBCNT+1))) S BAD(+$G(PXBPIECE))="" Q
 ..I PXBPIECE'["-" D
 ...I $D(GONE(PXBPIECE)) Q
 ...Q:PXBPIECE'?.N
 ...S $P(REQI,"^",8)=$O(PXBSKY(PXBPIECE,0)) ;-IEN
 ...S X=$P(PXBSAM(PXBPIECE),"^",1),DIC=81,DIC(0)="ZM",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
 ...S $P(REQI,"^",3)=+Y K Y
 ...S $P(REQI,"^",4)=0 ;-QUANTITY
 ...S GONE(PXBPIECE)=""
 ...D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
 ...D EN1^PXKMAIN
 ..I PXBPIECE["-" D
 ...F PXBJ=$P(PXBPIECE,"-",1):1:$P(PXBPIECE,"-",2) D
 ....I $D(GONE(PXBJ)) Q
 ....I PXBJ'>0!(PXBJ'<(PXBCNT+1)) S BAD(PXBJ)="" Q
 ....S $P(REQI,"^",8)=$O(PXBSKY(PXBJ,0)) ;-IEN
 ....S X=$P(PXBSAM(PXBJ),"^",1),DIC=81,DIC(0)="ZM",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
 ....S $P(REQI,"^",3)=+Y K Y
 ....S $P(REQI,"^",4)=0 ;-QUANTITY
 ....S GONE(PXBJ)=""
 ....D EN0^PXBSTOR(PXBVST,PATIENT,REQI)
 ....D EN1^PXKMAIN
 K GONE
 I $G(NF)&($D(BAD)) D  Q
 .S (BDATA,EDATA)=""
 .F  S BDATA=$O(BAD(BDATA)) Q:BDATA=""  S EDATA=EDATA_BDATA_"  "
 .W ! D HELP^PXBUTL0("CPTMD") W !
 .S DIR(0)="E" D ^DIR K DIR
 .S:Y=1 DATA="^C" S:Y=0!(Y="") DATA="^" K Y
 I $G(NF)&('$D(BAD)) S DATA="^C" Q
 Q
DX(PXC) ;GET DIAGNOSIS - PX124
DX2 ;2nd entry
 D CDX^PXBPCPT2(PXC)
 I DATA["^D" D  W IOCUU G DX2
 .S $P(REQI,U,PXC+11)=""
 Q:DATA["^"!(DATA["@")
 D PRINT^PXBDREQ(PXC+5),WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1)
 W IOSC,IOEDEOP,IORC
 Q
MORE(PXC)     ;MORE DXs? - PX124
 Q:PXC=19 0  ;last in list - NO More DXs
 N PX,ANS
 S ANS=0
 F PX=PXC+1:1:19 I $P(REQI,U,PX) S ANS=1 Q
 Q ANS
 ;