EC2P137B ;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
;
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
;;NON-OR REC TIME CATH LAB^NO001^
;;NON-OR REC TIME ENDOSCOPY^NO002^
;;NON-OR REC TIME RADIOLOGY^NO003^
;;NON-OR REC TIME CARDIOLOGY^NO004^
;;NON-OR REC TIME OTHER^NO005^
;;PHONE CALL W/PT EA AD'L 5M^NU216^
;;OT EVAL- LOW COMPLEX^OT001^97165
;;OT EVAL - MOD COMPLEX^OT002^97166
;;OT EVAL - HIGH COMPLEX^OT003^97167
;;OT REEVAL EST PLAN OF CARE^OT004^97168
;;PT EVAL- LOW COMPLEX^PT001^97161
;;PT EVAL - MOD COMPLEX^PT002^97162
;;PT EVAL - HIGH COMPLEX^PT003^97163
;;PT REEVAL EST PLAN OF CARE^PT004^97164
;;HEALTH BEH INTERVENT 15M^RC103^96152
;;COGNITIVE SKILLS DVMT 15M^RC104^97532
;;EXERCISE GRP^RC105^S9451
;;VESTIBULAR REHAB TRMT^RC106^97112
;;HEALTH & BEH INTER, GRP^RC107^96153
;;HEALTH & BEH INTER, FAM W/PT^RC108^96154
;;HEALTH & BEH INTER, FAM NO PT^RC109^96155
;;THER PROC, GAIT TRNG, IND^RC110^97116
;;UNLISTED THER PROCEDURE^RC111^97139
;;WHCHAIR MGMT/PROP TRNG IND^RC112^97542
;;PHYSICAL PERF TEST/MEASURE IND^RC113^97750
;;DEVICE FILL ORTH/PROS USE^RC114^97762
;;TELEPHONE SERVICE 11-20M^RC115^98967
;;TELEPHONE SERVICE 21-30M^RC116^98968
;;MED TESTIMONY/DEPOSITIONS^RC117^99075
;;SPECIAL RPT/FORM NON-STD^RC118^99080
;;NON-MD TEAM CONF W/PT^RC119^99366
;;DRIVE TIME, 15M^RC120^
;;HOME VISIT BY NON-MD NOS^RC121^99600
;;SCHD INTERDISCP TEAM CONF W/PT^RC122^G0175
;;TELEHEALTH^RC123^Q3014
;;WT MGMT NON-MD EA SESSION^RC124^S9449
;;CASE MGMT IND^RC125^T1016
;;THERAPEUTIC ACTIVITY IND^RC126^97530
;;THERAPEUTIC PROC GRP^RC127^97150
;;THERAPEUTIC PROC IND 15M^RC128^97110
;;EDUC AND TRNG, IND 30M^RC129^98960
;;EDUC AND TRNG, 2-4 PT 30M^RC130^98961
;;EDUC AND TRNG, 5-8 PT 30M^RC131^98962
;;ED/TRNG F2F 2-4 PTS 30M^SL011^98961
;;NC-ED/TRNG F2F 2-4 PTS 30M^SL012^
;;ED/TRNG F2F 5-8 PTS 30M^SL013^98962
;;NC-ED/TRNG F2F 5-8 PTS 30M^SL014^
;;ED/TRNG F2F IND 30M^SL015^98960
;;NC-ED/TRNG F2F IND 30M^SL016^
;;PT ED GRP EA SESSION^SL017^S9446
;;NC-PT ED GRP EA SESSION^SL018^
;;PT ED IND EA SESSION^SL019^S9445
;;NC-PT ED IND EA SESSION^SL020^
;;TELEMONITORING^SL021^S9110
;;NC-TELEMONITORING^SL022^
;;TELEPHONE CLINIC 5-10M^SL023^98966
;;NC-TELEPHONE CLINIC 5-10M^SL024^
;;TELEPHONE CLINIC 11-20M^SL025^98967
;;NC-TELEPHONE CLINIC 11-20M^SL026^
;;TELEPHONE CLINIC 21-30M^SL027^98968
;;NC-TELEPHONE CLINIC 21-30M^SL028^
;;CPAP CLINIC^SL029^99201
;;NC-CPAP CLINIC^SL030^
;;DME SUPPLY PROVISION^SL031^98961
;;NC-DME SUPPLY PROVISION^SL032^
;;DOCUMENT DME ORDER^SL036^
;;DATA DOWNLOAD^SL039^99091
;;NC-DATA DOWNLOAD^SL040^
;;MASK REFITTING^SL041^K0739
;;NC-MASK REFITTING^SL042^
;;EQUIPMENT REPAIR^SL043^K0739
;;NC-EQUIPMENT REPAIR^SL044^
;;CHART REVIEW^SL052^
;;DME SUPPLY COLLECTION^SL054^
;;SUPPLY ORDER REFILL^SL056^
;;SCHEDULING^SL058^
;;DEFECTIVE EQUIP RETURN^SL060^
;;INTERACTIVE COMPLEXITY^SW140^90785
;;PROLONGED CARE F2F OPT 1ST HR^SW141^99354
;;PROLONGED CARE F2F OPT EA AD'L 30M^SW142^99355
;;PROLONGED CARE F2F IPT^SW143^99356
;;PROLONGED CARE F2F IPT EA AD'L 30M^SW144^99357
;;PSYCHOTHERAPY CRISIS 16-29M^SW145^90832
;;PSYCHOTHERAPY CRISIS 1ST HR^SW146^90839
;;PSYCHOTHERAPY CRISIS EA AD'L 30M^SW147^90840
;;CONSULTATION WITH FAMILY^SW148^90887
;;IND PSYCHOPHYSIO THPY BIOFDBACK 30M^SW149^90875
;;IND PSYCHOPHYSIO THPY BIOFDBACK 45M^SW150^90876
;;TEAM CONFERENCE W/O PT W/ PRESCRIBER 30M^SW151^99367
;;PROGRAM INTAKE ASSESSMENT^SW153^T1023
;;HOME VISIT MARRIAGE COUNSEL^SW154^99510
;;PT EDUCATION, GRP^SW155^S9446
;;PT EDUCATION, IND^SW156^S9445
;;SMOKING CESSATION CLASS^SW157^S9453
;;STRESS MGMT CLASS^SW158^S9454
;;TRNG/EDUC R/T DISABLING MH PROBS^SW159^G0177
;;HEALTH & BEH ASSMT,EA 15M INITIAL^SW160^96150
;;HEALTH & BEH REASSMT 15M^SW161^96151
;;HEALTH & BEH INTERVENT 15M FAM W/ PT^SW162^96154
;;HEALTH & BEH INTERVENT 15M FAM W/O PT^SW163^96155
;;HOSPICE REFERRAL VISIT^SW164^S0255
;;ETOH &/OR DRUG ABUSE STRUCTURED ASSMT 15-30M^SW165^G0396
;;ETOH &/OR DRUG ABUSE STRUCTURED ASSMT >30M^SW166^G0397
;;PSYCH EVAL HOSP RECS MED DX^SW167^90885
;;RESULTS INTERP EXAMS TO OTHERS^SW168^90887
;;ENVIRON INTERVENT MED MGMT MH PT^SW169^90882
;;CASE MGMT ETOH/DRUG SERVICES^SW170^H0006
;;ETOH &/OR DRUG ASSMNT^SW171^H0001
;;BEH HEALTH IND/GRP COUNSEL TX 15M^SW172^H0004
;;GRP COUNSEL ETOH &/OR DRUG SERVICES^SW173^H0005
;;ETOH &/OR SA FAM/COUPLE COUNSEL^SW174^T1006
;;ETOH &/OR SA TX PLAN DVMT/MOD^SW175^T1007
;;BEH HEALTH COUNSEL THPY 15M^SW176^H0004
;;ETOH &/OR DRUG SERVICES GRP COUNSEL^SW177^H0005
;;ETOH &/OR DRUG SERVICES CRISIS OPT^SW178^H0007
;;PSYCHOEDUC SERVICE, 15M^SW179^H2027
;;ETOH &/OR DRUG SERVICES METHADONE^SW180^H0020
;;SECURE MESSAGES^SW181^98969
;;ADV DIRECTIVES EA AD'L30M^SW182^99498
;;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
;;NU007^NUTR PROB-NONE 10M
;;NU008^NUTR PROB-PREDICTED 10M
;;NU009^NUTR PROB-PRESENT 10M
;;NU019^PHONE 5-10M NO PT
;;NU020^PHONE 11-20M NO PT
;;NU021^PHONE 21-30M NO PT
;;NU022^PHONE 5-10M PROV
;;NU023^PHONE 11-20M PROV
;;NU024^PHONE 21-30M PROV
;;RC009^NON-MD TEAM CONF, NO PT
;;RC073^AQUATICTHER W/THER EX,IND
;;RC077^COMM REINT TRNG, IND 15M
;;RC081^PT ED NON-MD PROV IND SES
;;RC082^PT ED NON-MD PROV GRP SES
;;RC085^TELEPHONE SERVICE 5-10M
;;SD011^PREV RATE STATE DOM
;;SH011^PREV RATE STATE ADHC
;;SN011^PREV RATE STATE HOME
;;SW003^CASE MANAGEMENT
;;SW124^DISCH CONF PT, FAM OR S/O
;;SW076^HOME VISIT 15M
;;SW087^HOMEHEALTH F/U 15M
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC2P137B 8898 printed Oct 16, 2024@17:55:46 Page 2
EC2P137B ;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 ;
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 ;;NON-OR REC TIME CATH LAB^NO001^
+2 ;;NON-OR REC TIME ENDOSCOPY^NO002^
+3 ;;NON-OR REC TIME RADIOLOGY^NO003^
+4 ;;NON-OR REC TIME CARDIOLOGY^NO004^
+5 ;;NON-OR REC TIME OTHER^NO005^
+6 ;;PHONE CALL W/PT EA AD'L 5M^NU216^
+7 ;;OT EVAL- LOW COMPLEX^OT001^97165
+8 ;;OT EVAL - MOD COMPLEX^OT002^97166
+9 ;;OT EVAL - HIGH COMPLEX^OT003^97167
+10 ;;OT REEVAL EST PLAN OF CARE^OT004^97168
+11 ;;PT EVAL- LOW COMPLEX^PT001^97161
+12 ;;PT EVAL - MOD COMPLEX^PT002^97162
+13 ;;PT EVAL - HIGH COMPLEX^PT003^97163
+14 ;;PT REEVAL EST PLAN OF CARE^PT004^97164
+15 ;;HEALTH BEH INTERVENT 15M^RC103^96152
+16 ;;COGNITIVE SKILLS DVMT 15M^RC104^97532
+17 ;;EXERCISE GRP^RC105^S9451
+18 ;;VESTIBULAR REHAB TRMT^RC106^97112
+19 ;;HEALTH & BEH INTER, GRP^RC107^96153
+20 ;;HEALTH & BEH INTER, FAM W/PT^RC108^96154
+21 ;;HEALTH & BEH INTER, FAM NO PT^RC109^96155
+22 ;;THER PROC, GAIT TRNG, IND^RC110^97116
+23 ;;UNLISTED THER PROCEDURE^RC111^97139
+24 ;;WHCHAIR MGMT/PROP TRNG IND^RC112^97542
+25 ;;PHYSICAL PERF TEST/MEASURE IND^RC113^97750
+26 ;;DEVICE FILL ORTH/PROS USE^RC114^97762
+27 ;;TELEPHONE SERVICE 11-20M^RC115^98967
+28 ;;TELEPHONE SERVICE 21-30M^RC116^98968
+29 ;;MED TESTIMONY/DEPOSITIONS^RC117^99075
+30 ;;SPECIAL RPT/FORM NON-STD^RC118^99080
+31 ;;NON-MD TEAM CONF W/PT^RC119^99366
+32 ;;DRIVE TIME, 15M^RC120^
+33 ;;HOME VISIT BY NON-MD NOS^RC121^99600
+34 ;;SCHD INTERDISCP TEAM CONF W/PT^RC122^G0175
+35 ;;TELEHEALTH^RC123^Q3014
+36 ;;WT MGMT NON-MD EA SESSION^RC124^S9449
+37 ;;CASE MGMT IND^RC125^T1016
+38 ;;THERAPEUTIC ACTIVITY IND^RC126^97530
+39 ;;THERAPEUTIC PROC GRP^RC127^97150
+40 ;;THERAPEUTIC PROC IND 15M^RC128^97110
+41 ;;EDUC AND TRNG, IND 30M^RC129^98960
+42 ;;EDUC AND TRNG, 2-4 PT 30M^RC130^98961
+43 ;;EDUC AND TRNG, 5-8 PT 30M^RC131^98962
+44 ;;ED/TRNG F2F 2-4 PTS 30M^SL011^98961
+45 ;;NC-ED/TRNG F2F 2-4 PTS 30M^SL012^
+46 ;;ED/TRNG F2F 5-8 PTS 30M^SL013^98962
+47 ;;NC-ED/TRNG F2F 5-8 PTS 30M^SL014^
+48 ;;ED/TRNG F2F IND 30M^SL015^98960
+49 ;;NC-ED/TRNG F2F IND 30M^SL016^
+50 ;;PT ED GRP EA SESSION^SL017^S9446
+51 ;;NC-PT ED GRP EA SESSION^SL018^
+52 ;;PT ED IND EA SESSION^SL019^S9445
+53 ;;NC-PT ED IND EA SESSION^SL020^
+54 ;;TELEMONITORING^SL021^S9110
+55 ;;NC-TELEMONITORING^SL022^
+56 ;;TELEPHONE CLINIC 5-10M^SL023^98966
+57 ;;NC-TELEPHONE CLINIC 5-10M^SL024^
+58 ;;TELEPHONE CLINIC 11-20M^SL025^98967
+59 ;;NC-TELEPHONE CLINIC 11-20M^SL026^
+60 ;;TELEPHONE CLINIC 21-30M^SL027^98968
+61 ;;NC-TELEPHONE CLINIC 21-30M^SL028^
+62 ;;CPAP CLINIC^SL029^99201
+63 ;;NC-CPAP CLINIC^SL030^
+64 ;;DME SUPPLY PROVISION^SL031^98961
+65 ;;NC-DME SUPPLY PROVISION^SL032^
+66 ;;DOCUMENT DME ORDER^SL036^
+67 ;;DATA DOWNLOAD^SL039^99091
+68 ;;NC-DATA DOWNLOAD^SL040^
+69 ;;MASK REFITTING^SL041^K0739
+70 ;;NC-MASK REFITTING^SL042^
+71 ;;EQUIPMENT REPAIR^SL043^K0739
+72 ;;NC-EQUIPMENT REPAIR^SL044^
+73 ;;CHART REVIEW^SL052^
+74 ;;DME SUPPLY COLLECTION^SL054^
+75 ;;SUPPLY ORDER REFILL^SL056^
+76 ;;SCHEDULING^SL058^
+77 ;;DEFECTIVE EQUIP RETURN^SL060^
+78 ;;INTERACTIVE COMPLEXITY^SW140^90785
+79 ;;PROLONGED CARE F2F OPT 1ST HR^SW141^99354
+80 ;;PROLONGED CARE F2F OPT EA AD'L 30M^SW142^99355
+81 ;;PROLONGED CARE F2F IPT^SW143^99356
+82 ;;PROLONGED CARE F2F IPT EA AD'L 30M^SW144^99357
+83 ;;PSYCHOTHERAPY CRISIS 16-29M^SW145^90832
+84 ;;PSYCHOTHERAPY CRISIS 1ST HR^SW146^90839
+85 ;;PSYCHOTHERAPY CRISIS EA AD'L 30M^SW147^90840
+86 ;;CONSULTATION WITH FAMILY^SW148^90887
+87 ;;IND PSYCHOPHYSIO THPY BIOFDBACK 30M^SW149^90875
+88 ;;IND PSYCHOPHYSIO THPY BIOFDBACK 45M^SW150^90876
+89 ;;TEAM CONFERENCE W/O PT W/ PRESCRIBER 30M^SW151^99367
+90 ;;PROGRAM INTAKE ASSESSMENT^SW153^T1023
+91 ;;HOME VISIT MARRIAGE COUNSEL^SW154^99510
+92 ;;PT EDUCATION, GRP^SW155^S9446
+93 ;;PT EDUCATION, IND^SW156^S9445
+94 ;;SMOKING CESSATION CLASS^SW157^S9453
+95 ;;STRESS MGMT CLASS^SW158^S9454
+96 ;;TRNG/EDUC R/T DISABLING MH PROBS^SW159^G0177
+97 ;;HEALTH & BEH ASSMT,EA 15M INITIAL^SW160^96150
+98 ;;HEALTH & BEH REASSMT 15M^SW161^96151
+99 ;;HEALTH & BEH INTERVENT 15M FAM W/ PT^SW162^96154
+100 ;;HEALTH & BEH INTERVENT 15M FAM W/O PT^SW163^96155
+101 ;;HOSPICE REFERRAL VISIT^SW164^S0255
+102 ;;ETOH &/OR DRUG ABUSE STRUCTURED ASSMT 15-30M^SW165^G0396
+103 ;;ETOH &/OR DRUG ABUSE STRUCTURED ASSMT >30M^SW166^G0397
+104 ;;PSYCH EVAL HOSP RECS MED DX^SW167^90885
+105 ;;RESULTS INTERP EXAMS TO OTHERS^SW168^90887
+106 ;;ENVIRON INTERVENT MED MGMT MH PT^SW169^90882
+107 ;;CASE MGMT ETOH/DRUG SERVICES^SW170^H0006
+108 ;;ETOH &/OR DRUG ASSMNT^SW171^H0001
+109 ;;BEH HEALTH IND/GRP COUNSEL TX 15M^SW172^H0004
+110 ;;GRP COUNSEL ETOH &/OR DRUG SERVICES^SW173^H0005
+111 ;;ETOH &/OR SA FAM/COUPLE COUNSEL^SW174^T1006
+112 ;;ETOH &/OR SA TX PLAN DVMT/MOD^SW175^T1007
+113 ;;BEH HEALTH COUNSEL THPY 15M^SW176^H0004
+114 ;;ETOH &/OR DRUG SERVICES GRP COUNSEL^SW177^H0005
+115 ;;ETOH &/OR DRUG SERVICES CRISIS OPT^SW178^H0007
+116 ;;PSYCHOEDUC SERVICE, 15M^SW179^H2027
+117 ;;ETOH &/OR DRUG SERVICES METHADONE^SW180^H0020
+118 ;;SECURE MESSAGES^SW181^98969
+119 ;;ADV DIRECTIVES EA AD'L30M^SW182^99498
+120 ;;QUIT
+121 ;
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 ;;NU007^NUTR PROB-NONE 10M
+2 ;;NU008^NUTR PROB-PREDICTED 10M
+3 ;;NU009^NUTR PROB-PRESENT 10M
+4 ;;NU019^PHONE 5-10M NO PT
+5 ;;NU020^PHONE 11-20M NO PT
+6 ;;NU021^PHONE 21-30M NO PT
+7 ;;NU022^PHONE 5-10M PROV
+8 ;;NU023^PHONE 11-20M PROV
+9 ;;NU024^PHONE 21-30M PROV
+10 ;;RC009^NON-MD TEAM CONF, NO PT
+11 ;;RC073^AQUATICTHER W/THER EX,IND
+12 ;;RC077^COMM REINT TRNG, IND 15M
+13 ;;RC081^PT ED NON-MD PROV IND SES
+14 ;;RC082^PT ED NON-MD PROV GRP SES
+15 ;;RC085^TELEPHONE SERVICE 5-10M
+16 ;;SD011^PREV RATE STATE DOM
+17 ;;SH011^PREV RATE STATE ADHC
+18 ;;SN011^PREV RATE STATE HOME
+19 ;;SW003^CASE MANAGEMENT
+20 ;;SW124^DISCH CONF PT, FAM OR S/O
+21 ;;SW076^HOME VISIT 15M
+22 ;;SW087^HOMEHEALTH F/U 15M
+23 ;;QUIT
