ECX3P194 ;MNTVBB/RD - NATIONAL CLINIC (#728.441) File Update; FEB 27, 2025@14:42
;;3.0;DSS EXTRACTS;**194**;Dec 22, 1997;Build 4
;;Per VA Directive 6402, this routine should not be modified.
;
; Post-init routine to deactivate SOGI entry in the NATIONAL CLINIC (#728.441)
; file to comply with Defending Women Executive Order.
;
; Reference(s) to ^%DT supported by ICR# 10003
; Reference(s) to ^DIE supported by ICR# 10018
; Reference(s) to BMES^XPDUTL supported by ICR# 10141
; Reference(s) to MES^XPDUTL supported by ICR# 10141
;
Q
;
POST ;routine entry point
;
D BMES^XPDUTL("Update NATIONAL CLINIC (#728.441) file starts.")
D INACT ;inactivate existing clinic codes
D BMES^XPDUTL("Update complete.")
D MES^XPDUTL("")
;
Q
;
INACT ;* inactivate national clinc codes
;
; ECXX is in format:
; CODE^INACTIVATION DATE
;
N ECX,ECXX,ECXEXDT,ECXINDT,ECXDA,ECXCODE,ECXCNT,DIC,DIE,DA,DR,X,Y,%DT
S ECXCNT=0
D BMES^XPDUTL("*** Inactivating procedures in the EC NATIONAL PROCEDURE File (#728.441)")
D MES^XPDUTL(" ")
F ECX=1:1 K DD,DO,DA S ECXX=$P($T(OLD+ECX),";;",2) Q:ECXX="QUIT" D
.S ECXEXDT=$P(ECXX,U,2),X=ECXEXDT,%DT="X" D ^%DT S ECXINDT=$P(Y,".",1)
.S ECXCODE=$P(ECXX,U)
.D UPINACT
.Q
D BMES^XPDUTL(" Total "_ECXCNT_" CPT codes have been inactivated.")
Q
;
UPINACT ;Update codes as inactive
S ECXDA=+$O(^ECX(728.441,"B",ECXCODE,0))
I $D(^ECX(728.441,ECXDA,0)) D
.S DA=ECXDA,DR="3///^S X=ECXINDT",DIE="^ECX(728.441," D ^DIE
.D MES^XPDUTL(" "_ECXCODE_" inactivated as of "_ECXEXDT_".")
.S ECXCNT=ECXCNT+1
Q
;
OLD ;codes to be inactivated - national clinic code^inact. date
;;SOGI^3/31/2025
;;QUIT
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECX3P194 1701 printed Aug 26, 2025@22:06:33 Page 2
ECX3P194 ;MNTVBB/RD - NATIONAL CLINIC (#728.441) File Update; FEB 27, 2025@14:42
+1 ;;3.0;DSS EXTRACTS;**194**;Dec 22, 1997;Build 4
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Post-init routine to deactivate SOGI entry in the NATIONAL CLINIC (#728.441)
+5 ; file to comply with Defending Women Executive Order.
+6 ;
+7 ; Reference(s) to ^%DT supported by ICR# 10003
+8 ; Reference(s) to ^DIE supported by ICR# 10018
+9 ; Reference(s) to BMES^XPDUTL supported by ICR# 10141
+10 ; Reference(s) to MES^XPDUTL supported by ICR# 10141
+11 ;
+12 QUIT
+13 ;
POST ;routine entry point
+1 ;
+2 DO BMES^XPDUTL("Update NATIONAL CLINIC (#728.441) file starts.")
+3 ;inactivate existing clinic codes
DO INACT
+4 DO BMES^XPDUTL("Update complete.")
+5 DO MES^XPDUTL("")
+6 ;
+7 QUIT
+8 ;
INACT ;* inactivate national clinc codes
+1 ;
+2 ; ECXX is in format:
+3 ; CODE^INACTIVATION DATE
+4 ;
+5 NEW ECX,ECXX,ECXEXDT,ECXINDT,ECXDA,ECXCODE,ECXCNT,DIC,DIE,DA,DR,X,Y,%DT
+6 SET ECXCNT=0
+7 DO BMES^XPDUTL("*** Inactivating procedures in the EC NATIONAL PROCEDURE File (#728.441)")
+8 DO MES^XPDUTL(" ")
+9 FOR ECX=1:1
KILL DD,DO,DA
SET ECXX=$PIECE($TEXT(OLD+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+10 SET ECXEXDT=$PIECE(ECXX,U,2)
SET X=ECXEXDT
SET %DT="X"
DO ^%DT
SET ECXINDT=$PIECE(Y,".",1)
+11 SET ECXCODE=$PIECE(ECXX,U)
+12 DO UPINACT
+13 QUIT
End DoDot:1
+14 DO BMES^XPDUTL(" Total "_ECXCNT_" CPT codes have been inactivated.")
+15 QUIT
+16 ;
UPINACT ;Update codes as inactive
+1 SET ECXDA=+$ORDER(^ECX(728.441,"B",ECXCODE,0))
+2 IF $DATA(^ECX(728.441,ECXDA,0))
Begin DoDot:1
+3 SET DA=ECXDA
SET DR="3///^S X=ECXINDT"
SET DIE="^ECX(728.441,"
DO ^DIE
+4 DO MES^XPDUTL(" "_ECXCODE_" inactivated as of "_ECXEXDT_".")
+5 SET ECXCNT=ECXCNT+1
End DoDot:1
+6 QUIT
+7 ;
OLD ;codes to be inactivated - national clinic code^inact. date
+1 ;;SOGI^3/31/2025
+2 ;;QUIT
+3 ;
