EC725U61.m

EC725U61 ;ALB/BP - EC National Procedure Update ; 1/19/10 2:49pm

 ;;2.0; EVENT CAPTURE ;**111**;8 May 96;Build 12

 ;

 ;this routine is used as a post-init in KIDS build 

 ;to modify the the EC National Procedure file #725

 ;

 Q

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

 ;;RC023^9/1/2011

 ;;RC026^9/1/2011

 ;;RC032^9/1/2011

 ;;RC038^9/1/2011

 ;;RC041^9/1/2011

 ;;RC044^9/1/2011

 ;;RC048^9/1/2011

 ;;RC052^9/1/2011

 ;;RC059^9/1/2011

 ;;RC062^9/1/2011

 ;;RC068^9/1/2011

 ;;RC084^9/1/2011

 ;;RC095^9/1/2011

 ;;RC096^9/1/2011

 ;;RC097^9/1/2011

 ;;RC098^9/1/2011

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

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

 ;;RC001^97750

 ;;RC002^97750

 ;;RC003^97750

 ;;RC004^97750

 ;;RC005^97750

 ;;RC006^97750

 ;;RC007^97750

 ;;RC008^97750

 ;;RC010^98961

 ;;RC014^97150

 ;;RC015^97150

 ;;RC016^97150

 ;;RC053^96152

 ;;RC054^96152

 ;;QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---EC725U61   4227     printed  Mar 13, 2025@21:01:26                                                                                                                                                                                                    Page 2

EC725U61  ;ALB/BP - EC National Procedure Update ; 1/19/10 2:49pm

 +1       ;;2.0; EVENT CAPTURE ;**111**;8 May 96;Build 12

 +2       ;

 +3       ;this routine is used as a post-init in KIDS build 

 +4       ;to modify the the EC National Procedure file #725

 +5       ;

 +6        QUIT 

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       ;;RC023^9/1/2011

 +2       ;;RC026^9/1/2011

 +3       ;;RC032^9/1/2011

 +4       ;;RC038^9/1/2011

 +5       ;;RC041^9/1/2011

 +6       ;;RC044^9/1/2011

 +7       ;;RC048^9/1/2011

 +8       ;;RC052^9/1/2011

 +9       ;;RC059^9/1/2011

 +10      ;;RC062^9/1/2011

 +11      ;;RC068^9/1/2011

 +12      ;;RC084^9/1/2011

 +13      ;;RC095^9/1/2011

 +14      ;;RC096^9/1/2011

 +15      ;;RC097^9/1/2011

 +16      ;;RC098^9/1/2011

 +17      ;;QUIT

 +18      ;

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 code 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       ;;RC001^97750

 +2       ;;RC002^97750

 +3       ;;RC003^97750

 +4       ;;RC004^97750

 +5       ;;RC005^97750

 +6       ;;RC006^97750

 +7       ;;RC007^97750

 +8       ;;RC008^97750

 +9       ;;RC010^98961

 +10      ;;RC014^97150

 +11      ;;RC015^97150

 +12      ;;RC016^97150

 +13      ;;RC053^96152

 +14      ;;RC054^96152

 +15      ;;QUIT