Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: EC725CH7

EC725CH7.m

Go to the documentation of this file.
  1. EC725CH7 ;ALB/GTS/JAP - EC National Procedure Update; 10/28/98
  1. ;;2.0; EVENT CAPTURE ;**16**;8 May 96
  1. ;
  1. ;this routine is used as a post-init in KIDS build
  1. ;to modify the the EC National Procedure file #725
  1. ;
  1. INACT ;* inactivate national procedures
  1. ;
  1. ; ECXX is in format:
  1. ; NATIONAL NUMBER^INACTIVATION DATE
  1. ;
  1. N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT
  1. D MES^XPDUTL(" ")
  1. D BMES^XPDUTL("Inactivating procedures EC NATIONAL PROCEDURE File (#725)...")
  1. D MES^XPDUTL(" ")
  1. F ECX=1:1 K DD,DO,DA S ECXX=$P($T(OLD+ECX),";;",2) Q:ECXX="QUIT" D
  1. .S ECEXDT=$P(ECXX,U,2)
  1. .S X=ECEXDT
  1. .S %DT="X" D ^%DT
  1. .S ECINDT=$P(Y,".",1)
  1. .S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),0))
  1. .I $D(^EC(725,ECDA,0)) D
  1. ..S DA=ECDA,DR="2////^S X=ECINDT",DIE="^EC(725," D ^DIE
  1. ..D MES^XPDUTL(" ")
  1. ..D BMES^XPDUTL(" "_$P(ECXX,U,1)_" inactivated as of "_ECEXDT_".")
  1. Q
  1. ;
  1. OLD ;national procedures to be inactivated
  1. ;;SP002^1/1/1999
  1. ;;SP122^1/1/1999
  1. ;;SP135^1/1/1999
  1. ;;SP136^1/1/1999
  1. ;;SP138^1/1/1999
  1. ;;SP141^1/1/1999
  1. ;;SP146^1/1/1999
  1. ;;SP151^1/1/1999
  1. ;;SP156^1/1/1999
  1. ;;SP161^1/1/1999
  1. ;;SP169^1/1/1999
  1. ;;SP232^1/1/1999
  1. ;;SP240^1/1/1999
  1. ;;SP243^1/1/1999
  1. ;;SP244^1/1/1999
  1. ;;SP250^1/1/1999
  1. ;;SP251^1/1/1999
  1. ;;SP252^1/1/1999
  1. ;;QUIT
  1. ;
  1. CPTCHG ;* change cpt codes
  1. ;
  1. ; ECXX is in format:
  1. ; NATIONAL NUMBER^NEW CPT
  1. ;
  1. N ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y
  1. D MES^XPDUTL(" ")
  1. D BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)...")
  1. D MES^XPDUTL(" ")
  1. F ECX=1:1 S ECXX=$P($T(CPT+ECX),";;",2) Q:ECXX="QUIT" S CPT($P(ECXX,U,1))=$P(ECXX,U,2)
  1. S ECXX=""
  1. F S ECXX=$O(CPT(ECXX)) Q:ECXX="" D
  1. .S ECX=$O(^EC(725,"D",ECXX,0))
  1. .Q:+ECX=0
  1. .Q:'$D(^EC(725,ECX,0))
  1. .S CPT=CPT(ECXX)
  1. .S DA=ECX,DR="4////"_CPT,DIE="^EC(725," D ^DIE
  1. .D MES^XPDUTL(" ")
  1. .D BMES^XPDUTL(" Entry #"_ECX_" for "_ECXX)
  1. .D BMES^XPDUTL(" ...updated to use CPT code "_CPT_".")
  1. Q
  1. ;
  1. CPT ;cpt codes to be changed
  1. ;;SP037^97703
  1. ;;SP038^97703
  1. ;;QUIT