source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U45.m@ 1765

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

initial load of FOIAVistA 6/30/08 version

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