IBACUS2 ;ALB/CPM - TRICARE FISCAL INTERMEDIARY RX CLAIMS ;02-AUG-96
;;2.0;INTEGRATED BILLING;**52,91,51,240,341,347,647**;21-MAR-94;Build 10
;;Per VA Directive 6402, this routine should not be modified.
;
BILL(IBKEY,IBCHTRN) ; Create the TRICARE claim for the Fiscal Intermediary.
; 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
; IBCHTRN -- Pointer to the transaction entry in file #351.5
;
N IBQUERY
S IBY=1 K IBDRX
I '$G(IBKEY) G BILLQ
I $$FILE^IBRXUTL(+IBKEY,.01)="" G BILLQ
S IBAMT=$P($G(^IBA(351.5,+IBCHTRN,2)),"^",5) ; FI portion of charge
I 'IBAMT G BILLQ
;
; - derive minimal variables
I '$$CHECK^IBECEAU(0) S IBY="-1^IB009" G BILLQ
S IBSERV=$P($G(^IBE(350.1,1,0)),"^",4)
I '$$SERV^IBARX1(IBSERV) S IBY="-1^IB003" G BILLQ
;
; - establish a stub claim/receivable
D SET^IBR I IBY<0 G BILLQ
;
; - set up the following variables for claim establishment:
; .01 BILL #
; .17 ORIG CLAIM
; .2 AUTO?
; .02 DFN
; .06 TIMEFRAME
; .07 RATE TYPE
; .18 SC AT TIME?
; .04 LOCATION (WILL NEED DIVISION THAT DISPENSED)
; .05 BILL CLASSIF (3)
; .03 EVT DATE (FILL DATE)
; 151 BILL FROM
; 152 BILL TO
K IB
S (IB(.02),DFN,IBDFN)=$$FILE^IBRXUTL(+IBKEY,2)
I 'DFN S IBY="-1^IB002" G BILLQ
S IB(.07)=$O(^DGCR(399.3,"B","TRICARE",0))
I 'IB(.07) S IBY="-1^IB059" G BILLQ
I $$TRANS^PSOCPTRI(+IBKEY,+$P(IBKEY,";",2),.IBDRX)<0 S IBY="-1^IB010" G BILLQ
;
S IBIFN=PRCASV("ARREC")
S IB(.01)=$P(PRCASV("ARBIL"),"-",2)
S IB(.17)=""
S IB(.2)=0
S IB(.06)=1
S IB(.18)=$$SC^IBCU3(DFN)
S IB(.04)=1 ; how can I get Division? RON...
S IB(.05)=3
S (IB(.03),IB(151),IB(152))=IBDRX("FDT")
;
; - set 362.4 node to rx#^p50^days sup^fill date^qty^ndc
S IB(362.4,+IBKEY,1)=IBDRX("RX#")_"^"_$$FILE^IBRXUTL(+IBKEY,6)_"^"_IBDRX("SUP")_"^"_IBDRX("FDT")_"^"_IBDRX("QTY")_"^"_IBDRX("NDC")
;
; - call the autobiller module to create the claim with a default
; diagnosis and procedure for prescriptions
D EN^IBCD3(.IBQUERY)
D CLOSE^IBSDU(.IBQUERY)
;
; - add the payor (fiscal intermediary) to the claim
S IBCDFN=$$CUS^IBACUS(DFN)
I 'IBCDFN S IBY="-1^IB054" G BILLQ
S IBINS=+$G(^DPT(DFN,.312,IBCDFN,0))
S DIE="^DGCR(399,",DA=IBIFN,DR="112////"_IBCDFN
D ^DIE K DA,DR,DIE,DGRVRCAL
;
; - add charge to the claim
S IBRVCD=$P($G(^DIC(36,IBINS,0)),"^",15) ; rx refill rev code
I IBRVCD="" S IBRVCD=$P($G(^IBE(363.1,+$P($G(^IBE(350.9,1,9)),U,12),0)),U,5) ; CS def rev code
I IBRVCD="" S X=250 ; gen'l rx rev code
;
S IBBS=$P($G(^IBE(363.1,+$P($G(^IBE(350.9,1,9)),U,12),0)),U,6) ; CS def bedsection
S IBUNITS=1 ; one unit
S IBCPT=$P($G(^IBE(350.9,1,1)),"^",30) ; def rx refill cpt
S IBDIV="" ; division
S IBAA=0 ; not auto calc charges
S IBTYPE=3 ; rx type
S IBITEM="" ; charge item link
;
;
S X=$$ADDRC^IBCRBF(IBIFN,IBRVCD,IBBS,IBAMT,IBUNITS,IBCPT,IBDIV,IBAA,IBTYPE,IBITEM)
I X<0 S IBY="-1^^Unable to add Revenue Code charge to claim." G BILLQ
;
; - update the authorize/print fields
S DIE="^DGCR(399,",DA=IBIFN,DR="9////1" D ^DIE K DA,DR,DIE
S DIE="^DGCR(399,",DA=IBIFN,DR="12////"_DT D ^DIE K DA,DR,DIE
;
; - pass the claim to AR
D GVAR^IBCBB,ARRAY^IBCBB1,^PRCASVC6,REL^PRCASVC:PRCASV("OKAY")
I 'PRCASV("OKAY") S IBY="-1^^Unable to establish receivable in AR." G BILLQ
;
; - update the rx transaction file (#351.5)
S DA=IBCHTRN,DIE="^IBA(351.5,",DR=".09////"_IBIFN D ^DIE K DA,DIE,DR
;
; - update the AR status to Active
S PRCASV("STATUS")=16
D STATUS^PRCASVC1
;
BILLQ I IBY<0 D ERRMSG^IBACVA2(1,2)
K IBRVCD,IBBS,IBUNITS,IBCPT,IBDIV,IBAA,IBTYPE,IBITEM,IBAMT
K IBSERV,IBFAC,IBSITE,IBDRX,IB,IBCDFN,IBINS,IBIDS,IBIFN,IBDFN
K PRCASV,PRCAERR
Q
;
;
CANC(IBCHTRN) ; Cancel the claim to the Fiscal Intermediary.
; Input: IBCHTRN -- Pointer to the transaction entry in file #351.5
;
S IBIFN=+$P($G(^IBA(351.5,IBCHTRN,0)),"^",9)
I 'IBIFN G CANCQ
F I=0,"S" S IB(I)=$G(^DGCR(399,IBIFN,I))
I IB(0)="" G CANCQ
I +$P(IB("S"),U,16),$P(IB("S"),U,17)]"" G CANCQ
;
S DA=IBIFN,DR="16////1;19////PRESCRIPTION REVERSED",DIE="^DGCR(399,"
D ^DIE K DA,DIE,DR
;
; - decrease out the receivable in AR
S DFN=+$P(IB(0),"^",2)
S IB("U1")=$G(^DGCR(399,IBIFN,"U1"))
S IBIL=$P($G(^PRCA(430,IBIFN,0)),"^")
S IBCHG=$S(IB("U1")']"":0,$P(IB("U1"),"^",1)]"":$P(IB("U1"),"^",1),1:0)
S IBCRES="TRICARE PRESCRIPTION REVERSED"
;
S X="21^"_IBCHG_"^"_IBIL_"^"_$S('DUZ:.5,1:DUZ)_"^"_DT_"^"_IBCRES ; *341
D ^PRCASER1
I Y<0 S IBY=Y D BULL
;
CANCQ K DFN,IBIFN,IB,IBIL,IBCHG,IBCRES,IBY,X,Y
Q
;
;
BULL ; Generate a bulletin if there is an error in canceling the claim.
K IBT S IBPT=$$PT^IBEFUNC(DFN)
S XMSUB="ERROR ENCOUNTERED"
S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="IBT("
S XMY(DUZ)=""
S IBGRP=$P($G(^XMB(3.8,+$P($G(^IBE(350.9,1,1)),"^",7),0)),"^")
I IBGRP]"" S XMY("G."_IBGRP_"@"_^XMB("NETNAME"))=""
;
S IBT(1)="An error occurred while cancelling the Pharmacy claim to the TRICARE"
S IBT(2)="fiscal intermediary for the following patient:"
S IBT(3)=" " S IBC=3
S IBDUZ=DUZ D PAT^IBAERR1
S IBC=IBC+1,IBT(IBC)=" Bill #: "_IBIL
S IBC=IBC+1,IBT(IBC)=" "
S IBC=IBC+1,IBT(IBC)="The following error was encountered:"
S IBC=IBC+1,IBT(IBC)=" "
D ERR^IBAERR1
S IBC=IBC+1,IBT(IBC)=" "
S IBC=IBC+1,IBT(IBC)="Please review the circumstances surrounding this error and decrease"
S IBC=IBC+1,IBT(IBC)="out this receivable in Accounts Receivable if necessary."
;
D ^XMD
K IBC,IBDUZ,IBT,IBPT,IBGRP,XMDUZ,XMTEXT,XMSUB,XMY
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACUS2 6105 printed Apr 09, 2024@21:22:48 Page 2
IBACUS2 ;ALB/CPM - TRICARE FISCAL INTERMEDIARY RX CLAIMS ;02-AUG-96
+1 ;;2.0;INTEGRATED BILLING;**52,91,51,240,341,347,647**;21-MAR-94;Build 10
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
BILL(IBKEY,IBCHTRN) ; Create the TRICARE claim for the Fiscal Intermediary.
+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 ; IBCHTRN -- Pointer to the transaction entry in file #351.5
+6 ;
+7 NEW IBQUERY
+8 SET IBY=1
KILL IBDRX
+9 IF '$GET(IBKEY)
GOTO BILLQ
+10 IF $$FILE^IBRXUTL(+IBKEY,.01)=""
GOTO BILLQ
+11 ; FI portion of charge
SET IBAMT=$PIECE($GET(^IBA(351.5,+IBCHTRN,2)),"^",5)
+12 IF 'IBAMT
GOTO BILLQ
+13 ;
+14 ; - derive minimal variables
+15 IF '$$CHECK^IBECEAU(0)
SET IBY="-1^IB009"
GOTO BILLQ
+16 SET IBSERV=$PIECE($GET(^IBE(350.1,1,0)),"^",4)
+17 IF '$$SERV^IBARX1(IBSERV)
SET IBY="-1^IB003"
GOTO BILLQ
+18 ;
+19 ; - establish a stub claim/receivable
+20 DO SET^IBR
IF IBY<0
GOTO BILLQ
+21 ;
+22 ; - set up the following variables for claim establishment:
+23 ; .01 BILL #
+24 ; .17 ORIG CLAIM
+25 ; .2 AUTO?
+26 ; .02 DFN
+27 ; .06 TIMEFRAME
+28 ; .07 RATE TYPE
+29 ; .18 SC AT TIME?
+30 ; .04 LOCATION (WILL NEED DIVISION THAT DISPENSED)
+31 ; .05 BILL CLASSIF (3)
+32 ; .03 EVT DATE (FILL DATE)
+33 ; 151 BILL FROM
+34 ; 152 BILL TO
+35 KILL IB
+36 SET (IB(.02),DFN,IBDFN)=$$FILE^IBRXUTL(+IBKEY,2)
+37 IF 'DFN
SET IBY="-1^IB002"
GOTO BILLQ
+38 SET IB(.07)=$ORDER(^DGCR(399.3,"B","TRICARE",0))
+39 IF 'IB(.07)
SET IBY="-1^IB059"
GOTO BILLQ
+40 IF $$TRANS^PSOCPTRI(+IBKEY,+$PIECE(IBKEY,";",2),.IBDRX)<0
SET IBY="-1^IB010"
GOTO BILLQ
+41 ;
+42 SET IBIFN=PRCASV("ARREC")
+43 SET IB(.01)=$PIECE(PRCASV("ARBIL"),"-",2)
+44 SET IB(.17)=""
+45 SET IB(.2)=0
+46 SET IB(.06)=1
+47 SET IB(.18)=$$SC^IBCU3(DFN)
+48 ; how can I get Division? RON...
SET IB(.04)=1
+49 SET IB(.05)=3
+50 SET (IB(.03),IB(151),IB(152))=IBDRX("FDT")
+51 ;
+52 ; - set 362.4 node to rx#^p50^days sup^fill date^qty^ndc
+53 SET IB(362.4,+IBKEY,1)=IBDRX("RX#")_"^"_$$FILE^IBRXUTL(+IBKEY,6)_"^"_IBDRX("SUP")_"^"_IBDRX("FDT")_"^"_IBDRX("QTY")_"^"_IBDRX("NDC")
+54 ;
+55 ; - call the autobiller module to create the claim with a default
+56 ; diagnosis and procedure for prescriptions
+57 DO EN^IBCD3(.IBQUERY)
+58 DO CLOSE^IBSDU(.IBQUERY)
+59 ;
+60 ; - add the payor (fiscal intermediary) to the claim
+61 SET IBCDFN=$$CUS^IBACUS(DFN)
+62 IF 'IBCDFN
SET IBY="-1^IB054"
GOTO BILLQ
+63 SET IBINS=+$GET(^DPT(DFN,.312,IBCDFN,0))
+64 SET DIE="^DGCR(399,"
SET DA=IBIFN
SET DR="112////"_IBCDFN
+65 DO ^DIE
KILL DA,DR,DIE,DGRVRCAL
+66 ;
+67 ; - add charge to the claim
+68 ; rx refill rev code
SET IBRVCD=$PIECE($GET(^DIC(36,IBINS,0)),"^",15)
+69 ; CS def rev code
IF IBRVCD=""
SET IBRVCD=$PIECE($GET(^IBE(363.1,+$PIECE($GET(^IBE(350.9,1,9)),U,12),0)),U,5)
+70 ; gen'l rx rev code
IF IBRVCD=""
SET X=250
+71 ;
+72 ; CS def bedsection
SET IBBS=$PIECE($GET(^IBE(363.1,+$PIECE($GET(^IBE(350.9,1,9)),U,12),0)),U,6)
+73 ; one unit
SET IBUNITS=1
+74 ; def rx refill cpt
SET IBCPT=$PIECE($GET(^IBE(350.9,1,1)),"^",30)
+75 ; division
SET IBDIV=""
+76 ; not auto calc charges
SET IBAA=0
+77 ; rx type
SET IBTYPE=3
+78 ; charge item link
SET IBITEM=""
+79 ;
+80 ;
+81 SET X=$$ADDRC^IBCRBF(IBIFN,IBRVCD,IBBS,IBAMT,IBUNITS,IBCPT,IBDIV,IBAA,IBTYPE,IBITEM)
+82 IF X<0
SET IBY="-1^^Unable to add Revenue Code charge to claim."
GOTO BILLQ
+83 ;
+84 ; - update the authorize/print fields
+85 SET DIE="^DGCR(399,"
SET DA=IBIFN
SET DR="9////1"
DO ^DIE
KILL DA,DR,DIE
+86 SET DIE="^DGCR(399,"
SET DA=IBIFN
SET DR="12////"_DT
DO ^DIE
KILL DA,DR,DIE
+87 ;
+88 ; - pass the claim to AR
+89 DO GVAR^IBCBB
DO ARRAY^IBCBB1
DO ^PRCASVC6
if PRCASV("OKAY")
DO REL^PRCASVC
+90 IF 'PRCASV("OKAY")
SET IBY="-1^^Unable to establish receivable in AR."
GOTO BILLQ
+91 ;
+92 ; - update the rx transaction file (#351.5)
+93 SET DA=IBCHTRN
SET DIE="^IBA(351.5,"
SET DR=".09////"_IBIFN
DO ^DIE
KILL DA,DIE,DR
+94 ;
+95 ; - update the AR status to Active
+96 SET PRCASV("STATUS")=16
+97 DO STATUS^PRCASVC1
+98 ;
BILLQ IF IBY<0
DO ERRMSG^IBACVA2(1,2)
+1 KILL IBRVCD,IBBS,IBUNITS,IBCPT,IBDIV,IBAA,IBTYPE,IBITEM,IBAMT
+2 KILL IBSERV,IBFAC,IBSITE,IBDRX,IB,IBCDFN,IBINS,IBIDS,IBIFN,IBDFN
+3 KILL PRCASV,PRCAERR
+4 QUIT
+5 ;
+6 ;
CANC(IBCHTRN) ; Cancel the claim to the Fiscal Intermediary.
+1 ; Input: IBCHTRN -- Pointer to the transaction entry in file #351.5
+2 ;
+3 SET IBIFN=+$PIECE($GET(^IBA(351.5,IBCHTRN,0)),"^",9)
+4 IF 'IBIFN
GOTO CANCQ
+5 FOR I=0,"S"
SET IB(I)=$GET(^DGCR(399,IBIFN,I))
+6 IF IB(0)=""
GOTO CANCQ
+7 IF +$PIECE(IB("S"),U,16)
IF $PIECE(IB("S"),U,17)]""
GOTO CANCQ
+8 ;
+9 SET DA=IBIFN
SET DR="16////1;19////PRESCRIPTION REVERSED"
SET DIE="^DGCR(399,"
+10 DO ^DIE
KILL DA,DIE,DR
+11 ;
+12 ; - decrease out the receivable in AR
+13 SET DFN=+$PIECE(IB(0),"^",2)
+14 SET IB("U1")=$GET(^DGCR(399,IBIFN,"U1"))
+15 SET IBIL=$PIECE($GET(^PRCA(430,IBIFN,0)),"^")
+16 SET IBCHG=$SELECT(IB("U1")']"":0,$PIECE(IB("U1"),"^",1)]"":$PIECE(IB("U1"),"^",1),1:0)
+17 SET IBCRES="TRICARE PRESCRIPTION REVERSED"
+18 ;
+19 ; *341
SET X="21^"_IBCHG_"^"_IBIL_"^"_$SELECT('DUZ:.5,1:DUZ)_"^"_DT_"^"_IBCRES
+20 DO ^PRCASER1
+21 IF Y<0
SET IBY=Y
DO BULL
+22 ;
CANCQ KILL DFN,IBIFN,IB,IBIL,IBCHG,IBCRES,IBY,X,Y
+1 QUIT
+2 ;
+3 ;
BULL ; Generate a bulletin if there is an error in canceling the claim.
+1 KILL IBT
SET IBPT=$$PT^IBEFUNC(DFN)
+2 SET XMSUB="ERROR ENCOUNTERED"
+3 SET XMDUZ="INTEGRATED BILLING PACKAGE"
SET XMTEXT="IBT("
+4 SET XMY(DUZ)=""
+5 SET IBGRP=$PIECE($GET(^XMB(3.8,+$PIECE($GET(^IBE(350.9,1,1)),"^",7),0)),"^")
+6 IF IBGRP]""
SET XMY("G."_IBGRP_"@"_^XMB("NETNAME"))=""
+7 ;
+8 SET IBT(1)="An error occurred while cancelling the Pharmacy claim to the TRICARE"
+9 SET IBT(2)="fiscal intermediary for the following patient:"
+10 SET IBT(3)=" "
SET IBC=3
+11 SET IBDUZ=DUZ
DO PAT^IBAERR1
+12 SET IBC=IBC+1
SET IBT(IBC)=" Bill #: "_IBIL
+13 SET IBC=IBC+1
SET IBT(IBC)=" "
+14 SET IBC=IBC+1
SET IBT(IBC)="The following error was encountered:"
+15 SET IBC=IBC+1
SET IBT(IBC)=" "
+16 DO ERR^IBAERR1
+17 SET IBC=IBC+1
SET IBT(IBC)=" "
+18 SET IBC=IBC+1
SET IBT(IBC)="Please review the circumstances surrounding this error and decrease"
+19 SET IBC=IBC+1
SET IBT(IBC)="out this receivable in Accounts Receivable if necessary."
+20 ;
+21 DO ^XMD
+22 KILL IBC,IBDUZ,IBT,IBPT,IBGRP,XMDUZ,XMTEXT,XMSUB,XMY
+23 QUIT
