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

EC725U45.m

Go to the documentation of this file.
  1. EC725U45 ;ALB/GTS/JAP/GT - EC National Procedure Update; 10/17/2006
  1. ;;2.0; EVENT CAPTURE ;**89**;8 May 96;Build 3
  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^FIRST NATIONAL NUMBER SEQUENCE^
  1. ; LAST NATIONAL NUMBER SEQUENCE
  1. ;
  1. N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
  1. N ECSEQ,CODE,CODX
  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),X=ECEXDT,%DT="X" D ^%DT S ECINDT=$P(Y,".",1)
  1. .S CODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CODX=CODE
  1. .I ECBEG="" D UPINACT Q
  1. .F ECSEQ=ECBEG:1:ECEND D
  1. ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
  1. ..S CODE=CODX_ECADD
  1. ..D UPINACT
  1. Q
  1. UPINACT ;Update codes as inactive
  1. ;
  1. S ECDA=+$O(^EC(725,"D",CODE,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(" "_CODE_" inactivated as of "_ECEXDT_".")
  1. Q
  1. ;
  1. OLD ;national procedures to be inactivated - national code #^inact. date
  1. ;;HH040^1/1/2007
  1. ;;HH041^1/1/2007
  1. ;;HH062^1/1/2007
  1. ;;HH066^1/1/2007
  1. ;;HH068^1/1/2007
  1. ;;HH074^1/1/2007
  1. ;;HH083^1/1/2007
  1. ;;HH117^1/1/2007
  1. ;;HH119^1/1/2007
  1. ;;HH122^1/1/2007
  1. ;;QUIT
  1. ;
  1. REACT ;* reactivate national procedures
  1. ;
  1. ; ECXX is in format:
  1. ; NATIONAL NUMBER^DATE (FUTURE)^FIRST NATIONAL NUMBER SEQUENCE^
  1. ; LAST NATIONAL NUMBER SEQUENCE
  1. ;
  1. N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
  1. N ECSEQ,CODE,CODX,ECDES
  1. D MES^XPDUTL(" ")
  1. D BMES^XPDUTL("Reactivating procedures EC NATIONAL PROCEDURE File (#725)...")
  1. D MES^XPDUTL(" ")
  1. F ECX=1:1 K DD,DO,DA S ECXX=$P($T(ACT+ECX),";;",2) Q:ECXX="QUIT" D
  1. .S ECDES=$P(ECXX,U,5)
  1. .S CODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CODX=CODE
  1. .I ECBEG="" D UPREACT Q
  1. .F ECSEQ=ECBEG:1:ECEND D
  1. ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
  1. ..S CODE=CODX_ECADD
  1. ..D UPREACT
  1. Q
  1. UPREACT ;Update codes as reactive
  1. ;
  1. S ECDA=+$O(^EC(725,"D",CODE,0))
  1. I $D(^EC(725,ECDA,0)) D
  1. .S DA=ECDA,DR="2///@",DIE="^EC(725," D ^DIE
  1. .D BMES^XPDUTL(" "_CODE_" "_ECDES_" reactivated.")
  1. Q
  1. ;
  1. ACT ;national procedures to be reactivated - national number^date
  1. ;;QUIT
  1. ;
  1. CPTCHG ;* change cpt codes
  1. ;
  1. ; ECXX is in format:
  1. ; NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL
  1. ; NUMBER SEQUENCE
  1. ;
  1. N ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,NAME,ECSEQ,STR,CPTIEN
  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" D
  1. .S ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CPTIEN=$P(ECXX,U,2)
  1. .S CPTIEN=$S(CPTIEN="":"@",1:$$FIND1^DIC(81,"","X",CPTIEN))
  1. .I CPTIEN'="@",+CPTIEN<1 D Q
  1. ..S STR=$P(ECXX,U)_": CPT code "_$P(ECXX,U,2)_" is invalid."
  1. ..D MES^XPDUTL(" ")
  1. ..D BMES^XPDUTL(" "_STR)
  1. .I ECBEG="" S CPT($P(ECXX,U))=CPTIEN_U_$P(ECXX,U,2) Q
  1. .F ECSEQ=ECBEG:1:ECEND D
  1. ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
  1. ..S CPT($P(ECXX,U)_ECADD)=CPTIEN_U_$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. .I '$D(^EC(725,ECX,0))!(+ECX=0) D Q
  1. ..D MES^XPDUTL(" ")
  1. ..D BMES^XPDUTL(" Can't find entry for "_ECXX_",CPT cde not updated.")
  1. .S CPT=$P(CPT(ECXX),U),DA=ECX,DR="4////"_CPT,DIE="^EC(725," D ^DIE
  1. .D MES^XPDUTL(" ")
  1. .S STR=" Entry #"_ECX_" for "_ECXX
  1. .D BMES^XPDUTL(STR_" updated to use CPT code "_$P(CPT(ECXX),U,2))
  1. Q
  1. ;
  1. CPT ;cpt codes to be changed - national #^new CPT code
  1. ;;QUIT