ECX3P186 ;MNTVBB/DMR - NATIONAL CLINIC (#728.441) File Update; FEB 1, 2023@14:42
;;3.0;DSS EXTRACTS;**186**;Dec 22, 1997;Build 2
;;Per VA Directive 6402, this routine should not be modified.
;
; Post-init routine updating entries in the NATIONAL CLINIC (#728.441)
; file for FY23 Mid-Year.
;
; Reference(s) to $$FIND1^DIC supported by ICR# 2051
; Reference(s) to FILE^DIE supported by ICR# 2053
; Reference(s) to UPDATE^DIE supported by ICR# 2053
; Reference(s) to BMES^XPDUTL supported by ICR# 10141
; Reference(s) to MES^XPDUTL supported by ICR# 10141
;
Q
;
POST ;routine entry point
;
D BMES^XPDUTL("Update NATIONAL CLINIC (#728.441) file starts.")
D ADD ;add new code
D UPDATE ;change short description of existing clinic codes
D BMES^XPDUTL("Update complete.")
D MES^XPDUTL("")
;
Q
;
ADD ; Add new code
;
N ECXI,ECXREC,ECXNM,ECXCODE,ECXIEN,ECXERR
D BMES^XPDUTL(">>> Adding new CHAR4 code(s) to the NATIONAL CLINIC file (#728.441)...")
;
F ECXI=1:1 S ECXREC=$P($T(ADDCLIN+ECXI),";;",2) Q:ECXREC="QUIT" D
. S ECXNM=$P(ECXREC,U) ;Name
. S ECXCODE=$P(ECXREC,U,2) ;Code
. ; check if new code already exists in file 728.441
. S ECXIEN=$$FIND1^DIC(728.441,"","X",ECXCODE,"","","ECXERR")
. ; quit if error
. I $D(ECXERR) D Q
. . D BMES^XPDUTL(" >> ... Unable to add CHAR4 code "_ECXCODE_" - "_ECXNM_" to file.")
. . D MES^XPDUTL(" >> ... "_$G(ECXERR("DIERR",1,"TEXT",1))_".")
. . D MES^XPDUTL(" >> ... Please contact support for assistance...")
. . K ECXERR
. ; if code already exists, quit
. I ECXIEN D Q
. . D BMES^XPDUTL(" >> CHAR4 code "_ECXCODE_" - "_ECXNM_" already exists.")
. ; if code does not exist, add new entry
. ; set field values of new entry
. K ECXFDA
. S ECXFDA(728.441,"+1,",.01)=ECXCODE
. S ECXFDA(728.441,"+1,",1)=ECXNM
. ; add new entry
. D UPDATE^DIE("E","ECXFDA","","ECXERR")
. ; check if error
. I '$D(ECXERR) D
. . D BMES^XPDUTL(" >> CHAR4 Code "_ECXCODE_" - "_ECXNM_" added to file.")
. I $D(ECXERR) D
. . D BMES^XPDUTL(" >> ... Unable to add CHAR4 code "_ECXCODE_" "_ECXNM_" to file.")
. . D MES^XPDUTL(" >> ... "_$G(ECXERR("DIERR",1,"TEXT",1))_".")
. . D MES^XPDUTL(" >> ... Please contact support for assistance.")
. . ; clean out error array b4 processing next code
. . K ECXERR
;
D BMES^XPDUTL(">>> Add new CHAR4 code(s) complete.")
D MES^XPDUTL("")
Q
;
UPDATE ;changing short description of existing entries
;ECXREC is in format: code^short description
;
N ECXCODE,ECXDESC,ECXIEN,DIE,DA,DR,ECXI,ECXREC,ECXERR
;
D BMES^XPDUTL(">>> Updating entries in the NATIONAL CLINIC (728.441) file...")
;
F ECXI=1:1 S ECXREC=$P($T(UPDCLIN+ECXI),";;",2) Q:ECXREC="QUIT" D
.S ECXCODE=$P(ECXREC,"^"),ECXDESC=$P(ECXREC,"^",2)
.S ECXIEN=$$FIND1^DIC(728.441,"","X",ECXCODE,"","","ECXERR")
.I 'ECXIEN D Q
..D BMES^XPDUTL(">>>....Unable to find code: "_ECXCODE_".")
..D BMES^XPDUTL("*** Please contact support for assistance. ***")
.K FDA
.S FDA(728.441,ECXIEN_",",1)=ECXDESC
.D FILE^DIE(,"FDA","ECXERR")
.I '$D(ECXERR) D BMES^XPDUTL(">>>...."_ECXCODE_" - "_$P(ECXREC,U,2)_" updated")
.I $D(ECXERR) D BMES^XPDUTL(">>>....Unable to update code "_ECXCODE_".") D
..D BMES^XPDUTL("*** Please contact support for assistance. ***")
;
Q
;
ADDCLIN ;Add new code
;;QUIT
;
UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated
;;CGEC^CRH Environmental Registry
;;CGLC^Long COVID Care
;;CGTC^Care Coordination Review Team (CCRT)
;;COLL^Primary Care MH Integration CoCM
;;DEAC^Inpatient Pharmacist Anticoagulation Clinic
;;DEBC^CRH Long COVID
;;DEDC^CRH Low Vision OD
;;DEEC^CRH BROS/CATIS
;;DEFC^CRH BRS
;;DEGC^Inpatient Geriatrics Pharmacist
;;DELC^CRH VIST
;;DEMC^CRH Registered Dietician
;;DENC^CRH Registered Audiologist
;;DEPC^PACT Pharmacy Clinics
;;HDMC^Telemental Health Home Hospice
;;HDPC^Inpatient Mental Health Pharmacist
;;IDEC^Inpatient Pharmacist Antimicrobial Stewardship
;;IDFC^Inpatient Pharmacist Cardiology Clinic
;;IDGC^Inpatient Pharmacist Critical Care Clinic
;;IDJC^Inpatient Pharmacist General MTM Services Clinic
;;IDKC^Inpatient Pharmacist Infectious Disease Clinic
;;IDLC^Inpatient Pharmacist Internal Medicine Clinic
;;IDPC^Inpatient Meds Reconciliation/Discharge Counseling
;;IDQC^Inpatient Pharmacist Nutrition Support Clinic
;;IDRC^Inpatient Pharmacist Oncology Clinic
;;IDUC^Inpatient Pharmacist Pharmacokinetics
;;IDVC^Inpatient Pharmacist Spinal Cord Injury Clinic
;;IDWC^Inpatient Pharmacist Surgery Clinic
;;MPAX^Monkey Pox Vaccination Clinics
;;POPP^Mental Health Integration CoCM
;;XYEL^Integrated Mental Health for Specialty Clinics
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECX3P186 4792 printed Apr 09, 2024@20:55:01 Page 2
ECX3P186 ;MNTVBB/DMR - NATIONAL CLINIC (#728.441) File Update; FEB 1, 2023@14:42
+1 ;;3.0;DSS EXTRACTS;**186**;Dec 22, 1997;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Post-init routine updating entries in the NATIONAL CLINIC (#728.441)
+5 ; file for FY23 Mid-Year.
+6 ;
+7 ; Reference(s) to $$FIND1^DIC supported by ICR# 2051
+8 ; Reference(s) to FILE^DIE supported by ICR# 2053
+9 ; Reference(s) to UPDATE^DIE supported by ICR# 2053
+10 ; Reference(s) to BMES^XPDUTL supported by ICR# 10141
+11 ; Reference(s) to MES^XPDUTL supported by ICR# 10141
+12 ;
+13 QUIT
+14 ;
POST ;routine entry point
+1 ;
+2 DO BMES^XPDUTL("Update NATIONAL CLINIC (#728.441) file starts.")
+3 ;add new code
DO ADD
+4 ;change short description of existing clinic codes
DO UPDATE
+5 DO BMES^XPDUTL("Update complete.")
+6 DO MES^XPDUTL("")
+7 ;
+8 QUIT
+9 ;
ADD ; Add new code
+1 ;
+2 NEW ECXI,ECXREC,ECXNM,ECXCODE,ECXIEN,ECXERR
+3 DO BMES^XPDUTL(">>> Adding new CHAR4 code(s) to the NATIONAL CLINIC file (#728.441)...")
+4 ;
+5 FOR ECXI=1:1
SET ECXREC=$PIECE($TEXT(ADDCLIN+ECXI),";;",2)
if ECXREC="QUIT"
QUIT
Begin DoDot:1
+6 ;Name
SET ECXNM=$PIECE(ECXREC,U)
+7 ;Code
SET ECXCODE=$PIECE(ECXREC,U,2)
+8 ; check if new code already exists in file 728.441
+9 SET ECXIEN=$$FIND1^DIC(728.441,"","X",ECXCODE,"","","ECXERR")
+10 ; quit if error
+11 IF $DATA(ECXERR)
Begin DoDot:2
+12 DO BMES^XPDUTL(" >> ... Unable to add CHAR4 code "_ECXCODE_" - "_ECXNM_" to file.")
+13 DO MES^XPDUTL(" >> ... "_$GET(ECXERR("DIERR",1,"TEXT",1))_".")
+14 DO MES^XPDUTL(" >> ... Please contact support for assistance...")
+15 KILL ECXERR
End DoDot:2
QUIT
+16 ; if code already exists, quit
+17 IF ECXIEN
Begin DoDot:2
+18 DO BMES^XPDUTL(" >> CHAR4 code "_ECXCODE_" - "_ECXNM_" already exists.")
End DoDot:2
QUIT
+19 ; if code does not exist, add new entry
+20 ; set field values of new entry
+21 KILL ECXFDA
+22 SET ECXFDA(728.441,"+1,",.01)=ECXCODE
+23 SET ECXFDA(728.441,"+1,",1)=ECXNM
+24 ; add new entry
+25 DO UPDATE^DIE("E","ECXFDA","","ECXERR")
+26 ; check if error
+27 IF '$DATA(ECXERR)
Begin DoDot:2
+28 DO BMES^XPDUTL(" >> CHAR4 Code "_ECXCODE_" - "_ECXNM_" added to file.")
End DoDot:2
+29 IF $DATA(ECXERR)
Begin DoDot:2
+30 DO BMES^XPDUTL(" >> ... Unable to add CHAR4 code "_ECXCODE_" "_ECXNM_" to file.")
+31 DO MES^XPDUTL(" >> ... "_$GET(ECXERR("DIERR",1,"TEXT",1))_".")
+32 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
+33 ; clean out error array b4 processing next code
+34 KILL ECXERR
End DoDot:2
End DoDot:1
+35 ;
+36 DO BMES^XPDUTL(">>> Add new CHAR4 code(s) complete.")
+37 DO MES^XPDUTL("")
+38 QUIT
+39 ;
UPDATE ;changing short description of existing entries
+1 ;ECXREC is in format: code^short description
+2 ;
+3 NEW ECXCODE,ECXDESC,ECXIEN,DIE,DA,DR,ECXI,ECXREC,ECXERR
+4 ;
+5 DO BMES^XPDUTL(">>> Updating entries in the NATIONAL CLINIC (728.441) file...")
+6 ;
+7 FOR ECXI=1:1
SET ECXREC=$PIECE($TEXT(UPDCLIN+ECXI),";;",2)
if ECXREC="QUIT"
QUIT
Begin DoDot:1
+8 SET ECXCODE=$PIECE(ECXREC,"^")
SET ECXDESC=$PIECE(ECXREC,"^",2)
+9 SET ECXIEN=$$FIND1^DIC(728.441,"","X",ECXCODE,"","","ECXERR")
+10 IF 'ECXIEN
Begin DoDot:2
+11 DO BMES^XPDUTL(">>>....Unable to find code: "_ECXCODE_".")
+12 DO BMES^XPDUTL("*** Please contact support for assistance. ***")
End DoDot:2
QUIT
+13 KILL FDA
+14 SET FDA(728.441,ECXIEN_",",1)=ECXDESC
+15 DO FILE^DIE(,"FDA","ECXERR")
+16 IF '$DATA(ECXERR)
DO BMES^XPDUTL(">>>...."_ECXCODE_" - "_$PIECE(ECXREC,U,2)_" updated")
+17 IF $DATA(ECXERR)
DO BMES^XPDUTL(">>>....Unable to update code "_ECXCODE_".")
Begin DoDot:2
+18 DO BMES^XPDUTL("*** Please contact support for assistance. ***")
End DoDot:2
End DoDot:1
+19 ;
+20 QUIT
+21 ;
ADDCLIN ;Add new code
+1 ;;QUIT
+2 ;
UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated
+1 ;;CGEC^CRH Environmental Registry
+2 ;;CGLC^Long COVID Care
+3 ;;CGTC^Care Coordination Review Team (CCRT)
+4 ;;COLL^Primary Care MH Integration CoCM
+5 ;;DEAC^Inpatient Pharmacist Anticoagulation Clinic
+6 ;;DEBC^CRH Long COVID
+7 ;;DEDC^CRH Low Vision OD
+8 ;;DEEC^CRH BROS/CATIS
+9 ;;DEFC^CRH BRS
+10 ;;DEGC^Inpatient Geriatrics Pharmacist
+11 ;;DELC^CRH VIST
+12 ;;DEMC^CRH Registered Dietician
+13 ;;DENC^CRH Registered Audiologist
+14 ;;DEPC^PACT Pharmacy Clinics
+15 ;;HDMC^Telemental Health Home Hospice
+16 ;;HDPC^Inpatient Mental Health Pharmacist
+17 ;;IDEC^Inpatient Pharmacist Antimicrobial Stewardship
+18 ;;IDFC^Inpatient Pharmacist Cardiology Clinic
+19 ;;IDGC^Inpatient Pharmacist Critical Care Clinic
+20 ;;IDJC^Inpatient Pharmacist General MTM Services Clinic
+21 ;;IDKC^Inpatient Pharmacist Infectious Disease Clinic
+22 ;;IDLC^Inpatient Pharmacist Internal Medicine Clinic
+23 ;;IDPC^Inpatient Meds Reconciliation/Discharge Counseling
+24 ;;IDQC^Inpatient Pharmacist Nutrition Support Clinic
+25 ;;IDRC^Inpatient Pharmacist Oncology Clinic
+26 ;;IDUC^Inpatient Pharmacist Pharmacokinetics
+27 ;;IDVC^Inpatient Pharmacist Spinal Cord Injury Clinic
+28 ;;IDWC^Inpatient Pharmacist Surgery Clinic
+29 ;;MPAX^Monkey Pox Vaccination Clinics
+30 ;;POPP^Mental Health Integration CoCM
+31 ;;XYEL^Integrated Mental Health for Specialty Clinics
+32 ;;QUIT
