ECX3P189.m

ECX3P189 ;MNTVBB/DTA - NATIONAL CLINIC (#728.441) File Update; FEB 1, 2024@16:44

 ;;3.0;DSS EXTRACTS;**189**;Dec 22, 1997;Build 6

 ;;Per VA Directive 6402, this routine should not be modified.

 ;

 ; This routine is used as a post-init in a KIDS build to

 ; update the NATIONAL CLINIC (#728.441) file for FY24 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

 ;

 ; Start of Install

 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

 ;;National Tele-Rheumatology Program (NTRP)^NTRP^^

 ;;QUIT

 ;

UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated

 ;;CGNC^CRH Whole Health (WH)

 ;;CNSF^Surgical Pause/Frailty Evaluation Clinics

 ;;HDLC^Home Based Primary Care Home Health Aide (Pilot)

 ;;HTBC^NEXCSS Phone

 ;;MPAZ^National Mind Brain Program (MBP)

 ;;NASN^Suicide Prevention Coordinator-Team Clinics

 ;;NASR^National Tele-Palliative Care Program

 ;;WCLC^Anatomical-Clinical Pathology

 ;;WCMC^Molecular Pathology

 ;;WCTC^Transfusion Pathology

 ;;QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ECX3P189   3987     printed  Apr 23, 2025@18:05:10                                                                                                                                                                                                    Page 2

ECX3P189  ;MNTVBB/DTA - NATIONAL CLINIC (#728.441) File Update; FEB 1, 2024@16:44

 +1       ;;3.0;DSS EXTRACTS;**189**;Dec 22, 1997;Build 6

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;

 +4       ; This routine is used as a post-init in a KIDS build to

 +5       ; update the NATIONAL CLINIC (#728.441) file for FY24 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       ; Start of Install

 +3        DO BMES^XPDUTL("Update NATIONAL CLINIC (#728.441) file starts.")

 +4       ;add new code

           DO ADD

 +5       ;change short description of existing clinic codes

           DO UPDATE

 +6        DO BMES^XPDUTL("Update complete.")

 +7        DO MES^XPDUTL("")

 +8       ;

 +9        QUIT 

 +10      ;

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       ;;National Tele-Rheumatology Program (NTRP)^NTRP^^

 +2       ;;QUIT

 +3       ;

UPDCLIN   ;Contains the NATIONAL CLINIC entry description to be updated

 +1       ;;CGNC^CRH Whole Health (WH)

 +2       ;;CNSF^Surgical Pause/Frailty Evaluation Clinics

 +3       ;;HDLC^Home Based Primary Care Home Health Aide (Pilot)

 +4       ;;HTBC^NEXCSS Phone

 +5       ;;MPAZ^National Mind Brain Program (MBP)

 +6       ;;NASN^Suicide Prevention Coordinator-Team Clinics

 +7       ;;NASR^National Tele-Palliative Care Program

 +8       ;;WCLC^Anatomical-Clinical Pathology

 +9       ;;WCMC^Molecular Pathology

 +10      ;;WCTC^Transfusion Pathology

 +11      ;;QUIT