| 1 | EC725U37 ;ALB/GTS/JAP/GT - EC National Procedure Update; 10/11/2005
|
|---|
| 2 | ;;2.0; EVENT CAPTURE ;**79**;8 May 96
|
|---|
| 3 | ;
|
|---|
| 4 | ;this routine is used as a post-init in KIDS build
|
|---|
| 5 | ;to modify the the EC National Procedure file #725
|
|---|
| 6 | ;
|
|---|
| 7 | INACT ;* inactivate national procedures
|
|---|
| 8 | ;
|
|---|
| 9 | ; ECXX is in format:
|
|---|
| 10 | ; NATIONAL NUMBER^INACTIVATION DATE^FIRST NATIONAL NUMBER SEQUENCE^
|
|---|
| 11 | ; LAST NATIONAL NUMBER SEQUENCE
|
|---|
| 12 | ;
|
|---|
| 13 | N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
|
|---|
| 14 | N ECSEQ,CODE,CODX
|
|---|
| 15 | D MES^XPDUTL(" ")
|
|---|
| 16 | D BMES^XPDUTL("Inactivating procedures EC NATIONAL PROCEDURE File (#725)...")
|
|---|
| 17 | D MES^XPDUTL(" ")
|
|---|
| 18 | F ECX=1:1 K DD,DO,DA S ECXX=$P($T(OLD+ECX),";;",2) Q:ECXX="QUIT" D
|
|---|
| 19 | .S ECEXDT=$P(ECXX,U,2),X=ECEXDT,%DT="X" D ^%DT S ECINDT=$P(Y,".",1)
|
|---|
| 20 | .S CODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CODX=CODE
|
|---|
| 21 | .I ECBEG="" D UPINACT Q
|
|---|
| 22 | .F ECSEQ=ECBEG:1:ECEND D
|
|---|
| 23 | ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
|
|---|
| 24 | ..S CODE=CODX_ECADD
|
|---|
| 25 | ..D UPINACT
|
|---|
| 26 | Q
|
|---|
| 27 | UPINACT ;Update codes as inactive
|
|---|
| 28 | ;
|
|---|
| 29 | S ECDA=+$O(^EC(725,"D",CODE,0))
|
|---|
| 30 | I $D(^EC(725,ECDA,0)) D
|
|---|
| 31 | .S DA=ECDA,DR="2////^S X=ECINDT",DIE="^EC(725," D ^DIE
|
|---|
| 32 | .D MES^XPDUTL(" ")
|
|---|
| 33 | .D BMES^XPDUTL(" "_CODE_" inactivated as of "_ECEXDT_".")
|
|---|
| 34 | Q
|
|---|
| 35 | ;
|
|---|
| 36 | OLD ;national procedures to be inactivated - national code #^inact. date
|
|---|
| 37 | ;;QUIT
|
|---|
| 38 | ;
|
|---|
| 39 | REACT ;* reactivate national procedures
|
|---|
| 40 | ;
|
|---|
| 41 | ; ECXX is in format:
|
|---|
| 42 | ; NATIONAL NUMBER^DATE (FUTURE)^FIRST NATIONAL NUMBER SEQUENCE^
|
|---|
| 43 | ; LAST NATIONAL NUMBER SEQUENCE
|
|---|
| 44 | ;
|
|---|
| 45 | N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
|
|---|
| 46 | N ECSEQ,CODE,CODX,ECDES
|
|---|
| 47 | D MES^XPDUTL(" ")
|
|---|
| 48 | D BMES^XPDUTL("Reactivating procedures EC NATIONAL PROCEDURE File (#725)...")
|
|---|
| 49 | D MES^XPDUTL(" ")
|
|---|
| 50 | F ECX=1:1 K DD,DO,DA S ECXX=$P($T(ACT+ECX),";;",2) Q:ECXX="QUIT" D
|
|---|
| 51 | .S ECDES=$P(ECXX,U,5)
|
|---|
| 52 | .S CODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CODX=CODE
|
|---|
| 53 | .I ECBEG="" D UPREACT Q
|
|---|
| 54 | .F ECSEQ=ECBEG:1:ECEND D
|
|---|
| 55 | ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
|
|---|
| 56 | ..S CODE=CODX_ECADD
|
|---|
| 57 | ..D UPREACT
|
|---|
| 58 | Q
|
|---|
| 59 | UPREACT ;Update codes as reactive
|
|---|
| 60 | ;
|
|---|
| 61 | S ECDA=+$O(^EC(725,"D",CODE,0))
|
|---|
| 62 | I $D(^EC(725,ECDA,0)) D
|
|---|
| 63 | .S DA=ECDA,DR="2///@",DIE="^EC(725," D ^DIE
|
|---|
| 64 | .D BMES^XPDUTL(" "_CODE_" "_ECDES_" reactivated.")
|
|---|
| 65 | Q
|
|---|
| 66 | ;
|
|---|
| 67 | ACT ;national procedures to be reactivated - national number^date
|
|---|
| 68 | ;;QUIT
|
|---|
| 69 | ;
|
|---|
| 70 | CPTCHG ;* change cpt codes
|
|---|
| 71 | ;
|
|---|
| 72 | ; ECXX is in format:
|
|---|
| 73 | ; NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL
|
|---|
| 74 | ; NUMBER SEQUENCE
|
|---|
| 75 | ;
|
|---|
| 76 | N ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,NAME,ECSEQ,STR,CPTIEN
|
|---|
| 77 | D MES^XPDUTL(" ")
|
|---|
| 78 | D BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
|
|---|
| 79 | D MES^XPDUTL(" ")
|
|---|
| 80 | F ECX=1:1 S ECXX=$P($T(CPT+ECX),";;",2) Q:ECXX="QUIT" D
|
|---|
| 81 | .S ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CPTIEN=$P(ECXX,U,2)
|
|---|
| 82 | .S CPTIEN=$S(CPTIEN="":"@",1:$$FIND1^DIC(81,"","X",CPTIEN))
|
|---|
| 83 | .I CPTIEN'="@",+CPTIEN<1 D Q
|
|---|
| 84 | ..S STR=$P(ECXX,U)_": CPT code "_$P(ECXX,U,2)_" is invalid."
|
|---|
| 85 | ..D MES^XPDUTL(" ")
|
|---|
| 86 | ..D BMES^XPDUTL(" "_STR)
|
|---|
| 87 | .I ECBEG="" S CPT($P(ECXX,U))=CPTIEN_U_$P(ECXX,U,2) Q
|
|---|
| 88 | .F ECSEQ=ECBEG:1:ECEND D
|
|---|
| 89 | ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
|
|---|
| 90 | ..S CPT($P(ECXX,U)_ECADD)=CPTIEN_U_$P(ECXX,U,2)
|
|---|
| 91 | S ECXX=""
|
|---|
| 92 | F S ECXX=$O(CPT(ECXX)) Q:ECXX="" D
|
|---|
| 93 | .S ECX=$O(^EC(725,"D",ECXX,0))
|
|---|
| 94 | .Q:+ECX=0
|
|---|
| 95 | .I '$D(^EC(725,ECX,0))!(+ECX=0) D Q
|
|---|
| 96 | ..D MES^XPDUTL(" ")
|
|---|
| 97 | ..D BMES^XPDUTL(" Can't find entry for "_ECXX_",CPT cde not updated.")
|
|---|
| 98 | .S CPT=$P(CPT(ECXX),U),DA=ECX,DR="4////"_CPT,DIE="^EC(725," D ^DIE
|
|---|
| 99 | .D MES^XPDUTL(" ")
|
|---|
| 100 | .S STR=" Entry #"_ECX_" for "_ECXX
|
|---|
| 101 | .D BMES^XPDUTL(STR_" updated to use CPT code "_$P(CPT(ECXX),U,2))
|
|---|
| 102 | Q
|
|---|
| 103 | ;
|
|---|
| 104 | CPT ;cpt codes to be changed - national #^new CPT code
|
|---|
| 105 | ;;SP433^A7526
|
|---|
| 106 | ;;SP503^A4245
|
|---|
| 107 | ;;SP504^A4362
|
|---|
| 108 | ;;QUIT
|
|---|
