EC2P137C ;ALB/DE - EC National Procedure Update ; 4/8/17 11:00am
;;2.0;EVENT CAPTURE;**137**;8 May 96;Build 5
;
;this routine is used as a post-init in a KIDS build
;to modify the EC National Procedure file (#725)
;
Q
;
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
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 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
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(" ")
.D BMES^XPDUTL(" "_ECCODE_" inactivated as of "_ECEXDT_".")
Q
;
OLD ;national procedures to be inactivated - national code #^inact. date
;;RC010^10/1/2017
;;RC012^10/1/2017
;;RC013^10/1/2017
;;RC014^10/1/2017
;;RC017^10/1/2017
;;RC018^10/1/2017
;;RC019^10/1/2017
;;RC020^10/1/2017
;;RC021^10/1/2017
;;RC033^10/1/2017
;;RC034^10/1/2017
;;RC053^10/1/2017
;;RC054^10/1/2017
;;RC055^10/1/2017
;;RC056^10/1/2017
;;RC057^10/1/2017
;;RC069^10/1/2017
;;RC070^10/1/2017
;;RC074^10/1/2017
;;RC092^10/1/2017
;;RC093^10/1/2017
;;RC094^10/1/2017
;;RC100^10/1/2017
;;RC102^10/1/2017
;;SW001^10/1/2017
;;SW046^10/1/2017
;;SW048^10/1/2017
;;SW060^10/1/2017
;;SW072^10/1/2017
;;SW073^10/1/2017
;;SW074^10/1/2017
;;SW077^10/1/2017
;;SW088^10/1/2017
;;SW094^10/1/2017
;;SW095^10/1/2017
;;SW104^10/1/2017
;;SW107^10/1/2017
;;SW108^10/1/2017
;;SW121^10/1/2017
;;SW123^10/1/2017
;;SW127^10/1/2017
;;SW128^10/1/2017
;;SW129^10/1/2017
;;SW131^10/1/2017
;;SW132^10/1/2017
;;SW133^10/1/2017
;;SW134^10/1/2017
;;SW135^10/1/2017
;;SW136^10/1/2017
;;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(" ")
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),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 BMES^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 BMES^XPDUTL(" Can't find entry for "_ECXX_",CPT code not updated.")
.S ECCPT=$P(ECCPT(ECXX),U),DA=ECX,DR="4///"_ECCPT,DIE="^EC(725," D ^DIE
.D MES^XPDUTL(" ")
.S ECSTR=" Entry #"_ECX_" for "_ECXX
.D BMES^XPDUTL(ECSTR_" updated to use CPT code "_$P(ECCPT(ECXX),U,2))
Q
;
CPT ;cpt codes to be changed - national #^new CPT code
;;SW130^H0004
;;SW076^T1016
;;SW087^T1016
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P137C 3783 printed Oct 16, 2024@17:55:47 Page 2
EC2P137C ;ALB/DE - EC National Procedure Update ; 4/8/17 11:00am
+1 ;;2.0;EVENT CAPTURE;**137**;8 May 96;Build 5
+2 ;
+3 ;this routine is used as a post-init in a KIDS build
+4 ;to modify the EC National Procedure file (#725)
+5 ;
+6 QUIT
+7 ;
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
+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 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 QUIT
UPINACT ;Update codes as inactive
+1 ;
+2 SET ECDA=+$ORDER(^EC(725,"D",ECCODE,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(" "_ECCODE_" inactivated as of "_ECEXDT_".")
End DoDot:1
+7 QUIT
+8 ;
OLD ;national procedures to be inactivated - national code #^inact. date
+1 ;;RC010^10/1/2017
+2 ;;RC012^10/1/2017
+3 ;;RC013^10/1/2017
+4 ;;RC014^10/1/2017
+5 ;;RC017^10/1/2017
+6 ;;RC018^10/1/2017
+7 ;;RC019^10/1/2017
+8 ;;RC020^10/1/2017
+9 ;;RC021^10/1/2017
+10 ;;RC033^10/1/2017
+11 ;;RC034^10/1/2017
+12 ;;RC053^10/1/2017
+13 ;;RC054^10/1/2017
+14 ;;RC055^10/1/2017
+15 ;;RC056^10/1/2017
+16 ;;RC057^10/1/2017
+17 ;;RC069^10/1/2017
+18 ;;RC070^10/1/2017
+19 ;;RC074^10/1/2017
+20 ;;RC092^10/1/2017
+21 ;;RC093^10/1/2017
+22 ;;RC094^10/1/2017
+23 ;;RC100^10/1/2017
+24 ;;RC102^10/1/2017
+25 ;;SW001^10/1/2017
+26 ;;SW046^10/1/2017
+27 ;;SW048^10/1/2017
+28 ;;SW060^10/1/2017
+29 ;;SW072^10/1/2017
+30 ;;SW073^10/1/2017
+31 ;;SW074^10/1/2017
+32 ;;SW077^10/1/2017
+33 ;;SW088^10/1/2017
+34 ;;SW094^10/1/2017
+35 ;;SW095^10/1/2017
+36 ;;SW104^10/1/2017
+37 ;;SW107^10/1/2017
+38 ;;SW108^10/1/2017
+39 ;;SW121^10/1/2017
+40 ;;SW123^10/1/2017
+41 ;;SW127^10/1/2017
+42 ;;SW128^10/1/2017
+43 ;;SW129^10/1/2017
+44 ;;SW131^10/1/2017
+45 ;;SW132^10/1/2017
+46 ;;SW133^10/1/2017
+47 ;;SW134^10/1/2017
+48 ;;SW135^10/1/2017
+49 ;;SW136^10/1/2017
+50 ;;QUIT
+51 ;
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(" ")
+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 ECCPTIEN=$PIECE(ECXX,U,2)
+12 SET ECCPTIEN=$SELECT(ECCPTIEN="":"@",1:$$FIND1^DIC(81,"","X",ECCPTIEN))
+13 IF ECCPTIEN'="@"
IF +ECCPTIEN<1
Begin DoDot:2
+14 SET ECSTR=$PIECE(ECXX,U)_": CPT code "_$PIECE(ECXX,U,2)_" is invalid."
+15 DO MES^XPDUTL(" ")
+16 DO BMES^XPDUTL(" "_ECSTR)
End DoDot:2
QUIT
+17 IF ECBEG=""
SET ECCPT($PIECE(ECXX,U))=ECCPTIEN_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 ECCPT($PIECE(ECXX,U)_ECADD)=ECCPTIEN_U_$PIECE(ECXX,U,2)
End DoDot:2
End DoDot:1
+21 SET ECXX=""
+22 FOR
SET ECXX=$ORDER(ECCPT(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 code not updated.")
End DoDot:2
QUIT
+28 SET ECCPT=$PIECE(ECCPT(ECXX),U)
SET DA=ECX
SET DR="4///"_ECCPT
SET DIE="^EC(725,"
DO ^DIE
+29 DO MES^XPDUTL(" ")
+30 SET ECSTR=" Entry #"_ECX_" for "_ECXX
+31 DO BMES^XPDUTL(ECSTR_" updated to use CPT code "_$PIECE(ECCPT(ECXX),U,2))
End DoDot:1
+32 QUIT
+33 ;
CPT ;cpt codes to be changed - national #^new CPT code
+1 ;;SW130^H0004
+2 ;;SW076^T1016
+3 ;;SW087^T1016
+4 ;;QUIT
