- 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 Feb 18, 2025@23:51:11 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