Routine: ACPT24P1

ACPT24P1 ; IHS/ASDST/DMJ,SDR - CPT POST INIT ;      [ 02/03/2004  12:28 PM ]

 ;;2004;CPT FILES;**1,2**;JAN 14, 2004

START S ACPTYR=3040000

 D MSG

 D DIR

 S I=99999,ACPTTO=999999 D INA

 D HREAD  ;hcpcs

 D FINISH

 D XREFM

 W !!,"INSTALL COMPLETE",!!

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

 K DIR,ACPT,ACPTYR

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)'=3040000

 .S $P(^ICPT(I,0),"^",7)=ACPTYR  ;put date deleted

 .S $P(^ICPT(I,0),"^",4)=""  ;remove inactive flag

 .S ACPTEFDT=$O(^ICPT(I,60,"B",3040101,0))  ;get effective date entry

 .Q:ACPTEFDT=""

 .S DA(1)=I

 .S DIK="^ICPT("_DA(1)_",60,"

 .S DA=ACPTEFDT

 .D ^DIK

 .D DOTS(I)

 K ACPTTO

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

 U IO(0)

 W:'(X#100) "."

HREAD ;READ HCPCS FILE

 K ACPTCD,ACPTFLAG,ACPTIEN,ACPTDESC

 S ACPTCSV=""

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

 S ACPTFL="acpt2004.01h"

 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 A=$E(X,7,40) D DESC S ACPTSD=ACPTDESC

 .S A=$E(X,42,299) D DESC S ACPTLD=ACPTDESC

 .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 $P(^ICPT(ACPTIEN,0),"^",7)=""

 ..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/2004"

 ..S DIC("DR")=".02////1"

 ..D ^DIC

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

 .Q:ACPTIEN'>0

 .K ^ICPT(ACPTIEN,"D")

 .S ^ICPT(ACPTIEN,"D",0)="^81.01A^^"

 .S ^ICPT(ACPTIEN,"D",1,0)=ACPTLD

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

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

 .D DOTS(ACPTCNT)

 .S ACPTCSV=ACPTCD,ACPTFLAG=""

 D ^%ZISC

 K ACPTSD,ACPTLD

 K ACPTCSV,ACPTFLAG

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

FILE ;ASK FOR FILE NAME

W !

 S DIR(0)="F"

 D ^DIR K DIR

 S Y=$TR(Y,"/\")

 S ACPTFL=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

FINISH ;

 S I=99999,ACPTTO=999999

 W !!,"Updating Effective Date Field.",!

 F  S I=$O(^ICPT(I)) Q:I>ACPTTO!('I)  D

 .Q:$P($G(^ICPT(I,0)),"^",7)'=3040000

 .S DA(1)=I

 .S DIC="^ICPT("_DA(1)_",60,"

 .S DIC(0)="L"

 .S DIC("P")=$P(^DD(81,60,0),"^",2)

 .S X="01/01/2004"

 .S DIC("DR")=".02////0"

 .D ^DIC

 .D DOTS(I)

 K ACPTTO

XREFM ;RE-CROSS REFERENCE FILE

 W !,"WILL NOW RE-INDEX MODIFIER FILE.",!

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

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.04 Patch 1 contains HCPCs update for 2004.

 ;;The install will attempt to read the HCPCS codes file (acpt2004.h),

 ;;and update the codes accordingly.

;;

 ;;***end***

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/2004"

 .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)

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/2004"

 .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)

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.04"

 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///3031231;2///"_DT_";3///`"_DUZ

 D ^DIE

ACPT24P1  ; IHS/ASDST/DMJ,SDR - CPT POST INIT ;      [ 02/03/2004  12:28 PM ]

 +1       ;;2004;CPT FILES;**1,2**;JAN 14, 2004

 +2       ;

 +3       ;

START      SET ACPTYR=3040000

 +1        DO MSG

 +2        DO DIR

 +3        SET I=99999

           SET ACPTTO=999999

           DO INA

 +4       ;hcpcs

           DO HREAD

 +5        DO FINISH

 +6        DO XREFM

 +7        WRITE !!,"INSTALL COMPLETE",!!

 +8        SET DIR(0)="E"

           DO ^DIR

 +9        KILL DIR,ACPT,ACPTYR

 +10       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)'=3040000

                       QUIT

 +4       ;put date deleted

                   SET $PIECE(^ICPT(I,0),"^",7)=ACPTYR

 +5       ;remove inactive flag

                   SET $PIECE(^ICPT(I,0),"^",4)=""

 +6       ;get effective date entry

                   SET ACPTEFDT=$ORDER(^ICPT(I,60,"B",3040101,0))

 +7                IF ACPTEFDT=""

                       QUIT

 +8                SET DA(1)=I

 +9                SET DIK="^ICPT("_DA(1)_",60,"

 +10               SET DA=ACPTEFDT

 +11               DO ^DIK

 +12               DO DOTS(I)

               End DoDot:1

 +13       KILL ACPTTO

 +14       QUIT

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

 +1        USE IO(0)

 +2        IF '(X#100)

               WRITE "."

 +3        QUIT

 +4       ;

HREAD     ;READ HCPCS FILE

 +1        KILL ACPTCD,ACPTFLAG,ACPTIEN,ACPTDESC

 +2        SET ACPTCSV=""

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

 +4        SET ACPTFL="acpt2004.01h"

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

 +6        IF POP

               USE IO(0)

               WRITE !,"Could not open HCPCS file."

               QUIT

 +7        USE IO(0)

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

 +8        FOR ACPTCNT=1:1

               Begin DoDot:1

 +9                USE IO

                   READ X

                   IF $$STATUS^%ZISH

                       QUIT

 +10               SET ACPTCD=$EXTRACT(X,1,5)

 +11               IF ACPTCD=ACPTCSV

                       SET ACPTFLAG=1

 +12               IF ACPTCD'?1U4N

                       QUIT

 +13               SET A=$EXTRACT(X,7,40)

                   DO DESC

                   SET ACPTSD=ACPTDESC

 +14               SET A=$EXTRACT(X,42,299)

                   DO DESC

                   SET ACPTLD=ACPTDESC

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

                       Begin DoDot:2

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

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

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

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

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

 +21                       KILL DIC

 +22                       SET DA(1)=ACPTIEN

 +23                       SET DIC="^ICPT("_DA(1)_",60,"

 +24                       SET DIC(0)="L"

 +25                       SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)

 +26                       SET X="01/01/2004"

 +27                       SET DIC("DR")=".02////1"

 +28                       DO ^DIC

                       End DoDot:2

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

 +30               IF ACPTIEN'>0

                       QUIT

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

 +32               SET ^ICPT(ACPTIEN,"D",0)="^81.01A^^"

 +33               SET ^ICPT(ACPTIEN,"D",1,0)=ACPTLD

 +34               IF ACPTSD'=""

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

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

 +36               DO DOTS(ACPTCNT)

 +37               SET ACPTCSV=ACPTCD

                   SET ACPTFLAG=""

               End DoDot:1

               IF $$STATUS^%ZISH

                   QUIT

 +38       DO ^%ZISC

 +39       KILL ACPTSD,ACPTLD

 +40       KILL ACPTCSV,ACPTFLAG

 +41       QUIT

 +42      ;

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        QUIT

FINISH    ;

 +1        SET I=99999

           SET ACPTTO=999999

 +2        WRITE !!,"Updating Effective Date Field.",!

 +3        FOR

               SET I=$ORDER(^ICPT(I))

               IF I>ACPTTO!('I)

                   QUIT

               Begin DoDot:1

 +4                IF $PIECE($GET(^ICPT(I,0)),"^",7)'=3040000

                       QUIT

 +5                SET DA(1)=I

 +6                SET DIC="^ICPT("_DA(1)_",60,"

 +7                SET DIC(0)="L"

 +8                SET DIC("P")=$PIECE(^DD(81,60,0),"^",2)

 +9                SET X="01/01/2004"

 +10               SET DIC("DR")=".02////0"

 +11               DO ^DIC

 +12               DO DOTS(I)

               End DoDot:1

 +13       KILL ACPTTO

 +14       QUIT

XREFM     ;RE-CROSS REFERENCE FILE

 +1        WRITE !,"WILL NOW RE-INDEX MODIFIER FILE.",!

 +2        SET DIK="^AUTTCMOD("

           DO IXALL^DIK

 +3        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.04 Patch 1 contains HCPCs update for 2004.

 +2       ;;The install will attempt to read the HCPCS codes file (acpt2004.h),

 +3       ;;and update the codes accordingly.

 +4       ;;

 +5       ;;***end***

 +6        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/2004"

 +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/2004"

 +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       SET DR="13///2.04"

 +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///3031231;2///"_DT_";3///`"_DUZ

 +21       DO ^DIE

 +22       QUIT

ACPT24P1.m