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

EC2P168C.m

Go to the documentation of this file.
  1. EC2P168C ;MNT/JB - EC National Procedure Update; April 19, 2024@15:50
  1. ;;2.0;EVENT CAPTURE;**168**;May 8, 1996;Build 8
  1. ;
  1. ; This routine is used as a post-init in a KIDS build
  1. ; to inactivate national procedure codes and update
  1. ; CPT codes in the EC National Procedure file (#725)
  1. ; for FY25.
  1. ;
  1. ; references to ^%DT supported by ICR# 10003
  1. ; References to $$FIND1^DIC supported by ICR# 2051
  1. ; References to ^DIE supported by ICR# 10018
  1. ; References to BMES^XPDUTL supported by ICR# 10141
  1. ; References to MES^XPDUTL supported by ICR# 10141
  1. ;
  1. Q
  1. ;
  1. REACT ;* reactivate national procedures
  1. ;
  1. ; ECREC is in format: CODE #^
  1. ;
  1. N ECDA,ECX,ECXX,DA,DIE,DR,ECERR,ECNT
  1. D BMES^XPDUTL("*** Reactivating Procedure in EC NATIONAL PROCEDURE File (#725)")
  1. ;
  1. ; Load entries
  1. S ECNT=0
  1. F ECX=1:1 K DD,DO,DA S ECXX=$P($T(ACT+ECX),";;",2) Q:ECXX="QUIT" D
  1. . S ECDA=+$O(^EC(725,"D",ECXX,0))
  1. . ; Check if inactive
  1. . I $P($G(^EC(725,ECDA,0)),U,3)'="" D
  1. . . K ECFDA
  1. . . S ECFDA(725,ECDA_",",2)=""
  1. . . D FILE^DIE(,"ECFDA","ECERR")
  1. . . ; check if error
  1. . . I '$D(ECERR) D BMES^XPDUTL(" Reactivated: "_ECXX_" "_$P($G(^EC(725,ECDA,0)),"^",1))
  1. . . I $D(ECERR) D Q
  1. . . . D BMES^XPDUTL(" >> ... Unable to reactivate stop code: "_ECDA)
  1. . . . D MES^XPDUTL(" >> ... "_$G(ECERR("DIERR",1,"TEXT",1))_".")
  1. . . . D MES^XPDUTL(" >> ... Please contact support for assistance...")
  1. . . . K ECERR
  1. . . S ECNT=ECNT+1
  1. D BMES^XPDUTL(" Total "_ECNT_" procedure codes have been reactivated.")
  1. D MES^XPDUTL(" ")
  1. Q
  1. ;
  1. ACT ; Code to be reactivated - ;;number^
  1. ;;NU093
  1. ;;QUIT
  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,ECCNT2
  1. S ECCNT2=0
  1. D BMES^XPDUTL("*** Inactivating procedures in the 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. D BMES^XPDUTL(" Total "_ECCNT2_" CPT codes have been inactivated.")
  1. Q
  1. ;
  1. UPINACT ;Update codes as inactive
  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(" "_ECCODE_" inactivated as of "_ECEXDT_".")
  1. .S ECCNT2=ECCNT2+1
  1. Q
  1. ;
  1. OLD ;national procedures to be inactivated - national code#^inact. date
  1. ;;NU149^10/1/2024
  1. ;;NU150^10/1/2024
  1. ;;NU152^10/1/2024
  1. ;;NU154^10/1/2024
  1. ;;NU195^10/1/2024
  1. ;;NU211^10/1/2024
  1. ;;NU212^10/1/2024
  1. ;;NU213^10/1/2024
  1. ;;NU214^10/1/2024
  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("*** Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
  1. D MES^XPDUTL(" ")
  1. ;
  1. N ECCNT3,ECCNT33 S (ECCNT3,ECCNT33)=0
  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 MES^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. ;
  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 MES^XPDUTL(" Can't find entry for "_ECXX_",CPT code not updated.")
  1. ..S ECCNT33=ECCNT33+1
  1. .S ECCPT=$P(ECCPT(ECXX),U),DA=ECX,DR="4///"_ECCPT,DIE="^EC(725," D ^DIE
  1. .S ECSTR=" Entry #"_ECX_" for "_ECXX
  1. .D MES^XPDUTL(ECSTR_" updated to use CPT code "_$P(ECCPT(ECXX),U,2))
  1. .S ECCNT3=ECCNT3+1
  1. ;
  1. D BMES^XPDUTL(" Total "_ECCNT3_" CPT codes have been updated.")
  1. I ECCNT33>0 D MES^XPDUTL(" Total "_ECCNT33_" CPT codes did NOT get updated.")
  1. Q
  1. ;
  1. CPT ;cpt codes to be changed - national #^new CPT code
  1. ;;NU071^99078
  1. ;;NU072^99078
  1. ;;QUIT