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

EC2P132C.m

Go to the documentation of this file.
  1. EC2P132C ;ALB/DE - EC National Procedure Update ; 4/8/16 11:00am
  1. ;;2.0;EVENT CAPTURE;**132**;8 May 96;Build 3
  1. ;
  1. ;this routine is used as a post-init in a KIDS build
  1. ;to modify the EC National Procedure file (#725)
  1. ;
  1. Q
  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,ECCODE,ECCODX
  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 ECCODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),ECCODX=ECCODE
  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 ECCODE=ECCODX_ECADD
  1. ..D UPINACT
  1. Q
  1. UPINACT ;Update codes as inactive
  1. ;
  1. S ECDA=+$O(^EC(725,"D",ECCODE,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(" "_ECCODE_" inactivated as of "_ECEXDT_".")
  1. Q
  1. ;
  1. OLD ;national procedures to be inactivated - national code #^inact. date
  1. ;;SD001^10/1/2016
  1. ;;SD002^10/1/2016
  1. ;;SD003^10/1/2016
  1. ;;SD004^10/1/2016
  1. ;;SD005^10/1/2016
  1. ;;SD006^10/1/2016
  1. ;;SD007^10/1/2016
  1. ;;SD008^10/1/2016
  1. ;;SD009^10/1/2016
  1. ;;SD012^10/1/2016
  1. ;;SD013^10/1/2016
  1. ;;SD014^10/1/2016
  1. ;;SD015^10/1/2016
  1. ;;SD016^10/1/2016
  1. ;;SD017^10/1/2016
  1. ;;SD018^10/1/2016
  1. ;;SD019^10/1/2016
  1. ;;SD020^10/1/2016
  1. ;;SD021^10/1/2016
  1. ;;SD022^10/1/2016
  1. ;;SD023^10/1/2016
  1. ;;SD024^10/1/2016
  1. ;;SD025^10/1/2016
  1. ;;SD026^10/1/2016
  1. ;;SD027^10/1/2016
  1. ;;SD028^10/1/2016
  1. ;;SD029^10/1/2016
  1. ;;SD030^10/1/2016
  1. ;;SD031^10/1/2016
  1. ;;SD032^10/1/2016
  1. ;;SD033^10/1/2016
  1. ;;SD034^10/1/2016
  1. ;;SD035^10/1/2016
  1. ;;SD036^10/1/2016
  1. ;;SD037^10/1/2016
  1. ;;SD038^10/1/2016
  1. ;;SD039^10/1/2016
  1. ;;SD040^10/1/2016
  1. ;;SD041^10/1/2016
  1. ;;SD042^10/1/2016
  1. ;;SH001^10/1/2016
  1. ;;SH002^10/1/2016
  1. ;;SH003^10/1/2016
  1. ;;SH004^10/1/2016
  1. ;;SH005^10/1/2016
  1. ;;SH006^10/1/2016
  1. ;;SH007^10/1/2016
  1. ;;SH008^10/1/2016
  1. ;;SH009^10/1/2016
  1. ;;SH012^10/1/2016
  1. ;;SH013^10/1/2016
  1. ;;SH014^10/1/2016
  1. ;;SH015^10/1/2016
  1. ;;SH016^10/1/2016
  1. ;;SH017^10/1/2016
  1. ;;SH018^10/1/2016
  1. ;;SH019^10/1/2016
  1. ;;SH020^10/1/2016
  1. ;;SN001^10/1/2016
  1. ;;SN002^10/1/2016
  1. ;;SN003^10/1/2016
  1. ;;SN004^10/1/2016
  1. ;;SN005^10/1/2016
  1. ;;SN006^10/1/2016
  1. ;;SN007^10/1/2016
  1. ;;SN008^10/1/2016
  1. ;;SN009^10/1/2016
  1. ;;SN012^10/1/2016
  1. ;;SN013^10/1/2016
  1. ;;SN014^10/1/2016
  1. ;;SN015^10/1/2016
  1. ;;SN016^10/1/2016
  1. ;;SN017^10/1/2016
  1. ;;SN018^10/1/2016
  1. ;;SN019^10/1/2016
  1. ;;SN020^10/1/2016
  1. ;;SN021^10/1/2016
  1. ;;SN022^10/1/2016
  1. ;;SN023^10/1/2016
  1. ;;SN024^10/1/2016
  1. ;;SN025^10/1/2016
  1. ;;SN026^10/1/2016
  1. ;;SN027^10/1/2016
  1. ;;SN028^10/1/2016
  1. ;;SN029^10/1/2016
  1. ;;SN030^10/1/2016
  1. ;;SN031^10/1/2016
  1. ;;SN032^10/1/2016
  1. ;;SN033^10/1/2016
  1. ;;SN034^10/1/2016
  1. ;;SN035^10/1/2016
  1. ;;SN036^10/1/2016
  1. ;;SN037^10/1/2016
  1. ;;SN038^10/1/2016
  1. ;;SN039^10/1/2016
  1. ;;SN040^10/1/2016
  1. ;;SN041^10/1/2016
  1. ;;SN042^10/1/2016
  1. ;;SN043^10/1/2016
  1. ;;SN044^10/1/2016
  1. ;;SN045^10/1/2016
  1. ;;SN046^10/1/2016
  1. ;;SN047^10/1/2016
  1. ;;SN048^10/1/2016
  1. ;;SN049^10/1/2016
  1. ;;SN050^10/1/2016
  1. ;;SN051^10/1/2016
  1. ;;SN052^10/1/2016
  1. ;;SN053^10/1/2016
  1. ;;SN054^10/1/2016
  1. ;;SN055^10/1/2016
  1. ;;SN056^10/1/2016
  1. ;;SN057^10/1/2016
  1. ;;SN058^10/1/2016
  1. ;;SN059^10/1/2016
  1. ;;SN060^10/1/2016
  1. ;;SN061^10/1/2016
  1. ;;SN062^10/1/2016
  1. ;;SN063^10/1/2016
  1. ;;SN064^10/1/2016
  1. ;;SN065^10/1/2016
  1. ;;SN066^10/1/2016
  1. ;;SN067^10/1/2016
  1. ;;SN068^10/1/2016
  1. ;;SN069^10/1/2016
  1. ;;SN070^10/1/2016
  1. ;;SN071^10/1/2016
  1. ;;SN072^10/1/2016
  1. ;;SN073^10/1/2016
  1. ;;SN074^10/1/2016
  1. ;;SN075^10/1/2016
  1. ;;SN076^10/1/2016
  1. ;;SN077^10/1/2016
  1. ;;SN078^10/1/2016
  1. ;;SN079^10/1/2016
  1. ;;SN080^10/1/2016
  1. ;;SN081^10/1/2016
  1. ;;SN082^10/1/2016
  1. ;;SN083^10/1/2016
  1. ;;SN084^10/1/2016
  1. ;;SN085^10/1/2016
  1. ;;SN086^10/1/2016
  1. ;;SN087^10/1/2016
  1. ;;SN088^10/1/2016
  1. ;;SN089^10/1/2016
  1. ;;SN090^10/1/2016
  1. ;;SN091^10/1/2016
  1. ;;SN092^10/1/2016
  1. ;;SN093^10/1/2016
  1. ;;SN094^10/1/2016
  1. ;;SN095^10/1/2016
  1. ;;SN096^10/1/2016
  1. ;;SN097^10/1/2016
  1. ;;SN098^10/1/2016
  1. ;;SN099^10/1/2016
  1. ;;SN100^10/1/2016
  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,ECCPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,ECSEQ,ECSTR,ECCPTIEN
  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),ECCPTIEN=$P(ECXX,U,2)
  1. .S ECCPTIEN=$S(ECCPTIEN="":"@",1:$$FIND1^DIC(81,"","X",ECCPTIEN))
  1. .I ECCPTIEN'="@",+ECCPTIEN<1 D Q
  1. ..S ECSTR=$P(ECXX,U)_": CPT code "_$P(ECXX,U,2)_" is invalid."
  1. ..D MES^XPDUTL(" ")
  1. ..D BMES^XPDUTL(" "_ECSTR)
  1. .I ECBEG="" S ECCPT($P(ECXX,U))=ECCPTIEN_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 ECCPT($P(ECXX,U)_ECADD)=ECCPTIEN_U_$P(ECXX,U,2)
  1. S ECXX=""
  1. F S ECXX=$O(ECCPT(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 code not updated.")
  1. .S ECCPT=$P(ECCPT(ECXX),U),DA=ECX,DR="4///"_ECCPT,DIE="^EC(725," D ^DIE
  1. .D MES^XPDUTL(" ")
  1. .S ECSTR=" Entry #"_ECX_" for "_ECXX
  1. .D BMES^XPDUTL(ECSTR_" updated to use CPT code "_$P(ECCPT(ECXX),U,2))
  1. Q
  1. ;
  1. CPT ;cpt codes to be changed - national #^new CPT code
  1. ;;SP086^92570
  1. ;;SP256^92522
  1. ;;SP064^92537
  1. ;;SP231^92538
  1. ;;QUIT