ACPTPOST ; IHS/ASDST/DMJ,SDR - CPT POST INIT ; [ 02/03/2004 11:05 AM ]
;;2.08;CPT FILES;;DEC 17, 2007
;
;
START ;START HERE
I '$G(DT) D NOW^%DTC S DT=X
S ACPTYR=3080000
W $$EN^ACPTVDF("IOF")
W !!,"CPT Version 2.08 Install",!
D MSG
K DIR S DIR(0)="E" D ^DIR K DIR Q:Y'=1
D DIR
S I=99,ACPTTO=99999 D INA
S I=4848484969,ACPTTO=5248494971 D INA
;S I=9990002,ACPTTO=9990003 D INA ;inactivate erroneous code 0003T
;S I=9990007,ACPTTO=9990008 D INA ;inactivate erroneous code 0008T
;S I=9990017,ACPTTO=9990018 D INA ;inactivate erroneous code 0018T
;S I=9990020,ACPTTO=9990021 D INA ;inactivate erroneous code 0021T
;S I=9990043,ACPTTO=9990044 D INA ;inactivate erroneous code 0044T
D SREAD ;short desc.
D LREAD ;long desc.
;S I=99999,ACPTTO=999999 D INA ;HCPCS inactivation
;D HREAD ;hcpcs
D MREAD ;mod
D MOD^ACPTPST2 ;hcpc mod
;D GROUPS ;loads current group/ASC codes
D XREF
D XREFM
;D FIXCPT^ACPTPST2 ;acpt*2.06*1
;
D:'$D(^XT(8984.4,81,0)) ADD81
I ACPTYR>DT D QUE
I ACPTYR<DT D
.W !!,"Will now activate new codes, de-activate deleted codes.",!
.D ^ACPTSINF
D UPKG
W !!,"INSTALL COMPLETE",!!
S DIR(0)="E" D ^DIR
K DIR,ACPT,ACPTYR
Q
INA ;set date deleted for all codes
W !!,"Updating Year Deleted Field.",!
F S I=$O(^ICPT(I)) Q:I>ACPTTO!('I) D
.Q:$P($G(^ICPT(I,0)),"^",7)
.S $P(^ICPT(I,0),"^",7)=ACPTYR
.D DOTS(I)
K ACPTTO
Q
DOTS(X) ;EP - WRITE OUT A DOT EVERY HUNDRED
U IO(0)
W:'(X#100) "."
Q
SREAD ;READ AND UPDATE SHORT DESC.
S ACPTFL="acpt2008.s"
W !!,"Reading SHORT description file, file name ",ACPTFL,!
D OPEN^%ZISH("CPTSFILE",ACPTPTH,ACPTFL,"R")
I POP U IO(0) W !,"Could not open short description file." Q
F ACPTCNT=1:1 D Q:$$STATUS^%ZISH
.U IO R X Q:$$STATUS^%ZISH
.S ACPTCD=$P(X," ",1)
.I ACPTCD?4N1"T"!(ACPTCD?4N1"F") D CAT2S Q
.Q:ACPTCD'?5N
.S A=$P(X," ",2,999) D DESC
.I '$D(^ICPT(+ACPTCD)) D
..S ^ICPT(+ACPTCD,0)=ACPTCD
..S $P(^ICPT(+ACPTCD,0),"^",6)=ACPTYR
..S:ACPTYR>DT $P(^ICPT(+ACPTCD,0),"^",4)=1
..K DIC
..S DA(1)=ACPTCD
..S DIC="^ICPT("_DA(1)_",60,"
..S DIC(0)="L"
..S DIC("P")=$P(^DD(81,60,0),"^",2)
..S X="01/01/2008"
..S DIC("DR")=".02////1"
..D ^DIC
.S $P(^ICPT(+ACPTCD,0),"^",2)=ACPTDESC
.S:$P(^ICPT(+ACPTCD,0),"^",6)<DT $P(^ICPT(+ACPTCD,0),"^",4)=""
.S $P(^ICPT(+ACPTCD,0),"^",7)=""
.D CAT(ACPTCD)
.D DOTS(ACPTCNT)
D ^%ZISC
Q
;
LREAD ;READ AND UPDATE LONG DESC.
S ACPTFL="acpt2008.l"
W !!,"Reading LONG description file, file name ",ACPTFL,!
D OPEN^%ZISH("CPTLFILE",ACPTPTH,ACPTFL,"R")
I POP U IO(0) W !,"Could not open long description file." Q
F ACPTCNT=1:1 D Q:$$STATUS^%ZISH
.U IO R X Q:$$STATUS^%ZISH
.S ACPTCD=$E(X,1,5)
.I ACPTCD?4N1"T"!(ACPTCD?4N1"F") D CAT2L Q
.Q:ACPTCD'?5N
.S ACPTLN=$E(X,6,7)
.S A=$P(X," ",2,999) D DESC
.I '$D(^ICPT(+ACPTCD)) D
..S ^ICPT(+ACPTCD,0)=ACPTCD
..S $P(^ICPT(+ACPTCD,0),"^",6)=ACPTYR
..S:ACPTYR>DT $P(^ICPT(+ACPTCD,0),"^",4)=1
..K DIC
..S DA(1)=ACPTCD
..S DIC="^ICPT("_DA(1)_",60,"
..S DIC(0)="L"
..S DIC("P")=$P(^DD(81,60,0),"^",2)
..S X="01/01/2008"
..S DIC("DR")=".02////1"
..D ^DIC
.I +ACPTLN=1 D
..K ^ICPT(+ACPTCD,"D")
..S ^ICPT(+ACPTCD,"D",0)="^81.01A^^"
.S ^ICPT(+ACPTCD,"D",+ACPTLN,0)=ACPTDESC
.S $P(^ICPT(+ACPTCD,"D",0),"^",3,4)=+ACPTLN_"^"_+ACPTLN
.D DOTS(ACPTCNT)
D ^%ZISC
Q
;
HREAD ;READ HCPCS FILE
K ACPTCD,ACPTFLAG,ACPTIEN,ACPTDESC
S ACPTCSV=""
W !,"Installing ",$E(ACPTYR,1,3)+1700," HCPCS codes.",!
;S ACPTFL="acpt2006.h" ;acpt*2.07*1
S ACPTFL="acpt2007.01h" ;acpt*2.07*1
D OPEN^%ZISH("CPTHFILE",ACPTPTH,ACPTFL,"R")
I POP U IO(0) W !,"Could not open HCPCS file." Q
U IO(0) W !,"Reading HCPCS Codes File.",!
F ACPTCNT=1:1 D Q:$$STATUS^%ZISH
.U IO R X Q:$$STATUS^%ZISH
.S ACPTCD=$E(X,1,5)
.I ACPTCD=ACPTCSV S ACPTFLAG=1
.Q:ACPTCD'?1U4N
.;S ACPTLNE=$E(X,6,10) ;acpt*2.07*1
.;S ACPTACDE=$E(X,293) ;action code ;acpt*2.07*1
.S ACPTACDE=$E(X,6) ;action code ;acpt*2.07*1
.Q:ACPTACDE="" ;no action code
.;Q:ACPTACDE="N" ;no change to code ;acpt*2.07*1
.;Q:ACPTACDE="P" ;payment change-not stored ;acpt*2.07*1
.;I ACPTACDE="D" D Q ;delete code and quit ;acpt*2.07*1
.;.S ACPTIEN=$A($E(ACPTCD))_$E(ACPTCD,2,5) ;acpt*2.07*1
.;.I $G(^ICPT(ACPTIEN,0))="" S ACPTIEN=$O(^ICPT("B",ACPTCD,0)) ;acpt*2.07*1
.;.Q:+ACPTIEN=0 ;acpt*2.07*1
.;.Q:$P($G(^ICPT(ACPTIEN,0)),"^",7) ;acpt*2.07*1
.;.S $P(^ICPT(ACPTIEN,0),"^",7)=ACPTYR ;acpt*2.07*1
.;S A=$E(X,7,40) D DESC S ACPTSD=ACPTDESC ;acpt*2.06*1
.;S A=$E(X,42,299) D DESC S ACPTLD=ACPTDESC ;acpt*2.06*1
.;S A=$E(X,92,119) D DESC S ACPTSD=ACPTDESC ;acpt*2.06*1 ;acpt*2.07*1
.S A=$E(X,7,41) D DESC S ACPTSD=ACPTDESC ;acpt*2.07*1
.;S A=$E(X,12,91) D DESC S ACPTLD=ACPTDESC ;acpt*2.06*1 ;acpt*2.07*1
.S A=$E(X,42,975) D DESC S ACPTLD=ACPTDESC ;acpt*2.07*1
.;if no entry in CPT file
.I '$D(^ICPT("B",ACPTCD)) D
..S ACPTIEN=$A($E(ACPTCD))_$E(ACPTCD,2,5)
..S ^ICPT(ACPTIEN,0)=ACPTCD
..S ^ICPT("B",ACPTCD,ACPTIEN)=""
..S $P(^ICPT(ACPTIEN,0),"^",6)=ACPTYR
..S:ACPTYR>DT $P(^ICPT(ACPTIEN,0),"^",4)=1
..K DIC
..S DA(1)=ACPTIEN
..S DIC="^ICPT("_DA(1)_",60,"
..S DIC(0)="L"
..S DIC("P")=$P(^DD(81,60,0),"^",2)
..S X="01/01/2007"
..S DIC("DR")=".02////1"
..D ^DIC
.;get IEN and edit existing entry
.S ACPTIEN=$O(^ICPT("B",ACPTCD,0))
.Q:ACPTIEN'>0
.;start old code acpt*2.07*1
.;I +ACPTLNE=100 D
.;.K ^ICPT(ACPTIEN,"D")
.;.S ^ICPT(ACPTIEN,"D",0)="^81.01A^^"
.;S ACPTLN=$E(ACPTLNE,3)
.;S ^ICPT(ACPTIEN,"D",+ACPTLN,0)=ACPTLD
.;S $P(^ICPT(ACPTIEN,"D",0),"^",3,4)=+ACPTLN_"^"_+ACPTLN
.;end old code acpt*2.07*1
.;start new code acpt*2.07*1
.S ^ICPT(ACPTIEN,"D",1,0)=ACPTLD
.S $P(^ICPT(ACPTIEN,"D",0),"^",3,4)=1_"^"_1
.;end new code acpt*2.07*1
.S:ACPTSD'="" $P(^ICPT(ACPTIEN,0),"^",2)=ACPTSD
.S $P(^ICPT(ACPTIEN,0),"^",7)=""
.;start new code acpt*2.07*1
.S ACPTEDT=$O(^ICPT(ACPTIEN,60,"B",9999999),-1)
.I ACPTEDT'="" D
..S ACPTEIEN=$O(^ICPT(ACPTIEN,60,"B",ACPTEDT,0))
..I $P($G(^ICPT(ACPTIEN,60,ACPTEIEN,0)),U,2)'=1 D ;1=ACTIVE
...K DIC
...S DA(1)=ACPTIEN
...S DIC="^ICPT("_DA(1)_",60,"
...S DIC(0)="L"
...S DIC("P")=$P(^DD(81,60,0),"^",2)
...S X="01/01/2007"
...S DIC("DR")=".02////1"
...D ^DIC
.;end new code acpt*2.07*1
.D DOTS(ACPTCNT)
.S ACPTCSV=ACPTCD,ACPTFLAG=""
D ^%ZISC
K ACPTSD,ACPTLD
K ACPTCSV,ACPTFLAG
K ACPTLNE
Q
;
MREAD ;READ AND UPDATE MODIFIERS AND P-CODES
S ACPTFL="acpt2008.m"
W !!,"Reading MODIFIER file, file name ",ACPTFL,!
D OPEN^%ZISH("CPTSFILE",ACPTPTH,ACPTFL,"R")
I POP U IO(0) W !,"Could not open modifier and p-code file." Q
F ACPTCNT=1:1 D Q:$$STATUS^%ZISH
.U IO R X Q:$$STATUS^%ZISH
.S ACPTCD=$E(X,1,2)
.S DESC=$E($P(X,": ",1),4,$L(X))
.S ACPTCDN=$S(ACPTCD=+ACPTCD:ACPTCD,1:$A($E(ACPTCD,1))_$A($E(ACPTCD,2)))
.I '$D(^AUTTCMOD(ACPTCDN)) D
..S ^AUTTCMOD(ACPTCDN,0)=ACPTCD
.S $P(^AUTTCMOD(ACPTCDN,0),"^",2)=DESC
.D DOTS(ACPTCNT)
D ^%ZISC
Q
;
GROUPS ;
S ACPTFL="acpt2006.d"
W !!,"Reading Group file, file name ",ACPTFL,!
D OPEN^%ZISH("CPTSFILE",ACPTPTH,ACPTFL,"R")
I POP U IO(0) W !,"Could not open group file." Q
F ACPTCNT=1:1 D Q:$$STATUS^%ZISH
.U IO R X Q:$$STATUS^%ZISH
.S ACPTCD=$P(X,",")
.Q:ACPTCD=""
.S ACPTDA=$O(^ICPT("B",ACPTCD,""))
.Q:ACPTDA=""
.S ACPTGRP=$P(X,",",2)
.S DR="6///"_ACPTGRP
.S DIE="^ICPT("
.S DA=ACPTDA
.D ^DIE
.D DOTS(ACPTCNT)
D ^%ZISC
Q
DIR ;ASK DIRECTORY WHERE FILES WERE LOADED
W !
S DIR(0)="F",DIR("A")="Enter directory where CPT files are located."
S DIR("B")="/usr/spool/uucppublic/"
D ^DIR K DIR
Q:$D(DUOUT)!$D(DTOUT)!$D(DIRUT)
I ^%ZOSF("OS")["UNIX" D
.S Y=$TR(Y,"\","/")
.S:$E(Y)'="/" Y="/"_Y
.S:$E(Y,$L(Y))'="/" Y=Y_"/"
I ^%ZOSF("OS")'["UNIX" D
.S Y=$TR(Y,"/","\")
.I $E(Y)'="\",Y'[":" S Y="\"_Y
.S:$E(Y,$L(Y))'="\" Y=Y_"\"
S ACPTPTH=Y
Q
FILE ;ASK FOR FILE NAME
W !
S DIR(0)="F"
D ^DIR K DIR
S Y=$TR(Y,"/\")
S ACPTFL=Y
Q
DESC ;STRIP TRAILING BLANKS FROM DESCRIPTION FIELD
S ACPTDESC=""
N I F I=0:1:31 S A=$TR(A,$C(I))
N I F I=1:1:$L(A," ") D
.S ACPTWORD=$P(A," ",I)
.Q:ACPTWORD=""
.S:I>1 ACPTDESC=ACPTDESC_" "
.S ACPTDESC=ACPTDESC_ACPTWORD
K ACPTWORD
S ACPTDESC=$$UPC^ACPTPST2(ACPTDESC)
Q
CAT(Z) ;SET CPT CATEGORY
S ACPTCAT=Z
I '$D(^DIC(81.1,"ACPT",Z)) D
.S ACPTCAT=$O(^DIC(81.1,"ACPT",ACPTCAT),-1)
S ACPTCAT=$O(^DIC(81.1,"ACPT",ACPTCAT,0))
S $P(^ICPT(Z,0),"^",3)=ACPTCAT
K ACPTCAT
Q
ADD81 ;ADD FILE 81 TO LOCAL LOOKUP FILE
S DLAYGO=8984.4
W !!,"ADDING CPT FILE TO LOCAL LOOKUP FILE" D
.I '$D(^DIC(8984.4)) W !,"LOCAL LOOKUP FILE (FILE 8984.4) MISSING.",! Q
.S DIC="^XT(8984.4,",DIC(0)="LX",X=81 D ^DIC
.Q:Y<0 S DA=+Y,DIE=DIC,DR=".03////C" D ^DIE
.W !,"FILE 81 ADDED.",!
K DLAYGO
Q
XREF ;RE-CROSS REFERENCE FILE
W !,"WILL NOW RE-INDEX CPT FILE (this will take awhile).",!
S DIK="^ICPT(" D IXALL^DIK
D ^ACPTCXR
Q
XREFM ;RE-CROSS REFERENCE FILE
W !,"WILL NOW RE-INDEX MODIFIER FILE.",!
S DIK="^AUTTCMOD(" D IXALL^DIK
Q
QUE ;QUE JOB TO ACTIVATE/INACTIVATE CODES
S ZTRTN="^ACPTSINF"
S ZTIO=""
S ZTDESC="Activate/inactivate CPT codes."
S ZTDTH="60996,21600"
S ACPTRDT=$$HTFM^XLFDT(ZTDTH)
S ACPTRDT=$$FMTE^XLFDT(ACPTRDT,1)
D ^%ZTLOAD
I $G(ZTSK) D
.W !,"I've taken the liberty to queue task # ",ZTSK," to run on ",ACPTRDT
.W !,"This routine will inactivate deleted codes and activate new codes."
.W !,"If this date and time is inconvenient, you may use the Taskman re-schedule"
.W !,"option to run at a more suitable time."
I '$G(ZTSK) D
.W !,"Attempt to queue routine ACPTSINF was unsuccessful. This routine will"
.W !,"need to be run to activate new codes and de-activate old codes."
.W !,"and should be run January or February ",ACPTCV,"."
K ACPTRDT,ACPTCV
Q
MSG ;display message
F I=1:1 D Q:ACPTTXT["***end***"
.S ACPTTXT=$P($T(TXT+I),";;",2)
.Q:ACPTTXT["end"
.I ACPTTXT="NOTE:" W $$EN^ACPTVDF("RVN")
.W !,ACPTTXT
.I ACPTTXT="NOTE:" W $$EN^ACPTVDF("RVF")
K ACPTTXT
Q
TXT ;text lines
;;CPT version 2.08 contains CPT codes and Modifiers for 2008.
;;The install will attempt to read the short description file
;;(acpt2008.s), the long description file (acpt2008.l), the
;;HCPCS Modifiers file (acpt2008.c), and the Modifiers file
;;(acpt2008.m) from the directory you specify.
;;
;;***end***
Q
CAT2S ;
S A=$P(X," ",2,999) D DESC
S ACPTCDN=""
F ACPTCDC=1:1:5 S ACPTCDN=ACPTCDN_$A($E(ACPTCD,ACPTCDC))
I '$D(^ICPT(+ACPTCDN)) D
.S ^ICPT(+ACPTCDN,0)=ACPTCD
.S $P(^ICPT(+ACPTCDN,0),"^",6)=ACPTYR
.S:ACPTYR>DT $P(^ICPT(+ACPTCDN,0),"^",4)=1
.K DIC
.S DA(1)=+ACPTCDN
.S DIC="^ICPT("_DA(1)_",60,"
.S DIC(0)="L"
.S DIC("P")=$P(^DD(81,60,0),"^",2)
.S X="01/01/2008"
.S DIC("DR")=".02////1"
.D ^DIC
S $P(^ICPT(+ACPTCDN,0),"^",2)=ACPTDESC
S:$P(^ICPT(+ACPTCDN,0),"^",6)<DT $P(^ICPT(+ACPTCDN,0),"^",4)=""
S $P(^ICPT(+ACPTCDN,0),"^",7)=""
D CAT(ACPTCDN)
Q
CAT2L ;
S ACPTLN=$E(X,6,7)
S ACPTCDN=""
F ACPTCDC=1:1:5 S ACPTCDN=ACPTCDN_$A($E(ACPTCD,ACPTCDC))
S A=$P(X," ",2,999) D DESC
I '$D(^ICPT(+ACPTCDN)) D
.S ^ICPT(+ACPTCDN,0)=ACPTCD
.S $P(^ICPT(+ACPTCDN,0),"^",6)=ACPTYR
.S:ACPTYR>DT $P(^ICPT(+ACPTCDN,0),"^",4)=1
.K DIC
.S DA(1)=+ACPTCDN
.S DIC="^ICPT("_DA(1)_",60,"
.S DIC(0)="L"
.S DIC("P")=$P(^DD(81,60,0),"^",2)
.S X="01/01/2008"
.S DIC("DR")=".02////1"
.D ^DIC
I +ACPTLN=1 D
.K ^ICPT(+ACPTCDN,"D")
.S ^ICPT(+ACPTCDN,"D",0)="^81.01A^^"
S ^ICPT(+ACPTCDN,"D",+ACPTLN,0)=ACPTDESC
S $P(^ICPT(+ACPTCDN,"D",0),"^",3,4)=+ACPTLN_"^"_+ACPTLN
D DOTS(ACPTCNT)
Q
UPKG ;update package file
I '$G(DUZ) D
.S DUZ=1
.S DUZ(0)="@"
I '$G(DT) D
.D NOW^%DTC
.S DT=$P(%,".",1)
S DA=$O(^DIC(9.4,"C","ACPT",0))
Q:'DA
S DIE="^DIC(9.4,"
S DR="13///2.08" ;current version
D ^DIE
S DA(1)=DA
S X=2.04
S DIC="^DIC(9.4,DA(1),22,"
S DIC(0)="LX"
D ^DIC
Q:+Y<0
S DA=+Y
S DIE=DIC
S DR="1///3071231;2///"_DT_";3///`"_DUZ
D ^DIE
Q
ACPTPOST ; IHS/ASDST/DMJ,SDR - CPT POST INIT ; [ 02/03/2004 11:05 AM ]
+1 ;;2.08;CPT FILES;;DEC 17, 2007
+2 ;
+3 ;
START ;START HERE
+1 IF '$GET(DT)
DO NOW^%DTC
SET DT=X
+2 SET ACPTYR=3080000
+3 WRITE $$EN^ACPTVDF("IOF")
+4 WRITE !!,"CPT Version 2.08 Install",!
+5 DO MSG
+6 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF Y'=1
QUIT
+7 DO DIR
+8 SET I=99
SET ACPTTO=99999
DO INA
+9 SET I=4848484969
SET ACPTTO=5248494971
DO INA
+10 ;S I=9990002,ACPTTO=9990003 D INA ;inactivate erroneous code 0003T
+11 ;S I=9990007,ACPTTO=9990008 D INA ;inactivate erroneous code 0008T
+12 ;S I=9990017,ACPTTO=9990018 D INA ;inactivate erroneous code 0018T
+13 ;S I=9990020,ACPTTO=9990021 D INA ;inactivate erroneous code 0021T
+14 ;S I=9990043,ACPTTO=9990044 D INA ;inactivate erroneous code 0044T
+15 ;short desc.
DO SREAD
+16 ;long desc.
DO LREAD
+17 ;S I=99999,ACPTTO=999999 D INA ;HCPCS inactivation
+18 ;D HREAD ;hcpcs
+19 ;mod
DO MREAD
+20 ;hcpc mod
DO MOD^ACPTPST2
+21 ;D GROUPS ;loads current group/ASC codes
+22 DO XREF
+23 DO XREFM
+24 ;D FIXCPT^ACPTPST2 ;acpt*2.06*1
+25 ;
+26 IF '$DATA(^XT(8984.4,81,0))
DO ADD81
+27 IF ACPTYR>DT
DO QUE
+28 IF ACPTYR<DT
Begin DoDot:1
+29 WRITE !!,"Will now activate new codes, de-activate deleted codes.",!
+30 DO ^ACPTSINF
End DoDot:1
+31 DO UPKG
+32 WRITE !!,"INSTALL COMPLETE",!!
+33 SET DIR(0)="E"
DO ^DIR
+34 KILL DIR,ACPT,ACPTYR
+35 QUIT
INA ;set date deleted for all codes
+1 WRITE !!,"Updating Year Deleted Field.",!
+2 FOR
SET I=$ORDER(^ICPT(I))
IF I>ACPTTO!('I)
QUIT
Begin DoDot:1
+3 IF $PIECE($GET(^ICPT(I,0)),"^",7)
QUIT
+4 SET $PIECE(^ICPT(I,0),"^",7)=ACPTYR
+5 DO DOTS(I)
End DoDot:1
+6 KILL ACPTTO
+7 QUIT
DOTS(X) ;EP - WRITE OUT A DOT EVERY HUNDRED
+1 USE IO(0)
+2 IF '(X#100)
WRITE "."
+3 QUIT
SREAD ;READ AND UPDATE SHORT DESC.
+1 SET ACPTFL="acpt2008.s"
+2 WRITE !!,"Reading SHORT description file, file name ",ACPTFL,!
+3 DO OPEN^%ZISH("CPTSFILE",ACPTPTH,ACPTFL,"R")
+4 IF POP
USE IO(0)
WRITE !,"Could not open short description file."
QUIT
+5 FOR ACPTCNT=1:1
Begin DoDot:1
+6 USE IO
READ X
IF $$STATUS^%ZISH
QUIT
+7 SET ACPTCD=$PIECE(X," ",1)
+8 IF ACPTCD?4N1"T"!(ACPTCD?4N1"F")
DO CAT2S
QUIT
+9 IF ACPTCD'?5N
QUIT
+10 SET A=$PIECE(X," ",2,999)
DO DESC
+11 IF '$DATA(^ICPT(+ACPTCD))
Begin DoDot:2
+12 SET ^ICPT(+ACPTCD,0)=ACPTCD
+13 SET $PIECE(^ICPT(+ACPTCD,0),"^",6)=ACPTYR
+14 IF ACPTYR>DT
SET $PIECE(^ICPT(+ACPTCD,0),"^",4)=1
+15 KILL DIC
+16 SET DA(1)=ACPTCD
+17 SET DIC="^ICPT("_DA(1)_",60,"
+18 SET DIC(0)="L"
+19 SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+20 SET X="01/01/2008"
+21 SET DIC("DR")=".02////1"
+22 DO ^DIC
End DoDot:2
+23 SET $PIECE(^ICPT(+ACPTCD,0),"^",2)=ACPTDESC
+24 IF $PIECE(^ICPT(+ACPTCD,0),"^",6)<DT
SET $PIECE(^ICPT(+ACPTCD,0),"^",4)=""
+25 SET $PIECE(^ICPT(+ACPTCD,0),"^",7)=""
+26 DO CAT(ACPTCD)
+27 DO DOTS(ACPTCNT)
End DoDot:1
IF $$STATUS^%ZISH
QUIT
+28 DO ^%ZISC
+29 QUIT
+30 ;
LREAD ;READ AND UPDATE LONG DESC.
+1 SET ACPTFL="acpt2008.l"
+2 WRITE !!,"Reading LONG description file, file name ",ACPTFL,!
+3 DO OPEN^%ZISH("CPTLFILE",ACPTPTH,ACPTFL,"R")
+4 IF POP
USE IO(0)
WRITE !,"Could not open long description file."
QUIT
+5 FOR ACPTCNT=1:1
Begin DoDot:1
+6 USE IO
READ X
IF $$STATUS^%ZISH
QUIT
+7 SET ACPTCD=$EXTRACT(X,1,5)
+8 IF ACPTCD?4N1"T"!(ACPTCD?4N1"F")
DO CAT2L
QUIT
+9 IF ACPTCD'?5N
QUIT
+10 SET ACPTLN=$EXTRACT(X,6,7)
+11 SET A=$PIECE(X," ",2,999)
DO DESC
+12 IF '$DATA(^ICPT(+ACPTCD))
Begin DoDot:2
+13 SET ^ICPT(+ACPTCD,0)=ACPTCD
+14 SET $PIECE(^ICPT(+ACPTCD,0),"^",6)=ACPTYR
+15 IF ACPTYR>DT
SET $PIECE(^ICPT(+ACPTCD,0),"^",4)=1
+16 KILL DIC
+17 SET DA(1)=ACPTCD
+18 SET DIC="^ICPT("_DA(1)_",60,"
+19 SET DIC(0)="L"
+20 SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+21 SET X="01/01/2008"
+22 SET DIC("DR")=".02////1"
+23 DO ^DIC
End DoDot:2
+24 IF +ACPTLN=1
Begin DoDot:2
+25 KILL ^ICPT(+ACPTCD,"D")
+26 SET ^ICPT(+ACPTCD,"D",0)="^81.01A^^"
End DoDot:2
+27 SET ^ICPT(+ACPTCD,"D",+ACPTLN,0)=ACPTDESC
+28 SET $PIECE(^ICPT(+ACPTCD,"D",0),"^",3,4)=+ACPTLN_"^"_+ACPTLN
+29 DO DOTS(ACPTCNT)
End DoDot:1
IF $$STATUS^%ZISH
QUIT
+30 DO ^%ZISC
+31 QUIT
+32 ;
HREAD ;READ HCPCS FILE
+1 KILL ACPTCD,ACPTFLAG,ACPTIEN,ACPTDESC
+2 SET ACPTCSV=""
+3 WRITE !,"Installing ",$EXTRACT(ACPTYR,1,3)+1700," HCPCS codes.",!
+4 ;S ACPTFL="acpt2006.h" ;acpt*2.07*1
+5 ;acpt*2.07*1
SET ACPTFL="acpt2007.01h"
+6 DO OPEN^%ZISH("CPTHFILE",ACPTPTH,ACPTFL,"R")
+7 IF POP
USE IO(0)
WRITE !,"Could not open HCPCS file."
QUIT
+8 USE IO(0)
WRITE !,"Reading HCPCS Codes File.",!
+9 FOR ACPTCNT=1:1
Begin DoDot:1
+10 USE IO
READ X
IF $$STATUS^%ZISH
QUIT
+11 SET ACPTCD=$EXTRACT(X,1,5)
+12 IF ACPTCD=ACPTCSV
SET ACPTFLAG=1
+13 IF ACPTCD'?1U4N
QUIT
+14 ;S ACPTLNE=$E(X,6,10) ;acpt*2.07*1
+15 ;S ACPTACDE=$E(X,293) ;action code ;acpt*2.07*1
+16 ;action code ;acpt*2.07*1
SET ACPTACDE=$EXTRACT(X,6)
+17 ;no action code
IF ACPTACDE=""
QUIT
+18 ;Q:ACPTACDE="N" ;no change to code ;acpt*2.07*1
+19 ;Q:ACPTACDE="P" ;payment change-not stored ;acpt*2.07*1
+20 ;I ACPTACDE="D" D Q ;delete code and quit ;acpt*2.07*1
+21 ;.S ACPTIEN=$A($E(ACPTCD))_$E(ACPTCD,2,5) ;acpt*2.07*1
+22 ;.I $G(^ICPT(ACPTIEN,0))="" S ACPTIEN=$O(^ICPT("B",ACPTCD,0)) ;acpt*2.07*1
+23 ;.Q:+ACPTIEN=0 ;acpt*2.07*1
+24 ;.Q:$P($G(^ICPT(ACPTIEN,0)),"^",7) ;acpt*2.07*1
+25 ;.S $P(^ICPT(ACPTIEN,0),"^",7)=ACPTYR ;acpt*2.07*1
+26 ;S A=$E(X,7,40) D DESC S ACPTSD=ACPTDESC ;acpt*2.06*1
+27 ;S A=$E(X,42,299) D DESC S ACPTLD=ACPTDESC ;acpt*2.06*1
+28 ;S A=$E(X,92,119) D DESC S ACPTSD=ACPTDESC ;acpt*2.06*1 ;acpt*2.07*1
+29 ;acpt*2.07*1
SET A=$EXTRACT(X,7,41)
DO DESC
SET ACPTSD=ACPTDESC
+30 ;S A=$E(X,12,91) D DESC S ACPTLD=ACPTDESC ;acpt*2.06*1 ;acpt*2.07*1
+31 ;acpt*2.07*1
SET A=$EXTRACT(X,42,975)
DO DESC
SET ACPTLD=ACPTDESC
+32 ;if no entry in CPT file
+33 IF '$DATA(^ICPT("B",ACPTCD))
Begin DoDot:2
+34 SET ACPTIEN=$ASCII($EXTRACT(ACPTCD))_$EXTRACT(ACPTCD,2,5)
+35 SET ^ICPT(ACPTIEN,0)=ACPTCD
+36 SET ^ICPT("B",ACPTCD,ACPTIEN)=""
+37 SET $PIECE(^ICPT(ACPTIEN,0),"^",6)=ACPTYR
+38 IF ACPTYR>DT
SET $PIECE(^ICPT(ACPTIEN,0),"^",4)=1
+39 KILL DIC
+40 SET DA(1)=ACPTIEN
+41 SET DIC="^ICPT("_DA(1)_",60,"
+42 SET DIC(0)="L"
+43 SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+44 SET X="01/01/2007"
+45 SET DIC("DR")=".02////1"
+46 DO ^DIC
End DoDot:2
+47 ;get IEN and edit existing entry
+48 SET ACPTIEN=$ORDER(^ICPT("B",ACPTCD,0))
+49 IF ACPTIEN'>0
QUIT
+50 ;start old code acpt*2.07*1
+51 ;I +ACPTLNE=100 D
+52 ;.K ^ICPT(ACPTIEN,"D")
+53 ;.S ^ICPT(ACPTIEN,"D",0)="^81.01A^^"
+54 ;S ACPTLN=$E(ACPTLNE,3)
+55 ;S ^ICPT(ACPTIEN,"D",+ACPTLN,0)=ACPTLD
+56 ;S $P(^ICPT(ACPTIEN,"D",0),"^",3,4)=+ACPTLN_"^"_+ACPTLN
+57 ;end old code acpt*2.07*1
+58 ;start new code acpt*2.07*1
+59 SET ^ICPT(ACPTIEN,"D",1,0)=ACPTLD
+60 SET $PIECE(^ICPT(ACPTIEN,"D",0),"^",3,4)=1_"^"_1
+61 ;end new code acpt*2.07*1
+62 IF ACPTSD'=""
SET $PIECE(^ICPT(ACPTIEN,0),"^",2)=ACPTSD
+63 SET $PIECE(^ICPT(ACPTIEN,0),"^",7)=""
+64 ;start new code acpt*2.07*1
+65 SET ACPTEDT=$ORDER(^ICPT(ACPTIEN,60,"B",9999999),-1)
+66 IF ACPTEDT'=""
Begin DoDot:2
+67 SET ACPTEIEN=$ORDER(^ICPT(ACPTIEN,60,"B",ACPTEDT,0))
+68 ;1=ACTIVE
IF $PIECE($GET(^ICPT(ACPTIEN,60,ACPTEIEN,0)),U,2)'=1
Begin DoDot:3
+69 KILL DIC
+70 SET DA(1)=ACPTIEN
+71 SET DIC="^ICPT("_DA(1)_",60,"
+72 SET DIC(0)="L"
+73 SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+74 SET X="01/01/2007"
+75 SET DIC("DR")=".02////1"
+76 DO ^DIC
End DoDot:3
End DoDot:2
+77 ;end new code acpt*2.07*1
+78 DO DOTS(ACPTCNT)
+79 SET ACPTCSV=ACPTCD
SET ACPTFLAG=""
End DoDot:1
IF $$STATUS^%ZISH
QUIT
+80 DO ^%ZISC
+81 KILL ACPTSD,ACPTLD
+82 KILL ACPTCSV,ACPTFLAG
+83 KILL ACPTLNE
+84 QUIT
+85 ;
MREAD ;READ AND UPDATE MODIFIERS AND P-CODES
+1 SET ACPTFL="acpt2008.m"
+2 WRITE !!,"Reading MODIFIER file, file name ",ACPTFL,!
+3 DO OPEN^%ZISH("CPTSFILE",ACPTPTH,ACPTFL,"R")
+4 IF POP
USE IO(0)
WRITE !,"Could not open modifier and p-code file."
QUIT
+5 FOR ACPTCNT=1:1
Begin DoDot:1
+6 USE IO
READ X
IF $$STATUS^%ZISH
QUIT
+7 SET ACPTCD=$EXTRACT(X,1,2)
+8 SET DESC=$EXTRACT($PIECE(X,": ",1),4,$LENGTH(X))
+9 SET ACPTCDN=$SELECT(ACPTCD=+ACPTCD:ACPTCD,1:$ASCII($EXTRACT(ACPTCD,1))_$ASCII($EXTRACT(ACPTCD,2)))
+10 IF '$DATA(^AUTTCMOD(ACPTCDN))
Begin DoDot:2
+11 SET ^AUTTCMOD(ACPTCDN,0)=ACPTCD
End DoDot:2
+12 SET $PIECE(^AUTTCMOD(ACPTCDN,0),"^",2)=DESC
+13 DO DOTS(ACPTCNT)
End DoDot:1
IF $$STATUS^%ZISH
QUIT
+14 DO ^%ZISC
+15 QUIT
+16 ;
GROUPS ;
+1 SET ACPTFL="acpt2006.d"
+2 WRITE !!,"Reading Group file, file name ",ACPTFL,!
+3 DO OPEN^%ZISH("CPTSFILE",ACPTPTH,ACPTFL,"R")
+4 IF POP
USE IO(0)
WRITE !,"Could not open group file."
QUIT
+5 FOR ACPTCNT=1:1
Begin DoDot:1
+6 USE IO
READ X
IF $$STATUS^%ZISH
QUIT
+7 SET ACPTCD=$PIECE(X,",")
+8 IF ACPTCD=""
QUIT
+9 SET ACPTDA=$ORDER(^ICPT("B",ACPTCD,""))
+10 IF ACPTDA=""
QUIT
+11 SET ACPTGRP=$PIECE(X,",",2)
+12 SET DR="6///"_ACPTGRP
+13 SET DIE="^ICPT("
+14 SET DA=ACPTDA
+15 DO ^DIE
+16 DO DOTS(ACPTCNT)
End DoDot:1
IF $$STATUS^%ZISH
QUIT
+17 DO ^%ZISC
+18 QUIT
DIR ;ASK DIRECTORY WHERE FILES WERE LOADED
+1 WRITE !
+2 SET DIR(0)="F"
SET DIR("A")="Enter directory where CPT files are located."
+3 SET DIR("B")="/usr/spool/uucppublic/"
+4 DO ^DIR
KILL DIR
+5 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIRUT)
QUIT
+6 IF ^%ZOSF("OS")["UNIX"
Begin DoDot:1
+7 SET Y=$TRANSLATE(Y,"\","/")
+8 IF $EXTRACT(Y)'="/"
SET Y="/"_Y
+9 IF $EXTRACT(Y,$LENGTH(Y))'="/"
SET Y=Y_"/"
End DoDot:1
+10 IF ^%ZOSF("OS")'["UNIX"
Begin DoDot:1
+11 SET Y=$TRANSLATE(Y,"/","\")
+12 IF $EXTRACT(Y)'="\"
IF Y'[":"
SET Y="\"_Y
+13 IF $EXTRACT(Y,$LENGTH(Y))'="\"
SET Y=Y_"\"
End DoDot:1
+14 SET ACPTPTH=Y
+15 QUIT
FILE ;ASK FOR FILE NAME
+1 WRITE !
+2 SET DIR(0)="F"
+3 DO ^DIR
KILL DIR
+4 SET Y=$TRANSLATE(Y,"/\")
+5 SET ACPTFL=Y
+6 QUIT
DESC ;STRIP TRAILING BLANKS FROM DESCRIPTION FIELD
+1 SET ACPTDESC=""
+2 NEW I
FOR I=0:1:31
SET A=$TRANSLATE(A,$CHAR(I))
+3 NEW I
FOR I=1:1:$LENGTH(A," ")
Begin DoDot:1
+4 SET ACPTWORD=$PIECE(A," ",I)
+5 IF ACPTWORD=""
QUIT
+6 IF I>1
SET ACPTDESC=ACPTDESC_" "
+7 SET ACPTDESC=ACPTDESC_ACPTWORD
End DoDot:1
+8 KILL ACPTWORD
+9 SET ACPTDESC=$$UPC^ACPTPST2(ACPTDESC)
+10 QUIT
CAT(Z) ;SET CPT CATEGORY
+1 SET ACPTCAT=Z
+2 IF '$DATA(^DIC(81.1,"ACPT",Z))
Begin DoDot:1
+3 SET ACPTCAT=$ORDER(^DIC(81.1,"ACPT",ACPTCAT),-1)
End DoDot:1
+4 SET ACPTCAT=$ORDER(^DIC(81.1,"ACPT",ACPTCAT,0))
+5 SET $PIECE(^ICPT(Z,0),"^",3)=ACPTCAT
+6 KILL ACPTCAT
+7 QUIT
ADD81 ;ADD FILE 81 TO LOCAL LOOKUP FILE
+1 SET DLAYGO=8984.4
+2 WRITE !!,"ADDING CPT FILE TO LOCAL LOOKUP FILE"
Begin DoDot:1
+3 IF '$DATA(^DIC(8984.4))
WRITE !,"LOCAL LOOKUP FILE (FILE 8984.4) MISSING.",!
QUIT
+4 SET DIC="^XT(8984.4,"
SET DIC(0)="LX"
SET X=81
DO ^DIC
+5 IF Y<0
QUIT
SET DA=+Y
SET DIE=DIC
SET DR=".03////C"
DO ^DIE
+6 WRITE !,"FILE 81 ADDED.",!
End DoDot:1
+7 KILL DLAYGO
+8 QUIT
XREF ;RE-CROSS REFERENCE FILE
+1 WRITE !,"WILL NOW RE-INDEX CPT FILE (this will take awhile).",!
+2 SET DIK="^ICPT("
DO IXALL^DIK
+3 DO ^ACPTCXR
+4 QUIT
XREFM ;RE-CROSS REFERENCE FILE
+1 WRITE !,"WILL NOW RE-INDEX MODIFIER FILE.",!
+2 SET DIK="^AUTTCMOD("
DO IXALL^DIK
+3 QUIT
QUE ;QUE JOB TO ACTIVATE/INACTIVATE CODES
+1 SET ZTRTN="^ACPTSINF"
+2 SET ZTIO=""
+3 SET ZTDESC="Activate/inactivate CPT codes."
+4 SET ZTDTH="60996,21600"
+5 SET ACPTRDT=$$HTFM^XLFDT(ZTDTH)
+6 SET ACPTRDT=$$FMTE^XLFDT(ACPTRDT,1)
+7 DO ^%ZTLOAD
+8 IF $GET(ZTSK)
Begin DoDot:1
+9 WRITE !,"I've taken the liberty to queue task # ",ZTSK," to run on ",ACPTRDT
+10 WRITE !,"This routine will inactivate deleted codes and activate new codes."
+11 WRITE !,"If this date and time is inconvenient, you may use the Taskman re-schedule"
+12 WRITE !,"option to run at a more suitable time."
End DoDot:1
+13 IF '$GET(ZTSK)
Begin DoDot:1
+14 WRITE !,"Attempt to queue routine ACPTSINF was unsuccessful. This routine will"
+15 WRITE !,"need to be run to activate new codes and de-activate old codes."
+16 WRITE !,"and should be run January or February ",ACPTCV,"."
End DoDot:1
+17 KILL ACPTRDT,ACPTCV
+18 QUIT
MSG ;display message
+1 FOR I=1:1
Begin DoDot:1
+2 SET ACPTTXT=$PIECE($TEXT(TXT+I),";;",2)
+3 IF ACPTTXT["end"
QUIT
+4 IF ACPTTXT="NOTE:"
WRITE $$EN^ACPTVDF("RVN")
+5 WRITE !,ACPTTXT
+6 IF ACPTTXT="NOTE:"
WRITE $$EN^ACPTVDF("RVF")
End DoDot:1
IF ACPTTXT["***end***"
QUIT
+7 KILL ACPTTXT
+8 QUIT
TXT ;text lines
+1 ;;CPT version 2.08 contains CPT codes and Modifiers for 2008.
+2 ;;The install will attempt to read the short description file
+3 ;;(acpt2008.s), the long description file (acpt2008.l), the
+4 ;;HCPCS Modifiers file (acpt2008.c), and the Modifiers file
+5 ;;(acpt2008.m) from the directory you specify.
+6 ;;
+7 ;;***end***
+8 QUIT
CAT2S ;
+1 SET A=$PIECE(X," ",2,999)
DO DESC
+2 SET ACPTCDN=""
+3 FOR ACPTCDC=1:1:5
SET ACPTCDN=ACPTCDN_$ASCII($EXTRACT(ACPTCD,ACPTCDC))
+4 IF '$DATA(^ICPT(+ACPTCDN))
Begin DoDot:1
+5 SET ^ICPT(+ACPTCDN,0)=ACPTCD
+6 SET $PIECE(^ICPT(+ACPTCDN,0),"^",6)=ACPTYR
+7 IF ACPTYR>DT
SET $PIECE(^ICPT(+ACPTCDN,0),"^",4)=1
+8 KILL DIC
+9 SET DA(1)=+ACPTCDN
+10 SET DIC="^ICPT("_DA(1)_",60,"
+11 SET DIC(0)="L"
+12 SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+13 SET X="01/01/2008"
+14 SET DIC("DR")=".02////1"
+15 DO ^DIC
End DoDot:1
+16 SET $PIECE(^ICPT(+ACPTCDN,0),"^",2)=ACPTDESC
+17 IF $PIECE(^ICPT(+ACPTCDN,0),"^",6)<DT
SET $PIECE(^ICPT(+ACPTCDN,0),"^",4)=""
+18 SET $PIECE(^ICPT(+ACPTCDN,0),"^",7)=""
+19 DO CAT(ACPTCDN)
+20 QUIT
CAT2L ;
+1 SET ACPTLN=$EXTRACT(X,6,7)
+2 SET ACPTCDN=""
+3 FOR ACPTCDC=1:1:5
SET ACPTCDN=ACPTCDN_$ASCII($EXTRACT(ACPTCD,ACPTCDC))
+4 SET A=$PIECE(X," ",2,999)
DO DESC
+5 IF '$DATA(^ICPT(+ACPTCDN))
Begin DoDot:1
+6 SET ^ICPT(+ACPTCDN,0)=ACPTCD
+7 SET $PIECE(^ICPT(+ACPTCDN,0),"^",6)=ACPTYR
+8 IF ACPTYR>DT
SET $PIECE(^ICPT(+ACPTCDN,0),"^",4)=1
+9 KILL DIC
+10 SET DA(1)=+ACPTCDN
+11 SET DIC="^ICPT("_DA(1)_",60,"
+12 SET DIC(0)="L"
+13 SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)
+14 SET X="01/01/2008"
+15 SET DIC("DR")=".02////1"
+16 DO ^DIC
End DoDot:1
+17 IF +ACPTLN=1
Begin DoDot:1
+18 KILL ^ICPT(+ACPTCDN,"D")
+19 SET ^ICPT(+ACPTCDN,"D",0)="^81.01A^^"
End DoDot:1
+20 SET ^ICPT(+ACPTCDN,"D",+ACPTLN,0)=ACPTDESC
+21 SET $PIECE(^ICPT(+ACPTCDN,"D",0),"^",3,4)=+ACPTLN_"^"_+ACPTLN
+22 DO DOTS(ACPTCNT)
+23 QUIT
UPKG ;update package file
+1 IF '$GET(DUZ)
Begin DoDot:1
+2 SET DUZ=1
+3 SET DUZ(0)="@"
End DoDot:1
+4 IF '$GET(DT)
Begin DoDot:1
+5 DO NOW^%DTC
+6 SET DT=$PIECE(%,".",1)
End DoDot:1
+7 SET DA=$ORDER(^DIC(9.4,"C","ACPT",0))
+8 IF 'DA
QUIT
+9 SET DIE="^DIC(9.4,"
+10 ;current version
SET DR="13///2.08"
+11 DO ^DIE
+12 SET DA(1)=DA
+13 SET X=2.04
+14 SET DIC="^DIC(9.4,DA(1),22,"
+15 SET DIC(0)="LX"
+16 DO ^DIC
+17 IF +Y<0
QUIT
+18 SET DA=+Y
+19 SET DIE=DIC
+20 SET DR="1///3071231;2///"_DT_";3///`"_DUZ
+21 DO ^DIE
+22 QUIT
