source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U34.m@ 1765

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