SD53MY21.m

SD53MY21 ;ALB/TXH - FY21 MID-YEAR STOP CODE UPDATES; SEP 22, 2020@10:40

 ;;5.3;Scheduling;**770**;AUG 13, 1993;Build 4

 ;

 ; Post-install routine updating stop codes in CLINIC STOP file

 ; (#40.7) for FY21 mid-year updates - effective 04/01/2021.

 ;

 ; References to $$FIND1^DIC supported by ICR# 2051

 ; References to FILE^DIE supported by ICR# 2053

 ; References to BMES^XPDUTL supported by ICR# 10141

 ; References to MES^XPDUTL supported by ICR# 10141

 ;

 Q

 ;

POST ; Update stop codes in Clinic Stop file 40.7

 ;

 D BMES^XPDUTL("SD*5.3*770 Post-Install starts...")

 D:$P($T(ACT+1),";;",2)'="QUIT" REACT    ; reactivate code

 D:$P($T(CHG+1),";;",2)'="QUIT" CHGNM    ; change name

 D BMES^XPDUTL("SD*5.3*770 Post-Install complete.")

 D MES^XPDUTL("")

 K SDIEN,%H,%I,DIC,X,Y

 Q

 ;

REACT ; Reactivate code

 ; SDREC is in format: ;;code #^

 ;

 N SDDA,SDX,SDXX,DA,DIE,DR,SDERR

 D BMES^XPDUTL(">>> Reactivating Clinic Stop in CLINIC STOP (#40.7) file...")

 ;

 ; Load entries

 F SDX=1:1 K DD,DO,DA S SDXX=$P($T(ACT+SDX),";;",2) Q:SDXX="QUIT"  D

 . S SDDA=+$O(^DIC(40.7,"C",+SDXX,0))

 . ; Check if inactive

 . I $P($G(^DIC(40.7,SDDA,0)),U,3)'="" D

 . . K SDFDA

 . . S SDFDA(40.7,SDDA_",",2)=""

 . . D FILE^DIE(,"SDFDA","SDERR")

 . . ; check if error

 . . I '$D(SDERR) D BMES^XPDUTL("     Reactivated: "_+SDXX_"     "_$P($G(^DIC(40.7,SDDA,0)),"^"))

 . . I $D(SDERR) D  Q

 . . . D BMES^XPDUTL("    >> ... Unable to reactivate stop code: "_SDDA)

 . . . D MES^XPDUTL("    >> ... "_$G(SDERR("DIERR",1,"TEXT",1))_".")

 . . . D MES^XPDUTL("    >> ... Please contact support for assistance...")

 . . . K SDERR

 D BMES^XPDUTL(">>> Reactivating code completed.")

 Q

 ;

CHGNM ; Change code names

 ; SDREC is in format: ;;code name^code #^^new code name

 ;

 N SDI,SDCODE,SDIEN,SDNEWNM,SDNM,SDREC,SDCHGERR

 D BMES^XPDUTL(">>> Changing code names in CLINIC STOP (#40.7) file...")

 ;

 ; load entries

 F SDI=1:1 S SDREC=$P($T(CHG+SDI),";;",2) Q:SDREC="QUIT"  D

 . S SDCODE=$P(SDREC,U,2)  ;code

 . S SDNEWNM=$P(SDREC,U,4) ;new name

 . ;

 . ; check if code already exists

 . S SDIEN=$$FIND1^DIC(40.7,"","MX",SDCODE,"","","SDCHGERR")

 . ;

 . ; check if error

 . I $D(SDCHGERR) D  Q

 . . D BMES^XPDUTL("    >> ... Unable to change name of the stop code: "_SDCODE)

 . . D MES^XPDUTL("    >> ... "_$G(SDCHGERR("DIERR",1,"TEXT",1))_".")

 . . D MES^XPDUTL("    >> ... Please contact support for assistance...")

 . . ; clean out error array b4 processing next code

 . . K SDCHGERR

 . ;

 . ; quit if no entry in file

 . I 'SDIEN D  Q

 . . D BMES^XPDUTL("    >> ... Unable to find stop code: "_SDCODE)

 . . D MES^XPDUTL("    >> ... Please contact support for assistance.")

 . ;

 . ; check if code is active

 . I $D(^DIC(40.7,SDIEN,0)) I $P(^(0),U,3)="" D

 . . ; get current name

 . . S SDNM=$P(^DIC(40.7,SDIEN,0),U,1)

 . . K SDFDA

 . . S SDFDA(40.7,SDIEN_",",.01)=SDNEWNM

 . . D FILE^DIE(,"SDFDA","SDCHGERR")

 . . ; check if error

 . . I $D(SDCHGERR) D  Q

 . . . D BMES^XPDUTL("    >> ... Unable to change name for stop code: "_SDCODE)

 . . . D MES^XPDUTL("    >> ... "_$G(SDCHGERR("DIERR",1,"TEXT",1))_".")

 . . . D MES^XPDUTL("    >> ... Please contact support for assistance.")

 . . . ; clean out error array b4 processing next code

 . . . K SDCHGERR

 . . I '$D(SDCHGERR) D

 . . . D BMES^XPDUTL("    >> Stop Code "_SDCODE_" name changed from: "_SDNM)

 . . . D MES^XPDUTL("                                    to: "_SDNEWNM)

 . . . I SDNM=SDNEWNM D

 . . . . D BMES^XPDUTL("       Stop Code "_SDCODE_" name has already changed.")

 ;

 D BMES^XPDUTL(">>> Changing code names complete.")

 D MES^XPDUTL("")

 Q

 ;

ACT ; Code to be reactivated - ;;number^

 ;;306^

 ;;QUIT

 ;

CHG ; Code name changes - ;;code name^code #^^new code name

 ;;^306^^DIABETES CLINIC

 ;;QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---SD53MY21   3836     printed  Mar 13, 2025@21:50:55                                                                                                                                                                                                    Page 2

SD53MY21  ;ALB/TXH - FY21 MID-YEAR STOP CODE UPDATES; SEP 22, 2020@10:40

 +1       ;;5.3;Scheduling;**770**;AUG 13, 1993;Build 4

 +2       ;

 +3       ; Post-install routine updating stop codes in CLINIC STOP file

 +4       ; (#40.7) for FY21 mid-year updates - effective 04/01/2021.

 +5       ;

 +6       ; References to $$FIND1^DIC supported by ICR# 2051

 +7       ; References to FILE^DIE supported by ICR# 2053

 +8       ; References to BMES^XPDUTL supported by ICR# 10141

 +9       ; References to MES^XPDUTL supported by ICR# 10141

 +10      ;

 +11       QUIT 

 +12      ;

POST      ; Update stop codes in Clinic Stop file 40.7

 +1       ;

 +2        DO BMES^XPDUTL("SD*5.3*770 Post-Install starts...")

 +3       ; reactivate code

           if $PIECE($TEXT(ACT+1),";;",2)'="QUIT"

               DO REACT

 +4       ; change name

           if $PIECE($TEXT(CHG+1),";;",2)'="QUIT"

               DO CHGNM

 +5        DO BMES^XPDUTL("SD*5.3*770 Post-Install complete.")

 +6        DO MES^XPDUTL("")

 +7        KILL SDIEN,%H,%I,DIC,X,Y

 +8        QUIT 

 +9       ;

REACT     ; Reactivate code

 +1       ; SDREC is in format: ;;code #^

 +2       ;

 +3        NEW SDDA,SDX,SDXX,DA,DIE,DR,SDERR

 +4        DO BMES^XPDUTL(">>> Reactivating Clinic Stop in CLINIC STOP (#40.7) file...")

 +5       ;

 +6       ; Load entries

 +7        FOR SDX=1:1

               KILL DD,DO,DA

               SET SDXX=$PIECE($TEXT(ACT+SDX),";;",2)

               if SDXX="QUIT"

                   QUIT 

               Begin DoDot:1

 +8                SET SDDA=+$ORDER(^DIC(40.7,"C",+SDXX,0))

 +9       ; Check if inactive

 +10               IF $PIECE($GET(^DIC(40.7,SDDA,0)),U,3)'=""

                       Begin DoDot:2

 +11                       KILL SDFDA

 +12                       SET SDFDA(40.7,SDDA_",",2)=""

 +13                       DO FILE^DIE(,"SDFDA","SDERR")

 +14      ; check if error

 +15                       IF '$DATA(SDERR)

                               DO BMES^XPDUTL("     Reactivated: "_+SDXX_"     "_$PIECE($GET(^DIC(40.7,SDDA,0)),"^"))

 +16                       IF $DATA(SDERR)

                               Begin DoDot:3

 +17                               DO BMES^XPDUTL("    >> ... Unable to reactivate stop code: "_SDDA)

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

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

 +20                               KILL SDERR

                               End DoDot:3

                               QUIT 

                       End DoDot:2

               End DoDot:1

 +21       DO BMES^XPDUTL(">>> Reactivating code completed.")

 +22       QUIT 

 +23      ;

CHGNM     ; Change code names

 +1       ; SDREC is in format: ;;code name^code #^^new code name

 +2       ;

 +3        NEW SDI,SDCODE,SDIEN,SDNEWNM,SDNM,SDREC,SDCHGERR

 +4        DO BMES^XPDUTL(">>> Changing code names in CLINIC STOP (#40.7) file...")

 +5       ;

 +6       ; load entries

 +7        FOR SDI=1:1

               SET SDREC=$PIECE($TEXT(CHG+SDI),";;",2)

               if SDREC="QUIT"

                   QUIT 

               Begin DoDot:1

 +8       ;code

                   SET SDCODE=$PIECE(SDREC,U,2)

 +9       ;new name

                   SET SDNEWNM=$PIECE(SDREC,U,4)

 +10      ;

 +11      ; check if code already exists

 +12               SET SDIEN=$$FIND1^DIC(40.7,"","MX",SDCODE,"","","SDCHGERR")

 +13      ;

 +14      ; check if error

 +15               IF $DATA(SDCHGERR)

                       Begin DoDot:2

 +16                       DO BMES^XPDUTL("    >> ... Unable to change name of the stop code: "_SDCODE)

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

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

 +19      ; clean out error array b4 processing next code

 +20                       KILL SDCHGERR

                       End DoDot:2

                       QUIT 

 +21      ;

 +22      ; quit if no entry in file

 +23               IF 'SDIEN

                       Begin DoDot:2

 +24                       DO BMES^XPDUTL("    >> ... Unable to find stop code: "_SDCODE)

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

                       End DoDot:2

                       QUIT 

 +26      ;

 +27      ; check if code is active

 +28               IF $DATA(^DIC(40.7,SDIEN,0))

                       IF $PIECE(^(0),U,3)=""

                           Begin DoDot:2

 +29      ; get current name

 +30                           SET SDNM=$PIECE(^DIC(40.7,SDIEN,0),U,1)

 +31                           KILL SDFDA

 +32                           SET SDFDA(40.7,SDIEN_",",.01)=SDNEWNM

 +33                           DO FILE^DIE(,"SDFDA","SDCHGERR")

 +34      ; check if error

 +35                           IF $DATA(SDCHGERR)

                                   Begin DoDot:3

 +36                                   DO BMES^XPDUTL("    >> ... Unable to change name for stop code: "_SDCODE)

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

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

 +39      ; clean out error array b4 processing next code

 +40                                   KILL SDCHGERR

                                   End DoDot:3

                                   QUIT 

 +41                           IF '$DATA(SDCHGERR)

                                   Begin DoDot:3

 +42                                   DO BMES^XPDUTL("    >> Stop Code "_SDCODE_" name changed from: "_SDNM)

 +43                                   DO MES^XPDUTL("                                    to: "_SDNEWNM)

 +44                                   IF SDNM=SDNEWNM

                                           Begin DoDot:4

 +45                                           DO BMES^XPDUTL("       Stop Code "_SDCODE_" name has already changed.")

                                           End DoDot:4

                                   End DoDot:3

                           End DoDot:2

               End DoDot:1

 +46      ;

 +47       DO BMES^XPDUTL(">>> Changing code names complete.")

 +48       DO MES^XPDUTL("")

 +49       QUIT 

 +50      ;

ACT       ; Code to be reactivated - ;;number^

 +1       ;;306^

 +2       ;;QUIT

 +3       ;

CHG       ; Code name changes - ;;code name^code #^^new code name

 +1       ;;^306^^DIABETES CLINIC

 +2       ;;QUIT