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

ECX3P182.m

Go to the documentation of this file.
  1. ECX3P182 ;MNT/TXH - NATIONAL CLINIC (#728.441) File Update; May 26, 2021@16:03
  1. ;;3.0;DSS EXTRACTS;**182**;Dec 22, 1997;Build 2
  1. ;
  1. ; Post-init routine updating entries in the NATIONAL CLINIC (#728.441) file
  1. ; for FY22.
  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. D BMES^XPDUTL("Update NATIONAL CLINIC (#728.441) file starts.")
  1. D ADD ;add new code
  1. ;D UPDATE ;change short description of existing clinic codes - No FY22 Request
  1. D MES^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. ADDCLIN ;Add new code
  1. ;;SCEPTER CSP Back Pain Study^SPTR^^
  1. ;;Intimate Partner Violence Assistance Program^IPVP^^
  1. ;;IPVAP Strength at Home Program^IPVS^^
  1. ;;QUIT
  1. ;
  1. UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated
  1. ;;QUIT