- EC725U01 ;ALB/GTS/JAP/JAM - EC National Procedure Update; 08/11/99
- ;;2.0; EVENT CAPTURE ;**20**;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
- ;;SP^10/1/1999^125^126
- ;;SP^10/1/1999^142^145
- ;;SP^10/1/1999^148^150
- ;;SP^10/1/1999^152^155
- ;;SP^10/1/1999^157^160
- ;;SP^10/1/1999^162^168
- ;;SP^10/1/1999^170^206
- ;;SP^10/1/1999^257^259
- ;;SW005^10/1/1999
- ;;SW008^10/1/1999
- ;;SW016^10/1/1999
- ;;SW022^10/1/1999
- ;;SW029^10/1/1999
- ;;SW030^10/1/1999
- ;;SW040^10/1/1999
- ;;SW041^10/1/1999
- ;;SW042^10/1/1999
- ;;SW070^10/1/1999
- ;;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,FL
- D MES^XPDUTL(" ")
- D BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
- D BMES^XPDUTL(" Also adding '10M' to some procedure description...")
- 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)
- .I ECBEG="" S CPT($P(ECXX,U,1))=$P(ECXX,U,2)_U_0 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)=$P(ECXX,U,2)_U_1
- 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)
- ..D BMES^XPDUTL(" ...NAME field (#.01) nor CPT code updated.")
- .S CPT=$P(CPT(ECXX),U),FL=$P(CPT(ECXX),U,2),DA=ECX
- .I FL S NAME=$P(^EC(725,ECX,0),U) D I FL S NAME=NAME_" 10M"
- ..I $E(NAME,$L(NAME)-3,$L(NAME))=" 10M" S FL=0 ;10M already added
- .S DR=$S(FL:".01////^S X=NAME;",1:"")_"4////"_CPT,DIE="^EC(725," D ^DIE
- .D MES^XPDUTL(" ")
- .D BMES^XPDUTL(" Entry #"_ECX_" for "_ECXX)
- .D BMES^XPDUTL(" ...updated to use CPT code "_CPT_$S(FL:" with desc. "_NAME_".",1:"."))
- Q
- ;
- CPT ;cpt codes to be changed
- ;;CH^99499^1^15
- ;;CH^99499^17^71
- ;;CH^99499^73^84
- ;;SW002^99261
- ;;SW003^99238
- ;;SW013^99211
- ;;SW014^99263
- ;;SW019^99411
- ;;SW025^99411
- ;;SW026^99411
- ;;SW033^99262
- ;;SW034^99263
- ;;SW056^99212
- ;;SW057^99213
- ;;SW058^99214
- ;;SW059^99215
- ;;QUIT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC725U01 3387 printed Mar 13, 2025@21:01:09 Page 2
- EC725U01 ;ALB/GTS/JAP/JAM - EC National Procedure Update; 08/11/99
- +1 ;;2.0; EVENT CAPTURE ;**20**;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
- +1 ;;SP^10/1/1999^125^126
- +2 ;;SP^10/1/1999^142^145
- +3 ;;SP^10/1/1999^148^150
- +4 ;;SP^10/1/1999^152^155
- +5 ;;SP^10/1/1999^157^160
- +6 ;;SP^10/1/1999^162^168
- +7 ;;SP^10/1/1999^170^206
- +8 ;;SP^10/1/1999^257^259
- +9 ;;SW005^10/1/1999
- +10 ;;SW008^10/1/1999
- +11 ;;SW016^10/1/1999
- +12 ;;SW022^10/1/1999
- +13 ;;SW029^10/1/1999
- +14 ;;SW030^10/1/1999
- +15 ;;SW040^10/1/1999
- +16 ;;SW041^10/1/1999
- +17 ;;SW042^10/1/1999
- +18 ;;SW070^10/1/1999
- +19 ;;QUIT
- +20 ;
- 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,FL
- +7 DO MES^XPDUTL(" ")
- +8 DO BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
- +9 DO BMES^XPDUTL(" Also adding '10M' to some procedure description...")
- +10 DO MES^XPDUTL(" ")
- +11 FOR ECX=1:1
- SET ECXX=$PIECE($TEXT(CPT+ECX),";;",2)
- if ECXX="QUIT"
- QUIT
- Begin DoDot:1
- +12 SET ECBEG=$PIECE(ECXX,U,3)
- SET ECEND=$PIECE(ECXX,U,4)
- +13 IF ECBEG=""
- SET CPT($PIECE(ECXX,U,1))=$PIECE(ECXX,U,2)_U_0
- QUIT
- +14 FOR ECSEQ=ECBEG:1:ECEND
- Begin DoDot:2
- +15 SET ECADD="000"_ECSEQ
- SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
- +16 SET CPT($PIECE(ECXX,U)_ECADD)=$PIECE(ECXX,U,2)_U_1
- End DoDot:2
- End DoDot:1
- +17 SET ECXX=""
- +18 FOR
- SET ECXX=$ORDER(CPT(ECXX))
- if ECXX=""
- QUIT
- Begin DoDot:1
- +19 SET ECX=$ORDER(^EC(725,"D",ECXX,0))
- +20 if +ECX=0
- QUIT
- +21 IF '$DATA(^EC(725,ECX,0))!(+ECX=0)
- Begin DoDot:2
- +22 DO MES^XPDUTL(" ")
- +23 DO BMES^XPDUTL(" Can't find entry for"_ECXX)
- +24 DO BMES^XPDUTL(" ...NAME field (#.01) nor CPT code updated.")
- End DoDot:2
- QUIT
- +25 SET CPT=$PIECE(CPT(ECXX),U)
- SET FL=$PIECE(CPT(ECXX),U,2)
- SET DA=ECX
- +26 IF FL
- SET NAME=$PIECE(^EC(725,ECX,0),U)
- Begin DoDot:2
- +27 ;10M already added
- IF $EXTRACT(NAME,$LENGTH(NAME)-3,$LENGTH(NAME))=" 10M"
- SET FL=0
- End DoDot:2
- IF FL
- SET NAME=NAME_" 10M"
- +28 SET DR=$SELECT(FL:".01////^S X=NAME;",1:"")_"4////"_CPT
- SET DIE="^EC(725,"
- DO ^DIE
- +29 DO MES^XPDUTL(" ")
- +30 DO BMES^XPDUTL(" Entry #"_ECX_" for "_ECXX)
- +31 DO BMES^XPDUTL(" ...updated to use CPT code "_CPT_$SELECT(FL:" with desc. "_NAME_".",1:"."))
- End DoDot:1
- +32 QUIT
- +33 ;
- CPT ;cpt codes to be changed
- +1 ;;CH^99499^1^15
- +2 ;;CH^99499^17^71
- +3 ;;CH^99499^73^84
- +4 ;;SW002^99261
- +5 ;;SW003^99238
- +6 ;;SW013^99211
- +7 ;;SW014^99263
- +8 ;;SW019^99411
- +9 ;;SW025^99411
- +10 ;;SW026^99411
- +11 ;;SW033^99262
- +12 ;;SW034^99263
- +13 ;;SW056^99212
- +14 ;;SW057^99213
- +15 ;;SW058^99214
- +16 ;;SW059^99215
- +17 ;;QUIT
