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

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 4.3 KB
Line 
1EC725CH8 ;ALB/GTS/JAP - EC National Procedure Update; 10/28/98
2 ;;2.0; EVENT CAPTURE ;**16**;8 May 96
3 ;
4 ;this routine is used as a post-init in a KIDS build
5 ;to modify the EC National Procedure file #725
6 ;
7NAMECHG ;* change national procedure names
8 ;
9 ; ECXX is in format:
10 ; NATIONAL NUMBER^NEW NAME
11 ;
12 N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y
13 D MES^XPDUTL(" ")
14 D BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE File (#725)...")
15 D MES^XPDUTL(" ")
16 F ECX=1:1 S ECXX=$P($T(CHNG+ECX),";;",2) Q:ECXX="QUIT" D
17 .I $D(^EC(725,"D",$P(ECXX,U,1))) D
18 ..S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),0))
19 ..I $D(^EC(725,ECDA,0)) D
20 ...S DA=ECDA,DR=".01////^S X=$P(ECXX,U,2)",DIE="^EC(725," D ^DIE
21 ...D MES^XPDUTL(" ")
22 ...D BMES^XPDUTL(" Entry #"_ECDA_" for "_$P(ECXX,U,1))
23 ...D BMES^XPDUTL(" ...field (#.01) updated to "_$P(ECXX,U,2)_".")
24 .I '$D(^EC(725,"D",$P(ECXX,U,1))) D
25 ..D MES^XPDUTL(" ")
26 ..D BMES^XPDUTL("Can't find entry for "_$P(ECXX,U,1))
27 ..D BMES^XPDUTL("...field (#.01) not updated.")
28 Q
29 ;
30CHNG ;name changes
31 ;;SP016^APHASIA ASSESSMENT, PER HOUR
32 ;;SP024^OTHER NONINVASIVE INSTRUM EXAM
33 ;;SP056^NON-INSTRUMENT SWALLOWING EVAL
34 ;;SP100^CENTRAL AUDITORY FUNCTION TEST
35 ;;SP124^SPEECH/HEAR PROSTH DEVICE ORIENT
36 ;;SP130^EXPERT TESTIMONY/OPINION
37 ;;QUIT
38 ;
39ADDPROC ;* add national procedures
40 ;
41 ; ECXX is in format:
42 ; NAME^NATIONAL NUMBER^CPT CODE
43 ;
44 N ECX,ECXX,ECDINUM,NAME,CODE,CPT,COUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
45 D MES^XPDUTL(" ")
46 D BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE File (#725)...")
47 D MES^XPDUTL(" ")
48 S ECDINUM=$O(^EC(725,9999),-1),COUNT=$P(^EC(725,0),U,4)
49 F ECX=1:1 S ECXX=$P($T(NEW+ECX),";;",2) Q:ECXX="QUIT" D
50 .S NAME=$P(ECXX,U,1),CODE=$P(ECXX,U,2),CPT=$P(ECXX,U,3)
51 .I '$D(^EC(725,"D",CODE)) D
52 ..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"
53 ..D FILE^DICN
54 ..I +Y>0 D
55 ...S COUNT=COUNT+1
56 ...D MES^XPDUTL(" ")
57 ...D BMES^XPDUTL(" Entry #"_+Y_" for "_$P(Y,U,2)_" ("_CODE_")")
58 ...D BMES^XPDUTL(" ...successfully added.")
59 ..I Y=-1 D
60 ...D MES^XPDUTL(" ")
61 ...D BMES^XPDUTL("ERROR when attempting to add "_NAME_" ("_CODE_")")
62 .I $D(^EC(725,"DL",CODE)) D
63 ..S LIEN=$O(^EC(725,"DL",CODE,""))
64 ..D MES^XPDUTL(" ")
65 ..D BMES^XPDUTL(" Your site has a local procedure (entry #"_LIEN_") in File #725")
66 ..D BMES^XPDUTL(" which uses "_CODE_" as its National Number.")
67 ..D BMES^XPDUTL(" Please inactivate this local procedure.")
68 ..K Y
69 S $P(^EC(725,0),U,4)=COUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X
70 Q
71 ;
72NEW ;national procedures to add
73 ;;CRYOPRECIPITATE, THAWING^BB989^86999
74 ;;FRESH FROZEN PLASMA, THAWI^BB990^86999
75 ;;SASSI 2 SUBS ABS SCRN INV^PL057^96100
76 ;;CPAQ-CHRNPAIN ACC QUESTN^PL058^96100
77 ;;CSQ-COPING STRATEGY QUEST^PL059^96100
78 ;;CISS-COPING INVENT STRESS^PL060^96100
79 ;;CAI-CAREER ASSESS INVNTRY^PL061^96100
80 ;;WRAT-R WIDE RNG ACH TST R^PL062^96100
81 ;;ADD-ATTENTION DEFICIT DIS^PL063^96100
82 ;;BECK DEPRESSION INV SPANISH^PL064^96100
83 ;;ADHD-WENDER UTAH (ADHD)^PL065^96100
84 ;;STROOP NEURO SCREENING^PL900^96100
85 ;;PPVT PEABODY PICTURE VOCA^PL995^96100
86 ;;LOGIC/JUDGEMENT^PL996^96100
87 ;;Y-BOC^PL997^96100
88 ;;CTS CATEGORY TEST SLIDES^PL998^96100
89 ;;MHLC MULTIDIMEN LOCUS CNTR^PL999^96100
90 ;;ORTHOTIC MATERIAL COSTS^PR001^L8499
91 ;;ORTHOTIC LABOR MINUTES^PR002^L8499
92 ;;PSYC PT CONST WATCH/HOUR^PS101^99199
93 ;;SUCTIONING, 20 MIN^RT001^94799
94 ;;TRANSPORTING VENTILATOR^RT002^94799
95 ;;OXYGEN SETUPS, 10 MIN^RT003^94799
96 ;;CLEANINGEQUIPMENT, 10 M^RT004^94799
97 ;;INCENTIVESPIROMETRY, 10^RT005^94799
98 ;;WEANING PARAMETERS15 MIN^RT006^94799
99 ;;VENTILATOR SELF TESTS (E^RT007^94799
100 ;;EXTUBATIONS, 15 MIN^RT008^94799
101 ;;MONITOR EKG DURING BRONC^RT009^94799
102 ;;CHECK AEROSOLS & DRAIN T^RT010^94799
103 ;;NEW EQUIPSETUPS & CHANG^RT011^94799
104 ;;VENTILATOR CHANGES (RATE^RT012^94799
105 ;;END EXHALED C02 MANEUVER^RT013^94799
106 ;;CUFF PRESSURE CHECKS, TR^RT014^94799
107 ;;CYLINDEREXCHANGE, 15 MI^RT015^94799
108 ;;METERED DOSE INHALATION^RT016^94799
109 ;;HOME OXYGEN INSTRUCTION^RT017^94799
110 ;;TRACH TUBE CHANGING SUBSEQ^RT993^94799
111 ;;EXTUBATION^RT994^94799
112 ;;QUAD COUGH^RT995^94799
113 ;;AIRWAY CARE^RT996^94799
114 ;;WEANING CRITERIA^RT997^94799
115 ;;EQUIPMENTCHANGE^RT998^94799
116 ;;TRANSPORT^RT999^99082
117 ;;TINNITUS DEVICE SELECTION^SP261^92506
118 ;;ASSESS/EVAL, INI, BRIEF (15MIN)^RT989^94799
119 ;;REASSESSMENT^RT990^94799
120 ;;TEAM CONFERENCE^RT991^94799
121 ;;OXYGEN THERAPY^RT992^94799
122 ;;QUIT
Note: See TracBrowser for help on using the repository browser.