source: FOIAVistA/trunk/r/EVENT_CAPTURE-EC--ECT--ECX/ECUERPC.m@ 677

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

initial load of FOIAVistA 6/30/08 version
File size: 9.5 KB
Line 
1ECUERPC ;ALB/JAM;Event Capture Data Entry Broker Utilities ;Aug 16, 2000
2 ;;2.0; EVENT CAPTURE ;**25,32,33,46,47,59,72**;8 May 96
3 ;
4USRUNT(RESULTS,ECARY) ;
5 ;
6 ;This broker call returns an array of DSS units for a user & location
7 ; RPC: EC GETUSRDSSUNIT
8 ;INPUTS ECARY - Contains the following subscripted elements
9 ; 1. ECL - Location IEN (if define gives User's DSS
10 ; units for a location)
11 ; 2. ECDUZ - New Person IEN (if define gives list of
12 ; DSS Units available to user)
13 ;
14 ;OUTPUTS RESULTS - Array of DSS Units. Data pieces as follows:-
15 ; PIECE - Description
16 ; 1 IEN of file 724
17 ; 2 Name of DSS Unit
18 ; 3 Send to PCE Flag
19 ; 4 Data Entry Date/Time Default
20 N ECL,ECDUZ,CNT,STR,DPT,IEN
21 D SETENV^ECUMRPC
22 S ECL=$P(ECARY,U),ECDUZ=$P(ECARY,U,2) I ECL="",ECDUZ="" Q
23 ;S ECDUZ=$G(DUZ,U),ECL=$P(ECARY,U) I (ECDUZ="")!(ECL="") Q
24 K ^TMP($J,"ECUSRUNT") S (DPT,CNT)=0
25 I ECL'="",ECDUZ="" S ECDUZ=$G(DUZ,U) I ECDUZ="" Q
26 I $D(^XUSEC("ECALLU",ECDUZ)) S DPT="" D
27 .I ECL="" S ^TMP($J,"ECUSRUNT",CNT+1)="ALL^ALL" Q
28 .I ECL="ALL" S ECL=""
29 .F S DPT=$O(^ECD("B",DPT)) Q:DPT="" S IEN=0 D
30 ..F S IEN=$O(^ECD("B",DPT,IEN)) Q:'IEN D UNTCHK
31 E D
32 .I ECL="ALL" S ECL=""
33 .F S DPT=$O(^VA(200,ECDUZ,"EC",DPT)) Q:'DPT S IEN=DPT D UNTCHK
34 S RESULTS=$NA(^TMP($J,"ECUSRUNT"))
35 Q
36UNTCHK ;Check if DSS unit exist as event code screen and if active
37 N DSSF,DFD
38 ;I '$D(^ECJ("AP",ECL,IEN))!($P($G(^ECD(IEN,0)),U,6)) Q
39 I ECL'="",'$D(^ECJ("AP",ECL,IEN)) Q
40 I ($P($G(^ECD(IEN,0)),U,6))!('$P($G(^ECD(IEN,0)),U,8)) Q
41 S DSSF=$P(^ECD(IEN,0),"^",14) S:DSSF="" DSSF="N"
42 S DFD=$S($P(^ECD(IEN,0),"^",12)="N":"N",1:"X") ; added by VMP
43 S CNT=CNT+1,STR=IEN_"^"_$P(^ECD(IEN,0),"^")_U_DSSF_"^"_DFD
44 S ^TMP($J,"ECUSRUNT",CNT)=STR
45 Q
46CAT(RESULTS,ECARY) ;
47 ;
48 ;This broker entry point returns an array of categories for an Event
49 ;Code screen based on location and DSS unit.
50 ; RPC: EC GETECSCATS
51 ;INPUTS ECARY - Contains the following values separated by "^"
52 ; ECL - Location IEN
53 ; ECD - DSS Unit IEN
54 ; ECCSTA-Active or inactive category
55 ; A-ctive (default), I-nactive, B-oth
56 ;
57 ;OUTPUTS RESULTS - Array of categories. Data pieces as follows:-
58 ; PIECE - Description
59 ; 1 - Category IEN
60 ; 2 - Category description
61 ;
62 N ECL,ECD,ECC,CNT,DATA,ECCSTA
63 D SETENV^ECUMRPC
64 S ECL=$P(ECARY,U),ECD=$P(ECARY,U,2) I (ECL="")!(ECD="") Q
65 S ECCSTA=$P(ECARY,U,3)
66 K ^TMP($J,"ECSCATS")
67 D CATS^ECHECK1
68 M ^TMP($J,"ECSCATS")=ECC
69 S RESULTS=$NA(^TMP($J,"ECSCATS"))
70 Q
71PROC(RESULTS,ECARY) ;
72 ;
73 ;This broker entry point returns an array of procedures for an Event
74 ;Code screen (file #720.3) based on location, DSS unit, and Category
75 ; RPC: EC GETECSPROCS
76 ;INPUTS ECARY - Contains the following values separated by "^"
77 ; ECL - Location IEN
78 ; ECD - DSS Unit IEN
79 ; ECC - Category IEN
80 ; ECDT - Procedure Date
81 ;
82 ;OUTPUTS RESULTS - Array of procedures. Data pieces as follows:-
83 ; PIECE - Description
84 ; 1 - EC National Number SPACE Procedure Name SPACE
85 ; - [Synonym]
86 ; 2 - Procedure Code
87 ; 3 - CPT Code
88 ; 4 - Default volume (1 if no default volume)
89 ; 5 - Event code screen IEN
90 ;
91 N ECL,ECD,ECC,CNT,DATA,STR,ECCPT,PX
92 D SETENV^ECUMRPC
93 S ECL=$P(ECARY,U),ECD=$P(ECARY,U,2),ECC=$P(ECARY,U,3) S:ECC="" ECC=0
94 I (ECL="")!(ECD="") Q
95 S ECDT=$P(ECARY,U,4)
96 K ^TMP($J,"ECPRO")
97 D PROS^ECHECK1
98 S CNT=0 F S CNT=$O(^TMP("ECPRO",$J,CNT)) Q:'CNT D
99 .S DATA=^TMP("ECPRO",$J,CNT),PX=$P(DATA,U)
100 .S ECCPT=$S(PX["EC":$P($G(^EC(725,+PX,0)),"^",5),1:+PX)
101 .S STR=$P(DATA,U,5)_" "_$P(DATA,U,4)_" ["_$P(DATA,U,3)_"]"_U_PX
102 .S STR=STR_U_ECCPT_U_$S($P(DATA,U,6):+$P(DATA,U,6),1:1)_U_$P(DATA,U,2)
103 .S ^TMP($J,"ECPRO",CNT)=STR
104 S RESULTS=$NA(^TMP($J,"ECPRO"))
105 K ^TMP("ECPRO",$J)
106 Q
107ECPXMOD(RESULTS,ECARY) ;
108 ;
109 ;Broker call returns modifier entries for a CPT Procedure
110 ; RPC: EC GETPXMODIFIER
111 ;INPUTS ECARY - Contains the following values separated by "^"
112 ; ECCPT - CPT code ien (file #81)
113 ; ECDT - Procedure date and time (fileman format)
114 ;
115 ;OUTPUTS RESULTS - Array of procedure modifiers
116 ; 2-character modifier^modifer name^modifier ien #81.3
117 ;
118 N CNT,SUB,ECCPT,ECDT,DATA,ECMOD
119 D SETENV^ECUMRPC
120 S ECCPT=$P(ECARY,U),ECDT=$P(ECARY,U,2) I ECDT="" D NOW^%DTC S ECDT=%
121 I ECCPT="" Q
122 K ^TMP($J,"ECPXMODS") S (SUB,CNT)=0
123 S DATA=$$CODM^ICPTCOD(ECCPT,"ECMOD","",ECDT) I +DATA<0 Q
124 F S SUB=$O(ECMOD(SUB)) Q:SUB="" D
125 . S CNT=CNT+1,^TMP($J,"ECPXMODS",CNT)=SUB_U_ECMOD(SUB)
126 S RESULTS=$NA(^TMP($J,"ECPXMODS"))
127 Q
128PRVDER(RESULTS,ECARY) ;
129 ;remove this rpc before release;JAM 6/4/01
130 ;This broker entry point returns an array of valid providers
131 ; RPC: EC GETPROVIDER
132 ;INPUTS ECARY - Contains the following subscripted elements
133 ; ECDT - Procedure date
134 ;
135 ;OUTPUTS RESULTS - Array of providers. Data pieces as follows:-
136 ; PIECE - Description
137 ; IEN of file 200^Provider Name^occupation^specialty^
138 ; subspecialty
139 ;
140 N IEN,CNT,ECUTN,KEY,USR
141 D SETENV^ECUMRPC
142 S ECDT=$P($G(ECARY),U),ECDT=$S(ECDT="":DT,1:ECDT)
143 K ^TMP($J,"ECPRVDRS") S CNT=0
144 F KEY="PROVIDER" S IEN=0 D
145 .F S IEN=$O(^XUSEC(KEY,IEN)) Q:'IEN S USR=$G(^VA(200,IEN,0)) D:USR'=""
146 ..S ECUTN=$$GET^XUA4A72(IEN,ECDT) I +ECUTN'>0 Q
147 ..S CNT=CNT+1,^TMP($J,"ECPRVDRS",CNT)=IEN_U_$P(USR,U)_U_$P(ECUTN,2,4)
148 S RESULTS=$NA(^TMP($J,"ECPRVDRS"))
149 Q
150 ;
151ELIG(RESULTS,ECARY) ;
152 ;
153 ;Broker call returns a list of patient eligibilities
154 ; RPC: EC GETPATELIG
155 ;INPUTS ECARY - Contains the following subscripted elements
156 ; DFN - Patient ien (file #2)
157 ;
158 ;OUTPUTS RESULTS - Array of eligibilities
159 ; primary/secondary elig flag^elig ien^elig description
160 ;
161 N CNT,SUB,DFN,VAEL
162 D SETENV^ECUMRPC
163 S DFN=$P(ECARY,U) I DFN="" Q
164 K ^TMP($J,"ECPATELIG")
165 D ELIG^VADPT I $G(VAEL(1))="" Q
166 S ^TMP($J,"ECPATELIG",1)="1^"_VAEL(1),SUB=0,CNT=1
167 F S SUB=$O(VAEL(1,SUB)) Q:SUB="" D
168 . S CNT=CNT+1,^TMP($J,"ECPATELIG",CNT)="0^"_VAEL(1,SUB)
169 S RESULTS=$NA(^TMP($J,"ECPATELIG"))
170 Q
171PRDEFS(RESULTS,ECARY) ;
172 ;
173 ;This broker entry point returns the defaults for procedure data entry
174 ; RPC: EC GETPRODEFS
175 ;INPUTS ECARY - Contains the following values separated by "^"
176 ; ECL - Location IEN
177 ; ECD - DSS Unit IEN
178 ; ECC - Category IEN
179 ;
180 ;OUTPUTS RESULTS - Data pieces as follows:-
181 ; PIECE - Description
182 ; 1 - Associated Clinic IEN
183 ; 2 - Associated Clinic
184 ; 3 - Medical Specialty IEN
185 ; 4 - Medical Specialty
186 ;
187 N ECL,ECD,ECC,ECP,IEN,ASC,ASCNM,MEDSP,MEDSPNM,ECCH
188 D SETENV^ECUMRPC
189 S ECL=$P(ECARY,U),ECD=$P(ECARY,U,2),ECC=$P(ECARY,U,3),ECP=$P(ECARY,U,4)
190 S:ECC="" ECC=0 I (ECL="")!(ECD="") Q
191 S (ASCNM,MEDSPNM)="",ECCH=ECL_"-"_ECD_"-"_ECC_"-"_ECP
192 I '$D(^ECJ("B",ECCH)) Q
193 S IEN=$O(^ECJ("B",ECCH,0)) I IEN="" Q
194 S ASC=$P($G(^ECJ(IEN,"PRO")),U,4) I ASC D
195 .S ASCNM=$$GET1^DIQ(44,ASC,.01,"I")
196 S MEDSP=$P($G(^ECD(ECD,0)),U,3) I MEDSP D
197 .S MEDSPNM=$$GET1^DIQ(723,MEDSP,.01,"I")
198 S RESULTS=ASC_U_ASCNM_U_MEDSP_U_MEDSPNM
199 Q
200PATPROC(RESULTS,ECARY) ;
201 ;
202 ;Broker call returns the entries from EVENT CAPTURE PATIENT FILE #721
203 ; RPC: EC GETPATPROCS
204 ;INPUTS ECARY - Contains the following values separated by "^"
205 ; ECLOC - Location ien
206 ; ECPAT - Patient DFN ien
207 ; ECUNT - DSS unit ien
208 ; ECSD - Start Date
209 ; ECED - End Date
210 ;
211 ;OUTPUTS RESULTS - Array of Event Capture Patient entries contain
212 ; 721 IEN^Procedure date and time^Category^Procedure^Volume^
213 ; Provider^ordering section^associated clinic^primary diagnoses
214 ; ^Provider IEN
215 ;
216 N IEN,CNT,ECV,ECLOC,ECUNT,ECPAT,PX,NODE,DATA,PDT,PDX,PND,PDXD,CAT,ECI
217 N ORS,PRV,PRO,PROV,ECU
218 D SETENV^ECUMRPC
219 S ECV="ECLOC^ECPAT^ECUNT^ECSD^ECED"
220 D PARSE(ECV,ECARY) I (ECLOC="")!(ECPAT="")!(ECUNT="") Q
221 K ^TMP($J,"ECPATPX")
222 S ECSD=$G(ECSD,DT),ECED=$G(ECED,DT)
223 S %DT="X" F ECI="ECSD","ECED" S X=@ECI D ^%DT S @ECI=Y
224 K X,Y
225 S ECSD=$S(ECSD=-1:DT,1:ECSD)-.0001,ECED=$S(ECED=-1:DT,1:ECED)+.9999
226 Q:ECED'>ECSD S PDT=ECSD,CNT=0
227 F S PDT=$O(^ECH("ADT",ECLOC,ECPAT,ECUNT,PDT)) Q:'PDT!(PDT>ECED) D
228 . S IEN=0 F S IEN=$O(^ECH("ADT",ECLOC,ECPAT,ECUNT,PDT,IEN)) Q:'IEN D
229 . . S NODE=$G(^ECH(IEN,0)),PND=$G(^ECH(IEN,"P")),PX=$P(NODE,U,9)
230 . . Q:NODE="" S (PRV,CAT,ORS,ASC,PDXD)="",PDX=$P(PND,U,2)
231 . . I PX["EC" D
232 . . . S PRO=$G(^EC(725,$P(PX,";"),0)),PX=$P(PRO,U,2)_" "_$P(PRO,U)
233 . . E S PRO=$$CPT^ICPTCOD($P(PX,";"),PDT) S PX=$P(PRO,U,2)_" "_$P(PRO,U,3)
234 . . S:$P(NODE,U,8) CAT=$$GET1^DIQ(726,$P(NODE,U,8),.01,"I")
235 . . K PROV S ECU=$$GETPPRV^ECPRVMUT(IEN,.PROV),PRV=$S(ECU:"UNKNOWN",1:$P(PROV,"^",2)),ECU=$S('ECU:+PROV,1:"")
236 . . S:$P(NODE,U,12) ORS=$$GET1^DIQ(723,$P(NODE,U,12),.01,"I")
237 . . S:$P(NODE,U,19) ASC=$$GET1^DIQ(44,$P(NODE,U,19),.01,"I")
238 . . S:PDX PDXD=$$ICDDX^ICDCODE(PDX,PDT),PDXD=$P(PDXD,U,2)_" "_$P(PDXD,U,4)
239 . . S DATA=$P(NODE,U)_U_$$FMTE^XLFDT($P(NODE,U,3),"2F")_U_CAT_U_PX
240 . . S DATA=DATA_U_$P(NODE,U,10)_U_PRV_U_ORS_U_ASC_U_PDXD_U_ECU
241 . . S CNT=CNT+1,^TMP($J,"ECPATPX",CNT)=DATA
242 S RESULTS=$NA(^TMP($J,"ECPATPX"))
243 Q
244PARSE(ECV,ECARY) ;Parse Variable
245 N I
246 F I=1:1:$L(ECARY,U) S @$P(ECV,U,I)=$P(ECARY,U,I)
247 Q
Note: See TracBrowser for help on using the repository browser.