| 1 | EC725CH7 ;ALB/GTS/JAP - EC National Procedure Update; 10/28/98
|
|---|
| 2 | ;;2.0; EVENT CAPTURE ;**16**;8 May 96
|
|---|
| 3 | ;
|
|---|
| 4 | ;this routine is used as a post-init in KIDS build
|
|---|
| 5 | ;to modify the the EC National Procedure file #725
|
|---|
| 6 | ;
|
|---|
| 7 | INACT ;* inactivate national procedures
|
|---|
| 8 | ;
|
|---|
| 9 | ; ECXX is in format:
|
|---|
| 10 | ; NATIONAL NUMBER^INACTIVATION DATE
|
|---|
| 11 | ;
|
|---|
| 12 | N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT
|
|---|
| 13 | D MES^XPDUTL(" ")
|
|---|
| 14 | D BMES^XPDUTL("Inactivating procedures EC NATIONAL PROCEDURE File (#725)...")
|
|---|
| 15 | D MES^XPDUTL(" ")
|
|---|
| 16 | F ECX=1:1 K DD,DO,DA S ECXX=$P($T(OLD+ECX),";;",2) Q:ECXX="QUIT" D
|
|---|
| 17 | .S ECEXDT=$P(ECXX,U,2)
|
|---|
| 18 | .S X=ECEXDT
|
|---|
| 19 | .S %DT="X" D ^%DT
|
|---|
| 20 | .S ECINDT=$P(Y,".",1)
|
|---|
| 21 | .S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),0))
|
|---|
| 22 | .I $D(^EC(725,ECDA,0)) D
|
|---|
| 23 | ..S DA=ECDA,DR="2////^S X=ECINDT",DIE="^EC(725," D ^DIE
|
|---|
| 24 | ..D MES^XPDUTL(" ")
|
|---|
| 25 | ..D BMES^XPDUTL(" "_$P(ECXX,U,1)_" inactivated as of "_ECEXDT_".")
|
|---|
| 26 | Q
|
|---|
| 27 | ;
|
|---|
| 28 | OLD ;national procedures to be inactivated
|
|---|
| 29 | ;;SP002^1/1/1999
|
|---|
| 30 | ;;SP122^1/1/1999
|
|---|
| 31 | ;;SP135^1/1/1999
|
|---|
| 32 | ;;SP136^1/1/1999
|
|---|
| 33 | ;;SP138^1/1/1999
|
|---|
| 34 | ;;SP141^1/1/1999
|
|---|
| 35 | ;;SP146^1/1/1999
|
|---|
| 36 | ;;SP151^1/1/1999
|
|---|
| 37 | ;;SP156^1/1/1999
|
|---|
| 38 | ;;SP161^1/1/1999
|
|---|
| 39 | ;;SP169^1/1/1999
|
|---|
| 40 | ;;SP232^1/1/1999
|
|---|
| 41 | ;;SP240^1/1/1999
|
|---|
| 42 | ;;SP243^1/1/1999
|
|---|
| 43 | ;;SP244^1/1/1999
|
|---|
| 44 | ;;SP250^1/1/1999
|
|---|
| 45 | ;;SP251^1/1/1999
|
|---|
| 46 | ;;SP252^1/1/1999
|
|---|
| 47 | ;;QUIT
|
|---|
| 48 | ;
|
|---|
| 49 | CPTCHG ;* change cpt codes
|
|---|
| 50 | ;
|
|---|
| 51 | ; ECXX is in format:
|
|---|
| 52 | ; NATIONAL NUMBER^NEW CPT
|
|---|
| 53 | ;
|
|---|
| 54 | N ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y
|
|---|
| 55 | D MES^XPDUTL(" ")
|
|---|
| 56 | D BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)...")
|
|---|
| 57 | D MES^XPDUTL(" ")
|
|---|
| 58 | F ECX=1:1 S ECXX=$P($T(CPT+ECX),";;",2) Q:ECXX="QUIT" S CPT($P(ECXX,U,1))=$P(ECXX,U,2)
|
|---|
| 59 | S ECXX=""
|
|---|
| 60 | F S ECXX=$O(CPT(ECXX)) Q:ECXX="" D
|
|---|
| 61 | .S ECX=$O(^EC(725,"D",ECXX,0))
|
|---|
| 62 | .Q:+ECX=0
|
|---|
| 63 | .Q:'$D(^EC(725,ECX,0))
|
|---|
| 64 | .S CPT=CPT(ECXX)
|
|---|
| 65 | .S DA=ECX,DR="4////"_CPT,DIE="^EC(725," D ^DIE
|
|---|
| 66 | .D MES^XPDUTL(" ")
|
|---|
| 67 | .D BMES^XPDUTL(" Entry #"_ECX_" for "_ECXX)
|
|---|
| 68 | .D BMES^XPDUTL(" ...updated to use CPT code "_CPT_".")
|
|---|
| 69 | Q
|
|---|
| 70 | ;
|
|---|
| 71 | CPT ;cpt codes to be changed
|
|---|
| 72 | ;;SP037^97703
|
|---|
| 73 | ;;SP038^97703
|
|---|
| 74 | ;;QUIT
|
|---|
