source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U32.m@ 861

EC725U32 ;ALB/GTS/JAP/GT - EC National Procedure Update; 4/02/2005

 ;;2.0; EVENT CAPTURE ;**74**;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

 ;;A4265 ALCOHOL WIPES^SP503^A4265

 ;;A4363 SKIN PROTECTIVE BARRIER^SP504^A4363

 ;;A465 ADHESIVE REMOVER WIPES^SP505^A4365

 ;;A5119 SKIN PROTECTIVE WIPES^SP506^A5119

 ;;A7501 TRACH VALVE W DIAPHRAGM^SP507^A7501

 ;;A7502 DIAPHRAGM VALVE REPL^SP508^A7502

 ;;A7503 HMES FILTER HOLDER OR CAP^SP509^A7503

 ;;A7504 HMES FILTER^SP510^A7504

 ;;A7505 HMES VALVE HOUSING^SP511^A7505

 ;;A7506 HMES ADHESIVE DISC^SP512^A7506

 ;;A7507 HMES HOLDER WITH FILTER^SP513^A7507

 ;;A7508 HMES HOUSING WITH ADHESIVE^SP514^A7508

 ;;A7509 HMES SYSTEM^SP515^A7509

 ;;A7520 LARYNGECTOMY TUBE NON-CUFF^SP516^A7520

 ;;A7521 LARYNGECTOMY TUBE CUFFED^SP517^A7521

 ;;A7523 TRACH SHOWER PROTECT^SP518^A7523

 ;;A7524 TRACH STENT/STUD/BUTTON^SP519^A7524

 ;;A7527 TRACH TUBE PLUG/STOP^SP520^A7527

 ;;A9280 ALTERING DEVICE NOC^SP521^A9280

 ;;L8499 UNLISTED MISC PROSTH SERVICE^SP522^L8499

 ;;L8511 TRACH INSERT, INDWELL REPL^SP523^L8511

 ;;L8512 GEL CAP TRACH VOICE PROSTH^SP524^L8512

 ;;L8513 TRACH PROSTH CLEANING DEV^SP525^L8513

 ;;L8514 REPL TEPDIALATOR^SP526^L8514

 ;;L8515 GEL CAP APPLICATION^SP527^L8515

 ;;L8615 COCHLEAR IMPLANT HEADSET^SP528^L8615

 ;;L8616 COCHLEAR MICROPHONE REPL^SP529^L8616

 ;;L8617 COCHLEAR IMPLANT COIL REPL^SP530^L8617

 ;;L8620 CI BATTERY, LITHIUM^SP531^L8620

 ;;L8621 CI BATTERY ZINC AIR^SP532^L8621

 ;;L8622 CI BATTERY ALKALINE^SP533^L8622

 ;;S0250 COMP GERIATRIC ASSESSMENT^SP534^S0250

 ;;S0257 COUNSELING ADV DIRECTIVES^SP535^S0257

 ;;S0315 DISEASE MGMT PROG INITIAL^SP536^S0315

 ;;S0316 DISEASE MGMT FOLLOWUP^SP537^S0316

 ;;S0317 DISEASE MGMT PER DIEM^SP538^S0317

 ;;S0618 AUDIOMETRY FOR HEARING AID^SP539^S0618

 ;;S9092 CANALITH REPOSITIONING^SP540^S9092

 ;;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

 ;;NU014^MDS CARE PLAN DOC,10M

 ;;NU033^IP NUT.ED.GP,1-3PTS,30M

 ;;NU034^IP NUT.ED.GP,4-6PTS,30M

 ;;NU035^IP NUT.ED.GP,7-9PTS,30M

 ;;NU036^IP NUT.ED.GP,10-13PTS,30M

 ;;NU037^IP NUT.ED.GP,14-17PTS,30M

 ;;NU038^IP NUT.ED.GP,18-20PTS,30M

 ;;NU039^IP NUT.ED.GP,21-25PTS,30M

 ;;NU040^IP NUT.ED.GP,>25PTS,30M

 ;;NU042^INTERDISC IND VISIT 15M

 ;;NU043^DISCUSS W/OTHR HC PROV 5M

 ;;NU077^OPT NUT.ED.GP,1-3PTS

 ;;NU078^OPT NUT.ED.GP,4-6PTS

 ;;NU079^OPT NUT.ED.GP,7-9PTS

 ;;NU080^OPT NUT.ED.GP,10-13PTS

 ;;NU081^OPT NUT.ED.GP,14-17PTS

 ;;NU082^OPT NUT.ED.GP,18-20PTS

 ;;NU083^OPT NUT.ED.GP,21-25PTS

 ;;NU084^OPT NUT.ED.GP,>25PTS

 ;;SP432^TRACHEOSTOMY MASK

 ;;SP433^TRACH TUBE COLLAR/HOLDER

 ;;SP069^VERTICAL CHANNEL RECORDING

 ;;SP430^L8618 CI TRANSMIT CABLE RPL

 ;;SP434^A4623 TRACH INNER CANNULA

 ;;QUIT