ECSCR ;BIR/MAM,TTH,JPW-Retrieve Event Capture Location ;1 May 96
;;2.0; EVENT CAPTURE ;**1,63,72**;8 May 96
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
;If the LOC array contains only one location, set the LOC1 array.
I '$D(LOC(2)) S ECL=$P(LOC(1),"^",2),ECLOC=1,LOC1(1)=LOC(1) Q
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
I $D(LOC(2)) D LL I '$D(ECL) Q
END ;Exit routine
Q
LL ; select location
S ECLOC=0,ECWORD="create^selectable^select a"
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
S ECLOC=1 ;Specific location.
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
W @IOF,!,"Event Capture Locations: ",!
LOC S CNT=0 F I=0:0 S CNT=$O(LOC(CNT)) Q:'CNT W !,CNT_". "_$P(LOC(CNT),"^")
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
I X="" Q
I $D(LOC1(X)) W !,"This location has already been selected." G ASK
W " "_$P(LOC(X),"^") S NUM=X,LOC1(NUM)=LOC(X) S ECL="ALL"
G ASK
Q
ASK2 ;Display selection to the user.
W !,"Event Code Screen Information:"
W !,"----------------------------",!
W !,"DSS Unit : "_ECDN,!,"Category : "_ECCN,!,"Procedure: "_$$NAM^ECSCR
K Y,DIRUT
W ! S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this information correct"
D ^DIR Q:$D(DIRUT) S ECANS=+Y
Q
NAM() ;Display procedure name.
I ECP'?1.N.";".E Q "UNKNOWN"
N ECPF,ECPC
S ECPF="^"_$P(ECP,";",2)
S ECPC=$S($E($P(ECP,";",2),1)="E":1,1:3)
S ECPN=$S(ECPC=1:$P(@(ECPF_+ECP_",0)"),U,ECPC),1:$P($$CPT^ICPTCOD(+ECP),U,ECPC))
Q ECPN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECSCR 1955 printed Sep 23, 2025@19:34:55 Page 2
ECSCR ;BIR/MAM,TTH,JPW-Retrieve Event Capture Location ;1 May 96
+1 ;;2.0; EVENT CAPTURE ;**1,63,72**;8 May 96
+2 SET (ECOUT,X,CNT)=0
FOR I=0:0
SET X=$ORDER(^DIC(4,"LOC",X))
if X=""
QUIT
SET CNT=CNT+1
SET LOC(CNT)=X
SET Y=$ORDER(^DIC(4,"LOC",X,0))
SET LOC(CNT)=LOC(CNT)_"^"_Y
+3 ;If the LOC array contains only one location, set the LOC1 array.
+4 IF '$DATA(LOC(2))
SET ECL=$PIECE(LOC(1),"^",2)
SET ECLOC=1
SET LOC1(1)=LOC(1)
QUIT
+5 IF $DATA(LOC(2))
IF $DATA(ECN)
IF $DATA(ECY)
WRITE @IOF,!!,"Choose Event Capture Location for this event code screen.",!
KILL ECY,ECN
DO LOC
GOTO END
+6 IF $DATA(LOC(2))
DO LL
IF '$DATA(ECL)
QUIT
END ;Exit routine
+1 QUIT
LL ; select location
+1 SET ECLOC=0
SET ECWORD="create^selectable^select a"
+2 WRITE !!,"Do you want to "_$PIECE(ECWORD,"^")_" this Event Code Screen for ALL locations ? YES// "
READ X:DTIME
if '$TEST!(X="^")
QUIT
if X=""
SET X="Y"
SET X=$EXTRACT(X)
IF "Yy"[X
SET ECL="ALL"
QUIT
+3 ;Specific location.
SET ECLOC=1
+4 IF "YyNn"'[X
WRITE !!,"Enter <RET> if this procedure will be "_$PIECE(ECWORD,"^",2)_" from all locations,",!,"or ""NO"" to "_$PIECE(ECWORD,"^",3)_" location.",!!
GOTO LL
+5 WRITE @IOF,!,"Event Capture Locations: ",!
LOC SET CNT=0
FOR I=0:0
SET CNT=$ORDER(LOC(CNT))
if 'CNT
QUIT
WRITE !,CNT_". "_$PIECE(LOC(CNT),"^")
ASK WRITE !!,"Select Location: "
READ X:DTIME
if '$TEST!("^"[X)
QUIT
IF '$DATA(LOC(X))
WRITE !!,"Enter the number corresponding to the location you want to select.",!
GOTO ASK
+1 IF X=""
QUIT
+2 IF $DATA(LOC1(X))
WRITE !,"This location has already been selected."
GOTO ASK
+3 WRITE " "_$PIECE(LOC(X),"^")
SET NUM=X
SET LOC1(NUM)=LOC(X)
SET ECL="ALL"
+4 GOTO ASK
+5 QUIT
ASK2 ;Display selection to the user.
+1 WRITE !,"Event Code Screen Information:"
+2 WRITE !,"----------------------------",!
+3 WRITE !,"DSS Unit : "_ECDN,!,"Category : "_ECCN,!,"Procedure: "_$$NAM^ECSCR
+4 KILL Y,DIRUT
+5 WRITE !
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Is this information correct"
+6 DO ^DIR
if $DATA(DIRUT)
QUIT
SET ECANS=+Y
+7 QUIT
NAM() ;Display procedure name.
+1 IF ECP'?1.N.";".E
QUIT "UNKNOWN"
+2 NEW ECPF,ECPC
+3 SET ECPF="^"_$PIECE(ECP,";",2)
+4 SET ECPC=$SELECT($EXTRACT($PIECE(ECP,";",2),1)="E":1,1:3)
+5 SET ECPN=$SELECT(ECPC=1:$PIECE(@(ECPF_+ECP_",0)"),U,ECPC),1:$PIECE($$CPT^ICPTCOD(+ECP),U,ECPC))
+6 QUIT ECPN
