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
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)'=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
Q
DOTS(X) ;EP - WRITE OUT A DOT EVERY HUNDRED
U IO(0)
W:'(X#100) "."
Q
;
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
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
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
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 1 contains HCPCs update for 2004.
;;The install will attempt to read the HCPCS codes file (acpt2004.h),
;;and update the codes accordingly.
;;
;;***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/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)
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/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)
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
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
