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
