Routine: ACPTP1A

ACPTP1A ; IHS/ASDST/DMJ,SDR - CPT PATCH 1 ;      [ 01/07/2005  12:02 PM ]

 ;;2005;CPT FILES;**1**;DEC 31, 2004

START ;START HERE

 I '$G(DT) D NOW^%DTC S DT=X

 S ACPTYR=3050000

 W $$EN^ACPTVDF("IOF")

 W !!,"HCPCS Version 2.05 Install",!

 D MSG

 K DIR S DIR(0)="E" D ^DIR K DIR Q:Y'=1

 W !,"Installing ",$E(ACPTYR,1,3)+1700," HCPCS codes.",!

 D OPEN

 I POP U IO(0) W !,"Could not open HCPCS file." Q

 D HREAD  ;hcpcs

 D XREF

 W !!,"INSTALL COMPLETE",!!

 S DIR(0)="E" D ^DIR

 K DIR,ACPT,ACPTYR

OPEN ;open host file

 D DIR

 S ACPTFL="acpt2005.01h"

 D OPEN^%ZISH("CPTHFILE",ACPTPTH,ACPTFL,"R")

HREAD ;READ HCPCS FILE

 U IO(0) W !,"Reading HCPCS Codes File.",!

 F ACPTCNT=1:1 D  Q:$$STATUS^%ZISH

 .U IO R ACPTREC Q:$$STATUS^%ZISH

 .S ACPTCD=$E(ACPTREC,1,5)

 .Q:ACPTCD'?1U4N

 .D ONE

 .D DOTS(ACPTCNT)

 D ^%ZISC

 K ACPTSD,ACPTLD,ACPTDESC

 K ACPTCSV,ACPTFLAG,ACPTREC

ONE ;one record

 S A=$E(ACPTREC,7,40) D DESC S ACPTSD=ACPTDESC

 S A=$E(ACPTREC,42,299) D DESC S ACPTLD(1)=ACPTDESC

 I '$D(^ICPT("B",ACPTCD)) D NEW

 S ACPTIEN=$O(^ICPT("B",ACPTCD,0))

 Q:ACPTIEN'>0

 S:ACPTSD'="" $P(^ICPT(ACPTIEN,0),"^",2)=ACPTSD

 S $P(^ICPT(ACPTIEN,0),"^",4)=""

 S $P(^ICPT(ACPTIEN,0),"^",7)=""

 K ^ICPT(ACPTIEN,"D")

 D WP^DIE(81,ACPTIEN_",",50,"","ACPTLD")

NEW ;new hcpcs code

 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

DIR ;ASK DIRECTORY WHERE FILES WERE LOADED

W !

 S DIR(0)="F",DIR("A")="Enter directory where HCPCS file is 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

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

DOTS(X) ;EP - WRITE OUT A DOT EVERY HUNDRED

 U IO(0)

 W:'(X#100) "."

XREF ;RE-CROSS REFERENCE FILE

 W !,"WILL NOW RE-INDEX CPT FILE (this will take awhile).",!

 S DIK="^ICPT(" D IXALL^DIK

 D ^ACPTCXR

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

TXT ;text lines

 ;;CPT version 2.05 patch# 1 contains HCPCS codes for 2005.

 ;;The install will read the HCPCS code file (acpt2005.01h)

 ;;from the directory you specify.

;;

 ;;***end***

ACPTP1A   ; IHS/ASDST/DMJ,SDR - CPT PATCH 1 ;      [ 01/07/2005  12:02 PM ]

 +1       ;;2005;CPT FILES;**1**;DEC 31, 2004

 +2       ;

 +3       ;

START     ;START HERE

 +1        IF '$GET(DT)

               DO NOW^%DTC

               SET DT=X

 +2        SET ACPTYR=3050000

 +3        WRITE $$EN^ACPTVDF("IOF")

 +4        WRITE !!,"HCPCS Version 2.05 Install",!

 +5        DO MSG

 +6        KILL DIR

           SET DIR(0)="E"

           DO ^DIR

           KILL DIR

           IF Y'=1

               QUIT

 +7        WRITE !,"Installing ",$EXTRACT(ACPTYR,1,3)+1700," HCPCS codes.",!

 +8        DO OPEN

 +9        IF POP

               USE IO(0)

               WRITE !,"Could not open HCPCS file."

               QUIT

 +10      ;hcpcs

           DO HREAD

 +11       DO XREF

 +12       WRITE !!,"INSTALL COMPLETE",!!

 +13       SET DIR(0)="E"

           DO ^DIR

 +14       KILL DIR,ACPT,ACPTYR

 +15       QUIT

 +16      ;

OPEN      ;open host file

 +1        DO DIR

 +2        SET ACPTFL="acpt2005.01h"

 +3        DO OPEN^%ZISH("CPTHFILE",ACPTPTH,ACPTFL,"R")

 +4        QUIT

HREAD     ;READ HCPCS FILE

 +1        USE IO(0)

           WRITE !,"Reading HCPCS Codes File.",!

 +2        FOR ACPTCNT=1:1

               Begin DoDot:1

 +3                USE IO

                   READ ACPTREC

                   IF $$STATUS^%ZISH

                       QUIT

 +4                SET ACPTCD=$EXTRACT(ACPTREC,1,5)

 +5                IF ACPTCD'?1U4N

                       QUIT

 +6                DO ONE

 +7                DO DOTS(ACPTCNT)

               End DoDot:1

               IF $$STATUS^%ZISH

                   QUIT

 +8        DO ^%ZISC

 +9        KILL ACPTSD,ACPTLD,ACPTDESC

 +10       KILL ACPTCSV,ACPTFLAG,ACPTREC

 +11       QUIT

ONE       ;one record

 +1        SET A=$EXTRACT(ACPTREC,7,40)

           DO DESC

           SET ACPTSD=ACPTDESC

 +2        SET A=$EXTRACT(ACPTREC,42,299)

           DO DESC

           SET ACPTLD(1)=ACPTDESC

 +3        IF '$DATA(^ICPT("B",ACPTCD))

               DO NEW

 +4        SET ACPTIEN=$ORDER(^ICPT("B",ACPTCD,0))

 +5        IF ACPTIEN'>0

               QUIT

 +6        IF ACPTSD'=""

               SET $PIECE(^ICPT(ACPTIEN,0),"^",2)=ACPTSD

 +7        SET $PIECE(^ICPT(ACPTIEN,0),"^",4)=""

 +8        SET $PIECE(^ICPT(ACPTIEN,0),"^",7)=""

 +9        KILL ^ICPT(ACPTIEN,"D")

 +10       DO WP^DIE(81,ACPTIEN_",",50,"","ACPTLD")

 +11       QUIT

NEW       ;new hcpcs code

 +1        SET ACPTIEN=$ASCII($EXTRACT(ACPTCD))_$EXTRACT(ACPTCD,2,5)

 +2        SET ^ICPT(ACPTIEN,0)=ACPTCD

 +3        SET ^ICPT("B",ACPTCD,ACPTIEN)=""

 +4        SET $PIECE(^ICPT(ACPTIEN,0),"^",6)=ACPTYR

 +5        QUIT

 +6       ;

DIR       ;ASK DIRECTORY WHERE FILES WERE LOADED

 +1        WRITE !

 +2        SET DIR(0)="F"

           SET DIR("A")="Enter directory where HCPCS file is 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

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        QUIT

DOTS(X)   ;EP - WRITE OUT A DOT EVERY HUNDRED

 +1        USE IO(0)

 +2        IF '(X#100)

               WRITE "."

 +3        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

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.05 patch# 1 contains HCPCS codes for 2005.

 +2       ;;The install will read the HCPCS code file (acpt2005.01h)

 +3       ;;from the directory you specify.

 +4       ;;

 +5       ;;***end***

 +6        QUIT

ACPTP1A.m