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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRBEBA21 7582 printed Nov 22, 2024@17:20:03 Page 2
LRBEBA21 ;DALOI/JAH/FHS - PROCESS PANEL CPT CODE ;8/10/04
+1 ;;5.2;LAB SERVICE;**291,359**;Sep 27, 1994
+2 ;Continued LRBEBA2
+3 ;Process panel test for CPT
+4 ;Set 13th piece of LRSB(X) to prevent double counting
EN(LRBE21) ;LRBEAR1(LRBETST,
+1 ;Returns LRBE21
+2 ; 0 = process as atomic test
+3 ; 1 = processed (or will be processed in future) as panel
+4 NEW LRI,LRY,LRTST,LRNOP,LRNP,LRPEND,LRCANC,LRBSB,LRFDA,ERR,OK
+5 NEW LRBECDT,LRBEEDT,LRORREFN,LRPCECNT,LRBEQTY,LRNOREQ,LRBESTG
+6 SET (LRBE21,LRPCECNT,LRNP,LRNOP,LRPEND,LRCANC)=0
+7 IF $DATA(LRBEAR1(LRBETST))
Begin DoDot:1
+8 ;must be AMA/billable panel
+9 if '($DATA(LRBEPAN(LRBETST)))
QUIT
+10 SET LRY=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
+11 if 'LRY
QUIT
+12 SET LRY=LRY_","_LRSN_","_LRODT_","
+13 ;canceled test
+14 IF $$GET1^DIQ(69.03,LRY,8,"I")="CA"
KILL LRY
QUIT
+15 SET LRBECDT=$$GET1^DIQ(69.03,LRY,22,"I")
+16 IF 'LRBECDT
KILL LRY
QUIT
+17 IF '$GET(LRBERES)
SET LRPCECNT=$$GET1^DIQ(69.03,LRY,11,"I")
+18 IF LRPCECNT
KILL LRY
QUIT
+19 SET LRORREFN=$$GET1^DIQ(69.03,LRY,6,"I")
+20 IF $GET(ORIEN)
IF LRORREFN'=ORIEN
KILL LRY
QUIT
+21 ;check status of atomic tests
+22 SET LRNOREQ=1
+23 SET LRBSB=0
FOR
SET LRBSB=$ORDER(LRBEAR1(LRBETST,LRBSB))
if 'LRBSB
QUIT
IF $GET(LRIDT)
Begin DoDot:2
+24 ;check only 'required' atomic tests
+25 if '$DATA(LRBEAR1(LRBETST,LRBSB,"R"))
QUIT
+26 SET LRTST=+LRBEAR1(LRBETST,LRBSB,"R")
+27 SET X=$GET(LRBESB(LRBSB))
IF 'LRTST
SET LRTST=+$PIECE($PIECE(X,"^",3),"!",7)
+28 IF X=""
SET X=$GET(^LR(LRDFN,LRSS,LRIDT,LRBSB))
if (X'="")
SET LRBESB(LRBSB)=X
if (X="")
SET X="pending"
+29 ;check for not performed tests
+30 IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST,0)),U,6)="*Not Performed"
SET LRNP=1
+31 ;check for tests already sent to pce
+32 IF $PIECE(X,U,13)=1
SET LRNOP=1
QUIT
+33 ;check for cancelled tests
+34 IF $PIECE(X,U,1)="canc"
SET LRCANC=1
+35 ;check for tests still pending
+36 IF $PIECE(X,U,1)="pending"
SET LRPEND=1
+37 SET LRNOREQ=0
End DoDot:2
+38 ;quit if any 'required' atomic tests not performed or cancelled
+39 if ((LRNOREQ=0)&(LRNP!LRCANC))
QUIT
+40 ;check for resulted tests in panel with no 'required' tests
+41 SET OK=0
+42 IF LRNOREQ
SET LRBSB=0
FOR
SET LRBSB=$ORDER(LRBEAR1(LRBETST,LRBSB))
if 'LRBSB!($GET(LRNP))
QUIT
Begin DoDot:2
+43 SET X=$GET(LRBESB(LRBSB))
SET LRTST=+$PIECE($PIECE(X,"^",3),"!",7)
+44 IF $PIECE(X,U,1)'=""
IF $PIECE(X,U,1)'="canc"
IF $PIECE(X,U,1)'="pending"
SET OK=1
+45 ;check for not performed tests
+46 IF $PIECE($GET(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTST,0)),U,6)="*Not Performed"
SET LRNP=1
End DoDot:2
+47 ;quit if no 'required' tests on panel and no resulted tests
+48 if (LRNOREQ&'OK)
QUIT
+49 ;if not roll-up to PCE, proceed to panel CPT;
+50 ;including case where none of atomic tests are 'required' (if results available)
+51 IF '$GET(LRBEROLL)
DO PANEL^LRBEBA4
IF $ORDER(LRBECPT(LRBETST,0))
Begin DoDot:2
+52 SET LRI=0
FOR
SET LRI=$ORDER(LRBECPT(LRBETST,LRI))
if LRI<1
QUIT
Begin DoDot:3
+53 SET LRBECPT=$ORDER(LRBECPT(LRBETST,LRI,0))
+54 SET LRBEMOD=$$GMOD^LRBEBA2(LRAA,LRBECPT)
+55 SET LRBEPOS=DUZ
SET LRBEQTY=1
SET LRBEDN=+$ORDER(LRBEAR1(LRBETST,0))
+56 DO GDGX^LRBEBA21(LRBETST,LRBEDN,.LRBEAR,.LRBEAR1,.LRBEDGX)
+57 SET LRBESTG=LRBECPT_U_$GET(LRBEMOD)_U_$GET(LRBEDGX(LRBETST,1))_U_$GET(LRBEDGX(LRBETST,2))_U_$GET(LRBEDGX(LRBETST,3))
+58 SET LRBESTG=LRBESTG_U_$GET(LRBEDGX(LRBETST,4))_U_LRBECDT_U_LRBEEPRO_U_LRBEOPRO_U_LRBEQTY_U_LRBEPOS
+59 SET LRBESTG=LRBESTG_U_$GET(LRBEDGX(LRBETST,5))_U_$GET(LRBEDGX(LRBETST,6))_U_$GET(LRBEDGX(LRBETST,7))
+60 SET LRBESTG=LRBESTG_U_$GET(LRBEDGX(LRBETST,8))_U_LRORREFN
+61 IF $GET(LRBECPT(LRBETST,LRI,LRBECPT,"COUNT"))
SET $PIECE(LRBESTG,U,20)=LRBECPT(LRBETST,LRI,LRBECPT,"COUNT")+1
+62 SET LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBETST)=LRBESTG
End DoDot:3
End DoDot:2
End DoDot:1
+63 ;
+64 if $GET(LRY)=""
QUIT
+65 ;
+66 ;if PCE rollup, then 'unbundled' in SOP2^LRBEBA2
+67 IF $GET(LRBEROLL)
Begin DoDot:1
+68 KILL LRBECPT(LRBETST)
+69 ;clear 'pending panel' xref
+70 SET LRFDA(1,69.03,LRY,22.1)=0
+71 DO FILE^DIE("KS","LRFDA(1)","ERR")
End DoDot:1
QUIT
+72 ;
+73 ;if no required tests on panel and panel CPT exists, at least one resulted atomic,
+74 ;then mark panel as processed; retain LRBECPT array for BAWRK^LRBEBA;
+75 ;set return to "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
+76 IF $ORDER(LRBECPT(LRBETST,0))
IF LRNOREQ
Begin DoDot:1
+77 SET LRBE21=1
+78 DO LRSB
+79 SET LRFDA(1,69.03,LRY,11)=1
+80 ;clear 'pending panel' xref
+81 SET LRFDA(1,69.03,LRY,22.1)=0
+82 DO FILE^DIE("KS","LRFDA(1)","ERR")
End DoDot:1
QUIT
+83 ;
+84 ;if no required tests on panel and panel has no CPT or inactive CPT,
+85 ;then return is "0" for 'unbundled' processing in SOP2^LRBEBA2
+86 IF '$ORDER(LRBECPT(LRBETST,0))
IF LRNOREQ
QUIT
+87 ;
+88 ;if resending (from WORK^LRBEBA4) and panel CPT determined,
+89 ;then return "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
+90 IF $GET(LRBERES)&LRNOP&('LRPEND)&($ORDER(LRBECPT(LRBETST,0)))
SET LRBE21=1
QUIT
+91 ;
+92 ;if required atomic tests not performed, previously sent, or cancelled,
+93 ;then return is "0" for 'unbundled' processing in SOP2^LRBEBA2
+94 IF (LRNP!LRNOP!LRCANC)
Begin DoDot:1
+95 KILL LRBECPT(LRBETST)
+96 ;clear 'pending panel' xref
+97 SET LRFDA(1,69.03,LRY,22.1)=0
+98 DO FILE^DIE("KS","LRFDA(1)","ERR")
End DoDot:1
QUIT
+99 ;
+100 ;if panel has CPT and no required atomic test still pending,
+101 ;then mark panel as processed; retain LRBECPT array for BAWRK^LRBEBA;
+102 ;set return to "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
+103 IF $ORDER(LRBECPT(LRBETST,0))
IF 'LRPEND
Begin DoDot:1
+104 SET LRBE21=1
+105 DO LRSB
+106 SET LRFDA(1,69.03,LRY,11)=1
+107 ;clear 'pending panel' xref
+108 SET LRFDA(1,69.03,LRY,22.1)=0
+109 DO FILE^DIE("KS","LRFDA(1)","ERR")
End DoDot:1
QUIT
+110 ;
+111 ;if panel has no CPT or inactive CPT, but required atomic test still pending,
+112 ;then set return to "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
+113 IF '$ORDER(LRBECPT(LRBETST,0))
IF LRPEND
Begin DoDot:1
+114 SET LRBE21=1
+115 ;set 'pending panel' xref
+116 SET LRFDA(1,69.03,LRY,22.1)=1
+117 DO FILE^DIE("KS","LRFDA(1)","ERR")
End DoDot:1
QUIT
+118 ;
+119 ;if panel has CPT, but required atomic test still pending,
+120 ;then kill cpt to avoid transmission to PCE,
+121 ;set return to "1" to avoid 'unbundled' processing in SOP2^LRBEBA2
+122 IF $ORDER(LRBECPT(LRBETST,0))
IF LRPEND
Begin DoDot:1
+123 SET LRBE21=1
+124 SET LRI=$ORDER(LRBECPT(LRBETST,0))
KILL LRBEAR(LRBEDFN,"LRBEDGX",LRI,LRBETST)
+125 KILL LRBECPT(LRBETST)
+126 ;set 'pending panel' xref
+127 SET LRFDA(1,69.03,LRY,22.1)=1
+128 DO FILE^DIE("KS","LRFDA(1)","ERR")
End DoDot:1
+129 ;
+130 QUIT
+131 ;
LRSB ;Set LRBESB(TEST) 13th piece to 1, counted as part of panel.
+1 ;Set 13th piece of LRBESB(X) to prevent double counting
+2 NEW LRSBX
+3 SET LRSBX=0
FOR
SET LRSBX=$ORDER(LRBEAR1(LRBETST,LRSBX))
if LRSBX<1
QUIT
Begin DoDot:1
+4 IF $DATA(LRBESB(LRSBX))#2
SET $PIECE(LRBESB(LRSBX),U,13)=1
+5 IF $GET(LRIDT)
IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRSBX))
SET $PIECE(^(LRSBX),U,13)=1
End DoDot:1
+6 QUIT
+7 ;
GDGX(LRBETST,LRBEDN,LRBEAR,LRBEAR1,LRBEDGX) ; Set diagnosis LRBEDGX
+1 NEW LRBEPOV,LRBEPTDT,LRBETNUM
+2 SET (LRBEPOV,LRBETNUM)=""
FOR
SET LRBEPOV=$ORDER(LRBEAR1(LRBETST,LRBEDN,LRBEPOV))
if 'LRBEPOV
QUIT
Begin DoDot:1
+3 SET LRBEPTDT=$GET(LRBEAR1(LRBETST,LRBEDN,LRBEPOV))
+4 SET LRBETNUM=$GET(LRBETNUM)+1
SET LRBEDGX(LRBETST,LRBETNUM)=$PIECE(LRBEPTDT,U,1)
End DoDot:1
+5 if $DATA(LRBEDGX(LRBETST,1))
QUIT
+6 NEW DGX
SET DGX=0
+7 FOR
SET DGX=$ORDER(LRBEAR(LRBEDFN,"LRBEDGX",LRSAMP,LRSPEC,LRBETST,DGX))
if DGX<1
QUIT
Begin DoDot:1
+8 SET LRBETNUM=$GET(LRBETNUM)+1
SET LRBEDGX(LRBETST,LRBETNUM)=DGX
End DoDot:1
+9 QUIT
GOREF(LRODT,LRSN,LRBEDN,LRBEAR1,LRORREFN) ;
+1 ;Get the OERR INTERNAL FILE #
+2 NEW LRX1,LRBEIEN1,LRBETST
+3 SET LRBETST=""
+4 FOR
SET LRBETST=$ORDER(LRBEAR1(LRBETST))
if LRBETST=""
QUIT
Begin DoDot:1
+5 if '$DATA(LRBEAR1(LRBETST,LRBEDN))
QUIT
+6 SET LRX1=$ORDER(^LRO(69,LRODT,1,LRSN,2,"B",LRBETST,0))
+7 IF $GET(LRX1)
Begin DoDot:2
+8 SET LRBEIEN1=LRX1_","_LRSN_","_LRODT_","
+9 SET LRORREFN=$$GET1^DIQ(69.03,LRBEIEN1,6,"I")
End DoDot:2
QUIT
+10 SET LRORREFN=""
End DoDot:1
+11 QUIT
+12 ;
GMOD(LRBEAA,LRBECPT) ; Get external service modifier
+1 ;input LRBECPT - ien to #81, not required
+2 NEW DIC,LRBEESA,LRBEMOD,MOD,STAT,X,Y
+3 SET LRBEESA=$$GET1^DIQ(68,LRBEAA_",",12,"I")
SET LRBEMOD=""
+4 IF LRBEESA
Begin DoDot:1
+5 SET X=90
SET DIC="^DIC(81.3,"
SET DIC(0)="Z"
DO ^DIC
+6 IF +Y<0
KILL DIC
QUIT
+7 SET LRBEMOD=$PIECE(Y,U,2)
SET MOD=+Y
+8 ;if cpt/hcpcs provided, check if modifier is valid to use
+9 IF $GET(LRBECPT)
Begin DoDot:2
+10 SET STAT=$$MODP^ICPTMOD(LRBECPT,MOD,"I",DT)
+11 IF +STAT=0
SET LRBEMOD=""
End DoDot:2
End DoDot:1
+12 QUIT LRBEMOD
