source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U01.m@ 891

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

initial load of WorldVistAEHR
File size: 3.2 KB
RevLine 
[613]1EC725U01 ;ALB/GTS/JAP/JAM - EC National Procedure Update; 08/11/99
2 ;;2.0; EVENT CAPTURE ;**20**;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
37 ;;SP^10/1/1999^125^126
38 ;;SP^10/1/1999^142^145
39 ;;SP^10/1/1999^148^150
40 ;;SP^10/1/1999^152^155
41 ;;SP^10/1/1999^157^160
42 ;;SP^10/1/1999^162^168
43 ;;SP^10/1/1999^170^206
44 ;;SP^10/1/1999^257^259
45 ;;SW005^10/1/1999
46 ;;SW008^10/1/1999
47 ;;SW016^10/1/1999
48 ;;SW022^10/1/1999
49 ;;SW029^10/1/1999
50 ;;SW030^10/1/1999
51 ;;SW040^10/1/1999
52 ;;SW041^10/1/1999
53 ;;SW042^10/1/1999
54 ;;SW070^10/1/1999
55 ;;QUIT
56 ;
57CPTCHG ;* change cpt codes
58 ;
59 ; ECXX is in format:
60 ; NATIONAL NUMBER^NEW CPT^FIRST NATIONAL NUMBER SEQUENCE^LAST NATIONAL
61 ; NUMBER SEQUENCE
62 ;
63 N ECX,ECXX,CPT,DIC,DIE,DA,DR,X,Y,ECBEG,ECEND,ECADD,NAME,ECSEQ,FL
64 D MES^XPDUTL(" ")
65 D BMES^XPDUTL("Changing CPT Codes in EC NATIONAL PROCEDURE file (#725)")
66 D BMES^XPDUTL(" Also adding '10M' to some procedure description...")
67 D MES^XPDUTL(" ")
68 F ECX=1:1 S ECXX=$P($T(CPT+ECX),";;",2) Q:ECXX="QUIT" D
69 .S ECBEG=$P(ECXX,U,3),ECEND=$P(ECXX,U,4)
70 .I ECBEG="" S CPT($P(ECXX,U,1))=$P(ECXX,U,2)_U_0 Q
71 .F ECSEQ=ECBEG:1:ECEND D
72 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
73 ..S CPT($P(ECXX,U)_ECADD)=$P(ECXX,U,2)_U_1
74 S ECXX=""
75 F S ECXX=$O(CPT(ECXX)) Q:ECXX="" D
76 .S ECX=$O(^EC(725,"D",ECXX,0))
77 .Q:+ECX=0
78 .I '$D(^EC(725,ECX,0))!(+ECX=0) D Q
79 ..D MES^XPDUTL(" ")
80 ..D BMES^XPDUTL(" Can't find entry for"_ECXX)
81 ..D BMES^XPDUTL(" ...NAME field (#.01) nor CPT code updated.")
82 .S CPT=$P(CPT(ECXX),U),FL=$P(CPT(ECXX),U,2),DA=ECX
83 .I FL S NAME=$P(^EC(725,ECX,0),U) D I FL S NAME=NAME_" 10M"
84 ..I $E(NAME,$L(NAME)-3,$L(NAME))=" 10M" S FL=0 ;10M already added
85 .S DR=$S(FL:".01////^S X=NAME;",1:"")_"4////"_CPT,DIE="^EC(725," D ^DIE
86 .D MES^XPDUTL(" ")
87 .D BMES^XPDUTL(" Entry #"_ECX_" for "_ECXX)
88 .D BMES^XPDUTL(" ...updated to use CPT code "_CPT_$S(FL:" with desc. "_NAME_".",1:"."))
89 Q
90 ;
91CPT ;cpt codes to be changed
92 ;;CH^99499^1^15
93 ;;CH^99499^17^71
94 ;;CH^99499^73^84
95 ;;SW002^99261
96 ;;SW003^99238
97 ;;SW013^99211
98 ;;SW014^99263
99 ;;SW019^99411
100 ;;SW025^99411
101 ;;SW026^99411
102 ;;SW033^99262
103 ;;SW034^99263
104 ;;SW056^99212
105 ;;SW057^99213
106 ;;SW058^99214
107 ;;SW059^99215
108 ;;QUIT
Note: See TracBrowser for help on using the repository browser.