IBECUS3 ;RLM/DVAMC - CANCEL TRICARE PHARMACY TRANSACTION ; 14-AUG-96
;;2.0;INTEGRATED BILLING;**52,89,240**;21-MAR-94
;
EN ; Transmit a cancellation transaction.
; 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
; IBKEYD -- 1 ^ 2 ^ 3 ^ 4, where
; 1 = Rx label printing device
; 2 = Pointer to the Pharmacy in file #59
; 3 = Pointer to the Pharmacy user in file #200
; 4 = Pointer to the billing transaction
; in file #351.5 (cancellations only)
;
; - bleed off queue
F R *IBI:0 Q:IBI=-1
;
; - get rx data; make sure there is an NDC
K IBDRX,IBERR
I $$TRANS^PSOCPTRI(+IBKEY,+$P(IBKEY,";",2),.IBDRX)<0 S IBERR=1 G ENQ
;
; - must be a billing transaction for the cancellation
S IBCHTRN=+$P(IBKEYD,"^",4)
S IBCHTRND=$G(^IBA(351.5,IBCHTRN,0))
I 'IBCHTRND S IBERR=8 G ENQ
S DFN=+$P(IBCHTRND,"^",2)
I 'DFN S IBERR=4 G ENQ
;
; - is patient covered by TRICARE?
S IBCDFN=$$CUS^IBACUS(DFN,DT)
I 'IBCDFN S IBERR=2 G ENQ
;
; - get the BIN Number for the insurance company
S IBCDFND=$G(^DPT(DFN,.312,IBCDFN,0))
S IBBIN=$P($G(^DIC(36,+IBCDFND,3)),"^",3)
I $L(IBBIN)'=6 S IBERR=5 G ENQ
;
; - build transmission:
; o pharmacy division
; o FI identifier (bin number)
; o commercial software package version (32)
; o cancellation transaction code (11)
; o control # (currently 10 spaces)
; o pharmacy # (currently 12 spaces)
; o rx fill date
; o prescription number
;
; (pharmacy number [abp] ??)
; S JADNUM=$S($P(JADPSRX(2),"^",9)=1:7745017,1:7745029),JADLEN=12 D LJUST^JADNC S JADNABP=JADNUM
;
S IBLINE(1)=$$FILL^IBECUS2(IBDRX("DIV"),2)_IBBIN_"3211"_$J("",10)_$J("",12)
S IBLINE(1)=IBLINE(1)_$$DATE^IBECUS2(IBDRX("FDT"))
S IBLINE(1)=IBLINE(1)_$$FILL^IBECUS2(IBDRX("RX#"),7)
;
; - transmit
W IBLINE(1),!
;
; - receive
R IBRESP(1)#100:120 I '$L(IBRESP(1)) S IBERR=6 G ENQ
;
; - handle errors
I $E(IBRESP(1),1,3) D ERROR^IBECUS22 G ENQ
;
; - handle rejects
S IBRESP(1)=$E(IBRESP(1),3,999)
I $E(IBRESP(1),5)="R" D REJECT G ENQ
;
; - update cancellation auth number and user
S ^IBA(351.5,IBCHTRN,6)=$E(IBRESP(1),6,19)_"^"_+$P(IBKEYD,"^",3)
K ^IBA(351.5,"APOST",IBKEY)
;
; - Queue task to cancel charges
D TASK^IBECUS2("RXCAN;Rx Cancellation")
;
ENQ I $G(IBERR) D ERROR^IBECUS22
Q
;
;
REJECT ; Send alert for a reject.
S IBREJ=""
F IBRJ=8:2 S IBRJA=$E(IBRESP(1),IBRJ,IBRJ+1) Q:IBRJA=" "!(IBRJA="") D
.S IBERRP=$$ERRIEN^IBECUS22("UNIVERSAL",IBRJA)
.I IBERRP S IBREJ=IBREJ_","_IBERRP
S IBREJ=$E(IBREJ,2,999)
;
S XQA("G.IB CHAMP RX REJ")="",XQA(+$P(IBKEYD,"^",3))=""
S XQAMSG="Reversal for prescription #"_IBDRX("RX#")_" rejected for reason #"_IBREJ
S XQADATA=IBDRX("RX#")_"^"_IBREJ_"^"_DFN,XQAROU="DISP^IBECUS22"
D SETUP^XQALERT
;
; - update transaction file with reject codes
S $P(^IBA(351.5,IBCHTRN,6),"^",3)=IBREJ
;
K IBERRP,IBREJ,IBRJ,IBRJA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECUS3 3306 printed Apr 09, 2024@21:25:03 Page 2
IBECUS3 ;RLM/DVAMC - CANCEL TRICARE PHARMACY TRANSACTION ; 14-AUG-96
+1 ;;2.0;INTEGRATED BILLING;**52,89,240**;21-MAR-94
+2 ;
EN ; Transmit a cancellation transaction.
+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 ; IBKEYD -- 1 ^ 2 ^ 3 ^ 4, where
+6 ; 1 = Rx label printing device
+7 ; 2 = Pointer to the Pharmacy in file #59
+8 ; 3 = Pointer to the Pharmacy user in file #200
+9 ; 4 = Pointer to the billing transaction
+10 ; in file #351.5 (cancellations only)
+11 ;
+12 ; - bleed off queue
+13 FOR
READ *IBI:0
if IBI=-1
QUIT
+14 ;
+15 ; - get rx data; make sure there is an NDC
+16 KILL IBDRX,IBERR
+17 IF $$TRANS^PSOCPTRI(+IBKEY,+$PIECE(IBKEY,";",2),.IBDRX)<0
SET IBERR=1
GOTO ENQ
+18 ;
+19 ; - must be a billing transaction for the cancellation
+20 SET IBCHTRN=+$PIECE(IBKEYD,"^",4)
+21 SET IBCHTRND=$GET(^IBA(351.5,IBCHTRN,0))
+22 IF 'IBCHTRND
SET IBERR=8
GOTO ENQ
+23 SET DFN=+$PIECE(IBCHTRND,"^",2)
+24 IF 'DFN
SET IBERR=4
GOTO ENQ
+25 ;
+26 ; - is patient covered by TRICARE?
+27 SET IBCDFN=$$CUS^IBACUS(DFN,DT)
+28 IF 'IBCDFN
SET IBERR=2
GOTO ENQ
+29 ;
+30 ; - get the BIN Number for the insurance company
+31 SET IBCDFND=$GET(^DPT(DFN,.312,IBCDFN,0))
+32 SET IBBIN=$PIECE($GET(^DIC(36,+IBCDFND,3)),"^",3)
+33 IF $LENGTH(IBBIN)'=6
SET IBERR=5
GOTO ENQ
+34 ;
+35 ; - build transmission:
+36 ; o pharmacy division
+37 ; o FI identifier (bin number)
+38 ; o commercial software package version (32)
+39 ; o cancellation transaction code (11)
+40 ; o control # (currently 10 spaces)
+41 ; o pharmacy # (currently 12 spaces)
+42 ; o rx fill date
+43 ; o prescription number
+44 ;
+45 ; (pharmacy number [abp] ??)
+46 ; S JADNUM=$S($P(JADPSRX(2),"^",9)=1:7745017,1:7745029),JADLEN=12 D LJUST^JADNC S JADNABP=JADNUM
+47 ;
+48 SET IBLINE(1)=$$FILL^IBECUS2(IBDRX("DIV"),2)_IBBIN_"3211"_$JUSTIFY("",10)_$JUSTIFY("",12)
+49 SET IBLINE(1)=IBLINE(1)_$$DATE^IBECUS2(IBDRX("FDT"))
+50 SET IBLINE(1)=IBLINE(1)_$$FILL^IBECUS2(IBDRX("RX#"),7)
+51 ;
+52 ; - transmit
+53 WRITE IBLINE(1),!
+54 ;
+55 ; - receive
+56 READ IBRESP(1)#100:120
IF '$LENGTH(IBRESP(1))
SET IBERR=6
GOTO ENQ
+57 ;
+58 ; - handle errors
+59 IF $EXTRACT(IBRESP(1),1,3)
DO ERROR^IBECUS22
GOTO ENQ
+60 ;
+61 ; - handle rejects
+62 SET IBRESP(1)=$EXTRACT(IBRESP(1),3,999)
+63 IF $EXTRACT(IBRESP(1),5)="R"
DO REJECT
GOTO ENQ
+64 ;
+65 ; - update cancellation auth number and user
+66 SET ^IBA(351.5,IBCHTRN,6)=$EXTRACT(IBRESP(1),6,19)_"^"_+$PIECE(IBKEYD,"^",3)
+67 KILL ^IBA(351.5,"APOST",IBKEY)
+68 ;
+69 ; - Queue task to cancel charges
+70 DO TASK^IBECUS2("RXCAN;Rx Cancellation")
+71 ;
ENQ IF $GET(IBERR)
DO ERROR^IBECUS22
+1 QUIT
+2 ;
+3 ;
REJECT ; Send alert for a reject.
+1 SET IBREJ=""
+2 FOR IBRJ=8:2
SET IBRJA=$EXTRACT(IBRESP(1),IBRJ,IBRJ+1)
if IBRJA=" "!(IBRJA="")
QUIT
Begin DoDot:1
+3 SET IBERRP=$$ERRIEN^IBECUS22("UNIVERSAL",IBRJA)
+4 IF IBERRP
SET IBREJ=IBREJ_","_IBERRP
End DoDot:1
+5 SET IBREJ=$EXTRACT(IBREJ,2,999)
+6 ;
+7 SET XQA("G.IB CHAMP RX REJ")=""
SET XQA(+$PIECE(IBKEYD,"^",3))=""
+8 SET XQAMSG="Reversal for prescription #"_IBDRX("RX#")_" rejected for reason #"_IBREJ
+9 SET XQADATA=IBDRX("RX#")_"^"_IBREJ_"^"_DFN
SET XQAROU="DISP^IBECUS22"
+10 DO SETUP^XQALERT
+11 ;
+12 ; - update transaction file with reject codes
+13 SET $PIECE(^IBA(351.5,IBCHTRN,6),"^",3)=IBREJ
+14 ;
+15 KILL IBERRP,IBREJ,IBRJ,IBRJA
+16 QUIT
