EC2P138 ;ALB/DE - EC Procedure Reason Update ; 6/20/17 11:00am
;;2.0;EVENT CAPTURE;**138**;8 May 96;Build 1
;
;this routine is used as a post-init in a KIDS build
;to modify the EC Procedure Reason (#720.4) file
;
Q
;
POST ;Add entries in file 720.4
;
N ECXFDA,ECXERR,ECREAS,ECINC
;
;-add procedure reason
F ECINC=1:1 S ECREAS=$P($T(ADDREAS+ECINC),";;",2) Q:ECREAS="QUIT" D
.;
.;-quit w/error message if entry already exists in file #720.4
.I $$FIND1^DIC(720.4,"","X",ECREAS) D Q
..D BMES^XPDUTL(">>>..."_ECREAS_" not added, entry already exists.")
.;
.;Setup field values of new entry
.S ECXFDA(720.4,"+1,",.01)=ECREAS
.S ECXFDA(720.4,"+1,",.02)=1 ;Set "ACTIVE?" field to 1 (active)
.;
.;-add new entry to file #720.4
.D UPDATE^DIE("E","ECXFDA","","ECXERR")
.;
.I '$D(ECXERR) D BMES^XPDUTL(">>>..."_ECREAS_" added to file.")
.I $D(ECXERR) D BMES^XPDUTL(">>>...Unable to add "_ECREAS_" to file.")
;
Q
;
ADDREAS ;List of new procedure reasons
;;CHAP ADV CARE PLAN
;;CHAP EMPOWER VET PGM
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P138 1062 printed Dec 13, 2024@01:55:03 Page 2
EC2P138 ;ALB/DE - EC Procedure Reason Update ; 6/20/17 11:00am
+1 ;;2.0;EVENT CAPTURE;**138**;8 May 96;Build 1
+2 ;
+3 ;this routine is used as a post-init in a KIDS build
+4 ;to modify the EC Procedure Reason (#720.4) file
+5 ;
+6 QUIT
+7 ;
POST ;Add entries in file 720.4
+1 ;
+2 NEW ECXFDA,ECXERR,ECREAS,ECINC
+3 ;
+4 ;-add procedure reason
+5 FOR ECINC=1:1
SET ECREAS=$PIECE($TEXT(ADDREAS+ECINC),";;",2)
if ECREAS="QUIT"
QUIT
Begin DoDot:1
+6 ;
+7 ;-quit w/error message if entry already exists in file #720.4
+8 IF $$FIND1^DIC(720.4,"","X",ECREAS)
Begin DoDot:2
+9 DO BMES^XPDUTL(">>>..."_ECREAS_" not added, entry already exists.")
End DoDot:2
QUIT
+10 ;
+11 ;Setup field values of new entry
+12 SET ECXFDA(720.4,"+1,",.01)=ECREAS
+13 ;Set "ACTIVE?" field to 1 (active)
SET ECXFDA(720.4,"+1,",.02)=1
+14 ;
+15 ;-add new entry to file #720.4
+16 DO UPDATE^DIE("E","ECXFDA","","ECXERR")
+17 ;
+18 IF '$DATA(ECXERR)
DO BMES^XPDUTL(">>>..."_ECREAS_" added to file.")
+19 IF $DATA(ECXERR)
DO BMES^XPDUTL(">>>...Unable to add "_ECREAS_" to file.")
End DoDot:1
+20 ;
+21 QUIT
+22 ;
ADDREAS ;List of new procedure reasons
+1 ;;CHAP ADV CARE PLAN
+2 ;;CHAP EMPOWER VET PGM
+3 ;;QUIT
