source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U21.m@ 1608

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

initial load of WorldVistAEHR
File size: 4.1 KB
Line 
1EC725U21 ;ALB/GTS/JAP/JAM - EC National Procedure Update; 12/19/02
2 ;;2.0; EVENT CAPTURE ;**48**;8 May 96
3 ;
4 ;this routine is used as a post-init in KIDS build
5 ;to modify the the EC National Procedure file #725
6 ;
7INACT ;* inactivate national procedures
8 ;
9 ; ECXX is in format:
10 ; NATIONAL NUMBER^INACTIVATION DATE^FIRST NATIONAL NUMBER SEQUENCE^
11 ; LAST NATIONAL NUMBER SEQUENCE
12 ;
13 N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
14 N ECSEQ,CODE,CODX
15 D MES^XPDUTL(" ")
16 D BMES^XPDUTL("Inactivating procedures EC NATIONAL PROCEDURE File (#725)...")
17 D MES^XPDUTL(" ")
18 F ECX=1:1 K DD,DO,DA S ECXX=$P($T(OLD+ECX),";;",2) Q:ECXX="QUIT" D
19 .S ECEXDT=$P(ECXX,U,2),X=ECEXDT,%DT="X" D ^%DT S ECINDT=$P(Y,".",1)
20 .S CODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CODX=CODE
21 .I ECBEG="" D UPINACT Q
22 .F ECSEQ=ECBEG:1:ECEND D
23 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
24 ..S CODE=CODX_ECADD
25 ..D UPINACT
26 Q
27UPINACT ;Update codes as inactive
28 ;
29 S ECDA=+$O(^EC(725,"D",CODE,0))
30 I $D(^EC(725,ECDA,0)) D
31 .S DA=ECDA,DR="2////^S X=ECINDT",DIE="^EC(725," D ^DIE
32 .D MES^XPDUTL(" ")
33 .D BMES^XPDUTL(" "_CODE_" inactivated as of "_ECEXDT_".")
34 Q
35 ;
36OLD ;national procedures to be inactivated - national code #^inact. date
37 ;;SP127^1/1/2003
38 ;;SP128^1/1/2003
39 ;;SP129^1/1/2003
40 ;;SP236^1/1/2003
41 ;;SP237^1/1/2003
42 ;;SP238^1/1/2003
43 ;;SP239^1/1/2003
44 ;;SP241^1/1/2003
45 ;;SP242^1/1/2003
46 ;;SP262^1/1/2003
47 ;;SP263^1/1/2003
48 ;;SP444^1/1/2003
49 ;;SP445^1/1/2003
50 ;;SP446^1/1/2003
51 ;;SP448^1/1/2003
52 ;;SP465^1/1/2003
53 ;;SP466^1/1/2003
54 ;;QUIT
55 ;
56REACT ;* reactivate national procedures
57 ;
58 ; ECXX is in format:
59 ; NATIONAL NUMBER^DATE (FUTURE)^FIRST NATIONAL NUMBER SEQUENCE^
60 ; LAST NATIONAL NUMBER SEQUENCE
61 ;
62 N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
63 N ECSEQ,CODE,CODX,ECDES
64 D MES^XPDUTL(" ")
65 D BMES^XPDUTL("Reactivating procedures EC NATIONAL PROCEDURE File (#725)...")
66 D MES^XPDUTL(" ")
67 F ECX=1:1 K DD,DO,DA S ECXX=$P($T(ACT+ECX),";;",2) Q:ECXX="QUIT" D
68 .S ECDES=$P(ECXX,U,5)
69 .S CODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CODX=CODE
70 .I ECBEG="" D UPREACT Q
71 .F ECSEQ=ECBEG:1:ECEND D
72 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
73 ..S CODE=CODX_ECADD
74 ..D UPREACT
75 Q
76UPREACT ;Update codes as reactive
77 ;
78 S ECDA=+$O(^EC(725,"D",CODE,0))
79 I $D(^EC(725,ECDA,0)) D
80 .S DA=ECDA,DR="2///@",DIE="^EC(725," D ^DIE
81 .D BMES^XPDUTL(" "_CODE_" "_ECDES_" reactivated.")
82 Q
83 ;
84ACT ;national procedures to be reactivated - national number^date
85 ;;SP130^1/1/2003
86 ;;QUIT
87 ;
88CPTCHG ;* change cpt codes
89 ;
90 ; ECXX is in format:
91 ; NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL
92 ; NUMBER SEQUENCE
93 ;
94 N ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,NAME,ECSEQ,STR,CPTIEN
95 D MES^XPDUTL(" ")
96 D BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
97 D MES^XPDUTL(" ")
98 F ECX=1:1 S ECXX=$P($T(CPT+ECX),";;",2) Q:ECXX="QUIT" D
99 .S ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CPTIEN=$P(ECXX,U,2)
100 .S CPTIEN=$S(CPTIEN="":"@",1:$$FIND1^DIC(81,"","X",CPTIEN))
101 .I CPTIEN'="@",+CPTIEN<1 D Q
102 ..S STR=$P(ECXX,U)_": CPT code "_$P(ECXX,U,2)_" is invalid."
103 ..D MES^XPDUTL(" ")
104 ..D BMES^XPDUTL(" "_STR)
105 .I ECBEG="" S CPT($P(ECXX,U))=CPTIEN_U_$P(ECXX,U,2) Q
106 .F ECSEQ=ECBEG:1:ECEND D
107 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
108 ..S CPT($P(ECXX,U)_ECADD)=CPTIEN_U_$P(ECXX,U,2)
109 S ECXX=""
110 F S ECXX=$O(CPT(ECXX)) Q:ECXX="" D
111 .S ECX=$O(^EC(725,"D",ECXX,0))
112 .Q:+ECX=0
113 .I '$D(^EC(725,ECX,0))!(+ECX=0) D Q
114 ..D MES^XPDUTL(" ")
115 ..D BMES^XPDUTL(" Can't find entry for "_ECXX_",CPT cde not updated.")
116 .S CPT=$P(CPT(ECXX),U),DA=ECX,DR="4////"_CPT,DIE="^EC(725," D ^DIE
117 .D MES^XPDUTL(" ")
118 .S STR=" Entry #"_ECX_" for "_ECXX
119 .D BMES^XPDUTL(STR_" updated to use CPT code "_$P(CPT(ECXX),U,2))
120 Q
121 ;
122CPT ;cpt codes to be changed - national #^new CPT code
123 ;;CH065
124 ;;CH084
125 ;;SP112^92506
126 ;;SP114^92507
127 ;;SP116^92700
128 ;;SP117^92700
129 ;;SP230^92610
130 ;;SP233^92700
131 ;;SP327^92506
132 ;;SP328^92506
133 ;;SP329^92507
134 ;;SP330^92507
135 ;;SP440^92610
136 ;;SP441^92610
137 ;;SP447^92609
138 ;;SP453^92612
139 ;;SP454^92614
140 ;;SP455^92611
141 ;;SP463^92609
142 ;;SP464^92609
143 ;;SW076^G0155
144 ;;QUIT
Note: See TracBrowser for help on using the repository browser.