EC725U01 ;ALB/GTS/JAP/JAM - EC National Procedure Update; 08/11/99
;;2.0; EVENT CAPTURE ;**20**;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
;;SP^10/1/1999^125^126
;;SP^10/1/1999^142^145
;;SP^10/1/1999^148^150
;;SP^10/1/1999^152^155
;;SP^10/1/1999^157^160
;;SP^10/1/1999^162^168
;;SP^10/1/1999^170^206
;;SP^10/1/1999^257^259
;;SW005^10/1/1999
;;SW008^10/1/1999
;;SW016^10/1/1999
;;SW022^10/1/1999
;;SW029^10/1/1999
;;SW030^10/1/1999
;;SW040^10/1/1999
;;SW041^10/1/1999
;;SW042^10/1/1999
;;SW070^10/1/1999
;;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,FL
D MES^XPDUTL(" ")
D BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
D BMES^XPDUTL(" Also adding '10M' to some procedure description...")
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)
.I ECBEG="" S CPT($P(ECXX,U,1))=$P(ECXX,U,2)_U_0 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)=$P(ECXX,U,2)_U_1
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)
..D BMES^XPDUTL(" ...NAME field (#.01) nor CPT code updated.")
.S CPT=$P(CPT(ECXX),U),FL=$P(CPT(ECXX),U,2),DA=ECX
.I FL S NAME=$P(^EC(725,ECX,0),U) D I FL S NAME=NAME_" 10M"
..I $E(NAME,$L(NAME)-3,$L(NAME))=" 10M" S FL=0 ;10M already added
.S DR=$S(FL:".01////^S X=NAME;",1:"")_"4////"_CPT,DIE="^EC(725," D ^DIE
.D MES^XPDUTL(" ")
.D BMES^XPDUTL(" Entry #"_ECX_" for "_ECXX)
.D BMES^XPDUTL(" ...updated to use CPT code "_CPT_$S(FL:" with desc. "_NAME_".",1:"."))
Q
;
CPT ;cpt codes to be changed
;;CH^99499^1^15
;;CH^99499^17^71
;;CH^99499^73^84
;;SW002^99261
;;SW003^99238
;;SW013^99211
;;SW014^99263
;;SW019^99411
;;SW025^99411
;;SW026^99411
;;SW033^99262
;;SW034^99263
;;SW056^99212
;;SW057^99213
;;SW058^99214
;;SW059^99215
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC725U01 3387 printed Dec 13, 2024@01:56:28 Page 2
EC725U01 ;ALB/GTS/JAP/JAM - EC National Procedure Update; 08/11/99
+1 ;;2.0; EVENT CAPTURE ;**20**;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
+1 ;;SP^10/1/1999^125^126
+2 ;;SP^10/1/1999^142^145
+3 ;;SP^10/1/1999^148^150
+4 ;;SP^10/1/1999^152^155
+5 ;;SP^10/1/1999^157^160
+6 ;;SP^10/1/1999^162^168
+7 ;;SP^10/1/1999^170^206
+8 ;;SP^10/1/1999^257^259
+9 ;;SW005^10/1/1999
+10 ;;SW008^10/1/1999
+11 ;;SW016^10/1/1999
+12 ;;SW022^10/1/1999
+13 ;;SW029^10/1/1999
+14 ;;SW030^10/1/1999
+15 ;;SW040^10/1/1999
+16 ;;SW041^10/1/1999
+17 ;;SW042^10/1/1999
+18 ;;SW070^10/1/1999
+19 ;;QUIT
+20 ;
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,FL
+7 DO MES^XPDUTL(" ")
+8 DO BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
+9 DO BMES^XPDUTL(" Also adding '10M' to some procedure description...")
+10 DO MES^XPDUTL(" ")
+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)
+13 IF ECBEG=""
SET CPT($PIECE(ECXX,U,1))=$PIECE(ECXX,U,2)_U_0
QUIT
+14 FOR ECSEQ=ECBEG:1:ECEND
Begin DoDot:2
+15 SET ECADD="000"_ECSEQ
SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
+16 SET CPT($PIECE(ECXX,U)_ECADD)=$PIECE(ECXX,U,2)_U_1
End DoDot:2
End DoDot:1
+17 SET ECXX=""
+18 FOR
SET ECXX=$ORDER(CPT(ECXX))
if ECXX=""
QUIT
Begin DoDot:1
+19 SET ECX=$ORDER(^EC(725,"D",ECXX,0))
+20 if +ECX=0
QUIT
+21 IF '$DATA(^EC(725,ECX,0))!(+ECX=0)
Begin DoDot:2
+22 DO MES^XPDUTL(" ")
+23 DO BMES^XPDUTL(" Can't find entry for"_ECXX)
+24 DO BMES^XPDUTL(" ...NAME field (#.01) nor CPT code updated.")
End DoDot:2
QUIT
+25 SET CPT=$PIECE(CPT(ECXX),U)
SET FL=$PIECE(CPT(ECXX),U,2)
SET DA=ECX
+26 IF FL
SET NAME=$PIECE(^EC(725,ECX,0),U)
Begin DoDot:2
+27 ;10M already added
IF $EXTRACT(NAME,$LENGTH(NAME)-3,$LENGTH(NAME))=" 10M"
SET FL=0
End DoDot:2
IF FL
SET NAME=NAME_" 10M"
+28 SET DR=$SELECT(FL:".01////^S X=NAME;",1:"")_"4////"_CPT
SET DIE="^EC(725,"
DO ^DIE
+29 DO MES^XPDUTL(" ")
+30 DO BMES^XPDUTL(" Entry #"_ECX_" for "_ECXX)
+31 DO BMES^XPDUTL(" ...updated to use CPT code "_CPT_$SELECT(FL:" with desc. "_NAME_".",1:"."))
End DoDot:1
+32 QUIT
+33 ;
CPT ;cpt codes to be changed
+1 ;;CH^99499^1^15
+2 ;;CH^99499^17^71
+3 ;;CH^99499^73^84
+4 ;;SW002^99261
+5 ;;SW003^99238
+6 ;;SW013^99211
+7 ;;SW014^99263
+8 ;;SW019^99411
+9 ;;SW025^99411
+10 ;;SW026^99411
+11 ;;SW033^99262
+12 ;;SW034^99263
+13 ;;SW056^99212
+14 ;;SW057^99213
+15 ;;SW058^99214
+16 ;;SW059^99215
+17 ;;QUIT
