source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725CH8.m@ 1595

EC725CH8 ;ALB/GTS/JAP - EC National Procedure Update; 10/28/98
 ;;2.0; EVENT CAPTURE ;**16**;8 May 96
 ;
 ;this routine is used as a post-init in a KIDS build 
 ;to modify the EC National Procedure file #725
 ;
NAMECHG ;* change national procedure names
 ;
 ;  ECXX is in format:
 ;   NATIONAL NUMBER^NEW NAME
 ;
 N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y
 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 BMES^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(" ")
 ..D BMES^XPDUTL("Can't find entry for "_$P(ECXX,U,1))
 ..D BMES^XPDUTL("...field (#.01) not updated.")
 Q
 ;
CHNG ;name changes
 ;;SP016^APHASIA ASSESSMENT, PER HOUR
 ;;SP024^OTHER NONINVASIVE INSTRUM EXAM
 ;;SP056^NON-INSTRUMENT SWALLOWING EVAL
 ;;SP100^CENTRAL AUDITORY FUNCTION TEST
 ;;SP124^SPEECH/HEAR PROSTH DEVICE ORIENT
 ;;SP130^EXPERT TESTIMONY/OPINION
 ;;QUIT
 ;
ADDPROC ;* add national procedures
 ;
 ;  ECXX is in format:
 ;   NAME^NATIONAL NUMBER^CPT CODE
 ;
 N ECX,ECXX,ECDINUM,NAME,CODE,CPT,COUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
 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),CPT=$P(ECXX,U,3)
 .I '$D(^EC(725,"D",CODE)) D
 ..S X=NAME,ECDINUM=ECDINUM+1,DINUM=ECDINUM,DIC(0)="L",DLAYGO=725,DIC="^EC(725,",DIC("DR")="1////^S X=CODE;4////^S X=CPT"
 ..D FILE^DICN
 ..I +Y>0 D
 ...S COUNT=COUNT+1
 ...D MES^XPDUTL(" ")
 ...D BMES^XPDUTL("   Entry #"_+Y_" for "_$P(Y,U,2)_" ("_CODE_")")
 ...D BMES^XPDUTL("   ...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
 S $P(^EC(725,0),U,4)=COUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X
 Q
 ;
NEW ;national procedures to add
 ;;CRYOPRECIPITATE, THAWING^BB989^86999
 ;;FRESH FROZEN PLASMA, THAWI^BB990^86999
 ;;SASSI 2 SUBS ABS SCRN INV^PL057^96100
 ;;CPAQ-CHRNPAIN ACC QUESTN^PL058^96100
 ;;CSQ-COPING STRATEGY QUEST^PL059^96100
 ;;CISS-COPING INVENT STRESS^PL060^96100
 ;;CAI-CAREER ASSESS INVNTRY^PL061^96100
 ;;WRAT-R WIDE RNG ACH TST R^PL062^96100
 ;;ADD-ATTENTION DEFICIT DIS^PL063^96100
 ;;BECK DEPRESSION INV SPANISH^PL064^96100
 ;;ADHD-WENDER UTAH (ADHD)^PL065^96100
 ;;STROOP NEURO SCREENING^PL900^96100
 ;;PPVT PEABODY PICTURE VOCA^PL995^96100
 ;;LOGIC/JUDGEMENT^PL996^96100
 ;;Y-BOC^PL997^96100
 ;;CTS CATEGORY TEST SLIDES^PL998^96100
 ;;MHLC MULTIDIMEN LOCUS CNTR^PL999^96100
 ;;ORTHOTIC MATERIAL COSTS^PR001^L8499
 ;;ORTHOTIC LABOR MINUTES^PR002^L8499
 ;;PSYC PT CONST WATCH/HOUR^PS101^99199
 ;;SUCTIONING, 20 MIN^RT001^94799
 ;;TRANSPORTING VENTILATOR^RT002^94799
 ;;OXYGEN SETUPS, 10 MIN^RT003^94799
 ;;CLEANINGEQUIPMENT, 10 M^RT004^94799
 ;;INCENTIVESPIROMETRY, 10^RT005^94799
 ;;WEANING PARAMETERS15 MIN^RT006^94799
 ;;VENTILATOR SELF TESTS (E^RT007^94799
 ;;EXTUBATIONS, 15 MIN^RT008^94799
 ;;MONITOR EKG DURING BRONC^RT009^94799
 ;;CHECK AEROSOLS & DRAIN T^RT010^94799
 ;;NEW EQUIPSETUPS & CHANG^RT011^94799
 ;;VENTILATOR CHANGES (RATE^RT012^94799
 ;;END EXHALED C02 MANEUVER^RT013^94799
 ;;CUFF PRESSURE CHECKS, TR^RT014^94799
 ;;CYLINDEREXCHANGE, 15 MI^RT015^94799
 ;;METERED DOSE INHALATION^RT016^94799
 ;;HOME OXYGEN INSTRUCTION^RT017^94799
 ;;TRACH TUBE CHANGING SUBSEQ^RT993^94799
 ;;EXTUBATION^RT994^94799
 ;;QUAD COUGH^RT995^94799
 ;;AIRWAY CARE^RT996^94799
 ;;WEANING CRITERIA^RT997^94799
 ;;EQUIPMENTCHANGE^RT998^94799
 ;;TRANSPORT^RT999^99082
 ;;TINNITUS DEVICE SELECTION^SP261^92506
 ;;ASSESS/EVAL, INI, BRIEF (15MIN)^RT989^94799
 ;;REASSESSMENT^RT990^94799
 ;;TEAM CONFERENCE^RT991^94799
 ;;OXYGEN THERAPY^RT992^94799
 ;;QUIT