ACPT24P2.m

ACPT24P2 ; IHS/ASDST/DMJ,SDR - CPT POST INIT ;      [ 02/03/2004  11:07 AM ]

 ;;2004;CPT FILES;**2**;DEC 31, 2003

 ;

 ; Fixes problem with modifiers not having complete description

 ;

 ;

START ;START HERE

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

 S ACPTYR=3040000

 W $$EN^ACPTVDF("IOF")

 W !!,"CPT Version 2.04 Install",!

 D MSG

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

 D DIR

 D MREAD  ;mod

 D XREFM

 ;

 D:'$D(^XT(8984.4,81,0)) ADD81

 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

MREAD ;READ AND UPDATE MODIFIERS AND P-CODES

 ;S ACPTFL="acpt2004.m"  ;IHS/SD/SDR 2/3/2004

 S ACPTFL="acpt2004.02m"  ;IHS/SD/SDR 2/3/2004

 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

 .I $E(X,1)'="-" Q

 .S ACPTCD=$E(X,2,3)

 .S DESC=$E($P(X,": ",1),4,$L(X))

 .;S DESC=$E(DESC,5,$L(DESC))  ;IHS/SD/SDR 2/3/2004

 .S DESC=$E(DESC,2,$L(DESC))  ;IHS/SD/SDR 2/3/2004

 .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

 ;

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

 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

XREFM ;RE-CROSS REFERENCE FILE

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

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

 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.04 patch 2 contains corrections for 2004 CPT

 ;;modifiers.  The install will attempt to read the Modifiers

 ;;file (acpt2004.m) and update the description to be correct. 

 ;;

 ;;***end***

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

 Q

ACPT24P2  ; IHS/ASDST/DMJ,SDR - CPT POST INIT ;      [ 02/03/2004  11:07 AM ]

 +1       ;;2004;CPT FILES;**2**;DEC 31, 2003

 +2       ;

 +3       ; Fixes problem with modifiers not having complete description

 +4       ;

 +5       ;

START     ;START HERE

 +1        IF '$GET(DT)

               DO NOW^%DTC

               SET DT=X

 +2        SET ACPTYR=3040000

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

 +4        WRITE !!,"CPT Version 2.04 Install",!

 +5        DO MSG

 +6        KILL DIR

           SET DIR(0)="E"

           DO ^DIR

           KILL DIR

           IF Y'=1

               QUIT 

 +7        DO DIR

 +8       ;mod

           DO MREAD

 +9        DO XREFM

 +10      ;

 +11       IF '$DATA(^XT(8984.4,81,0))

               DO ADD81

 +12       DO UPKG

 +13       WRITE !!,"INSTALL COMPLETE",!!

 +14       SET DIR(0)="E"

           DO ^DIR

 +15       KILL DIR,ACPT,ACPTYR

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

MREAD     ;READ AND UPDATE MODIFIERS AND P-CODES

 +1       ;S ACPTFL="acpt2004.m"  ;IHS/SD/SDR 2/3/2004

 +2       ;IHS/SD/SDR 2/3/2004

           SET ACPTFL="acpt2004.02m"

 +3        WRITE !!,"Reading MODIFIER file, file name ",ACPTFL,!

 +4        DO OPEN^%ZISH("CPTSFILE",ACPTPTH,ACPTFL,"R")

 +5        IF POP

               USE IO(0)

               WRITE !,"Could not open modifier and p-code file."

               QUIT 

 +6        FOR ACPTCNT=1:1

               Begin DoDot:1

 +7                USE IO

                   READ X

                   IF $$STATUS^%ZISH

                       QUIT 

 +8                IF $EXTRACT(X,1)'="-"

                       QUIT 

 +9                SET ACPTCD=$EXTRACT(X,2,3)

 +10               SET DESC=$EXTRACT($PIECE(X,": ",1),4,$LENGTH(X))

 +11      ;S DESC=$E(DESC,5,$L(DESC))  ;IHS/SD/SDR 2/3/2004

 +12      ;IHS/SD/SDR 2/3/2004

                   SET DESC=$EXTRACT(DESC,2,$LENGTH(DESC))

 +13               SET ACPTCDN=$SELECT(ACPTCD=+ACPTCD:ACPTCD,1:$ASCII($EXTRACT(ACPTCD,1))_$ASCII($EXTRACT(ACPTCD,2)))

 +14               IF '$DATA(^AUTTCMOD(ACPTCDN))

                       Begin DoDot:2

 +15                       SET ^AUTTCMOD(ACPTCDN,0)=ACPTCD

                       End DoDot:2

 +16               SET $PIECE(^AUTTCMOD(ACPTCDN,0),"^",2)=DESC

 +17               DO DOTS(ACPTCNT)

               End DoDot:1

               IF $$STATUS^%ZISH

                   QUIT 

 +18       DO ^%ZISC

 +19       QUIT 

 +20      ;

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 

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 

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 2 contains corrections for 2004 CPT

 +2       ;;modifiers.  The install will attempt to read the Modifiers

 +3       ;;file (acpt2004.m) and update the description to be correct. 

 +4       ;;

 +5       ;;***end***

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