EC725U48 ;ALB/GTS/JAP/GT - EC National Procedure Update; 02/27/2008
;;2.0; EVENT CAPTURE ;**96**;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
;
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,NAME,CODE,CPT,COUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
N ECADD,ECBEG,ECEND,CODX,NAMX,ECSEQ,LIEN,STR,CPTN,STR
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),COUNT=$P(^EC(725,0),U,4)
F ECX=1:1 S ECXX=$P($T(NEW+ECX),";;",2) Q:ECXX="QUIT" D
.S NAME=$P(ECXX,U,1),CODE=$P(ECXX,U,2),CPTN=$P(ECXX,U,3),CODX=CODE
.S CPT=""
.I CPTN'="" S CPT=$$FIND1^DIC(81,"","X",CPTN) I +CPT<1 D Q
..S STR=" CPT code "_CPTN_" not a valid code in CPT File."
..D MES^XPDUTL(" ")
..D BMES^XPDUTL(" ["_CODE_"] "_STR)
.S ECBEG=$P(ECXX,U,4),ECEND=$P(ECXX,U,5),NAMX=NAME
.I ECBEG="" S X=NAME D FILPROC Q
.F ECSEQ=ECBEG:1:ECEND D
..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
..;S NAME=NAMX_ECADD,X=NAME,CODE=CODX_ECADD
..I $E(CODX,1,3)'="RCM" S NAME=NAMX_ECSEQ,X=NAME,CODE=CODX_ECADD
..E S NAME=NAMX_$E(ECADD,2,99),X=NAME,CODE=CODX_$E(ECADD,2,99)
..D FILPROC
S $P(^EC(725,0),U,4)=COUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X
Q
;
FILPROC ;File national procedures
I '$D(^EC(725,"D",CODE)) D
.S ECDINUM=ECDINUM+1,DINUM=ECDINUM,DIC(0)="L",DLAYGO=725,DIC="^EC(725,"
.S DIC("DR")="1////^S X=CODE;4////^S X=CPT"
.D FILE^DICN
.I +Y>0 D
..S COUNT=COUNT+1
..D MES^XPDUTL(" ")
..S STR=" Entry #"_+Y_" for "_$P(Y,U,2)
..S STR=STR_$S(CPT'="":" [CPT: "_CPT_"]",1:"")_" ("_CODE_")"
..D BMES^XPDUTL(STR_" ...successfully added.")
.I Y=-1 D
..D MES^XPDUTL(" ")
..D BMES^XPDUTL("ERROR when attempting to add "_NAME_" ("_CODE_")")
I $D(^EC(725,"DL",CODE)) D
.S LIEN=$O(^EC(725,"DL",CODE,""))
.D MES^XPDUTL(" ")
.D BMES^XPDUTL(" Your site has a local procedure (entry #"_LIEN_") in File #725")
.D BMES^XPDUTL(" which uses "_CODE_" 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
;;97001 REFER/CONS/SCREEN^RC001^97001
;;97001 RECORD REVIEW^RC002^97001
;;97001 ASMNT INIT 30M^RC003^97001
;;97002 ASMNT UPREVDISC 30M^RC004^97002
;;97001 ASMNT PROG NOTE^RC005^97001
;;97001 ASMNT PROG NOTE 15M^RC006^97001
;;97001 DISCH/COMM REF 15M^RC007^97001
;;97001 DISCH/COMM REF 30M^RC008^97001
;;98961 TEAMEETCAREPLAN 15M^RC009^98961
;;98961 TEAMEETCAREPLAN 30M^RC010^98961
;;98962 IDT GRP 2-4 30M^RC011^98962
;;98962 IDT GRP 5-10 30M^RC012^98962
;;97530 REC CREATARTIND 15M^RC013^97530
;;99499 REC CREATARTGRP 2-4^RC014^99499
;;99499 REC CREATARTGRP 5-20^RC015^99499
;;99499 REC CREATARTGRP >20^RC016^99499
;;97532 RECTHER EMOT IND 15M^RC017^97532
;;97530 RECTHER COG IND 15M^RC018^97530
;;97112 RECTHER PHY IND 15M^RC019^97112
;;97532 RECTHER SOC IND 15M^RC020^97532
;;97150 RECTHER SOC GRP 2-4^RC021^97150
;;97150 RECTHER SOC GRP 5-20^RC022^97150
;;97150 RECTHER SOC GRP>20^RC023^97150
;;97150 RECTHER COG GRP 2-4^RC024^97150
;;97150 RECTHER COG GRP 5-20^RC025^97150
;;97150 RECTHER COG GRP >20^RC026^97150
;;97150 RECTHER PHY GRP 2-4^RC027^97150
;;97150 RECTHER PHY GRP 5-20^RC028^97150
;;97150 RECTHER PHY GRP >20^RC029^97150
;;97150 RECTHER EMOT GRP 2-4^RC030^97150
;;97150 RECTHER EMOTGRP 5-20^RC031^97150
;;97150 RECTHER EMOTGRP >20^RC032^97150
;;97530 ARTTHER SOC IND 15M^RC033^97530
;;97532 ARTTHER COG IND 15M^RC034^97532
;;97533 ARTTHER EMOTIND 15M^RC035^97533
;;97150 ARTTHER SOC GRP 2-4^RC036^97150
;;97150 ARTTHER SOC GRP 5-20^RC037^97150
;;97150 ARTTHER SOC GRP >20^RC038^97150
;;97150 ARTTHER COG GRP 2-4^RC039^97150
;;97150 ARTTHER COG GRP 5-20^RC040^97150
;;97150 ARTTHER COG GRP >20^RC041^97150
;;97150 ARTTHER EMOTGRP 2-4^RC042^97150
;;97150 ARTTHER EMOTGRP 5-20^RC043^97150
;;97150 ARTTHER EMOTGRP >20^RC044^97150
;;97530 DANCETHER IND15M^RC045^97530
;;97530 DANCETHER GRP 2-4^RC046^97150
;;97530 DANCETHER GRP 5-20^RC047^97150
;;97530 DANCETHER GRP >20^RC048^97150
;;97150 DRAMA THER IND^RC049^97530
;;97530 DRAMA THER GRP 2-4^RC050^97150
;;97530 DRAMA THER GRP 5-20^RC051^97150
;;97530 DRAMA THER GRP >20^RC052^97150
;;92506 MUSTHER SOC IND 15M^RC053^92506
;;92507 MUSTHER COG IND 15M^RC054^92507
;;97112 MUSTHER PHYIND 15M^RC055^97112
;;91533 MUSTHER EMOTIND 15M^RC056^97533
;;97150 MUSTHER SOCGRP 2-4^RC057^97150
;;97150 MUSTHER SOCGRP 5-20^RC058^97150
;;97150 MUSTHER SOCGRP >20^RC059^97150
;;97150 MUSTHER COGGRP 2-4^RC060^97150
;;97150 MUSTHER COGGRP 5-20^RC061^97150
;;97150 MUSTHER COGGRP >20^RC062^97150
;;97150 MUSTHER PHYGRP 2-4^RC063^97150
;;97150 MUSTHER PHYGRP 5-20^RC064^97150
;;97150 MUSTHER PHYGRP >20^RC065^97150
;;97150 MUSTHER EMOTGRP 2-4^RC066^97150
;;97150 MUSTHER EMOTGRP 5-20^RC067^97150
;;97150 MUSTHER EMOTGRP >20^RC068^97150
;;97110 AQUATIC ACT IND 30M^RC069^97110
;;S9454 AQUATIC ACT GRP 2-4^RC070^S9454
;;S9454 AQUATIC ACT GRP 5-20^RC071^S9454
;;S9454 AQUATIC ACT GRP >20^RC072^S9454
;;97113 AQUATICTHER IND 30M^RC073^97113
;;97150 AQUATICTHER GRP 2-4^RC074^97150
;;97150 AQUATICTHER GRP5-20^RC075^97150
;;97150 AQUATICTHER GRP >20^RC076^97150
;;97537 COMMIINTEGRT IND^RC077^97537
;;97537 COMMINTEGRTGRP 2-4^RC078^97537
;;97537 COMM INTEGRTGRP 5-20^RC079^97537
;;97537 COMM INTEGRTGRP >20^RC080^97537
;;S9446 LEIS EDUC IND 15M^RC081^S9446
;;S9446 LEIS EDUCGRP2-4 15M^RC082^S9446
;;S9446 LEIS EDUCGRP 5-20 15M^RC083^S9446
;;S9446 LEIS EDUCGRP>20 15M^RC084^S9446
;;98966 TELEPHONE SHORT^RC085^98966
;;98967 TELEPHONE MED^RC086^98967
;;98968 TELEPHONE LONG^RC087^98968
;;T2001 PAT ESCORT GRP 2-4^RC088^T2001
;;T2001 PAT ESCORT GRP 5-20^RC089^T2001
;;T2001 PAT ESCORT GRP >20^RC090^T2001
;;CNH PHONE OVERSIGHT^HH142^
;;CNH FAX REVIEW ONLY^HH143^
;;NU162/MNT F/U EA 15M^NU162^97803
;;NU163/MNT SUBSEQ EA 15M^NU163^G0270
;;NU164/NUT CNSG IND,1ST15M^NU164^S9470
;;NU165/CASE MGT,W/PT EA15M^NU165^T1017
;;NU166/NUT SCREENING 10M^NU166^T1023
;;NU167/OTHER OPT VISIT^NU167^99211
;;NU168/PT EDUC 1ST 15M^NU168^S9445
;;NU169/INSLN PMP ED 1ST15M^NU169^S9145
;;NU170/GLUC FINGER STICK^NU170^82962
;;NU171/PHONE 5-10 MIN^NU171^98966
;;NU172/PHONE 11-20 MIN^NU172^98967
;;NU173/PHONE 21-30 MIN^NU173^98968
;;NU174/DSMT ACCRED IND 30M^NU174^G0108
;;NU175/DSMT NONACD 1ST15M^NU175^S9465
;;NU176/DSMT NONACD FU1ST15^NU176^S9140
;;NU177/CBGM^NU177^95250
;;NU178/SELF-MGT ED IND,30M^NU178^98960
;;NU179/SELF MGT GP2-4,30M^NU179^98961
;;NU180/SELF MGT GP5-8,30M^NU180^98962
;;NU181/COLL RVW ELEC DATA^NU181^99091
;;NU182/MNT INIT EA 15M^NU182^97802
;;NON-PHYS TM CNF, PT PRSNT^SP551^99366
;;NON-PHYS TM CNF, PT NOT PRSNT^SP552^99368
;;98969 ONLINE SERVICE^SP553^98969
;;QUIT
NAMECHG ;* change national procedure names
;
; ECXX is in format:
; NATIONAL NUMBER^NEW NAME
;
N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,STR
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 STR="Can't find entry for "_$P(ECXX,U,1)
..D BMES^XPDUTL(STR_" ...field (#.01) not updated.")
Q
;
CHNG ;name changes -national code #^new procedure name
;;NU019^NU019/PHONE 5-10M NO PT
;;NU020^NU020/PHONE 11-20M NO PT
;;NU021^NU021/PHONE 21-30M NO PT
;;NU022^NU022/PHONE 5-10M PROV
;;NU023^NU023/PHONE 11-20M PROV
;;NU024^NU024/PHONE 21-30M PROV
;;SP350^STANDARDIZED COGNITIVE TESTING
;;SW010^PHONE CONTACT 5-10 MIN
;;SW012^PHONE D/C NONMH F/U 15MIN
;;SW044^PHONE CONTACT 11-20 MIN
;;SW045^PHONE CONTACT 21-30 MIN
;;SW054^PHONE D/C NONMH F/U 45MIN
;;SW089^PHONE D/C MH F/U 15 MIN
;;SP196^98966 TELEPHONE SERVICE, 5-10 MIN
;;SP197^98967 TELEPHONE SERVICE, 11-20 MIN
;;SP198^98968 TELEPHONE SERVICE, 21-30 MIN
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC725U48 8615 printed Nov 22, 2024@17:06:53 Page 2
EC725U48 ;ALB/GTS/JAP/GT - EC National Procedure Update; 02/27/2008
+1 ;;2.0; EVENT CAPTURE ;**96**;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 ;
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,NAME,CODE,CPT,COUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
+7 NEW ECADD,ECBEG,ECEND,CODX,NAMX,ECSEQ,LIEN,STR,CPTN,STR
+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 COUNT=$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 NAME=$PIECE(ECXX,U,1)
SET CODE=$PIECE(ECXX,U,2)
SET CPTN=$PIECE(ECXX,U,3)
SET CODX=CODE
+14 SET CPT=""
+15 IF CPTN'=""
SET CPT=$$FIND1^DIC(81,"","X",CPTN)
IF +CPT<1
Begin DoDot:2
+16 SET STR=" CPT code "_CPTN_" not a valid code in CPT File."
+17 DO MES^XPDUTL(" ")
+18 DO BMES^XPDUTL(" ["_CODE_"] "_STR)
End DoDot:2
QUIT
+19 SET ECBEG=$PIECE(ECXX,U,4)
SET ECEND=$PIECE(ECXX,U,5)
SET NAMX=NAME
+20 IF ECBEG=""
SET X=NAME
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 NAME=NAMX_ECADD,X=NAME,CODE=CODX_ECADD
+24 IF $EXTRACT(CODX,1,3)'="RCM"
SET NAME=NAMX_ECSEQ
SET X=NAME
SET CODE=CODX_ECADD
+25 IF '$TEST
SET NAME=NAMX_$EXTRACT(ECADD,2,99)
SET X=NAME
SET CODE=CODX_$EXTRACT(ECADD,2,99)
+26 DO FILPROC
End DoDot:2
End DoDot:1
+27 SET $PIECE(^EC(725,0),U,4)=COUNT
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",CODE))
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=CODE;4////^S X=CPT"
+4 DO FILE^DICN
+5 IF +Y>0
Begin DoDot:2
+6 SET COUNT=COUNT+1
+7 DO MES^XPDUTL(" ")
+8 SET STR=" Entry #"_+Y_" for "_$PIECE(Y,U,2)
+9 SET STR=STR_$SELECT(CPT'="":" [CPT: "_CPT_"]",1:"")_" ("_CODE_")"
+10 DO BMES^XPDUTL(STR_" ...successfully added.")
End DoDot:2
+11 IF Y=-1
Begin DoDot:2
+12 DO MES^XPDUTL(" ")
+13 DO BMES^XPDUTL("ERROR when attempting to add "_NAME_" ("_CODE_")")
End DoDot:2
End DoDot:1
+14 IF $DATA(^EC(725,"DL",CODE))
Begin DoDot:1
+15 SET LIEN=$ORDER(^EC(725,"DL",CODE,""))
+16 DO MES^XPDUTL(" ")
+17 DO BMES^XPDUTL(" Your site has a local procedure (entry #"_LIEN_") in File #725")
+18 DO BMES^XPDUTL(" which uses "_CODE_" as its National Number.")
+19 DO BMES^XPDUTL(" Please inactivate this local procedure.")
+20 KILL Y
End DoDot:1
+21 QUIT
NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
+1 ;;97001 REFER/CONS/SCREEN^RC001^97001
+2 ;;97001 RECORD REVIEW^RC002^97001
+3 ;;97001 ASMNT INIT 30M^RC003^97001
+4 ;;97002 ASMNT UPREVDISC 30M^RC004^97002
+5 ;;97001 ASMNT PROG NOTE^RC005^97001
+6 ;;97001 ASMNT PROG NOTE 15M^RC006^97001
+7 ;;97001 DISCH/COMM REF 15M^RC007^97001
+8 ;;97001 DISCH/COMM REF 30M^RC008^97001
+9 ;;98961 TEAMEETCAREPLAN 15M^RC009^98961
+10 ;;98961 TEAMEETCAREPLAN 30M^RC010^98961
+11 ;;98962 IDT GRP 2-4 30M^RC011^98962
+12 ;;98962 IDT GRP 5-10 30M^RC012^98962
+13 ;;97530 REC CREATARTIND 15M^RC013^97530
+14 ;;99499 REC CREATARTGRP 2-4^RC014^99499
+15 ;;99499 REC CREATARTGRP 5-20^RC015^99499
+16 ;;99499 REC CREATARTGRP >20^RC016^99499
+17 ;;97532 RECTHER EMOT IND 15M^RC017^97532
+18 ;;97530 RECTHER COG IND 15M^RC018^97530
+19 ;;97112 RECTHER PHY IND 15M^RC019^97112
+20 ;;97532 RECTHER SOC IND 15M^RC020^97532
+21 ;;97150 RECTHER SOC GRP 2-4^RC021^97150
+22 ;;97150 RECTHER SOC GRP 5-20^RC022^97150
+23 ;;97150 RECTHER SOC GRP>20^RC023^97150
+24 ;;97150 RECTHER COG GRP 2-4^RC024^97150
+25 ;;97150 RECTHER COG GRP 5-20^RC025^97150
+26 ;;97150 RECTHER COG GRP >20^RC026^97150
+27 ;;97150 RECTHER PHY GRP 2-4^RC027^97150
+28 ;;97150 RECTHER PHY GRP 5-20^RC028^97150
+29 ;;97150 RECTHER PHY GRP >20^RC029^97150
+30 ;;97150 RECTHER EMOT GRP 2-4^RC030^97150
+31 ;;97150 RECTHER EMOTGRP 5-20^RC031^97150
+32 ;;97150 RECTHER EMOTGRP >20^RC032^97150
+33 ;;97530 ARTTHER SOC IND 15M^RC033^97530
+34 ;;97532 ARTTHER COG IND 15M^RC034^97532
+35 ;;97533 ARTTHER EMOTIND 15M^RC035^97533
+36 ;;97150 ARTTHER SOC GRP 2-4^RC036^97150
+37 ;;97150 ARTTHER SOC GRP 5-20^RC037^97150
+38 ;;97150 ARTTHER SOC GRP >20^RC038^97150
+39 ;;97150 ARTTHER COG GRP 2-4^RC039^97150
+40 ;;97150 ARTTHER COG GRP 5-20^RC040^97150
+41 ;;97150 ARTTHER COG GRP >20^RC041^97150
+42 ;;97150 ARTTHER EMOTGRP 2-4^RC042^97150
+43 ;;97150 ARTTHER EMOTGRP 5-20^RC043^97150
+44 ;;97150 ARTTHER EMOTGRP >20^RC044^97150
+45 ;;97530 DANCETHER IND15M^RC045^97530
+46 ;;97530 DANCETHER GRP 2-4^RC046^97150
+47 ;;97530 DANCETHER GRP 5-20^RC047^97150
+48 ;;97530 DANCETHER GRP >20^RC048^97150
+49 ;;97150 DRAMA THER IND^RC049^97530
+50 ;;97530 DRAMA THER GRP 2-4^RC050^97150
+51 ;;97530 DRAMA THER GRP 5-20^RC051^97150
+52 ;;97530 DRAMA THER GRP >20^RC052^97150
+53 ;;92506 MUSTHER SOC IND 15M^RC053^92506
+54 ;;92507 MUSTHER COG IND 15M^RC054^92507
+55 ;;97112 MUSTHER PHYIND 15M^RC055^97112
+56 ;;91533 MUSTHER EMOTIND 15M^RC056^97533
+57 ;;97150 MUSTHER SOCGRP 2-4^RC057^97150
+58 ;;97150 MUSTHER SOCGRP 5-20^RC058^97150
+59 ;;97150 MUSTHER SOCGRP >20^RC059^97150
+60 ;;97150 MUSTHER COGGRP 2-4^RC060^97150
+61 ;;97150 MUSTHER COGGRP 5-20^RC061^97150
+62 ;;97150 MUSTHER COGGRP >20^RC062^97150
+63 ;;97150 MUSTHER PHYGRP 2-4^RC063^97150
+64 ;;97150 MUSTHER PHYGRP 5-20^RC064^97150
+65 ;;97150 MUSTHER PHYGRP >20^RC065^97150
+66 ;;97150 MUSTHER EMOTGRP 2-4^RC066^97150
+67 ;;97150 MUSTHER EMOTGRP 5-20^RC067^97150
+68 ;;97150 MUSTHER EMOTGRP >20^RC068^97150
+69 ;;97110 AQUATIC ACT IND 30M^RC069^97110
+70 ;;S9454 AQUATIC ACT GRP 2-4^RC070^S9454
+71 ;;S9454 AQUATIC ACT GRP 5-20^RC071^S9454
+72 ;;S9454 AQUATIC ACT GRP >20^RC072^S9454
+73 ;;97113 AQUATICTHER IND 30M^RC073^97113
+74 ;;97150 AQUATICTHER GRP 2-4^RC074^97150
+75 ;;97150 AQUATICTHER GRP5-20^RC075^97150
+76 ;;97150 AQUATICTHER GRP >20^RC076^97150
+77 ;;97537 COMMIINTEGRT IND^RC077^97537
+78 ;;97537 COMMINTEGRTGRP 2-4^RC078^97537
+79 ;;97537 COMM INTEGRTGRP 5-20^RC079^97537
+80 ;;97537 COMM INTEGRTGRP >20^RC080^97537
+81 ;;S9446 LEIS EDUC IND 15M^RC081^S9446
+82 ;;S9446 LEIS EDUCGRP2-4 15M^RC082^S9446
+83 ;;S9446 LEIS EDUCGRP 5-20 15M^RC083^S9446
+84 ;;S9446 LEIS EDUCGRP>20 15M^RC084^S9446
+85 ;;98966 TELEPHONE SHORT^RC085^98966
+86 ;;98967 TELEPHONE MED^RC086^98967
+87 ;;98968 TELEPHONE LONG^RC087^98968
+88 ;;T2001 PAT ESCORT GRP 2-4^RC088^T2001
+89 ;;T2001 PAT ESCORT GRP 5-20^RC089^T2001
+90 ;;T2001 PAT ESCORT GRP >20^RC090^T2001
+91 ;;CNH PHONE OVERSIGHT^HH142^
+92 ;;CNH FAX REVIEW ONLY^HH143^
+93 ;;NU162/MNT F/U EA 15M^NU162^97803
+94 ;;NU163/MNT SUBSEQ EA 15M^NU163^G0270
+95 ;;NU164/NUT CNSG IND,1ST15M^NU164^S9470
+96 ;;NU165/CASE MGT,W/PT EA15M^NU165^T1017
+97 ;;NU166/NUT SCREENING 10M^NU166^T1023
+98 ;;NU167/OTHER OPT VISIT^NU167^99211
+99 ;;NU168/PT EDUC 1ST 15M^NU168^S9445
+100 ;;NU169/INSLN PMP ED 1ST15M^NU169^S9145
+101 ;;NU170/GLUC FINGER STICK^NU170^82962
+102 ;;NU171/PHONE 5-10 MIN^NU171^98966
+103 ;;NU172/PHONE 11-20 MIN^NU172^98967
+104 ;;NU173/PHONE 21-30 MIN^NU173^98968
+105 ;;NU174/DSMT ACCRED IND 30M^NU174^G0108
+106 ;;NU175/DSMT NONACD 1ST15M^NU175^S9465
+107 ;;NU176/DSMT NONACD FU1ST15^NU176^S9140
+108 ;;NU177/CBGM^NU177^95250
+109 ;;NU178/SELF-MGT ED IND,30M^NU178^98960
+110 ;;NU179/SELF MGT GP2-4,30M^NU179^98961
+111 ;;NU180/SELF MGT GP5-8,30M^NU180^98962
+112 ;;NU181/COLL RVW ELEC DATA^NU181^99091
+113 ;;NU182/MNT INIT EA 15M^NU182^97802
+114 ;;NON-PHYS TM CNF, PT PRSNT^SP551^99366
+115 ;;NON-PHYS TM CNF, PT NOT PRSNT^SP552^99368
+116 ;;98969 ONLINE SERVICE^SP553^98969
+117 ;;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,STR
+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 STR="Can't find entry for "_$PIECE(ECXX,U,1)
+20 DO BMES^XPDUTL(STR_" ...field (#.01) not updated.")
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
CHNG ;name changes -national code #^new procedure name
+1 ;;NU019^NU019/PHONE 5-10M NO PT
+2 ;;NU020^NU020/PHONE 11-20M NO PT
+3 ;;NU021^NU021/PHONE 21-30M NO PT
+4 ;;NU022^NU022/PHONE 5-10M PROV
+5 ;;NU023^NU023/PHONE 11-20M PROV
+6 ;;NU024^NU024/PHONE 21-30M PROV
+7 ;;SP350^STANDARDIZED COGNITIVE TESTING
+8 ;;SW010^PHONE CONTACT 5-10 MIN
+9 ;;SW012^PHONE D/C NONMH F/U 15MIN
+10 ;;SW044^PHONE CONTACT 11-20 MIN
+11 ;;SW045^PHONE CONTACT 21-30 MIN
+12 ;;SW054^PHONE D/C NONMH F/U 45MIN
+13 ;;SW089^PHONE D/C MH F/U 15 MIN
+14 ;;SP196^98966 TELEPHONE SERVICE, 5-10 MIN
+15 ;;SP197^98967 TELEPHONE SERVICE, 11-20 MIN
+16 ;;SP198^98968 TELEPHONE SERVICE, 21-30 MIN
+17 ;;QUIT
