Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRBEBA21

LRBEBA21.m

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