LRBEBA21 ;DALOI/JAH/FHS - PROCESS PANEL CPT CODE ;8/10/04
 ;;5.2;LAB SERVICE;**291,359**;Sep 27, 1994
 ;Continued LRBEBA2
 ;Process panel test for CPT
 ;Set 13th piece of LRSB(X) to prevent double counting
EN(LRBE21) ;LRBEAR1(LRBETST,
 ;Returns LRBE21
 ;        0 = process as atomic test
 ;        1 = processed (or will be processed in future) as panel
 N LRI,LRY,LRTST,LRNOP,LRNP,LRPEND,LRCANC,LRBSB,LRFDA,ERR,OK
 N LRBECDT,LRBEEDT,LRORREFN,LRPCECNT,LRBEQTY,LRNOREQ,LRBESTG
 S (LRBE21,LRPCECNT,LRNP,LRNOP,LRPEND,LRCANC)=0
 I $D(LRBEAR1(LRBETST)) D
 . ;must be AMA/billable panel
 . Q:'($D(LRBEPAN(LRBETST)))
 . S LRY=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
 . Q:'LRY
 . S LRY=LRY_","_LRSN_","_LRODT_","
 . ;canceled test
 . I $$GET1^DIQ(69.03,LRY,8,"I")="CA" K LRY Q
 . S LRBECDT=$$GET1^DIQ(69.03,LRY,22,"I")
 . I 'LRBECDT K LRY Q
 . I '$G(LRBERES) S LRPCECNT=$$GET1^DIQ(69.03,LRY,11,"I")
 . I LRPCECNT K LRY Q
 . S LRORREFN=$$GET1^DIQ(69.03,LRY,6,"I")
 . I $G(ORIEN),LRORREFN'=ORIEN K LRY Q
 . ;check status of atomic tests
 . S LRNOREQ=1
 . S LRBSB=0 F  S LRBSB=$O(LRBEAR1(LRBETST,LRBSB)) Q:'LRBSB  I $G(LRIDT) D
 . . ;check only 'required' atomic tests
 . . Q:'$D(LRBEAR1(LRBETST,LRBSB,"R"))
 . . S LRTST=+LRBEAR1(LRBETST,LRBSB,"R")
 . . S X=$G(LRBESB(LRBSB)) I 'LRTST S LRTST=+$P($P(X,"^",3),"!",7)
 . . I X="" S X=$G(^LR(LRDFN,LRSS,LRIDT,LRBSB)) S:(X'="") LRBESB(LRBSB)=X S:(X="") X="pending"
 . . ;check for not performed tests
 . . I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST,0)),U,6)="*Not Performed" S LRNP=1
 . . ;check for tests already sent to pce
 . . I $P(X,U,13)=1 S LRNOP=1 Q
 . . ;check for cancelled tests
 . . I $P(X,U,1)="canc" S LRCANC=1
 . . ;check for tests still pending
 . . I $P(X,U,1)="pending" S LRPEND=1
 . . S LRNOREQ=0
 . ;quit if any 'required' atomic tests not performed or cancelled
 . Q:((LRNOREQ=0)&(LRNP!LRCANC))
 . ;check for resulted tests in panel with no 'required' tests
 . S OK=0
 . I LRNOREQ S LRBSB=0 F  S LRBSB=$O(LRBEAR1(LRBETST,LRBSB)) Q:'LRBSB!($G(LRNP))  D
 . . S X=$G(LRBESB(LRBSB)),LRTST=+$P($P(X,"^",3),"!",7)
 . . I $P(X,U,1)'="",$P(X,U,1)'="canc",$P(X,U,1)'="pending" S OK=1
 . . ;check for not performed tests
 . . I $P($G(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST,0)),U,6)="*Not Performed" S LRNP=1
 . ;quit if no 'required' tests on panel and no resulted tests
 . Q:(LRNOREQ&'OK)
 . ;if not roll-up to PCE, proceed to panel CPT; 
 . ;including case where none of atomic tests are 'required' (if results available)
 . I '$G(LRBEROLL) D PANEL^LRBEBA4 I $O(LRBECPT(LRBETST,0)) D
 . . S LRI=0 F  S LRI=$O(LRBECPT(LRBETST,LRI)) Q:LRI<1  D
 . . . S LRBECPT=$O(LRBECPT(LRBETST,LRI,0))
 . . . S LRBEMOD=$$GMOD^LRBEBA2(LRAA,LRBECPT)
 . . . S LRBEPOS=DUZ,LRBEQTY=1,LRBEDN=+$O(LRBEAR1(LRBETST,0))
 . . . D GDGX^LRBEBA21(LRBETST,LRBEDN,.LRBEAR,.LRBEAR1,.LRBEDGX)
 . . . S LRBESTG=LRBECPT_U_$G(LRBEMOD)_U_$G(LRBEDGX(LRBETST,1))_U_$G(LRBEDGX(LRBETST,2))_U_$G(LRBEDGX(LRBETST,3))
 . . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,4))_U_LRBECDT_U_LRBEEPRO_U_LRBEOPRO_U_LRBEQTY_U_LRBEPOS
 . . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,5))_U_$G(LRBEDGX(LRBETST,6))_U_$G(LRBEDGX(LRBETST,7))
 . . . S LRBESTG=LRBESTG_U_$G(LRBEDGX(LRBETST,8))_U_LRORREFN
 . . . I $G(LRBECPT(LRBETST,LRI,LRBECPT,"COUNT")) S $P(LRBESTG,U,20)=LRBECPT(LRBETST,LRI,LRBECPT,"COUNT")+1
 . . . S LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBETST)=LRBESTG
 ;
 Q:$G(LRY)=""
 ;
 ;if PCE rollup, then 'unbundled' in SOP2^LRBEBA2
 I $G(LRBEROLL) D  Q
 . K LRBECPT(LRBETST)
 . ;clear 'pending panel' xref
 . S LRFDA(1,69.03,LRY,22.1)=0
 . D FILE^DIE("KS","LRFDA(1)","ERR")
 ;
 ;if no required tests on panel and panel CPT exists, at least one resulted atomic,
 ;then mark panel as processed; retain LRBECPT array for BAWRK^LRBEBA;
 ;set return to "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
 I $O(LRBECPT(LRBETST,0)),LRNOREQ D  Q
 . S LRBE21=1
 . D LRSB
 . S LRFDA(1,69.03,LRY,11)=1
 . ;clear 'pending panel' xref
 . S LRFDA(1,69.03,LRY,22.1)=0
 . D FILE^DIE("KS","LRFDA(1)","ERR")
 ;
 ;if no required tests on panel and panel has no CPT or inactive CPT,
 ;then return is "0" for 'unbundled' processing in SOP2^LRBEBA2
 I '$O(LRBECPT(LRBETST,0)),LRNOREQ Q
 ;
 ;if resending (from WORK^LRBEBA4) and panel CPT determined,
 ;then return "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
 I $G(LRBERES)&LRNOP&('LRPEND)&($O(LRBECPT(LRBETST,0))) S LRBE21=1 Q
 ;
 ;if required atomic tests not performed, previously sent, or cancelled,
 ;then return is "0" for 'unbundled' processing in SOP2^LRBEBA2
 I (LRNP!LRNOP!LRCANC) D  Q
 . K LRBECPT(LRBETST)
 . ;clear 'pending panel' xref
 . S LRFDA(1,69.03,LRY,22.1)=0
 . D FILE^DIE("KS","LRFDA(1)","ERR")
 ;
 ;if panel has CPT and no required atomic test still pending,
 ;then mark panel as processed; retain LRBECPT array for BAWRK^LRBEBA;
 ;set return to "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
 I $O(LRBECPT(LRBETST,0)),'LRPEND D  Q
 . S LRBE21=1
 . D LRSB
 . S LRFDA(1,69.03,LRY,11)=1
 . ;clear 'pending panel' xref
 . S LRFDA(1,69.03,LRY,22.1)=0
 . D FILE^DIE("KS","LRFDA(1)","ERR")
 ;
 ;if panel has no CPT or inactive CPT, but required atomic test still pending,
 ;then set return to "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
 I '$O(LRBECPT(LRBETST,0)),LRPEND D  Q
 . S LRBE21=1
 . ;set 'pending panel' xref
 . S LRFDA(1,69.03,LRY,22.1)=1
 . D FILE^DIE("KS","LRFDA(1)","ERR")
 ;
 ;if panel has CPT, but required atomic test still pending,
 ;then kill cpt to avoid transmission to PCE,
 ;set return to "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
 I $O(LRBECPT(LRBETST,0)),LRPEND D
 . S LRBE21=1
 . S LRI=$O(LRBECPT(LRBETST,0)) K LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBETST)
 . K LRBECPT(LRBETST)
 . ;set 'pending panel' xref
 . S LRFDA(1,69.03,LRY,22.1)=1
 . D FILE^DIE("KS","LRFDA(1)","ERR")
 ;
 Q
 ;
LRSB ;Set LRBESB(TEST) 13th piece to 1, counted as part of panel.
 ;Set 13th piece of LRBESB(X) to prevent double counting
 N LRSBX
 S LRSBX=0 F  S LRSBX=$O(LRBEAR1(LRBETST,LRSBX)) Q:LRSBX<1  D
 . I $D(LRBESB(LRSBX))#2 S $P(LRBESB(LRSBX),U,13)=1
 . I $G(LRIDT),$D(^LR(LRDFN,LRSS,LRIDT,LRSBX)) S $P(^(LRSBX),U,13)=1
 Q
 ;
GDGX(LRBETST,LRBEDN,LRBEAR,LRBEAR1,LRBEDGX) ; Set diagnosis LRBEDGX
 N LRBEPOV,LRBEPTDT,LRBETNUM
 S (LRBEPOV,LRBETNUM)=""  F  S LRBEPOV=$O(LRBEAR1(LRBETST,LRBEDN,LRBEPOV)) Q:'LRBEPOV  D
 . S LRBEPTDT=$G(LRBEAR1(LRBETST,LRBEDN,LRBEPOV))
 . S LRBETNUM=$G(LRBETNUM)+1,LRBEDGX(LRBETST,LRBETNUM)=$P(LRBEPTDT,U,1)
  Q:$D(LRBEDGX(LRBETST,1))
 N DGX S DGX=0
 F  S DGX=$O(LRBEAR(LRBEDFN,"LRBEDGX",LRSAMP,LRSPEC,LRBETST,DGX)) Q:DGX<1  D
 . S LRBETNUM=$G(LRBETNUM)+1,LRBEDGX(LRBETST,LRBETNUM)=DGX
 Q
GOREF(LRODT,LRSN,LRBEDN,LRBEAR1,LRORREFN) ;
 ;Get the OERR INTERNAL FILE #
 N LRX1,LRBEIEN1,LRBETST
 S LRBETST=""
 F  S LRBETST=$O(LRBEAR1(LRBETST)) Q:LRBETST=""  D
 .Q:'$D(LRBEAR1(LRBETST,LRBEDN))
 .S LRX1=$O(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
 .I $G(LRX1) D  Q
 ..S LRBEIEN1=LRX1_","_LRSN_","_LRODT_","
 ..S LRORREFN=$$GET1^DIQ(69.03,LRBEIEN1,6,"I")
 .S LRORREFN=""
 Q
 ;
GMOD(LRBEAA,LRBECPT) ; Get external service modifier
 ;input LRBECPT - ien to #81, not required
 N DIC,LRBEESA,LRBEMOD,MOD,STAT,X,Y
 S LRBEESA=$$GET1^DIQ(68,LRBEAA_",",12,"I"),LRBEMOD=""
 I LRBEESA D
 .S X=90,DIC="^DIC(81.3,",DIC(0)="Z" D ^DIC
 .I +Y<0 K DIC Q
 .S LRBEMOD=$P(Y,U,2),MOD=+Y
 .;if cpt/hcpcs provided, check if modifier is valid to use
 .I $G(LRBECPT) D
 ..S STAT=$$MODP^ICPTMOD(LRBECPT,MOD,"I",DT)
 ..I +STAT=0 S LRBEMOD=""
 Q LRBEMOD