IBNCPDP6 ;OAK/ELZ - TRICARE NCPDP TOOLS; 02-AUG-96
;;2.0;INTEGRATED BILLING;**383,384,411,452,526**;21-MAR-94;Build 17
;;Per VHA Directive 6402, this routine should not be modified.
;
START(IBKEY,IBELIG,IBRT) ; initial storage done during
; billing determination check (updates allowed)
; Input: IBKEY -- 1 ; 2, where
; 1 = Pointer to the prescription in file #52
; 2 = Pointer to the refill in file #52.1, or
; 0 for the original fill
; IBELIG -- single character indicating elig indicator
; V = VETERAN
; T = TRICARE
; C = CHAMPVA
; IBRT -- Rate type pointer to be used for the bill later
;
N IBCHTRN,DO,DIC,X,Y,DIE,DA,DR
S IBCHTRN=$O(^IBCNR(366.15,"B",IBKEY,0))
I 'IBCHTRN D
. S DIC="^IBCNR(366.15,",DIC(0)="",X=IBKEY D FILE^DICN
. S IBCHTRN=+Y
S DIE="^IBCNR(366.15,",DA=IBCHTRN,DR=".02////^S X=IBELIG;.03////^S X=IBRT"
D ^DIE
Q
;
BILL(IBKEY,IBCHG,IBRT) ; Create the TRICARE Rx copay charge.
; Input: IBKEY -- 1 ; 2, where
; 1 = Pointer to the prescription in file #52
; 2 = Pointer to the refill in file #52.1, or
; 0 for the original fill
; IBCHG -- charge amount
; IBRT -- rate type on 3rd party (optional)
;
N IBCHTRN,IBY,IBATYP,IBSERV,IBDESC,IBUNIT,IBSL,IBFR,DA,DIE,DR,DFN,IBN,IBZ
;
S IBY=1
I '$G(IBKEY) G BILLQ
S IBCHTRN=$O(^IBCNR(366.15,"B",IBKEY,0))
I 'IBCHTRN G BILLQ
S IBZ=$G(^IBCNR(366.15,IBCHTRN,0))
;
; - TRICARE?
I $P(IBZ,"^",2)'="T",'$G(IBRT) G BILLQ
I $G(IBRT),$P($G(^DGCR(399.3,IBRT,0)),"^")'="TRICARE" G BILLQ
;
; - already billed, need to cancel to bill
I $P(IBZ,"^",4) D CANC(IBKEY)
;
I $$FILE^IBRXUTL(+IBKEY,.01)="" G BILLQ
;
; - need patient
S DFN=$$FILE^IBRXUTL(+IBKEY,2)
I 'DFN S IBY="-1^IB002" G BILLQ
;
; - need action type
S IBATYP=$O(^IBE(350.1,"E","TRICARE RX COPAY",0))
I 'IBATYP S IBY="-1^IB008" G BILLQ
;
; - need facility number
I '$$CHECK^IBECEAU(0) S IBY="-1^IB009" G BILLQ
;
; - need the Pharmacy service pointer; get from #350.1 and check it
S IBSERV=$P($G(^IBE(350.1,1,0)),"^",4)
I '$$SERV^IBARX1(IBSERV) S IBY="-1^IB003" G BILLQ
;
; - need a charge amount
S IBCHG=+$G(IBCHG)
I 'IBCHG S IBY="-1^IB029" G BILLQ
;
; - set remaining variables
S IBDESC="TRICARE RX COPAY",IBUNIT=1
S IBSL="52:"_+IBKEY S:$P(IBKEY,";",2) IBSL=IBSL_";1:"_$P(IBKEY,";",2)
S IBFR=DT
;
; - add the charge to file #350
D ADD^IBECEAU3 I IBY<0 G BILLQ
;
; *526 set approving official #4129
I '$D(^VA(200,DUZ,0)) D DUZ^XUP(.5)
; - release the charge to AR
D AR^IBR
;
; - update the rx file (#366.15)
S DA=IBCHTRN,DIE="^IBCNR(366.15,",DR=".04////"_IBN D ^DIE K DA,DIE,DR
;
BILLQ ;
I IBY<0 D ERRMSG^IBACVA2(1,2)
;
Q
;
;
CANC(IBKEY) ; Cancel the TRICARE Rx copay charge.
; Input: IBKEY -- 1 ; 2, where
; 1 = Pointer to the prescription in file #52
; 2 = Pointer to the refill in file #52.1, or
; 0 for the original fill
;
N IBCHTRND,IBDUZ,IBN,IBCRES,DFN,IBSITE,IBFAC,IBND,IBPARNT,IBCANC,IBH,IBCANTR,IBXA,IBATYP,IBSEQNO,IBIL,IBUNIT,IBCHG,IBFR,DIE,DA,DR,IBCHTRN,IBY
;
S IBY=1,IBDUZ=DUZ
S IBCHTRN=$O(^IBCNR(366.15,"B",IBKEY,0))
I 'IBCHTRN G CANCQ
S IBCHTRND=$G(^IBCNR(366.15,IBCHTRN,0)),DFN=$$FILE^IBRXUTL(+IBKEY,2)
S IBN=+$P(IBCHTRND,"^",4) I 'IBN G CANCQ
I '$$CHECK^IBECEAU(0) S IBY="-1^IB009" G CANCQ
S IBCRES=$O(^IBE(350.3,"B","RX CANCELLED",0)) S:'IBCRES IBCRES=5
;
; - cancel the charge
D CED^IBECEAU4(IBN) I IBY<0 G CANCQ
D CANC^IBECEAU4(IBN,IBCRES,1)
;
S DIE="^IBCNR(366.15,",DA=IBCHTRN,DR=".04///@" D ^DIE
CANCQ ;
I IBY<0 D ERRMSG^IBACVA2(0,2)
;
Q
;
RT(IBKEY) ; returns rate type previously determined
Q $P($G(^IBCNR(366.15,+$O(^IBCNR(366.15,"B",IBKEY,0)),0)),"^",3)
;
TRICARE(IBKEY) ; returns if the Key is RT TRICARE
N IBRT
S IBRT=+$$RT(IBKEY)
Q $S($P($G(^DGCR(399.3,IBRT,0)),"^")["TRICARE":1,1:0)
;
;gets the insurance phone
;input:
; IB36 - ptr to INSURANCE COMPANY File (#36)
;output:
; the phone number
PHONE(IB36) ;
N IB1
;check first CLAIMS (RX) PHONE NUMBER if empty
S IB1=$$GET1^DIQ(36,+IB36,.1311,"E")
Q:$L(IB1)>0 IB1
;check BILLING PHONE NUMBER if empty - return nothing
S IB1=$$GET1^DIQ(36,+IB36,.132,"E")
Q IB1
;IBNCPDP6
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPDP6 4588 printed Dec 13, 2024@02:24:41 Page 2
IBNCPDP6 ;OAK/ELZ - TRICARE NCPDP TOOLS; 02-AUG-96
+1 ;;2.0;INTEGRATED BILLING;**383,384,411,452,526**;21-MAR-94;Build 17
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
START(IBKEY,IBELIG,IBRT) ; initial storage done during
+1 ; billing determination check (updates allowed)
+2 ; Input: IBKEY -- 1 ; 2, where
+3 ; 1 = Pointer to the prescription in file #52
+4 ; 2 = Pointer to the refill in file #52.1, or
+5 ; 0 for the original fill
+6 ; IBELIG -- single character indicating elig indicator
+7 ; V = VETERAN
+8 ; T = TRICARE
+9 ; C = CHAMPVA
+10 ; IBRT -- Rate type pointer to be used for the bill later
+11 ;
+12 NEW IBCHTRN,DO,DIC,X,Y,DIE,DA,DR
+13 SET IBCHTRN=$ORDER(^IBCNR(366.15,"B",IBKEY,0))
+14 IF 'IBCHTRN
Begin DoDot:1
+15 SET DIC="^IBCNR(366.15,"
SET DIC(0)=""
SET X=IBKEY
DO FILE^DICN
+16 SET IBCHTRN=+Y
End DoDot:1
+17 SET DIE="^IBCNR(366.15,"
SET DA=IBCHTRN
SET DR=".02////^S X=IBELIG;.03////^S X=IBRT"
+18 DO ^DIE
+19 QUIT
+20 ;
BILL(IBKEY,IBCHG,IBRT) ; Create the TRICARE Rx copay charge.
+1 ; Input: IBKEY -- 1 ; 2, where
+2 ; 1 = Pointer to the prescription in file #52
+3 ; 2 = Pointer to the refill in file #52.1, or
+4 ; 0 for the original fill
+5 ; IBCHG -- charge amount
+6 ; IBRT -- rate type on 3rd party (optional)
+7 ;
+8 NEW IBCHTRN,IBY,IBATYP,IBSERV,IBDESC,IBUNIT,IBSL,IBFR,DA,DIE,DR,DFN,IBN,IBZ
+9 ;
+10 SET IBY=1
+11 IF '$GET(IBKEY)
GOTO BILLQ
+12 SET IBCHTRN=$ORDER(^IBCNR(366.15,"B",IBKEY,0))
+13 IF 'IBCHTRN
GOTO BILLQ
+14 SET IBZ=$GET(^IBCNR(366.15,IBCHTRN,0))
+15 ;
+16 ; - TRICARE?
+17 IF $PIECE(IBZ,"^",2)'="T"
IF '$GET(IBRT)
GOTO BILLQ
+18 IF $GET(IBRT)
IF $PIECE($GET(^DGCR(399.3,IBRT,0)),"^")'="TRICARE"
GOTO BILLQ
+19 ;
+20 ; - already billed, need to cancel to bill
+21 IF $PIECE(IBZ,"^",4)
DO CANC(IBKEY)
+22 ;
+23 IF $$FILE^IBRXUTL(+IBKEY,.01)=""
GOTO BILLQ
+24 ;
+25 ; - need patient
+26 SET DFN=$$FILE^IBRXUTL(+IBKEY,2)
+27 IF 'DFN
SET IBY="-1^IB002"
GOTO BILLQ
+28 ;
+29 ; - need action type
+30 SET IBATYP=$ORDER(^IBE(350.1,"E","TRICARE RX COPAY",0))
+31 IF 'IBATYP
SET IBY="-1^IB008"
GOTO BILLQ
+32 ;
+33 ; - need facility number
+34 IF '$$CHECK^IBECEAU(0)
SET IBY="-1^IB009"
GOTO BILLQ
+35 ;
+36 ; - need the Pharmacy service pointer; get from #350.1 and check it
+37 SET IBSERV=$PIECE($GET(^IBE(350.1,1,0)),"^",4)
+38 IF '$$SERV^IBARX1(IBSERV)
SET IBY="-1^IB003"
GOTO BILLQ
+39 ;
+40 ; - need a charge amount
+41 SET IBCHG=+$GET(IBCHG)
+42 IF 'IBCHG
SET IBY="-1^IB029"
GOTO BILLQ
+43 ;
+44 ; - set remaining variables
+45 SET IBDESC="TRICARE RX COPAY"
SET IBUNIT=1
+46 SET IBSL="52:"_+IBKEY
if $PIECE(IBKEY,";",2)
SET IBSL=IBSL_";1:"_$PIECE(IBKEY,";",2)
+47 SET IBFR=DT
+48 ;
+49 ; - add the charge to file #350
+50 DO ADD^IBECEAU3
IF IBY<0
GOTO BILLQ
+51 ;
+52 ; *526 set approving official #4129
+53 IF '$DATA(^VA(200,DUZ,0))
DO DUZ^XUP(.5)
+54 ; - release the charge to AR
+55 DO AR^IBR
+56 ;
+57 ; - update the rx file (#366.15)
+58 SET DA=IBCHTRN
SET DIE="^IBCNR(366.15,"
SET DR=".04////"_IBN
DO ^DIE
KILL DA,DIE,DR
+59 ;
BILLQ ;
+1 IF IBY<0
DO ERRMSG^IBACVA2(1,2)
+2 ;
+3 QUIT
+4 ;
+5 ;
CANC(IBKEY) ; Cancel the TRICARE Rx copay charge.
+1 ; Input: IBKEY -- 1 ; 2, where
+2 ; 1 = Pointer to the prescription in file #52
+3 ; 2 = Pointer to the refill in file #52.1, or
+4 ; 0 for the original fill
+5 ;
+6 NEW IBCHTRND,IBDUZ,IBN,IBCRES,DFN,IBSITE,IBFAC,IBND,IBPARNT,IBCANC,IBH,IBCANTR,IBXA,IBATYP,IBSEQNO,IBIL,IBUNIT,IBCHG,IBFR,DIE,DA,DR,IBCHTRN,IBY
+7 ;
+8 SET IBY=1
SET IBDUZ=DUZ
+9 SET IBCHTRN=$ORDER(^IBCNR(366.15,"B",IBKEY,0))
+10 IF 'IBCHTRN
GOTO CANCQ
+11 SET IBCHTRND=$GET(^IBCNR(366.15,IBCHTRN,0))
SET DFN=$$FILE^IBRXUTL(+IBKEY,2)
+12 SET IBN=+$PIECE(IBCHTRND,"^",4)
IF 'IBN
GOTO CANCQ
+13 IF '$$CHECK^IBECEAU(0)
SET IBY="-1^IB009"
GOTO CANCQ
+14 SET IBCRES=$ORDER(^IBE(350.3,"B","RX CANCELLED",0))
if 'IBCRES
SET IBCRES=5
+15 ;
+16 ; - cancel the charge
+17 DO CED^IBECEAU4(IBN)
IF IBY<0
GOTO CANCQ
+18 DO CANC^IBECEAU4(IBN,IBCRES,1)
+19 ;
+20 SET DIE="^IBCNR(366.15,"
SET DA=IBCHTRN
SET DR=".04///@"
DO ^DIE
CANCQ ;
+1 IF IBY<0
DO ERRMSG^IBACVA2(0,2)
+2 ;
+3 QUIT
+4 ;
RT(IBKEY) ; returns rate type previously determined
+1 QUIT $PIECE($GET(^IBCNR(366.15,+$ORDER(^IBCNR(366.15,"B",IBKEY,0)),0)),"^",3)
+2 ;
TRICARE(IBKEY) ; returns if the Key is RT TRICARE
+1 NEW IBRT
+2 SET IBRT=+$$RT(IBKEY)
+3 QUIT $SELECT($PIECE($GET(^DGCR(399.3,IBRT,0)),"^")["TRICARE":1,1:0)
+4 ;
+5 ;gets the insurance phone
+6 ;input:
+7 ; IB36 - ptr to INSURANCE COMPANY File (#36)
+8 ;output:
+9 ; the phone number
PHONE(IB36) ;
+1 NEW IB1
+2 ;check first CLAIMS (RX) PHONE NUMBER if empty
+3 SET IB1=$$GET1^DIQ(36,+IB36,.1311,"E")
+4 if $LENGTH(IB1)>0
QUIT IB1
+5 ;check BILLING PHONE NUMBER if empty - return nothing
+6 SET IB1=$$GET1^DIQ(36,+IB36,.132,"E")
+7 QUIT IB1
+8 ;IBNCPDP6
