Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: SDES856P

SDES856P.m

Go to the documentation of this file.
  1. SDES856P ;ALB/MGD - FY24 STOP CODE CHANGES; July 12, 2023@11:20
  1. ;;5.3;Scheduling;**856**;AUG 13, 1993;Build 3
  1. ;;Per VHA Directive 6402, this routine should not be modified
  1. ;
  1. ; Post-init routine updating stop codes in CLINIC STOP file (#40.7)
  1. ; for FY24 updates - effective 10/01/2023.
  1. ;
  1. Q
  1. ;
  1. POST ; Update stop codes in Clinic Stop file 40.7
  1. ;
  1. D BMES^XPDUTL("SD*5.3*856 Post-Install starts...")
  1. D:$P($T(NEW+1),";;",2)'="QUIT" ADD ; add new stop code
  1. D:$P($T(OFF+1),";;",2)'="QUIT" INACT ; inactivate
  1. D:$P($T(ON+1),";;",2)'="QUIT" REACT ; reactivate
  1. D:$P($T(CHG+1),";;",2)'="QUIT" CHGNM ; change name
  1. D:$P($T(RT+1),";;",2)'="QUIT" CHGRT ; change restriction data
  1. D MES^XPDUTL("SD*5.3*856 Post-Install is complete."),MES^XPDUTL("")
  1. K SDIEN,%H,%I,DIC,X,Y
  1. ;
  1. Q
  1. ;
  1. ADD ; Add new stop code
  1. ; SDREC is in format:
  1. ; ;;stop code name^code #^restriction type^restriction date^CDR
  1. ;
  1. N SDI,SDREC,SDCODE,SDNM,SDRESTYP,SDFDA,SDADDERR,SDIEN,SDCDR,SDRESIN,SDRESEX
  1. D BMES^XPDUTL(">>> Adding stop code to the CLINIC STOP (#40.7) file...")
  1. D BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used UNTIL 10/01/2023]")
  1. ;
  1. ; load all new entries
  1. F SDI=1:1 S SDREC=$P($T(NEW+SDI),";;",2) Q:SDREC="QUIT" D
  1. . S SDCODE=$P(SDREC,U,2) ;code
  1. . S SDNM=$P(SDREC,U) ;name
  1. . S SDRESTYP=$P(SDREC,U,3) ;restriction type
  1. . S (SDRESIN,SDRESEX)=""
  1. . ; restriction date
  1. . I +$P(SDREC,U,4) D
  1. . . S X=$P(SDREC,U,4)
  1. . . S %DT="FTX"
  1. . . D ^%DT
  1. . . I Y<0 S SDRESIN="" Q
  1. . . S SDRESIN=Y
  1. . . D DD^%DT
  1. . . S SDRESEX=Y
  1. . S SDCDR=$P(SDREC,U,5) ;CDR #
  1. . ;
  1. . ; check if code already exists in file 40.7
  1. . S SDIEN=$$FIND1^DIC(40.7,"","MX",SDCODE,"","","SDADDERR")
  1. . ; quit if error
  1. . I $D(SDADDERR) D Q
  1. . . D BMES^XPDUTL(" >> ... Unable to add stop code "_SDCODE_" "_SDNM_" to file.")
  1. . . D MES^XPDUTL(" >> ... "_$G(SDADDERR("DIERR",1,"TEXT",1))_".")
  1. . . D MES^XPDUTL(" >> ... Please contact support for assistance...")
  1. . . K SDADDERR
  1. . ;
  1. . ; If code already exists, update it.
  1. . I SDIEN D Q
  1. . . K SDADDERR
  1. . . S SDFDA(40.7,SDIEN_",",.01)=SDNM
  1. . . S SDFDA(40.7,SDIEN_",",1)=SDCODE
  1. . . S SDFDA(40.7,SDIEN_",",4)=SDCDR
  1. . . S SDFDA(40.7,SDIEN_",",5)=SDRESTYP
  1. . . S SDFDA(40.7,SDIEN_",",6)=SDRESIN
  1. . . D FILE^DIE(,"SDFDA","SDADDERR")
  1. . . ; check if error
  1. . . I '$D(SDADDERR) D Q
  1. . . . D BMES^XPDUTL(" >> Stop Code "_SDCODE_" "_SDNM_" already exists.")
  1. . . I $D(SDADDERR) D
  1. . . . D BMES^XPDUTL(" ... Unable to add stop code "_SDCODE_" "_SDNM_" to file.")
  1. . . . D MES^XPDUTL(" ... "_$G(SDADDERR("DIERR",1,"TEXT",1))_".")
  1. . . . D MES^XPDUTL(" ... Please contact support for assistance.")
  1. . . . K SDADDERR
  1. . ; if code does not exist, add new entry
  1. . ; set field values of new entry
  1. . S SDFDA(40.7,"+1,",.01)=SDNM
  1. . S SDFDA(40.7,"+1,",1)=SDCODE
  1. . S SDFDA(40.7,"+1,",4)=SDCDR
  1. . S SDFDA(40.7,"+1,",5)=SDRESTYP
  1. . S SDFDA(40.7,"+1,",6)=SDRESIN
  1. . ; add new entry
  1. . D UPDATE^DIE("E","SDFDA","","SDADDERR")
  1. . ; check if error
  1. . I '$D(SDADDERR) D
  1. . . D BMES^XPDUTL(" >> Stop Code "_SDCODE_" "_SDNM_" added to file.")
  1. . I $D(SDADDERR) D
  1. . . D BMES^XPDUTL(" >> ... Unable to add stop code "_SDCODE_" "_SDNM_" to file.")
  1. . . D MES^XPDUTL(" >> ... "_$G(SDADDERR("DIERR",1,"TEXT",1))_".")
  1. . . D MES^XPDUTL(" >> ... Please contact support for assistance.")
  1. . . ; clean out error array b4 processing next code
  1. . . K SDADDERR
  1. ;
  1. D BMES^XPDUTL(">>> Add new stop codes complete.")
  1. D MES^XPDUTL("")
  1. ;
  1. Q
  1. ;
  1. INACT ; Inactivate stop code
  1. ; SDREC is in format: ;;code #^^inactivation date (in FileMan format)
  1. ;
  1. N SDI,SDREC,SDCODE,SDEXDT,SDINDT,SDNM,SDINTERR
  1. D BMES^XPDUTL(">>> Inactivating stop codes in CLINIC STOP (#40.7) file...")
  1. D BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used AFTER the indicated inactivation date.]")
  1. ;
  1. ; load entries w/ inactivate date
  1. F SDI=1:1 S SDREC=$P($T(OFF+SDI),";;",2) Q:SDREC="QUIT" D
  1. . S SDCODE=$P(SDREC,U) ;code
  1. . ; get inactivate date and validate date passed in
  1. . I +$P(SDREC,U,3) D
  1. . . S X=$P(SDREC,U,3)
  1. . . S %DT="FTX"
  1. . . D ^%DT
  1. . . Q:Y<0
  1. . . S SDINDT=Y
  1. . . D DD^%DT
  1. . . S SDEXDT=Y
  1. . . ; check if code already exists
  1. . . S SDIEN=$$FIND1^DIC(40.7,"","MX",SDCODE,"","","SDINTERR")
  1. . . ; quit if unable to find code in 40.7
  1. . . I 'SDIEN D Q
  1. . . . D BMES^XPDUTL(" >> ... Unable to find stop code: "_SDCODE)
  1. . . . D MES^XPDUTL(" >> ... Please contact support for assistance.")
  1. . . ; check if error
  1. . . I $D(SDINTERR) D Q
  1. . . . D BMES^XPDUTL(" >> ... Unable to inactivate stop code "_SDCODE)
  1. . . . D MES^XPDUTL(" >> ... "_$G(SDINTERR("DIERR",1,"TEXT",1))_".")
  1. . . . D MES^XPDUTL(" >> ... Please contact support for assistance...")
  1. . . . ; clean out error array b4 processing next code
  1. . . . K SDINTERR
  1. . . ; if no error, check if active
  1. . . I $D(^DIC(40.7,SDIEN,0)) I $P(^(0),U,3)="" D
  1. . . . S SDNM=$P($G(^DIC(40.7,SDIEN,0)),U) ;code name
  1. . . . ; set field value
  1. . . . K SDFDA
  1. . . . S SDFDA(40.7,SDIEN_",",2)=SDINDT
  1. . . . D FILE^DIE(,"SDFDA","SDINTERR")
  1. . . . ; check if error
  1. . . . I $D(SDINTERR) D Q
  1. . . . . D BMES^XPDUTL(" >> ... Unable to inactivate stop code: "_SDCODE)
  1. . . . . D MES^XPDUTL(" >> ... "_$G(SDINTERR("DIERR",1,"TEXT",1))_".")
  1. . . . . D MES^XPDUTL(" >> ... Please contact support for assistance.")
  1. . . . . ; clean out error array b4 processing next code
  1. . . . . K SDINTERR
  1. . . . I '$D(SDINTERR) D
  1. . . . . D BMES^XPDUTL(" >> Inactivated: "_+SDCODE_" "_SDNM_" as of "_SDEXDT)
  1. ;
  1. D BMES^XPDUTL(">>> Inactivation complete.")
  1. D MES^XPDUTL("")
  1. K %,%DT,%H,%I,DIC,X,Y
  1. ;
  1. Q
  1. ;
  1. REACT ; Reactivate stop code
  1. ; SDREC is in format: ;;code #^^@
  1. ;
  1. N SDI,SDREC,SDCODE,SDEXDT,SDINDT,SDNM,SDINTERR
  1. D BMES^XPDUTL(">>> Reactivating stop codes in CLINIC STOP (#40.7) file...")
  1. D BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used UNTIL 10/01/2023]")
  1. ;
  1. ; load entries w/ @ to delete INACTIVE DATE (#2)
  1. F SDI=1:1 S SDREC=$P($T(ON+SDI),";;",2) Q:SDREC="QUIT" D
  1. . S SDCODE=$P(SDREC,U) ;code
  1. . ; check for delete of INACTIVE DATE field
  1. . I $P(SDREC,U,3)="@" D
  1. . . ; check if code already exists
  1. . . S SDIEN=$$FIND1^DIC(40.7,"","MX",SDCODE,"","","SDINTERR")
  1. . . ; quit if unable to find code in 40.7
  1. . . I 'SDIEN D Q
  1. . . . D BMES^XPDUTL(" >> ... Unable to find stop code: "_SDCODE)
  1. . . . D MES^XPDUTL(" >> ... Please contact support for assistance.")
  1. . . ; check if error
  1. . . I $D(SDINTERR) D Q
  1. . . . D BMES^XPDUTL(" >> ... Unable to reactivate stop code "_SDCODE)
  1. . . . D MES^XPDUTL(" >> ... "_$G(SDINTERR("DIERR",1,"TEXT",1))_".")
  1. . . . D MES^XPDUTL(" >> ... Please contact support for assistance...")
  1. . . . ; clean out error array b4 processing next code
  1. . . . K SDINTERR
  1. . . ; if no error, check if active
  1. . . I $D(^DIC(40.7,SDIEN,0)) D
  1. . . . S SDNM=$P($G(^DIC(40.7,SDIEN,0)),U) ;code name
  1. . . . ; set field value
  1. . . . K SDFDA
  1. . . . S SDFDA(40.7,SDIEN_",",2)="@"
  1. . . . D FILE^DIE(,"SDFDA","SDINTERR")
  1. . . . ; check if error
  1. . . . I $D(SDINTERR) D Q
  1. . . . . D BMES^XPDUTL(" >> ... Unable to reactivate stop code: "_SDCODE)
  1. . . . . D MES^XPDUTL(" >> ... "_$G(SDINTERR("DIERR",1,"TEXT",1))_".")
  1. . . . . D MES^XPDUTL(" >> ... Please contact support for assistance.")
  1. . . . . ; clean out error array b4 processing next code
  1. . . . . K SDINTERR
  1. . . . I '$D(SDINTERR) D
  1. . . . . D BMES^XPDUTL(" >> Reactivated: "_+SDCODE_" "_SDNM_" as of 10/01/2023")
  1. ;
  1. D BMES^XPDUTL(">>> Reactivation complete.")
  1. D MES^XPDUTL("")
  1. K %,%DT,%H,%I,DIC,X,Y
  1. ;
  1. Q
  1. ;
  1. CHGNM ; Change code names
  1. ; SDREC is in format: ;;code name^code #^^new code name
  1. ;
  1. N SDI,SDCODE,SDIEN,SDNEWNM,SDNM,SDREC,SDCHGERR
  1. D BMES^XPDUTL(">>> Changing code names in CLINIC STOP (#40.7) file...")
  1. ;
  1. ; load entries
  1. F SDI=1:1 S SDREC=$P($T(CHG+SDI),";;",2) Q:SDREC="QUIT" D
  1. . S SDNM=$P(SDREC,U) ;current name
  1. . S SDCODE=$P(SDREC,U,2) ;code
  1. . S SDNEWNM=$P(SDREC,U,4) ;new name
  1. . ; check if code already exists
  1. . S SDIEN=$$FIND1^DIC(40.7,"","MX",SDCODE,"","","SDCHGERR")
  1. . ; check if error
  1. . I $D(SDCHGERR) D Q
  1. . . D BMES^XPDUTL(" >> ... Unable to inactivate stop code: "_SDCODE)
  1. . . D MES^XPDUTL(" >> ... "_$G(SDCHGERR("DIERR",1,"TEXT",1))_".")
  1. . . D MES^XPDUTL(" >> ... Please contact support for assistance...")
  1. . . ; clean out error array b4 processing next code
  1. . . K SDCHGERR
  1. . ; quit if no entry in file
  1. . I 'SDIEN D Q
  1. . . D BMES^XPDUTL(" >> ... Unable to find stop code: "_SDCODE)
  1. . . D MES^XPDUTL(" >> ... Please contact support for assistance.")
  1. . ; check if code is active
  1. . I $D(^DIC(40.7,SDIEN,0)) D
  1. . . K SDFDA
  1. . . S SDFDA(40.7,SDIEN_",",.01)=SDNEWNM
  1. . . S SDFDA(40.7,SDIEN_",",2)=""
  1. . . D FILE^DIE(,"SDFDA","SDCHGERR")
  1. . . ; check if error
  1. . . I $D(SDCHGERR) D Q
  1. . . . D BMES^XPDUTL(" >> ... Unable to change name for stop code: "_SDCODE)
  1. . . . D MES^XPDUTL(" >> ... "_$G(SDCHGERR("DIERR",1,"TEXT",1))_".")
  1. . . . D MES^XPDUTL(" >> ... Please contact support for assistance.")
  1. . . . ; clean out error array b4 processing next code
  1. . . . K SDCHGERR
  1. . . I '$D(SDCHGERR) D
  1. . . . D BMES^XPDUTL(" >> Stop Code "_SDCODE_" name changed from: "_SDNM)
  1. . . . D MES^XPDUTL(" to: "_SDNEWNM)
  1. . . . I SDNM=SDNEWNM D
  1. . . . . D BMES^XPDUTL(" Stop Code "_SDCODE_" name has already changed.")
  1. ;
  1. D BMES^XPDUTL(">>> Changing code names complete.")
  1. D MES^XPDUTL("")
  1. ;
  1. Q
  1. ;
  1. CHGRT ; Change restriction data
  1. ; SDREC is in format: ;;code name^code #^restriction type^restriction date
  1. N SDI,SDREC,SDNM,SDNUM,SDRTERR,SDIEN,SDOLDRT,SDRD,SDRT,SDX,SDINDT,SDEXRD,SDRDEX,SDRDIN
  1. D BMES^XPDUTL(">>> Changing restriction data in CLINIC STOP (#40.7) file...")
  1. ; load new entry
  1. F SDI=1:1 S SDREC=$P($T(RT+SDI),";;",2) Q:SDREC="QUIT" D
  1. . S SDNM=$P(SDREC,U) ; code name
  1. . S SDNUM=$P(SDREC,U,2) ; code #
  1. . S SDRT=$P(SDREC,U,3) ; restriction type
  1. . S SDRD=$P(SDREC,U,4) ; restriction date
  1. . ;
  1. . ; check if code already exists and get code IEN
  1. . S SDIEN=$$FIND1^DIC(40.7,"","MX",SDNUM,"","","SDRTERR")
  1. . ; check if error
  1. . I $D(SDRTERR) D Q
  1. . . D BMES^XPDUTL(" >> ... Unable to change restriction type: "_SDNUM)
  1. . . D MES^XPDUTL(" >> ... "_$G(SDRTERR("DIERR",1,"TEXT",1))_".")
  1. . . D MES^XPDUTL(" >> ... Please contact support for assistance...")
  1. . . ; clean out error array b4 processing next code
  1. . . K SDRTERR
  1. . I 'SDIEN D Q
  1. . . D BMES^XPDUTL(" >> ... Unable to find stop code: "_SDNUM)
  1. . . D MES^XPDUTL(" >> ... Please contact support for assistance.")
  1. . ; find current restriction type and date
  1. . I $D(^DIC(40.7,SDIEN,0)) D
  1. . . S SDOLDRT=$P(^DIC(40.7,SDIEN,0),U,6) ; old restriction type
  1. . . S SDEXRD=""
  1. . . S X=$P(^DIC(40.7,SDIEN,0),U,7) ; old restriction date
  1. . . S %DT="FTX" D ^%DT Q:Y<0
  1. . . S SDINDT=Y D DD^%DT S SDEXRD=Y
  1. . ; set field value
  1. . ; new restriction date
  1. . S X=SDRD
  1. . S %DT="FTX"
  1. . D ^%DT
  1. . I Y<0 S SDRDIN="" Q
  1. . S SDRDIN=Y
  1. . D DD^%DT
  1. . S SDRDEX=Y
  1. . ;
  1. . K SDFDA
  1. . S SDFDA(40.7,SDIEN_",",2)=""
  1. . S SDFDA(40.7,SDIEN_",",5)=SDRT
  1. . S SDFDA(40.7,SDIEN_",",6)=SDRDIN ; save internal dt
  1. . D FILE^DIE(,"SDFDA","SDRTERR")
  1. . I SDOLDRT'=SDRT D
  1. . . D BMES^XPDUTL(" >> Stop Code "_SDNUM_" restriction type changed from: "_SDOLDRT)
  1. . . D MES^XPDUTL(" to: "_SDRT)
  1. . E D
  1. . . D BMES^XPDUTL(" >> Stop Code "_SDNUM_" restriction type changed from: "_SDOLDRT)
  1. . . D MES^XPDUTL(" to: "_SDRT)
  1. . . D BMES^XPDUTL(" restriction type has already changed.")
  1. . I SDEXRD'=SDRDEX D
  1. . . D BMES^XPDUTL(" >> restriction date changed from: "_SDEXRD)
  1. . . D MES^XPDUTL(" to: "_SDRDEX)
  1. . E D
  1. . . D BMES^XPDUTL(" >> restriction date changed from: "_SDEXRD)
  1. . . D MES^XPDUTL(" to: "_SDRDEX)
  1. . . D BMES^XPDUTL(" restriction date has already changed.")
  1. D BMES^XPDUTL(">>> Changing restriction data complete.")
  1. D MES^XPDUTL("")
  1. K %,%DT,%H,%I,DIC,X,Y,SDFDA
  1. Q
  1. ;
  1. NEW ; codes to add - ;;stop code name^code #^restriction type^restriction date^CDR
  1. ;;QUIT
  1. ;
  1. OFF ; codes to be inactivated - ;;code #^^inactive date
  1. ;;290^^10/1/2023
  1. ;;291^^10/1/2023
  1. ;;292^^10/1/2023
  1. ;;293^^10/1/2023
  1. ;;296^^10/1/2023
  1. ;;297^^10/1/2023
  1. ;;573^^10/1/2023
  1. ;;QUIT
  1. ;
  1. ON ; codes to be reactivated - ;;code #^^@
  1. ;;129^^@
  1. ;;569^^@
  1. ;;QUIT
  1. ;
  1. CHG ; Code name changes - ;;code name^code #^^new code name
  1. ;;HYPERTENSION SCREENING^129^^VA EMERGENCY AMBULANCE SRVS
  1. ;;URGENT CARE CLINIC^131^^URGENT CARE
  1. ;;COMP WOMEN'S HLTH^322^^COMP WMS HLTH GNDR DIVERSE PC
  1. ;;MH CWT/SE NON-F TO F (MAS NONC^569^^COMMTY BASED EMPLOY SRVS CBES
  1. ;;WMS SPECIFIC PREVENTIVE CARE^704^^WMS GNDR DIVERSE PREVENT CARE
  1. ;;TELE-ICU PATIENT SITE^901^^TELECRITCAL CARE PATIENT SITE
  1. ;;QUIT
  1. ;
  1. RT ; Change Restriction - ;;stop code name^CODE #^rest type^rest date
  1. ;;VA EMERGENCY AMBULANCE SRVS^129^P^10/1/2023
  1. ;;COMMUNITY ADHC FOLLOWUP^191^E^10/1/2023
  1. ;;QUIT