120 lines
3.7 KiB
Mathematica
120 lines
3.7 KiB
Mathematica
EC725U27 ;ALB/GTS/JAP/GT - EC National Procedure Update; 9/11/2003
|
|
;;2.0; EVENT CAPTURE ;**67**;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
|
|
;;SP497^01/01/2004
|
|
;;SP498^01/01/2004
|
|
;;SP499^01/01/2004
|
|
;;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
|
|
;;SP457^10/1/2004
|
|
;;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
|
|
;;BB002^36430
|
|
;;BB003^36430
|
|
;;BB004^36430
|
|
;;SP456^E2500
|
|
;;SP457^E2502
|
|
;;SP458^E2508
|
|
;;SP459^E2510
|
|
;;SP460^E2511
|
|
;;SP461^E2512
|
|
;;SP462^E2599
|
|
;;QUIT
|