ECED1 ;BIR/MAM,JPW-Event Capture Data Entry (cont'd) ;6 Mar 96
;;2.0; EVENT CAPTURE ;**4,5,8,10,18,23,41,47,50,72**;8 May 96
CAT ;cat & set unit info
W !!,"Location: "_ECLN,!,"DSS Unit: "_ECDN,!
D CATS^ECHECK1
S NODE=$G(^ECD(ECD,0)),ECS=+$P(NODE,"^",2),ECM=+$P(NODE,"^",3),ECDDT=$P(NODE,"^",12),ECDDT=$S(ECDDT="T":"NOW",ECDDT="N":"NOW",1:"")
S ECSN=$S($P($G(^DIC(49,ECS,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN"),ECMN=$S($P($G(^ECC(723,ECM,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
S ECPCE="U~"_$S($P(NODE,"^",14)]"":$P(NODE,"^",14),1:"N")
PAT ;get pat
S (ECJLP,ECOUT)=0
K EC,^TMP("ECLKUP",$J) S CNT=0 K DIC S DIC=2,DIC(0)="QEAMZ",DIC("A")="Select Patient: " D ^DIC K DIC Q:Y<0 S ECDFN=+Y,ECPAT=$P(Y,"^",2),ECOUT=0
N ECUP S DFN=ECDFN D 2^VADPT I +VADM(6) D I $G(ECUP)="^" G PAT
. ; NOIS MWV-0603-21781: line below changed by VMP.
. W !!,"WARNING "_"[PATIENT DIED ON "_$P(VADM(6),U,2)_"] ",!!
. R "Press Return to Continue or ^ to Deselect: ",ECUP:DTIME
ASKD ;get proc date
D DATE Q:ECOUT
;
;- Determine inpatient/outpatient status
S ECPTSTAT=$$INOUTPT^ECUTL0(+$G(ECDFN),+$G(ECDT))
I ECPTSTAT="" D INOUTERR^ECUTL0 Q
;
;- Display inpatient/outpatient status message
D DSPSTAT^ECUTL0(ECPTSTAT) S ECIOFLG=1
;
PR S X=$E(ECDT,1,7)-.0001 F I=0:0 S X=$O(^ECH("ADT",ECL,ECDFN,ECD,X)) Q:X>ECDT1!('X) S ECFN=0 F I=0:0 S ECFN=$O(^ECH("ADT",ECL,ECDFN,ECD,X,ECFN)) Q:'ECFN S CNT=CNT+1,EC(CNT)=ECFN D SET
S CNT=0 I '$O(EC(0))&ECOUT=99 S ECOUT=0 Q
PROS ; display procedures
I ECOUT K ECPAT D HDR W ! G PAT
I '$D(EC(1)) S ECJLP=1 D DATE Q:ECOUT D NEW^ECED2 S CNT=0 K EC G PR
;
;- Prevents inpat/outpat status from scrolling off screen before heading
; clears screen and prints at top
I $D(EC(1)),(+$G(ECIOFLG)) D MSG1^ECMUTL1 K ECIOFLG
D HDR K ECHOICE F I=0:0 S CNT=$O(EC(CNT)) Q:'CNT!($D(ECHOICE)) S CNT1=CNT D LIST
I ECOUT K ECPAT D HDR W ! G PAT
I $D(ECHOICE),ECHOICE S EC=ECHOICE D EDIT^ECED3 S CNT=0 K EC G PR
I $D(ECHOICE),ECHOICE="N" S ECJLP=1 D DATE Q:ECOUT D NEW^ECED2 S CNT=0 K EC G PR
SELP W !!!,"Select a number to edit/delete, or enter N to create a New Procedure: " R X:DTIME I '$T!("^"[X) K ECPAT D HDR G PAT
I "Nn"[X S ECJLP=1 D DATE Q:ECOUT D NEW^ECED2 S CNT=0 K EC G PR
I '$D(EC(X)) W !!,"Enter N to create a new procedure, or the number corresponding to the",!,"procedure that you want to edit or delete. Enter ^ quit.",!!,"Press <RET> to continue " R X:DTIME S CNT=CNT1-5 G PROS
S EC=X D EDIT^ECED3 S CNT=0 K EC G PR
;
LIST ; list procedures
I $Y+8>IOSL D SEL Q:$D(ECHOICE)!(X="")
S ECDTM=$$FMTE^XLFDT($P(EC(CNT),"^",10),2)
W !!,CNT_".",?5,"Category : "_$E($P(EC(CNT),"^",2),1,23),?41,"Pr. Date: ",ECDTM,?67,$P(EC(CNT),"^",4),!,?5,"Procedure: "_$E($P(EC(CNT),"^",3),1,50)_" ("_$P(EC(CNT),"^",6)_")",?67,$E($P(EC(CNT),"^",5),1,13)
I $O(EC(CNT,"MOD",""))'="" D
. N MOD S MOD="" F S MOD=$O(EC(CNT,"MOD",MOD)) Q:MOD="" D
. . W !?6,"Modifier: "," - ",MOD," ",$E(EC(CNT,"MOD",MOD),1,55)
I $P(EC(CNT),"^",9)]"" W !?5,"Procedure Reason: "_$P(EC(CNT),"^",9)
Q
HDR ; heading
W @IOF,!,"Location: "_ECLN,?40,"Service: "_ECSN,!,"Section: "_ECMN,?40,"DSS Unit: "_ECDN I $D(ECPAT) W !,"Patient: "_ECPAT,?40,"Procedure Date: "_ECDATE
Q
SEL ; select procedure
W !!!,"Select a number to edit, enter N for a New Procedure, or press <RET> to ",!,"continue listing procedures: " R X:DTIME I '$T!(X="^") S (ECOUT,ECHOICE)=1 Q
I X="" S CNT=CNT-1 D HDR Q
I "Na"[X S ECHOICE="N" Q
I $D(EC(X)) S ECHOICE=X Q
W !!,"To create a new procedure, type N. If you would like to edit or delete",!,"one of the procedures listed, enter the corresponding number. Press <RET>",!,"to continue the list, or ^ to quit."
W !!,"Press <RET> to continue " R X:DTIME S X="",CNT=CNT-6 D HDR
Q
SET ; set EC array
N ECPXD
I '$D(^ECH(EC(CNT),0)) W !!,"Event Capture patient data missing.",!! S ECOUT=1 Q
S ECCH=$G(^ECH(EC(CNT),0)),(ECPSYN,ECPTCD)="",ECDTM=$P(ECCH,"^",3)
S ECTEMP=+$P(ECCH,"^",8),ECCN=$S($P($G(^EC(726,ECTEMP,0)),"^")]"":$P(^(0),"^"),1:"None")
S ECTEMP=$P(ECCH,"^",9),ECTEST="^"_$P(ECTEMP,";",2),ECTEMP=+ECTEMP
I $P(ECCH,"^",4)'="",$P(ECCH,"^",7)'="",$P(ECCH,"^",8)'="",$P(ECCH,"^",9)'="" D
. S ECPSY=+$O(^ECJ("AP",$P(ECCH,"^",4),$P(ECCH,"^",7),$P(ECCH,"^",8),$P(ECCH,"^",9),""))
. I ECPSY'="" S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),"^",2)
S ECCPT=$S(ECTEST["EC":$P($G(^EC(725,ECTEMP,0)),"^",5),1:ECTEMP)
S (ECPTCD,ECPXD)="" I ECCPT'="" D
. S ECPXD=$$CPT^ICPTCOD(ECCPT,ECDTM) I +ECPXD>0 S ECPTCD=$P(ECPXD,U,2)
I $D(^ECH(EC(CNT),"MOD")) D K MOD,ARR,ECMODF
. K ARR,ECMOD S ECMODF=$$MOD^ECUTL(EC(CNT),"E",.ARR) I 'ECMODF Q
. S MOD="" F S MOD=$O(ARR(MOD)) Q:MOD="" S ECMOD(MOD)=$P(ARR(MOD),U,3)
I ECTEST["EC" D G SET1
. S ECPN=$S($P($G(^EC(725,ECTEMP,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
I ECTEST["ICPT" D G SET1
. S ECPN=$S($P(ECPXD,U,3)]"":$P(ECPXD,U,3),1:"UNKNOWN")
S ECPN="UNKNOWN"
SET1 S ECPN=ECPTCD_" "_ECPN_$S(ECPSYN="":"",1:" ["_ECPSYN_"]")
S ECTEMP=+$P(ECCH,"^",12)
S ECON=$S($P($G(^ECC(723,ECTEMP,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
S ECV=$P(ECCH,"^",10),EC4=$P(ECCH,"^",19),ECID=$P(ECCH,"^",20)
S EC4N=$S($P($G(^SC(+EC4,0)),"^")]"":$P(^(0),"^"),1:"")
S ECDAT=$$GETPPRV^ECPRVMUT(EC(CNT),.ECUN) I ECDAT S ECUN="^No primary provider"
S ECUN=$P(ECUN,"^",2)
;
;- Check for and display procedure reason
I +$P(ECCH,"^",23) S ECPRS=+$P(ECCH,"^",23),ECPRSL=$P($G(^ECL(ECPRS,0)),"^"),ECPRSN=$P($G(^ECR(ECPRSL,0)),"^")
S EC(CNT)=EC(CNT)_"^"_ECCN_"^"_ECPN_"^"_$S(ECUN[",":$P(ECUN,",")_", "_$E($P(ECUN,",",2)),1:ECUN)_"^"_$E(ECON,1,15)_"^"_ECV_"^"_EC4_"^"_ECID_$S($G(ECPRSN)]"":"^"_ECPRSN,1:"")
S $P(EC(CNT),"^",10)=ECDTM
I $O(ECMOD(""))'="" D
. M EC(CNT,"MOD")=ECMOD
K ECPRS,ECPRSN,ECPRSL,ECMOD
Q
DATE ;ask date
I ECJLP,$D(ECDT),$P(ECDT,".",2)]"" Q
I ECJLP,$D(ECDT),$P(ECDT,".",2)']"" W !!,"You must enter both DATE and TIME to create a new procedure record.",!!
;
;- Prevent future dates from being entered
K %DT S %DT="EAXR",%DT("A")="Enter Date and Time of Procedure: ",%DT(0)="-NOW" S:ECDDT]"" %DT("B")=ECDDT D ^%DT K %DT I Y<0 S ECOUT=1 Q
S ECDT=+Y,ECDT1=$E(Y,1,7)+.9999,ECDATE=$$FMTE^XLFDT(ECDT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECED1 6184 printed Sep 23, 2025@19:33:24 Page 2
ECED1 ;BIR/MAM,JPW-Event Capture Data Entry (cont'd) ;6 Mar 96
+1 ;;2.0; EVENT CAPTURE ;**4,5,8,10,18,23,41,47,50,72**;8 May 96
CAT ;cat & set unit info
+1 WRITE !!,"Location: "_ECLN,!,"DSS Unit: "_ECDN,!
+2 DO CATS^ECHECK1
+3 SET NODE=$GET(^ECD(ECD,0))
SET ECS=+$PIECE(NODE,"^",2)
SET ECM=+$PIECE(NODE,"^",3)
SET ECDDT=$PIECE(NODE,"^",12)
SET ECDDT=$SELECT(ECDDT="T":"NOW",ECDDT="N":"NOW",1:"")
+4 SET ECSN=$SELECT($PIECE($GET(^DIC(49,ECS,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
SET ECMN=$SELECT($PIECE($GET(^ECC(723,ECM,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
+5 SET ECPCE="U~"_$SELECT($PIECE(NODE,"^",14)]"":$PIECE(NODE,"^",14),1:"N")
PAT ;get pat
+1 SET (ECJLP,ECOUT)=0
+2 KILL EC,^TMP("ECLKUP",$JOB)
SET CNT=0
KILL DIC
SET DIC=2
SET DIC(0)="QEAMZ"
SET DIC("A")="Select Patient: "
DO ^DIC
KILL DIC
if Y<0
QUIT
SET ECDFN=+Y
SET ECPAT=$PIECE(Y,"^",2)
SET ECOUT=0
+3 NEW ECUP
SET DFN=ECDFN
DO 2^VADPT
IF +VADM(6)
Begin DoDot:1
+4 ; NOIS MWV-0603-21781: line below changed by VMP.
+5 WRITE !!,"WARNING "_"[PATIENT DIED ON "_$PIECE(VADM(6),U,2)_"] ",!!
+6 READ "Press Return to Continue or ^ to Deselect: ",ECUP:DTIME
End DoDot:1
IF $GET(ECUP)="^"
GOTO PAT
ASKD ;get proc date
+1 DO DATE
if ECOUT
QUIT
+2 ;
+3 ;- Determine inpatient/outpatient status
+4 SET ECPTSTAT=$$INOUTPT^ECUTL0(+$GET(ECDFN),+$GET(ECDT))
+5 IF ECPTSTAT=""
DO INOUTERR^ECUTL0
QUIT
+6 ;
+7 ;- Display inpatient/outpatient status message
+8 DO DSPSTAT^ECUTL0(ECPTSTAT)
SET ECIOFLG=1
+9 ;
PR SET X=$EXTRACT(ECDT,1,7)-.0001
FOR I=0:0
SET X=$ORDER(^ECH("ADT",ECL,ECDFN,ECD,X))
if X>ECDT1!('X)
QUIT
SET ECFN=0
FOR I=0:0
SET ECFN=$ORDER(^ECH("ADT",ECL,ECDFN,ECD,X,ECFN))
if 'ECFN
QUIT
SET CNT=CNT+1
SET EC(CNT)=ECFN
DO SET
+1 SET CNT=0
IF '$ORDER(EC(0))&ECOUT=99
SET ECOUT=0
QUIT
PROS ; display procedures
+1 IF ECOUT
KILL ECPAT
DO HDR
WRITE !
GOTO PAT
+2 IF '$DATA(EC(1))
SET ECJLP=1
DO DATE
if ECOUT
QUIT
DO NEW^ECED2
SET CNT=0
KILL EC
GOTO PR
+3 ;
+4 ;- Prevents inpat/outpat status from scrolling off screen before heading
+5 ; clears screen and prints at top
+6 IF $DATA(EC(1))
IF (+$GET(ECIOFLG))
DO MSG1^ECMUTL1
KILL ECIOFLG
+7 DO HDR
KILL ECHOICE
FOR I=0:0
SET CNT=$ORDER(EC(CNT))
if 'CNT!($DATA(ECHOICE))
QUIT
SET CNT1=CNT
DO LIST
+8 IF ECOUT
KILL ECPAT
DO HDR
WRITE !
GOTO PAT
+9 IF $DATA(ECHOICE)
IF ECHOICE
SET EC=ECHOICE
DO EDIT^ECED3
SET CNT=0
KILL EC
GOTO PR
+10 IF $DATA(ECHOICE)
IF ECHOICE="N"
SET ECJLP=1
DO DATE
if ECOUT
QUIT
DO NEW^ECED2
SET CNT=0
KILL EC
GOTO PR
SELP WRITE !!!,"Select a number to edit/delete, or enter N to create a New Procedure: "
READ X:DTIME
IF '$TEST!("^"[X)
KILL ECPAT
DO HDR
GOTO PAT
+1 IF "Nn"[X
SET ECJLP=1
DO DATE
if ECOUT
QUIT
DO NEW^ECED2
SET CNT=0
KILL EC
GOTO PR
+2 IF '$DATA(EC(X))
WRITE !!,"Enter N to create a new procedure, or the number corresponding to the",!,"procedure that you want to edit or delete. Enter ^ quit.",!!,"Press <RET> to continue "
READ X:DTIME
SET CNT=CNT1-5
GOTO PROS
+3 SET EC=X
DO EDIT^ECED3
SET CNT=0
KILL EC
GOTO PR
+4 ;
LIST ; list procedures
+1 IF $Y+8>IOSL
DO SEL
if $DATA(ECHOICE)!(X="")
QUIT
+2 SET ECDTM=$$FMTE^XLFDT($PIECE(EC(CNT),"^",10),2)
+3 WRITE !!,CNT_".",?5,"Category : "_$EXTRACT($PIECE(EC(CNT),"^",2),1,23),?41,"Pr. Date: ",ECDTM,?67,$PIECE(EC(CNT),"^",4),!,?5,"Procedure: "_$EXTRACT($PIECE(EC(CNT),"^",3),1,50)_" ("_$PIECE(EC(CNT),"^",6)_")",?67,$EXTRACT($PIECE(EC(CNT),"^",5),1,
13)
+4 IF $ORDER(EC(CNT,"MOD",""))'=""
Begin DoDot:1
+5 NEW MOD
SET MOD=""
FOR
SET MOD=$ORDER(EC(CNT,"MOD",MOD))
if MOD=""
QUIT
Begin DoDot:2
+6 WRITE !?6,"Modifier: "," - ",MOD," ",$EXTRACT(EC(CNT,"MOD",MOD),1,55)
End DoDot:2
End DoDot:1
+7 IF $PIECE(EC(CNT),"^",9)]""
WRITE !?5,"Procedure Reason: "_$PIECE(EC(CNT),"^",9)
+8 QUIT
HDR ; heading
+1 WRITE @IOF,!,"Location: "_ECLN,?40,"Service: "_ECSN,!,"Section: "_ECMN,?40,"DSS Unit: "_ECDN
IF $DATA(ECPAT)
WRITE !,"Patient: "_ECPAT,?40,"Procedure Date: "_ECDATE
+2 QUIT
SEL ; select procedure
+1 WRITE !!!,"Select a number to edit, enter N for a New Procedure, or press <RET> to ",!,"continue listing procedures: "
READ X:DTIME
IF '$TEST!(X="^")
SET (ECOUT,ECHOICE)=1
QUIT
+2 IF X=""
SET CNT=CNT-1
DO HDR
QUIT
+3 IF "Na"[X
SET ECHOICE="N"
QUIT
+4 IF $DATA(EC(X))
SET ECHOICE=X
QUIT
+5 WRITE !!,"To create a new procedure, type N. If you would like to edit or delete",!,"one of the procedures listed, enter the corresponding number. Press <RET>",!,"to continue the list, or ^ to quit."
+6 WRITE !!,"Press <RET> to continue "
READ X:DTIME
SET X=""
SET CNT=CNT-6
DO HDR
+7 QUIT
SET ; set EC array
+1 NEW ECPXD
+2 IF '$DATA(^ECH(EC(CNT),0))
WRITE !!,"Event Capture patient data missing.",!!
SET ECOUT=1
QUIT
+3 SET ECCH=$GET(^ECH(EC(CNT),0))
SET (ECPSYN,ECPTCD)=""
SET ECDTM=$PIECE(ECCH,"^",3)
+4 SET ECTEMP=+$PIECE(ECCH,"^",8)
SET ECCN=$SELECT($PIECE($GET(^EC(726,ECTEMP,0)),"^")]"":$PIECE(^(0),"^"),1:"None")
+5 SET ECTEMP=$PIECE(ECCH,"^",9)
SET ECTEST="^"_$PIECE(ECTEMP,";",2)
SET ECTEMP=+ECTEMP
+6 IF $PIECE(ECCH,"^",4)'=""
IF $PIECE(ECCH,"^",7)'=""
IF $PIECE(ECCH,"^",8)'=""
IF $PIECE(ECCH,"^",9)'=""
Begin DoDot:1
+7 SET ECPSY=+$ORDER(^ECJ("AP",$PIECE(ECCH,"^",4),$PIECE(ECCH,"^",7),$PIECE(ECCH,"^",8),$PIECE(ECCH,"^",9),""))
+8 IF ECPSY'=""
SET ECPSYN=$PIECE($GET(^ECJ(ECPSY,"PRO")),"^",2)
End DoDot:1
+9 SET ECCPT=$SELECT(ECTEST["EC":$PIECE($GET(^EC(725,ECTEMP,0)),"^",5),1:ECTEMP)
+10 SET (ECPTCD,ECPXD)=""
IF ECCPT'=""
Begin DoDot:1
+11 SET ECPXD=$$CPT^ICPTCOD(ECCPT,ECDTM)
IF +ECPXD>0
SET ECPTCD=$PIECE(ECPXD,U,2)
End DoDot:1
+12 IF $DATA(^ECH(EC(CNT),"MOD"))
Begin DoDot:1
+13 KILL ARR,ECMOD
SET ECMODF=$$MOD^ECUTL(EC(CNT),"E",.ARR)
IF 'ECMODF
QUIT
+14 SET MOD=""
FOR
SET MOD=$ORDER(ARR(MOD))
if MOD=""
QUIT
SET ECMOD(MOD)=$PIECE(ARR(MOD),U,3)
End DoDot:1
KILL MOD,ARR,ECMODF
+15 IF ECTEST["EC"
Begin DoDot:1
+16 SET ECPN=$SELECT($PIECE($GET(^EC(725,ECTEMP,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
End DoDot:1
GOTO SET1
+17 IF ECTEST["ICPT"
Begin DoDot:1
+18 SET ECPN=$SELECT($PIECE(ECPXD,U,3)]"":$PIECE(ECPXD,U,3),1:"UNKNOWN")
End DoDot:1
GOTO SET1
+19 SET ECPN="UNKNOWN"
SET1 SET ECPN=ECPTCD_" "_ECPN_$SELECT(ECPSYN="":"",1:" ["_ECPSYN_"]")
+1 SET ECTEMP=+$PIECE(ECCH,"^",12)
+2 SET ECON=$SELECT($PIECE($GET(^ECC(723,ECTEMP,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
+3 SET ECV=$PIECE(ECCH,"^",10)
SET EC4=$PIECE(ECCH,"^",19)
SET ECID=$PIECE(ECCH,"^",20)
+4 SET EC4N=$SELECT($PIECE($GET(^SC(+EC4,0)),"^")]"":$PIECE(^(0),"^"),1:"")
+5 SET ECDAT=$$GETPPRV^ECPRVMUT(EC(CNT),.ECUN)
IF ECDAT
SET ECUN="^No primary provider"
+6 SET ECUN=$PIECE(ECUN,"^",2)
+7 ;
+8 ;- Check for and display procedure reason
+9 IF +$PIECE(ECCH,"^",23)
SET ECPRS=+$PIECE(ECCH,"^",23)
SET ECPRSL=$PIECE($GET(^ECL(ECPRS,0)),"^")
SET ECPRSN=$PIECE($GET(^ECR(ECPRSL,0)),"^")
+10 SET EC(CNT)=EC(CNT)_"^"_ECCN_"^"_ECPN_"^"_$SELECT(ECUN[",":$PIECE(ECUN,",")_", "_$EXTRACT($PIECE(ECUN,",",2)),1:ECUN)_"^"_$EXTRACT(ECON,1,15)_"^"_ECV_"^"_EC4_"^"_ECID_$SELECT($GET(ECPRSN)]"":"^"_ECPRSN,1:"")
+11 SET $PIECE(EC(CNT),"^",10)=ECDTM
+12 IF $ORDER(ECMOD(""))'=""
Begin DoDot:1
+13 MERGE EC(CNT,"MOD")=ECMOD
End DoDot:1
+14 KILL ECPRS,ECPRSN,ECPRSL,ECMOD
+15 QUIT
DATE ;ask date
+1 IF ECJLP
IF $DATA(ECDT)
IF $PIECE(ECDT,".",2)]""
QUIT
+2 IF ECJLP
IF $DATA(ECDT)
IF $PIECE(ECDT,".",2)']""
WRITE !!,"You must enter both DATE and TIME to create a new procedure record.",!!
+3 ;
+4 ;- Prevent future dates from being entered
+5 KILL %DT
SET %DT="EAXR"
SET %DT("A")="Enter Date and Time of Procedure: "
SET %DT(0)="-NOW"
if ECDDT]""
SET %DT("B")=ECDDT
DO ^%DT
KILL %DT
IF Y<0
SET ECOUT=1
QUIT
+6 SET ECDT=+Y
SET ECDT1=$EXTRACT(Y,1,7)+.9999
SET ECDATE=$$FMTE^XLFDT(ECDT)
+7 QUIT
