ECX147PT.m

ECX147PT ;ALB/AG-ECX*3.0*147 Post-Init Rtn;10/8/13; ; 12/4/13 3:52pm

 ;;3.0;DSS EXTRACTS;**147**;Dec 22,1997;Build 4

 ;

 ;Post-init routine adding new entries and updating current entries to

 ;

 ;NATIONAL CLINIC file(#728.441)

 ;

 Q

 ;

EN ;

 ;Routine entry point

 D UNLOCK     ;unlock Data Dictionary to allow changes

 D ADDNEW     ;add new Clinic codes

 D UPDATE     ;change name to existing Clinic codes

 D LOCK       ;lock Data Dictionary to restrict changes

 Q

 ;

UNLOCK ;

 K ^DD(728.441,.01,7.5)

 N ECXI

 F ECXI=.01,1,3 S $P(^DD(728.441,ECXI,0),"^",2)=$TR($P(^DD(728.441,ECXI,0),"^",2),"I","")

 Q

ADDNEW ;Add new entry to file 728.441

 ;ECXREC is in format:code^short description

 ;

 ;

 N ECXFDA,ECXERR,ECXCODE,ECXREC,ECXI

 ;

 ;-get National Clinic record

 F ECXI=1:1 S ECXREC=$P($T(ADDCLIN+ECXI),";;",2) Q:ECXREC="QUIT"  D

 .;

 .;-National Clinic Code

 .S ECXCODE=$P(ECXREC,"^")

 .;

 .;-quit w/error message if entry already exists in file #728.441

 .I $$FIND1^DIC(728.441,"","X",ECXCODE) D  Q

 ..D BMES^XPDUTL(">>>..."_ECXCODE_" "_$P(ECXREC,U,2)_" not added, entry already exists.")

 ..D BMES^XPDUTL(">>> Contact Support for assistance.")

 .;

 .;Setup field values of new entry

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

 .S ECXFDA(728.441,"+1,",1)=$P(ECXREC,"^",2)

 .;

 .;-add new entry to file #728.441

 .D UPDATE^DIE("E","ECXFDA","","ECXERR")

 .;

 .I '$D(ECXERR) D BMES^XPDUTL(">>>...."_ECXCODE_" "_$P(ECXREC,U,2)_" added to file.")

 .I $D(ECXERR) D BMES^XPDUTL(">>>....Unable to add "_ECXCODE_" "_$P(ECXREC,U,2)_"     to file.") D

 ..D BMES^XPDUTL(">>>....Contact Support for assistance.")

 ;

 Q

UPDATE ;changing short description of existing clinic

 N ECXCODE,ECXDESC,ECXIEN,DIE,DA,DR,ECXI

 D BMES^XPDUTL(">>>Updating entry in the NATIONAL CLINIC (728.441) file...")

 I $P(^DD(728.441,.01,0),"^",2)["I" D  Q

 .D BMES^XPDUTL(">>Unable to update File 728.441 is locked")

 .D BMES^XPDUTL("Contact support for assistance")

 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,"","","ERR")

 .I 'ECXIEN D  Q

 ..D BMES^XPDUTL(">>>....Unable to add "_ECXCODE_" "_$P(ECXREC,U,2)_" to file.")

 ..D BMES^XPDUTL(">>>....Contact support for assistance")

 .S DIE="^ECX(728.441,",DA=ECXIEN,DR="1///^S X=ECXDESC"

 .D ^DIE

 .D BMES^XPDUTL(">>>...."_ECXCODE_" "_$P(ECXREC,U,2)_" updated")

 Q

 ;

LOCK ;

 N ECXI

 S ^DD(728.441,.01,7.5)="I $G(DIC(0))[""L"",'$D(ECX4CHAR) D EN^DDIOL(""Entries can only be added by CHAR4 Council."","""",""!?5"") K X"

 F ECXI=.01,1,3 I $P(^DD(728.441,ECXI,0),U,2)'["I" S $P(^DD(728.441,ECXI,0),U,2)=$P(^DD(728.441,ECXI,0),U,2)_"I" ;Makes all fields uneditable

 Q

ADDCLIN ;Contains the NATIONAL CLINIC entries to be added

 ;;AMSM^Antimicrb Stwrdshp MD

 ;;PEER^Peer Support

 ;;APSZ^E-Consult NP or CNS

 ;;CLSZ^E-Consult PSO or POD

 ;;PASZ^E-Consult PA

 ;;RESZ^E-Consult Resident/Fellow

 ;;VL5Z^E-Consult Contract Labor

 ;;QUIT

UPDCLIN ;Contains the NATIONAL CLINIC entry description to be updated

 ;;FEEZ^Profee

 ;;HDGC^Employment Specialist

 ;;RHAC^Reserved

 ;;RHEC^Rehab Audiology

 ;;RHFC^Rehab Blind Rehab

 ;;RHGC^Rehab Chiropractic

 ;;RHHC^Rehab KT

 ;;RHJC^Rehab MD

 ;;RHMC^Rehab OT

 ;;RHRC^Rehab RT

 ;;RHSC^Rehab SP

 ;;CNSZ^E-Consult MD/PSI/Gen'l

 ;;QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ECX147PT   3384     printed  Mar 13, 2025@20:54:21                                                                                                                                                                                                    Page 2

ECX147PT  ;ALB/AG-ECX*3.0*147 Post-Init Rtn;10/8/13; ; 12/4/13 3:52pm

 +1       ;;3.0;DSS EXTRACTS;**147**;Dec 22,1997;Build 4

 +2       ;

 +3       ;Post-init routine adding new entries and updating current entries to

 +4       ;

 +5       ;NATIONAL CLINIC file(#728.441)

 +6       ;

 +7        QUIT 

 +8       ;

EN        ;

 +1       ;Routine entry point

 +2       ;unlock Data Dictionary to allow changes

           DO UNLOCK

 +3       ;add new Clinic codes

           DO ADDNEW

 +4       ;change name to existing Clinic codes

           DO UPDATE

 +5       ;lock Data Dictionary to restrict changes

           DO LOCK

 +6        QUIT 

 +7       ;

UNLOCK    ;

 +1        KILL ^DD(728.441,.01,7.5)

 +2        NEW ECXI

 +3        FOR ECXI=.01,1,3

               SET $PIECE(^DD(728.441,ECXI,0),"^",2)=$TRANSLATE($PIECE(^DD(728.441,ECXI,0),"^",2),"I","")

 +4        QUIT 

ADDNEW    ;Add new entry to file 728.441

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

 +2       ;

 +3       ;

 +4        NEW ECXFDA,ECXERR,ECXCODE,ECXREC,ECXI

 +5       ;

 +6       ;-get National Clinic record

 +7        FOR ECXI=1:1

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

               if ECXREC="QUIT"

                   QUIT 

               Begin DoDot:1

 +8       ;

 +9       ;-National Clinic Code

 +10               SET ECXCODE=$PIECE(ECXREC,"^")

 +11      ;

 +12      ;-quit w/error message if entry already exists in file #728.441

 +13               IF $$FIND1^DIC(728.441,"","X",ECXCODE)

                       Begin DoDot:2

 +14                       DO BMES^XPDUTL(">>>..."_ECXCODE_" "_$PIECE(ECXREC,U,2)_" not added, entry already exists.")

 +15                       DO BMES^XPDUTL(">>> Contact Support for assistance.")

                       End DoDot:2

                       QUIT 

 +16      ;

 +17      ;Setup field values of new entry

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

 +19               SET ECXFDA(728.441,"+1,",1)=$PIECE(ECXREC,"^",2)

 +20      ;

 +21      ;-add new entry to file #728.441

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

 +23      ;

 +24               IF '$DATA(ECXERR)

                       DO BMES^XPDUTL(">>>...."_ECXCODE_" "_$PIECE(ECXREC,U,2)_" added to file.")

 +25               IF $DATA(ECXERR)

                       DO BMES^XPDUTL(">>>....Unable to add "_ECXCODE_" "_$PIECE(ECXREC,U,2)_"     to file.")

                       Begin DoDot:2

 +26                       DO BMES^XPDUTL(">>>....Contact Support for assistance.")

                       End DoDot:2

               End DoDot:1

 +27      ;

 +28       QUIT 

UPDATE    ;changing short description of existing clinic

 +1        NEW ECXCODE,ECXDESC,ECXIEN,DIE,DA,DR,ECXI

 +2        DO BMES^XPDUTL(">>>Updating entry in the NATIONAL CLINIC (728.441) file...")

 +3        IF $PIECE(^DD(728.441,.01,0),"^",2)["I"

               Begin DoDot:1

 +4                DO BMES^XPDUTL(">>Unable to update File 728.441 is locked")

 +5                DO BMES^XPDUTL("Contact support for assistance")

               End DoDot:1

               QUIT 

 +6        FOR ECXI=1:1

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

               if ECXREC="QUIT"

                   QUIT 

               Begin DoDot:1

 +7                SET ECXCODE=$PIECE(ECXREC,"^")

                   SET ECXDESC=$PIECE(ECXREC,"^",2)

 +8                SET ECXIEN=$$FIND1^DIC(728.441,"","X",ECXCODE,"","","ERR")

 +9                IF 'ECXIEN

                       Begin DoDot:2

 +10                       DO BMES^XPDUTL(">>>....Unable to add "_ECXCODE_" "_$PIECE(ECXREC,U,2)_" to file.")

 +11                       DO BMES^XPDUTL(">>>....Contact support for assistance")

                       End DoDot:2

                       QUIT 

 +12               SET DIE="^ECX(728.441,"

                   SET DA=ECXIEN

                   SET DR="1///^S X=ECXDESC"

 +13               DO ^DIE

 +14               DO BMES^XPDUTL(">>>...."_ECXCODE_" "_$PIECE(ECXREC,U,2)_" updated")

               End DoDot:1

 +15       QUIT 

 +16      ;

LOCK      ;

 +1        NEW ECXI

 +2        SET ^DD(728.441,.01,7.5)="I $G(DIC(0))[""L"",'$D(ECX4CHAR) D EN^DDIOL(""Entries can only be added by CHAR4 Council."","""",""!?5"") K X"

 +3       ;Makes all fields uneditable

           FOR ECXI=.01,1,3

               IF $PIECE(^DD(728.441,ECXI,0),U,2)'["I"

                   SET $PIECE(^DD(728.441,ECXI,0),U,2)=$PIECE(^DD(728.441,ECXI,0),U,2)_"I"

 +4        QUIT 

ADDCLIN   ;Contains the NATIONAL CLINIC entries to be added

 +1       ;;AMSM^Antimicrb Stwrdshp MD

 +2       ;;PEER^Peer Support

 +3       ;;APSZ^E-Consult NP or CNS

 +4       ;;CLSZ^E-Consult PSO or POD

 +5       ;;PASZ^E-Consult PA

 +6       ;;RESZ^E-Consult Resident/Fellow

 +7       ;;VL5Z^E-Consult Contract Labor

 +8       ;;QUIT

UPDCLIN   ;Contains the NATIONAL CLINIC entry description to be updated

 +1       ;;FEEZ^Profee

 +2       ;;HDGC^Employment Specialist

 +3       ;;RHAC^Reserved

 +4       ;;RHEC^Rehab Audiology

 +5       ;;RHFC^Rehab Blind Rehab

 +6       ;;RHGC^Rehab Chiropractic

 +7       ;;RHHC^Rehab KT

 +8       ;;RHJC^Rehab MD

 +9       ;;RHMC^Rehab OT

 +10      ;;RHRC^Rehab RT

 +11      ;;RHSC^Rehab SP

 +12      ;;CNSZ^E-Consult MD/PSI/Gen'l

 +13      ;;QUIT