ACPT23P2 ; CPT V2.03 patch 2 - 7/7/2003 2:05:48 PM [ 09/09/2003 10:03 AM ]
;;2.03;CPT FILES;**2**;DEC 19, 2002
;
; New routine - adds/edits/deletes to CPT file
; for 7/1/2003 released changes from AMA
;
START ; - EP
D ADD
D EDIT
D DELETE
D LINEUP
Q
;
;;code^description
ADD ;add
K DIC
W !,"ADDING CODES"
S DIC="^ICPT("
S DIC(0)="LXO"
S DLAYGO=81
S X=99601
W !,X
D ^DIC ;adds code
;
I +Y>0 D
.S DIE=DIC
.S DA=99601
.S DR="50///Home infusion/specialty drug administration, per visit (up to 2 hours)"
.S DR=$G(DR)_";7///7/1/2003"
.D ^DIE
.;;
.K DIC
.S DIC="^ICPT(99601,60,"
.S DA(1)=99601
.S DIC(0)="L"
.S DIC("P")=$P(^DD(81,60,0),"^",2)
.S (DA,X)=3030701
.S DIC("DR")=".02////1"
.D ^DIC
;
;
K DIC,X,DLAYGO,Y
S DIC="^ICPT("
S DIC(0)="LXO"
S DLAYGO=81
S X=99602
W !,X
D ^DIC
;
I +Y>0 D
.S DIE=DIC
.S DA=99602
.S DR="50///Each additional hour (List separately in addition to primary procedure)"
.S DR=$G(DR)_";7///7/1/2003"
.D ^DIE
.K DIC
.S DIC="^ICPT(99602,60,"
.S DA(1)=99602
.S DIC(0)="L"
.S DIC("P")=$P(^DD(81,60,0),"^",2)
.S (DA,X)=3030701
.S DIC("DR")=".02////1"
.D ^DIC
Q
;
EDIT ;edit
W !,"EDITING CODES"
S DA(1)=$O(^ICPT("B",99050,""))
S DIE="^ICPT("_DA(1)_",""D"","
S DA=1
S DR=".01///Services requested after posted office hours in addition to basic service"
W !,DA(1)
D ^DIE
Q
;
DELETE ;delete
W !,"DELETING CODES"
S DIE="^ICPT("
F ACPTCD=99551,99552,99553,99554,99555,99556,99557,99558,99559,99560,99561,99562,99563,99564,99565,99566,99567,99568,99569 D
. S ACPTCDE=$O(^ICPT("B",ACPTCD,""))
. S DA=ACPTCDE
. W !,DA
. S DR="8///7/1/2003;5////1" ;Date deleted/inactive flag
. D ^DIE
. ;
. S DA(1)=DA
. S DIC="^ICPT("_DA(1)_",60,"
. S DIC(0)="L"
. S DIC("P")=$P(^DD(81,60,0),"^",2)
. S (DA,X)=3030701
. S DIC("DR")=".02///0"
. D ^DIC
Q
LINEUP ; Make sure effective date multiple and active/inactive stuff are the same
S ACPTDA=0
F S ACPTDA=$O(^ICPT(ACPTDA)) Q:ACPTDA="" D
. Q:$L(ACPTDA)'=$L(+ACPTDA) ;only do "good" codes
. K ACPTINA,ACPTDDEL,ACPTEDT,ACPTDA2,DIC,DIE,DA
. S ACPTINA=$P($G(^ICPT(ACPTDA,0)),"^",4) ;inactive flag
. S ACPTDDEL=$P($G(^ICPT(ACPTDA,0)),"^",7) ;date deleted
. S ACPTEDT=$O(^ICPT(ACPTDA,60,"B",9999999),-1) ;most current effective date
. S:ACPTEDT'="" ACPTDA2=$O(^ICPT(ACPTDA,60,"B",ACPTEDT,0))
. S:$G(ACPTDA2)'="" ACPTSTAT=$P($G(^ICPT(ACPTDA,60,ACPTDA2,0)),"^",2),ACPTEDT=$P($G(^ICPT(ACPTDA,60,ACPTDA2,0)),"^") ;status
. I $G(ACPTDDEL)="",$G(ACPTINA)="",$G(ACPTSTAT)=1 D LINEUP2 Q ;no delete date, no inactive flag and status is active
. I ACPTDDEL'="",($E(ACPTDDEL,1,3))'=($E(ACPTEDT,1,3)) D
.. I ACPTDDEL>ACPTEDT D
... S DA(1)=ACPTDA
... S DIC="^ICPT("_DA(1)_",60,"
... S DIC(0)="LIX"
... S DLAYGO=81.02
... S X=ACPTDDEL
... S DIC("DR")=".02///0"
... S DIC("P")=$P(^DD(81,60,0),"^",2)
... D ^DIC
.. I ACPTEDT>ACPTDDEL D
... S DIE="^ICPT("
... S DA=ACPTDA
... S DR="8////"_ACPTEDT
... I ACPTSTAT=0 S DR=DR_";5///1" ;inactive
... I ACPTSTAT=1 S DR=DR_";5///@" ;active
... D ^DIE
.D LINEUP2
Q
; lineup Date Added
LINEUP2 S ACPTADT=$P($G(^ICPT(ACPTDA,0)),"^",6)
Q:ACPTADT'="" ;there's a date, don't do anything
I ACPTADT="" D
. S ACPTEDA=0,ACPTSTAT=""
. F S ACPTEDA=$O(^ICPT(ACPTDA,60,"B",ACPTEDA)) Q:+ACPTEDA=0 D Q:$G(ACCPTEDT)'="" ;most current effective date
.. S ACPTEDA2=$O(^ICPT(ACPTDA,60,"B",ACPTEDA,0))
.. S ACPTSTAT=$P($G(^ICPT(ACPTDA,60,ACPTEDA2,0)),"^",2)
.. I $G(ACPTSTAT)=1 S ACPTEDT=$P($G(^ICPT(ACPTDA,60,ACPTEDA2,0)),"^")
. I $G(ACPTEDT)'="" D
.. S DIE="^ICPT("
.. S DA=ACPTDA
.. S DR="7////"_ACPTEDT
.. D ^DIE
Q
ACPT23P2 ; CPT V2.03 patch 2 - 7/7/2003 2:05:48 PM [ 09/09/2003 10:03 AM ]
+1 ;;2.03;CPT FILES;**2**;DEC 19, 2002
+2 ;
+3 ; New routine - adds/edits/deletes to CPT file
+4 ; for 7/1/2003 released changes from AMA
+5 ;
START ; - EP
+1 DO ADD
+2 DO EDIT
+3 DO DELETE
+4 DO LINEUP
+5 QUIT
+6 ;
+7 ;;code^description
ADD ;add
+1 KILL DIC
+2 WRITE !,"ADDING CODES"
+3 SET DIC="^ICPT("
+4 SET DIC(0)="LXO"
+5 SET DLAYGO=81
+6 SET X=99601
+7 WRITE !,X
+8 ;adds code
DO ^DIC
+9 ;
+10 IF +Y>0
Begin DoDot:1
+11 SET DIE=DIC
+12 SET DA=99601
+13 SET DR="50///Home infusion/specialty drug administration, per visit (up to 2 hours)"
+14 SET DR=$GET(DR)_";7///7/1/2003"
+15 DO ^DIE
+16 ;;
+17 KILL DIC
+18 SET DIC="^ICPT(99601,60,"
+19 SET DA(1)=99601
+20 SET DIC(0)="L"
+21 SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+22 SET (DA,X)=3030701
+23 SET DIC("DR")=".02////1"
+24 DO ^DIC
End DoDot:1
+25 ;
+26 ;
+27 KILL DIC,X,DLAYGO,Y
+28 SET DIC="^ICPT("
+29 SET DIC(0)="LXO"
+30 SET DLAYGO=81
+31 SET X=99602
+32 WRITE !,X
+33 DO ^DIC
+34 ;
+35 IF +Y>0
Begin DoDot:1
+36 SET DIE=DIC
+37 SET DA=99602
+38 SET DR="50///Each additional hour (List separately in addition to primary procedure)"
+39 SET DR=$GET(DR)_";7///7/1/2003"
+40 DO ^DIE
+41 KILL DIC
+42 SET DIC="^ICPT(99602,60,"
+43 SET DA(1)=99602
+44 SET DIC(0)="L"
+45 SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+46 SET (DA,X)=3030701
+47 SET DIC("DR")=".02////1"
+48 DO ^DIC
End DoDot:1
+49 QUIT
+50 ;
EDIT ;edit
+1 WRITE !,"EDITING CODES"
+2 SET DA(1)=$ORDER(^ICPT("B",99050,""))
+3 SET DIE="^ICPT("_DA(1)_",""D"","
+4 SET DA=1
+5 SET DR=".01///Services requested after posted office hours in addition to basic service"
+6 WRITE !,DA(1)
+7 DO ^DIE
+8 QUIT
+9 ;
DELETE ;delete
+1 WRITE !,"DELETING CODES"
+2 SET DIE="^ICPT("
+3 FOR ACPTCD=99551,99552,99553,99554,99555,99556,99557,99558,99559,99560,99561,99562,99563,99564,99565,99566,99567,99568,99569
Begin DoDot:1
+4 SET ACPTCDE=$ORDER(^ICPT("B",ACPTCD,""))
+5 SET DA=ACPTCDE
+6 WRITE !,DA
+7 ;Date deleted/inactive flag
SET DR="8///7/1/2003;5////1"
+8 DO ^DIE
+9 ;
+10 SET DA(1)=DA
+11 SET DIC="^ICPT("_DA(1)_",60,"
+12 SET DIC(0)="L"
+13 SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+14 SET (DA,X)=3030701
+15 SET DIC("DR")=".02///0"
+16 DO ^DIC
End DoDot:1
+17 QUIT
LINEUP ; Make sure effective date multiple and active/inactive stuff are the same
+1 SET ACPTDA=0
+2 FOR
SET ACPTDA=$ORDER(^ICPT(ACPTDA))
IF ACPTDA=""
QUIT
Begin DoDot:1
+3 ;only do "good" codes
IF $LENGTH(ACPTDA)'=$LENGTH(+ACPTDA)
QUIT
+4 KILL ACPTINA,ACPTDDEL,ACPTEDT,ACPTDA2,DIC,DIE,DA
+5 ;inactive flag
SET ACPTINA=$PIECE($GET(^ICPT(ACPTDA,0)),"^",4)
+6 ;date deleted
SET ACPTDDEL=$PIECE($GET(^ICPT(ACPTDA,0)),"^",7)
+7 ;most current effective date
SET ACPTEDT=$ORDER(^ICPT(ACPTDA,60,"B",9999999),-1)
+8 IF ACPTEDT'=""
SET ACPTDA2=$ORDER(^ICPT(ACPTDA,60,"B",ACPTEDT,0))
+9 ;status
IF $GET(ACPTDA2)'=""
SET ACPTSTAT=$PIECE($GET(^ICPT(ACPTDA,60,ACPTDA2,0)),"^",2)
SET ACPTEDT=$PIECE($GET(^ICPT(ACPTDA,60,ACPTDA2,0)),"^")
+10 ;no delete date, no inactive flag and status is active
IF $GET(ACPTDDEL)=""
IF $GET(ACPTINA)=""
IF $GET(ACPTSTAT)=1
DO LINEUP2
QUIT
+11 IF ACPTDDEL'=""
IF ($EXTRACT(ACPTDDEL,1,3))'=($EXTRACT(ACPTEDT,1,3))
Begin DoDot:2
+12 IF ACPTDDEL>ACPTEDT
Begin DoDot:3
+13 SET DA(1)=ACPTDA
+14 SET DIC="^ICPT("_DA(1)_",60,"
+15 SET DIC(0)="LIX"
+16 SET DLAYGO=81.02
+17 SET X=ACPTDDEL
+18 SET DIC("DR")=".02///0"
+19 SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+20 DO ^DIC
End DoDot:3
+21 IF ACPTEDT>ACPTDDEL
Begin DoDot:3
+22 SET DIE="^ICPT("
+23 SET DA=ACPTDA
+24 SET DR="8////"_ACPTEDT
+25 ;inactive
IF ACPTSTAT=0
SET DR=DR_";5///1"
+26 ;active
IF ACPTSTAT=1
SET DR=DR_";5///@"
+27 DO ^DIE
End DoDot:3
End DoDot:2
+28 DO LINEUP2
End DoDot:1
+29 QUIT
+30 ; lineup Date Added
LINEUP2 SET ACPTADT=$PIECE($GET(^ICPT(ACPTDA,0)),"^",6)
+1 ;there's a date, don't do anything
IF ACPTADT'=""
QUIT
+2 IF ACPTADT=""
Begin DoDot:1
+3 SET ACPTEDA=0
SET ACPTSTAT=""
+4 ;most current effective date
FOR
SET ACPTEDA=$ORDER(^ICPT(ACPTDA,60,"B",ACPTEDA))
IF +ACPTEDA=0
QUIT
Begin DoDot:2
+5 SET ACPTEDA2=$ORDER(^ICPT(ACPTDA,60,"B",ACPTEDA,0))
+6 SET ACPTSTAT=$PIECE($GET(^ICPT(ACPTDA,60,ACPTEDA2,0)),"^",2)
+7 IF $GET(ACPTSTAT)=1
SET ACPTEDT=$PIECE($GET(^ICPT(ACPTDA,60,ACPTEDA2,0)),"^")
End DoDot:2
IF $GET(ACCPTEDT)'=""
QUIT
+8 IF $GET(ACPTEDT)'=""
Begin DoDot:2
+9 SET DIE="^ICPT("
+10 SET DA=ACPTDA
+11 SET DR="7////"_ACPTEDT
+12 DO ^DIE
End DoDot:2
End DoDot:1
+13 QUIT
