source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCAPES.m@ 1006

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

initial load of WorldVistAEHR

File size: 9.3 KB
Line 
1LRCAPES ;DALOI/FHS/KLL -MANUAL PCE CPT WORKLOAD CAPTURE ;07/30/04
2 ;;5.2;LAB SERVICE;**274,259,349,308**;Sep 27, 1994
3 ;Reference to $$GET^XUA4A72 - Supported by DBIA #1625
4EN ;
5 D EN^LRCAPES1
6 Q
7EX1 ;Parse the read entry
8 N LRXY,LRACTV,LRXY1,LRXY2,LRD2,LRNR,LRWL2,LRINA2,LRREL2,LRQ
9 Q:'$L($G(LRX))
10 ;Edit on 5-digit code entry
11 I LRX?5N,'$D(^TMP("LR",$J,"AK",LRX))#2 D Q
12 .S LRXY=$$CPT^ICPTCOD(LRX,DT)
13 .D CHKCPT^LRCAPES1
14 .;Don't pass to PCE if CPT is missing or inactive in #81 or #64
15 .Q:'$P(LRXY,U,7)!(LRNR)
16 .;If CPT is inactive in #64 and another active CPT exists, replace
17 .; the inactive with the active CPT
18 .I LRACTV D Q
19 ..S LRXY=$$CPT^ICPTCOD(LRXY2,DT)
20 ..S LRCNT=+$G(LRCNT)+1
21 ..S ^TMP("LR",$J,"LRLST",LRCNT)=$P(LRXY,U)_U_LRWL2_U_$P(LRXY,U,3)_U
22 ..S LRRF64=$S($G(LRRF64):LRRF64_LRXY1_"\"_LRXY2_",",1:LRXY1_"\"_LRXY2_",")
23 ..;If CPT passes edits, continue
24 .S LRCNT=+$G(LRCNT)+1
25 .S ^TMP("LR",$J,"LRLST",LRCNT)=$P(LRXY,U)_"^^"_$P(LRXY,U,3)_U
26 ;Edit on ES Display Order # entry
27 S LRQ="^TMP(""LR"","_$J_",""AK"","_LRX_")"
28 S LRQ=$Q(@LRQ)
29 S LRXY=$$CPT^ICPTCOD($QS(LRQ,6),DT)
30 D CHKCPT^LRCAPES1
31 Q:'$P(LRXY,U,7)!(LRNR)
32 ;If CPT is inactive in #64 and another active CPT exists, replace
33 ; the inactive with the active CPT
34 I LRACTV D Q
35 .S LRXY=$$CPT^ICPTCOD(LRXY2,DT)
36 .S LRCNT=+$G(LRCNT)+1
37 .S ^TMP("LR",$J,"LRLST",LRCNT)=$P(LRXY,U)_U_LRWL2_U_$P(LRXY,U,3)_U
38 .S LRRF64=$S($G(LRRF64):LRRF64_LRXY1_"\"_LRXY2_",",1:LRXY1_"\"_LRXY2_",")
39 .;I CPT passes edits, continue
40 S LRCNT=+$G(LRCNT)+1
41 S ^TMP("LR",$J,"LRLST",LRCNT)=$QS(LRQ,6)_U_@LRQ
42 Q
43END1 ;
44 D END S LREND=1
45 Q
46END ;
47 I $G(LRAA),$G(LRAD),$G(LRAN) L -^LRO(68,LRAA,1,LRAD,1,LRAN)
48 K:'$G(LRESCPT) ^TMP("LR",$J,"AK")
49 I $G(LRDEBUG) W !,"END ",! Q
50 Q
51WLN ;Interactive entry point
52 D KVA^VADPT
53 K DIC,DIR
54 K LREND,LRUID,DIC,DIR,LRVBY
55 K ^TMP("LR",$J,"LRLST")
56 K LRAA,LRACC,LRAD,LRAN,LRDFN,LRDPF,LRIDT
57 K LRRB,LRSS,LRTIME,LRTREA,LRUID,LRWRD,PNM,SEX,SSN,AGE
58 S (LRAA,LRACC,LRAD,LRNOP,LRAN,LREND)=0,LRVBY=1,LRUID=""
59 S:'$G(LRPRO) LRPRO=DUZ
60 I '$G(LRESCPT) S LRVBY=$$SELBY^LRWU4("Select Accession By")
61 D:LRVBY=1 ^LRVERA D:LRVBY=2 UID^LRVERA
62 I 'LRVBY!(LRAA<1) D END S LREND=1 Q
63 S LRDFN=+$$GET1^DIQ(68.02,+$G(LRAN)_","_+$G(LRAD)_","_+$G(LRAA)_",",.01)
64 I 'LRDFN D END S LRNOP=1 D Q
65 . W !?5,"This accession is corrupt",!
66LCK ;
67 L +^LRO(68,LRAA,1,LRAD,1,LRAN):10 I '$T D Q
68 . W !?5,"Someone else is editing this accession",!
69 . S LRNOP=1
70 D PT^LRX
71 S LRUID=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",16)
72 S LRLLOCX=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",6)
73 S LRSPECID="Acc #: "_$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",15,"E")
74 S:$L($G(LRUID)) LRSPECID=LRSPECID_" UID: "_LRUID
75 S LREDT=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",9,"I")
76 I LREDT'?7N.E D Q
77 . W !?5,"This accession does not have a Collection Date/Time",!
78 . W !?10,"CAN NOT PROCEED",!
79 . S LRNOP="6^Not Accessioned"
80 I '$G(LRIDT) S LRIDT=+$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",13.5,"I")
81 S LRCDT="Collection Date: "_$$FMTE^XLFDT(LREDT,1)
82 I '$L($G(LRSS)) S LRSS=$$GET1^DIQ(68,LRAA_",",.02,"I")
83 S LRDSSLOC=+$$GET1^DIQ(68,LRAA_",",.8,"I")
84 S LRDSSLOC=$S($G(LRDSSLOC):LRDSSLOC,1:LRDLOC)
85 D DEM^LRCAPES1
86PRO ;Get provider,patient/location information
87 S LREND=0
88 D
89 . N LRPRONM,DIR,DIRUT,DUOUT,X,Y
90 . S LRPRONM=$$GET1^DIQ(200,+$G(LRPRO),.01,"I")
91 . I $L(LRPRONM),$D(^VA(200,"AK.PROVIDER",LRPRONM,+$G(LRPRO)))#2,$$GET^XUA4A72(+$G(LRPRO),DT)>0 S DIR("B")=LRPRONM
92 . ;S DIR("A")="Releasing Pathologist"
93 . S DIR("A")="Provider"
94 . S LRPRO=0,DIR(0)="PO^200:ENMZ"
95 . S DIR("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U),+Y)),$$GET^XUA4A72(+Y,DT)>0"
96 . D ^DIR
97 . I Y>1 S LRPRO=+Y
98 I '$G(LRPRO) D D END1 Q
99 . W !?5,"No Active Provider Selected",!
100 . S LRNOP=1
101 I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))#2 D D END1 G WLN
102 . W !?5,"The accession is corrupt - missing zero node",!
103 . S LRNOP="7^Corrupt Accession"
104LOC ;Reporting Location
105 S LRNODE0=^LRO(68,LRAA,1,LRAD,1,LRAN,0)
106 S LRNOP=0
107 S (LRLLOCX,LRLLOC)=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",6)
108 I $L(LRLLOC) S LRLLOC=+$$FIND1^DIC(44,"","OM",LRLLOC)
109ASKLOC ;Check to see if outpatient location
110 I '$D(^SC(+$G(LRLLOC),0))#2 D
111 . N DIR,X,Y
112 . S LRLLOC=""
113 . S DIR(0)="PO^44:AEZNMO",DIR("A")=" Ordering Location "
114 . D ^DIR
115 . I +Y<1 Q
116 . S LRLLOC=+Y
117 I '$G(LRLLOC) D END1 Q
118 S LRDSSID=+$$GET1^DIQ(44,+LRLLOC,8,"I") ;I 'LRDSSID S LRNOP="2^No Stop Code Number" Q
119 S LRNINS=$$GET1^DIQ(44,+LRLLOC,3,"I")
120 S LRNINS=$S(LRNINS:LRNINS,1:DUZ(2))
121 Q
122ES() ;Entry point for front end application.
123 N DFN,LRESCPT,LRDFN,LRLLOC,LRLLOCX,LRNINS,LRTST,LRENCDT,LRDUZ
124 K LRES,LRESCPT
125 S LRES=1
126ASK ; Option entry point - Check and setup PCE reporting variables
127 D EN^LRCAPES1
128 N X,Y,T1
129 S LREND=0
130 D ^LRPARAM Q:$G(LREND)
131 K ^TMP("LRPXAPI",$J),^TMP("LR",$J,"LRLST")
132 S ^TMP("LR",$J,"LRLST")=$$FMADD^XLFDT(DT,2)_U_DT_U_"LAB ES CPT"
133 S:'$G(LRPKG) LRPKG=$O(^DIC(9.4,"B","LR",0))
134 S:'$G(LRPKG) LRPKG=$O(^DIC(9.4,"B","LAB SERVICE",0))
135PKG ;Check to see if Lab Package is installed
136 I '$G(LRPKG) D D WKL Q
137 . W !?5,"LAB SERVICE PACKAGE is not loaded",!
138PCE ;Check to see if PCE is turned on
139 S X="PXAI" X ^%ZOSF("TEST") I '$T D:'$G(LRES) D WKL Q
140 . W !?5,"PCE Is not installed",!
141 S LRPCEON=$$PKGON^VSIT("PX")
142 I '$G(LRES),'LRPCEON D D WKL Q
143 . W !?5,"PCE is not turned on",!
144 S LRDLOC=+$$GET1^DIQ(69.9,"1,",.8,"I")
145OOS ;Check to see if the LRDLOC is an OOS location
146 I $G(LRES),$P($G(^SC(LRDLOC,0)),U)'["LAB DIV " D D WKL Q
147 . W !?5,"DEFAULT LAB OOS LOCATION is not defined correctly",!
148 S LRESCPT=1
149 D:'$G(^TMP("LR",$J,"AK",0,1))'=DUZ_U_DT EN
150 I $G(LRES) Q $G(LRESCPT)
151LOOP ;
152 Q:$G(LREND)
153 F D WLN Q:$G(LREND) I '$G(LRNOP) D CPTEN Q:$G(LREND)
154 D CLEAN Q
155CPTEN ;Entry point from CPT API call
156WKL S (LRNOP,LREND)=0 D READ^LRCAPES1
157 D DIS^LRCAPES1
158 I '$O(^TMP("LR",$J,"LRLST",0)) D END Q
159LOAD ;Setup ^TMP("LRPXAPI" to load CPT workload
160 K LRXCPT,LRXTST,^TMP("LRPXAPI",$J)
161 S LRDUZ=LRPRO
162 I '$G(LRESCPT) S LRNOP="3^PCE Workload Capture Not Setup"
163 I $G(LRNOP) D D SENDWKL Q
164 . I '$D(LRQUIET) W !,$$CJ^XLFSTR("PCE Wkld Abort "_$P(LRNOP,U,2),IOM)
165 I $G(LRESCPT),'$G(LRNOP) D
166 . N AFTER812,D,D0,DDER,DI,DIC,DIG,DIH,DISL,DIV
167 . N I,LRACC,LRCNT,LRI,LRPCEN,PXALOOK,PXASUB,PXJ,PXJJ,LRCCT
168 . N SDT1,SPEL,SUBL,TYPEI,X,XPARSYS
169 . S LRTST=0
170 . F S LRTST=$O(^TMP("LR",$J,"LRLST",LRTST)) Q:LRTST<1 D
171 . . S (LRNLTN,CPT)=+$G(^TMP("LR",$J,"LRLST",LRTST)),LRTSTP=$P(^(LRTST),U,2,99)
172 . . D SET^LRCAPPH1
173 . D ADDPREV
174SENDWKL ; Store LMIP workload
175 D SEND^LRCAPES1
176 L -^LRO(68,LRAA,1,LRAD,1,LRAN)
177 S LRNOP=0
178 Q
179ADDPREV ;Add CPT quantities from PCE to current totals
180 N LRSTR2,LRIEN2,LRPX,LRCPT,LRXX,LRCPT2,LRCPT1,LRX1,LRQ1,LRQ2,LRQT,LRCT
181 S LRSTR2=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE"))
182 Q:'LRSTR2
183 K LRVIS S LRVIS=""
184 S LRCT=$L(LRSTR2,";")-1,LRVIS=$P(LRSTR2,";",LRCT)
185 F LRPX=1:1 S LRIEN2=$P(LRSTR2,";",LRPX) Q:LRIEN2="" D
186 .D GETCPT^PXAPIOE(LRIEN2,"LRCPT","ERR")
187 S LRXX=""
188 F S LRXX=$O(LRCPT(LRXX)) Q:LRXX="" D
189 .Q:$P(LRCPT(LRXX),"^",3)'=LRVIS
190 .S LRCPT2=""
191 .S LRCPT2=+$G(LRCPT(LRXX))
192 .D:LRCPT2
193 ..S (LRX1,LRQT)=0
194 ..F S LRX1=$O(^TMP("LRPXAPI",$J,"PROCEDURE",LRX1)) Q:LRX1=""!(LRQT) D
195 ...S LRCPT1=+$G(^TMP("LRPXAPI",$J,"PROCEDURE",LRX1,"PROCEDURE"))
196 ...I LRCPT1=LRCPT2 D
197 ....S LRQ1=$P(LRCPT(LRXX),"^",16)
198 ....S LRQ2=+$G(^TMP("LRPXAPI",$J,"PROCEDURE",LRX1,"QTY"))
199 ....S ^TMP("LRPXAPI",$J,"PROCEDURE",LRX1,"QTY")=LRQ1+LRQ2
200 ....S LRQT=1
201 Q
202CLEAN ;Final Cleanup
203 K AFTER812,AGE,CPT,D,D0,DOB,DDER,DFN,DI,DIC,DIG,DIH,DIR,DIRUT
204 K DISL,DIRUT,DIU,DUOUT,DIV,DQ
205 K I,J,LRACC,LRCNT,LRI,POP,PXALOOK,PXASUB,PXJ,PXJJ
206 K SDT1,SPEL,SUBL,T1,TYPEI,X,XPARSYS
207 K ANS,CLN,CNT,FPRI,LRAA,LRAD,LRAN,LRANSX,LRANSY,LRCDT,LRCNT
208 K LRDFN,LRDPF,LRDLOC,LRDSSID,LRDSSLOC,LRDUZ,LREDT,LREND,LRES,LRESCPT
209 K LRIDT,LRIDIV,LRLLOC,LRLLOCX,LRLST,LRNINS,LRNLT,LRNLTN,LRNODE0,LRNOP,LROK
210 K LRPCEN,LRPCENON,LRPCEVSO,LRPKG,LRPRAC,LRPRO,LRRB,LRQ,LRSS,LRTREA,LRTST,LRURG
211 K LRSPECID,LRTSTP,LRUID,LRVBY
212 K LRVSITN,LRWRD,LRX,LRXCPT,LRXTST
213 K NODE,NODE0,PNM,SEX,SDFLAG,SSN,VA,X1,X2,X3
214 K ^TMP("LRMOD",$J)
215 K ^TMP("LR",$J,"AK"),^TMP("LR",$J,"LRLST")
216 K ^TMP("LRPXAPI",$J)
217 D KVAR^VADPT
218 Q
219CPT(LRAA,LRAD,LRAN,LRPRO) ;AP Release entry point
220 ;LRAA=accession area, LRAD=accession date, LRAN=accession number
221 ;LRPRO=provider
222 N X,Y,I,LRI,LREDT,LRCDT,LRIDT,LRLLOCX,LRSPECID,DIC,LRNOP,LREND,LRES
223 S (LRLLOCX,LRLLOC)=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",6)
224 S DIC=44,DIC(0)="ONM",X=LRLLOC D ^DIC
225 I Y>1 S LRLLOC=+Y
226 I Y<1 D Q:$G(LREND)
227 . S DIC(0)="AEZNM" D ^DIC
228 . I Y<1 S LRNOP="4^Not an outpatient location",LREND=1 Q
229 . S LRLLOC=+Y
230 ;KLL - set LRDSSLOC to LRDLOC, instead of LRLLOC to resolve location
231 ; problem occurring in PCE
232 ;TAC - use accession area OOS location if one exists
233 S LRDSSLOC=+$$GET1^DIQ(68,LRAA_",",.8,"I")
234 S LRDSSLOC=$S($G(LRDSSLOC):LRDSSLOC,1:+$G(LRDLOC))
235 S LRDSSID=+$$GET1^DIQ(44,+LRLLOC,8,"I")
236 S LRNINS=$$GET1^DIQ(44,+LRLLOC,3,"I")
237 S LRNINS=$S(LRNINS:LRNINS,1:DUZ(2))
238 I '$G(LRIDT) S LRIDT=+$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",13.5,"I")
239 S LRUID=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",16)
240 S LRLLOCX=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",6)
241 S LRSPECID="Acc #: "_$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",15,"E")
242 S:$L($G(LRUID)) LRSPECID=LRSPECID_" UID: "_LRUID
243 S LREDT=$$GET1^DIQ(68.02,LRAN_","_LRAD_","_LRAA_",",9,"I")
244 I 'LREDT S LREDT=$$NOW^XLFDT
245 S LRCDT="Collection Date: "_$$FMTE^XLFDT(LREDT,1)
246 I '$G(LRESCPT) D Q
247 . D EN^DDIOL("CPT workload is not activated","","!?20")
248 I $S('$G(LRAA):1,'$G(LRAD):1,'$G(LRAN):1,'$G(LRPRO):1,1:0) Q
249 I +$G(^LRO(68,LRAA,1,LRAD,1,LRAN,0))'=LRDFN Q
250 D CPTEN
251 Q
Note: See TracBrowser for help on using the repository browser.