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 ---[H[J[2J[HSD53MY21 3836 printed Dec 13, 2024@02:46 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
