source: WorldVistAEHR/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECED1.m@ 1240

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