- 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 Jan 18, 2025@03:00:03 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