source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U27.m@ 1036

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

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