EC2P137C.m

EC2P137C ;ALB/DE - EC National Procedure Update ; 4/8/17 11:00am

 ;;2.0;EVENT CAPTURE;**137**;8 May 96;Build 5

 ;

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

 ;to modify 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,ECCODE,ECCODX

 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 ECCODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),ECCODX=ECCODE

 .I ECBEG="" D UPINACT Q

 .F ECSEQ=ECBEG:1:ECEND D

 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))

 ..S ECCODE=ECCODX_ECADD

 ..D UPINACT

 Q

UPINACT ;Update codes as inactive

 ;

 S ECDA=+$O(^EC(725,"D",ECCODE,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("   "_ECCODE_" inactivated as of "_ECEXDT_".")

 Q

 ;

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

 ;;RC010^10/1/2017

 ;;RC012^10/1/2017

 ;;RC013^10/1/2017

 ;;RC014^10/1/2017

 ;;RC017^10/1/2017

 ;;RC018^10/1/2017

 ;;RC019^10/1/2017

 ;;RC020^10/1/2017

 ;;RC021^10/1/2017

 ;;RC033^10/1/2017

 ;;RC034^10/1/2017

 ;;RC053^10/1/2017

 ;;RC054^10/1/2017

 ;;RC055^10/1/2017

 ;;RC056^10/1/2017

 ;;RC057^10/1/2017

 ;;RC069^10/1/2017

 ;;RC070^10/1/2017

 ;;RC074^10/1/2017

 ;;RC092^10/1/2017

 ;;RC093^10/1/2017

 ;;RC094^10/1/2017

 ;;RC100^10/1/2017

 ;;RC102^10/1/2017

 ;;SW001^10/1/2017

 ;;SW046^10/1/2017

 ;;SW048^10/1/2017

 ;;SW060^10/1/2017

 ;;SW072^10/1/2017

 ;;SW073^10/1/2017

 ;;SW074^10/1/2017

 ;;SW077^10/1/2017

 ;;SW088^10/1/2017

 ;;SW094^10/1/2017

 ;;SW095^10/1/2017

 ;;SW104^10/1/2017

 ;;SW107^10/1/2017

 ;;SW108^10/1/2017

 ;;SW121^10/1/2017

 ;;SW123^10/1/2017

 ;;SW127^10/1/2017

 ;;SW128^10/1/2017

 ;;SW129^10/1/2017

 ;;SW131^10/1/2017

 ;;SW132^10/1/2017

 ;;SW133^10/1/2017

 ;;SW134^10/1/2017

 ;;SW135^10/1/2017

 ;;SW136^10/1/2017

 ;;QUIT

 ;

CPTCHG ;* change cpt codes

 ;

 ;  ECXX is in format:

 ;  NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL

 ;  NUMBER SEQUENCE

 ;

 N ECX,ECXX,ECCPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,ECSEQ,ECSTR,ECCPTIEN

 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),ECCPTIEN=$P(ECXX,U,2)

 .S ECCPTIEN=$S(ECCPTIEN="":"@",1:$$FIND1^DIC(81,"","X",ECCPTIEN))

 .I ECCPTIEN'="@",+ECCPTIEN<1 D  Q

 ..S ECSTR=$P(ECXX,U)_":  CPT code "_$P(ECXX,U,2)_" is invalid."

 ..D MES^XPDUTL(" ")

 ..D BMES^XPDUTL("   "_ECSTR)

 .I ECBEG="" S ECCPT($P(ECXX,U))=ECCPTIEN_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 ECCPT($P(ECXX,U)_ECADD)=ECCPTIEN_U_$P(ECXX,U,2)

 S ECXX=""

 F  S ECXX=$O(ECCPT(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 ECCPT=$P(ECCPT(ECXX),U),DA=ECX,DR="4///"_ECCPT,DIE="^EC(725," D ^DIE

 .D MES^XPDUTL(" ")

 .S ECSTR="   Entry #"_ECX_" for "_ECXX

 .D BMES^XPDUTL(ECSTR_" updated to use CPT code "_$P(ECCPT(ECXX),U,2))

 Q

 ;

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

 ;;SW130^H0004

 ;;SW076^T1016

 ;;SW087^T1016

 ;;QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---EC2P137C   3783     printed  Apr 23, 2025@18:09:30                                                                                                                                                                                                    Page 2

EC2P137C  ;ALB/DE - EC National Procedure Update ; 4/8/17 11:00am

 +1       ;;2.0;EVENT CAPTURE;**137**;8 May 96;Build 5

 +2       ;

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

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

 +5       ;

 +6        QUIT 

 +7       ;

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,ECCODE,ECCODX

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

                   SET ECBEG=$PIECE(ECXX,U,3)

                   SET ECEND=$PIECE(ECXX,U,4)

                   SET ECCODX=ECCODE

 +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 ECCODE=ECCODX_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",ECCODE,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("   "_ECCODE_" inactivated as of "_ECEXDT_".")

               End DoDot:1

 +7        QUIT 

 +8       ;

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

 +1       ;;RC010^10/1/2017

 +2       ;;RC012^10/1/2017

 +3       ;;RC013^10/1/2017

 +4       ;;RC014^10/1/2017

 +5       ;;RC017^10/1/2017

 +6       ;;RC018^10/1/2017

 +7       ;;RC019^10/1/2017

 +8       ;;RC020^10/1/2017

 +9       ;;RC021^10/1/2017

 +10      ;;RC033^10/1/2017

 +11      ;;RC034^10/1/2017

 +12      ;;RC053^10/1/2017

 +13      ;;RC054^10/1/2017

 +14      ;;RC055^10/1/2017

 +15      ;;RC056^10/1/2017

 +16      ;;RC057^10/1/2017

 +17      ;;RC069^10/1/2017

 +18      ;;RC070^10/1/2017

 +19      ;;RC074^10/1/2017

 +20      ;;RC092^10/1/2017

 +21      ;;RC093^10/1/2017

 +22      ;;RC094^10/1/2017

 +23      ;;RC100^10/1/2017

 +24      ;;RC102^10/1/2017

 +25      ;;SW001^10/1/2017

 +26      ;;SW046^10/1/2017

 +27      ;;SW048^10/1/2017

 +28      ;;SW060^10/1/2017

 +29      ;;SW072^10/1/2017

 +30      ;;SW073^10/1/2017

 +31      ;;SW074^10/1/2017

 +32      ;;SW077^10/1/2017

 +33      ;;SW088^10/1/2017

 +34      ;;SW094^10/1/2017

 +35      ;;SW095^10/1/2017

 +36      ;;SW104^10/1/2017

 +37      ;;SW107^10/1/2017

 +38      ;;SW108^10/1/2017

 +39      ;;SW121^10/1/2017

 +40      ;;SW123^10/1/2017

 +41      ;;SW127^10/1/2017

 +42      ;;SW128^10/1/2017

 +43      ;;SW129^10/1/2017

 +44      ;;SW131^10/1/2017

 +45      ;;SW132^10/1/2017

 +46      ;;SW133^10/1/2017

 +47      ;;SW134^10/1/2017

 +48      ;;SW135^10/1/2017

 +49      ;;SW136^10/1/2017

 +50      ;;QUIT

 +51      ;

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,ECCPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,ECSEQ,ECSTR,ECCPTIEN

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

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

 +13               IF ECCPTIEN'="@"

                       IF +ECCPTIEN<1

                           Begin DoDot:2

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

 +15                           DO MES^XPDUTL(" ")

 +16                           DO BMES^XPDUTL("   "_ECSTR)

                           End DoDot:2

                           QUIT 

 +17               IF ECBEG=""

                       SET ECCPT($PIECE(ECXX,U))=ECCPTIEN_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 ECCPT($PIECE(ECXX,U)_ECADD)=ECCPTIEN_U_$PIECE(ECXX,U,2)

                       End DoDot:2

               End DoDot:1

 +21       SET ECXX=""

 +22       FOR 

               SET ECXX=$ORDER(ECCPT(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 ECCPT=$PIECE(ECCPT(ECXX),U)

                   SET DA=ECX

                   SET DR="4///"_ECCPT

                   SET DIE="^EC(725,"

                   DO ^DIE

 +29               DO MES^XPDUTL(" ")

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

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

               End DoDot:1

 +32       QUIT 

 +33      ;

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

 +1       ;;SW130^H0004

 +2       ;;SW076^T1016

 +3       ;;SW087^T1016

 +4       ;;QUIT