EC2P167C ;HDSO/RD - EC National Procedure Update; Nov 30, 2023@09:50
;;2.0;EVENT CAPTURE;**167**;May 8, 1996;Build 4
;;Per VA Directive 6402, this routine should not be modified.
;
; This routine is used as a post-init in a KIDS build
; to inactivate national procedure codes and update
; CPT codes in the EC National Procedure file (#725).
;
; references to ^%DT supported by ICR# 10003
; References to $$FIND1^DIC supported by ICR# 2051
; References to ^DIE supported by ICR# 10018
; References to BMES^XPDUTL supported by ICR# 10141
; References to MES^XPDUTL supported by ICR# 10141
;
Q
;
REACT ;* reactivate national procedures
;
; ECREC is in format: CODE #^
;
N ECDA,ECX,ECXX,DA,DIE,DR,ECERR,ECNT
D BMES^XPDUTL("*** Reactivating Procedure in EC NATIONAL PROCEDURE File (#725)")
;
; Load entries
S ECNT=0
F ECX=1:1 K DD,DO,DA S ECXX=$P($T(ACT+ECX),";;",2) Q:ECXX="QUIT" D
. S ECDA=+$O(^EC(725,"D",ECXX,0))
. ; Check if inactive
. I $P($G(^EC(725,ECDA,0)),U,3)'="" D
. . K ECFDA
. . S ECFDA(725,ECDA_",",2)=""
. . D FILE^DIE(,"ECFDA","ECERR")
. . ; check if error
. . I '$D(ECERR) D BMES^XPDUTL(" Reactivated: "_ECXX_" "_$P($G(^EC(725,ECDA,0)),"^",1))
. . I $D(ECERR) D Q
. . . D BMES^XPDUTL(" >> ... Unable to reactivate stop code: "_ECDA)
. . . D MES^XPDUTL(" >> ... "_$G(ECERR("DIERR",1,"TEXT",1))_".")
. . . D MES^XPDUTL(" >> ... Please contact support for assistance...")
. . . K ECERR
. . S ECNT=ECNT+1
D BMES^XPDUTL(" Total "_ECNT_" procedure codes have been reactivated.")
D MES^XPDUTL(" ")
Q
;
ACT ; Code to be reactivated - ;;number^
;;QUIT
;
INACT ;* inactivate national procedures
;
; ECXX is in format:
; NATIONAL NUMBER^INACTIVATION DATE^FIRST NATIONAL NUMBER SEQUENCE^
; LAST NATIONAL NUMBER SEQUENCE
;
N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
N ECSEQ,ECCODE,ECCODX,ECCNT2
S ECCNT2=0
D BMES^XPDUTL("*** Inactivating procedures in the EC NATIONAL PROCEDURE File (#725)")
D MES^XPDUTL(" ")
F ECX=1:1 K DD,DO,DA S ECXX=$P($T(OLD+ECX),";;",2) Q:ECXX="QUIT" D
.S ECEXDT=$P(ECXX,U,2),X=ECEXDT,%DT="X" D ^%DT S ECINDT=$P(Y,".",1)
.S ECCODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),ECCODX=ECCODE
.I ECBEG="" D UPINACT Q
.F ECSEQ=ECBEG:1:ECEND D
..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
..S ECCODE=ECCODX_ECADD
..D UPINACT
D BMES^XPDUTL(" Total "_ECCNT2_" CPT codes have been inactivated.")
Q
;
UPINACT ;Update codes as inactive
S ECDA=+$O(^EC(725,"D",ECCODE,0))
I $D(^EC(725,ECDA,0)) D
.S DA=ECDA,DR="2///^S X=ECINDT",DIE="^EC(725," D ^DIE
.D MES^XPDUTL(" "_ECCODE_" inactivated as of "_ECEXDT_".")
.S ECCNT2=ECCNT2+1
Q
;
OLD ;national procedures to be inactivated - national code#^inact. date
;;NU052^4/1/2024
;;NU053^4/1/2024
;;NU054^4/1/2024
;;NU055^4/1/2024
;;NU077^4/1/2024
;;NU078^4/1/2024
;;NU079^4/1/2024
;;NU080^4/1/2024
;;NU085^4/1/2024
;;NU086^4/1/2024
;;NU087^4/1/2024
;;NU088^4/1/2024
;;NU093^4/1/2024
;;NU163^4/1/2024
;;NU168^4/1/2024
;;NU170^4/1/2024
;;NU175^4/1/2024
;;NU176^4/1/2024
;;NU184^4/1/2024
;;NU185^4/1/2024
;;NU190^4/1/2024
;;NU192^4/1/2024
;;NU193^4/1/2024
;;NU194^4/1/2024
;;NU204^4/1/2024
;;NU217^4/1/2024
;;NU218^4/1/2024
;;NU219^4/1/2024
;;NU220^4/1/2024
;;NU222^4/1/2024
;;SW182^4/1/2024
;;QUIT
;
CPTCHG ;* change cpt codes
;
; ECXX is in format:
; NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL
; NUMBER SEQUENCE
;
N ECX,ECXX,ECCPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,ECSEQ,ECSTR,ECCPTIEN
D MES^XPDUTL("*** Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
D MES^XPDUTL(" ")
;
N ECCNT3,ECCNT33 S (ECCNT3,ECCNT33)=0
F ECX=1:1 S ECXX=$P($T(CPT+ECX),";;",2) Q:ECXX="QUIT" D
.S ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),ECCPTIEN=$P(ECXX,U,2)
.S ECCPTIEN=$S(ECCPTIEN="":"@",1:$$FIND1^DIC(81,"","X",ECCPTIEN))
.I ECCPTIEN'="@",+ECCPTIEN<1 D Q
..S ECSTR=$P(ECXX,U)_": CPT code "_$P(ECXX,U,2)_" is invalid."
..D MES^XPDUTL(" ")
..D MES^XPDUTL(" "_ECSTR)
.I ECBEG="" S ECCPT($P(ECXX,U))=ECCPTIEN_U_$P(ECXX,U,2) Q
.F ECSEQ=ECBEG:1:ECEND D
..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
..S ECCPT($P(ECXX,U)_ECADD)=ECCPTIEN_U_$P(ECXX,U,2)
;
S ECXX=""
F S ECXX=$O(ECCPT(ECXX)) Q:ECXX="" D
.S ECX=$O(^EC(725,"D",ECXX,0))
.Q:+ECX=0
.I '$D(^EC(725,ECX,0))!(+ECX=0) D Q
..D MES^XPDUTL(" ")
..D MES^XPDUTL(" Can't find entry for "_ECXX_",CPT code not updated.")
..S ECCNT33=ECCNT33+1
.S ECCPT=$P(ECCPT(ECXX),U),DA=ECX,DR="4///"_ECCPT,DIE="^EC(725," D ^DIE
.S ECSTR=" Entry #"_ECX_" for "_ECXX
.D MES^XPDUTL(ECSTR_" updated to use CPT code "_$P(ECCPT(ECXX),U,2))
.S ECCNT3=ECCNT3+1
;
D BMES^XPDUTL(" Total "_ECCNT3_" CPT codes have been updated.")
I ECCNT33>0 D MES^XPDUTL(" Total "_ECCNT33_" CPT codes did NOT get updated.")
Q
;
CPT ;cpt codes to be changed - national #^new CPT code
;;SW122^S0257
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P167C 5080 printed Oct 16, 2024@17:56:30 Page 2
EC2P167C ;HDSO/RD - EC National Procedure Update; Nov 30, 2023@09:50
+1 ;;2.0;EVENT CAPTURE;**167**;May 8, 1996;Build 4
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; This routine is used as a post-init in a KIDS build
+5 ; to inactivate national procedure codes and update
+6 ; CPT codes in the EC National Procedure file (#725).
+7 ;
+8 ; references to ^%DT supported by ICR# 10003
+9 ; References to $$FIND1^DIC supported by ICR# 2051
+10 ; References to ^DIE supported by ICR# 10018
+11 ; References to BMES^XPDUTL supported by ICR# 10141
+12 ; References to MES^XPDUTL supported by ICR# 10141
+13 ;
+14 QUIT
+15 ;
REACT ;* reactivate national procedures
+1 ;
+2 ; ECREC is in format: CODE #^
+3 ;
+4 NEW ECDA,ECX,ECXX,DA,DIE,DR,ECERR,ECNT
+5 DO BMES^XPDUTL("*** Reactivating Procedure in EC NATIONAL PROCEDURE File (#725)")
+6 ;
+7 ; Load entries
+8 SET ECNT=0
+9 FOR ECX=1:1
KILL DD,DO,DA
SET ECXX=$PIECE($TEXT(ACT+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+10 SET ECDA=+$ORDER(^EC(725,"D",ECXX,0))
+11 ; Check if inactive
+12 IF $PIECE($GET(^EC(725,ECDA,0)),U,3)'=""
Begin DoDot:2
+13 KILL ECFDA
+14 SET ECFDA(725,ECDA_",",2)=""
+15 DO FILE^DIE(,"ECFDA","ECERR")
+16 ; check if error
+17 IF '$DATA(ECERR)
DO BMES^XPDUTL(" Reactivated: "_ECXX_" "_$PIECE($GET(^EC(725,ECDA,0)),"^",1))
+18 IF $DATA(ECERR)
Begin DoDot:3
+19 DO BMES^XPDUTL(" >> ... Unable to reactivate stop code: "_ECDA)
+20 DO MES^XPDUTL(" >> ... "_$GET(ECERR("DIERR",1,"TEXT",1))_".")
+21 DO MES^XPDUTL(" >> ... Please contact support for assistance...")
+22 KILL ECERR
End DoDot:3
QUIT
+23 SET ECNT=ECNT+1
End DoDot:2
End DoDot:1
+24 DO BMES^XPDUTL(" Total "_ECNT_" procedure codes have been reactivated.")
+25 DO MES^XPDUTL(" ")
+26 QUIT
+27 ;
ACT ; Code to be reactivated - ;;number^
+1 ;;QUIT
+2 ;
INACT ;* inactivate national procedures
+1 ;
+2 ; ECXX is in format:
+3 ; NATIONAL NUMBER^INACTIVATION DATE^FIRST NATIONAL NUMBER SEQUENCE^
+4 ; LAST NATIONAL NUMBER SEQUENCE
+5 ;
+6 NEW ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
+7 NEW ECSEQ,ECCODE,ECCODX,ECCNT2
+8 SET ECCNT2=0
+9 DO BMES^XPDUTL("*** Inactivating procedures in the EC NATIONAL PROCEDURE File (#725)")
+10 DO MES^XPDUTL(" ")
+11 FOR ECX=1:1
KILL DD,DO,DA
SET ECXX=$PIECE($TEXT(OLD+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+12 SET ECEXDT=$PIECE(ECXX,U,2)
SET X=ECEXDT
SET %DT="X"
DO ^%DT
SET ECINDT=$PIECE(Y,".",1)
+13 SET ECCODE=$PIECE(ECXX,U)
SET ECBEG=$PIECE(ECXX,U,3)
SET ECEND=$PIECE(ECXX,U,4)
SET ECCODX=ECCODE
+14 IF ECBEG=""
DO UPINACT
QUIT
+15 FOR ECSEQ=ECBEG:1:ECEND
Begin DoDot:2
+16 SET ECADD="000"_ECSEQ
SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
+17 SET ECCODE=ECCODX_ECADD
+18 DO UPINACT
End DoDot:2
End DoDot:1
+19 DO BMES^XPDUTL(" Total "_ECCNT2_" CPT codes have been inactivated.")
+20 QUIT
+21 ;
UPINACT ;Update codes as inactive
+1 SET ECDA=+$ORDER(^EC(725,"D",ECCODE,0))
+2 IF $DATA(^EC(725,ECDA,0))
Begin DoDot:1
+3 SET DA=ECDA
SET DR="2///^S X=ECINDT"
SET DIE="^EC(725,"
DO ^DIE
+4 DO MES^XPDUTL(" "_ECCODE_" inactivated as of "_ECEXDT_".")
+5 SET ECCNT2=ECCNT2+1
End DoDot:1
+6 QUIT
+7 ;
OLD ;national procedures to be inactivated - national code#^inact. date
+1 ;;NU052^4/1/2024
+2 ;;NU053^4/1/2024
+3 ;;NU054^4/1/2024
+4 ;;NU055^4/1/2024
+5 ;;NU077^4/1/2024
+6 ;;NU078^4/1/2024
+7 ;;NU079^4/1/2024
+8 ;;NU080^4/1/2024
+9 ;;NU085^4/1/2024
+10 ;;NU086^4/1/2024
+11 ;;NU087^4/1/2024
+12 ;;NU088^4/1/2024
+13 ;;NU093^4/1/2024
+14 ;;NU163^4/1/2024
+15 ;;NU168^4/1/2024
+16 ;;NU170^4/1/2024
+17 ;;NU175^4/1/2024
+18 ;;NU176^4/1/2024
+19 ;;NU184^4/1/2024
+20 ;;NU185^4/1/2024
+21 ;;NU190^4/1/2024
+22 ;;NU192^4/1/2024
+23 ;;NU193^4/1/2024
+24 ;;NU194^4/1/2024
+25 ;;NU204^4/1/2024
+26 ;;NU217^4/1/2024
+27 ;;NU218^4/1/2024
+28 ;;NU219^4/1/2024
+29 ;;NU220^4/1/2024
+30 ;;NU222^4/1/2024
+31 ;;SW182^4/1/2024
+32 ;;QUIT
+33 ;
CPTCHG ;* change cpt codes
+1 ;
+2 ; ECXX is in format:
+3 ; NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL
+4 ; NUMBER SEQUENCE
+5 ;
+6 NEW ECX,ECXX,ECCPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,ECSEQ,ECSTR,ECCPTIEN
+7 DO MES^XPDUTL("*** Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
+8 DO MES^XPDUTL(" ")
+9 ;
+10 NEW ECCNT3,ECCNT33
SET (ECCNT3,ECCNT33)=0
+11 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(CPT+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+12 SET ECBEG=$PIECE(ECXX,U,3)
SET ECEND=$PIECE(ECXX,U,4)
SET ECCPTIEN=$PIECE(ECXX,U,2)
+13 SET ECCPTIEN=$SELECT(ECCPTIEN="":"@",1:$$FIND1^DIC(81,"","X",ECCPTIEN))
+14 IF ECCPTIEN'="@"
IF +ECCPTIEN<1
Begin DoDot:2
+15 SET ECSTR=$PIECE(ECXX,U)_": CPT code "_$PIECE(ECXX,U,2)_" is invalid."
+16 DO MES^XPDUTL(" ")
+17 DO MES^XPDUTL(" "_ECSTR)
End DoDot:2
QUIT
+18 IF ECBEG=""
SET ECCPT($PIECE(ECXX,U))=ECCPTIEN_U_$PIECE(ECXX,U,2)
QUIT
+19 FOR ECSEQ=ECBEG:1:ECEND
Begin DoDot:2
+20 SET ECADD="000"_ECSEQ
SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
+21 SET ECCPT($PIECE(ECXX,U)_ECADD)=ECCPTIEN_U_$PIECE(ECXX,U,2)
End DoDot:2
End DoDot:1
+22 ;
+23 SET ECXX=""
+24 FOR
SET ECXX=$ORDER(ECCPT(ECXX))
if ECXX=""
QUIT
Begin DoDot:1
+25 SET ECX=$ORDER(^EC(725,"D",ECXX,0))
+26 if +ECX=0
QUIT
+27 IF '$DATA(^EC(725,ECX,0))!(+ECX=0)
Begin DoDot:2
+28 DO MES^XPDUTL(" ")
+29 DO MES^XPDUTL(" Can't find entry for "_ECXX_",CPT code not updated.")
+30 SET ECCNT33=ECCNT33+1
End DoDot:2
QUIT
+31 SET ECCPT=$PIECE(ECCPT(ECXX),U)
SET DA=ECX
SET DR="4///"_ECCPT
SET DIE="^EC(725,"
DO ^DIE
+32 SET ECSTR=" Entry #"_ECX_" for "_ECXX
+33 DO MES^XPDUTL(ECSTR_" updated to use CPT code "_$PIECE(ECCPT(ECXX),U,2))
+34 SET ECCNT3=ECCNT3+1
End DoDot:1
+35 ;
+36 DO BMES^XPDUTL(" Total "_ECCNT3_" CPT codes have been updated.")
+37 IF ECCNT33>0
DO MES^XPDUTL(" Total "_ECCNT33_" CPT codes did NOT get updated.")
+38 QUIT
+39 ;
CPT ;cpt codes to be changed - national #^new CPT code
+1 ;;SW122^S0257
+2 ;;QUIT
