ACPTPOST.m

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