| 1 | VEPERCPT ;RED/DAOU ; 8/1/05 7:30pm
|
|---|
| 2 | ;;1.0;Code to clean out CPT codes;;;Build 1
|
|---|
| 3 | ;REMOVE COPYRIGHTED CPT FILES' DATA
|
|---|
| 4 | W !,"Removing CPT code data now",!
|
|---|
| 5 | K ^ICPT S ^ICPT(0)="CPT^81I"
|
|---|
| 6 | K ^DIC(81.1) S ^DIC(81.1,0)="CPT CATEGORY^81.1",^(0,"GL")="^DIC(81.1,"
|
|---|
| 7 | K ^DIC(81.3) S ^DIC(81.3,0)="CPT MODIFIER^81.3I",^(0,"GL")="^DIC(81.3,"
|
|---|
| 8 | S %=$P(^DD(757.02,1,0),U,2) I %'="RF" W !,"757.02,1 has changed" Q
|
|---|
| 9 | S $P(^DD(757.02,1,0),U,2)="F"
|
|---|
| 10 | S %=$P(^DD(757.02,2,0),U,2) I %'="RP757.03'" W !,"757.02,2 has changed" Q
|
|---|
| 11 | S $P(^DD(757.02,2,0),U,2)="P757.03'"
|
|---|
| 12 | S DA=0,DIE=757.02,DR="1///@;2///@"
|
|---|
| 13 | F S DA=$O(^LEX(757.02,DA)) Q:DA'>0 D
|
|---|
| 14 | . S %=$P($G(^LEX(757.02,DA,0)),U,3)
|
|---|
| 15 | . I %=3!(%=4) D ^DIE
|
|---|
| 16 | . Q
|
|---|
| 17 | S $P(^DD(757.02,1,0),U,2)="RF"
|
|---|
| 18 | S $P(^DD(757.02,2,0),U,2)="RP757.03'"
|
|---|
| 19 | W !,"CPT Codes removed",!
|
|---|
| 20 | Q
|
|---|
