LRBEBA31 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ;8/10/04
;;5.2;LAB SERVICE;**1031**;Nov 1, 1997
;
;;VA LR Patche(s): 291
;
DADD(LRODT,LRSN,LRBETN,LRXDA,LRTS,LRBERF) ; Take care of ADDs to accession
Q:'$$MODEXIST^BLRUTIL4("IB") ; IHS/MSC/MKK - LR*5.2*1031
;
N LRBEALO,LRBEAALO,LRBEFN,LRBEX,LRBEVAL,LRBEXD,LRBEQT,LRBESPEC,LRBESAMP
Q:'$$CIDC^IBBAPI(DFN)
S LRBERF=$G(LRBERF)
S LRBEVAL=$D(^XUSEC("PROVIDER",DUZ))
S LRBEFN="O",LRBEDFN=DFN
S X=^LRO(69,LRODT,1,LRSN,0),LRBESAMP=$P(X,"^",3) K X
S LRBESPEC=$O(^LRO(69,LRODT,1,LRSN,4,0))
S LRBESPEC=$S(LRBESPEC>0:$P(^LRO(69,LRODT,1,LRSN,4,LRBESPEC,0),"^",1),1:"")
I LRBERF=1 D
. D QRYADD^LRBEBA3(LRODT,LRSN,LRBETN,LRBEDFN,LRBESAMP,LRBESPEC,LRTS,.LRBEX)
. D SACC^LRBEBA2(LRODT,LRSN,LRXDA,LRBESAMP,LRBESPEC,LRTS,.LRBEX)
I LRBEVAL,LRBERF=0 D
. D ELIG^LRBEBA3(LRBEDFN)
. S LRBEQT=$$QUES^LRBEBA(LRBEDFN,LRBESAMP,LRBESPEC,LRTS,LRODT,.LRBEX)
. D:'LRBEQT SACC^LRBEBA2(LRODT,LRSN,LRXDA,LRBESAMP,LRBESPEC,LRTS,.LRBEX)
Q
;
SBA(LRDFN,LRBEX,LRBEQT,LROT) ; billing questions
N LRBECNT,LRBEST,LRBEDFN,LRBESMP,LRBESPC,LRBEY,LRBETN,LRBEQT
N LRBEOT,LRBETS,LRBEMSG,LRBEPTDT
I '$D(DFN) S LRBEDFN=$$GET1^DIQ(63,LRDFN,.03,"I")
S:$D(DFN) LRBEDFN=DFN
D:$G(LRBEAT)=1 ELIG^LRBEBA3(LRBEDFN)
S LRBEST=1,LRBEQT=0
S LRBESMP="" F S LRBESMP=$O(LROT(LRBESMP)) Q:LRBESMP=""!(LRBEQT) D
.S LRBESPC="" F S LRBESPC=$O(LROT(LRBESMP,LRBESPC)) Q:LRBESPC="" D
..S LRBEY="" F S LRBEY=$O(LROT(LRBESMP,LRBESPC,LRBEY)) Q:LRBEY="" D
...S LRBEOT(LRBEY,LRBESMP,LRBESPC)=""
S LRBEY="" F S LRBEY=$O(LRBEOT(LRBEY)) Q:LRBEY="" D
.S LRBESMP="" F S LRBESMP=$O(LRBEOT(LRBEY,LRBESMP)) Q:LRBESMP=""!(LRBEQT) D
..S LRBESPC="" F S LRBESPC=$O(LRBEOT(LRBEY,LRBESMP,LRBESPC)) Q:LRBESPC="" D
...S LRBEPTDT=$G(LROT(LRBESMP,LRBESPC,LRBEY)),LRBETS=$P(LRBEPTDT,U,1)
...S LRBETN=$$GET1^DIQ(60,LRBETS_",",.01)
...S LRBEMSG="Enter information for "_LRBETN D EN^DDIOL(LRBEMSG,"","!")
...S:$G(LRBEAT)'=1 LRBEALO=1
...S LRBEQT=$$QUES^LRBEBA(LRBEDFN,LRBESMP,LRBESPC,LRBETS,LRODT,.LRBEX)
...S:LRBEQT LRBEST=0 Q:LRBEQT
...D EN^DDIOL("","","!")
Q LRBEST
LRBEBA31 ;DALOI/JAH/FHS - ORDERING AND RESULTING OUTPATIENT ;8/10/04
+1 ;;5.2;LAB SERVICE;**1031**;Nov 1, 1997
+2 ;
+3 ;;VA LR Patche(s): 291
+4 ;
DADD(LRODT,LRSN,LRBETN,LRXDA,LRTS,LRBERF) ; Take care of ADDs to accession
+1 ; IHS/MSC/MKK - LR*5.2*1031
IF '$$MODEXIST^BLRUTIL4("IB")
QUIT
+2 ;
+3 NEW LRBEALO,LRBEAALO,LRBEFN,LRBEX,LRBEVAL,LRBEXD,LRBEQT,LRBESPEC,LRBESAMP
+4 IF '$$CIDC^IBBAPI(DFN)
QUIT
+5 SET LRBERF=$GET(LRBERF)
+6 SET LRBEVAL=$DATA(^XUSEC("PROVIDER",DUZ))
+7 SET LRBEFN="O"
SET LRBEDFN=DFN
+8 SET X=^LRO(69,LRODT,1,LRSN,0)
SET LRBESAMP=$PIECE(X,"^",3)
KILL X
+9 SET LRBESPEC=$ORDER(^LRO(69,LRODT,1,LRSN,4,0))
+10 SET LRBESPEC=$SELECT(LRBESPEC>0:$PIECE(^LRO(69,LRODT,1,LRSN,4,LRBESPEC,0),"^",1),1:"")
+11 IF LRBERF=1
Begin DoDot:1
+12 DO QRYADD^LRBEBA3(LRODT,LRSN,LRBETN,LRBEDFN,LRBESAMP,LRBESPEC,LRTS,.LRBEX)
+13 DO SACC^LRBEBA2(LRODT,LRSN,LRXDA,LRBESAMP,LRBESPEC,LRTS,.LRBEX)
End DoDot:1
+14 IF LRBEVAL
IF LRBERF=0
Begin DoDot:1
+15 DO ELIG^LRBEBA3(LRBEDFN)
+16 SET LRBEQT=$$QUES^LRBEBA(LRBEDFN,LRBESAMP,LRBESPEC,LRTS,LRODT,.LRBEX)
+17 IF 'LRBEQT
DO SACC^LRBEBA2(LRODT,LRSN,LRXDA,LRBESAMP,LRBESPEC,LRTS,.LRBEX)
End DoDot:1
+18 QUIT
+19 ;
SBA(LRDFN,LRBEX,LRBEQT,LROT) ; billing questions
+1 NEW LRBECNT,LRBEST,LRBEDFN,LRBESMP,LRBESPC,LRBEY,LRBETN,LRBEQT
+2 NEW LRBEOT,LRBETS,LRBEMSG,LRBEPTDT
+3 IF '$DATA(DFN)
SET LRBEDFN=$$GET1^DIQ(63,LRDFN,.03,"I")
+4 IF $DATA(DFN)
SET LRBEDFN=DFN
+5 IF $GET(LRBEAT)=1
DO ELIG^LRBEBA3(LRBEDFN)
+6 SET LRBEST=1
SET LRBEQT=0
+7 SET LRBESMP=""
FOR
SET LRBESMP=$ORDER(LROT(LRBESMP))
IF LRBESMP=""!(LRBEQT)
QUIT
Begin DoDot:1
+8 SET LRBESPC=""
FOR
SET LRBESPC=$ORDER(LROT(LRBESMP,LRBESPC))
IF LRBESPC=""
QUIT
Begin DoDot:2
+9 SET LRBEY=""
FOR
SET LRBEY=$ORDER(LROT(LRBESMP,LRBESPC,LRBEY))
IF LRBEY=""
QUIT
Begin DoDot:3
+10 SET LRBEOT(LRBEY,LRBESMP,LRBESPC)=""
End DoDot:3
End DoDot:2
End DoDot:1
+11 SET LRBEY=""
FOR
SET LRBEY=$ORDER(LRBEOT(LRBEY))
IF LRBEY=""
QUIT
Begin DoDot:1
+12 SET LRBESMP=""
FOR
SET LRBESMP=$ORDER(LRBEOT(LRBEY,LRBESMP))
IF LRBESMP=""!(LRBEQT)
QUIT
Begin DoDot:2
+13 SET LRBESPC=""
FOR
SET LRBESPC=$ORDER(LRBEOT(LRBEY,LRBESMP,LRBESPC))
IF LRBESPC=""
QUIT
Begin DoDot:3
+14 SET LRBEPTDT=$GET(LROT(LRBESMP,LRBESPC,LRBEY))
SET LRBETS=$PIECE(LRBEPTDT,U,1)
+15 SET LRBETN=$$GET1^DIQ(60,LRBETS_",",.01)
+16 SET LRBEMSG="Enter information for "_LRBETN
DO EN^DDIOL(LRBEMSG,"","!")
+17 IF $GET(LRBEAT)'=1
SET LRBEALO=1
+18 SET LRBEQT=$$QUES^LRBEBA(LRBEDFN,LRBESMP,LRBESPC,LRBETS,LRODT,.LRBEX)
+19 IF LRBEQT
SET LRBEST=0
IF LRBEQT
QUIT
+20 DO EN^DDIOL("","","!")
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT LRBEST
