EC725CH7 ;ALB/GTS/JAP - EC National Procedure Update; 10/28/98
;;2.0; EVENT CAPTURE ;**16**;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
;
N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT
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)
.S X=ECEXDT
.S %DT="X" D ^%DT
.S ECINDT=$P(Y,".",1)
.S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),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(" "_$P(ECXX,U,1)_" inactivated as of "_ECEXDT_".")
Q
;
OLD ;national procedures to be inactivated
;;SP002^1/1/1999
;;SP122^1/1/1999
;;SP135^1/1/1999
;;SP136^1/1/1999
;;SP138^1/1/1999
;;SP141^1/1/1999
;;SP146^1/1/1999
;;SP151^1/1/1999
;;SP156^1/1/1999
;;SP161^1/1/1999
;;SP169^1/1/1999
;;SP232^1/1/1999
;;SP240^1/1/1999
;;SP243^1/1/1999
;;SP244^1/1/1999
;;SP250^1/1/1999
;;SP251^1/1/1999
;;SP252^1/1/1999
;;QUIT
;
CPTCHG ;* change cpt codes
;
; ECXX is in format:
; NATIONAL NUMBER^NEW CPT
;
N ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y
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" S CPT($P(ECXX,U,1))=$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
.Q:'$D(^EC(725,ECX,0))
.S CPT=CPT(ECXX)
.S DA=ECX,DR="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_".")
Q
;
CPT ;cpt codes to be changed
;;SP037^97703
;;SP038^97703
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC725CH7 2015 printed Dec 13, 2024@01:56:24 Page 2
EC725CH7 ;ALB/GTS/JAP - EC National Procedure Update; 10/28/98
+1 ;;2.0; EVENT CAPTURE ;**16**;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
+4 ;
+5 NEW ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT
+6 DO MES^XPDUTL(" ")
+7 DO BMES^XPDUTL("Inactivating procedures EC NATIONAL PROCEDURE File (#725)...")
+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 ECEXDT=$PIECE(ECXX,U,2)
+11 SET X=ECEXDT
+12 SET %DT="X"
DO ^%DT
+13 SET ECINDT=$PIECE(Y,".",1)
+14 SET ECDA=+$ORDER(^EC(725,"D",$PIECE(ECXX,U,1),0))
+15 IF $DATA(^EC(725,ECDA,0))
Begin DoDot:2
+16 SET DA=ECDA
SET DR="2////^S X=ECINDT"
SET DIE="^EC(725,"
DO ^DIE
+17 DO MES^XPDUTL(" ")
+18 DO BMES^XPDUTL(" "_$PIECE(ECXX,U,1)_" inactivated as of "_ECEXDT_".")
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
OLD ;national procedures to be inactivated
+1 ;;SP002^1/1/1999
+2 ;;SP122^1/1/1999
+3 ;;SP135^1/1/1999
+4 ;;SP136^1/1/1999
+5 ;;SP138^1/1/1999
+6 ;;SP141^1/1/1999
+7 ;;SP146^1/1/1999
+8 ;;SP151^1/1/1999
+9 ;;SP156^1/1/1999
+10 ;;SP161^1/1/1999
+11 ;;SP169^1/1/1999
+12 ;;SP232^1/1/1999
+13 ;;SP240^1/1/1999
+14 ;;SP243^1/1/1999
+15 ;;SP244^1/1/1999
+16 ;;SP250^1/1/1999
+17 ;;SP251^1/1/1999
+18 ;;SP252^1/1/1999
+19 ;;QUIT
+20 ;
CPTCHG ;* change cpt codes
+1 ;
+2 ; ECXX is in format:
+3 ; NATIONAL NUMBER^NEW CPT
+4 ;
+5 NEW ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y
+6 DO MES^XPDUTL(" ")
+7 DO BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)...")
+8 DO MES^XPDUTL(" ")
+9 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(CPT+ECX),";;",2)
if ECXX="QUIT"
QUIT
SET CPT($PIECE(ECXX,U,1))=$PIECE(ECXX,U,2)
+10 SET ECXX=""
+11 FOR
SET ECXX=$ORDER(CPT(ECXX))
if ECXX=""
QUIT
Begin DoDot:1
+12 SET ECX=$ORDER(^EC(725,"D",ECXX,0))
+13 if +ECX=0
QUIT
+14 if '$DATA(^EC(725,ECX,0))
QUIT
+15 SET CPT=CPT(ECXX)
+16 SET DA=ECX
SET DR="4////"_CPT
SET DIE="^EC(725,"
DO ^DIE
+17 DO MES^XPDUTL(" ")
+18 DO BMES^XPDUTL(" Entry #"_ECX_" for "_ECXX)
+19 DO BMES^XPDUTL(" ...updated to use CPT code "_CPT_".")
End DoDot:1
+20 QUIT
+21 ;
CPT ;cpt codes to be changed
+1 ;;SP037^97703
+2 ;;SP038^97703
+3 ;;QUIT
