source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U49.m@ 1169

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

initial load of FOIAVistA 6/30/08 version
File size: 3.7 KB
Line 
1EC725U49 ;ALB/GTS/JAP/GT - EC National Procedure Update; 02/27/2008
2 ;;2.0; EVENT CAPTURE ;**96**;8 May 96;Build 5
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 ;;SW055^4/15/2008
38 ;;QUIT
39 ;
40REACT ;* reactivate national procedures
41 ;
42 ; ECXX is in format:
43 ; NATIONAL NUMBER^DATE (FUTURE)^FIRST NATIONAL NUMBER SEQUENCE^
44 ; LAST NATIONAL NUMBER SEQUENCE
45 ;
46 N ECX,ECXX,ECEXDT,ECINDT,ECDA,DIC,DIE,DA,DR,X,Y,%DT,ECBEG,ECEND,ECADD
47 N ECSEQ,CODE,CODX,ECDES
48 D MES^XPDUTL(" ")
49 D BMES^XPDUTL("Reactivating procedures EC NATIONAL PROCEDURE File (#725)...")
50 D MES^XPDUTL(" ")
51 F ECX=1:1 K DD,DO,DA S ECXX=$P($T(ACT+ECX),";;",2) Q:ECXX="QUIT" D
52 .S ECDES=$P(ECXX,U,5)
53 .S CODE=$P(ECXX,U),ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CODX=CODE
54 .I ECBEG="" D UPREACT Q
55 .F ECSEQ=ECBEG:1:ECEND D
56 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
57 ..S CODE=CODX_ECADD
58 ..D UPREACT
59 Q
60UPREACT ;Update codes as reactive
61 ;
62 S ECDA=+$O(^EC(725,"D",CODE,0))
63 I $D(^EC(725,ECDA,0)) D
64 .S DA=ECDA,DR="2///@",DIE="^EC(725," D ^DIE
65 .D BMES^XPDUTL(" "_CODE_" "_ECDES_" reactivated.")
66 Q
67 ;
68ACT ;national procedures to be reactivated - national number^date
69 ;;QUIT
70 ;
71CPTCHG ;* change cpt codes
72 ;
73 ; ECXX is in format:
74 ; NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL
75 ; NUMBER SEQUENCE
76 ;
77 N ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,NAME,ECSEQ,STR,CPTIEN
78 D MES^XPDUTL(" ")
79 D BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
80 D MES^XPDUTL(" ")
81 F ECX=1:1 S ECXX=$P($T(CPT+ECX),";;",2) Q:ECXX="QUIT" D
82 .S ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4),CPTIEN=$P(ECXX,U,2)
83 .S CPTIEN=$S(CPTIEN="":"@",1:$$FIND1^DIC(81,"","X",CPTIEN))
84 .I CPTIEN'="@",+CPTIEN<1 D Q
85 ..S STR=$P(ECXX,U)_": CPT code "_$P(ECXX,U,2)_" is invalid."
86 ..D MES^XPDUTL(" ")
87 ..D BMES^XPDUTL(" "_STR)
88 .I ECBEG="" S CPT($P(ECXX,U))=CPTIEN_U_$P(ECXX,U,2) Q
89 .F ECSEQ=ECBEG:1:ECEND D
90 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
91 ..S CPT($P(ECXX,U)_ECADD)=CPTIEN_U_$P(ECXX,U,2)
92 S ECXX=""
93 F S ECXX=$O(CPT(ECXX)) Q:ECXX="" D
94 .S ECX=$O(^EC(725,"D",ECXX,0))
95 .Q:+ECX=0
96 .I '$D(^EC(725,ECX,0))!(+ECX=0) D Q
97 ..D MES^XPDUTL(" ")
98 ..D BMES^XPDUTL(" Can't find entry for "_ECXX_",CPT cde not updated.")
99 .S CPT=$P(CPT(ECXX),U),DA=ECX,DR="4////"_CPT,DIE="^EC(725," D ^DIE
100 .D MES^XPDUTL(" ")
101 .S STR=" Entry #"_ECX_" for "_ECXX
102 .D BMES^XPDUTL(STR_" updated to use CPT code "_$P(CPT(ECXX),U,2))
103 Q
104 ;
105CPT ;cpt codes to be changed - national #^new CPT code
106 ;;HH025^98966
107 ;;HH026^98967
108 ;;HH027^98968
109 ;;SP350^96125
110 ;;SW010^98966
111 ;;SW012^98967
112 ;;SW044^98967
113 ;;SW045^98968
114 ;;SW054^98968
115 ;;SW089^98967
116 ;;SP196^98966
117 ;;SP197^98967
118 ;;SP198^98968
119 ;;QUIT
Note: See TracBrowser for help on using the repository browser.