- 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 Feb 18, 2025@23:21:27 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