ECX3P183.m

ECX3P183 ;MNT/TXH - NATIONAL CLINIC (#728.441) File Update; OCT 18, 2021@14:42

 ;;3.0;DSS EXTRACTS;**183**;Dec 22, 1997;Build 3

 ;

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

 ; file for FY22 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

 ;;Sexual Orientation and Gender Identity^SOGI^^

 ;;VET HOME^VTHM^^

 ;;QUIT

 ;

UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated

 ;;CDQC^COVID-19 VACCINATION CLINIC

 ;;CDDC^CCC Pharmacist

 ;;CDLC^CCC NP

 ;;CDMC^CCC MD/DO

 ;;CDPC^CCC PA

 ;;CDRC^CCC RN

 ;;CNSP^Suicide Prevention Clinical Telehealth HUB

 ;;NASP^Suicide Prevention Clinical Telehealth SPOKE

 ;;DEHC^Environmental Health Registry Exams

 ;;IDMC^INTERMEDIATE CARE TECHNICIAN

 ;;NASO^National Tele-Neurology Program (NTNP)

 ;;NASZ^National Tele-Oncology (NTO)

 ;;PLCH^Hospice Pharmacist

 ;;PLMT^Surgical/Orthopedics Pain Pharmacist

 ;;PLPS^Polytrauma Psychiatrist

 ;;PNFC^Pain Team Conference

 ;;PNRD^Pain Management MD

 ;;PNSW^PAIN MANAGEMENT BEHAVIORAL HEALTH

 ;;PNWC^Pain Opioid Management

 ;;MBSR^Mindfulness Based Interventions

 ;;MDTN^Meditation (non-mindfulness-based intervention)

 ;;STUD^Student Provider

 ;;MPAK^Mobile Prosthetic and Orthotic Care (MoPOC)

 ;;AGTO^CHAR4 COUNCIL

 ;;EXPX^CHAR4 COUNCIL

 ;;GULF^CHAR4 COUNCIL

 ;;QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ECX3P183   4378     printed  Feb 18, 2025@23:17:01                                                                                                                                                                                                    Page 2

ECX3P183  ;MNT/TXH - NATIONAL CLINIC (#728.441) File Update; OCT 18, 2021@14:42

 +1       ;;3.0;DSS EXTRACTS;**183**;Dec 22, 1997;Build 3

 +2       ;

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

 +4       ; file for FY22 Mid-Year.

 +5       ;

 +6       ; Reference(s) to $$FIND1^DIC supported by ICR# 2051

 +7       ; Reference(s) to FILE^DIE supported by ICR# 2053

 +8       ; Reference(s) to UPDATE^DIE supported by ICR# 2053

 +9       ; Reference(s) to BMES^XPDUTL supported by ICR# 10141

 +10      ; Reference(s) to MES^XPDUTL supported by ICR# 10141

 +11      ;

 +12       QUIT 

 +13      ;

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       ;;Sexual Orientation and Gender Identity^SOGI^^

 +2       ;;VET HOME^VTHM^^

 +3       ;;QUIT

 +4       ;

UPDCLIN   ;Contains the NATIONAL CLINIC entry description to be updated

 +1       ;;CDQC^COVID-19 VACCINATION CLINIC

 +2       ;;CDDC^CCC Pharmacist

 +3       ;;CDLC^CCC NP

 +4       ;;CDMC^CCC MD/DO

 +5       ;;CDPC^CCC PA

 +6       ;;CDRC^CCC RN

 +7       ;;CNSP^Suicide Prevention Clinical Telehealth HUB

 +8       ;;NASP^Suicide Prevention Clinical Telehealth SPOKE

 +9       ;;DEHC^Environmental Health Registry Exams

 +10      ;;IDMC^INTERMEDIATE CARE TECHNICIAN

 +11      ;;NASO^National Tele-Neurology Program (NTNP)

 +12      ;;NASZ^National Tele-Oncology (NTO)

 +13      ;;PLCH^Hospice Pharmacist

 +14      ;;PLMT^Surgical/Orthopedics Pain Pharmacist

 +15      ;;PLPS^Polytrauma Psychiatrist

 +16      ;;PNFC^Pain Team Conference

 +17      ;;PNRD^Pain Management MD

 +18      ;;PNSW^PAIN MANAGEMENT BEHAVIORAL HEALTH

 +19      ;;PNWC^Pain Opioid Management

 +20      ;;MBSR^Mindfulness Based Interventions

 +21      ;;MDTN^Meditation (non-mindfulness-based intervention)

 +22      ;;STUD^Student Provider

 +23      ;;MPAK^Mobile Prosthetic and Orthotic Care (MoPOC)

 +24      ;;AGTO^CHAR4 COUNCIL

 +25      ;;EXPX^CHAR4 COUNCIL

 +26      ;;GULF^CHAR4 COUNCIL

 +27      ;;QUIT