source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/EC725U46.m@ 1608

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

initial load of WorldVistAEHR

File size: 4.1 KB
Line 
1EC725U46 ;ALB/GTS/JAP/GT - EC National Procedure Update; 06/05/2007
2 ;;2.0; EVENT CAPTURE ;**93**;8 May 96;Build 1
3 ;
4 ;this routine is used as a post-init in a KIDS build
5 ;to modify the EC National Procedure file #725
6 ;
7ADDPROC ;* add national procedures
8 ;
9 ; ECXX is in format:
10 ; NAME^NATIONAL NUMBER^CPT CODE^FIRST NATIONAL NUMBER SEQUENCE
11 ; LAST NATIONAL NUMBER SEQUENCE
12 ;
13 N ECX,ECXX,ECDINUM,NAME,CODE,CPT,COUNT,X,Y,DIC,DIE,DA,DR,DLAYGO,DINUM
14 N ECADD,ECBEG,ECEND,CODX,NAMX,ECSEQ,LIEN,STR,CPTN,STR
15 D MES^XPDUTL(" ")
16 D BMES^XPDUTL("Adding new procedures to EC NATIONAL PROCEDURE File (#725)...")
17 D MES^XPDUTL(" ")
18 S ECDINUM=$O(^EC(725,9999),-1),COUNT=$P(^EC(725,0),U,4)
19 F ECX=1:1 S ECXX=$P($T(NEW+ECX),";;",2) Q:ECXX="QUIT" D
20 .S NAME=$P(ECXX,U,1),CODE=$P(ECXX,U,2),CPTN=$P(ECXX,U,3),CODX=CODE
21 .S CPT=""
22 .I CPTN'="" S CPT=$$FIND1^DIC(81,"","X",CPTN) I +CPT<1 D Q
23 ..S STR=" CPT code "_CPTN_" not a valid code in CPT File."
24 ..D MES^XPDUTL(" ")
25 ..D BMES^XPDUTL(" ["_CODE_"] "_STR)
26 .S ECBEG=$P(ECXX,U,4),ECEND=$P(ECXX,U,5),NAMX=NAME
27 .I ECBEG="" S X=NAME D FILPROC Q
28 .F ECSEQ=ECBEG:1:ECEND D
29 ..S ECADD="000"_ECSEQ,ECADD=$E(ECADD,$L(ECADD)-2,$L(ECADD))
30 ..;S NAME=NAMX_ECADD,X=NAME,CODE=CODX_ECADD
31 ..I $E(CODX,1,3)'="RCM" S NAME=NAMX_ECSEQ,X=NAME,CODE=CODX_ECADD
32 ..E S NAME=NAMX_$E(ECADD,2,99),X=NAME,CODE=CODX_$E(ECADD,2,99)
33 ..D FILPROC
34 S $P(^EC(725,0),U,4)=COUNT,X=$O(^EC(725,999999),-1),$P(^EC(725,0),U,3)=X
35 Q
36 ;
37FILPROC ;File national procedures
38 I '$D(^EC(725,"D",CODE)) D
39 .S ECDINUM=ECDINUM+1,DINUM=ECDINUM,DIC(0)="L",DLAYGO=725,DIC="^EC(725,"
40 .S DIC("DR")="1////^S X=CODE;4////^S X=CPT"
41 .D FILE^DICN
42 .I +Y>0 D
43 ..S COUNT=COUNT+1
44 ..D MES^XPDUTL(" ")
45 ..S STR=" Entry #"_+Y_" for "_$P(Y,U,2)
46 ..S STR=STR_$S(CPT'="":" [CPT: "_CPT_"]",1:"")_" ("_CODE_")"
47 ..D BMES^XPDUTL(STR_" ...successfully added.")
48 .I Y=-1 D
49 ..D MES^XPDUTL(" ")
50 ..D BMES^XPDUTL("ERROR when attempting to add "_NAME_" ("_CODE_")")
51 I $D(^EC(725,"DL",CODE)) D
52 .S LIEN=$O(^EC(725,"DL",CODE,""))
53 .D MES^XPDUTL(" ")
54 .D BMES^XPDUTL(" Your site has a local procedure (entry #"_LIEN_") in File #725")
55 .D BMES^XPDUTL(" which uses "_CODE_" as its National Number.")
56 .D BMES^XPDUTL(" Please inactivate this local procedure.")
57 .K Y
58 Q
59NEW ;national procedures to add;;descript^nation #^CPT code^beg seq^end seq
60 ;;DRIVERS REHAB EVAL^PM001^^
61 ;;DRIVERS REHAB TREATMENT^PM002^^
62 ;;RITE-SACRMNT-ORDNCE <15M^CH100^99499^
63 ;;RITE-SACRMNT-ORDNCE <30M^CH101^99499^
64 ;;RITE-SACRMNT-ORDNCE <45M^CH102^99499^
65 ;;WSHP DEVOTIONAL <12-30M^CH103^99499^
66 ;;WSHP INFORMAL >12-30M^CH104^99499^
67 ;;WSHP FORMAL <12-60M^CH105^99499^
68 ;;WSHP FULL >12-60M^CH106^99499^
69 ;;FUNERAL-MEM GRAVESIDE^CH107^99499^
70 ;;FUNERAL-MEM SERVICE ONLY^CH108^99499^
71 ;;FUNERAL-MEM SERVICE&GRAVE^CH109^99499^
72 ;;IND CARE-COUNSEL <15M^CH110^99499^
73 ;;IND CARE-COUNSEL <30M^CH111^99499^
74 ;;IND CARE-COUNSEL <45M^CH112^99499^
75 ;;IND CARE-COUNSEL <60M^CH113^99499^
76 ;;FAM CARE-COUNSEL <15M^CH114^99499^
77 ;;FAM CARE-COUNSEL <30M^CH115^99499^
78 ;;FAM CARE-COUNSEL <45M^CH116^99499^
79 ;;FAM CARE-COUNSEL <60M^CH117^99499^
80 ;;GROUP SMALL <12-30M^CH118^99499^
81 ;;GROUP INFORMAL >12-30M^CH119^99499^
82 ;;GROUP FORMAL <12-60M^CH120^99499^
83 ;;GROUP FULL >12-60M^CH121^99499^
84 ;;SPIRITUAL ASSESSMENT <15M^CH122^99499^
85 ;;SPIRITUAL ASSESSMENT <30M^CH123^99499^
86 ;;SPIRITUAL ASSESSMENT <60M^CH124^99499^
87 ;;QUIT
88NAMECHG ;* change national procedure names
89 ;
90 ; ECXX is in format:
91 ; NATIONAL NUMBER^NEW NAME
92 ;
93 N ECX,ECXX,ECDA,DA,DR,DIC,DIE,X,Y,STR
94 D MES^XPDUTL(" ")
95 D BMES^XPDUTL("Changing names in EC NATIONAL PROCEDURE File (#725)...")
96 D MES^XPDUTL(" ")
97 F ECX=1:1 S ECXX=$P($T(CHNG+ECX),";;",2) Q:ECXX="QUIT" D
98 .I $D(^EC(725,"D",$P(ECXX,U,1))) D
99 ..S ECDA=+$O(^EC(725,"D",$P(ECXX,U,1),0))
100 ..I $D(^EC(725,ECDA,0)) D
101 ...S DA=ECDA,DR=".01////^S X=$P(ECXX,U,2)",DIE="^EC(725," D ^DIE
102 ...D MES^XPDUTL(" ")
103 ...D MES^XPDUTL(" Entry #"_ECDA_" for "_$P(ECXX,U,1))
104 ...D BMES^XPDUTL(" ... field (#.01) updated to "_$P(ECXX,U,2)_".")
105 .I '$D(^EC(725,"D",$P(ECXX,U,1))) D
106 ..D MES^XPDUTL(" ")
107 ..S STR="Can't find entry for "_$P(ECXX,U,1)
108 ..D BMES^XPDUTL(STR_" ...field (#.01) not updated.")
109 Q
110 ;
111CHNG ;name changes -national code #^new procedure name
112 ;;QUIT
Note: See TracBrowser for help on using the repository browser.