ECUTL2 ;ALB/JAM - Event Capture Diagnosis Code Selection ;23 Aug 2007
;;2.0;EVENT CAPTURE;**23,33,47,63,72,95,114**;8 May 96;Build 20
;
; Reference to $$SINFO^ICDEX supported by ICR #5747
; Reference to $$ICDDX^ICDEX supported by ICR5747
;
DIAG ;ask dx question (primary and multiple secondary)
;check for primary dx and display message
D PDXMSG
;ask for primary dx
D PDX I ECOUT Q
;ask for secondary dx
D SDX I ECOUT Q
I $D(DTOUT)!$D(DUOUT) W:$P(ECPCE,"~",2)'="N" !!,"Please note that this record cannot be sent to PCE without a diagnosis.",!!
Q
PDXMSG ; Check for existence of primary diagnoses and display message
N TXT,ECPDX
S (ECDX,ECDXN,ECDXO)="" K ECDXS
;Check if primary dx exist in file #721
S ECPDX=$$PDXCK(ECDFN,ECDT,ECL,EC4)
I +ECPDX W ! D
. W !?5,"WARNING: Primary Diagnoses already on File for this encounter."
. W !?5,"If changed, all procedures will be updated. ("_ECDXN_")"
. S ECDXO=ECDX
I $P(ECPDX,U,2) D
. S TXT="WARNING: Primary diagnoses already sent to PCE. If changed,"
. S TXT=TXT_" all procedures"
. W !!?5,TXT
. S TXT="associated with this encounter will be updated and resent "
. S TXT=TXT_"to PCE."
. W !?5,TXT
Q
PDXCK(ECDFN,ECDTX,ECLX,EC4X) ;Get primary dx frm file #721 for pat encounter
; Input: ECDFN = Patient ien
; ECDTX = Date/time of procedure
; ECLX = Location ien
; EC4X = Clinic ien
;
; Output: PDXF^PCEF = primary dx flag (1/0)^dx sent to PCE flag (1/0)
; ECDX = Primary diagnoses ien
; ECDXN = Primary diagnoses code
; ECDXIEN = Array of encounter IENs w primary dx
;
N PDXF,PCEF,DA,DXIEN,DXS,DXN,ECCS
S (PDXF,PCEF)=0,DA="" K ECDXIEN
I $G(ECDFN)=""!($G(ECDTX)="")!($G(ECLX)="")!($G(EC4X)="") Q PDXF_U_PCEF
I $O(^ECH("APAT",ECDFN,ECDTX,""))="" Q PDXF_U_PCEF
F S DA=$O(^ECH("APAT",ECDFN,ECDTX,DA)) Q:DA="" D
.I EC4X'=$P($G(^ECH(DA,0)),U,19) Q
.S ECDX=$P($G(^ECH(DA,"P")),U,2) I ECDX="" Q
.; Determine Active Coding System Based on Date of Interest
.S ECCS=$$SINFO^ICDEX("DIAG",ECDTX) ; Supported by ICR 5747
.; Retrieve ICD info - Supported by ICR 5747
.S ECDXN=$P($$ICDDX^ICDEX(ECDX,ECDTX,+ECCS,"I"),U,2)
.S ECDXIEN(DA)=ECDXN_U_ECDX,PDXF=1
.I $D(^ECH(DA,"SEND")),^("SEND")="" S PCEF=1
.I $D(^ECH(DA,"DX")) D
..S DXS=0 F S DXS=$O(^ECH(DA,"DX",DXS)) Q:'DXS D
...S DXIEN=$P($G(^ECH(DA,"DX",DXS,0)),U)
...; Retrieve ICD info - Supported by ICR 5747
...S DXN=$P($$ICDDX^ICDEX(DXIEN,ECDTX,+ECCS,"I"),U,2) S:DXN'="" ECDXS(DXN)=DXIEN
Q PDXF_U_PCEF
PDX ;Ask primary diagnoses code
; Variables: ECDX = Primary diagnoses ien
; ECDXN = Primary diagnoses code, default if define
; ECOUT = Error flag (1/0)
;
N DIC,X,Y,DTOUT,DUOUT,DEFX,ECODE,PROMPT,ECCS
S ECDX=$G(ECDX),ECDXN=$G(ECDXN),PROMPT="Primary ICD Code: "
S:ECDXN'="" DEFX=ECDXN
F D LEX Q:$G(ECOUT) D I $D(ECODE) Q
.I X="" W !,"This is a required response. Enter '^' to exit" Q
.S ECDXN=ECODE
.S ECCS=$$SINFO^ICDEX("DIAG",$G(ECDT)) ; Supported by ICR 5747
.S ECDX=$$ICDDX^ICDEX(ECODE,$G(ECDT),+ECCS,"E") ; Supported by ICR 5747
Q
SDX ;Ask secondary diagnoses code
; Variables: ECDX = Primary diagnoses ien, default if define
; ECDXN = Primary diagnoses code
; ECOUT = Error flag (1/0)
; ECDXS = Array with secondary diagnosis code
; subscript=dx code and set equal to dx ien
;
N Y,X,DEFX,DIC,DTOUT,DUOUT,ECODE,ECCS
S ECOUT=$G(ECOUT),PROMPT="Secondary ICD Code: "
F D LSTDXS,LEX Q:Y<0 D I ECOUT Q
.I ECODE="" Q
.I ECODE=$G(ECDXN) W " Already exist as primary dx." Q
.I $D(ECDXS(ECODE)) D DELDUP Q
.; Determine Active Coding System Based on Date of Interest
.S ECCS=$$SINFO^ICDEX("DIAG",$G(ECDT)) ; Supported by ICR 5747
.S ECDXS(ECODE)=+$$ICDDX^ICDEX(ECODE,$G(ECDT),+ECCS,"E") ; Supported by ICR 5747
Q
DELDUP ;Delete secondary diagnosis code from list
N DIR,DIRUT,DTOUT,DUOUT,DIROUT
S DIR("A")="Delete "_ECODE_" Code from List"
S DIR(0)="Y"
D ^DIR
I $D(DIRUT)!($D(DIROUT)) S ECOUT=1 Q
I Y K ECDXS(ECODE)
Q
;
LEX ;ICD code from LEX database
;K X,Y
N IMP,APP,ECX
S (ECX,X)=$G(DEFX)
;LEX DBIA1577
S IMP=$$IMPDATE^LEXU("10D"),APP=$S(ECDT<IMP:"ICD",1:"10D") ; Supported by ICR 5679
D CONFIG^LEXSET(APP,APP,$G(ECDT))
D LOOK^LEXA(ECX,APP,1,"",ECDT) ;LEX DBIA2950
S DIC="757.01",DIC(0)=$S('$L($G(X)):"A",1:"")_"EQM",DIC("A")=PROMPT
D ^DIC
I $D(DTOUT)!$D(DUOUT) S ECOUT=1 Q
I X="" Q
I Y<0 S ECOUT=1 Q
S ECODE=$G(Y(1))
Q
;
LSTDXS ;list ICD code
N DXS,ECCS
I $D(ECDXS) D
. W !?1,"Secondary ICD code entered:"
. S DXS=""
. F S DXS=$O(ECDXS(DXS)) Q:DXS="" D
. . ; Determine Active Coding System Based on Date of Interest
. . S ECCS=$$SINFO^ICDEX("DIAG",$G(ECDT)) ; Supported by ICR 5747
. . W !,?4,DXS,?15,$P($$ICDDX^ICDEX(DXS,$G(ECDT),+ECCS,"E"),"^",4) ; Supported by ICR 5747
Q
PXUPD(ECDFN,ECDT,ECL,EC4,ECDXP,ECDXX,ECXIEN) ; Update all associated
; procedures for an EC Patient encounter with the same primary and
; secondary dx codes
;
; Input: ECDFN = Patient ien
; ECDT = Date/time of procedure
; ECL = Location ien
; EC4 = Clinic ien
; ECDXP = Primary diagnoses code
; ECDXX = Array of secondary diagnoses codes
; ECXIEN = 721 ien, if define don't process
;
; Output: ECERR 0 - Process completed
;
N ECIEN,ECERR,DIE,DR,DA,DTOUT,DIROUT,ECDXIEN,ECPDX,ECDX,ECDXN,DIC,X
N ECVST,ECVAR1,VALQUIET,DXN,DXSIEN,DIK,ECDXS
S ECERR=0
I $D(ECDXP)="" Q ECERR
S ECPDX=$$PDXCK(ECDFN,ECDT,ECL,EC4)
I '$D(ECDXIEN) Q ECERR
S ECIEN="",DIE="^ECH("
F S ECIEN=$O(ECDXIEN(ECIEN)) Q:ECIEN="" D
. I $G(ECXIEN)'="",ECXIEN=ECIEN Q
. S ECNODE=$G(^ECH(ECIEN,"P")) I ECNODE="" Q
. I ECDXP'=$P(ECNODE,U,2) D
. . S DA=ECIEN,DR="20////"_ECDXP D ^DIE
. . S $P(^ECH(ECIEN,"PCE"),"~",11)=ECDXP
. ;delete all secondary diagnosis codes
. S DA(1)=ECIEN,DIK="^ECH("_DA(1)_",""DX"",",DA=0
. F S DA=$O(^ECH(ECIEN,"DX",DA)) Q:'DA D ^DIK
. I $D(^ECH(ECIEN,"DX")) K ^ECH(ECIEN,"DX")
. ;update secondary diagnosis codes on procedure
. S DXN="" F S DXN=$O(ECDXX(DXN)) Q:DXN="" D
. . S DXSIEN=$P(ECDXX(DXN),U) I DXSIEN<0 Q
. . K DIC,DD,DO S DIC(0)="L",DA(1)=ECIEN,DIC("P")=$P(^DD(721,38,0),U,2)
. . S X=DXSIEN,DIC="^ECH("_DA(1)_","_"""DX"""_"," D FILE^DICN
. ;delete visit and resend to PCE
. S ECVST=+$P($G(^ECH(ECIEN,0)),"^",21) I 'ECVST Q
. ;* Prepare all EC records with same Visit file entry to resend to PCE
. K EC2PCE S ECVAR1=$$FNDVST^ECUTL(ECVST,,.EC2PCE)
. ;- Set VALQUIET to stop Amb Care validator from broadcasting to screen
. N ECPKG,ECSOU
. S ECPKG=$O(^DIC(9.4,"B","EVENT CAPTURE",0)),ECSOU="EVENT CAPTURE DATA"
. S VALQUIET=1,ECVV=$$DELVFILE^PXAPI("ALL",ECVST,ECPKG,ECSOU)
. ;- Send to PCE task
. D PCETASK^ECPCEU(.EC2PCE) K EC2PCE
Q ECERR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECUTL2 7083 printed Oct 16, 2024@17:59:58 Page 2
ECUTL2 ;ALB/JAM - Event Capture Diagnosis Code Selection ;23 Aug 2007
+1 ;;2.0;EVENT CAPTURE;**23,33,47,63,72,95,114**;8 May 96;Build 20
+2 ;
+3 ; Reference to $$SINFO^ICDEX supported by ICR #5747
+4 ; Reference to $$ICDDX^ICDEX supported by ICR5747
+5 ;
DIAG ;ask dx question (primary and multiple secondary)
+1 ;check for primary dx and display message
+2 DO PDXMSG
+3 ;ask for primary dx
+4 DO PDX
IF ECOUT
QUIT
+5 ;ask for secondary dx
+6 DO SDX
IF ECOUT
QUIT
+7 IF $DATA(DTOUT)!$DATA(DUOUT)
if $PIECE(ECPCE,"~",2)'="N"
WRITE !!,"Please note that this record cannot be sent to PCE without a diagnosis.",!!
+8 QUIT
PDXMSG ; Check for existence of primary diagnoses and display message
+1 NEW TXT,ECPDX
+2 SET (ECDX,ECDXN,ECDXO)=""
KILL ECDXS
+3 ;Check if primary dx exist in file #721
+4 SET ECPDX=$$PDXCK(ECDFN,ECDT,ECL,EC4)
+5 IF +ECPDX
WRITE !
Begin DoDot:1
+6 WRITE !?5,"WARNING: Primary Diagnoses already on File for this encounter."
+7 WRITE !?5,"If changed, all procedures will be updated. ("_ECDXN_")"
+8 SET ECDXO=ECDX
End DoDot:1
+9 IF $PIECE(ECPDX,U,2)
Begin DoDot:1
+10 SET TXT="WARNING: Primary diagnoses already sent to PCE. If changed,"
+11 SET TXT=TXT_" all procedures"
+12 WRITE !!?5,TXT
+13 SET TXT="associated with this encounter will be updated and resent "
+14 SET TXT=TXT_"to PCE."
+15 WRITE !?5,TXT
End DoDot:1
+16 QUIT
PDXCK(ECDFN,ECDTX,ECLX,EC4X) ;Get primary dx frm file #721 for pat encounter
+1 ; Input: ECDFN = Patient ien
+2 ; ECDTX = Date/time of procedure
+3 ; ECLX = Location ien
+4 ; EC4X = Clinic ien
+5 ;
+6 ; Output: PDXF^PCEF = primary dx flag (1/0)^dx sent to PCE flag (1/0)
+7 ; ECDX = Primary diagnoses ien
+8 ; ECDXN = Primary diagnoses code
+9 ; ECDXIEN = Array of encounter IENs w primary dx
+10 ;
+11 NEW PDXF,PCEF,DA,DXIEN,DXS,DXN,ECCS
+12 SET (PDXF,PCEF)=0
SET DA=""
KILL ECDXIEN
+13 IF $GET(ECDFN)=""!($GET(ECDTX)="")!($GET(ECLX)="")!($GET(EC4X)="")
QUIT PDXF_U_PCEF
+14 IF $ORDER(^ECH("APAT",ECDFN,ECDTX,""))=""
QUIT PDXF_U_PCEF
+15 FOR
SET DA=$ORDER(^ECH("APAT",ECDFN,ECDTX,DA))
if DA=""
QUIT
Begin DoDot:1
+16 IF EC4X'=$PIECE($GET(^ECH(DA,0)),U,19)
QUIT
+17 SET ECDX=$PIECE($GET(^ECH(DA,"P")),U,2)
IF ECDX=""
QUIT
+18 ; Determine Active Coding System Based on Date of Interest
+19 ; Supported by ICR 5747
SET ECCS=$$SINFO^ICDEX("DIAG",ECDTX)
+20 ; Retrieve ICD info - Supported by ICR 5747
+21 SET ECDXN=$PIECE($$ICDDX^ICDEX(ECDX,ECDTX,+ECCS,"I"),U,2)
+22 SET ECDXIEN(DA)=ECDXN_U_ECDX
SET PDXF=1
+23 IF $DATA(^ECH(DA,"SEND"))
IF ^("SEND")=""
SET PCEF=1
+24 IF $DATA(^ECH(DA,"DX"))
Begin DoDot:2
+25 SET DXS=0
FOR
SET DXS=$ORDER(^ECH(DA,"DX",DXS))
if 'DXS
QUIT
Begin DoDot:3
+26 SET DXIEN=$PIECE($GET(^ECH(DA,"DX",DXS,0)),U)
+27 ; Retrieve ICD info - Supported by ICR 5747
+28 SET DXN=$PIECE($$ICDDX^ICDEX(DXIEN,ECDTX,+ECCS,"I"),U,2)
if DXN'=""
SET ECDXS(DXN)=DXIEN
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT PDXF_U_PCEF
PDX ;Ask primary diagnoses code
+1 ; Variables: ECDX = Primary diagnoses ien
+2 ; ECDXN = Primary diagnoses code, default if define
+3 ; ECOUT = Error flag (1/0)
+4 ;
+5 NEW DIC,X,Y,DTOUT,DUOUT,DEFX,ECODE,PROMPT,ECCS
+6 SET ECDX=$GET(ECDX)
SET ECDXN=$GET(ECDXN)
SET PROMPT="Primary ICD Code: "
+7 if ECDXN'=""
SET DEFX=ECDXN
+8 FOR
DO LEX
if $GET(ECOUT)
QUIT
Begin DoDot:1
+9 IF X=""
WRITE !,"This is a required response. Enter '^' to exit"
QUIT
+10 SET ECDXN=ECODE
+11 ; Supported by ICR 5747
SET ECCS=$$SINFO^ICDEX("DIAG",$GET(ECDT))
+12 ; Supported by ICR 5747
SET ECDX=$$ICDDX^ICDEX(ECODE,$GET(ECDT),+ECCS,"E")
End DoDot:1
IF $DATA(ECODE)
QUIT
+13 QUIT
SDX ;Ask secondary diagnoses code
+1 ; Variables: ECDX = Primary diagnoses ien, default if define
+2 ; ECDXN = Primary diagnoses code
+3 ; ECOUT = Error flag (1/0)
+4 ; ECDXS = Array with secondary diagnosis code
+5 ; subscript=dx code and set equal to dx ien
+6 ;
+7 NEW Y,X,DEFX,DIC,DTOUT,DUOUT,ECODE,ECCS
+8 SET ECOUT=$GET(ECOUT)
SET PROMPT="Secondary ICD Code: "
+9 FOR
DO LSTDXS
DO LEX
if Y<0
QUIT
Begin DoDot:1
+10 IF ECODE=""
QUIT
+11 IF ECODE=$GET(ECDXN)
WRITE " Already exist as primary dx."
QUIT
+12 IF $DATA(ECDXS(ECODE))
DO DELDUP
QUIT
+13 ; Determine Active Coding System Based on Date of Interest
+14 ; Supported by ICR 5747
SET ECCS=$$SINFO^ICDEX("DIAG",$GET(ECDT))
+15 ; Supported by ICR 5747
SET ECDXS(ECODE)=+$$ICDDX^ICDEX(ECODE,$GET(ECDT),+ECCS,"E")
End DoDot:1
IF ECOUT
QUIT
+16 QUIT
DELDUP ;Delete secondary diagnosis code from list
+1 NEW DIR,DIRUT,DTOUT,DUOUT,DIROUT
+2 SET DIR("A")="Delete "_ECODE_" Code from List"
+3 SET DIR(0)="Y"
+4 DO ^DIR
+5 IF $DATA(DIRUT)!($DATA(DIROUT))
SET ECOUT=1
QUIT
+6 IF Y
KILL ECDXS(ECODE)
+7 QUIT
+8 ;
LEX ;ICD code from LEX database
+1 ;K X,Y
+2 NEW IMP,APP,ECX
+3 SET (ECX,X)=$GET(DEFX)
+4 ;LEX DBIA1577
+5 ; Supported by ICR 5679
SET IMP=$$IMPDATE^LEXU("10D")
SET APP=$SELECT(ECDT<IMP:"ICD",1:"10D")
+6 DO CONFIG^LEXSET(APP,APP,$GET(ECDT))
+7 ;LEX DBIA2950
DO LOOK^LEXA(ECX,APP,1,"",ECDT)
+8 SET DIC="757.01"
SET DIC(0)=$SELECT('$LENGTH($GET(X)):"A",1:"")_"EQM"
SET DIC("A")=PROMPT
+9 DO ^DIC
+10 IF $DATA(DTOUT)!$DATA(DUOUT)
SET ECOUT=1
QUIT
+11 IF X=""
QUIT
+12 IF Y<0
SET ECOUT=1
QUIT
+13 SET ECODE=$GET(Y(1))
+14 QUIT
+15 ;
LSTDXS ;list ICD code
+1 NEW DXS,ECCS
+2 IF $DATA(ECDXS)
Begin DoDot:1
+3 WRITE !?1,"Secondary ICD code entered:"
+4 SET DXS=""
+5 FOR
SET DXS=$ORDER(ECDXS(DXS))
if DXS=""
QUIT
Begin DoDot:2
+6 ; Determine Active Coding System Based on Date of Interest
+7 ; Supported by ICR 5747
SET ECCS=$$SINFO^ICDEX("DIAG",$GET(ECDT))
+8 ; Supported by ICR 5747
WRITE !,?4,DXS,?15,$PIECE($$ICDDX^ICDEX(DXS,$GET(ECDT),+ECCS,"E"),"^",4)
End DoDot:2
End DoDot:1
+9 QUIT
PXUPD(ECDFN,ECDT,ECL,EC4,ECDXP,ECDXX,ECXIEN) ; Update all associated
+1 ; procedures for an EC Patient encounter with the same primary and
+2 ; secondary dx codes
+3 ;
+4 ; Input: ECDFN = Patient ien
+5 ; ECDT = Date/time of procedure
+6 ; ECL = Location ien
+7 ; EC4 = Clinic ien
+8 ; ECDXP = Primary diagnoses code
+9 ; ECDXX = Array of secondary diagnoses codes
+10 ; ECXIEN = 721 ien, if define don't process
+11 ;
+12 ; Output: ECERR 0 - Process completed
+13 ;
+14 NEW ECIEN,ECERR,DIE,DR,DA,DTOUT,DIROUT,ECDXIEN,ECPDX,ECDX,ECDXN,DIC,X
+15 NEW ECVST,ECVAR1,VALQUIET,DXN,DXSIEN,DIK,ECDXS
+16 SET ECERR=0
+17 IF $DATA(ECDXP)=""
QUIT ECERR
+18 SET ECPDX=$$PDXCK(ECDFN,ECDT,ECL,EC4)
+19 IF '$DATA(ECDXIEN)
QUIT ECERR
+20 SET ECIEN=""
SET DIE="^ECH("
+21 FOR
SET ECIEN=$ORDER(ECDXIEN(ECIEN))
if ECIEN=""
QUIT
Begin DoDot:1
+22 IF $GET(ECXIEN)'=""
IF ECXIEN=ECIEN
QUIT
+23 SET ECNODE=$GET(^ECH(ECIEN,"P"))
IF ECNODE=""
QUIT
+24 IF ECDXP'=$PIECE(ECNODE,U,2)
Begin DoDot:2
+25 SET DA=ECIEN
SET DR="20////"_ECDXP
DO ^DIE
+26 SET $PIECE(^ECH(ECIEN,"PCE"),"~",11)=ECDXP
End DoDot:2
+27 ;delete all secondary diagnosis codes
+28 SET DA(1)=ECIEN
SET DIK="^ECH("_DA(1)_",""DX"","
SET DA=0
+29 FOR
SET DA=$ORDER(^ECH(ECIEN,"DX",DA))
if 'DA
QUIT
DO ^DIK
+30 IF $DATA(^ECH(ECIEN,"DX"))
KILL ^ECH(ECIEN,"DX")
+31 ;update secondary diagnosis codes on procedure
+32 SET DXN=""
FOR
SET DXN=$ORDER(ECDXX(DXN))
if DXN=""
QUIT
Begin DoDot:2
+33 SET DXSIEN=$PIECE(ECDXX(DXN),U)
IF DXSIEN<0
QUIT
+34 KILL DIC,DD,DO
SET DIC(0)="L"
SET DA(1)=ECIEN
SET DIC("P")=$PIECE(^DD(721,38,0),U,2)
+35 SET X=DXSIEN
SET DIC="^ECH("_DA(1)_","_"""DX"""_","
DO FILE^DICN
End DoDot:2
+36 ;delete visit and resend to PCE
+37 SET ECVST=+$PIECE($GET(^ECH(ECIEN,0)),"^",21)
IF 'ECVST
QUIT
+38 ;* Prepare all EC records with same Visit file entry to resend to PCE
+39 KILL EC2PCE
SET ECVAR1=$$FNDVST^ECUTL(ECVST,,.EC2PCE)
+40 ;- Set VALQUIET to stop Amb Care validator from broadcasting to screen
+41 NEW ECPKG,ECSOU
+42 SET ECPKG=$ORDER(^DIC(9.4,"B","EVENT CAPTURE",0))
SET ECSOU="EVENT CAPTURE DATA"
+43 SET VALQUIET=1
SET ECVV=$$DELVFILE^PXAPI("ALL",ECVST,ECPKG,ECSOU)
+44 ;- Send to PCE task
+45 DO PCETASK^ECPCEU(.EC2PCE)
KILL EC2PCE
End DoDot:1
+46 QUIT ECERR
