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

EC2P137C.m

Go to the documentation of this file.
EC2P137C ;ALB/DE - EC National Procedure Update ; 4/8/17 11:00am
 ;;2.0;EVENT CAPTURE;**137**;8 May 96;Build 5
 ;
 ;this routine is used as a post-init in a KIDS build
 ;to modify the EC National Procedure file (#725)
 ;
 Q
 ;
INACT ;* inactivate national procedures
 ;
 ;  ECXX is in format:
 ;   NATIONAL NUMBER^INACTIVATION DATE^FIRST NATIONAL NUMBER SEQUENCE^
 ;   LAST NATIONAL NUMBER SEQUENCE
 ;
 N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
 N ECSEQ,ECCODE,ECCODX
 D MES^XPDUTL(" ")
 D BMES^XPDUTL("Inactivating procedures EC NATIONAL PROCEDURE File (#725)...")
 D MES^XPDUTL(" ")
 F ECX=1:1 K DD,DO,DA S ECXX=$P($T(OLD+ECX),";;",2) Q:ECXX="QUIT"  D
 .S ECEXDT=$P(ECXX,U,2),X=ECEXDT,%DT="X" D ^%DT S ECINDT=$P(Y,".",1)
 .S ECCODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),ECCODX=ECCODE
 .I ECBEG="" D UPINACT Q
 .F ECSEQ=ECBEG:1:ECEND D
 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
 ..S ECCODE=ECCODX_ECADD
 ..D UPINACT
 Q
UPINACT ;Update codes as inactive
 ;
 S ECDA=+$O(^EC(725,"D",ECCODE,0))
 I $D(^EC(725,ECDA,0)) D
 .S DA=ECDA,DR="2///^S X=ECINDT",DIE="^EC(725," D ^DIE
 .D MES^XPDUTL(" ")
 .D BMES^XPDUTL("   "_ECCODE_" inactivated as of "_ECEXDT_".")
 Q
 ;
OLD ;national procedures to be inactivated - national code #^inact. date
 ;;RC010^10/1/2017
 ;;RC012^10/1/2017
 ;;RC013^10/1/2017
 ;;RC014^10/1/2017
 ;;RC017^10/1/2017
 ;;RC018^10/1/2017
 ;;RC019^10/1/2017
 ;;RC020^10/1/2017
 ;;RC021^10/1/2017
 ;;RC033^10/1/2017
 ;;RC034^10/1/2017
 ;;RC053^10/1/2017
 ;;RC054^10/1/2017
 ;;RC055^10/1/2017
 ;;RC056^10/1/2017
 ;;RC057^10/1/2017
 ;;RC069^10/1/2017
 ;;RC070^10/1/2017
 ;;RC074^10/1/2017
 ;;RC092^10/1/2017
 ;;RC093^10/1/2017
 ;;RC094^10/1/2017
 ;;RC100^10/1/2017
 ;;RC102^10/1/2017
 ;;SW001^10/1/2017
 ;;SW046^10/1/2017
 ;;SW048^10/1/2017
 ;;SW060^10/1/2017
 ;;SW072^10/1/2017
 ;;SW073^10/1/2017
 ;;SW074^10/1/2017
 ;;SW077^10/1/2017
 ;;SW088^10/1/2017
 ;;SW094^10/1/2017
 ;;SW095^10/1/2017
 ;;SW104^10/1/2017
 ;;SW107^10/1/2017
 ;;SW108^10/1/2017
 ;;SW121^10/1/2017
 ;;SW123^10/1/2017
 ;;SW127^10/1/2017
 ;;SW128^10/1/2017
 ;;SW129^10/1/2017
 ;;SW131^10/1/2017
 ;;SW132^10/1/2017
 ;;SW133^10/1/2017
 ;;SW134^10/1/2017
 ;;SW135^10/1/2017
 ;;SW136^10/1/2017
 ;;QUIT
 ;
CPTCHG ;* change cpt codes
 ;
 ;  ECXX is in format:
 ;  NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL
 ;  NUMBER SEQUENCE
 ;
 N ECX,ECXX,ECCPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,ECSEQ,ECSTR,ECCPTIEN
 D MES^XPDUTL(" ")
 D BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
 D MES^XPDUTL(" ")
 F ECX=1:1 S ECXX=$P($T(CPT+ECX),";;",2) Q:ECXX="QUIT"  D
 .S ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),ECCPTIEN=$P(ECXX,U,2)
 .S ECCPTIEN=$S(ECCPTIEN="":"@",1:$$FIND1^DIC(81,"","X",ECCPTIEN))
 .I ECCPTIEN'="@",+ECCPTIEN<1 D  Q
 ..S ECSTR=$P(ECXX,U)_":  CPT code "_$P(ECXX,U,2)_" is invalid."
 ..D MES^XPDUTL(" ")
 ..D BMES^XPDUTL("   "_ECSTR)
 .I ECBEG="" S ECCPT($P(ECXX,U))=ECCPTIEN_U_$P(ECXX,U,2) Q
 .F ECSEQ=ECBEG:1:ECEND D
 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
 ..S ECCPT($P(ECXX,U)_ECADD)=ECCPTIEN_U_$P(ECXX,U,2)
 S ECXX=""
 F  S ECXX=$O(ECCPT(ECXX)) Q:ECXX=""  D
 .S ECX=$O(^EC(725,"D",ECXX,0))
 .Q:+ECX=0
 .I '$D(^EC(725,ECX,0))!(+ECX=0) D  Q
 ..D MES^XPDUTL(" ")
 ..D BMES^XPDUTL("   Can't find entry for "_ECXX_",CPT code not updated.")
 .S ECCPT=$P(ECCPT(ECXX),U),DA=ECX,DR="4///"_ECCPT,DIE="^EC(725," D ^DIE
 .D MES^XPDUTL(" ")
 .S ECSTR="   Entry #"_ECX_" for "_ECXX
 .D BMES^XPDUTL(ECSTR_" updated to use CPT code "_$P(ECCPT(ECXX),U,2))
 Q
 ;
CPT ;cpt codes to be changed - national #^new CPT code
 ;;SW130^H0004
 ;;SW076^T1016
 ;;SW087^T1016
 ;;QUIT