EC725U34 ;ALB/GTS/JAP/GT - EC National Procedure Update; 6/29/2005
;;2.0; EVENT CAPTURE ;**77**;8 May 96
;
;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
;;HH RN SPVSN CTRCT ADLT DY CARE^HH133^99499
;;HH DRIVE TIME (15MIN) MD^HH134
;;HH DRIVE TIME (15MIN) RN^HH135
;;HH DRIVE TIME (15MIN) NP^HH136
;;HH DRIVE TIME (15MIN) SW^HH137
;;HH DRIVE TIME (15MIN) DIET^HH138
;;HH DRIVE TIME (15MIN) OT^HH139
;;HH DRIVE TIME (15MIN) PT^HH140
;;HH DRIVE TIME (15MIN) OTHER^HH141
;;PT ED GP,10-13 PT,1ST 30M^NU096^S9446
;;PT ED GP,14-17 PT,1ST 30M^NU097^S9446
;;PT ED GP,18-20 PT,1ST 30M^NU098^S9446
;;PT ED GP,21-25 PT,1ST 30M^NU099^S9446
;;PT ED GP,>25 PT,1ST 30M^NU100^S9446
;;SMOK CESS,2-3PT,1ST 30M^NU101^S9453
;;SMOK CESS,4-6PT,1ST 30M^NU102^S9453
;;SMOK CESS,7-9PT,1ST 30M^NU103^S9453
;;SMOK CESS,10-13PT,1ST 30M^NU104^S9453
;;SMOK CESS,14-17PT,1ST 30M^NU105^S9453
;;SMOK CESS,18-20PT,1ST 30M^NU106^S9453
;;SMOK CESS,21-25PT,1ST 30M^NU107^S9453
;;SMOK CESS,>25PT,1ST 30M^NU108^S9453
;;NUTR GP,2-3PT,EA AD'L 30M^NU109
;;NUTR GP,4-6PT,EA AD'L 30M^NU110
;;NUTR GP,7-9PT,EA AD'L 30M^NU111
;;NUTR GP,10-13PT,EA AD'L 30M^NU112
;;NUTR GP,14-17PT,EA AD'L 30M^NU113
;;NUTR GP,18-20PT,EA AD'L 30M^NU114
;;NUTR GP,21-25PT,EA AD'L 30M^NU115
;;NUTR GP,>25PT,EA AD'L 30M^NU116
;;WT MGT,2-3PT,EA AD'L 30M^NU117
;;WT MGT,4-6PT,EA AD'L 30M^NU118
;;WT MGT,7-9PT,EA AD'L 30M^NU119
;;WT MGT,10-13PT,EA AD'L 30M^NU120
;;WT MGT,14-17PT,EA AD'L 30M^NU121
;;WT MGT18-20PT,EA AD'L 30M^NU122
;;WT MGT,21-25PT,EA AD'L 30M^NU123
;;WT MGT,>25PT,EA AD'L 30M^NU124
;;DIAB MGT,2-3PT,EA AD'L30M^NU125
;;DIAB MGT,4-6PT,EA AD'L30M^NU126
;;DIAB MGT,7-9PT,EA AD'L30M^NU127
;;DIAB MGT,10-13PT,EA AD'L30M^NU128
;;DIAB MGT,14-17PT,EA AD'L30M^NU129
;;DIAB MGT,18-20PT,EA AD'L30M^NU130
;;DIAB MGT,21-25PT,EA AD'L30M^NU131
;;DIAB MGT,>25PT,EA AD'L 30M^NU132
;;PT ED GP,2-3PT,EA AD'L 30M^NU133
;;PT ED GP,4-6PT,EA AD'L 30M^NU134
;;PT ED GP,7-9PT,EA AD'L 30M^NU135
;;PT ED GP,10-13PT,EA AD'L30M^NU136
;;PT ED GP,14-17PT,EA AD'L30M^NU137
;;PT ED GP,18-20PT,EA AD'L30M^NU138
;;PT ED GP,21-25PT,EA AD'L30M^NU139
;;PT ED GP,>25PT,EA AD'L 30M^NU140
;;SMOK CESS,2-3PT,EA AD'L30M^NU141
;;SMOK CESS,4-6PT,EA AD'L30M^NU142
;;SMOK CESS,7-9PT,EA AD'L30M^NU143
;;SMOK CESS,10-13PT,EA AD'L30M^NU144
;;SMOK CESS,14-17PT,EA AD'L30M^NU145
;;SMOK CESS,18-20PT,EA AD'L30M^NU146
;;SMOK CESS,21-25PT,EA AD'L30M^NU147
;;SMOK CESS,>25PT,EA AD'L30M^NU148
;;PT EDUC IND, EA AD'L 15M^NU149
;;DIAB MGT IND, EA AD'L15M^NU150
;;NUTR CNSLG IND, EA AD'L15M^NU151
;;DIAB MGT F/U, EA AD'L15M^NU152
;;INSLN PMP INSTR,EA AD'L15M^NU153
;;MED RECORD REVIEW,OPT,5M^NU154
;;NON-NUTR INPT ED,EA 15M^NU155
;;NUTR HBPC DRIVE TIME,EA 15M^NU156
;;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
;;MH066^MH CWT/TWE <4 HR NFF
;;MH067^MH CWT/TWE 4 to <8 HR NFF
;;MH068^MH CWT/TWE 8 HRS/MORE NFF
;;MH069^MH CWT/SE <4 HR NFF
;;MH070^MH CWT/SE 4 to <8 HR NFF
;;MH071^MH CWT/SE 8 HRS/MORE NFF
;;PM504^PM CWT/TWE <4 HR NFF
;;PM505^PM CWT/TWE 4 to <8 HR NFF
;;PM506^PM CWT/TWE 8 HRS/MORE NFF
;;PM507^PM CWT/SE <4 HR NFF
;;PM508^PM CWT/SE 4 to <8 HR NFF
;;PM509^PM CWT/SE 8 HRS/MORE NFF
;;NU006^MED RECORD REVIEW,INPT,5M
;;NU013^MENU ANLYS/MEAL PLN DEV,5M
;;NU016^INTERDISC.CARE PLN MTG,3M
;;NU019^PHONE-BRIEF-ON PT BEHALF
;;NU020^PHONE-INTERM-ON PT BEHALF
;;NU021^PHONE-LENGTH-ON PT BEHALF
;;NU025^INTERDISC GP,2-3PT,EA15M
;;NU026^INTERDISC GP,4-6PT,EA15M
;;NU027^INTERDISC GP,7-9PT,EA15M
;;NU028^INTERDISC GP,10-13PT,EA15M
;;NU029^INTERDISC GP,14-17PT,EA15M
;;NU030^INTERDISC GP,18-20PT,EA15M
;;NU031^INTERDISC GP,21-25PT,EA15M
;;NU032^INTERDISC GP,>25PT,EA15M
;;NU033^IP NUTR ED GP,2-3PT,EA,30M
;;NU034^IP NUTR ED GP,4-6PT,EA,30M
;;NU035^IP NUTR ED GP,7-9PT,EA,30M
;;NU036^IP NUTR ED GP,10-13PT,EA30M
;;NU037^IP NUTR ED GP,14-17PT,EA30M
;;NU038^IP NUTR ED GP,18-20PT,EA30M
;;NU039^IP NUTR ED GP,21-25PT,EA30M
;;NU040^IP NUTR ED GP,>25PT,EA30M
;;NU042^INTERDISC IND VISIT,15M
;;NU043^DISCUSS W/OTHR HC PROV,5M
;;NU044^MNT NUTR GP,2-3 PT,EA30M
;;NU045^MNT NUTR GP,4-6 PT,EA30M
;;NU046^MNT NUTR GP,7-9 PT,EA30M
;;NU047^MNT NUTR GP,10-13PT,EA30M
;;NU048^MNT NUTR GP,14-17PT,EA30M
;;NU049^MNT NUTR GP,18-20PT,EA30M
;;NU050^MNT NUTR GP,21-25PT,EA30M
;;NU051^MNT NUTR GP,>25PT,EA30M
;;NU052^MNT GP 2ND REF,2-3PT,EA30M
;;NU053^MNT GP 2ND REF,4-6PT,EA30M
;;NU054^MNT GP 2ND REF,7-9PT,EA30M
;;NU055^MNT GP 2ND REF,10-13PT,EA30M
;;NU056^MNT GP 2ND REF,14-17PT,EA30M
;;NU057^MNT GP 2ND REF,18-20PT,EA30M
;;NU058^MNT GP 2ND REF,21-25PT,EA30M
;;NU059^MNT GP 2ND REF,>25PT,EA30M
;;NU060^DSMT GP,2-3PT,EA 30M
;;NU061^DSMT GP,4-6PT,EA 30M
;;NU062^DSMT GP,7-9PT,EA 30M
;;NU063^DSMT GP,10-13PT,EA 30M
;;NU064^DSMT GP,14-17PT,EA 30M
;;NU065^DSMT GP,18-20PT,EA 30M
;;NU066^DSMT GP,21-25PT,EA 30M
;;NU067^DSMT GP,>25PT,EA 30M
;;NU069^WT MGT,2-3PT,1ST 30M
;;NU070^WT MGT,4-6PT,1ST 30M
;;NU071^WT MGT,7-9PT,1ST 30M
;;NU072^WT MGT,10-13PT,1ST 30M
;;NU073^WT MGT,14-17PT,1ST 30M
;;NU074^WT MGT,18-20PT,1ST 30M
;;NU075^WT MGT,21-25PT,1ST 30M
;;NU076^WT MGT,>25MT,1ST 30M
;;NU077^NUTR ED,2-3PT,1ST 30M
;;NU078^NUTR ED,4-6PT,1ST 30M
;;NU079^NUTR ED,7-9PT,1ST 30M
;;NU080^NUTR ED,10-13PT,1ST 30M
;;NU081^NUTR ED,14-17PT,1ST 30M
;;NU082^NUTR ED,18-20PT,1ST 30M
;;NU083^NUTR ED,21-25PT,1ST 30M
;;NU084^NUTR ED,>25PT,1ST 30M
;;NU085^DIAB MGT,2-3PT,1ST 30M
;;NU086^DIAB MGT,4-6PT,1ST 30M
;;NU087^DIAB MGT,7-9PT,1ST 30M
;;NU088^DIAB MGT,10-13PT,1ST 30M
;;NU089^DIAB MGT,14-17PT,1ST 30M
;;NU090^DIAB MGT,18-20PT,1ST 30M
;;NU091^DIAB MGT,21-25PT,1ST 30M
;;NU092^DIAB MGT,>25PT,1ST 30M
;;NU093^PT ED GP,2-3PT,1ST 30M
;;NU094^PT ED GP,4-6 PT,1ST 30M
;;NU095^PT ED GP,7-9 PT,1ST 30M
;;QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEC725U34 8933 printed Apr 09, 2024@21:01:19 Page 2
EC725U34 ;ALB/GTS/JAP/GT - EC National Procedure Update; 6/29/2005
+1 ;;2.0; EVENT CAPTURE ;**77**;8 May 96
+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 ;;HH RN SPVSN CTRCT ADLT DY CARE^HH133^99499
+2 ;;HH DRIVE TIME (15MIN) MD^HH134
+3 ;;HH DRIVE TIME (15MIN) RN^HH135
+4 ;;HH DRIVE TIME (15MIN) NP^HH136
+5 ;;HH DRIVE TIME (15MIN) SW^HH137
+6 ;;HH DRIVE TIME (15MIN) DIET^HH138
+7 ;;HH DRIVE TIME (15MIN) OT^HH139
+8 ;;HH DRIVE TIME (15MIN) PT^HH140
+9 ;;HH DRIVE TIME (15MIN) OTHER^HH141
+10 ;;PT ED GP,10-13 PT,1ST 30M^NU096^S9446
+11 ;;PT ED GP,14-17 PT,1ST 30M^NU097^S9446
+12 ;;PT ED GP,18-20 PT,1ST 30M^NU098^S9446
+13 ;;PT ED GP,21-25 PT,1ST 30M^NU099^S9446
+14 ;;PT ED GP,>25 PT,1ST 30M^NU100^S9446
+15 ;;SMOK CESS,2-3PT,1ST 30M^NU101^S9453
+16 ;;SMOK CESS,4-6PT,1ST 30M^NU102^S9453
+17 ;;SMOK CESS,7-9PT,1ST 30M^NU103^S9453
+18 ;;SMOK CESS,10-13PT,1ST 30M^NU104^S9453
+19 ;;SMOK CESS,14-17PT,1ST 30M^NU105^S9453
+20 ;;SMOK CESS,18-20PT,1ST 30M^NU106^S9453
+21 ;;SMOK CESS,21-25PT,1ST 30M^NU107^S9453
+22 ;;SMOK CESS,>25PT,1ST 30M^NU108^S9453
+23 ;;NUTR GP,2-3PT,EA AD'L 30M^NU109
+24 ;;NUTR GP,4-6PT,EA AD'L 30M^NU110
+25 ;;NUTR GP,7-9PT,EA AD'L 30M^NU111
+26 ;;NUTR GP,10-13PT,EA AD'L 30M^NU112
+27 ;;NUTR GP,14-17PT,EA AD'L 30M^NU113
+28 ;;NUTR GP,18-20PT,EA AD'L 30M^NU114
+29 ;;NUTR GP,21-25PT,EA AD'L 30M^NU115
+30 ;;NUTR GP,>25PT,EA AD'L 30M^NU116
+31 ;;WT MGT,2-3PT,EA AD'L 30M^NU117
+32 ;;WT MGT,4-6PT,EA AD'L 30M^NU118
+33 ;;WT MGT,7-9PT,EA AD'L 30M^NU119
+34 ;;WT MGT,10-13PT,EA AD'L 30M^NU120
+35 ;;WT MGT,14-17PT,EA AD'L 30M^NU121
+36 ;;WT MGT18-20PT,EA AD'L 30M^NU122
+37 ;;WT MGT,21-25PT,EA AD'L 30M^NU123
+38 ;;WT MGT,>25PT,EA AD'L 30M^NU124
+39 ;;DIAB MGT,2-3PT,EA AD'L30M^NU125
+40 ;;DIAB MGT,4-6PT,EA AD'L30M^NU126
+41 ;;DIAB MGT,7-9PT,EA AD'L30M^NU127
+42 ;;DIAB MGT,10-13PT,EA AD'L30M^NU128
+43 ;;DIAB MGT,14-17PT,EA AD'L30M^NU129
+44 ;;DIAB MGT,18-20PT,EA AD'L30M^NU130
+45 ;;DIAB MGT,21-25PT,EA AD'L30M^NU131
+46 ;;DIAB MGT,>25PT,EA AD'L 30M^NU132
+47 ;;PT ED GP,2-3PT,EA AD'L 30M^NU133
+48 ;;PT ED GP,4-6PT,EA AD'L 30M^NU134
+49 ;;PT ED GP,7-9PT,EA AD'L 30M^NU135
+50 ;;PT ED GP,10-13PT,EA AD'L30M^NU136
+51 ;;PT ED GP,14-17PT,EA AD'L30M^NU137
+52 ;;PT ED GP,18-20PT,EA AD'L30M^NU138
+53 ;;PT ED GP,21-25PT,EA AD'L30M^NU139
+54 ;;PT ED GP,>25PT,EA AD'L 30M^NU140
+55 ;;SMOK CESS,2-3PT,EA AD'L30M^NU141
+56 ;;SMOK CESS,4-6PT,EA AD'L30M^NU142
+57 ;;SMOK CESS,7-9PT,EA AD'L30M^NU143
+58 ;;SMOK CESS,10-13PT,EA AD'L30M^NU144
+59 ;;SMOK CESS,14-17PT,EA AD'L30M^NU145
+60 ;;SMOK CESS,18-20PT,EA AD'L30M^NU146
+61 ;;SMOK CESS,21-25PT,EA AD'L30M^NU147
+62 ;;SMOK CESS,>25PT,EA AD'L30M^NU148
+63 ;;PT EDUC IND, EA AD'L 15M^NU149
+64 ;;DIAB MGT IND, EA AD'L15M^NU150
+65 ;;NUTR CNSLG IND, EA AD'L15M^NU151
+66 ;;DIAB MGT F/U, EA AD'L15M^NU152
+67 ;;INSLN PMP INSTR,EA AD'L15M^NU153
+68 ;;MED RECORD REVIEW,OPT,5M^NU154
+69 ;;NON-NUTR INPT ED,EA 15M^NU155
+70 ;;NUTR HBPC DRIVE TIME,EA 15M^NU156
+71 ;;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 ;;MH066^MH CWT/TWE <4 HR NFF
+2 ;;MH067^MH CWT/TWE 4 to <8 HR NFF
+3 ;;MH068^MH CWT/TWE 8 HRS/MORE NFF
+4 ;;MH069^MH CWT/SE <4 HR NFF
+5 ;;MH070^MH CWT/SE 4 to <8 HR NFF
+6 ;;MH071^MH CWT/SE 8 HRS/MORE NFF
+7 ;;PM504^PM CWT/TWE <4 HR NFF
+8 ;;PM505^PM CWT/TWE 4 to <8 HR NFF
+9 ;;PM506^PM CWT/TWE 8 HRS/MORE NFF
+10 ;;PM507^PM CWT/SE <4 HR NFF
+11 ;;PM508^PM CWT/SE 4 to <8 HR NFF
+12 ;;PM509^PM CWT/SE 8 HRS/MORE NFF
+13 ;;NU006^MED RECORD REVIEW,INPT,5M
+14 ;;NU013^MENU ANLYS/MEAL PLN DEV,5M
+15 ;;NU016^INTERDISC.CARE PLN MTG,3M
+16 ;;NU019^PHONE-BRIEF-ON PT BEHALF
+17 ;;NU020^PHONE-INTERM-ON PT BEHALF
+18 ;;NU021^PHONE-LENGTH-ON PT BEHALF
+19 ;;NU025^INTERDISC GP,2-3PT,EA15M
+20 ;;NU026^INTERDISC GP,4-6PT,EA15M
+21 ;;NU027^INTERDISC GP,7-9PT,EA15M
+22 ;;NU028^INTERDISC GP,10-13PT,EA15M
+23 ;;NU029^INTERDISC GP,14-17PT,EA15M
+24 ;;NU030^INTERDISC GP,18-20PT,EA15M
+25 ;;NU031^INTERDISC GP,21-25PT,EA15M
+26 ;;NU032^INTERDISC GP,>25PT,EA15M
+27 ;;NU033^IP NUTR ED GP,2-3PT,EA,30M
+28 ;;NU034^IP NUTR ED GP,4-6PT,EA,30M
+29 ;;NU035^IP NUTR ED GP,7-9PT,EA,30M
+30 ;;NU036^IP NUTR ED GP,10-13PT,EA30M
+31 ;;NU037^IP NUTR ED GP,14-17PT,EA30M
+32 ;;NU038^IP NUTR ED GP,18-20PT,EA30M
+33 ;;NU039^IP NUTR ED GP,21-25PT,EA30M
+34 ;;NU040^IP NUTR ED GP,>25PT,EA30M
+35 ;;NU042^INTERDISC IND VISIT,15M
+36 ;;NU043^DISCUSS W/OTHR HC PROV,5M
+37 ;;NU044^MNT NUTR GP,2-3 PT,EA30M
+38 ;;NU045^MNT NUTR GP,4-6 PT,EA30M
+39 ;;NU046^MNT NUTR GP,7-9 PT,EA30M
+40 ;;NU047^MNT NUTR GP,10-13PT,EA30M
+41 ;;NU048^MNT NUTR GP,14-17PT,EA30M
+42 ;;NU049^MNT NUTR GP,18-20PT,EA30M
+43 ;;NU050^MNT NUTR GP,21-25PT,EA30M
+44 ;;NU051^MNT NUTR GP,>25PT,EA30M
+45 ;;NU052^MNT GP 2ND REF,2-3PT,EA30M
+46 ;;NU053^MNT GP 2ND REF,4-6PT,EA30M
+47 ;;NU054^MNT GP 2ND REF,7-9PT,EA30M
+48 ;;NU055^MNT GP 2ND REF,10-13PT,EA30M
+49 ;;NU056^MNT GP 2ND REF,14-17PT,EA30M
+50 ;;NU057^MNT GP 2ND REF,18-20PT,EA30M
+51 ;;NU058^MNT GP 2ND REF,21-25PT,EA30M
+52 ;;NU059^MNT GP 2ND REF,>25PT,EA30M
+53 ;;NU060^DSMT GP,2-3PT,EA 30M
+54 ;;NU061^DSMT GP,4-6PT,EA 30M
+55 ;;NU062^DSMT GP,7-9PT,EA 30M
+56 ;;NU063^DSMT GP,10-13PT,EA 30M
+57 ;;NU064^DSMT GP,14-17PT,EA 30M
+58 ;;NU065^DSMT GP,18-20PT,EA 30M
+59 ;;NU066^DSMT GP,21-25PT,EA 30M
+60 ;;NU067^DSMT GP,>25PT,EA 30M
+61 ;;NU069^WT MGT,2-3PT,1ST 30M
+62 ;;NU070^WT MGT,4-6PT,1ST 30M
+63 ;;NU071^WT MGT,7-9PT,1ST 30M
+64 ;;NU072^WT MGT,10-13PT,1ST 30M
+65 ;;NU073^WT MGT,14-17PT,1ST 30M
+66 ;;NU074^WT MGT,18-20PT,1ST 30M
+67 ;;NU075^WT MGT,21-25PT,1ST 30M
+68 ;;NU076^WT MGT,>25MT,1ST 30M
+69 ;;NU077^NUTR ED,2-3PT,1ST 30M
+70 ;;NU078^NUTR ED,4-6PT,1ST 30M
+71 ;;NU079^NUTR ED,7-9PT,1ST 30M
+72 ;;NU080^NUTR ED,10-13PT,1ST 30M
+73 ;;NU081^NUTR ED,14-17PT,1ST 30M
+74 ;;NU082^NUTR ED,18-20PT,1ST 30M
+75 ;;NU083^NUTR ED,21-25PT,1ST 30M
+76 ;;NU084^NUTR ED,>25PT,1ST 30M
+77 ;;NU085^DIAB MGT,2-3PT,1ST 30M
+78 ;;NU086^DIAB MGT,4-6PT,1ST 30M
+79 ;;NU087^DIAB MGT,7-9PT,1ST 30M
+80 ;;NU088^DIAB MGT,10-13PT,1ST 30M
+81 ;;NU089^DIAB MGT,14-17PT,1ST 30M
+82 ;;NU090^DIAB MGT,18-20PT,1ST 30M
+83 ;;NU091^DIAB MGT,21-25PT,1ST 30M
+84 ;;NU092^DIAB MGT,>25PT,1ST 30M
+85 ;;NU093^PT ED GP,2-3PT,1ST 30M
+86 ;;NU094^PT ED GP,4-6 PT,1ST 30M
+87 ;;NU095^PT ED GP,7-9 PT,1ST 30M
+88 ;;QUIT
