Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECUTL2

ECUTL2.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to $$SINFO^ICDEX supported by ICR #5747
  1. ; Reference to $$ICDDX^ICDEX supported by ICR5747
  1. ;
  1. DIAG ;ask dx question (primary and multiple secondary)
  1. ;check for primary dx and display message
  1. D PDXMSG
  1. ;ask for primary dx
  1. D PDX I ECOUT Q
  1. ;ask for secondary dx
  1. D SDX I ECOUT Q
  1. I $D(DTOUT)!$D(DUOUT) W:$P(ECPCE,"~",2)'="N" !!,"Please note that this record cannot be sent to PCE without a diagnosis.",!!
  1. Q
  1. PDXMSG ; Check for existence of primary diagnoses and display message
  1. N TXT,ECPDX
  1. S (ECDX,ECDXN,ECDXO)="" K ECDXS
  1. ;Check if primary dx exist in file #721
  1. S ECPDX=$$PDXCK(ECDFN,ECDT,ECL,EC4)
  1. I +ECPDX W ! D
  1. . W !?5,"WARNING: Primary Diagnoses already on File for this encounter."
  1. . W !?5,"If changed, all procedures will be updated. ("_ECDXN_")"
  1. . S ECDXO=ECDX
  1. I $P(ECPDX,U,2) D
  1. . S TXT="WARNING: Primary diagnoses already sent to PCE. If changed,"
  1. . S TXT=TXT_" all procedures"
  1. . W !!?5,TXT
  1. . S TXT="associated with this encounter will be updated and resent "
  1. . S TXT=TXT_"to PCE."
  1. . W !?5,TXT
  1. Q
  1. PDXCK(ECDFN,ECDTX,ECLX,EC4X) ;Get primary dx frm file #721 for pat encounter
  1. ; Input: ECDFN = Patient ien
  1. ; ECDTX = Date/time of procedure
  1. ; ECLX = Location ien
  1. ; EC4X = Clinic ien
  1. ;
  1. ; Output: PDXF^PCEF = primary dx flag (1/0)^dx sent to PCE flag (1/0)
  1. ; ECDX = Primary diagnoses ien
  1. ; ECDXN = Primary diagnoses code
  1. ; ECDXIEN = Array of encounter IENs w primary dx
  1. ;
  1. N PDXF,PCEF,DA,DXIEN,DXS,DXN,ECCS
  1. S (PDXF,PCEF)=0,DA="" K ECDXIEN
  1. I $G(ECDFN)=""!($G(ECDTX)="")!($G(ECLX)="")!($G(EC4X)="") Q PDXF_U_PCEF
  1. I $O(^ECH("APAT",ECDFN,ECDTX,""))="" Q PDXF_U_PCEF
  1. F S DA=$O(^ECH("APAT",ECDFN,ECDTX,DA)) Q:DA="" D
  1. .I EC4X'=$P($G(^ECH(DA,0)),U,19) Q
  1. .S ECDX=$P($G(^ECH(DA,"P")),U,2) I ECDX="" Q
  1. .; Determine Active Coding System Based on Date of Interest
  1. .S ECCS=$$SINFO^ICDEX("DIAG",ECDTX) ; Supported by ICR 5747
  1. .; Retrieve ICD info - Supported by ICR 5747
  1. .S ECDXN=$P($$ICDDX^ICDEX(ECDX,ECDTX,+ECCS,"I"),U,2)
  1. .S ECDXIEN(DA)=ECDXN_U_ECDX,PDXF=1
  1. .I $D(^ECH(DA,"SEND")),^("SEND")="" S PCEF=1
  1. .I $D(^ECH(DA,"DX")) D
  1. ..S DXS=0 F S DXS=$O(^ECH(DA,"DX",DXS)) Q:'DXS D
  1. ...S DXIEN=$P($G(^ECH(DA,"DX",DXS,0)),U)
  1. ...; Retrieve ICD info - Supported by ICR 5747
  1. ...S DXN=$P($$ICDDX^ICDEX(DXIEN,ECDTX,+ECCS,"I"),U,2) S:DXN'="" ECDXS(DXN)=DXIEN
  1. Q PDXF_U_PCEF
  1. PDX ;Ask primary diagnoses code
  1. ; Variables: ECDX = Primary diagnoses ien
  1. ; ECDXN = Primary diagnoses code, default if define
  1. ; ECOUT = Error flag (1/0)
  1. ;
  1. N DIC,X,Y,DTOUT,DUOUT,DEFX,ECODE,PROMPT,ECCS
  1. S ECDX=$G(ECDX),ECDXN=$G(ECDXN),PROMPT="Primary ICD Code: "
  1. S:ECDXN'="" DEFX=ECDXN
  1. F D LEX Q:$G(ECOUT) D I $D(ECODE) Q
  1. .I X="" W !,"This is a required response. Enter '^' to exit" Q
  1. .S ECDXN=ECODE
  1. .S ECCS=$$SINFO^ICDEX("DIAG",$G(ECDT)) ; Supported by ICR 5747
  1. .S ECDX=$$ICDDX^ICDEX(ECODE,$G(ECDT),+ECCS,"E") ; Supported by ICR 5747
  1. Q
  1. SDX ;Ask secondary diagnoses code
  1. ; Variables: ECDX = Primary diagnoses ien, default if define
  1. ; ECDXN = Primary diagnoses code
  1. ; ECOUT = Error flag (1/0)
  1. ; ECDXS = Array with secondary diagnosis code
  1. ; subscript=dx code and set equal to dx ien
  1. ;
  1. N Y,X,DEFX,DIC,DTOUT,DUOUT,ECODE,ECCS
  1. S ECOUT=$G(ECOUT),PROMPT="Secondary ICD Code: "
  1. F D LSTDXS,LEX Q:Y<0 D I ECOUT Q
  1. .I ECODE="" Q
  1. .I ECODE=$G(ECDXN) W " Already exist as primary dx." Q
  1. .I $D(ECDXS(ECODE)) D DELDUP Q
  1. .; Determine Active Coding System Based on Date of Interest
  1. .S ECCS=$$SINFO^ICDEX("DIAG",$G(ECDT)) ; Supported by ICR 5747
  1. .S ECDXS(ECODE)=+$$ICDDX^ICDEX(ECODE,$G(ECDT),+ECCS,"E") ; Supported by ICR 5747
  1. Q
  1. DELDUP ;Delete secondary diagnosis code from list
  1. N DIR,DIRUT,DTOUT,DUOUT,DIROUT
  1. S DIR("A")="Delete "_ECODE_" Code from List"
  1. S DIR(0)="Y"
  1. D ^DIR
  1. I $D(DIRUT)!($D(DIROUT)) S ECOUT=1 Q
  1. I Y K ECDXS(ECODE)
  1. Q
  1. ;
  1. LEX ;ICD code from LEX database
  1. ;K X,Y
  1. N IMP,APP,ECX
  1. S (ECX,X)=$G(DEFX)
  1. ;LEX DBIA1577
  1. S IMP=$$IMPDATE^LEXU("10D"),APP=$S(ECDT<IMP:"ICD",1:"10D") ; Supported by ICR 5679
  1. D CONFIG^LEXSET(APP,APP,$G(ECDT))
  1. D LOOK^LEXA(ECX,APP,1,"",ECDT) ;LEX DBIA2950
  1. S DIC="757.01",DIC(0)=$S('$L($G(X)):"A",1:"")_"EQM",DIC("A")=PROMPT
  1. D ^DIC
  1. I $D(DTOUT)!$D(DUOUT) S ECOUT=1 Q
  1. I X="" Q
  1. I Y<0 S ECOUT=1 Q
  1. S ECODE=$G(Y(1))
  1. Q
  1. ;
  1. LSTDXS ;list ICD code
  1. N DXS,ECCS
  1. I $D(ECDXS) D
  1. . W !?1,"Secondary ICD code entered:"
  1. . S DXS=""
  1. . F S DXS=$O(ECDXS(DXS)) Q:DXS="" D
  1. . . ; Determine Active Coding System Based on Date of Interest
  1. . . S ECCS=$$SINFO^ICDEX("DIAG",$G(ECDT)) ; Supported by ICR 5747
  1. . . W !,?4,DXS,?15,$P($$ICDDX^ICDEX(DXS,$G(ECDT),+ECCS,"E"),"^",4) ; Supported by ICR 5747
  1. Q
  1. PXUPD(ECDFN,ECDT,ECL,EC4,ECDXP,ECDXX,ECXIEN) ; Update all associated
  1. ; procedures for an EC Patient encounter with the same primary and
  1. ; secondary dx codes
  1. ;
  1. ; Input: ECDFN = Patient ien
  1. ; ECDT = Date/time of procedure
  1. ; ECL = Location ien
  1. ; EC4 = Clinic ien
  1. ; ECDXP = Primary diagnoses code
  1. ; ECDXX = Array of secondary diagnoses codes
  1. ; ECXIEN = 721 ien, if define don't process
  1. ;
  1. ; Output: ECERR 0 - Process completed
  1. ;
  1. N ECIEN,ECERR,DIE,DR,DA,DTOUT,DIROUT,ECDXIEN,ECPDX,ECDX,ECDXN,DIC,X
  1. N ECVST,ECVAR1,VALQUIET,DXN,DXSIEN,DIK,ECDXS
  1. S ECERR=0
  1. I $D(ECDXP)="" Q ECERR
  1. S ECPDX=$$PDXCK(ECDFN,ECDT,ECL,EC4)
  1. I '$D(ECDXIEN) Q ECERR
  1. S ECIEN="",DIE="^ECH("
  1. F S ECIEN=$O(ECDXIEN(ECIEN)) Q:ECIEN="" D
  1. . I $G(ECXIEN)'="",ECXIEN=ECIEN Q
  1. . S ECNODE=$G(^ECH(ECIEN,"P")) I ECNODE="" Q
  1. . I ECDXP'=$P(ECNODE,U,2) D
  1. . . S DA=ECIEN,DR="20////"_ECDXP D ^DIE
  1. . . S $P(^ECH(ECIEN,"PCE"),"~",11)=ECDXP
  1. . ;delete all secondary diagnosis codes
  1. . S DA(1)=ECIEN,DIK="^ECH("_DA(1)_",""DX"",",DA=0
  1. . F S DA=$O(^ECH(ECIEN,"DX",DA)) Q:'DA D ^DIK
  1. . I $D(^ECH(ECIEN,"DX")) K ^ECH(ECIEN,"DX")
  1. . ;update secondary diagnosis codes on procedure
  1. . S DXN="" F S DXN=$O(ECDXX(DXN)) Q:DXN="" D
  1. . . S DXSIEN=$P(ECDXX(DXN),U) I DXSIEN<0 Q
  1. . . K DIC,DD,DO S DIC(0)="L",DA(1)=ECIEN,DIC("P")=$P(^DD(721,38,0),U,2)
  1. . . S X=DXSIEN,DIC="^ECH("_DA(1)_","_"""DX"""_"," D FILE^DICN
  1. . ;delete visit and resend to PCE
  1. . S ECVST=+$P($G(^ECH(ECIEN,0)),"^",21) I 'ECVST Q
  1. . ;* Prepare all EC records with same Visit file entry to resend to PCE
  1. . K EC2PCE S ECVAR1=$$FNDVST^ECUTL(ECVST,,.EC2PCE)
  1. . ;- Set VALQUIET to stop Amb Care validator from broadcasting to screen
  1. . N ECPKG,ECSOU
  1. . S ECPKG=$O(^DIC(9.4,"B","EVENT CAPTURE",0)),ECSOU="EVENT CAPTURE DATA"
  1. . S VALQUIET=1,ECVV=$$DELVFILE^PXAPI("ALL",ECVST,ECPKG,ECSOU)
  1. . ;- Send to PCE task
  1. . D PCETASK^ECPCEU(.EC2PCE) K EC2PCE
  1. Q ECERR