- 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
