Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECSCR

ECSCR.m

Go to the documentation of this file.
  1. ECSCR ;BIR/MAM,TTH,JPW-Retrieve Event Capture Location ;1 May 96
  1. ;;2.0; EVENT CAPTURE ;**1,63,72**;8 May 96
  1. 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
  1. ;If the LOC array contains only one location, set the LOC1 array.
  1. I '$D(LOC(2)) S ECL=$P(LOC(1),"^",2),ECLOC=1,LOC1(1)=LOC(1) Q
  1. 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
  1. I $D(LOC(2)) D LL I '$D(ECL) Q
  1. END ;Exit routine
  1. Q
  1. LL ; select location
  1. S ECLOC=0,ECWORD="create^selectable^select a"
  1. 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
  1. S ECLOC=1 ;Specific location.
  1. 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
  1. W @IOF,!,"Event Capture Locations: ",!
  1. LOC S CNT=0 F I=0:0 S CNT=$O(LOC(CNT)) Q:'CNT W !,CNT_". "_$P(LOC(CNT),"^")
  1. ASK 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
  1. I X="" Q
  1. I $D(LOC1(X)) W !,"This location has already been selected." G ASK
  1. W " "_$P(LOC(X),"^") S NUM=X,LOC1(NUM)=LOC(X) S ECL="ALL"
  1. G ASK
  1. Q
  1. ASK2 ;Display selection to the user.
  1. W !,"Event Code Screen Information:"
  1. W !,"----------------------------",!
  1. W !,"DSS Unit : "_ECDN,!,"Category : "_ECCN,!,"Procedure: "_$$NAM^ECSCR
  1. K Y,DIRUT
  1. W ! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this information correct"
  1. D ^DIR Q:$D(DIRUT) S ECANS=+Y
  1. Q
  1. NAM() ;Display procedure name.
  1. I ECP'?1.N.";".E Q "UNKNOWN"
  1. N ECPF,ECPC
  1. S ECPF="^"_$P(ECP,";",2)
  1. S ECPC=$S($E($P(ECP,";",2),1)="E":1,1:3)
  1. S ECPN=$S(ECPC=1:$P(@(ECPF_+ECP_",0)"),U,ECPC),1:$P($$CPT^ICPTCOD(+ECP),U,ECPC))
  1. Q ECPN