- EC725U21 ;ALB/GTS/JAP/JAM - EC National Procedure Update; 12/19/02
- ;;2.0; EVENT CAPTURE ;**48**;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
- ;;SP127^1/1/2003
- ;;SP128^1/1/2003
- ;;SP129^1/1/2003
- ;;SP236^1/1/2003
- ;;SP237^1/1/2003
- ;;SP238^1/1/2003
- ;;SP239^1/1/2003
- ;;SP241^1/1/2003
- ;;SP242^1/1/2003
- ;;SP262^1/1/2003
- ;;SP263^1/1/2003
- ;;SP444^1/1/2003
- ;;SP445^1/1/2003
- ;;SP446^1/1/2003
- ;;SP448^1/1/2003
- ;;SP465^1/1/2003
- ;;SP466^1/1/2003
- ;;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
- ;;SP130^1/1/2003
- ;;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
- ;;CH065
- ;;CH084
- ;;SP112^92506
- ;;SP114^92507
- ;;SP116^92700
- ;;SP117^92700
- ;;SP230^92610
- ;;SP233^92700
- ;;SP327^92506
- ;;SP328^92506
- ;;SP329^92507
- ;;SP330^92507
- ;;SP440^92610
- ;;SP441^92610
- ;;SP447^92609
- ;;SP453^92612
- ;;SP454^92614
- ;;SP455^92611
- ;;SP463^92609
- ;;SP464^92609
- ;;SW076^G0155
- ;;QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC725U21 4354 printed Mar 13, 2025@21:01:11 Page 2
- EC725U21 ;ALB/GTS/JAP/JAM - EC National Procedure Update; 12/19/02
- +1 ;;2.0; EVENT CAPTURE ;**48**;8 May 96
- +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 ;;SP127^1/1/2003
- +2 ;;SP128^1/1/2003
- +3 ;;SP129^1/1/2003
- +4 ;;SP236^1/1/2003
- +5 ;;SP237^1/1/2003
- +6 ;;SP238^1/1/2003
- +7 ;;SP239^1/1/2003
- +8 ;;SP241^1/1/2003
- +9 ;;SP242^1/1/2003
- +10 ;;SP262^1/1/2003
- +11 ;;SP263^1/1/2003
- +12 ;;SP444^1/1/2003
- +13 ;;SP445^1/1/2003
- +14 ;;SP446^1/1/2003
- +15 ;;SP448^1/1/2003
- +16 ;;SP465^1/1/2003
- +17 ;;SP466^1/1/2003
- +18 ;;QUIT
- +19 ;
- 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 ;;SP130^1/1/2003
- +2 ;;QUIT
- +3 ;
- 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 ;;CH065
- +2 ;;CH084
- +3 ;;SP112^92506
- +4 ;;SP114^92507
- +5 ;;SP116^92700
- +6 ;;SP117^92700
- +7 ;;SP230^92610
- +8 ;;SP233^92700
- +9 ;;SP327^92506
- +10 ;;SP328^92506
- +11 ;;SP329^92507
- +12 ;;SP330^92507
- +13 ;;SP440^92610
- +14 ;;SP441^92610
- +15 ;;SP447^92609
- +16 ;;SP453^92612
- +17 ;;SP454^92614
- +18 ;;SP455^92611
- +19 ;;SP463^92609
- +20 ;;SP464^92609
- +21 ;;SW076^G0155
- +22 ;;QUIT
