Routine: EC725U47

EC725U47 ;ALB/GTS/JAP/GT - EC National Procedure Update; 06/05/2007

 ;;2.0; EVENT CAPTURE ;**93**;8 May 96;Build 1

 ;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

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_".")

OLD ;national procedures to be inactivated - national code #^inact. date

 ;;CH001^10/01/07

 ;;CH002^10/01/07

 ;;CH003^10/01/07

 ;;CH004^10/01/07

 ;;CH005^10/01/07

 ;;CH006^10/01/07

 ;;CH007^10/01/07

 ;;CH008^10/01/07

 ;;CH009^10/01/07

 ;;CH010^10/01/07

 ;;CH011^10/01/07

 ;;CH012^10/01/07

 ;;CH013^10/01/07

 ;;CH014^10/01/07

 ;;CH015^10/01/07

 ;;CH017^10/01/07

 ;;CH018^10/01/07

 ;;CH019^10/01/07

 ;;CH020^10/01/07

 ;;CH021^10/01/07

 ;;CH022^10/01/07

 ;;CH023^10/01/07

 ;;CH024^10/01/07

 ;;CH025^10/01/07

 ;;CH026^10/01/07

 ;;CH027^10/01/07

 ;;CH028^10/01/07

 ;;CH029^10/01/07

 ;;CH030^10/01/07

 ;;CH031^10/01/07

 ;;CH032^10/01/07

 ;;CH033^10/01/07

 ;;CH034^10/01/07

 ;;CH035^10/01/07

 ;;CH036^10/01/07

 ;;CH037^10/01/07

 ;;CH038^10/01/07

 ;;CH039^10/01/07

 ;;CH040^10/01/07

 ;;CH041^10/01/07

 ;;CH042^10/01/07

 ;;CH043^10/01/07

 ;;CH044^10/01/07

 ;;CH045^10/01/07

 ;;CH046^10/01/07

 ;;CH047^10/01/07

 ;;CH048^10/01/07

 ;;CH049^10/01/07

 ;;CH050^10/01/07

 ;;CH051^10/01/07

 ;;CH052^10/01/07

 ;;CH053^10/01/07

 ;;CH054^10/01/07

 ;;CH055^10/01/07

 ;;CH056^10/01/07

 ;;CH057^10/01/07

 ;;CH058^10/01/07

 ;;CH059^10/01/07

 ;;CH060^10/01/07

 ;;CH061^10/01/07

 ;;CH062^10/01/07

 ;;CH063^10/01/07

 ;;CH064^10/01/07

 ;;CH065^10/01/07

 ;;CH066^10/01/07

 ;;CH067^10/01/07

 ;;CH068^10/01/07

 ;;CH069^10/01/07

 ;;CH070^10/01/07

 ;;CH071^10/01/07

 ;;CH073^10/01/07

 ;;CH074^10/01/07

 ;;CH075^10/01/07

 ;;CH076^10/01/07

 ;;CH077^10/01/07

 ;;CH078^10/01/07

 ;;CH079^10/01/07

 ;;CH080^10/01/07

 ;;CH081^10/01/07

 ;;CH082^10/01/07

 ;;CH083^10/01/07

 ;;CH084^10/01/07

 ;;CH088^10/01/07

 ;;CH089^10/01/07

 ;;CH090^10/01/07

 ;;CH091^10/01/07

 ;;CH092^10/01/07

 ;;CH093^10/01/07

 ;;CH094^10/01/07

 ;;CH095^10/01/07

 ;;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

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.")

ACT ;national procedures to be reactivated - national number^date

 ;;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))

CPT ;cpt codes to be changed - national #^new CPT code

 ;;QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC725U47   5407     printed  Apr 23, 2025@18:11:11                                                                                                                                                                                                    Page 2

EC725U47  ;ALB/GTS/JAP/GT - EC National Procedure Update; 06/05/2007

 +1       ;;2.0; EVENT CAPTURE ;**93**;8 May 96;Build 1

 +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 - national code #^inact. date

 +1       ;;CH001^10/01/07

 +2       ;;CH002^10/01/07

 +3       ;;CH003^10/01/07

 +4       ;;CH004^10/01/07

 +5       ;;CH005^10/01/07

 +6       ;;CH006^10/01/07

 +7       ;;CH007^10/01/07

 +8       ;;CH008^10/01/07

 +9       ;;CH009^10/01/07

 +10      ;;CH010^10/01/07

 +11      ;;CH011^10/01/07

 +12      ;;CH012^10/01/07

 +13      ;;CH013^10/01/07

 +14      ;;CH014^10/01/07

 +15      ;;CH015^10/01/07

 +16      ;;CH017^10/01/07

 +17      ;;CH018^10/01/07

 +18      ;;CH019^10/01/07

 +19      ;;CH020^10/01/07

 +20      ;;CH021^10/01/07

 +21      ;;CH022^10/01/07

 +22      ;;CH023^10/01/07

 +23      ;;CH024^10/01/07

 +24      ;;CH025^10/01/07

 +25      ;;CH026^10/01/07

 +26      ;;CH027^10/01/07

 +27      ;;CH028^10/01/07

 +28      ;;CH029^10/01/07

 +29      ;;CH030^10/01/07

 +30      ;;CH031^10/01/07

 +31      ;;CH032^10/01/07

 +32      ;;CH033^10/01/07

 +33      ;;CH034^10/01/07

 +34      ;;CH035^10/01/07

 +35      ;;CH036^10/01/07

 +36      ;;CH037^10/01/07

 +37      ;;CH038^10/01/07

 +38      ;;CH039^10/01/07

 +39      ;;CH040^10/01/07

 +40      ;;CH041^10/01/07

 +41      ;;CH042^10/01/07

 +42      ;;CH043^10/01/07

 +43      ;;CH044^10/01/07

 +44      ;;CH045^10/01/07

 +45      ;;CH046^10/01/07

 +46      ;;CH047^10/01/07

 +47      ;;CH048^10/01/07

 +48      ;;CH049^10/01/07

 +49      ;;CH050^10/01/07

 +50      ;;CH051^10/01/07

 +51      ;;CH052^10/01/07

 +52      ;;CH053^10/01/07

 +53      ;;CH054^10/01/07

 +54      ;;CH055^10/01/07

 +55      ;;CH056^10/01/07

 +56      ;;CH057^10/01/07

 +57      ;;CH058^10/01/07

 +58      ;;CH059^10/01/07

 +59      ;;CH060^10/01/07

 +60      ;;CH061^10/01/07

 +61      ;;CH062^10/01/07

 +62      ;;CH063^10/01/07

 +63      ;;CH064^10/01/07

 +64      ;;CH065^10/01/07

 +65      ;;CH066^10/01/07

 +66      ;;CH067^10/01/07

 +67      ;;CH068^10/01/07

 +68      ;;CH069^10/01/07

 +69      ;;CH070^10/01/07

 +70      ;;CH071^10/01/07

 +71      ;;CH073^10/01/07

 +72      ;;CH074^10/01/07

 +73      ;;CH075^10/01/07

 +74      ;;CH076^10/01/07

 +75      ;;CH077^10/01/07

 +76      ;;CH078^10/01/07

 +77      ;;CH079^10/01/07

 +78      ;;CH080^10/01/07

 +79      ;;CH081^10/01/07

 +80      ;;CH082^10/01/07

 +81      ;;CH083^10/01/07

 +82      ;;CH084^10/01/07

 +83      ;;CH088^10/01/07

 +84      ;;CH089^10/01/07

 +85      ;;CH090^10/01/07

 +86      ;;CH091^10/01/07

 +87      ;;CH092^10/01/07

 +88      ;;CH093^10/01/07

 +89      ;;CH094^10/01/07

 +90      ;;CH095^10/01/07

 +91      ;;QUIT

 +92      ;

REACT     ;* reactivate national procedures

 +1       ;

 +2       ;  ECXX is in format:

 +3       ;   NATIONAL NUMBER^DATE (FUTURE)^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,ECDES

 +8        DO MES^XPDUTL(" ")

 +9        DO BMES^XPDUTL("Reactivating procedures EC NATIONAL PROCEDURE File (#725)...")

 +10       DO MES^XPDUTL(" ")

 +11       FOR ECX=1:1

               KILL DD,DO,DA

               SET ECXX=$PIECE($TEXT(ACT+ECX),";;",2)

               if ECXX="QUIT"

                   QUIT

               Begin DoDot:1

 +12               SET ECDES=$PIECE(ECXX,U,5)

 +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 UPREACT

                       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 UPREACT

                       End DoDot:2

               End DoDot:1

 +19       QUIT

UPREACT   ;Update codes as reactive

 +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///@"

                   SET DIE="^EC(725,"

                   DO ^DIE

 +5                DO BMES^XPDUTL("   "_CODE_" "_ECDES_" reactivated.")

               End DoDot:1

 +6        QUIT

 +7       ;

ACT       ;national procedures to be reactivated - national number^date

 +1       ;;QUIT

 +2       ;

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,STR,CPTIEN

 +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 CPTIEN=$PIECE(ECXX,U,2)

 +12               SET CPTIEN=$SELECT(CPTIEN="":"@",1:$$FIND1^DIC(81,"","X",CPTIEN))

 +13               IF CPTIEN'="@"

                       IF +CPTIEN<1

                           Begin DoDot:2

 +14                           SET STR=$PIECE(ECXX,U)_":  CPT code "_$PIECE(ECXX,U,2)_" is invalid."

 +15                           DO MES^XPDUTL(" ")

 +16                           DO BMES^XPDUTL("   "_STR)

                           End DoDot:2

                           QUIT

 +17               IF ECBEG=""

                       SET CPT($PIECE(ECXX,U))=CPTIEN_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 CPT($PIECE(ECXX,U)_ECADD)=CPTIEN_U_$PIECE(ECXX,U,2)

                       End DoDot:2

               End DoDot:1

 +21       SET ECXX=""

 +22       FOR

               SET ECXX=$ORDER(CPT(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 cde not updated.")

                       End DoDot:2

                       QUIT

 +28               SET CPT=$PIECE(CPT(ECXX),U)

                   SET DA=ECX

                   SET DR="4////"_CPT

                   SET DIE="^EC(725,"

                   DO ^DIE

 +29               DO MES^XPDUTL(" ")

 +30               SET STR="   Entry #"_ECX_" for "_ECXX

 +31               DO BMES^XPDUTL(STR_" updated to use CPT code "_$PIECE(CPT(ECXX),U,2))

               End DoDot:1

 +32       QUIT

 +33      ;

CPT       ;cpt codes to be changed - national #^new CPT code

 +1       ;;QUIT

EC725U47.m