- SDES856P ;ALB/MGD - FY24 STOP CODE CHANGES; July 12, 2023@11:20
- ;;5.3;Scheduling;**856**;AUG 13, 1993;Build 3
- ;;Per VHA Directive 6402, this routine should not be modified
- ;
- ; Post-init routine updating stop codes in CLINIC STOP file (#40.7)
- ; for FY24 updates - effective 10/01/2023.
- ;
- Q
- ;
- POST ; Update stop codes in Clinic Stop file 40.7
- ;
- D BMES^XPDUTL("SD*5.3*856 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(ON+1),";;",2)'="QUIT" REACT ; reactivate
- 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*856 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 10/01/2023]")
- ;
- ; 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
- ;
- REACT ; Reactivate stop code
- ; SDREC is in format: ;;code #^^@
- ;
- N SDI,SDREC,SDCODE,SDEXDT,SDINDT,SDNM,SDINTERR
- D BMES^XPDUTL(">>> Reactivating stop codes in CLINIC STOP (#40.7) file...")
- D BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used UNTIL 10/01/2023]")
- ;
- ; load entries w/ @ to delete INACTIVE DATE (#2)
- F SDI=1:1 S SDREC=$P($T(ON+SDI),";;",2) Q:SDREC="QUIT" D
- . S SDCODE=$P(SDREC,U) ;code
- . ; check for delete of INACTIVE DATE field
- . I $P(SDREC,U,3)="@" D
- . . ; 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 reactivate 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)) D
- . . . S SDNM=$P($G(^DIC(40.7,SDIEN,0)),U) ;code name
- . . . ; set field value
- . . . K SDFDA
- . . . S SDFDA(40.7,SDIEN_",",2)="@"
- . . . D FILE^DIE(,"SDFDA","SDINTERR")
- . . . ; check if error
- . . . I $D(SDINTERR) D Q
- . . . . D BMES^XPDUTL(" >> ... Unable to reactivate 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(" >> Reactivated: "_+SDCODE_" "_SDNM_" as of 10/01/2023")
- ;
- D BMES^XPDUTL(">>> Reactivation 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)) D
- . . K SDFDA
- . . S SDFDA(40.7,SDIEN_",",.01)=SDNEWNM
- . . S SDFDA(40.7,SDIEN_",",2)=""
- . . 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 type: "_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)) 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_",",2)=""
- . 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
- ;;290^^10/1/2023
- ;;291^^10/1/2023
- ;;292^^10/1/2023
- ;;293^^10/1/2023
- ;;296^^10/1/2023
- ;;297^^10/1/2023
- ;;573^^10/1/2023
- ;;QUIT
- ;
- ON ; codes to be reactivated - ;;code #^^@
- ;;129^^@
- ;;569^^@
- ;;QUIT
- ;
- CHG ; Code name changes - ;;code name^code #^^new code name
- ;;HYPERTENSION SCREENING^129^^VA EMERGENCY AMBULANCE SRVS
- ;;URGENT CARE CLINIC^131^^URGENT CARE
- ;;COMP WOMEN'S HLTH^322^^COMP WMS HLTH GNDR DIVERSE PC
- ;;MH CWT/SE NON-F TO F (MAS NONC^569^^COMMTY BASED EMPLOY SRVS CBES
- ;;WMS SPECIFIC PREVENTIVE CARE^704^^WMS GNDR DIVERSE PREVENT CARE
- ;;TELE-ICU PATIENT SITE^901^^TELECRITCAL CARE PATIENT SITE
- ;;QUIT
- ;
- RT ; Change Restriction - ;;stop code name^CODE #^rest type^rest date
- ;;VA EMERGENCY AMBULANCE SRVS^129^P^10/1/2023
- ;;COMMUNITY ADHC FOLLOWUP^191^E^10/1/2023
- ;;QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDES856P 13486 printed Jan 18, 2025@03:56:23 Page 2
- SDES856P ;ALB/MGD - FY24 STOP CODE CHANGES; July 12, 2023@11:20
- +1 ;;5.3;Scheduling;**856**;AUG 13, 1993;Build 3
- +2 ;;Per VHA Directive 6402, this routine should not be modified
- +3 ;
- +4 ; Post-init routine updating stop codes in CLINIC STOP file (#40.7)
- +5 ; for FY24 updates - effective 10/01/2023.
- +6 ;
- +7 QUIT
- +8 ;
- POST ; Update stop codes in Clinic Stop file 40.7
- +1 ;
- +2 DO BMES^XPDUTL("SD*5.3*856 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 ; reactivate
- if $PIECE($TEXT(ON+1),";;",2)'="QUIT"
- DO REACT
- +6 ; change name
- if $PIECE($TEXT(CHG+1),";;",2)'="QUIT"
- DO CHGNM
- +7 ; change restriction data
- if $PIECE($TEXT(RT+1),";;",2)'="QUIT"
- DO CHGRT
- +8 DO MES^XPDUTL("SD*5.3*856 Post-Install is complete.")
- 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/2023]")
- +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 ;
- REACT ; Reactivate stop code
- +1 ; SDREC is in format: ;;code #^^@
- +2 ;
- +3 NEW SDI,SDREC,SDCODE,SDEXDT,SDINDT,SDNM,SDINTERR
- +4 DO BMES^XPDUTL(">>> Reactivating stop codes in CLINIC STOP (#40.7) file...")
- +5 DO BMES^XPDUTL(" [NOTE: These Stop Codes CANNOT be used UNTIL 10/01/2023]")
- +6 ;
- +7 ; load entries w/ @ to delete INACTIVE DATE (#2)
- +8 FOR SDI=1:1
- SET SDREC=$PIECE($TEXT(ON+SDI),";;",2)
- if SDREC="QUIT"
- QUIT
- Begin DoDot:1
- +9 ;code
- SET SDCODE=$PIECE(SDREC,U)
- +10 ; check for delete of INACTIVE DATE field
- +11 IF $PIECE(SDREC,U,3)="@"
- Begin DoDot:2
- +12 ; check if code already exists
- +13 SET SDIEN=$$FIND1^DIC(40.7,"","MX",SDCODE,"","","SDINTERR")
- +14 ; quit if unable to find code in 40.7
- +15 IF 'SDIEN
- Begin DoDot:3
- +16 DO BMES^XPDUTL(" >> ... Unable to find stop code: "_SDCODE)
- +17 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
- End DoDot:3
- QUIT
- +18 ; check if error
- +19 IF $DATA(SDINTERR)
- Begin DoDot:3
- +20 DO BMES^XPDUTL(" >> ... Unable to reactivate stop code "_SDCODE)
- +21 DO MES^XPDUTL(" >> ... "_$GET(SDINTERR("DIERR",1,"TEXT",1))_".")
- +22 DO MES^XPDUTL(" >> ... Please contact support for assistance...")
- +23 ; clean out error array b4 processing next code
- +24 KILL SDINTERR
- End DoDot:3
- QUIT
- +25 ; if no error, check if active
- +26 IF $DATA(^DIC(40.7,SDIEN,0))
- Begin DoDot:3
- +27 ;code name
- SET SDNM=$PIECE($GET(^DIC(40.7,SDIEN,0)),U)
- +28 ; set field value
- +29 KILL SDFDA
- +30 SET SDFDA(40.7,SDIEN_",",2)="@"
- +31 DO FILE^DIE(,"SDFDA","SDINTERR")
- +32 ; check if error
- +33 IF $DATA(SDINTERR)
- Begin DoDot:4
- +34 DO BMES^XPDUTL(" >> ... Unable to reactivate stop code: "_SDCODE)
- +35 DO MES^XPDUTL(" >> ... "_$GET(SDINTERR("DIERR",1,"TEXT",1))_".")
- +36 DO MES^XPDUTL(" >> ... Please contact support for assistance.")
- +37 ; clean out error array b4 processing next code
- +38 KILL SDINTERR
- End DoDot:4
- QUIT
- +39 IF '$DATA(SDINTERR)
- Begin DoDot:4
- +40 DO BMES^XPDUTL(" >> Reactivated: "_+SDCODE_" "_SDNM_" as of 10/01/2023")
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +41 ;
- +42 DO BMES^XPDUTL(">>> Reactivation complete.")
- +43 DO MES^XPDUTL("")
- +44 KILL %,%DT,%H,%I,DIC,X,Y
- +45 ;
- +46 QUIT
- +47 ;
- 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))
- Begin DoDot:2
- +26 KILL SDFDA
- +27 SET SDFDA(40.7,SDIEN_",",.01)=SDNEWNM
- +28 SET SDFDA(40.7,SDIEN_",",2)=""
- +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 type: "_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))
- 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_",",2)=""
- +42 SET SDFDA(40.7,SDIEN_",",5)=SDRT
- +43 ; save internal dt
- SET SDFDA(40.7,SDIEN_",",6)=SDRDIN
- +44 DO FILE^DIE(,"SDFDA","SDRTERR")
- +45 IF SDOLDRT'=SDRT
- Begin DoDot:2
- +46 DO BMES^XPDUTL(" >> Stop Code "_SDNUM_" restriction type changed from: "_SDOLDRT)
- +47 DO MES^XPDUTL(" to: "_SDRT)
- End DoDot:2
- +48 IF '$TEST
- Begin DoDot:2
- +49 DO BMES^XPDUTL(" >> Stop Code "_SDNUM_" restriction type changed from: "_SDOLDRT)
- +50 DO MES^XPDUTL(" to: "_SDRT)
- +51 DO BMES^XPDUTL(" restriction type has already changed.")
- End DoDot:2
- +52 IF SDEXRD'=SDRDEX
- Begin DoDot:2
- +53 DO BMES^XPDUTL(" >> restriction date changed from: "_SDEXRD)
- +54 DO MES^XPDUTL(" to: "_SDRDEX)
- End DoDot:2
- +55 IF '$TEST
- Begin DoDot:2
- +56 DO BMES^XPDUTL(" >> restriction date changed from: "_SDEXRD)
- +57 DO MES^XPDUTL(" to: "_SDRDEX)
- +58 DO BMES^XPDUTL(" restriction date has already changed.")
- End DoDot:2
- End DoDot:1
- +59 DO BMES^XPDUTL(">>> Changing restriction data complete.")
- +60 DO MES^XPDUTL("")
- +61 KILL %,%DT,%H,%I,DIC,X,Y,SDFDA
- +62 QUIT
- +63 ;
- 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 ;;290^^10/1/2023
- +2 ;;291^^10/1/2023
- +3 ;;292^^10/1/2023
- +4 ;;293^^10/1/2023
- +5 ;;296^^10/1/2023
- +6 ;;297^^10/1/2023
- +7 ;;573^^10/1/2023
- +8 ;;QUIT
- +9 ;
- ON ; codes to be reactivated - ;;code #^^@
- +1 ;;129^^@
- +2 ;;569^^@
- +3 ;;QUIT
- +4 ;
- CHG ; Code name changes - ;;code name^code #^^new code name
- +1 ;;HYPERTENSION SCREENING^129^^VA EMERGENCY AMBULANCE SRVS
- +2 ;;URGENT CARE CLINIC^131^^URGENT CARE
- +3 ;;COMP WOMEN'S HLTH^322^^COMP WMS HLTH GNDR DIVERSE PC
- +4 ;;MH CWT/SE NON-F TO F (MAS NONC^569^^COMMTY BASED EMPLOY SRVS CBES
- +5 ;;WMS SPECIFIC PREVENTIVE CARE^704^^WMS GNDR DIVERSE PREVENT CARE
- +6 ;;TELE-ICU PATIENT SITE^901^^TELECRITCAL CARE PATIENT SITE
- +7 ;;QUIT
- +8 ;
- RT ; Change Restriction - ;;stop code name^CODE #^rest type^rest date
- +1 ;;VA EMERGENCY AMBULANCE SRVS^129^P^10/1/2023
- +2 ;;COMMUNITY ADHC FOLLOWUP^191^E^10/1/2023
- +3 ;;QUIT