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

ECX3P191.m

Go to the documentation of this file.
  1. ECX3P191 ;MNTVBB/DTA - NATIONAL CLINIC (#728.441) File Update; JULY 15, 2024@16:44
  1. ;;3.0;DSS EXTRACTS;**191**;Dec 22, 1997;Build 3
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; This routine is used as a post-init in a KIDS build to
  1. ; update the NATIONAL CLINIC (#728.441) file for FY25.
  1. ;
  1. ; Reference(s) to $$FIND1^DIC supported by ICR# 2051
  1. ; Reference(s) to FILE^DIE supported by ICR# 2053
  1. ; Reference(s) to UPDATE^DIE supported by ICR# 2053
  1. ; Reference(s) to BMES^XPDUTL supported by ICR# 10141
  1. ; Reference(s) to MES^XPDUTL supported by ICR# 10141
  1. ;
  1. Q
  1. ;
  1. POST ;routine entry point
  1. ;
  1. ; Start of Install
  1. D BMES^XPDUTL("Update NATIONAL CLINIC (#728.441) file starts.")
  1. ;D ADD ;add new code
  1. N ECX191FILES
  1. S ECX191FILE=""
  1. S ECX191FILES="728.441"
  1. S ECXCNT=0
  1. F ECXCNT=1:1:$L(ECX191FILES,"^") D
  1. . S ECX191FILE=$P(ECX191FILES,"^",ECXCNT)
  1. . D GLBBKUP
  1. . Q
  1. ;
  1. D UPDATE ;change short description of existing clinic codes
  1. D BMES^XPDUTL("Update complete.")
  1. D MES^XPDUTL("")
  1. ;
  1. Q
  1. ;
  1. ADD ; Add new code
  1. ;
  1. N ECXI,ECXREC,ECXNM,ECXCODE,ECXIEN,ECXERR
  1. D BMES^XPDUTL(">>> Adding new CHAR4 code(s) to the NATIONAL CLINIC file (#728.441)...")
  1. ;
  1. F ECXI=1:1 S ECXREC=$P($T(ADDCLIN+ECXI),";;",2) Q:ECXREC="QUIT" D
  1. . S ECXNM=$P(ECXREC,U) ;Name
  1. . S ECXCODE=$P(ECXREC,U,2) ;Code
  1. . ; check if new code already exists in file 728.441
  1. . S ECXIEN=$$FIND1^DIC(728.441,"","X",ECXCODE,"","","ECXERR")
  1. . ; quit if error
  1. . I $D(ECXERR) D Q
  1. . . D BMES^XPDUTL(" >> ... Unable to add CHAR4 code "_ECXCODE_" - "_ECXNM_" to file.")
  1. . . D MES^XPDUTL(" >> ... "_$G(ECXERR("DIERR",1,"TEXT",1))_".")
  1. . . D MES^XPDUTL(" >> ... Please contact support for assistance...")
  1. . . K ECXERR
  1. . ; if code already exists, quit
  1. . I ECXIEN D Q
  1. . . D BMES^XPDUTL(" >> CHAR4 code "_ECXCODE_" - "_ECXNM_" already exists.")
  1. . ; if code does not exist, add new entry
  1. . ; set field values of new entry
  1. . K ECXFDA
  1. . S ECXFDA(728.441,"+1,",.01)=ECXCODE
  1. . S ECXFDA(728.441,"+1,",1)=ECXNM
  1. . ; add new entry
  1. . D UPDATE^DIE("E","ECXFDA","","ECXERR")
  1. . ; check if error
  1. . I '$D(ECXERR) D
  1. . . D BMES^XPDUTL(" >> CHAR4 Code "_ECXCODE_" - "_ECXNM_" added to file.")
  1. . I $D(ECXERR) D
  1. . . D BMES^XPDUTL(" >> ... Unable to add CHAR4 code "_ECXCODE_" "_ECXNM_" to file.")
  1. . . D MES^XPDUTL(" >> ... "_$G(ECXERR("DIERR",1,"TEXT",1))_".")
  1. . . D MES^XPDUTL(" >> ... Please contact support for assistance.")
  1. . . ; clean out error array b4 processing next code
  1. . . K ECXERR
  1. ;
  1. D BMES^XPDUTL(">>> Add new CHAR4 code(s) complete.")
  1. D MES^XPDUTL("")
  1. Q
  1. ;
  1. UPDATE ;changing short description of existing entries
  1. ;ECXREC is in format: code^short description
  1. ;
  1. N ECXCODE,ECXDESC,ECXIEN,DIE,DA,DR,ECXI,ECXREC,ECXERR
  1. ;
  1. D BMES^XPDUTL(">>> Updating entries in the NATIONAL CLINIC (728.441) file...")
  1. ;
  1. F ECXI=1:1 S ECXREC=$P($T(UPDCLIN+ECXI),";;",2) Q:ECXREC="QUIT" D
  1. .S ECXCODE=$P(ECXREC,"^"),ECXDESC=$P(ECXREC,"^",2)
  1. .S ECXIEN=$$FIND1^DIC(728.441,"","X",ECXCODE,"","","ECXERR")
  1. .I 'ECXIEN D Q
  1. ..D BMES^XPDUTL(">>>....Unable to find code: "_ECXCODE_".")
  1. ..D BMES^XPDUTL("*** Please contact support for assistance. ***")
  1. .K FDA
  1. .S FDA(728.441,ECXIEN_",",1)=ECXDESC
  1. .D FILE^DIE(,"FDA","ECXERR")
  1. .I '$D(ECXERR) D BMES^XPDUTL(">>>...."_ECXCODE_" - "_$P(ECXREC,U,2)_" updated")
  1. .I $D(ECXERR) D BMES^XPDUTL(">>>....Unable to update code "_ECXCODE_".") D
  1. ..D BMES^XPDUTL("*** Please contact support for assistance. ***")
  1. ;
  1. Q
  1. ;
  1. GLBBKUP ; XTMP Backup of file(s)
  1. S ECXBKUPNDE="ECX*3*191-Update NATIONAL CLINIC FY25 Char4 (#728.441)"
  1. S ^XTMP("ECX3P191",0)=$$FMADD^XLFDT(DT,120)_"^"_DT_"^"_ECXBKUPNDE
  1. M ^XTMP("ECX3P191",ECX191FILE,$H)=^ECX(ECX191FILE)
  1. Q
  1. ;
  1. ADDCLIN ;Add new code
  1. ;
  1. ;
  1. UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated
  1. ;;CDEC^CRH State Veterans Home (for Cleland Dole Pilot)
  1. ;;HTWC^Welch Allyn BP Machines
  1. ;;JCBC^Boothless Audiometry Clinic
  1. ;;MPAL^My Life My Story Program
  1. ;;WCRC^CRH Provider Type Not Assigned to other Char4
  1. ;;QUIT