source: FOIAVistA/trunk/r/LAB_SERVICE-LR-LS/LRCAPES1.m@ 846

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1LRCAPES1 ;DALOI/FHS/KLL-CONT MANUAL PCE CPT WORKLOAD CAPTURE ;07/30/04
2 ;;5.2;LAB SERVICE;**274,308**;Sep 27, 1994
3 ;Continuation of LRCAPES
4EN ;Setup the order of defined NLT codes
5 ; ^ICPTCOD supported by DBIA 1995-A
6 Q:$G(^TMP("LR",$J,"AK",0,1))=DUZ_U_DT
7 N LRI,LRY,LRX,LRX2,LRX3,LRDES,LRCNT
8 K ^TMP("LR",$J,"AK")
9 S LRCNT=0
10 S ^TMP("LR",$J,"AK",0)=$$FMADD^XLFDT(DT,2)_U_DT_U_"ES CPT code list"
11 S ^TMP("LR",$J,"AK",0,1)=DUZ_U_DT
12 S LRY="^LAM(""AK"")" F S LRY=$Q(@LRY) Q:$QS(LRY,1)'="AK" D
13 . N LRDES
14 . S LRX2=$QS(LRY,2),LRX3=$QS(LRY,3)
15 . Q:'$G(LRX2)!('$G(LRX3))
16 . S LRI=0 F S LRI=$O(^LAM(LRX3,4,"AC","CPT",LRI)) Q:LRI<1 D
17 . . S LRX=+$G(^LAM(LRX3,4,LRI,0)),LRX=$$CPT^ICPTCOD(LRX,DT)
18 . . Q:'$P(LRX,U,7)
19 . . K LRDES S LRDES=$$CPTD^ICPTCOD(+LRX,"LRDES")
20 . . S LRCNT=LRCNT+1
21 . . I $L(LRDES(1)) S ^TMP("LR",$J,"AK",LRX2,LRI,+LRX)=LRX3_U_$E(LRDES(1),1,55)_U_$$GET1^DIQ(64,LRX3_",",.01,"E")_U_$$GET1^DIQ(64,LRX3_",",1,"E") Q
22 . . S ^TMP("LR",$J,"AK",LRX2,LRI,+LRX)=LRX3_U_$P(LRX,U,3)_U_$$GET1^DIQ(64,LRX3_",",.01,"E")_U_$$GET1^DIQ(64,LRX3_",",1,"E")
23 Q
24SET(DFN,LRPRO,LREDT,LRLOC,LRINS,LRCPT,LRAA,LRAD,LRAN) ; Call to check variable
25 S (LREND,LROK)=0,LRAA=+$G(LRAA),LRAD=+$G(LRAD),LRAN=+$G(LRAN)
26 I '$D(^DPT(DFN,0))#2 S LROK="1^Error Patient" Q LROK
27 I $$GET^XUA4A72(LRPRO,DT)<1 S LROK="2^Inactive Provider" Q LROK
28 I LREDT'?7N.E S LROK="3^Date Format" Q LROK
29 I '$D(^SC(LRLOC,0))#2 S LROK="4^Location Error" Q LROK
30 I "CMZ"'[$P($G(^SC(LRLOC,0)),U,3) S LROK="4.2^Not Inpatient Location" Q LROK
31 I '$G(LRDSSID) S LROK="4.2^Not Inpatient Location" Q LROK
32 I '$D(^DIC(4,LRINS,0))#2 S LROK="5^Institution Error" Q LROK
33 I '$O(LRCPT(0)) S LROK="6^No CPT Codes Passed" Q LROK
34 D EN^LRCAPES,READ^LRCAPES1
35 D DIS I '$O(^TMP("LR",$J,"LRLST",0)) S LROK="-1" Q LROK
36 D LOAD^LRCAPES,CLEAN^LRCAPES
37 Q LROK
38 ;
39SEND ;Send data to PCE via DATA2PCE^PXAPI API
40 I $$GET1^DIQ(63,+$G(LRDFN),.02,"I")=2,$G(LRDSSID),$O(^TMP("LRPXAPI",$J,"PROCEDURE",0)) D
41 . I '$D(LRQUIET) W !,$$CJ^XLFSTR("Sending PCE Workload",IOM)
42 . S:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE")) ^("PCE")="" S LRPCEN=^("PCE")
43 . S LREDT=$S($G(LREDT):LREDT,1:$$NOW^XLFDT)
44 . S:'$P(LREDT,".",2) $P(LREDT,".",2)="1201"
45 . D SEND^LRCAPPH1
46 . I '$D(LRQUIET) W $$CJ^XLFSTR("Visit # "_LRVSITN,80)
47 . S ^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE")=$E(LRPCEN_LRVSITN_";",1,80)
48 D SETWKL(LRAA,LRAD,LRAN)
49 Q
50SETWKL(LRAA,LRAD,LRAN) ;Set workload into 68 from CPT coding
51 Q:'$P(LRPARAM,U,14)!('$P($G(^LRO(68,+$G(LRAA),0)),U,16))
52 I '$G(^LRO(68,+$G(LRAA),1,+$G(LRAD),1,+$G(LRAN),0)) Q
53 I '$O(^TMP("LR",$J,"LRLST",0)) K ^TMP("LR",$J,"LRLST") Q
54 I '$D(LRQUIET) W !,$$CJ^XLFSTR("Storing LMIP Workload",IOM)
55 N LRCNT,LRT,LRP,LRTIME,LRCDEF,LRURGW,LRI,LRADD
56 S:'$G(LRURG) LRURG=9
57 S (LRADD,LRCNT)=1,LRCDEF="3000",LRURGW=+$G(LRURG)
58 S LRT("P")=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
59 S LRI=0 F S LRI=$O(^TMP("LR",$J,"LRLST",LRI)) Q:LRI<1 D
60 . S LRP=$P(^TMP("LR",$J,"LRLST",LRI),U,2)
61 . I 'LRP D Q:'LRP
62 . . S LRP=+$O(^LAM("AB",$P(^TMP("LR",$J,"LRLST",LRI),U)_";ICPT(",0))
63 . Q:'($D(^LAM(LRP,0))#2)
64 . S LRT=+$O(^LAM(LRP,7,"B",0))
65 . I 'LRT S LRT=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,0))
66 . Q:'LRT
67 . D SET^LRCAPV1S,STUFI^LRCAPV1
68 K ^TMP("LR",$J,"LRLST")
69 Q
70DIS ;
71 N X9
72 K X,LRLST,LRCNT,LRI,LRX,LRXY,LRXTST
73 K ^TMP("LR",$J,"LRLST")
74 N LRNOTFD,LRNOLK,LRIA81,LRIA64,LRRF64
75 I $G(LRANSX) D
76 . S X=LRANSX D RANGE^LRWU2
77 . X (X9_"S LRX=T1 D EX1^LRCAPES")
78 I '$O(^TMP("LR",$J,"LRLST",0)) D Q
79 . W !!!,?5,"The following CPT Code(s) are not selected:"
80 . W:$G(LRNOTFD) !?8,"Not found in #81: ",LRNOTFD
81 . W:$G(LRIA81) !?8,"Inactive in #81: ",LRIA81
82 . W:$G(LRIA64) !?8,"Inactive in #64: ",LRIA64
83 . W:$G(LRNOLK) !?8,"Not linked to workload: ",LRNOLK
84 . W !
85 . S LRANSY=0
86 D DEM
87CHK ;User accepts CPT list
88 N DIR
89 S DIR("A")="Is this correct "
90 S DIR(0)="Y",DIR("B")="Yes" D RD
91 I $G(LRANSY)'=1 D
92 .K ^TMP("LR",$J,"LRLST")
93 .S ^TMP("LR",$J,"LRLST")=$$FMADD^XLFDT(DT,2)_U_DT_U_"LAB ES CPT"
94 Q
95PG ;Page break
96 N DIR,DIRUT,DUOUT,DTOUT
97 S DIR(0)="E" D ^DIR
98 I $G(DIRUT) S LREND=1 Q
99 W @IOF
100 Q
101RD ;DIR read
102 N Y,X,DTOUT,DUOUT,DIRUT,DIROUT
103 S (LRANSY,LRANSX)=0
104 S LREND=0 W !
105 D ^DIR I $D(DIRUT) S LREND=1 Q
106 S LRANSY=$G(Y),LRANSX=$G(X)
107 Q
108READ ;Select CPT codes for accession
109 ; Ask if want to see previously loaded CPT codes
110 D LSTCPT(LRAA,LRAD,LRAN)
111 N DIR,LREND
112 S DIR(0)="LO",LREND=0
113 S DIR("A")="Select CPT codes"
114 S DIR("?")="List or range e.g, 1,3,5-7,88000."
115 S DIR("??")="^D HLP^LRCAPES1"
116 D RD
117 Q
118DEM ;
119 N LRIENS,DA
120 S LRIENS=LRAN_","_LRAD_","_LRAA_","
121 W @IOF
122 W !?3,PNM,?35,SSN,?55,"DOB: ",$$FMTE^XLFDT(DOB,1)
123 W !?5,LRCDT
124 W !?10,LRSPECID,?60,"Loc: ",$G(LRLLOCX)
125 I $G(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE")) W !?15,"PCE ENC # "_^("PCE")
126 W !?15,"Specimen: ",$$GET1^DIQ(68.05,"1,"_LRIENS,.01,"E")
127 I $L($G(LRSS)),$O(^LR(LRDFN,LRSS,LRIDT,.1,0)) D
128 . N LRX
129 . W !?5,"Tissue Specimens: "
130 . S LRX=0 F S LRX=$O(^LR(LRDFN,LRSS,LRIDT,.1,LRX)) Q:LRX<1 W !,?15,$P($G(^(LRX,0)),U)
131 W !?5,"Test(s); "
132 S (LREND,LRX)=0 D
133 . N LREND
134 . F S LRX=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRX)) Q:LRX<1!($G(LREND)) D
135 . . I $Y>(IOSL-5) D PG Q:$G(LREND)
136 . . W ?15,$P($G(^LAB(60,+LRX,0)),U)_"/ "
137 ;Display pathologist's name
138 N LRPATH,LRIENS,LRFL
139 S:LRSS="AU" LRPATH=$$GET1^DIQ(63,LRDFN,13.6,"I")
140 I LRSS'="AU" D
141 .S LRFL=$S(LRSS="EM":63.02,LRSS="CY":63.09,LRSS="SP":63.08,1:0)
142 .S LRIENS=LRIDT_","_LRDFN_","
143 .S LRPATH=$$GET1^DIQ(LRFL,LRIENS,.02,"I")
144 S LRPATH=$$GET1^DIQ(200,+$G(LRPATH),.01,"I")
145 W:LRSS="CY" !?5,"Pathologist/Cytotechnologist: ",LRPATH,!
146 W:LRSS'="CY" !?5,"Pathologist: ",LRPATH,!
147 ;
148 Q:'$O(^TMP("LR",$J,"LRLST",0))
149 W !!,$$CJ^XLFSTR("Selected CPT Codes",IOM)
150 W ! S (LREND,LRX)=0 D
151 . N LREND,LRTMP
152 . S LRTMP=0
153 . F S LRX=+$O(^TMP("LR",$J,"LRLST",LRX)) Q:LRX<1!($G(LREND)) D
154 . . I $Y>(IOSL-5) D PG Q:$G(LREND)
155 . . S LRTMP=$G(^TMP("LR",$J,"LRLST",LRX))
156 . . W !?5,"("_LRX_") "_$P(LRTMP,U)_" "_$E($P(LRTMP,U,3),1,50),!
157 . . W:$P(LRTMP,U,5) ?10,$E($P(LRTMP,U,4),1,50)_" {"_$P(LRTMP,U,5)_"}"
158 I $G(LRNOTFD)!$G(LRIA81)!$G(LRIA64)!$G(LRNOLK)!$G(LRRF64) D
159 . W !!!?5,"The following CPT Codes are NOT Selected"
160 . W:$G(LRNOTFD) !?8,"Not found in #81: ",LRNOTFD
161 . W:$G(LRIA81) !?8,"Inactive in #81: ",LRIA81
162 . W:$G(LRIA64) !?8,"Inactive in #64: ",LRIA64
163 . W:$G(LRNOLK) !?8,"Not Linked to Workload: ",LRNOLK
164 . W:$G(LRRF64) !?8,"Inactive in #64\Active Replacement Found: ",LRRF64
165 Q
166CHKCPT ;Edit CPT code - does it exist,active in 81 or 64, linked to workload?
167 N LRINACT,LRII
168 S (LRNR,LRACTV,LRXY2,LRWL2,LRD2)=0,LRXY1=$P(LRXY,U)
169 I LRXY1=-1 S LRNOTFD=$S($G(LRNOTFD):LRNOTFD_LRX_",",1:LRX_",") Q
170 I '$P(LRXY,U,7) S LRIA81=$S($G(LRIA81):LRIA81_LRXY1_",",1:LRXY1_",") Q
171 I '$O(^LAM("AB",LRXY1_";ICPT(",0)) D Q
172 . S LRNOLK=$S($G(LRNOLK):LRNOLK_LRXY1_",",1:LRXY1_","),LRNR=1
173 ;If CPT is not active in 64, look for alternative active CPT
174 S LRWL2=+$O(^LAM("AB",LRXY1_";ICPT(",0))
175 S:$G(LRQ)'="" LRWL2=$P(@LRQ,"^") ;For ES Display CPTs
176 Q:'LRWL2
177 S LRD2=+$O(^LAM("AB",LRXY1_";ICPT(",LRWL2,LRD2))
178 S LRREL2=$P(^LAM(LRWL2,4,LRD2,0),U,3),LRINA2=$P(^(0),U,4)
179 Q:LRREL2&(LRINA2="")
180 Q:LREDT>(LRREL2-1)&((LREDT<LRINA2)!(LRINA2=""))
181 ;CPT is inactive, search for another linked, active CPT to replace it
182 S LRD2="A",LRD2=$O(^LAM(LRWL2,4,LRD2),-1)
183 I LRD2>1 D
184 .S LRII=0,(LRREL2,LRINA2)=""
185 .F S LRII=$O(^LAM(LRWL2,4,LRII)) Q:'LRII!(LRACTV) D
186 ..S LRXY2=+$P(^LAM(LRWL2,4,LRII,0),U)
187 ..Q:LRXY2=LRXY1
188 ..S LRREL2=$P(^LAM(LRWL2,4,LRII,0),U,3),LRINA2=$P(^(0),U,4)
189 ..I LRREL2&(LRINA2="") S LRACTV=1 Q
190 ..I LREDT>(LRREL2-1)&((LREDT<LRINA2)!(LRINA2="")) S LRACTV=1 Q
191 ;No replacement active CPT found,
192 I 'LRACTV S LRIA64=$S($G(LRIA64):LRIA64_LRXY1_",",1:LRXY1_","),LRNR=1 Q
193 Q
194LSTCPT(LRAA,LRAD,LRAN) ; Show loaded CPT codes if any
195 Q:$S('$G(LRAA):1,'$G(LRAD):1,'$G(LRAN):1,1:0)
196 N LRSTR
197 S LRSTR=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,"PCE")) Q:'LRSTR
198 N DA,DIC,DIR,DIRUT,DIR,DR,ERR,DUOUT,IEN,LRDA,LRENC,LREND,LRP,S,X,Y
199 S DIR(0)="Y",DIR("A")=" Would you like to see PCE CPT Information"
200 S DIR("B")="No" D ^DIR Q:$G(DIRUT)!($G(Y)'=1)
201 ;List filed CPT CODES
202 W @IOF
203 F LRP=1:1 S IEN=$P(LRSTR,";",LRP) Q:IEN="" D
204 . D GETCPT^PXAPIOE(IEN,"LRENC","ERR")
205 S (LRDA,LREND)=0 F S LRDA=$O(LRENC(LRDA)) Q:'LRDA!($G(LREND)) D
206 . I $Y>(IOSL-6) D PG W @IOF Q:$G(LREND)
207 . S S=0,DA=LRDA,DR="0:99",DIC="^AUPNVCPT(" D EN^DIQ
208 Q
209HLP ;Help display for CPT selection
210 N DIR,DIRUT,DUOUT,DTOUT,LREND,LRX,LRY
211 W @IOF
212 S LRX="^TMP(""LR"","_$J_",""AK"",0,1)"
213 W $$CJ^XLFSTR("List or range e.g, 1,3,5-7,88300.",IOM)
214 W $$CJ^XLFSTR("Select from the following or enter CPT separated by a comma",IOM),!
215 F S LRX=$Q(@LRX) Q:$QS(LRX,2)'=$J!($G(LREND))!($QS(LRX,1)'="LR") D
216 . S LRY=@LRX
217 . W !?3,$QS(LRX,4),?6," = "_$QS(LRX,6)_" "_$E($P(LRY,U,2),1,60),!
218 . W:$P(LRY,U,4) ?8,$P(LRY,U,3)_" { NLT = "_$P(LRY,U,4)_" }",!
219 . I $Y>(IOSL-6) S DIR(0)="E" D RD I '$G(LREND) W @IOF
220 D LSTCPT^LRCAPES1($G(LRAA),$G(LRAD),$G(LRAN))
221 Q
Note: See TracBrowser for help on using the repository browser.