source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRBEBA21.m@ 1667

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

initial load of WorldVistAEHR
File size: 7.2 KB
Line 
1LRBEBA21 ;DALOI/JAH/FHS - PROCESS PANEL CPT CODE ;8/10/04
2 ;;5.2;LAB SERVICE;**291,359**;Sep 27, 1994
3 ;Continued LRBEBA2
4 ;Process panel test for CPT
5 ;Set 13th piece of LRSB(X) to prevent double counting
6EN(LRBE21) ;LRBEAR1(LRBETST,
7 ;Returns LRBE21
8 ; 0 = process as atomic test
9 ; 1 = processed (or will be processed in future) as panel
10 N LRI,LRY,LRTST,LRNOP,LRNP,LRPEND,LRCANC,LRBSB,LRFDA,ERR,OK
11 N LRBECDT,LRBEEDT,LRORREFN,LRPCECNT,LRBEQTY,LRNOREQ,LRBESTG
12 S (LRBE21,LRPCECNT,LRNP,LRNOP,LRPEND,LRCANC)=0
13 I $D(LRBEAR1(LRBETST)) D
14 . ;must be AMA/billable panel
15 . Q:'($D(LRBEPAN(LRBETST)))
16 . S LRY=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
17 . Q:'LRY
18 . S LRY=LRY_","_LRSN_","_LRODT_","
19 . ;canceled test
20 . I $$GET1^DIQ(69.03,LRY,8,"I")="CA" K LRY Q
21 . S LRBECDT=$$GET1^DIQ(69.03,LRY,22,"I")
22 . I 'LRBECDT K LRY Q
23 . I '$G(LRBERES) S LRPCECNT=$$GET1^DIQ(69.03,LRY,11,"I")
24 . I LRPCECNT K LRY Q
25 . S LRORREFN=$$GET1^DIQ(69.03,LRY,6,"I")
26 . I $G(ORIEN),LRORREFN'=ORIEN K LRY Q
27 . ;check status of atomic tests
28 . S LRNOREQ=1
29 . S LRBSB=0 F S LRBSB=$O(LRBEAR1(LRBETST,LRBSB)) Q:'LRBSB I $G(LRIDT) D
30 . . ;check only 'required' atomic tests
31 . . Q:'$D(LRBEAR1(LRBETST,LRBSB,"R"))
32 . . S LRTST=+LRBEAR1(LRBETST,LRBSB,"R")
33 . . S X=$G(LRBESB(LRBSB)) I 'LRTST S LRTST=+$P($P(X,"^",3),"!",7)
34 . . I X="" S X=$G(^LR(LRDFN,LRSS,LRIDT,LRBSB)) S:(X'="") LRBESB(LRBSB)=X S:(X="") X="pending"
35 . . ;check for not performed tests
36 . . I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST,0)),U,6)="*Not Performed" S LRNP=1
37 . . ;check for tests already sent to pce
38 . . I $P(X,U,13)=1 S LRNOP=1 Q
39 . . ;check for cancelled tests
40 . . I $P(X,U,1)="canc" S LRCANC=1
41 . . ;check for tests still pending
42 . . I $P(X,U,1)="pending" S LRPEND=1
43 . . S LRNOREQ=0
44 . ;quit if any 'required' atomic tests not performed or cancelled
45 . Q:((LRNOREQ=0)&(LRNP!LRCANC))
46 . ;check for resulted tests in panel with no 'required' tests
47 . S OK=0
48 . I LRNOREQ S LRBSB=0 F S LRBSB=$O(LRBEAR1(LRBETST,LRBSB)) Q:'LRBSB!($G(LRNP)) D
49 . . S X=$G(LRBESB(LRBSB)),LRTST=+$P($P(X,"^",3),"!",7)
50 . . I $P(X,U,1)'="",$P(X,U,1)'="canc",$P(X,U,1)'="pending" S OK=1
51 . . ;check for not performed tests
52 . . I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST,0)),U,6)="*Not Performed" S LRNP=1
53 . ;quit if no 'required' tests on panel and no resulted tests
54 . Q:(LRNOREQ&'OK)
55 . ;if not roll-up to PCE, proceed to panel CPT;
56 . ;including case where none of atomic tests are 'required' (if results available)
57 . I '$G(LRBEROLL) D PANEL^LRBEBA4 I $O(LRBECPT(LRBETST,0)) D
58 . . S LRI=0 F S LRI=$O(LRBECPT(LRBETST,LRI)) Q:LRI<1 D
59 . . . S LRBECPT=$O(LRBECPT(LRBETST,LRI,0))
60 . . . S LRBEMOD=$$GMOD^LRBEBA2(LRAA,LRBECPT)
61 . . . S LRBEPOS=DUZ,LRBEQTY=1,LRBEDN=+$O(LRBEAR1(LRBETST,0))
62 . . . D GDGX^LRBEBA21(LRBETST,LRBEDN,.LRBEAR,.LRBEAR1,.LRBEDGX)
63 . . . S LRBESTG=LRBECPT_U_$G(LRBEMOD)_U_$G(LRBEDGX(LRBETST,1))_U_$G(LRBEDGX(LRBETST,2))_U_$G(LRBEDGX(LRBETST,3))
64 . . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,4))_U_LRBECDT_U_LRBEEPRO_U_LRBEOPRO_U_LRBEQTY_U_LRBEPOS
65 . . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,5))_U_$G(LRBEDGX(LRBETST,6))_U_$G(LRBEDGX(LRBETST,7))
66 . . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,8))_U_LRORREFN
67 . . . I $G(LRBECPT(LRBETST,LRI,LRBECPT,"COUNT")) S $P(LRBESTG,U,20)=LRBECPT(LRBETST,LRI,LRBECPT,"COUNT")+1
68 . . . S LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBETST)=LRBESTG
69 ;
70 Q:$G(LRY)=""
71 ;
72 ;if PCE rollup, then 'unbundled' in SOP2^LRBEBA2
73 I $G(LRBEROLL) D Q
74 . K LRBECPT(LRBETST)
75 . ;clear 'pending panel' xref
76 . S LRFDA(1,69.03,LRY,22.1)=0
77 . D FILE^DIE("KS","LRFDA(1)","ERR")
78 ;
79 ;if no required tests on panel and panel CPT exists, at least one resulted atomic,
80 ;then mark panel as processed; retain LRBECPT array for BAWRK^LRBEBA;
81 ;set return to "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
82 I $O(LRBECPT(LRBETST,0)),LRNOREQ D Q
83 . S LRBE21=1
84 . D LRSB
85 . S LRFDA(1,69.03,LRY,11)=1
86 . ;clear 'pending panel' xref
87 . S LRFDA(1,69.03,LRY,22.1)=0
88 . D FILE^DIE("KS","LRFDA(1)","ERR")
89 ;
90 ;if no required tests on panel and panel has no CPT or inactive CPT,
91 ;then return is "0" for 'unbundled' processing in SOP2^LRBEBA2
92 I '$O(LRBECPT(LRBETST,0)),LRNOREQ Q
93 ;
94 ;if resending (from WORK^LRBEBA4) and panel CPT determined,
95 ;then return "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
96 I $G(LRBERES)&LRNOP&('LRPEND)&($O(LRBECPT(LRBETST,0))) S LRBE21=1 Q
97 ;
98 ;if required atomic tests not performed, previously sent, or cancelled,
99 ;then return is "0" for 'unbundled' processing in SOP2^LRBEBA2
100 I (LRNP!LRNOP!LRCANC) D Q
101 . K LRBECPT(LRBETST)
102 . ;clear 'pending panel' xref
103 . S LRFDA(1,69.03,LRY,22.1)=0
104 . D FILE^DIE("KS","LRFDA(1)","ERR")
105 ;
106 ;if panel has CPT and no required atomic test still pending,
107 ;then mark panel as processed; retain LRBECPT array for BAWRK^LRBEBA;
108 ;set return to "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
109 I $O(LRBECPT(LRBETST,0)),'LRPEND D Q
110 . S LRBE21=1
111 . D LRSB
112 . S LRFDA(1,69.03,LRY,11)=1
113 . ;clear 'pending panel' xref
114 . S LRFDA(1,69.03,LRY,22.1)=0
115 . D FILE^DIE("KS","LRFDA(1)","ERR")
116 ;
117 ;if panel has no CPT or inactive CPT, but required atomic test still pending,
118 ;then set return to "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
119 I '$O(LRBECPT(LRBETST,0)),LRPEND D Q
120 . S LRBE21=1
121 . ;set 'pending panel' xref
122 . S LRFDA(1,69.03,LRY,22.1)=1
123 . D FILE^DIE("KS","LRFDA(1)","ERR")
124 ;
125 ;if panel has CPT, but required atomic test still pending,
126 ;then kill cpt to avoid transmission to PCE,
127 ;set return to "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
128 I $O(LRBECPT(LRBETST,0)),LRPEND D
129 . S LRBE21=1
130 . S LRI=$O(LRBECPT(LRBETST,0)) K LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBETST)
131 . K LRBECPT(LRBETST)
132 . ;set 'pending panel' xref
133 . S LRFDA(1,69.03,LRY,22.1)=1
134 . D FILE^DIE("KS","LRFDA(1)","ERR")
135 ;
136 Q
137 ;
138LRSB ;Set LRBESB(TEST) 13th piece to 1, counted as part of panel.
139 ;Set 13th piece of LRBESB(X) to prevent double counting
140 N LRSBX
141 S LRSBX=0 F S LRSBX=$O(LRBEAR1(LRBETST,LRSBX)) Q:LRSBX<1 D
142 . I $D(LRBESB(LRSBX))#2 S $P(LRBESB(LRSBX),U,13)=1
143 . I $G(LRIDT),$D(^LR(LRDFN,LRSS,LRIDT,LRSBX)) S $P(^(LRSBX),U,13)=1
144 Q
145 ;
146GDGX(LRBETST,LRBEDN,LRBEAR,LRBEAR1,LRBEDGX) ; Set diagnosis LRBEDGX
147 N LRBEPOV,LRBEPTDT,LRBETNUM
148 S (LRBEPOV,LRBETNUM)="" F S LRBEPOV=$O(LRBEAR1(LRBETST,LRBEDN,LRBEPOV)) Q:'LRBEPOV D
149 . S LRBEPTDT=$G(LRBEAR1(LRBETST,LRBEDN,LRBEPOV))
150 . S LRBETNUM=$G(LRBETNUM)+1,LRBEDGX(LRBETST,LRBETNUM)=$P(LRBEPTDT,U,1)
151 Q:$D(LRBEDGX(LRBETST,1))
152 N DGX S DGX=0
153 F S DGX=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRSAMP,LRSPEC,LRBETST,DGX)) Q:DGX<1 D
154 . S LRBETNUM=$G(LRBETNUM)+1,LRBEDGX(LRBETST,LRBETNUM)=DGX
155 Q
156GOREF(LRODT,LRSN,LRBEDN,LRBEAR1,LRORREFN) ;
157 ;Get the OERR INTERNAL FILE #
158 N LRX1,LRBEIEN1,LRBETST
159 S LRBETST=""
160 F S LRBETST=$O(LRBEAR1(LRBETST)) Q:LRBETST="" D
161 .Q:'$D(LRBEAR1(LRBETST,LRBEDN))
162 .S LRX1=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
163 .I $G(LRX1) D Q
164 ..S LRBEIEN1=LRX1_","_LRSN_","_LRODT_","
165 ..S LRORREFN=$$GET1^DIQ(69.03,LRBEIEN1,6,"I")
166 .S LRORREFN=""
167 Q
168 ;
169GMOD(LRBEAA,LRBECPT) ; Get external service modifier
170 ;input LRBECPT - ien to #81, not required
171 N DIC,LRBEESA,LRBEMOD,MOD,STAT,X,Y
172 S LRBEESA=$$GET1^DIQ(68,LRBEAA_",",12,"I"),LRBEMOD=""
173 I LRBEESA D
174 .S X=90,DIC="^DIC(81.3,",DIC(0)="Z" D ^DIC
175 .I +Y<0 K DIC Q
176 .S LRBEMOD=$P(Y,U,2),MOD=+Y
177 .;if cpt/hcpcs provided, check if modifier is valid to use
178 .I $G(LRBECPT) D
179 ..S STAT=$$MODP^ICPTMOD(LRBECPT,MOD,"I",DT)
180 ..I +STAT=0 S LRBEMOD=""
181 Q LRBEMOD
Note: See TracBrowser for help on using the repository browser.