ECDSSCRN ;BIR/RHK - Enter Event Code Screens ;30 Mar 95
;;2.0; EVENT CAPTURE ;;8 May 96
;Routine for entering event code screens
START ; Check for location
W @IOF
I $O(^DIC(4,"LOC",""))="" W !,"You have no locations flagged for event cature.",!! Q
UNIT ; Select unit
K DIC S ECNOPE="",DIC=724,DIC(0)="QEAMZ",DIC("A")="Select DSS Unit: ",DIC("S")="I $P(^(0),U,8)" D ^DIC K DIC G:Y<0 END
S ECU=+Y,ECUN=$P(Y,U,2) D CHECK
I $D(DUOUT)!($D(DTOUT)) G END
I ECNOPE G UNIT
CAT ; Check if unit uses categories
I $P(^ECD(ECU,0),U,11) D S ECUDIR=$S($D(DUOUT):"END",$D(ECUERR):"UNIT",1:"PROC") W @IOF G @ECUDIR
.S DIC=726
.S DIC(0)="AEQMZ"
.S DIC("S")="I '$P(^(0),U,3)!($P(^(0),U,3)>DT)"
.S DIC("A")="Select Category: "
.D ^DIC K DIC Q:$D(DUOUT)
.I Y<0 S ECUERR=1 Q
.S ECUCAT=+Y
PROC ; Set procedures
; Find highest entry number
F ECUP=0:0 S ECUP=$O(^ECD(ECU,"PRO",ECUP)) Q:+$O(^(ECUP))'>0
S ECUP=ECUP+1
I '$D(ECUCAT) S ECUCAT=""
S DIR(0)="724.011,.01",DIR("A")="Select Procedure" D ^DIR K DIR
I +Y'>0 G END
S ECUPRO=Y
I $D(^ECD(ECU,"PRO","CB",ECUCAT,ECUPRO)) D G PROC
.W !,"That procedure already exists.",!!
.S ECUPROP=$O(^ECD(ECU,"PRO","CB",ECUCAT,ECUPRO,""))
.I $P(^ECD(ECU,"PRO",ECUPROP,0),U,3),($P(^(0),U,3)<DT) D
..S Y=$P(^ECD(ECU,"PRO",ECUPROP,0),U,3) X ^DD("DD")
..W "This procedure was inactivated on ",Y,". You may use the 'Inactivate",!,"Event Code Screen option to change this date.",!!
.K ECUP
S ^ECD(ECU,"PRO",ECUP,0)=Y_"^"_ECUCAT
I '$D(^ECD(ECU,"PRO",0)) S ^ECD(ECU,"PRO",0)="^724.011AV^^"
; Set the cross references for this entry
S ^ECD(ECU,"PRO","B",Y,ECUP)=""
S ^ECD(ECU,"PRO","C",ECUCAT,ECUP)=""
K DA,ECUP,Y,X G PROC
STOP ; Stop loop and check for another category
G CAT
END ;
K DA,DIE,DIK,DR,ECNOPE,ECU,ECUCAT,ECUDIR,ECUERR,ECUN,ECUP,ECUPRO,ECUPROP,X,Y
Q
CHECK ; Check to see if active unit
I $P(^ECD(ECU,0),U,6) S ECNOPE=1
I ECNOPE W !!,"This DSS Unit has not been activated for use in Event",!,"Capture software.",!! S DIR(0)="E" D ^DIR K DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECDSSCRN 2051 printed Apr 09, 2024@21:02:58 Page 2
ECDSSCRN ;BIR/RHK - Enter Event Code Screens ;30 Mar 95
+1 ;;2.0; EVENT CAPTURE ;;8 May 96
+2 ;Routine for entering event code screens
START ; Check for location
+1 WRITE @IOF
+2 IF $ORDER(^DIC(4,"LOC",""))=""
WRITE !,"You have no locations flagged for event cature.",!!
QUIT
UNIT ; Select unit
+1 KILL DIC
SET ECNOPE=""
SET DIC=724
SET DIC(0)="QEAMZ"
SET DIC("A")="Select DSS Unit: "
SET DIC("S")="I $P(^(0),U,8)"
DO ^DIC
KILL DIC
if Y<0
GOTO END
+2 SET ECU=+Y
SET ECUN=$PIECE(Y,U,2)
DO CHECK
+3 IF $DATA(DUOUT)!($DATA(DTOUT))
GOTO END
+4 IF ECNOPE
GOTO UNIT
CAT ; Check if unit uses categories
+1 IF $PIECE(^ECD(ECU,0),U,11)
Begin DoDot:1
+2 SET DIC=726
+3 SET DIC(0)="AEQMZ"
+4 SET DIC("S")="I '$P(^(0),U,3)!($P(^(0),U,3)>DT)"
+5 SET DIC("A")="Select Category: "
+6 DO ^DIC
KILL DIC
if $DATA(DUOUT)
QUIT
+7 IF Y<0
SET ECUERR=1
QUIT
+8 SET ECUCAT=+Y
End DoDot:1
SET ECUDIR=$SELECT($DATA(DUOUT):"END",$DATA(ECUERR):"UNIT",1:"PROC")
WRITE @IOF
GOTO @ECUDIR
PROC ; Set procedures
+1 ; Find highest entry number
+2 FOR ECUP=0:0
SET ECUP=$ORDER(^ECD(ECU,"PRO",ECUP))
if +$ORDER(^(ECUP))'>0
QUIT
+3 SET ECUP=ECUP+1
+4 IF '$DATA(ECUCAT)
SET ECUCAT=""
+5 SET DIR(0)="724.011,.01"
SET DIR("A")="Select Procedure"
DO ^DIR
KILL DIR
+6 IF +Y'>0
GOTO END
+7 SET ECUPRO=Y
+8 IF $DATA(^ECD(ECU,"PRO","CB",ECUCAT,ECUPRO))
Begin DoDot:1
+9 WRITE !,"That procedure already exists.",!!
+10 SET ECUPROP=$ORDER(^ECD(ECU,"PRO","CB",ECUCAT,ECUPRO,""))
+11 IF $PIECE(^ECD(ECU,"PRO",ECUPROP,0),U,3)
IF ($PIECE(^(0),U,3)<DT)
Begin DoDot:2
+12 SET Y=$PIECE(^ECD(ECU,"PRO",ECUPROP,0),U,3)
XECUTE ^DD("DD")
+13 WRITE "This procedure was inactivated on ",Y,". You may use the 'Inactivate",!,"Event Code Screen option to change this date.",!!
End DoDot:2
+14 KILL ECUP
End DoDot:1
GOTO PROC
+15 SET ^ECD(ECU,"PRO",ECUP,0)=Y_"^"_ECUCAT
+16 IF '$DATA(^ECD(ECU,"PRO",0))
SET ^ECD(ECU,"PRO",0)="^724.011AV^^"
+17 ; Set the cross references for this entry
+18 SET ^ECD(ECU,"PRO","B",Y,ECUP)=""
+19 SET ^ECD(ECU,"PRO","C",ECUCAT,ECUP)=""
+20 KILL DA,ECUP,Y,X
GOTO PROC
STOP ; Stop loop and check for another category
+1 GOTO CAT
END ;
+1 KILL DA,DIE,DIK,DR,ECNOPE,ECU,ECUCAT,ECUDIR,ECUERR,ECUN,ECUP,ECUPRO,ECUPROP,X,Y
+2 QUIT
CHECK ; Check to see if active unit
+1 IF $PIECE(^ECD(ECU,0),U,6)
SET ECNOPE=1
+2 IF ECNOPE
WRITE !!,"This DSS Unit has not been activated for use in Event",!,"Capture software.",!!
SET DIR(0)="E"
DO ^DIR
KILL DIR
+3 QUIT
