SD53FY21 ;ALB/TXH - FY21 STOP CODE UPDATES; JUN 11, 2020@17:00
;;5.3;Scheduling;**752**;AUG 13, 1993;Build 2
;
; Post-init routine updating stop codes in CLINIC STOP file
; (#40.7) for FY21 updates - effective 10/01/2020.
;
Q
;
POST ; Update stop codes in Clinic Stop file 40.7
;
D BMES^XPDUTL("SD*5.3*752 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*752 Post-Install is complete.")
D 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 10/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)
. . . I $D(SDINTERR) 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
. . ; 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 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
;
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 change restriction data for 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
;;QUIT
;
OFF ; codes to be inactivated - ;;code #^^inactive date
;;144^^10/1/2020
;;155^^10/1/2020
;;207^^10/1/2020
;;208^^10/1/2020
;;213^^10/1/2020
;;222^^10/1/2020
;;331^^10/1/2020
;;525^^10/1/2020
;;QUIT
;
CHG ; Code name changes - ;;code name^code #^^new code name
;;^105^^X-RAY & FLUORO (XR & RF)
;;^109^^NUC MED & PET (NM & PET)
;;^110^^INTERVENT RAD CLINIC (IR)
;;^115^^ULTRASOUND (US)
;;^153^^INTERVENT RAD PROCEDURE (IR)
;;^332^^PRE-BED CARE (MED SERVICE)
;;^516^^PTSD OUTPT RES SPEC PROG GRP
;;^562^^PTSD OUTPT RES SPEC PROG INDIV
;;^568^^MH CWT/SE
;;^574^^MH CWT/TWE
;;^703^^MAMMOGRAM (MG)
;;QUIT
;
RT ; Change Restriction - ;;stop code name^CODE #^rest type^rest date
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSD53FY21 11393 printed Apr 09, 2024@21:48:20 Page 2
SD53FY21 ;ALB/TXH - FY21 STOP CODE UPDATES; JUN 11, 2020@17:00
+1 ;;5.3;Scheduling;**752**;AUG 13, 1993;Build 2
+2 ;
+3 ; Post-init routine updating stop codes in CLINIC STOP file
+4 ; (#40.7) for FY21 updates - effective 10/01/2020.
+5 ;
+6 QUIT
+7 ;
POST ; Update stop codes in Clinic Stop file 40.7
+1 ;
+2 DO BMES^XPDUTL("SD*5.3*752 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*752 Post-Install is complete.")
+8 DO MES^XPDUTL("")
+9 KILL SDIEN,%H,%I,DIC,X,Y
+10 ;
+11 QUIT
+12 ;
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 10/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 IF $DATA(SDINTERR)
DO MES^XPDUTL(" >> ... "_$GET(SDINTERR("DIERR",1,"TEXT",1))_".")
+25 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
+26 ; clean out error array b4 processing next code
+27 KILL SDINTERR
End DoDot:3
QUIT
+28 ; check if error
+29 IF $DATA(SDINTERR)
Begin DoDot:3
+30 DO BMES^XPDUTL(" >> ... Unable to inactivate stop code "_SDCODE)
+31 DO MES^XPDUTL(" >> ... "_$GET(SDINTERR("DIERR",1,"TEXT",1))_".")
+32 DO MES^XPDUTL(" >> ... Please contact support for assistance...")
+33 ; clean out error array b4 processing next code
+34 KILL SDINTERR
End DoDot:3
QUIT
+35 ; if no error, check if active
+36 IF $DATA(^DIC(40.7,SDIEN,0))
IF $PIECE(^(0),U,3)=""
Begin DoDot:3
+37 ;code name
SET SDNM=$PIECE($GET(^DIC(40.7,SDIEN,0)),U)
+38 ; set field value
+39 KILL SDFDA
+40 SET SDFDA(40.7,SDIEN_",",2)=SDINDT
+41 DO FILE^DIE(,"SDFDA","SDINTERR")
+42 ; check if error
+43 IF $DATA(SDINTERR)
Begin DoDot:4
+44 DO BMES^XPDUTL(" >> ... Unable to inactivate stop code: "_SDCODE)
+45 DO MES^XPDUTL(" >> ... "_$GET(SDINTERR("DIERR",1,"TEXT",1))_".")
+46 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
+47 ; clean out error array b4 processing next code
+48 KILL SDINTERR
End DoDot:4
QUIT
+49 IF '$DATA(SDINTERR)
Begin DoDot:4
+50 DO BMES^XPDUTL(" >> Inactivated: "_+SDCODE_" "_SDNM_" as of "_SDEXDT)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+51 ;
+52 DO BMES^XPDUTL(">>> Inactivation complete.")
+53 DO MES^XPDUTL("")
+54 KILL %,%DT,%H,%I,DIC,X,Y
+55 ;
+56 QUIT
+57 ;
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 ; check if code already exists
+11 SET SDIEN=$$FIND1^DIC(40.7,"","MX",SDCODE,"","","SDCHGERR")
+12 ; check if error
+13 IF $DATA(SDCHGERR)
Begin DoDot:2
+14 DO BMES^XPDUTL(" >> ... Unable to change name of the stop code: "_SDCODE)
+15 DO MES^XPDUTL(" >> ... "_$GET(SDCHGERR("DIERR",1,"TEXT",1))_".")
+16 DO MES^XPDUTL(" >> ... Please contact support for assistance...")
+17 ; clean out error array b4 processing next code
+18 KILL SDCHGERR
End DoDot:2
QUIT
+19 ; quit if no entry in file
+20 IF 'SDIEN
Begin DoDot:2
+21 DO BMES^XPDUTL(" >> ... Unable to find stop code: "_SDCODE)
+22 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
End DoDot:2
QUIT
+23 ; check if code is active
+24 IF $DATA(^DIC(40.7,SDIEN,0))
IF $PIECE(^(0),U,3)=""
Begin DoDot:2
+25 ; get current name
+26 SET SDNM=$PIECE(^DIC(40.7,SDIEN,0),U,1)
+27 KILL SDFDA
+28 SET SDFDA(40.7,SDIEN_",",.01)=SDNEWNM
+29 DO FILE^DIE(,"SDFDA","SDCHGERR")
+30 ; check if error
+31 IF $DATA(SDCHGERR)
Begin DoDot:3
+32 DO BMES^XPDUTL(" >> ... Unable to change name for stop code: "_SDCODE)
+33 DO MES^XPDUTL(" >> ... "_$GET(SDCHGERR("DIERR",1,"TEXT",1))_".")
+34 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
+35 ; clean out error array b4 processing next code
+36 KILL SDCHGERR
End DoDot:3
QUIT
+37 IF '$DATA(SDCHGERR)
Begin DoDot:3
+38 DO BMES^XPDUTL(" >> Stop Code "_SDCODE_" name changed from: "_SDNM)
+39 DO MES^XPDUTL(" to: "_SDNEWNM)
+40 IF SDNM=SDNEWNM
Begin DoDot:4
+41 DO BMES^XPDUTL(" Stop Code "_SDCODE_" name has already changed.")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+42 ;
+43 DO BMES^XPDUTL(">>> Changing code names complete.")
+44 DO MES^XPDUTL("")
+45 ;
+46 QUIT
+47 ;
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 change restriction data for 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 ;;QUIT
+2 ;
OFF ; codes to be inactivated - ;;code #^^inactive date
+1 ;;144^^10/1/2020
+2 ;;155^^10/1/2020
+3 ;;207^^10/1/2020
+4 ;;208^^10/1/2020
+5 ;;213^^10/1/2020
+6 ;;222^^10/1/2020
+7 ;;331^^10/1/2020
+8 ;;525^^10/1/2020
+9 ;;QUIT
+10 ;
CHG ; Code name changes - ;;code name^code #^^new code name
+1 ;;^105^^X-RAY & FLUORO (XR & RF)
+2 ;;^109^^NUC MED & PET (NM & PET)
+3 ;;^110^^INTERVENT RAD CLINIC (IR)
+4 ;;^115^^ULTRASOUND (US)
+5 ;;^153^^INTERVENT RAD PROCEDURE (IR)
+6 ;;^332^^PRE-BED CARE (MED SERVICE)
+7 ;;^516^^PTSD OUTPT RES SPEC PROG GRP
+8 ;;^562^^PTSD OUTPT RES SPEC PROG INDIV
+9 ;;^568^^MH CWT/SE
+10 ;;^574^^MH CWT/TWE
+11 ;;^703^^MAMMOGRAM (MG)
+12 ;;QUIT
+13 ;
RT ; Change Restriction - ;;stop code name^CODE #^rest type^rest date
+1 ;;QUIT
