Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: EC725CH8

EC725CH8.m

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