ECEDU ;BIR/MAM,JPW-Enter Event Capture Data (cont'd) ;6 Mar 96
;;2.0; EVENT CAPTURE ;**10,18,23,47,63,72**;8 May 96
HDR ;hdr for filing
W @IOF,!,"ENTERING A NEW PROCEDURE FOR "_ECPAT_" ...",!!,"LOCATION: "_ECLN,!,"SERVICE: "_ECSN,!,"SECTION: "_ECMN,!,"CATEGORY: "_ECCN,!!,"PROCEDURE: "
W $S(ECCPT="":"",1:ECPTCD_" ")_$E(ECPN,1,50)
I SYN]"",SYN'["NOT DEFINED" W " ["_SYN_"]"
W " (#"_NATN_")"
Q
MSGC ;msg cat
W !!,"Please enter the number that corresponds to the "_$S(EC1:"procedure",1:"category")_" from which",!,"you would like to select a procedure. If you would like to continue",!,"with the list, press <RET>. Enter ^ to quit."
S CNT=CNT-5
Q
HDR1 ; heading
W @IOF,!,"Patient: "_ECPAT,?40,"Procedure Date: "_ECDATE,!!,"Location: "_ECLN,?40,"Service: "_ECSN,!,"Section: "_ECMN,?40,"DSS Unit: "_ECDN W:$D(ECCN) !,"Category: "_ECCN
Q
MSG W !!,"No procedures entered. No Action Taken.",!!,"Press <RET> to continue " R X:DTIME S ECOUT=1
Q
SETE ;set edit
N ECPXD
S DA=+EC(EC),EC(0)=^ECH(DA,0),ECC=+$P(EC(0),"^",8),ECCN=$S('ECC:"None",$P($G(^EC(726,ECC,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
S (ECP,ECPROF)=$P(EC(0),"^",9)
S ECPSY=+$O(^ECJ("AP",+ECL,+ECD,ECC,+ECP,""))
S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),"^",2)
S ECFILE=$S(ECPROF["EC":725,ECPROF["ICPT":81,1:"UNKNOWN")
I ECFILE="UNKNOWN" S ECPN="UNKNOWN"
S ECCPT=$S(ECP["ICPT":+ECP,1:$P($G(^EC(725,+ECP,0)),U,5))
S (ECPTCD,ECPXD)="" I ECCPT'="" D
. S ECPXD=$$CPT^ICPTCOD(ECCPT,$P(EC(0),U,3)) I +ECPXD>0 S ECPTCD=$P(ECPXD,U,2)
I ECFILE=81 S ECPN=$S($P(ECPXD,U,3)]"":$P(ECPXD,U,3),1:"UNKNOWN")
I ECFILE=725 S ECPN=$S($P($G(^EC(725,+ECP,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
HDRE ; hdr for editing
W @IOF,!,"EDITING A PROCEDURE FOR "_ECPAT_" ...",!!,"LOCATION: "_ECLN,!,"SERVICE: "_ECSN,!,"SECTION: "_ECMN,!,"CATEGORY: "_ECCN,!,"PROCEDURE: "_$S(ECCPT="":"",1:ECPTCD_" ")_ECPN_$S(ECPSYN="":"",1:" ["_ECPSYN_"]")
Q
DXEDT ;ALB/JAM - Edit Primary and multiple secondary dx codes
N PXUPD,IEN,ECPDX,ECDXS,ECDT,ECDXI
S EC4=$P($G(^ECH(ECFN,0)),"^",19),(ECDX,ECDXN)="",ECDT=ECNEWDT
S ECPDX=$$PDXCK^ECUTL2(ECDFN,ECNEWDT,ECL,EC4),IEN="" K ECDXIEN(ECFN)
;update primary diagnoses code
S ECDX=ECDX1,ECDXI=$$ICDDX^ICDCODE(ECDX1,ECNEWDT),ECDXN=$P(ECDXI,U,2)
W !,"Primary ICD-9 Code: ",ECDXN," ",$P(ECDXI,U,4)
D PDX^ECUTL2 I ECOUT=1 Q
S ECDX1=ECDX
S DA=ECFN,DR="20////"_ECDX1 D ^DIE K DIE
;check for any changes to primary dx
S ECDX1=X,IEN=""
F S IEN=$O(ECDXIEN(IEN)) Q:IEN="" I $P(ECDXIEN(IEN),U,2)'=ECDX1 D Q
.W !?5,"WARNING: More than 1 Primary diagnoses exist for this encounter. All"
.W !?14,"Procedures will be updated to have same primary & secondary dx"
; update secondary diagnosis codes
D SDX^ECUTL2 S DXS=""
K ECDXX M ECDXX=ECDXS K ECDXS
;Update all procedures for the encounter with same primary dx
S PXUPD=$$PXUPD^ECUTL2(ECDFN,ECNEWDT,ECL,EC4,ECDX1,.ECDXX)
K PXUPD,ECDXX S DA=ECFN
Q
F S DXS=$O(ECDXS(DXS)) Q:DXS="" S DXSIEN=$P(ECDXS(DXS),U) D:DXSIEN>0
. K DIC,DD,DO S DIC(0)="L",DA(1)=ECFN,DIC="^ECH("_DA(1)_","_"""DX"""_","
. S DIC("P")=$P(^DD(721,38,0),U,2),X=DXSIEN D FILE^DICN
K DXSIEN,DXS,ECDXX,DIC M ECDXX=ECDXS K ECDXS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECEDU 3184 printed Oct 16, 2024@17:58:08 Page 2
ECEDU ;BIR/MAM,JPW-Enter Event Capture Data (cont'd) ;6 Mar 96
+1 ;;2.0; EVENT CAPTURE ;**10,18,23,47,63,72**;8 May 96
HDR ;hdr for filing
+1 WRITE @IOF,!,"ENTERING A NEW PROCEDURE FOR "_ECPAT_" ...",!!,"LOCATION: "_ECLN,!,"SERVICE: "_ECSN,!,"SECTION: "_ECMN,!,"CATEGORY: "_ECCN,!!,"PROCEDURE: "
+2 WRITE $SELECT(ECCPT="":"",1:ECPTCD_" ")_$EXTRACT(ECPN,1,50)
+3 IF SYN]""
IF SYN'["NOT DEFINED"
WRITE " ["_SYN_"]"
+4 WRITE " (#"_NATN_")"
+5 QUIT
MSGC ;msg cat
+1 WRITE !!,"Please enter the number that corresponds to the "_$SELECT(EC1:"procedure",1:"category")_" from which",!,"you would like to select a procedure. If you would like to continue",!,"with the list, press <RET>. Enter ^ to quit."
+2 SET CNT=CNT-5
+3 QUIT
HDR1 ; heading
+1 WRITE @IOF,!,"Patient: "_ECPAT,?40,"Procedure Date: "_ECDATE,!!,"Location: "_ECLN,?40,"Service: "_ECSN,!,"Section: "_ECMN,?40,"DSS Unit: "_ECDN
if $DATA(ECCN)
WRITE !,"Category: "_ECCN
+2 QUIT
MSG WRITE !!,"No procedures entered. No Action Taken.",!!,"Press <RET> to continue "
READ X:DTIME
SET ECOUT=1
+1 QUIT
SETE ;set edit
+1 NEW ECPXD
+2 SET DA=+EC(EC)
SET EC(0)=^ECH(DA,0)
SET ECC=+$PIECE(EC(0),"^",8)
SET ECCN=$SELECT('ECC:"None",$PIECE($GET(^EC(726,ECC,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
+3 SET (ECP,ECPROF)=$PIECE(EC(0),"^",9)
+4 SET ECPSY=+$ORDER(^ECJ("AP",+ECL,+ECD,ECC,+ECP,""))
+5 SET ECPSYN=$PIECE($GET(^ECJ(ECPSY,"PRO")),"^",2)
+6 SET ECFILE=$SELECT(ECPROF["EC":725,ECPROF["ICPT":81,1:"UNKNOWN")
+7 IF ECFILE="UNKNOWN"
SET ECPN="UNKNOWN"
+8 SET ECCPT=$SELECT(ECP["ICPT":+ECP,1:$PIECE($GET(^EC(725,+ECP,0)),U,5))
+9 SET (ECPTCD,ECPXD)=""
IF ECCPT'=""
Begin DoDot:1
+10 SET ECPXD=$$CPT^ICPTCOD(ECCPT,$PIECE(EC(0),U,3))
IF +ECPXD>0
SET ECPTCD=$PIECE(ECPXD,U,2)
End DoDot:1
+11 IF ECFILE=81
SET ECPN=$SELECT($PIECE(ECPXD,U,3)]"":$PIECE(ECPXD,U,3),1:"UNKNOWN")
+12 IF ECFILE=725
SET ECPN=$SELECT($PIECE($GET(^EC(725,+ECP,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
HDRE ; hdr for editing
+1 WRITE @IOF,!,"EDITING A PROCEDURE FOR "_ECPAT_" ...",!!,"LOCATION: "_ECLN,!,"SERVICE: "_ECSN,!,"SECTION: "_ECMN,!,"CATEGORY: "_ECCN,!,"PROCEDURE: "_$SELECT(ECCPT="":"",1:ECPTCD_" ")_ECPN_$SELECT(ECPSYN="":"",1:" ["_ECPSYN_"]")
+2 QUIT
DXEDT ;ALB/JAM - Edit Primary and multiple secondary dx codes
+1 NEW PXUPD,IEN,ECPDX,ECDXS,ECDT,ECDXI
+2 SET EC4=$PIECE($GET(^ECH(ECFN,0)),"^",19)
SET (ECDX,ECDXN)=""
SET ECDT=ECNEWDT
+3 SET ECPDX=$$PDXCK^ECUTL2(ECDFN,ECNEWDT,ECL,EC4)
SET IEN=""
KILL ECDXIEN(ECFN)
+4 ;update primary diagnoses code
+5 SET ECDX=ECDX1
SET ECDXI=$$ICDDX^ICDCODE(ECDX1,ECNEWDT)
SET ECDXN=$PIECE(ECDXI,U,2)
+6 WRITE !,"Primary ICD-9 Code: ",ECDXN," ",$PIECE(ECDXI,U,4)
+7 DO PDX^ECUTL2
IF ECOUT=1
QUIT
+8 SET ECDX1=ECDX
+9 SET DA=ECFN
SET DR="20////"_ECDX1
DO ^DIE
KILL DIE
+10 ;check for any changes to primary dx
+11 SET ECDX1=X
SET IEN=""
+12 FOR
SET IEN=$ORDER(ECDXIEN(IEN))
if IEN=""
QUIT
IF $PIECE(ECDXIEN(IEN),U,2)'=ECDX1
Begin DoDot:1
+13 WRITE !?5,"WARNING: More than 1 Primary diagnoses exist for this encounter. All"
+14 WRITE !?14,"Procedures will be updated to have same primary & secondary dx"
End DoDot:1
QUIT
+15 ; update secondary diagnosis codes
+16 DO SDX^ECUTL2
SET DXS=""
+17 KILL ECDXX
MERGE ECDXX=ECDXS
KILL ECDXS
+18 ;Update all procedures for the encounter with same primary dx
+19 SET PXUPD=$$PXUPD^ECUTL2(ECDFN,ECNEWDT,ECL,EC4,ECDX1,.ECDXX)
+20 KILL PXUPD,ECDXX
SET DA=ECFN
+21 QUIT
+22 FOR
SET DXS=$ORDER(ECDXS(DXS))
if DXS=""
QUIT
SET DXSIEN=$PIECE(ECDXS(DXS),U)
if DXSIEN>0
Begin DoDot:1
+23 KILL DIC,DD,DO
SET DIC(0)="L"
SET DA(1)=ECFN
SET DIC="^ECH("_DA(1)_","_"""DX"""_","
+24 SET DIC("P")=$PIECE(^DD(721,38,0),U,2)
SET X=DXSIEN
DO FILE^DICN
End DoDot:1
+25 KILL DXSIEN,DXS,ECDXX,DIC
MERGE ECDXX=ECDXS
KILL ECDXS
