EC725U21 ;ALB/GTS/JAP/JAM - EC National Procedure Update; 12/19/02
;;2.0; EVENT CAPTURE ;**48**;8 May 96
;
;this routine is used as a post-init in KIDS build
;to modify the the EC National Procedure file #725
;
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,CODE,CODX
D MES^XPDUTL(" ")
D BMES^XPDUTL("Inactivating procedures 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 CODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CODX=CODE
.I ECBEG="" D UPINACT Q
.F ECSEQ=ECBEG:1:ECEND D
..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
..S CODE=CODX_ECADD
..D UPINACT
Q
UPINACT ;Update codes as inactive
;
S ECDA=+$O(^EC(725,"D",CODE,0))
I $D(^EC(725,ECDA,0)) D
.S DA=ECDA,DR="2////^S X=ECINDT",DIE="^EC(725," D ^DIE
.D MES^XPDUTL(" ")
.D BMES^XPDUTL(" "_CODE_" inactivated as of "_ECEXDT_".")
Q
;
OLD ;national procedures to be inactivated - national code #^inact. date
;;SP127^1/1/2003
;;SP128^1/1/2003
;;SP129^1/1/2003
;;SP236^1/1/2003
;;SP237^1/1/2003
;;SP238^1/1/2003
;;SP239^1/1/2003
;;SP241^1/1/2003
;;SP242^1/1/2003
;;SP262^1/1/2003
;;SP263^1/1/2003
;;SP444^1/1/2003
;;SP445^1/1/2003
;;SP446^1/1/2003
;;SP448^1/1/2003
;;SP465^1/1/2003
;;SP466^1/1/2003
;;QUIT
;
REACT ;* reactivate national procedures
;
; ECXX is in format:
; NATIONAL NUMBER^DATE (FUTURE)^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,CODE,CODX,ECDES
D MES^XPDUTL(" ")
D BMES^XPDUTL("Reactivating procedures EC NATIONAL PROCEDURE File (#725)...")
D MES^XPDUTL(" ")
F ECX=1:1 K DD,DO,DA S ECXX=$P($T(ACT+ECX),";;",2) Q:ECXX="QUIT" D
.S ECDES=$P(ECXX,U,5)
.S CODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CODX=CODE
.I ECBEG="" D UPREACT Q
.F ECSEQ=ECBEG:1:ECEND D
..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
..S CODE=CODX_ECADD
..D UPREACT
Q
UPREACT ;Update codes as reactive
;
S ECDA=+$O(^EC(725,"D",CODE,0))
I $D(^EC(725,ECDA,0)) D
.S DA=ECDA,DR="2///@",DIE="^EC(725," D ^DIE
.D BMES^XPDUTL(" "_CODE_" "_ECDES_" reactivated.")
Q
;
ACT ;national procedures to be reactivated - national number^date
;;SP130^1/1/2003
;;QUIT
;
CPTCHG ;* change cpt codes
;
; ECXX is in format:
; NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL
; NUMBER SEQUENCE
;
N ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,NAME,ECSEQ,STR,CPTIEN
D MES^XPDUTL(" ")
D BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
D MES^XPDUTL(" ")
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),CPTIEN=$P(ECXX,U,2)
.S CPTIEN=$S(CPTIEN="":"@",1:$$FIND1^DIC(81,"","X",CPTIEN))
.I CPTIEN'="@",+CPTIEN<1 D Q
..S STR=$P(ECXX,U)_": CPT code "_$P(ECXX,U,2)_" is invalid."
..D MES^XPDUTL(" ")
..D BMES^XPDUTL(" "_STR)
.I ECBEG="" S CPT($P(ECXX,U))=CPTIEN_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 CPT($P(ECXX,U)_ECADD)=CPTIEN_U_$P(ECXX,U,2)
S ECXX=""
F S ECXX=$O(CPT(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 BMES^XPDUTL(" Can't find entry for "_ECXX_",CPT cde not updated.")
.S CPT=$P(CPT(ECXX),U),DA=ECX,DR="4////"_CPT,DIE="^EC(725," D ^DIE
.D MES^XPDUTL(" ")
.S STR=" Entry #"_ECX_" for "_ECXX
.D BMES^XPDUTL(STR_" updated to use CPT code "_$P(CPT(ECXX),U,2))
Q
;
CPT ;cpt codes to be changed - national #^new CPT code
;;CH065
;;CH084
;;SP112^92506
;;SP114^92507
;;SP116^92700
;;SP117^92700
;;SP230^92610
;;SP233^92700
;;SP327^92506
;;SP328^92506
;;SP329^92507
;;SP330^92507
;;SP440^92610
;;SP441^92610
;;SP447^92609
;;SP453^92612
;;SP454^92614
;;SP455^92611
;;SP463^92609
;;SP464^92609
;;SW076^G0155
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC725U21 4354 printed Oct 16, 2024@17:57:15 Page 2
EC725U21 ;ALB/GTS/JAP/JAM - EC National Procedure Update; 12/19/02
+1 ;;2.0; EVENT CAPTURE ;**48**;8 May 96
+2 ;
+3 ;this routine is used as a post-init in KIDS build
+4 ;to modify the the EC National Procedure file #725
+5 ;
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,CODE,CODX
+8 DO MES^XPDUTL(" ")
+9 DO BMES^XPDUTL("Inactivating procedures 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 CODE=$PIECE(ECXX,U)
SET ECBEG=$PIECE(ECXX,U,3)
SET ECEND=$PIECE(ECXX,U,4)
SET CODX=CODE
+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 CODE=CODX_ECADD
+18 DO UPINACT
End DoDot:2
End DoDot:1
+19 QUIT
UPINACT ;Update codes as inactive
+1 ;
+2 SET ECDA=+$ORDER(^EC(725,"D",CODE,0))
+3 IF $DATA(^EC(725,ECDA,0))
Begin DoDot:1
+4 SET DA=ECDA
SET DR="2////^S X=ECINDT"
SET DIE="^EC(725,"
DO ^DIE
+5 DO MES^XPDUTL(" ")
+6 DO BMES^XPDUTL(" "_CODE_" inactivated as of "_ECEXDT_".")
End DoDot:1
+7 QUIT
+8 ;
OLD ;national procedures to be inactivated - national code #^inact. date
+1 ;;SP127^1/1/2003
+2 ;;SP128^1/1/2003
+3 ;;SP129^1/1/2003
+4 ;;SP236^1/1/2003
+5 ;;SP237^1/1/2003
+6 ;;SP238^1/1/2003
+7 ;;SP239^1/1/2003
+8 ;;SP241^1/1/2003
+9 ;;SP242^1/1/2003
+10 ;;SP262^1/1/2003
+11 ;;SP263^1/1/2003
+12 ;;SP444^1/1/2003
+13 ;;SP445^1/1/2003
+14 ;;SP446^1/1/2003
+15 ;;SP448^1/1/2003
+16 ;;SP465^1/1/2003
+17 ;;SP466^1/1/2003
+18 ;;QUIT
+19 ;
REACT ;* reactivate national procedures
+1 ;
+2 ; ECXX is in format:
+3 ; NATIONAL NUMBER^DATE (FUTURE)^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,CODE,CODX,ECDES
+8 DO MES^XPDUTL(" ")
+9 DO BMES^XPDUTL("Reactivating procedures EC NATIONAL PROCEDURE File (#725)...")
+10 DO MES^XPDUTL(" ")
+11 FOR ECX=1:1
KILL DD,DO,DA
SET ECXX=$PIECE($TEXT(ACT+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+12 SET ECDES=$PIECE(ECXX,U,5)
+13 SET CODE=$PIECE(ECXX,U)
SET ECBEG=$PIECE(ECXX,U,3)
SET ECEND=$PIECE(ECXX,U,4)
SET CODX=CODE
+14 IF ECBEG=""
DO UPREACT
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 CODE=CODX_ECADD
+18 DO UPREACT
End DoDot:2
End DoDot:1
+19 QUIT
UPREACT ;Update codes as reactive
+1 ;
+2 SET ECDA=+$ORDER(^EC(725,"D",CODE,0))
+3 IF $DATA(^EC(725,ECDA,0))
Begin DoDot:1
+4 SET DA=ECDA
SET DR="2///@"
SET DIE="^EC(725,"
DO ^DIE
+5 DO BMES^XPDUTL(" "_CODE_" "_ECDES_" reactivated.")
End DoDot:1
+6 QUIT
+7 ;
ACT ;national procedures to be reactivated - national number^date
+1 ;;SP130^1/1/2003
+2 ;;QUIT
+3 ;
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,CPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,NAME,ECSEQ,STR,CPTIEN
+7 DO MES^XPDUTL(" ")
+8 DO BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
+9 DO MES^XPDUTL(" ")
+10 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(CPT+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+11 SET ECBEG=$PIECE(ECXX,U,3)
SET ECEND=$PIECE(ECXX,U,4)
SET CPTIEN=$PIECE(ECXX,U,2)
+12 SET CPTIEN=$SELECT(CPTIEN="":"@",1:$$FIND1^DIC(81,"","X",CPTIEN))
+13 IF CPTIEN'="@"
IF +CPTIEN<1
Begin DoDot:2
+14 SET STR=$PIECE(ECXX,U)_": CPT code "_$PIECE(ECXX,U,2)_" is invalid."
+15 DO MES^XPDUTL(" ")
+16 DO BMES^XPDUTL(" "_STR)
End DoDot:2
QUIT
+17 IF ECBEG=""
SET CPT($PIECE(ECXX,U))=CPTIEN_U_$PIECE(ECXX,U,2)
QUIT
+18 FOR ECSEQ=ECBEG:1:ECEND
Begin DoDot:2
+19 SET ECADD="000"_ECSEQ
SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
+20 SET CPT($PIECE(ECXX,U)_ECADD)=CPTIEN_U_$PIECE(ECXX,U,2)
End DoDot:2
End DoDot:1
+21 SET ECXX=""
+22 FOR
SET ECXX=$ORDER(CPT(ECXX))
if ECXX=""
QUIT
Begin DoDot:1
+23 SET ECX=$ORDER(^EC(725,"D",ECXX,0))
+24 if +ECX=0
QUIT
+25 IF '$DATA(^EC(725,ECX,0))!(+ECX=0)
Begin DoDot:2
+26 DO MES^XPDUTL(" ")
+27 DO BMES^XPDUTL(" Can't find entry for "_ECXX_",CPT cde not updated.")
End DoDot:2
QUIT
+28 SET CPT=$PIECE(CPT(ECXX),U)
SET DA=ECX
SET DR="4////"_CPT
SET DIE="^EC(725,"
DO ^DIE
+29 DO MES^XPDUTL(" ")
+30 SET STR=" Entry #"_ECX_" for "_ECXX
+31 DO BMES^XPDUTL(STR_" updated to use CPT code "_$PIECE(CPT(ECXX),U,2))
End DoDot:1
+32 QUIT
+33 ;
CPT ;cpt codes to be changed - national #^new CPT code
+1 ;;CH065
+2 ;;CH084
+3 ;;SP112^92506
+4 ;;SP114^92507
+5 ;;SP116^92700
+6 ;;SP117^92700
+7 ;;SP230^92610
+8 ;;SP233^92700
+9 ;;SP327^92506
+10 ;;SP328^92506
+11 ;;SP329^92507
+12 ;;SP330^92507
+13 ;;SP440^92610
+14 ;;SP441^92610
+15 ;;SP447^92609
+16 ;;SP453^92612
+17 ;;SP454^92614
+18 ;;SP455^92611
+19 ;;SP463^92609
+20 ;;SP464^92609
+21 ;;SW076^G0155
+22 ;;QUIT
