ECX3P188.m

ECX3P188 ;MNTVBB/DMR - NATIONAL CLINIC (#728.441) File Update; May 15, 2023@15:03 ; 7/18/23 1:10pm

 ;;3.0;DSS EXTRACTS;**188**;May 15, 2023;Build 5

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

 ;

 ; Post-init routine updating entries in the NATIONAL CLINIC (#728.441)

 ; file for FY24.

 ;

 ; 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

 ;ECXREC is in format: ;;short description^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,1)   ;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

 ;;Care Coordination Review Team (CCRT)^CCRT^^

 ;;Certified Registered Nurse Anesthetist^CRNA^^

 ;;HPACT Mobile Medical Unit (MMU)^HMMU^^

 ;;Homeless Patient Aligned Care Team (HPACT)^HPAC^^

 ;;Nursing Home to Home RN^NHRN^^

 ;;QUIT

 ;

UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated

 ;;CDSC^CRH Toxic Exposure Screening (TES)

 ;;CGPC^CRH Interdisciplinary Team Meeting With Patient

 ;;CGTC^CHAR4 COUNCIL

 ;;CGWC^CRH Interdisciplinary Team Meeting Without Patient

 ;;CNSG^E-Consult RN/CRNA

 ;;DEUC^Tele Emergency Care PA

 ;;DMUC^Tele Emergency Care MD

 ;;NASG^NTO Program Genetic Counseling

 ;;NAST^NTO Program Clinical Trials

 ;;NASU^NTO Program Close to Me

 ;;NASW^NTO Breast Gynecologic Oncology SoE (BGSOE)

 ;;NASX^Environmental Toxic Exposure Screening

 ;;NASY^NTO Program Advanced Practice Provider (APP)

 ;;PNUC^Tele Emergency Care NP

 ;;QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ECX3P188   4333     printed  Mar 13, 2025@20:55:21                                                                                                                                                                                                    Page 2

ECX3P188  ;MNTVBB/DMR - NATIONAL CLINIC (#728.441) File Update; May 15, 2023@15:03 ; 7/18/23 1:10pm

 +1       ;;3.0;DSS EXTRACTS;**188**;May 15, 2023;Build 5

 +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 FY24.

 +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       QUIT 

 +13      ;

POST      ;routine entry point

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

 +2       ;add new code

           DO ADD

 +3       ;change short description of existing clinic codes

           DO UPDATE

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

 +5        DO MES^XPDUTL("")

 +6        QUIT 

 +7       ;

ADD       ; Add new code

 +1       ;ECXREC is in format: ;;short description^code^^

 +2       ;

 +3        NEW ECXI,ECXREC,ECXNM,ECXCODE,ECXIEN,ECXERR

 +4        DO BMES^XPDUTL(">>> Adding new CHAR4 code(s) to the NATIONAL CLINIC file (#728.441)...")

 +5       ;

 +6        FOR ECXI=1:1

               SET ECXREC=$PIECE($TEXT(ADDCLIN+ECXI),";;",2)

               if ECXREC="QUIT"

                   QUIT 

               Begin DoDot:1

 +7       ;Name

                   SET ECXNM=$PIECE(ECXREC,U,1)

 +8       ;Code

                   SET ECXCODE=$PIECE(ECXREC,U,2)

 +9       ; check if new code already exists in file 728.441

 +10               SET ECXIEN=$$FIND1^DIC(728.441,"","X",ECXCODE,"","","ECXERR")

 +11      ; quit if error

 +12               IF $DATA(ECXERR)

                       Begin DoDot:2

 +13                       DO BMES^XPDUTL("       >> ... Unable to add CHAR4 code "_ECXCODE_" - "_ECXNM_" to file.")

 +14                       DO MES^XPDUTL("        >> ... "_$GET(ECXERR("DIERR",1,"TEXT",1))_".")

 +15                       DO MES^XPDUTL("        >> ... Please contact support for assistance...")

 +16                       KILL ECXERR

                       End DoDot:2

                       QUIT 

 +17      ; if code already exists, quit

 +18               IF ECXIEN

                       Begin DoDot:2

 +19                       DO BMES^XPDUTL("    >> CHAR4 code "_ECXCODE_" - "_ECXNM_" already exists.")

                       End DoDot:2

                       QUIT 

 +20      ; if code does not exist, add new entry

 +21      ; set field values of new entry

 +22               KILL ECXFDA

 +23               SET ECXFDA(728.441,"+1,",.01)=ECXCODE

 +24               SET ECXFDA(728.441,"+1,",1)=ECXNM

 +25      ; add new entry

 +26               DO UPDATE^DIE("E","ECXFDA","","ECXERR")

 +27      ; check if error

 +28               IF '$DATA(ECXERR)

                       Begin DoDot:2

 +29                       DO BMES^XPDUTL("    >> CHAR4 Code "_ECXCODE_" - "_ECXNM_" added to file.")

                       End DoDot:2

 +30               IF $DATA(ECXERR)

                       Begin DoDot:2

 +31                       DO BMES^XPDUTL("    >> ... Unable to add CHAR4 code "_ECXCODE_" "_ECXNM_" to file.")

 +32                       DO MES^XPDUTL("    >> ... "_$GET(ECXERR("DIERR",1,"TEXT",1))_".")

 +33                       DO MES^XPDUTL("    >> ... Please contact support for assistance.")

 +34      ; clean out error array b4 processing next code

 +35                       KILL ECXERR

                       End DoDot:2

               End DoDot:1

 +36      ;

 +37       DO BMES^XPDUTL(">>> Add new CHAR4 code(s) complete.")

 +38       DO MES^XPDUTL("")

 +39       QUIT 

 +40      ;

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       QUIT 

 +20      ;

ADDCLIN   ;Add new code

 +1       ;;Care Coordination Review Team (CCRT)^CCRT^^

 +2       ;;Certified Registered Nurse Anesthetist^CRNA^^

 +3       ;;HPACT Mobile Medical Unit (MMU)^HMMU^^

 +4       ;;Homeless Patient Aligned Care Team (HPACT)^HPAC^^

 +5       ;;Nursing Home to Home RN^NHRN^^

 +6       ;;QUIT

 +7       ;

UPDCLIN   ;Contains the NATIONAL CLINIC entry description to be updated

 +1       ;;CDSC^CRH Toxic Exposure Screening (TES)

 +2       ;;CGPC^CRH Interdisciplinary Team Meeting With Patient

 +3       ;;CGTC^CHAR4 COUNCIL

 +4       ;;CGWC^CRH Interdisciplinary Team Meeting Without Patient

 +5       ;;CNSG^E-Consult RN/CRNA

 +6       ;;DEUC^Tele Emergency Care PA

 +7       ;;DMUC^Tele Emergency Care MD

 +8       ;;NASG^NTO Program Genetic Counseling

 +9       ;;NAST^NTO Program Clinical Trials

 +10      ;;NASU^NTO Program Close to Me

 +11      ;;NASW^NTO Breast Gynecologic Oncology SoE (BGSOE)

 +12      ;;NASX^Environmental Toxic Exposure Screening

 +13      ;;NASY^NTO Program Advanced Practice Provider (APP)

 +14      ;;PNUC^Tele Emergency Care NP

 +15      ;;QUIT