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

EC2P138.m

Go to the documentation of this file.
  1. EC2P138 ;ALB/DE - EC Procedure Reason Update ; 6/20/17 11:00am
  1. ;;2.0;EVENT CAPTURE;**138**;8 May 96;Build 1
  1. ;
  1. ;this routine is used as a post-init in a KIDS build
  1. ;to modify the EC Procedure Reason (#720.4) file
  1. ;
  1. Q
  1. ;
  1. POST ;Add entries in file 720.4
  1. ;
  1. N ECXFDA,ECXERR,ECREAS,ECINC
  1. ;
  1. ;-add procedure reason
  1. F ECINC=1:1 S ECREAS=$P($T(ADDREAS+ECINC),";;",2) Q:ECREAS="QUIT" D
  1. .;
  1. .;-quit w/error message if entry already exists in file #720.4
  1. .I $$FIND1^DIC(720.4,"","X",ECREAS) D Q
  1. ..D BMES^XPDUTL(">>>..."_ECREAS_" not added, entry already exists.")
  1. .;
  1. .;Setup field values of new entry
  1. .S ECXFDA(720.4,"+1,",.01)=ECREAS
  1. .S ECXFDA(720.4,"+1,",.02)=1 ;Set "ACTIVE?" field to 1 (active)
  1. .;
  1. .;-add new entry to file #720.4
  1. .D UPDATE^DIE("E","ECXFDA","","ECXERR")
  1. .;
  1. .I '$D(ECXERR) D BMES^XPDUTL(">>>..."_ECREAS_" added to file.")
  1. .I $D(ECXERR) D BMES^XPDUTL(">>>...Unable to add "_ECREAS_" to file.")
  1. ;
  1. Q
  1. ;
  1. ADDREAS ;List of new procedure reasons
  1. ;;CHAP ADV CARE PLAN
  1. ;;CHAP EMPOWER VET PGM
  1. ;;QUIT