Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PXBPCPT

PXBPCPT.m

Go to the documentation of this file. 
  1. PXBPCPT ;ISL/JVS,ESW - PROMPT CPT ; 4/23/03 7:15pm
  1.  ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,89,112**;Aug 12, 1996
  1.  ;
  1.  ;
  1.  ;
  1. CPT ;--CPT CODE
  1.  ;SELINE=LINE NUMBER OF SELECTED ITEM
  1.  N TIMED,PXBUT,EDATA,DIC,LINE,XFLAG,SELINE
  1.  N I,X,Y,Q,DOUBLEQQ,NF,BAD,OK,CPT,PXEDIT
  1.  I '$D(^DISV(DUZ,"PXBCPT-1")) S ^DISV(DUZ,"PXBCPT-1")=" "
  1.  I '$D(IOSC) D TERM^PXBCC
  1.  S DOUBLEQQ=0,PXEDIT=""
  1.  S TIMED="I '$T!(DATA[""^"")!(DATA="""")"
  1.  S DIC("S")="I $$CPTSCREN^PXBUTL(Y,IDATE)"
  1. C ;--SECOND ENTRY POINT
  1.  W IOSC
  1.  ;---DYNAMIC  HEADER-----------------
  1.  I '$D(CYCL) D
  1.  .I PXBCNT=0,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There are "_$G(PXBCNT)_" PROCEDURES associated with this encounter.",IOUOFF,IOELEOL
  1.  .I PXBCNT=1,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There is "_$G(PXBCNT)_" PROCEDURE associated with this encounter.",IOUOFF,IOELEOL
  1.  .I PXBCNT>1,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There are "_$G(PXBCNT)_" PROCEDURES associated with this encounter.",IOUOFF,IOELEOL
  1.  ;
  1.  D LOC^PXBCC(15,0)
  1.  ;I PXBCNT>30 
  1.  ;W IOCUU,IOELEOL,
  1.  W:PXTLNS>10 !,"Enter '+' for next page, '-' for last page." ;,IORC
  1.  D WIN17^PXBCC(PXBCNT)
  1.  I '$D(^TMP("PXK",$J,"CPT")) W !,"Enter PROCEDURE (CPT CODE): "
  1.  I $D(^TMP("PXK",$J,"CPT")) W !,"Enter ",IOINHI,"NEXT",IOINLOW," PROCEDURE (CPT CODE): "
  1.  W IOELEOL R DATA:DTIME S EDATA=DATA
  1. C1 ;----Third entry point
  1.  X TIMED I  S PXBUT=1 S:DATA="^^" PXBEXIT=0 S:DATA="^^^" PXBRRR="" G CPTX
  1.  I DATA?1.N1"E".NAP S DATA=" "_DATA
  1.  I $L(DATA)>200 S (DATA,EDATA)=$E(DATA,1,199)
  1.  I DATA?24.N S (DATA,EDATA)=$E(DATA,1,24)
  1.  D CASE^PXBUTL
  1.  ;----SPACE BAR---
  1.  I DATA=" ",$D(^DISV(DUZ,"PXBCPT-1")) S DATA=^DISV(DUZ,"PXBCPT-1") W DATA
  1.  ;---------------
  1.  I DATA["^P" G CPTX
  1.  I DATA["^C" G CPTX
  1.  ;
  1.  I ((DATA="+")!(DATA="-")) D DISCPT4^PXBDCPT(DATA) G C
  1.  ;
  1. M ;--------If Multiple entries have been entered
  1.  D ADDM^PXBPCPT1
  1.  I $G(NF) G C1
  1.  ;
  1. DEL ;--------If Multiple deleting
  1.  D DELM^PXBPCPT1
  1.  I DATA["^C" G CPTX
  1.  I $G(NF) G C1
  1.  ;
  1.  D MOD
  1.  ;
  1. LI ;--------If picked a line number display 
  1.  ;
  1.  I (DATA>0)&(DATA<(PXBCNT+1))&($L(DATA)'>$L(PXBCNT)) D
  1.  .S XFLAG=1
  1.  .D DISCPT4^PXBDCPT(PXBSAM(DATA,"LINE"))
  1.  .D REVCPT^PXBCC(DATA,1)
  1.  .S SELINE=DATA
  1.  .F I=1:1:$L(DATA) W IOCUB,IOECH
  1.  .S CPTQUA=$P($G(PXBSAM(DATA)),"^",2)
  1.  .S DATA=$P($G(PXBSAM(DATA)),"^",1)
  1.  .;I $G(Q)'>1 W DATA
  1.  I $D(XFLAG),XFLAG=1 S Y=DATA G FIN
  1.  ;
  1.  ;
  1.  ;--------If CPT is already in the file
  1.  I $D(PXBKY(DATA)) D  I +PXEDIT<0 S DATA="^C" G C1
  1.  .D DISCPT4^PXBDCPT(PXBSAM($O(PXBKY(DATA,0)),"LINE"))
  1.  .K Q
  1.  .D TIMES^PXBUTL(DATA)
  1.  .S PXEDIT=$$MULTI(DATA) Q:+PXEDIT<0
  1.  .I Q=1 D
  1.  ..S LINE=$O(PXBKY(DATA,0))
  1.  ..S XFLAG=1
  1.  ..Q:PXEDIT="A"
  1.  ..D REVCPT^PXBCC(LINE,1)
  1.  ..S CPTQUA=$P($G(PXBSAM(LINE)),"^",2)
  1.  ..S SELINE=$O(Q(0))
  1.  .I Q>1,PXEDIT="E" D
  1.  ..N PXPG
  1.  ..S NLINE=0
  1.  ..S PXPG=+$G(^TMP("PXBDCPT",$J,"START"))+10
  1.  ..F  S NLINE=$O(Q(NLINE)) Q:NLINE=""  Q:PXBSAM(NLINE,"LINE")>PXPG  D
  1.  ...D REVCPT^PXBCC(NLINE,1)
  1.  I '$G(Q) K SELINE
  1.  I PXEDIT="E",$D(Q),Q>1 D  G:DATA="^C" C1 G LI
  1.  .D WHICH^PXBPWCH S:DATA["^" DATA="^C"
  1.  I $D(XFLAG),XFLAG=1 S Y=DATA G FIN
  1.  ;
  1.  ;--------Need to do a DIC lookup on data
  1.  I DATA'="??" D  G:DATA="^C" C I DATA="?" G C
  1.  .D:DATA="?" EN1^PXBHLP0("PXB","CPT",1,"",1)
  1.  I DATA="??" D  G:UDATA="^C" C1 G FIN
  1.  .S DOUBLEQQ=1
  1.  .D EN1^PXBHLP0("PXB","CPT","",1,2)
  1.  .I $L(DATA,"^")>1 D
  1.  ..S DATA=+$P(DATA,"^",2)_$S($P(DATA,U,3)]"":"-"_$P(DATA,U,3),1:"")
  1.  ..D MOD
  1.  ..S Y=DATA
  1.  .S:$G(UDATA)="" UDATA="^C"
  1.  .S:UDATA="^C" (DATA,EDATA,Y)=UDATA
  1.  ;
  1.  ;--If a "?" is NOT entered during lookup
  1.  S FROM="CPT",(VAL,Y)=$P($P($$DOUBLE1^PXBGCPT2(FROM),"^",2),"--",1)
  1.  S (X,DATA,EDATA)=VAL,DIC=81,DIC(0)="MZ" D ^DIC
  1.  I Y<1 S DATA="^C" G C1
  1.  ;
  1.  ;--If Y is good and already in file...
  1.  I $D(Y),$D(PXBKY(Y)) W IORC,IOCUU,IOEDEOP,! D
  1.  .D DISCPT4^PXBDCPT($O(PXBKY($P(Y,"^",2),0)))
  1.  .S LINE=$O(PXBKY($P(Y,"^",2),0)) D REVCPT^PXBCC(LINE,1)
  1.  .S CPTQUA=$P($G(PXBSAM(LINE)),"^",2)
  1.  ;
  1.  ;
  1. FIN ;--FINISH CPT
  1.  I $G(SELINE) S $P(REQE,"^",1)=$P($G(PXBSAM(SELINE)),"^",3)
  1.  I $P(REQE,"^",1)="" S $P(REQE,"^",1)="...No Provider Selected..."
  1.  I $L(Y,"^")'>1 S X=Y,DIC=81,DIC(0)="ZM" D ^DIC
  1.  I Y<0 D HELP^PXBUTL0("CPTM") G C
  1.  S OK=$$CPTOK^PXBUTL(+Y,IDATE) D  G:+OK=0 C
  1.  .I +OK=0 W IOCUF,IOCUF,IORVON,"INACTIVE!--",IORVOFF D HELP1^PXBUTL1("CPTI") ;--HELP
  1.  S CPT=Y(0)
  1.  S ^DISV(DUZ,"PXBCPT-1")=$P(CPT,"^",1)
  1.  I $D(PXBNCPT) S PXBNCPTF=1
  1.  I $D(PXBKY(Y(0,0))),$G(SELINE) D
  1.  .S $P(REQI,"^",8)=$O(PXBSKY(SELINE,0))
  1.  .S PREDOC=$P(PXBSAM(SELINE),"^",3)
  1.  .I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
  1.  ..Q:$P(REQI,"^",8)]""
  1.  ..S $P(REQI,"^",8)=$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0))
  1.  .I $D(PXBPRV($P(REQE,"^",1))) D
  1.  ..S CPTQUA=$P(PXBSAM($O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0)),0))),"^",2)
  1.  I $D(PXBKY(Y(0,0))),'$G(SELINE) D
  1.  .;S $P(REQI,"^",8)=$O(PXBSKY($O(PXBKY(Y(0,0),0)),0))
  1.  .S PREDOC=$P(PXBSAM($O(PXBKY(Y(0,0),0))),"^",3)
  1.  .I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
  1.  ..S $P(REQI,"^",8)=$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0))
  1.  .I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
  1.  ..S CPTQUA=$P(PXBSAM($O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0)),0))),"^",2)
  1.  S $P(REQI,"^",3)=+Y
  1.  S $P(REQE,"^",3)=$P(CPT,"^",1)_"-- "_$P(CPT,"^",2)
  1.  S PXBNCPT($P(CPT,"^",1))=$P(REQI,"^",8)
  1.  S:$P(REQI,"^",8)]"" PXBNCPT($P(CPT,"^",1),$P(REQI,"^",8))=""
  1.  ;
  1. CPTX ;--CPT Exit and cleanup
  1.  I $P(REQE,"^",1)="" S $P(REQE,"^",1)="...No Provider Selected..."
  1.  I $G(WHAT)="INTV",DATA="^" S PXBEXIT="^^"
  1.  I $D(PXBRRR) S DATA="^"
  1.  I $D(PREDOC) D
  1.  .I PREDOC]""&($P(REQE,"^",1)'[PREDOC) W !,IOINHI,"--WARNING!",IOINLOW," Currently stored Provider of service:-",IOINHI,PREDOC,IOINLOW D
  1.  ..I '$D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) S $P(REQI,"^",8)=""
  1.  K PXBDPRV,PREDOC
  1.  W IOEDEOP
  1.  Q
  1. MOD ;---Separate CPT modifiers from CPT codes in entry string, if entered
  1.  I DATA?1.N1"-".NE D
  1.  .S PXMODSTR=$P(DATA,"-",2)
  1.  .S (DATA,EDATA)=$P(DATA,"-",1)
  1.  Q
  1.  ;
  1. MULTI(CPTCD) ;--Prompt user to Edit existing CPT code or Add as new entry
  1.  ;
  1.  N DIR,DA,X,Y
  1.  S DIR(0)="SB^E:EDIT;A:ADD"
  1.  S DIR("A")="Do you wish to (E)dit or (A)dd"
  1.  I $D(^IBE(357.69,+CPTCD)) S DIR(0)="SB^E:EDIT",DIR("A")="You may only (E)dit this code, no duplicate E&M allowed."
  1.  S DIR("A",1)="CPT "_CPTCD_" already on file for this Encounter"
  1.  D ^DIR
  1.  I Y']""!(Y="^") Q -1
  1.  Q Y