ACPTPST2 ; IHS/ASDST/DMJ,SDR - CPT POST INIT ; [ 01/08/2004 10:18 AM ]
;;2.08;CPT FILES;;DEC 17, 2007
START ;START HERE
MOD ;EP - hcpcs modifier
S ACPTFL="acpt2008.c"
S ACPTCSV="" ;acpt*2.06*1
W !!,"Reading HCPCS MODIFIER file, file name ",ACPTFL,!
D OPEN^%ZISH("CPTSFILE",ACPTPTH,ACPTFL,"R")
I POP U IO(0) W !,"Could not open hcpcs modifier file." Q
F ACPTCNT=1:1 D Q:$$STATUS^%ZISH
.U IO R X Q:$$STATUS^%ZISH
.;S ACPTCD=$E(ACPTCD,1,2) ;acpt*2.06*1 ;acpt*2.07*1
.S ACPTCD=$E(X,1,2) ;acpt*2.07*1
.;S ACPTCD=$E(X,4,5) ;acpt*2.06*1 ;acpt*2.07*1
.;I ACPTCD=ACPTCSV S ACPTFLAG=1 ;acpt*2.06*1 ;acpt*2.07*1
.;start old code acpt*2.07*1
.;S ACPTLNE=$E(X,6,10) ;acpt*2.06*1
.;S ACPTACDE=$E(X,293) ;action code acpt*2.06*1
.;Q:ACPTACDE="" ;no action code acpt*2.06*1
.;Q:ACPTACDE="N" ;no change to code acpt*2.06*1
.;Q:ACPTACDE="P" ;payment change-not stored acpt*2.06*1
.;I ACPTACDE="D" D Q ;delete code and quit acpt*2.06*1
.;.S ACPTIEN=$O(^AUTTCMOD("B",ACPTCD,0)) ;acpt*2.06*1
.;.Q:+ACPTIEN=0 ;acpt*2.06*1
.;.Q:$P($G(^AUTTCMOD(ACPTIEN,0)),"^",4) ;acpt*2.06*1
.;.S $P(^AUTTCMOD(ACPTIEN,0),"^",4)=ACPTYR ;acpt*2.06*1
.;end old code acpt*2.07*1
.S A=$E(X,3,30) D DESC S ACPTSD=ACPTDESC
.S A=$E(X,31,210) D DESC S ACPTLD=ACPTDESC
.I '$D(^AUTTCMOD("B",ACPTCD)) D
..S ACPTIEN=$A($E(ACPTCD,1))_$A($E(ACPTCD,2))
..S ^AUTTCMOD(ACPTIEN,0)=ACPTCD
..S ^AUTTCMOD("B",ACPTCD,ACPTIEN)=""
..S $P(^AUTTCMOD(ACPTIEN,0),"^",3)=ACPTYR
.;get IEN and edit existing entry
.S ACPTIEN=$O(^AUTTCMOD("B",ACPTCD,0))
.;Q:ACPTIEN'>0 ;acpt*2.07*1
.;I +ACPTLN=1 D ;acpt*2.06*1
.;start old code acpt*2.07*1
.;I +ACPTLNE=100 D ;acpt*2.06*1
.;.K ^AUTTCMOD(ACPTIEN,1)
.;.S ^AUTTCMOD(ACPTIEN,1,0)=""
.;S ACPTLN=$E(ACPTLNE,3) ;acpt*2.06*1
.;S ^AUTTCMOD(ACPTIEN,1,+ACPTLN,0)=ACPTLD ;acpt*2.06*1
.;S $P(^AUTTCMOD(ACPTIEN,1,0),"^",3,4)=+ACPTLN_"^"_+ACPTLN ;acpt*2.06*1
.;end old code start new code acpt*2.07*1
.K ^AUTTCMOD(ACPTIEN,1) ;acpt*2.07*1
.S ^AUTTCMOD(ACPTIEN,1,1,0)=ACPTLD
.S $P(^AUTTCMOD(ACPTIEN,1,0),"^",3,4)=1_"^"_1
.;end new code acpt*2.07*1
.S:ACPTSD'="" $P(^AUTTCMOD(ACPTIEN,0),"^",2)=ACPTSD
.;the below modifiers are reused and no short description was sent so what is there is wrong for the new code
.I ACPTCD="AE"!(ACPTCD="AF")!(ACPTCD="AG")!(ACPTCD="AK")!(ACPTCD="CB")!(ACPTCD="FP")!(ACPTCD="QA") S $P(^AUTTCMOD(ACPTIEN,0),"^",2)="" ;acpt*2.07*1
.S $P(^AUTTCMOD(ACPTIEN,0),U,2)=$$UPC($P($G(^AUTTCMOD(ACPTIEN,0)),U,2)) ;acpt*2.07*1
.S $P(^AUTTCMOD(ACPTIEN,0),"^",4)="" ;acpt*2.06*1
.D DOTS^ACPTPOST(ACPTCNT)
.S ACPTCSV=ACPTCD,ACPTFLAG=""
D ^%ZISC
K ACPTSD,ACPTLD ;acpt*2.06*1
K ACPTCSV,ACPTFLAG ;acpt*2.06*1
K ACPTLNE ;acpt*2.06*1
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
S ACPTDESC=$$UPC(ACPTDESC)
K ACPTWORD
Q
UPC(X) ;EP - UPPER CASE
N Y
S Y=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q Y
XREF ;EP - RE-CROSS REFERENCE FILE
W !,"WILL NOW RE-INDEX CPT MODIFIERS FILE.",!
S DIK="^AUTTCMOD(" D IXALL^DIK
Q
FIXCPT ; EP - removes entries where the .01 field is null and marked inactive
S ACPTDA=0
F S ACPTDA=$O(^ICPT(ACPTDA)) Q:'ACPTDA D
.S ACPTCD=$P($G(^ICPT(ACPTDA,0)),"^")
.I ACPTCD="" D ;if no code
..K ^ICPT(ACPTDA)
Q
ACPTPST2 ; IHS/ASDST/DMJ,SDR - CPT POST INIT ; [ 01/08/2004 10:18 AM ]
+1 ;;2.08;CPT FILES;;DEC 17, 2007
START ;START HERE
MOD ;EP - hcpcs modifier
+1 SET ACPTFL="acpt2008.c"
+2 ;acpt*2.06*1
SET ACPTCSV=""
+3 WRITE !!,"Reading HCPCS MODIFIER file, file name ",ACPTFL,!
+4 DO OPEN^%ZISH("CPTSFILE",ACPTPTH,ACPTFL,"R")
+5 IF POP
USE IO(0)
WRITE !,"Could not open hcpcs modifier file."
QUIT
+6 FOR ACPTCNT=1:1
Begin DoDot:1
+7 USE IO
READ X
IF $$STATUS^%ZISH
QUIT
+8 ;S ACPTCD=$E(ACPTCD,1,2) ;acpt*2.06*1 ;acpt*2.07*1
+9 ;acpt*2.07*1
SET ACPTCD=$EXTRACT(X,1,2)
+10 ;S ACPTCD=$E(X,4,5) ;acpt*2.06*1 ;acpt*2.07*1
+11 ;I ACPTCD=ACPTCSV S ACPTFLAG=1 ;acpt*2.06*1 ;acpt*2.07*1
+12 ;start old code acpt*2.07*1
+13 ;S ACPTLNE=$E(X,6,10) ;acpt*2.06*1
+14 ;S ACPTACDE=$E(X,293) ;action code acpt*2.06*1
+15 ;Q:ACPTACDE="" ;no action code acpt*2.06*1
+16 ;Q:ACPTACDE="N" ;no change to code acpt*2.06*1
+17 ;Q:ACPTACDE="P" ;payment change-not stored acpt*2.06*1
+18 ;I ACPTACDE="D" D Q ;delete code and quit acpt*2.06*1
+19 ;.S ACPTIEN=$O(^AUTTCMOD("B",ACPTCD,0)) ;acpt*2.06*1
+20 ;.Q:+ACPTIEN=0 ;acpt*2.06*1
+21 ;.Q:$P($G(^AUTTCMOD(ACPTIEN,0)),"^",4) ;acpt*2.06*1
+22 ;.S $P(^AUTTCMOD(ACPTIEN,0),"^",4)=ACPTYR ;acpt*2.06*1
+23 ;end old code acpt*2.07*1
+24 SET A=$EXTRACT(X,3,30)
DO DESC
SET ACPTSD=ACPTDESC
+25 SET A=$EXTRACT(X,31,210)
DO DESC
SET ACPTLD=ACPTDESC
+26 IF '$DATA(^AUTTCMOD("B",ACPTCD))
Begin DoDot:2
+27 SET ACPTIEN=$ASCII($EXTRACT(ACPTCD,1))_$ASCII($EXTRACT(ACPTCD,2))
+28 SET ^AUTTCMOD(ACPTIEN,0)=ACPTCD
+29 SET ^AUTTCMOD("B",ACPTCD,ACPTIEN)=""
+30 SET $PIECE(^AUTTCMOD(ACPTIEN,0),"^",3)=ACPTYR
End DoDot:2
+31 ;get IEN and edit existing entry
+32 SET ACPTIEN=$ORDER(^AUTTCMOD("B",ACPTCD,0))
+33 ;Q:ACPTIEN'>0 ;acpt*2.07*1
+34 ;I +ACPTLN=1 D ;acpt*2.06*1
+35 ;start old code acpt*2.07*1
+36 ;I +ACPTLNE=100 D ;acpt*2.06*1
+37 ;.K ^AUTTCMOD(ACPTIEN,1)
+38 ;.S ^AUTTCMOD(ACPTIEN,1,0)=""
+39 ;S ACPTLN=$E(ACPTLNE,3) ;acpt*2.06*1
+40 ;S ^AUTTCMOD(ACPTIEN,1,+ACPTLN,0)=ACPTLD ;acpt*2.06*1
+41 ;S $P(^AUTTCMOD(ACPTIEN,1,0),"^",3,4)=+ACPTLN_"^"_+ACPTLN ;acpt*2.06*1
+42 ;end old code start new code acpt*2.07*1
+43 ;acpt*2.07*1
KILL ^AUTTCMOD(ACPTIEN,1)
+44 SET ^AUTTCMOD(ACPTIEN,1,1,0)=ACPTLD
+45 SET $PIECE(^AUTTCMOD(ACPTIEN,1,0),"^",3,4)=1_"^"_1
+46 ;end new code acpt*2.07*1
+47 IF ACPTSD'=""
SET $PIECE(^AUTTCMOD(ACPTIEN,0),"^",2)=ACPTSD
+48 ;the below modifiers are reused and no short description was sent so what is there is wrong for the new code
+49 ;acpt*2.07*1
IF ACPTCD="AE"!(ACPTCD="AF")!(ACPTCD="AG")!(ACPTCD="AK")!(ACPTCD="CB")!(ACPTCD="FP")!(ACPTCD="QA")
SET $PIECE(^AUTTCMOD(ACPTIEN,0),"^",2)=""
+50 ;acpt*2.07*1
SET $PIECE(^AUTTCMOD(ACPTIEN,0),U,2)=$$UPC($PIECE($GET(^AUTTCMOD(ACPTIEN,0)),U,2))
+51 ;acpt*2.06*1
SET $PIECE(^AUTTCMOD(ACPTIEN,0),"^",4)=""
+52 DO DOTS^ACPTPOST(ACPTCNT)
+53 SET ACPTCSV=ACPTCD
SET ACPTFLAG=""
End DoDot:1
IF $$STATUS^%ZISH
QUIT
+54 DO ^%ZISC
+55 ;acpt*2.06*1
KILL ACPTSD,ACPTLD
+56 ;acpt*2.06*1
KILL ACPTCSV,ACPTFLAG
+57 ;acpt*2.06*1
KILL ACPTLNE
+58 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 SET ACPTDESC=$$UPC(ACPTDESC)
+9 KILL ACPTWORD
+10 QUIT
UPC(X) ;EP - UPPER CASE
+1 NEW Y
+2 SET Y=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+3 QUIT Y
XREF ;EP - RE-CROSS REFERENCE FILE
+1 WRITE !,"WILL NOW RE-INDEX CPT MODIFIERS FILE.",!
+2 SET DIK="^AUTTCMOD("
DO IXALL^DIK
+3 QUIT
FIXCPT ; EP - removes entries where the .01 field is null and marked inactive
+1 SET ACPTDA=0
+2 FOR
SET ACPTDA=$ORDER(^ICPT(ACPTDA))
IF 'ACPTDA
QUIT
Begin DoDot:1
+3 SET ACPTCD=$PIECE($GET(^ICPT(ACPTDA,0)),"^")
+4 ;if no code
IF ACPTCD=""
Begin DoDot:2
+5 KILL ^ICPT(ACPTDA)
End DoDot:2
End DoDot:1
+6 QUIT
