source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECUTL2.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.6 KB
Line 
1ECUTL2 ;ALB/JAM - Event Capture Diagnosis Code Selection ;11 Jan 2000
2 ;;2.0; EVENT CAPTURE ;**23,33,47,63,72**;8 May 96
3DIAG ;ask dx question (primary and multiple secondary)
4 ;check for primary dx and display message
5 D PDXMSG
6 ;ask for primary dx
7 D PDX I ECOUT Q
8 ;ask for secondary dx
9 D SDX I ECOUT Q
10 I $D(DTOUT)!$D(DUOUT) W:$P(ECPCE,"~",2)'="N" !!,"Please note that this record cannot be sent to PCE without a diagnosis.",!!
11 Q
12PDXMSG ; Check for existence of primary diagnoses and display message
13 N TXT,ECPDX
14 S (ECDX,ECDXN,ECDXO)="" K ECDXS
15 ;Check if primary dx exist in file #721
16 S ECPDX=$$PDXCK(ECDFN,ECDT,ECL,EC4)
17 I +ECPDX W ! D
18 . W !?5,"WARNING: Primary Diagnoses already on File for this encounter."
19 . W !?5,"If changed, all procedures will be updated. ("_ECDXN_")"
20 . S ECDXO=ECDX
21 I $P(ECPDX,U,2) D
22 . S TXT="WARNING: Primary diagnoses already sent to PCE. If changed,"
23 . S TXT=TXT_" all procedures"
24 . W !!?5,TXT
25 . S TXT="associated with this encounter will be updated and resent "
26 . S TXT=TXT_"to PCE."
27 . W !?5,TXT
28 Q
29PDXCK(ECDFN,ECDTX,ECLX,EC4X) ;Get primary dx frm file #721 for pat encounter
30 ; Input: ECDFN = Patient ien
31 ; ECDTX = Date/time of procedure
32 ; ECLX = Location ien
33 ; EC4X = Clinic ien
34 ;
35 ; Output: PDXF^PCEF = primary dx flag (1/0)^dx sent to PCE flag (1/0)
36 ; ECDX = Primary diagnoses ien
37 ; ECDXN = Primary diagnoses code
38 ; ECDXIEN = Array of encounter IENs w primary dx
39 ;
40 N PDXF,PCEF,DA,DXIEN,DXS,DXN
41 S (PDXF,PCEF)=0,DA="" K ECDXIEN
42 I $G(ECDFN)=""!($G(ECDTX)="")!($G(ECLX)="")!($G(EC4X)="") Q PDXF_U_PCEF
43 I $O(^ECH("APAT",ECDFN,ECDTX,""))="" Q PDXF_U_PCEF
44 F S DA=$O(^ECH("APAT",ECDFN,ECDTX,DA)) Q:DA="" D
45 . I EC4X'=$P($G(^ECH(DA,0)),U,19) Q
46 . S ECDX=$P($G(^ECH(DA,"P")),U,2) I ECDX="" Q
47 . S ECDXN=$P($$ICDDX^ICDCODE(ECDX,ECDTX),U,2)
48 . S ECDXIEN(DA)=ECDXN_U_ECDX,PDXF=1
49 . I $D(^ECH(DA,"SEND")),^("SEND")="" S PCEF=1
50 . I $D(^ECH(DA,"DX")) D
51 . . S DXS=0 F S DXS=$O(^ECH(DA,"DX",DXS)) Q:'DXS D
52 ...S DXIEN=$P($G(^ECH(DA,"DX",DXS,0)),U)
53 ...S DXN=$P($$ICDDX^ICDCODE(DXIEN,ECDTX),U,2) S:DXN'="" ECDXS(DXN)=DXIEN
54 Q PDXF_U_PCEF
55PDX ;Ask primary diagnoses code
56 ; Variables: ECDX = Primary diagnoses ien
57 ; ECDXN = Primary diagnoses code, default if define
58 ; ECOUT = Error flag (1/0)
59 ;
60 N DIC,X,Y,DTOUT,DUOUT,DEFX,ECODE,PROMPT
61 S ECDX=$G(ECDX),ECDXN=$G(ECDXN),PROMPT="Primary ICD-9 Code: "
62 S:ECDXN'="" DEFX=ECDXN
63 F D LEX Q:$G(ECOUT) D I $D(ECODE) Q
64 .I X="" W !,"This is a required response. Enter '^' to exit" Q
65 .S ECDXN=ECODE,ECDX=+$$ICDDX^ICDCODE(ECODE,$G(ECDT))
66 Q
67SDX ;Ask secondary diagnoses code
68 ; Variables: ECDX = Primary diagnoses ien, default if define
69 ; ECDXN = Primary diagnoses code
70 ; ECOUT = Error flag (1/0)
71 ; ECDXS = Array with secondary diagnosis code
72 ; subscript=dx code and set equal to dx ien
73 ;
74 N Y,X,DEFX,DIC,DTOUT,DUOUT,ECODE
75 S ECOUT=$G(ECOUT),PROMPT="Secondary ICD-9 Code: "
76 F D LSTDXS,LEX Q:Y<0 D I ECOUT Q
77 .I ECODE="" Q
78 .I ECODE=$G(ECDXN) W " Already exist as primary dx." Q
79 .I $D(ECDXS(ECODE)) D DELDUP Q
80 .S ECDXS(ECODE)=+$$ICDDX^ICDCODE(ECODE,$G(ECDT))
81 Q
82DELDUP ;Delete secondary diagnosis code from list
83 N DIR,DIRUT,DTOUT,DUOUT,DIROUT
84 S DIR("A")="Delete "_ECODE_" Code from List"
85 S DIR(0)="Y"
86 D ^DIR
87 I $D(DIRUT)!($D(DIROUT)) S ECOUT=1 Q
88 I Y K ECDXS(ECODE)
89 Q
90LEX ;ICD code from LEX database
91 ;K X,Y
92 S X=$G(DEFX)
93 ;LEX DBIA1577
94 D CONFIG^LEXSET("ICD",,$G(ECDT))
95 S DIC="757.01",DIC(0)=$S('$L($G(X)):"A",1:"")_"EQM",DIC("A")=PROMPT
96 D ^DIC
97 I $D(DTOUT)!$D(DUOUT) S ECOUT=1 Q
98 I X="" Q
99 I Y<0 S ECOUT=1 Q
100 S ECODE=$G(Y(1))
101 Q
102LSTDXS ;list icd9-code
103 N DXS
104 I $D(ECDXS) D
105 . W !?1,"Secondary ICD-9 code entered:"
106 . S DXS=""
107 . F S DXS=$O(ECDXS(DXS)) Q:DXS="" W !,?4,DXS,?15,$P($$ICDDX^ICDCODE(DXS,$G(ECDT)),"^",4)
108 Q
109PXUPD(ECDFN,ECDT,ECL,EC4,ECDXP,ECDXX,ECXIEN) ; Update all associated
110 ; procedures for an EC Patient encounter with the same primary and
111 ; secondary dx codes
112 ;
113 ; Input: ECDFN = Patient ien
114 ; ECDT = Date/time of procedure
115 ; ECL = Location ien
116 ; EC4 = Clinic ien
117 ; ECDXP = Primary diagnoses code
118 ; ECDXX = Array of secondary diagnoses codes
119 ; ECXIEN = 721 ien, if define don't process
120 ;
121 ; Output: ECERR 0 - Process completed
122 ;
123 N ECIEN,ECERR,DIE,DR,DA,DTOUT,DIROUT,ECDXIEN,ECPDX,ECDX,ECDXN,DIC,X
124 N ECVST,ECVAR1,VALQUIET,DXN,DXSIEN,DIK,ECDXS
125 S ECERR=0
126 I $D(ECDXP)="" Q ECERR
127 S ECPDX=$$PDXCK(ECDFN,ECDT,ECL,EC4)
128 I '$D(ECDXIEN) Q ECERR
129 S ECIEN="",DIE="^ECH("
130 F S ECIEN=$O(ECDXIEN(ECIEN)) Q:ECIEN="" D
131 . I $G(ECXIEN)'="",ECXIEN=ECIEN Q
132 . S ECNODE=$G(^ECH(ECIEN,"P")) I ECNODE="" Q
133 . I ECDXP'=$P(ECNODE,U,2) D
134 . . S DA=ECIEN,DR="20////"_ECDXP D ^DIE
135 . . S $P(^ECH(ECIEN,"PCE"),"~",11)=ECDXP
136 . ;delete all secondary diagnosis codes
137 . S DA(1)=ECIEN,DIK="^ECH("_DA(1)_",""DX"",",DA=0
138 . F S DA=$O(^ECH(ECIEN,"DX",DA)) Q:'DA D ^DIK
139 . I $D(^ECH(ECIEN,"DX")) K ^ECH(ECIEN,"DX")
140 . ;update secondary diagnosis codes on procedure
141 . S DXN="" F S DXN=$O(ECDXX(DXN)) Q:DXN="" D
142 . . S DXSIEN=$P(ECDXX(DXN),U) I DXSIEN<0 Q
143 . . K DIC,DD,DO S DIC(0)="L",DA(1)=ECIEN,DIC("P")=$P(^DD(721,38,0),U,2)
144 . . S X=DXSIEN,DIC="^ECH("_DA(1)_","_"""DX"""_"," D FILE^DICN
145 . ;delete visit and resend to PCE
146 . S ECVST=+$P($G(^ECH(ECIEN,0)),"^",21) I 'ECVST Q
147 . ;* Prepare all EC records with same Visit file entry to resend to PCE
148 . S ECVAR1=$$FNDVST^ECUTL(ECVST)
149 . ;- Set VALQUIET to stop Amb Care validator from broadcasting to screen
150 . S VALQUIET=1,ECVV=$$DELVFILE^PXAPI("ALL",ECVST)
151 Q ECERR
Note: See TracBrowser for help on using the repository browser.