SD53MY20 ;ALB/TXH - MID-FY20 STOP CODE CHANGES; Feb 05, 2020@13:24
;;5.3;Scheduling;**736**;AUG 13, 1993;Build 2
;
; Post-init routine updating stop codes in CLINIC STOP file (#40.7)
; for MY20 updates - effective 04/01/2020.
;
Q
;
POST ; Update stop codes in Clinic Stop file 40.7
;
D BMES^XPDUTL("SD*5.3*736 Post-Install starts...")
D:$P($T(NEW+1),";;",2)'="QUIT" ADD ; add new stop code
D:$P($T(OFF+1),";;",2)'="QUIT" INACT ; inactivate
D:$P($T(CHG+1),";;",2)'="QUIT" CHGNM ; change name
D:$P($T(RT+1),";;",2)'="QUIT" CHGRT ; change restriction data
D MES^XPDUTL("SD*5.3*736 Post-Install is complete."),MES^XPDUTL("")
K SDIEN,%H,%I,DIC,X,Y
;
Q
;
ADD ; Add new stop code
; SDREC is in format:
; ;;stop code name^code #^restriction type^restriction date^CDR
;
N SDI,SDREC,SDCODE,SDNM,SDRESTYP,SDFDA,SDADDERR,SDIEN,SDCDR,SDRESIN,SDRESEX
D BMES^XPDUTL(">>> Adding stop code to the CLINIC STOP (#40.7) file...")
D BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used UNTIL 04/01/2020]")
;
; load all new entries
F SDI=1:1 S SDREC=$P($T(NEW+SDI),";;",2) Q:SDREC="QUIT" D
. S SDCODE=$P(SDREC,U,2) ;code
. S SDNM=$P(SDREC,U) ;name
. S SDRESTYP=$P(SDREC,U,3) ;restriction type
. S (SDRESIN,SDRESEX)=""
. ; restriction date
. I +$P(SDREC,U,4) D
. . S X=$P(SDREC,U,4)
. . S %DT="FTX"
. . D ^%DT
. . I Y<0 S SDRESIN="" Q
. . S SDRESIN=Y
. . D DD^%DT
. . S SDRESEX=Y
. S SDCDR=$P(SDREC,U,5) ;CDR #
. ;
. ; check if code already exists in file 40.7
. S SDIEN=$$FIND1^DIC(40.7,"","MX",SDCODE,"","","SDADDERR")
. ; quit if error
. I $D(SDADDERR) D Q
. . D BMES^XPDUTL(" >> ... Unable to add stop code "_SDCODE_" "_SDNM_" to file.")
. . D MES^XPDUTL(" >> ... "_$G(SDADDERR("DIERR",1,"TEXT",1))_".")
. . D MES^XPDUTL(" >> ... Please contact support for assistance...")
. . K SDADDERR
. ;
. ; If code already exists, update it.
. I SDIEN D Q
. . K SDADDERR
. . S SDFDA(40.7,SDIEN_",",.01)=SDNM
. . S SDFDA(40.7,SDIEN_",",1)=SDCODE
. . S SDFDA(40.7,SDIEN_",",4)=SDCDR
. . S SDFDA(40.7,SDIEN_",",5)=SDRESTYP
. . S SDFDA(40.7,SDIEN_",",6)=SDRESIN
. . D FILE^DIE(,"SDFDA","SDADDERR")
. . ; check if error
. . I '$D(SDADDERR) D Q
. . . D BMES^XPDUTL(" >> Stop Code "_SDCODE_" "_SDNM_" already exists.")
. . I $D(SDADDERR) D
. . . D BMES^XPDUTL(" ... Unable to add stop code "_SDCODE_" "_SDNM_" to file.")
. . . D MES^XPDUTL(" ... "_$G(SDADDERR("DIERR",1,"TEXT",1))_".")
. . . D MES^XPDUTL(" ... Please contact support for assistance.")
. . . K SDADDERR
. ; if code does not exist, add new entry
. ; set field values of new entry
. S SDFDA(40.7,"+1,",.01)=SDNM
. S SDFDA(40.7,"+1,",1)=SDCODE
. S SDFDA(40.7,"+1,",4)=SDCDR
. S SDFDA(40.7,"+1,",5)=SDRESTYP
. S SDFDA(40.7,"+1,",6)=SDRESIN
. ; add new entry
. D UPDATE^DIE("E","SDFDA","","SDADDERR")
. ; check if error
. I '$D(SDADDERR) D
. . D BMES^XPDUTL(" >> Stop Code "_SDCODE_" "_SDNM_" added to file.")
. I $D(SDADDERR) D
. . D BMES^XPDUTL(" >> ... Unable to add stop code "_SDCODE_" "_SDNM_" to file.")
. . D MES^XPDUTL(" >> ... "_$G(SDADDERR("DIERR",1,"TEXT",1))_".")
. . D MES^XPDUTL(" >> ... Please contact support for assistance.")
. . ; clean out error array b4 processing next code
. . K SDADDERR
;
D BMES^XPDUTL(">>> Add new stop codes complete.")
D MES^XPDUTL("")
;
Q
;
INACT ; Inactivate stop code
; SDREC is in format: ;;code #^^inactivation date (in FileMan format)
;
N SDI,SDREC,SDCODE,SDEXDT,SDINDT,SDNM,SDINTERR
D BMES^XPDUTL(">>> Inactivating stop codes in CLINIC STOP (#40.7) file...")
D BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used AFTER the indicated inactivation date.]")
;
; load entries w/ inactivate date
F SDI=1:1 S SDREC=$P($T(OFF+SDI),";;",2) Q:SDREC="QUIT" D
. S SDCODE=$P(SDREC,U) ;code
. ; get inactivate date and validate date passed in
. I +$P(SDREC,U,3) D
. . S X=$P(SDREC,U,3)
. . S %DT="FTX"
. . D ^%DT
. . Q:Y<0
. . S SDINDT=Y
. . D DD^%DT
. . S SDEXDT=Y
. . ; check if code already exists
. . S SDIEN=$$FIND1^DIC(40.7,"","MX",SDCODE,"","","SDINTERR")
. . ; quit if unable to find code in 40.7
. . I 'SDIEN D Q
. . . D BMES^XPDUTL(" >> ... Unable to find stop code: "_SDCODE)
. . . D MES^XPDUTL(" >> ... Please contact support for assistance.")
. . ; check if error
. . I $D(SDINTERR) D Q
. . . D BMES^XPDUTL(" >> ... Unable to inactivate stop code "_SDCODE)
. . . D MES^XPDUTL(" >> ... "_$G(SDINTERR("DIERR",1,"TEXT",1))_".")
. . . D MES^XPDUTL(" >> ... Please contact support for assistance...")
. . . ; clean out error array b4 processing next code
. . . K SDINTERR
. . ; if no error, check if active
. . I $D(^DIC(40.7,SDIEN,0)) I $P(^(0),U,3)="" D
. . . S SDNM=$P($G(^DIC(40.7,SDIEN,0)),U) ;code name
. . . ; set field value
. . . K SDFDA
. . . S SDFDA(40.7,SDIEN_",",2)=SDINDT
. . . D FILE^DIE(,"SDFDA","SDINTERR")
. . . ; check if error
. . . I $D(SDINTERR) D Q
. . . . D BMES^XPDUTL(" >> ... Unable to inactivate stop code: "_SDCODE)
. . . . D MES^XPDUTL(" >> ... "_$G(SDINTERR("DIERR",1,"TEXT",1))_".")
. . . . D MES^XPDUTL(" >> ... Please contact support for assistance.")
. . . . ; clean out error array b4 processing next code
. . . . K SDINTERR
. . . I '$D(SDINTERR) D
. . . . D BMES^XPDUTL(" >> Inactivated: "_+SDCODE_" "_SDNM_" as of "_SDEXDT)
;
D BMES^XPDUTL(">>> Inactivation complete.")
D MES^XPDUTL("")
K %,%DT,%H,%I,DIC,X,Y
;
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 SDNM=$P(SDREC,U) ;current name
. 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 inactivate 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
. . 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
;
CHGRT ; Change restriction data
; SDREC is in format: ;;code name^code #^restriction type^restriction date
N SDI,SDREC,SDNM,SDNUM,SDRTERR,SDIEN,SDOLDRT,SDRD,SDRT,SDX,SDINDT,SDEXRD,SDRDEX,SDRDIN
D BMES^XPDUTL(">>> Changing restriction data in CLINIC STOP (#40.7) file...")
; load new entry
F SDI=1:1 S SDREC=$P($T(RT+SDI),";;",2) Q:SDREC="QUIT" D
. S SDNM=$P(SDREC,U) ; code name
. S SDNUM=$P(SDREC,U,2) ; code #
. S SDRT=$P(SDREC,U,3) ; restriction type
. S SDRD=$P(SDREC,U,4) ; restriction date
. ;
. ; check if code already exists and get code IEN
. S SDIEN=$$FIND1^DIC(40.7,"","MX",SDNUM,"","","SDRTERR")
. ; check if error
. I $D(SDRTERR) D Q
. . D BMES^XPDUTL(" >> ... Unable to inactivate stop code: "_SDNUM)
. . D MES^XPDUTL(" >> ... "_$G(SDRTERR("DIERR",1,"TEXT",1))_".")
. . D MES^XPDUTL(" >> ... Please contact support for assistance...")
. . ; clean out error array b4 processing next code
. . K SDRTERR
. I 'SDIEN D Q
. . D BMES^XPDUTL(" >> ... Unable to find stop code: "_SDNUM)
. . D MES^XPDUTL(" >> ... Please contact support for assistance.")
. ; find current restriction type and date
. I $D(^DIC(40.7,SDIEN,0)) I $P(^(0),U,3)="" D
. . S SDOLDRT=$P(^DIC(40.7,SDIEN,0),U,6) ; old restriction type
. . S SDEXRD=""
. . S X=$P(^DIC(40.7,SDIEN,0),U,7) ; old restriction date
. . S %DT="FTX" D ^%DT Q:Y<0
. . S SDINDT=Y D DD^%DT S SDEXRD=Y
. ; set field value
. ; new restriction date
. S X=SDRD
. S %DT="FTX"
. D ^%DT
. I Y<0 S SDRDIN="" Q
. S SDRDIN=Y
. D DD^%DT
. S SDRDEX=Y
. ;
. K SDFDA
. S SDFDA(40.7,SDIEN_",",5)=SDRT
. S SDFDA(40.7,SDIEN_",",6)=SDRDIN ; save internal dt
. D FILE^DIE(,"SDFDA","SDRTERR")
. I SDOLDRT'=SDRT D
. . D BMES^XPDUTL(" >> Stop Code "_SDNUM_" restriction type changed from: "_SDOLDRT)
. . D MES^XPDUTL(" to: "_SDRT)
. E D
. . D BMES^XPDUTL(" >> Stop Code "_SDNUM_" restriction type changed from: "_SDOLDRT)
. . D MES^XPDUTL(" to: "_SDRT)
. . D BMES^XPDUTL(" restriction type has already changed.")
. I SDEXRD'=SDRDEX D
. . D BMES^XPDUTL(" >> restriction date changed from: "_SDEXRD)
. . D MES^XPDUTL(" to: "_SDRDEX)
. E D
. . D BMES^XPDUTL(" >> restriction date changed from: "_SDEXRD)
. . D MES^XPDUTL(" to: "_SDRDEX)
. . D BMES^XPDUTL(" restriction date has already changed.")
D BMES^XPDUTL(">>> Changing restriction data complete.")
D MES^XPDUTL("")
K %,%DT,%H,%I,DIC,X,Y,SDFDA
Q
;
NEW ; codes to add - ;;stop code name^code #^restriction type^restriction date^CDR
;;CAREGIVER SUPPORT PROGRAM^192^E^
;;QUIT
;
OFF ; codes to be inactivated - ;;code #^^inactive date
;;QUIT
;
CHG ; Code name changes - ;;code name^code #^^new code name
;;MOVE! PGM INDIV^372^^WEIGHT MGMT & MOVE! PROG - IND
;;MOVE! PGM GROUP^373^^WEIGHT MGMT & MOVE! PROG - GRP
;;QUIT
;
RT ; Change Restriction - ;;stop code name^CODE #^rest type^rest date
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD53MY20 10825 printed Nov 22, 2024@17:55:55 Page 2
SD53MY20 ;ALB/TXH - MID-FY20 STOP CODE CHANGES; Feb 05, 2020@13:24
+1 ;;5.3;Scheduling;**736**;AUG 13, 1993;Build 2
+2 ;
+3 ; Post-init routine updating stop codes in CLINIC STOP file (#40.7)
+4 ; for MY20 updates - effective 04/01/2020.
+5 ;
+6 QUIT
+7 ;
POST ; Update stop codes in Clinic Stop file 40.7
+1 ;
+2 DO BMES^XPDUTL("SD*5.3*736 Post-Install starts...")
+3 ; add new stop code
if $PIECE($TEXT(NEW+1),";;",2)'="QUIT"
DO ADD
+4 ; inactivate
if $PIECE($TEXT(OFF+1),";;",2)'="QUIT"
DO INACT
+5 ; change name
if $PIECE($TEXT(CHG+1),";;",2)'="QUIT"
DO CHGNM
+6 ; change restriction data
if $PIECE($TEXT(RT+1),";;",2)'="QUIT"
DO CHGRT
+7 DO MES^XPDUTL("SD*5.3*736 Post-Install is complete.")
DO MES^XPDUTL("")
+8 KILL SDIEN,%H,%I,DIC,X,Y
+9 ;
+10 QUIT
+11 ;
ADD ; Add new stop code
+1 ; SDREC is in format:
+2 ; ;;stop code name^code #^restriction type^restriction date^CDR
+3 ;
+4 NEW SDI,SDREC,SDCODE,SDNM,SDRESTYP,SDFDA,SDADDERR,SDIEN,SDCDR,SDRESIN,SDRESEX
+5 DO BMES^XPDUTL(">>> Adding stop code to the CLINIC STOP (#40.7) file...")
+6 DO BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used UNTIL 04/01/2020]")
+7 ;
+8 ; load all new entries
+9 FOR SDI=1:1
SET SDREC=$PIECE($TEXT(NEW+SDI),";;",2)
if SDREC="QUIT"
QUIT
Begin DoDot:1
+10 ;code
SET SDCODE=$PIECE(SDREC,U,2)
+11 ;name
SET SDNM=$PIECE(SDREC,U)
+12 ;restriction type
SET SDRESTYP=$PIECE(SDREC,U,3)
+13 SET (SDRESIN,SDRESEX)=""
+14 ; restriction date
+15 IF +$PIECE(SDREC,U,4)
Begin DoDot:2
+16 SET X=$PIECE(SDREC,U,4)
+17 SET %DT="FTX"
+18 DO ^%DT
+19 IF Y<0
SET SDRESIN=""
QUIT
+20 SET SDRESIN=Y
+21 DO DD^%DT
+22 SET SDRESEX=Y
End DoDot:2
+23 ;CDR #
SET SDCDR=$PIECE(SDREC,U,5)
+24 ;
+25 ; check if code already exists in file 40.7
+26 SET SDIEN=$$FIND1^DIC(40.7,"","MX",SDCODE,"","","SDADDERR")
+27 ; quit if error
+28 IF $DATA(SDADDERR)
Begin DoDot:2
+29 DO BMES^XPDUTL(" >> ... Unable to add stop code "_SDCODE_" "_SDNM_" to file.")
+30 DO MES^XPDUTL(" >> ... "_$GET(SDADDERR("DIERR",1,"TEXT",1))_".")
+31 DO MES^XPDUTL(" >> ... Please contact support for assistance...")
+32 KILL SDADDERR
End DoDot:2
QUIT
+33 ;
+34 ; If code already exists, update it.
+35 IF SDIEN
Begin DoDot:2
+36 KILL SDADDERR
+37 SET SDFDA(40.7,SDIEN_",",.01)=SDNM
+38 SET SDFDA(40.7,SDIEN_",",1)=SDCODE
+39 SET SDFDA(40.7,SDIEN_",",4)=SDCDR
+40 SET SDFDA(40.7,SDIEN_",",5)=SDRESTYP
+41 SET SDFDA(40.7,SDIEN_",",6)=SDRESIN
+42 DO FILE^DIE(,"SDFDA","SDADDERR")
+43 ; check if error
+44 IF '$DATA(SDADDERR)
Begin DoDot:3
+45 DO BMES^XPDUTL(" >> Stop Code "_SDCODE_" "_SDNM_" already exists.")
End DoDot:3
QUIT
+46 IF $DATA(SDADDERR)
Begin DoDot:3
+47 DO BMES^XPDUTL(" ... Unable to add stop code "_SDCODE_" "_SDNM_" to file.")
+48 DO MES^XPDUTL(" ... "_$GET(SDADDERR("DIERR",1,"TEXT",1))_".")
+49 DO MES^XPDUTL(" ... Please contact support for assistance.")
+50 KILL SDADDERR
End DoDot:3
End DoDot:2
QUIT
+51 ; if code does not exist, add new entry
+52 ; set field values of new entry
+53 SET SDFDA(40.7,"+1,",.01)=SDNM
+54 SET SDFDA(40.7,"+1,",1)=SDCODE
+55 SET SDFDA(40.7,"+1,",4)=SDCDR
+56 SET SDFDA(40.7,"+1,",5)=SDRESTYP
+57 SET SDFDA(40.7,"+1,",6)=SDRESIN
+58 ; add new entry
+59 DO UPDATE^DIE("E","SDFDA","","SDADDERR")
+60 ; check if error
+61 IF '$DATA(SDADDERR)
Begin DoDot:2
+62 DO BMES^XPDUTL(" >> Stop Code "_SDCODE_" "_SDNM_" added to file.")
End DoDot:2
+63 IF $DATA(SDADDERR)
Begin DoDot:2
+64 DO BMES^XPDUTL(" >> ... Unable to add stop code "_SDCODE_" "_SDNM_" to file.")
+65 DO MES^XPDUTL(" >> ... "_$GET(SDADDERR("DIERR",1,"TEXT",1))_".")
+66 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
+67 ; clean out error array b4 processing next code
+68 KILL SDADDERR
End DoDot:2
End DoDot:1
+69 ;
+70 DO BMES^XPDUTL(">>> Add new stop codes complete.")
+71 DO MES^XPDUTL("")
+72 ;
+73 QUIT
+74 ;
INACT ; Inactivate stop code
+1 ; SDREC is in format: ;;code #^^inactivation date (in FileMan format)
+2 ;
+3 NEW SDI,SDREC,SDCODE,SDEXDT,SDINDT,SDNM,SDINTERR
+4 DO BMES^XPDUTL(">>> Inactivating stop codes in CLINIC STOP (#40.7) file...")
+5 DO BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used AFTER the indicated inactivation date.]")
+6 ;
+7 ; load entries w/ inactivate date
+8 FOR SDI=1:1
SET SDREC=$PIECE($TEXT(OFF+SDI),";;",2)
if SDREC="QUIT"
QUIT
Begin DoDot:1
+9 ;code
SET SDCODE=$PIECE(SDREC,U)
+10 ; get inactivate date and validate date passed in
+11 IF +$PIECE(SDREC,U,3)
Begin DoDot:2
+12 SET X=$PIECE(SDREC,U,3)
+13 SET %DT="FTX"
+14 DO ^%DT
+15 if Y<0
QUIT
+16 SET SDINDT=Y
+17 DO DD^%DT
+18 SET SDEXDT=Y
+19 ; check if code already exists
+20 SET SDIEN=$$FIND1^DIC(40.7,"","MX",SDCODE,"","","SDINTERR")
+21 ; quit if unable to find code in 40.7
+22 IF 'SDIEN
Begin DoDot:3
+23 DO BMES^XPDUTL(" >> ... Unable to find stop code: "_SDCODE)
+24 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
End DoDot:3
QUIT
+25 ; check if error
+26 IF $DATA(SDINTERR)
Begin DoDot:3
+27 DO BMES^XPDUTL(" >> ... Unable to inactivate stop code "_SDCODE)
+28 DO MES^XPDUTL(" >> ... "_$GET(SDINTERR("DIERR",1,"TEXT",1))_".")
+29 DO MES^XPDUTL(" >> ... Please contact support for assistance...")
+30 ; clean out error array b4 processing next code
+31 KILL SDINTERR
End DoDot:3
QUIT
+32 ; if no error, check if active
+33 IF $DATA(^DIC(40.7,SDIEN,0))
IF $PIECE(^(0),U,3)=""
Begin DoDot:3
+34 ;code name
SET SDNM=$PIECE($GET(^DIC(40.7,SDIEN,0)),U)
+35 ; set field value
+36 KILL SDFDA
+37 SET SDFDA(40.7,SDIEN_",",2)=SDINDT
+38 DO FILE^DIE(,"SDFDA","SDINTERR")
+39 ; check if error
+40 IF $DATA(SDINTERR)
Begin DoDot:4
+41 DO BMES^XPDUTL(" >> ... Unable to inactivate stop code: "_SDCODE)
+42 DO MES^XPDUTL(" >> ... "_$GET(SDINTERR("DIERR",1,"TEXT",1))_".")
+43 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
+44 ; clean out error array b4 processing next code
+45 KILL SDINTERR
End DoDot:4
QUIT
+46 IF '$DATA(SDINTERR)
Begin DoDot:4
+47 DO BMES^XPDUTL(" >> Inactivated: "_+SDCODE_" "_SDNM_" as of "_SDEXDT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+48 ;
+49 DO BMES^XPDUTL(">>> Inactivation complete.")
+50 DO MES^XPDUTL("")
+51 KILL %,%DT,%H,%I,DIC,X,Y
+52 ;
+53 QUIT
+54 ;
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 ;current name
SET SDNM=$PIECE(SDREC,U)
+9 ;code
SET SDCODE=$PIECE(SDREC,U,2)
+10 ;new name
SET SDNEWNM=$PIECE(SDREC,U,4)
+11 ; check if code already exists
+12 SET SDIEN=$$FIND1^DIC(40.7,"","MX",SDCODE,"","","SDCHGERR")
+13 ; check if error
+14 IF $DATA(SDCHGERR)
Begin DoDot:2
+15 DO BMES^XPDUTL(" >> ... Unable to inactivate stop code: "_SDCODE)
+16 DO MES^XPDUTL(" >> ... "_$GET(SDCHGERR("DIERR",1,"TEXT",1))_".")
+17 DO MES^XPDUTL(" >> ... Please contact support for assistance...")
+18 ; clean out error array b4 processing next code
+19 KILL SDCHGERR
End DoDot:2
QUIT
+20 ; quit if no entry in file
+21 IF 'SDIEN
Begin DoDot:2
+22 DO BMES^XPDUTL(" >> ... Unable to find stop code: "_SDCODE)
+23 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
End DoDot:2
QUIT
+24 ; check if code is active
+25 IF $DATA(^DIC(40.7,SDIEN,0))
IF $PIECE(^(0),U,3)=""
Begin DoDot:2
+26 KILL SDFDA
+27 SET SDFDA(40.7,SDIEN_",",.01)=SDNEWNM
+28 DO FILE^DIE(,"SDFDA","SDCHGERR")
+29 ; check if error
+30 IF $DATA(SDCHGERR)
Begin DoDot:3
+31 DO BMES^XPDUTL(" >> ... Unable to change name for stop code: "_SDCODE)
+32 DO MES^XPDUTL(" >> ... "_$GET(SDCHGERR("DIERR",1,"TEXT",1))_".")
+33 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
+34 ; clean out error array b4 processing next code
+35 KILL SDCHGERR
End DoDot:3
QUIT
+36 IF '$DATA(SDCHGERR)
Begin DoDot:3
+37 DO BMES^XPDUTL(" >> Stop Code "_SDCODE_" name changed from: "_SDNM)
+38 DO MES^XPDUTL(" to: "_SDNEWNM)
+39 IF SDNM=SDNEWNM
Begin DoDot:4
+40 DO BMES^XPDUTL(" Stop Code "_SDCODE_" name has already changed.")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+41 ;
+42 DO BMES^XPDUTL(">>> Changing code names complete.")
+43 DO MES^XPDUTL("")
+44 ;
+45 QUIT
+46 ;
CHGRT ; Change restriction data
+1 ; SDREC is in format: ;;code name^code #^restriction type^restriction date
+2 NEW SDI,SDREC,SDNM,SDNUM,SDRTERR,SDIEN,SDOLDRT,SDRD,SDRT,SDX,SDINDT,SDEXRD,SDRDEX,SDRDIN
+3 DO BMES^XPDUTL(">>> Changing restriction data in CLINIC STOP (#40.7) file...")
+4 ; load new entry
+5 FOR SDI=1:1
SET SDREC=$PIECE($TEXT(RT+SDI),";;",2)
if SDREC="QUIT"
QUIT
Begin DoDot:1
+6 ; code name
SET SDNM=$PIECE(SDREC,U)
+7 ; code #
SET SDNUM=$PIECE(SDREC,U,2)
+8 ; restriction type
SET SDRT=$PIECE(SDREC,U,3)
+9 ; restriction date
SET SDRD=$PIECE(SDREC,U,4)
+10 ;
+11 ; check if code already exists and get code IEN
+12 SET SDIEN=$$FIND1^DIC(40.7,"","MX",SDNUM,"","","SDRTERR")
+13 ; check if error
+14 IF $DATA(SDRTERR)
Begin DoDot:2
+15 DO BMES^XPDUTL(" >> ... Unable to inactivate stop code: "_SDNUM)
+16 DO MES^XPDUTL(" >> ... "_$GET(SDRTERR("DIERR",1,"TEXT",1))_".")
+17 DO MES^XPDUTL(" >> ... Please contact support for assistance...")
+18 ; clean out error array b4 processing next code
+19 KILL SDRTERR
End DoDot:2
QUIT
+20 IF 'SDIEN
Begin DoDot:2
+21 DO BMES^XPDUTL(" >> ... Unable to find stop code: "_SDNUM)
+22 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
End DoDot:2
QUIT
+23 ; find current restriction type and date
+24 IF $DATA(^DIC(40.7,SDIEN,0))
IF $PIECE(^(0),U,3)=""
Begin DoDot:2
+25 ; old restriction type
SET SDOLDRT=$PIECE(^DIC(40.7,SDIEN,0),U,6)
+26 SET SDEXRD=""
+27 ; old restriction date
SET X=$PIECE(^DIC(40.7,SDIEN,0),U,7)
+28 SET %DT="FTX"
DO ^%DT
if Y<0
QUIT
+29 SET SDINDT=Y
DO DD^%DT
SET SDEXRD=Y
End DoDot:2
+30 ; set field value
+31 ; new restriction date
+32 SET X=SDRD
+33 SET %DT="FTX"
+34 DO ^%DT
+35 IF Y<0
SET SDRDIN=""
QUIT
+36 SET SDRDIN=Y
+37 DO DD^%DT
+38 SET SDRDEX=Y
+39 ;
+40 KILL SDFDA
+41 SET SDFDA(40.7,SDIEN_",",5)=SDRT
+42 ; save internal dt
SET SDFDA(40.7,SDIEN_",",6)=SDRDIN
+43 DO FILE^DIE(,"SDFDA","SDRTERR")
+44 IF SDOLDRT'=SDRT
Begin DoDot:2
+45 DO BMES^XPDUTL(" >> Stop Code "_SDNUM_" restriction type changed from: "_SDOLDRT)
+46 DO MES^XPDUTL(" to: "_SDRT)
End DoDot:2
+47 IF '$TEST
Begin DoDot:2
+48 DO BMES^XPDUTL(" >> Stop Code "_SDNUM_" restriction type changed from: "_SDOLDRT)
+49 DO MES^XPDUTL(" to: "_SDRT)
+50 DO BMES^XPDUTL(" restriction type has already changed.")
End DoDot:2
+51 IF SDEXRD'=SDRDEX
Begin DoDot:2
+52 DO BMES^XPDUTL(" >> restriction date changed from: "_SDEXRD)
+53 DO MES^XPDUTL(" to: "_SDRDEX)
End DoDot:2
+54 IF '$TEST
Begin DoDot:2
+55 DO BMES^XPDUTL(" >> restriction date changed from: "_SDEXRD)
+56 DO MES^XPDUTL(" to: "_SDRDEX)
+57 DO BMES^XPDUTL(" restriction date has already changed.")
End DoDot:2
End DoDot:1
+58 DO BMES^XPDUTL(">>> Changing restriction data complete.")
+59 DO MES^XPDUTL("")
+60 KILL %,%DT,%H,%I,DIC,X,Y,SDFDA
+61 QUIT
+62 ;
NEW ; codes to add - ;;stop code name^code #^restriction type^restriction date^CDR
+1 ;;CAREGIVER SUPPORT PROGRAM^192^E^
+2 ;;QUIT
+3 ;
OFF ; codes to be inactivated - ;;code #^^inactive date
+1 ;;QUIT
+2 ;
CHG ; Code name changes - ;;code name^code #^^new code name
+1 ;;MOVE! PGM INDIV^372^^WEIGHT MGMT & MOVE! PROG - IND
+2 ;;MOVE! PGM GROUP^373^^WEIGHT MGMT & MOVE! PROG - GRP
+3 ;;QUIT
+4 ;
RT ; Change Restriction - ;;stop code name^CODE #^rest type^rest date
+1 ;;QUIT
