source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECSCR.m@ 1379

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

initial load of FOIAVistA 6/30/08 version

File size: 1.9 KB
Line 
1ECSCR ;BIR/MAM,TTH,JPW-Retrieve Event Capture Location ;1 May 96
2 ;;2.0; EVENT CAPTURE ;**1,63,72**;8 May 96
3 S (ECOUT,X,CNT)=0 F I=0:0 S X=$O(^DIC(4,"LOC",X)) Q:X="" S CNT=CNT+1,LOC(CNT)=X S Y=$O(^DIC(4,"LOC",X,0)),LOC(CNT)=LOC(CNT)_"^"_Y
4 ;If the LOC array contains only one location, set the LOC1 array.
5 I '$D(LOC(2)) S ECL=$P(LOC(1),"^",2),ECLOC=1,LOC1(1)=LOC(1) Q
6 I $D(LOC(2)),$D(ECN),$D(ECY) W @IOF,!!,"Choose Event Capture Location for this event code screen.",! K ECY,ECN D LOC G END
7 I $D(LOC(2)) D LL I '$D(ECL) Q
8END ;Exit routine
9 Q
10LL ; select location
11 S ECLOC=0,ECWORD="create^selectable^select a"
12 W !!,"Do you want to "_$P(ECWORD,"^")_" this Event Code Screen for ALL locations ? YES// " R X:DTIME Q:'$T!(X="^") S:X="" X="Y" S X=$E(X) I "Yy"[X S ECL="ALL" Q
13 S ECLOC=1 ;Specific location.
14 I "YyNn"'[X W !!,"Enter <RET> if this procedure will be "_$P(ECWORD,"^",2)_" from all locations,",!,"or ""NO"" to "_$P(ECWORD,"^",3)_" location.",!! G LL
15 W @IOF,!,"Event Capture Locations: ",!
16LOC S CNT=0 F I=0:0 S CNT=$O(LOC(CNT)) Q:'CNT W !,CNT_". "_$P(LOC(CNT),"^")
17ASK W !!,"Select Location: " R X:DTIME Q:'$T!("^"[X) I '$D(LOC(X)) W !!,"Enter the number corresponding to the location you want to select.",! G ASK
18 I X="" Q
19 I $D(LOC1(X)) W !,"This location has already been selected." G ASK
20 W " "_$P(LOC(X),"^") S NUM=X,LOC1(NUM)=LOC(X) S ECL="ALL"
21 G ASK
22 Q
23ASK2 ;Display selection to the user.
24 W !,"Event Code Screen Information:"
25 W !,"----------------------------",!
26 W !,"DSS Unit : "_ECDN,!,"Category : "_ECCN,!,"Procedure: "_$$NAM^ECSCR
27 K Y,DIRUT
28 W ! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this information correct"
29 D ^DIR Q:$D(DIRUT) S ECANS=+Y
30 Q
31NAM() ;Display procedure name.
32 I ECP'?1.N.";".E Q "UNKNOWN"
33 N ECPF,ECPC
34 S ECPF="^"_$P(ECP,";",2)
35 S ECPC=$S($E($P(ECP,";",2),1)="E":1,1:3)
36 S ECPN=$S(ECPC=1:$P(@(ECPF_+ECP_",0)"),U,ECPC),1:$P($$CPT^ICPTCOD(+ECP),U,ECPC))
37 Q ECPN
Note: See TracBrowser for help on using the repository browser.