source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U37.m@ 1605

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

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