source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECDSS.m@ 623

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

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1ECDSS ;BIR/RHK,JPW-Enter/Edit Local Procedures ;30 Apr 96
2 ;;2.0; EVENT CAPTURE ;**4,23,30**;8 May 96
3NEWED ;
4 W @IOF,!,"Enter/Edit Local Procedures",!
5 K DIR S DIR(0)="YO",DIR("A")="Would you like to review a listing of your current local procedures",DIR("B")="NO"
6 S DIR("?")="Answer YES to print a listing of your current local procedures, answer or <RET> to continue without the listing, or ^ to exit."
7 D ^DIR K DIR I $D(DIRUT) D MSG G END
8 I Y D LIST
9ASK ;ask for procedure name
10 K LN S $P(LN,"*",65)="" W !!,?5,LN
11 W !,?5,"* You must enter an associated CPT with your local procedure",?68,"*",!,?5,"* to pass this procedural data to PCE.",?68,"*",!,?5,LN,! K LN
12 W ! K DIR,DIRUT,ECRN,ECPN,ECNA S DIR(0)="FO^3:50^K:X'?1AN.ANLP X"
13 S DIR("A")="Enter Local Procedure"
14 S DIR("?")="Enter a free text name from 3 to 50 characters" D ^DIR K DIR I Y="" G END
15 I $D(DIRUT) D MSG G END
16 W !!,"Checking current procedures...",! S ECPN=Y
17 S ECOUT=0,(ECP,ECPR)="" F S ECP=$O(^EC(725,"B",ECP)) Q:(ECP="")!(ECOUT)!(ECPR) I ECP[ECPN D QUEST Q:(ECOUT)!(ECPR)
18 G:ECOUT END
19 I ECPR S ECJLP=0 D EDIT G ASK
20 W ! K DIR,DIRUT,DTOUT,DUOUT S DIR(0)="YO",DIR("A")="Are you sure you want to add "_ECPN_" as a new local procedure",DIR("B")="YES"
21 S DIR("?")="Answer YES or <RET> to add the procedure locally, NO to enter a different procedure name, or ^ to exit"
22 D ^DIR K DIR I $D(DIRUT) D MSG G END
23 I 'Y S ECJLP=0 D MSG2 G ASK
24NUM ; set proc # code
25 W !!,"Local Procedure: ",ECPN,!
26 W !,?5,"** Please NOTE: The number code must be 5 characters in length,",!,?23,"starting with an uppercase alpha character,",!,?23,"followed by 4 alpha or numeric characters.",!
27 S DIR(0)="F^5:5^K:X'?1U.4AN X",DIR("A")="Enter Local Procedure Code Number",DIR("?")="Enter your locally defined national number for this procedure"
28 N UPY D ^DIR K DIR I $D(DIRUT) S ECJLP=1 D MSG2 G ASK
29 S UPY=$$UP^XLFSTR(Y)
30 I $D(^EC(725,"E",Y))!($D(^EC(725,"E",UPY))) D MSG1 K Y G NUM
31 I $D(^EC(725,"D",Y))!($D(^EC(725,"D",UPY))) D MSG1 K Y G NUM
32 I $D(^EC(725,"DL",Y))!($D(^EC(725,"DL",UPY))) D MSG1 K Y G NUM
33 S ECNA=Y
34FIND ;find next number
35 L +^EC(725):1
36 S ECRN=$O(^EC(725," "),-1)
37 F S ECRN=ECRN+1 Q:'$D(^EC(725,ECRN))
38 I ECRN<90001 S ECRN=90001
39 S $P(^EC(725,0),"^",3)=ECRN,$P(^EC(725,0),"^",4)=$P(^EC(725,0),"^",4)+1
40 L -^EC(725)
41 S ^EC(725,ECRN,0)=ECPN_"^"_ECNA
42INDEX ; Set file indexes
43 S DIK="^EC(725,",DA=ECRN,DIK(1)=".01" D EN^DIK K DIK
44 S DIK="^EC(725,",DA=ECRN,DIK(1)="1" D EN^DIK K DIK
45 S DIE=725,DR="4" D ^DIE K DA,DIE
46 W !,ECPN," added.",! G ASK
47END ;kill variables
48 D ^ECKILL
49 Q
50LIST ;List of local procedures
51 S ECNR=90000,(ECJLP,ECOUT)=0
52 D HDRL Q:ECOUT
53 F S ECNR=$O(^EC(725,ECNR)) Q:'ECNR!(ECOUT) I $D(^EC(725,ECNR,0)) S ECJLP=ECJLP+1 D:$Y+5>IOSL HDRL W !,$P(^(0),"^"),?45,$P(^(0),"^",2),!
54 W:'ECJLP !,?5,"**** No Local Procedures Defined ****",!
55 Q
56HDRL ;hdr for listing
57 I $Y+5>IOSL K DIR,DIRUT S DIR(0)="E" D ^DIR K DIR I $D(DIRUT) S ECOUT=1 Q
58 Q:ECOUT
59 W @IOF,!,"Listing local procedures...",!!,"Procedure Name",?40,"National #/Code",!
60 Q
61EDIT ;
62 I ECPR<90000 W !,ECPN," is a nationally defined procedure.",!,"You cannot edit this procedure.",! S ECJLP=1 D MSG Q
63 K DA,DIR,DIRUT S DA=+ECPR,EC1=$P($G(^EC(725,+ECPR,0)),"^"),DIR(0)="FO^3:50^K:X'?1AN.ANLP X",DIR("B")=EC1
64 S DIR("A")="Edit Local Procedure",DIR("?")="Edit the existing procedure name or press <RET> to quit without editing the name"
65 D ^DIR K DIR I $D(DIRUT) D MSG Q
66 I Y="" G DIE
67 I Y]"",Y'=EC1 S ECNEW=Y D SURE
68DIE ;edit nat #
69 K DA,DIE S DIE=725,DA=ECPR,DR="1;4" D ^DIE K DA,DIR,DR
70 Q
71SURE ;ask edit
72 W !!,"You want to change the procedure name ",EC1,!,"to ",Y,"."
73 K DA,DIR S DIR(0)="YO",DIR("A")="Are you sure ",DIR("?")="Answer YES to replace the procedure name, NO or ^ to quit"
74 D ^DIR I $D(DIRUT) D MSG S ECOUT=1 Q
75 I 'Y D MSG Q
76 I Y S $P(^EC(725,+ECPR,0),"^")=ECNEW K ^EC(725,"B",EC1,ECPR) K DA,DIK S DA=+ECPR,DIK="^EC(725,",DIK(1)=".01" D EN^DIK K DA,DIK W !!,"Named has been changed to ",ECNEW,".",!!
77 Q
78MSG ;message
79 W !,"No action taken.",!
80 Q
81MSG1 ;dup number msg
82 W !,Y," currently exists. The must be a unique number code.",!,"Enter a different code for this local procedure.",!
83 Q
84MSG2 ;
85 W !,"Procedure ",ECPN," was not added."
86 W:ECJLP !,"A unique number code was not entered." W !
87 Q
88QUEST ;ask if match
89 K DIR,DIRUT,DTOUT,DUOUT S DIR(0)="YO",DIR("A")="Do you want to edit "_ECP_" procedure",DIR("B")="YES"
90 S DIR("?")="Answer YES to edit this procedure, NO to continue, or ^ to exit"
91 D ^DIR K DIR I $D(DIRUT) D MSG S ECOUT=1 Q
92 I Y S ECPR="",ECPR=$O(^EC(725,"B",ECP,ECPR))
93 Q
Note: See TracBrowser for help on using the repository browser.