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
Q
;
OPEN ;open host file
D DIR
S ACPTFL="acpt2005.01h"
D OPEN^%ZISH("CPTHFILE",ACPTPTH,ACPTFL,"R")
Q
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
Q
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")
Q
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
Q
;
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
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
DOTS(X) ;EP - WRITE OUT A DOT EVERY HUNDRED
U IO(0)
W:'(X#100) "."
Q
XREF ;RE-CROSS REFERENCE FILE
W !,"WILL NOW RE-INDEX CPT FILE (this will take awhile).",!
S DIK="^ICPT(" D IXALL^DIK
D ^ACPTCXR
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.05 patch# 1 contains HCPCS codes for 2005.
;;The install will read the HCPCS code file (acpt2005.01h)
;;from the directory you specify.
;;
;;***end***
Q
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
