EC2P132B ;ALB/DE - EC National Procedure Update ; 4/8/16 11:00am
;;2.0;EVENT CAPTURE;**132**;8 May 96;Build 3
;
;this routine is used as a post-init in a KIDS build
;to modify the EC National Procedure file (#725)
;
Q
;
ADDPROC ;* add national procedures
;
; ECXX is in format:
; NAME^NATIONAL NUMBER^CPT CODE^FIRST NATIONAL NUMBER SEQUENCE
; LAST NATIONAL NUMBER SEQUENCE
;
N ECX,ECXX,ECDINUM,ECNAME,ECCODE,ECCPT,ECCOUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
N ECADD,ECBEG,ECEND,ECCODX,ECNAMX,ECSEQ,ECLIEN,ECSTR,ECCPTN
D MES^XPDUTL(" ")
D BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE File (#725)...")
D MES^XPDUTL(" ")
S ECDINUM=$O(^EC(725,9999),-1),ECCOUNT=$P(^EC(725,0),U,4)
F ECX=1:1 S ECXX=$P($T(NEW+ECX),";;",2) Q:ECXX="QUIT" D
.S ECNAME=$P(ECXX,U,1),ECCODE=$P(ECXX,U,2),ECCPTN=$P(ECXX,U,3),ECCODX=ECCODE
.S ECCPT=""
.I ECCPTN'="" S ECCPT=$$FIND1^DIC(81,"","X",ECCPTN) I +ECCPT<1 D Q
..S ECSTR=" CPT code "_ECCPTN_" not a valid code in CPT File."
..D MES^XPDUTL(" ")
..D BMES^XPDUTL(" ["_ECCODE_"] "_ECSTR)
.S ECBEG=$P(ECXX,U,4),ECEND=$P(ECXX,U,5),ECNAMX=ECNAME
.I ECBEG="" S X=ECNAME D FILPROC Q
.F ECSEQ=ECBEG:1:ECEND D
..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
..;S ECNAME=ECNAMX_ECADD,X=ECNAME,ECCODE=ECCODX_ECADD
..I $E(ECCODX,1,3)'="RCM" S ECNAME=ECNAMX_ECSEQ,X=ECNAME,ECCODE=ECCODX_ECADD
..E S ECNAME=ECNAMX_$E(ECADD,2,99),X=ECNAME,ECCODE=ECCODX_$E(ECADD,2,99)
..D FILPROC
S $P(^EC(725,0),U,4)=ECCOUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X
Q
;
FILPROC ;File national procedures
I '$D(^EC(725,"D",ECCODE)) D
.S ECDINUM=ECDINUM+1,DINUM=ECDINUM,DIC(0)="L",DLAYGO=725,DIC="^EC(725,"
.S DIC("DR")="1////^S X=ECCODE;4///^S X=ECCPT"
.D FILE^DICN
.I +Y>0 D
..S ECCOUNT=ECCOUNT+1
..D MES^XPDUTL(" ")
..S ECSTR=" Entry #"_+Y_" for "_$P(Y,U,2)
..S ECSTR=ECSTR_$S(ECCPT'="":" [CPT: "_ECCPT_"]",1:"")_" ("_ECCODE_")"
..D BMES^XPDUTL(ECSTR)
..D BMES^XPDUTL(" ...successfully added.")
.I Y=-1 D
..D MES^XPDUTL(" ")
..D BMES^XPDUTL("ERROR when attempting to add "_ECNAME_" ("_ECCODE_")")
I $D(^EC(725,"DL",ECCODE)) D
.S ECLIEN=$O(^EC(725,"DL",ECCODE,""))
.D MES^XPDUTL(" ")
.D BMES^XPDUTL(" Your site has a local procedure (entry #"_ECLIEN_") in File #725")
.D BMES^XPDUTL(" which uses "_ECCODE_" as its National Number.")
.D BMES^XPDUTL(" Please inactivate this local procedure.")
.K Y
Q
NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
;;CAT F/U PROSTH DEV^BR059^97762
;;LS AT ASSESS^BR060^97755
;;LS F/U PROSTH DEV^BR061^97762
;;MS AT ASSESS^BR062^97755
;;MS F/U PROSTH DEV^BR063^97762
;;OM AT ASSESS^BR064^97755
;;OMF/U PROSTH DEV^BR065^97762
;;LV AT ASSESS^BR066^97755
;;LV F/U PROSTH DEV^BR067^97762
;;YOGA / GRP 30M^CI001^
;;YOGA / IND 30M^CI002^
;;YOGA / GRP REMOT 30M^CI003^
;;YOGA / IND REMOT 30M^CI004^
;;TAI CHI / GRP 30M^CI005^
;;TAI CHI / IND 30M^CI006^
;;QI GONG / GRP 30M^CI007^
;;QI GONG / IND 30M^CI008^
;;REIKI / GRP 30M^CI009^
;;REIKI / IND 15M^CI010^
;;HEAL TCH / GRP 30M^CI011^
;;HEAL TCH / IND 15M^CI013^
;;WHL HLTH CO IP / GRP 30M^CI014^
;;WHL HLTH CO IP / IND 30M^CI015^
;;WHL HLTH CO TEL / IND 15M^CI016^
;;WHL HLTH PR FAC / GRP 30M^CI017^
;;WHL HLTH PR FAC / IND 30M^CI018^
;;OTR RXN TQ / GRP 30M^CI019^
;;OTR RXN TQ / IND 30M^CI020^
;;BIOFDBK / GRP 30M^CI021^
;;BIOFDBK / IND 30M^CI022^
;;MDFLNS / GRP 30M^CI023^
;;MDFLNS / IND 30M^CI024^
;;MDTN / GRP 30M^CI025^
;;MDTN / IND 30M^CI026^
;;WELL BNG MSG / IND 30M^CI027^
;;WHL HLTH ED / GRP 30M^CI028^
;;WHL HLTH ED / IND 30M^CI029^
;;OTHR MVMT TRPY/GRP 30M^CI030^
;;OTHR MVMT TRPY/IND 30M^CI031^
;;BIOFLD OTHR / GRP 30M^CI032^
;;BIOFLD OTHR / IND 30M^CI033^
;;CRT WHC IP / GRP 30M^CI034^
;;CRT WHC IP / IND 30M^CI035^
;;CRT WHC TEL / IND 15M^CI036^
;;ACUPT / GRP 30M^CI037^
;;ACUPT / IND 30M^CI038^
;;BFA / GRP 30^CI039^
;;BFA / IND 30^CI040^
;;EDMR / IND 30M^CI041^
;;EDMR / GRP 30M^CI042^
;;EXP ART THRPY / GRP 30M^CI043^
;;EXP ART THRPY / IND 30M^CI044^
;;NAT AM HLG / GRP 30M^CI045^
;;NAT AM HLG / IND 30M^CI046^
;;IH CONSULT / GRP 30M^CI047^
;;IH CONSULT / IND 30M^CI048^
;;TRMT MSG / IND <30M^CI049^
;;AML AST THRPY / GRP 30M^CI050^
;;AML AST THRPY / IND 30M^CI051^
;;EQN THRPY / GRP 30M^CI052^
;;EQN THRPY / IND 30M^CI053^
;;CLIN HYP / GRP 30M^CI054^
;;CLIN HYP / IND 30M^CI055^
;;MDFLNS / GRP 120M^CI056^
;;WAX REMOV UNI INSTR^SP571^69209
;;QUIT
NAMECHG ;* change national procedure names
;
; ECXX is in format:
; NATIONAL NUMBER^NEW NAME
;
N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,ECSTR
D MES^XPDUTL(" ")
D BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE File (#725)...")
D MES^XPDUTL(" ")
F ECX=1:1 S ECXX=$P($T(CHNG+ECX),";;",2) Q:ECXX="QUIT" D
.I $D(^EC(725,"D",$P(ECXX,U,1))) D
..S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),0))
..I $D(^EC(725,ECDA,0)) D
...S DA=ECDA,DR=".01////^S X=$P(ECXX,U,2)",DIE="^EC(725," D ^DIE
...D MES^XPDUTL(" ")
...D MES^XPDUTL(" Entry #"_ECDA_" for "_$P(ECXX,U,1))
...D BMES^XPDUTL(" ... field (#.01) updated to "_$P(ECXX,U,2)_".")
.I '$D(^EC(725,"D",$P(ECXX,U,1))) D
..D MES^XPDUTL(" ")
..S ECSTR="Can't find entry for "_$P(ECXX,U,1)
..D BMES^XPDUTL(ECSTR_" ...field (#.01) not updated.")
Q
;
CHNG ;name changes -national code #^new procedure name
;;NU194^MOVE QUESTION W/PT 1ST15M
;;RC092^CASE MGMT IND
;;RC093^CASE MGMT GRP 2-4
;;RC094^CASE MGMT GRP 5-8
;;SD010^BASIC RATE, STATE DOM
;;SD011^SVC-CONNECT(SC) STATE DOM
;;SH010^BASIC RATE, STATE ADHC
;;SH011^SVC-CONNECT(SC) ST ADHC
;;SN010^BASIC RATE, STATE HOME
;;SN011^SVC-CONNECT(SC) STATE HME
;;SP147^E&M, OUTPATIENT EST
;;SP196^TELEPHONE SERVICE, 5-10 MIN
;;SP197^TELEPHONE SERVICE,11-20 MIN
;;SP198^TELEPHONE SERVICE, 21-30 MIN
;;SP206^DISABILITY EXAMINATION
;;SP364^FITTING/ORIENTATION/CHECKING OF HEARING AID
;;SP365^REPAIR/MODIFICATION OF HEARING AID
;;SP366^CONFORMITY EVAL, REAL-EAR MEASUREMENT
;;SP367^HEARING AID, MON, BODY WORN, AIR CONDUCTION
;;SP368^HEARING AID, MON, BODY WORN, BONE CONDUCTION
;;SP369^HEARING AID, MONAURAL, ITE
;;SP370^HEARING AID, MONAURAL, BTE
;;SP371^HEARING AID, EYEGLASS, AIR CONDUCTION
;;SP372^HEARING AID, EYEGLASS, BONE CONDUCTION
;;SP373^DISPENSING FEE, UNSPECIFIED HEARING AID
;;SP374^HEARING AID, BILATERAL, BODY WORN
;;SP375^DISPENSING FEE, BILATERAL HEARING AID
;;SP376^HEARING AID, BINAURAL, BODY HEARING AID
;;SP377^HEARING AID, BINAURAL, ITE
;;SP378^HEARING AID, BINAURAL, BTE
;;SP379^HEARING AID, BINAURAL, EYEGLASS
;;SP380^DISPENSING FEE, BINAURAL HEARING AID
;;SP381^HEARING AID, CROS, ITE
;;SP382^HEARING AID, CROS, BTE
;;SP383^HEARING AID, CROS, GLASSES
;;SP384^DISPENSING FEE, CROS
;;SP385^HEARING AID, BICROS, ITE
;;SP386^HEARING AID, BICROS, BTE
;;SP387^HEARING AID, BICROS, GLASSES
;;SP388^DISPENSING FEE, BICROS
;;SP389^HEARING AID, MISCELLANEOUS SERVICE
;;SP391^OUTCOME VERIFICATION, QUESTIONNAIRE
;;SP392^ADJUST, DIGITAL PROGRAM, OR RE-PROGRAM
;;SP422^COCHLEAR IMPLANT DEVICE/SYSTEM
;;SP423^COCHLEAR IMPLANT EXT SPEECH PROCESSOR, REPL
;;SP428^ARTIFICIAL LARYNX, ANY TYPE
;;SP429^TRACHEOSTOMY SPEAKING VALVE
;;SP430^CI TRANSMIT CABLE RPL
;;SP431^TRACHEOSTOMA FILTER
;;SP434^TRACH INNER CANNULA
;;SP435^TRACHEOSTOMY CARE KIT FOR NEW TRACHEOSTOMY
;;SP436^TRACHEOSTOMY CARE KIT FOR EST TRACHEOSTOMY
;;SP452^REPAIR/MODIFICATION OF PROSTHETIC DEVICE
;;SP473^COMMUNICATION BOARD
;;SP503^ALCOHOL WIPES
;;SP504^SKIN PROTECTIVE BARRIER
;;SP505^ADHESIVE REMOVER WIPES
;;SP506^SKIN BARRIER WIPE/SWAB
;;SP507^TRACH VALVE W DIAPHRAGM
;;SP508^DIAPHRAGM VALVE REPL
;;SP509^HMES FILTER HOLDER OR CAP
;;SP510^HMES FILTER
;;SP511^HMES VALVE HOUSING
;;SP512^HMES ADHESIVE DISC
;;SP513^HMES HOLDER WITH FILTER
;;SP514^HMES HOUSING WITH ADHESIVE
;;SP515^HMES SYSTEM
;;SP516^LARYNGECTOMY TUBE NON-CUFF
;;SP517^LARYNGECTOMY TUBE CUFFED
;;SP518^TRACH SHOWER PROTECT
;;SP519^TRACH STENT/STUD/BUTTON
;;SP520^TRACH TUBE PLUG/STOP
;;SP521^ALERTING DEVICE, NOC
;;SP522^UNLISTED MISC PROSTH SERVICE
;;SP523^TRACH INSERT, INDWELL REPL
;;SP524^GEL CAP TRACH VOICE PROSTH
;;SP525^TRACH PROSTH CLEANING DEV
;;SP526^REPL TEPDIALATOR
;;SP527^GEL CAP APPLICATION
;;SP528^COCHLEAR IMPLANT HEADSET
;;SP529^COCHLEAR MICROPHONE REPL
;;SP530^COCHLEAR IMPLANT COIL REPL
;;SP531^LITHIUM ION BAT,CIDEVBDY
;;SP532^CI BATTERY ZINC AIR
;;SP533^CI BATTERY ALKALINE
;;SP534^COMP GERIATRIC ASSESSMENT
;;SP535^COUNSELING ADV DIRECTIVES
;;SP536^DISEASE MGMT PROG INITIAL
;;SP537^DISEASE MGMT FOLLOWUP
;;SP538^DISEASE MGMT PER DIEM
;;SP539^AUDIOMETRY FOR HEARING AID
;;SP544^PROSTHETIC IMPLANT, NOS
;;SP549^LITHIUM BAT,CIDEV,EARLVL
;;SP550^SEMI-IMPLNT MIDEAR HRDV
;;SP553^ONLINE SERVICE
;;SP001^WAX REMOV UNI INSTR
;;SP064^CAL W/REC,BIL;BITHER
;;SP231^CAL W/REC,BIL;MONOTH
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P132B 9040 printed Oct 16, 2024@17:55:39 Page 2
EC2P132B ;ALB/DE - EC National Procedure Update ; 4/8/16 11:00am
+1 ;;2.0;EVENT CAPTURE;**132**;8 May 96;Build 3
+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 ;
ADDPROC ;* add national procedures
+1 ;
+2 ; ECXX is in format:
+3 ; NAME^NATIONAL NUMBER^CPT CODE^FIRST NATIONAL NUMBER SEQUENCE
+4 ; LAST NATIONAL NUMBER SEQUENCE
+5 ;
+6 NEW ECX,ECXX,ECDINUM,ECNAME,ECCODE,ECCPT,ECCOUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
+7 NEW ECADD,ECBEG,ECEND,ECCODX,ECNAMX,ECSEQ,ECLIEN,ECSTR,ECCPTN
+8 DO MES^XPDUTL(" ")
+9 DO BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE File (#725)...")
+10 DO MES^XPDUTL(" ")
+11 SET ECDINUM=$ORDER(^EC(725,9999),-1)
SET ECCOUNT=$PIECE(^EC(725,0),U,4)
+12 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(NEW+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+13 SET ECNAME=$PIECE(ECXX,U,1)
SET ECCODE=$PIECE(ECXX,U,2)
SET ECCPTN=$PIECE(ECXX,U,3)
SET ECCODX=ECCODE
+14 SET ECCPT=""
+15 IF ECCPTN'=""
SET ECCPT=$$FIND1^DIC(81,"","X",ECCPTN)
IF +ECCPT<1
Begin DoDot:2
+16 SET ECSTR=" CPT code "_ECCPTN_" not a valid code in CPT File."
+17 DO MES^XPDUTL(" ")
+18 DO BMES^XPDUTL(" ["_ECCODE_"] "_ECSTR)
End DoDot:2
QUIT
+19 SET ECBEG=$PIECE(ECXX,U,4)
SET ECEND=$PIECE(ECXX,U,5)
SET ECNAMX=ECNAME
+20 IF ECBEG=""
SET X=ECNAME
DO FILPROC
QUIT
+21 FOR ECSEQ=ECBEG:1:ECEND
Begin DoDot:2
+22 SET ECADD="000"_ECSEQ
SET ECADD=$EXTRACT(ECADD,$LENGTH(ECADD)-2,$LENGTH(ECADD))
+23 ;S ECNAME=ECNAMX_ECADD,X=ECNAME,ECCODE=ECCODX_ECADD
+24 IF $EXTRACT(ECCODX,1,3)'="RCM"
SET ECNAME=ECNAMX_ECSEQ
SET X=ECNAME
SET ECCODE=ECCODX_ECADD
+25 IF '$TEST
SET ECNAME=ECNAMX_$EXTRACT(ECADD,2,99)
SET X=ECNAME
SET ECCODE=ECCODX_$EXTRACT(ECADD,2,99)
+26 DO FILPROC
End DoDot:2
End DoDot:1
+27 SET $PIECE(^EC(725,0),U,4)=ECCOUNT
SET X=$ORDER(^EC(725,999999),-1)
SET $PIECE(^EC(725,0),U,3)=X
+28 QUIT
+29 ;
FILPROC ;File national procedures
+1 IF '$DATA(^EC(725,"D",ECCODE))
Begin DoDot:1
+2 SET ECDINUM=ECDINUM+1
SET DINUM=ECDINUM
SET DIC(0)="L"
SET DLAYGO=725
SET DIC="^EC(725,"
+3 SET DIC("DR")="1////^S X=ECCODE;4///^S X=ECCPT"
+4 DO FILE^DICN
+5 IF +Y>0
Begin DoDot:2
+6 SET ECCOUNT=ECCOUNT+1
+7 DO MES^XPDUTL(" ")
+8 SET ECSTR=" Entry #"_+Y_" for "_$PIECE(Y,U,2)
+9 SET ECSTR=ECSTR_$SELECT(ECCPT'="":" [CPT: "_ECCPT_"]",1:"")_" ("_ECCODE_")"
+10 DO BMES^XPDUTL(ECSTR)
+11 DO BMES^XPDUTL(" ...successfully added.")
End DoDot:2
+12 IF Y=-1
Begin DoDot:2
+13 DO MES^XPDUTL(" ")
+14 DO BMES^XPDUTL("ERROR when attempting to add "_ECNAME_" ("_ECCODE_")")
End DoDot:2
End DoDot:1
+15 IF $DATA(^EC(725,"DL",ECCODE))
Begin DoDot:1
+16 SET ECLIEN=$ORDER(^EC(725,"DL",ECCODE,""))
+17 DO MES^XPDUTL(" ")
+18 DO BMES^XPDUTL(" Your site has a local procedure (entry #"_ECLIEN_") in File #725")
+19 DO BMES^XPDUTL(" which uses "_ECCODE_" as its National Number.")
+20 DO BMES^XPDUTL(" Please inactivate this local procedure.")
+21 KILL Y
End DoDot:1
+22 QUIT
NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
+1 ;;CAT F/U PROSTH DEV^BR059^97762
+2 ;;LS AT ASSESS^BR060^97755
+3 ;;LS F/U PROSTH DEV^BR061^97762
+4 ;;MS AT ASSESS^BR062^97755
+5 ;;MS F/U PROSTH DEV^BR063^97762
+6 ;;OM AT ASSESS^BR064^97755
+7 ;;OMF/U PROSTH DEV^BR065^97762
+8 ;;LV AT ASSESS^BR066^97755
+9 ;;LV F/U PROSTH DEV^BR067^97762
+10 ;;YOGA / GRP 30M^CI001^
+11 ;;YOGA / IND 30M^CI002^
+12 ;;YOGA / GRP REMOT 30M^CI003^
+13 ;;YOGA / IND REMOT 30M^CI004^
+14 ;;TAI CHI / GRP 30M^CI005^
+15 ;;TAI CHI / IND 30M^CI006^
+16 ;;QI GONG / GRP 30M^CI007^
+17 ;;QI GONG / IND 30M^CI008^
+18 ;;REIKI / GRP 30M^CI009^
+19 ;;REIKI / IND 15M^CI010^
+20 ;;HEAL TCH / GRP 30M^CI011^
+21 ;;HEAL TCH / IND 15M^CI013^
+22 ;;WHL HLTH CO IP / GRP 30M^CI014^
+23 ;;WHL HLTH CO IP / IND 30M^CI015^
+24 ;;WHL HLTH CO TEL / IND 15M^CI016^
+25 ;;WHL HLTH PR FAC / GRP 30M^CI017^
+26 ;;WHL HLTH PR FAC / IND 30M^CI018^
+27 ;;OTR RXN TQ / GRP 30M^CI019^
+28 ;;OTR RXN TQ / IND 30M^CI020^
+29 ;;BIOFDBK / GRP 30M^CI021^
+30 ;;BIOFDBK / IND 30M^CI022^
+31 ;;MDFLNS / GRP 30M^CI023^
+32 ;;MDFLNS / IND 30M^CI024^
+33 ;;MDTN / GRP 30M^CI025^
+34 ;;MDTN / IND 30M^CI026^
+35 ;;WELL BNG MSG / IND 30M^CI027^
+36 ;;WHL HLTH ED / GRP 30M^CI028^
+37 ;;WHL HLTH ED / IND 30M^CI029^
+38 ;;OTHR MVMT TRPY/GRP 30M^CI030^
+39 ;;OTHR MVMT TRPY/IND 30M^CI031^
+40 ;;BIOFLD OTHR / GRP 30M^CI032^
+41 ;;BIOFLD OTHR / IND 30M^CI033^
+42 ;;CRT WHC IP / GRP 30M^CI034^
+43 ;;CRT WHC IP / IND 30M^CI035^
+44 ;;CRT WHC TEL / IND 15M^CI036^
+45 ;;ACUPT / GRP 30M^CI037^
+46 ;;ACUPT / IND 30M^CI038^
+47 ;;BFA / GRP 30^CI039^
+48 ;;BFA / IND 30^CI040^
+49 ;;EDMR / IND 30M^CI041^
+50 ;;EDMR / GRP 30M^CI042^
+51 ;;EXP ART THRPY / GRP 30M^CI043^
+52 ;;EXP ART THRPY / IND 30M^CI044^
+53 ;;NAT AM HLG / GRP 30M^CI045^
+54 ;;NAT AM HLG / IND 30M^CI046^
+55 ;;IH CONSULT / GRP 30M^CI047^
+56 ;;IH CONSULT / IND 30M^CI048^
+57 ;;TRMT MSG / IND <30M^CI049^
+58 ;;AML AST THRPY / GRP 30M^CI050^
+59 ;;AML AST THRPY / IND 30M^CI051^
+60 ;;EQN THRPY / GRP 30M^CI052^
+61 ;;EQN THRPY / IND 30M^CI053^
+62 ;;CLIN HYP / GRP 30M^CI054^
+63 ;;CLIN HYP / IND 30M^CI055^
+64 ;;MDFLNS / GRP 120M^CI056^
+65 ;;WAX REMOV UNI INSTR^SP571^69209
+66 ;;QUIT
NAMECHG ;* change national procedure names
+1 ;
+2 ; ECXX is in format:
+3 ; NATIONAL NUMBER^NEW NAME
+4 ;
+5 NEW ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,ECSTR
+6 DO MES^XPDUTL(" ")
+7 DO BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE File (#725)...")
+8 DO MES^XPDUTL(" ")
+9 FOR ECX=1:1
SET ECXX=$PIECE($TEXT(CHNG+ECX),";;",2)
if ECXX="QUIT"
QUIT
Begin DoDot:1
+10 IF $DATA(^EC(725,"D",$PIECE(ECXX,U,1)))
Begin DoDot:2
+11 SET ECDA=+$ORDER(^EC(725,"D",$PIECE(ECXX,U,1),0))
+12 IF $DATA(^EC(725,ECDA,0))
Begin DoDot:3
+13 SET DA=ECDA
SET DR=".01////^S X=$P(ECXX,U,2)"
SET DIE="^EC(725,"
DO ^DIE
+14 DO MES^XPDUTL(" ")
+15 DO MES^XPDUTL(" Entry #"_ECDA_" for "_$PIECE(ECXX,U,1))
+16 DO BMES^XPDUTL(" ... field (#.01) updated to "_$PIECE(ECXX,U,2)_".")
End DoDot:3
End DoDot:2
+17 IF '$DATA(^EC(725,"D",$PIECE(ECXX,U,1)))
Begin DoDot:2
+18 DO MES^XPDUTL(" ")
+19 SET ECSTR="Can't find entry for "_$PIECE(ECXX,U,1)
+20 DO BMES^XPDUTL(ECSTR_" ...field (#.01) not updated.")
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
CHNG ;name changes -national code #^new procedure name
+1 ;;NU194^MOVE QUESTION W/PT 1ST15M
+2 ;;RC092^CASE MGMT IND
+3 ;;RC093^CASE MGMT GRP 2-4
+4 ;;RC094^CASE MGMT GRP 5-8
+5 ;;SD010^BASIC RATE, STATE DOM
+6 ;;SD011^SVC-CONNECT(SC) STATE DOM
+7 ;;SH010^BASIC RATE, STATE ADHC
+8 ;;SH011^SVC-CONNECT(SC) ST ADHC
+9 ;;SN010^BASIC RATE, STATE HOME
+10 ;;SN011^SVC-CONNECT(SC) STATE HME
+11 ;;SP147^E&M, OUTPATIENT EST
+12 ;;SP196^TELEPHONE SERVICE, 5-10 MIN
+13 ;;SP197^TELEPHONE SERVICE,11-20 MIN
+14 ;;SP198^TELEPHONE SERVICE, 21-30 MIN
+15 ;;SP206^DISABILITY EXAMINATION
+16 ;;SP364^FITTING/ORIENTATION/CHECKING OF HEARING AID
+17 ;;SP365^REPAIR/MODIFICATION OF HEARING AID
+18 ;;SP366^CONFORMITY EVAL, REAL-EAR MEASUREMENT
+19 ;;SP367^HEARING AID, MON, BODY WORN, AIR CONDUCTION
+20 ;;SP368^HEARING AID, MON, BODY WORN, BONE CONDUCTION
+21 ;;SP369^HEARING AID, MONAURAL, ITE
+22 ;;SP370^HEARING AID, MONAURAL, BTE
+23 ;;SP371^HEARING AID, EYEGLASS, AIR CONDUCTION
+24 ;;SP372^HEARING AID, EYEGLASS, BONE CONDUCTION
+25 ;;SP373^DISPENSING FEE, UNSPECIFIED HEARING AID
+26 ;;SP374^HEARING AID, BILATERAL, BODY WORN
+27 ;;SP375^DISPENSING FEE, BILATERAL HEARING AID
+28 ;;SP376^HEARING AID, BINAURAL, BODY HEARING AID
+29 ;;SP377^HEARING AID, BINAURAL, ITE
+30 ;;SP378^HEARING AID, BINAURAL, BTE
+31 ;;SP379^HEARING AID, BINAURAL, EYEGLASS
+32 ;;SP380^DISPENSING FEE, BINAURAL HEARING AID
+33 ;;SP381^HEARING AID, CROS, ITE
+34 ;;SP382^HEARING AID, CROS, BTE
+35 ;;SP383^HEARING AID, CROS, GLASSES
+36 ;;SP384^DISPENSING FEE, CROS
+37 ;;SP385^HEARING AID, BICROS, ITE
+38 ;;SP386^HEARING AID, BICROS, BTE
+39 ;;SP387^HEARING AID, BICROS, GLASSES
+40 ;;SP388^DISPENSING FEE, BICROS
+41 ;;SP389^HEARING AID, MISCELLANEOUS SERVICE
+42 ;;SP391^OUTCOME VERIFICATION, QUESTIONNAIRE
+43 ;;SP392^ADJUST, DIGITAL PROGRAM, OR RE-PROGRAM
+44 ;;SP422^COCHLEAR IMPLANT DEVICE/SYSTEM
+45 ;;SP423^COCHLEAR IMPLANT EXT SPEECH PROCESSOR, REPL
+46 ;;SP428^ARTIFICIAL LARYNX, ANY TYPE
+47 ;;SP429^TRACHEOSTOMY SPEAKING VALVE
+48 ;;SP430^CI TRANSMIT CABLE RPL
+49 ;;SP431^TRACHEOSTOMA FILTER
+50 ;;SP434^TRACH INNER CANNULA
+51 ;;SP435^TRACHEOSTOMY CARE KIT FOR NEW TRACHEOSTOMY
+52 ;;SP436^TRACHEOSTOMY CARE KIT FOR EST TRACHEOSTOMY
+53 ;;SP452^REPAIR/MODIFICATION OF PROSTHETIC DEVICE
+54 ;;SP473^COMMUNICATION BOARD
+55 ;;SP503^ALCOHOL WIPES
+56 ;;SP504^SKIN PROTECTIVE BARRIER
+57 ;;SP505^ADHESIVE REMOVER WIPES
+58 ;;SP506^SKIN BARRIER WIPE/SWAB
+59 ;;SP507^TRACH VALVE W DIAPHRAGM
+60 ;;SP508^DIAPHRAGM VALVE REPL
+61 ;;SP509^HMES FILTER HOLDER OR CAP
+62 ;;SP510^HMES FILTER
+63 ;;SP511^HMES VALVE HOUSING
+64 ;;SP512^HMES ADHESIVE DISC
+65 ;;SP513^HMES HOLDER WITH FILTER
+66 ;;SP514^HMES HOUSING WITH ADHESIVE
+67 ;;SP515^HMES SYSTEM
+68 ;;SP516^LARYNGECTOMY TUBE NON-CUFF
+69 ;;SP517^LARYNGECTOMY TUBE CUFFED
+70 ;;SP518^TRACH SHOWER PROTECT
+71 ;;SP519^TRACH STENT/STUD/BUTTON
+72 ;;SP520^TRACH TUBE PLUG/STOP
+73 ;;SP521^ALERTING DEVICE, NOC
+74 ;;SP522^UNLISTED MISC PROSTH SERVICE
+75 ;;SP523^TRACH INSERT, INDWELL REPL
+76 ;;SP524^GEL CAP TRACH VOICE PROSTH
+77 ;;SP525^TRACH PROSTH CLEANING DEV
+78 ;;SP526^REPL TEPDIALATOR
+79 ;;SP527^GEL CAP APPLICATION
+80 ;;SP528^COCHLEAR IMPLANT HEADSET
+81 ;;SP529^COCHLEAR MICROPHONE REPL
+82 ;;SP530^COCHLEAR IMPLANT COIL REPL
+83 ;;SP531^LITHIUM ION BAT,CIDEVBDY
+84 ;;SP532^CI BATTERY ZINC AIR
+85 ;;SP533^CI BATTERY ALKALINE
+86 ;;SP534^COMP GERIATRIC ASSESSMENT
+87 ;;SP535^COUNSELING ADV DIRECTIVES
+88 ;;SP536^DISEASE MGMT PROG INITIAL
+89 ;;SP537^DISEASE MGMT FOLLOWUP
+90 ;;SP538^DISEASE MGMT PER DIEM
+91 ;;SP539^AUDIOMETRY FOR HEARING AID
+92 ;;SP544^PROSTHETIC IMPLANT, NOS
+93 ;;SP549^LITHIUM BAT,CIDEV,EARLVL
+94 ;;SP550^SEMI-IMPLNT MIDEAR HRDV
+95 ;;SP553^ONLINE SERVICE
+96 ;;SP001^WAX REMOV UNI INSTR
+97 ;;SP064^CAL W/REC,BIL;BITHER
+98 ;;SP231^CAL W/REC,BIL;MONOTH
+99 ;;QUIT
