- 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
