IBECUS22 ;RLM/DVAMC - TRICARE PHARMACY BILLING UTILITIES ; 14-AUG-96
;;2.0;INTEGRATED BILLING;**52,89,240,274**;21-MAR-94
;
ERROR ; File errors.
; Input: IBERR [opt] -- DHCP Error Code
; IBDRX("RX#") -- Prescription Number
; IBRESP(1) [opt] -- First record transmitted by the FI
; IBKEY -- 1 ; 2, where
; 1 = Pointer to the rx 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)
;
I '$G(IBERR) S IBERC=$E(IBRESP(1),1,3)
I $G(IBERR) K ^IBA(351.5,"APOST",IBKEY) S IBERC=IBERR
S IBMACH=$S($D(IBERR):"DHCP",1:"MLINK")
K IBERR,IBTXT
;
; - expand the code if necessary
I $D(IBRESP(1)),$E(IBRESP(1),1,3)=" " S IBERC="001"
I IBERC?1.N S IBERC=+IBERC F Q:$L(IBERC)>1 S IBERC="0"_IBERC
S IBERRP=$$ERRIEN(IBMACH,IBERC)
;
; - send bulletin to the Reject Notice group
S IBTXT(1)=IBMACH_" has detected error #"_IBERC_" while processing RX# "_$S($G(IBDRX("RX#"))]"":IBDRX("RX#"),1:"Unknown")
S IBTXT(2)="Error text: "_$$ERRTXT(IBERRP)
S XMDUN="TRICARE PHARMACY BILLING",XMDUZ=.5,XMSUB="Tricare/IPS Billing Error"
S XMTEXT="IBTXT(",XMY("G.IB CHAMP RX REJ")="",XMY(+$P(IBKEYD,"^",3))=""
N DIQUIET S DIQUIET=1 D DT^DICRW,^XMD
;
; - file the rejected transaction
S IBCHREJ=$O(^IBA(351.52,"B",IBKEY,0))
I 'IBCHREJ D ADDREJ^IBECUS21
I IBCHREJ S $P(^IBA(351.52,IBCHREJ,0),"^",3)=DT,^(1)=IBERRP
K IBERC,IBERRP,IBTXT,IBMACH,XMDUN,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
Q
;
;
DUP ; Act on duplicates.
S XQA("G.IB CHAMP RX REJ")=""
S XQAMSG="Prescription #"_$S($G(IBDRX("RX#"))]"":IBDRX("RX#"),1:"Unknown")_" is a duplicate submission."
D SETUP^XQALERT
K ^IBA(351.5,"APOST",IBKEY)
Q
;
;
DISP ; Display Universal errors on alerts.
N ERR,TXT,X,Y
S Y=$G(^DPT(+$P(XQADATA,"^",3),0))
W !!,"RX# ",$P(XQADATA,"^")," for ",$P(Y,"^")," (",$E($P(Y,"^",9),6,10),") rejected because:"
S XQADATA=$P(XQADATA,"^",2)
F X=1:1 S ERR=$P(XQADATA,",",X) Q:ERR="" D
.S TXT=$$ERRTXT(ERR)
.I TXT]"" W !?3,TXT
W !!,"Press ENTER key to continue..." R X:DTIME
Q
;
;
ERRTXT(IEN) ; Return Error Text.
; Input: IEN -- Pointer to the Error Text in file #351.51
Q $P($G(^IBE(351.51,+$G(IEN),0)),"^",3)
;
ERRIEN(MACH,CODE) ; Return Error File Entry Number.
; Input: MACH -- System on which the error occurred
; CODE -- Error Code
N X S X=""
I $G(MACH)="" G ERRIENQ
I $G(CODE)="" G ERRIENQ
S X=$O(^IBE(351.51,"AD",MACH,CODE,0))
ERRIENQ Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECUS22 3025 printed Oct 16, 2024@18:22:26 Page 2
IBECUS22 ;RLM/DVAMC - TRICARE PHARMACY BILLING UTILITIES ; 14-AUG-96
+1 ;;2.0;INTEGRATED BILLING;**52,89,240,274**;21-MAR-94
+2 ;
ERROR ; File errors.
+1 ; Input: IBERR [opt] -- DHCP Error Code
+2 ; IBDRX("RX#") -- Prescription Number
+3 ; IBRESP(1) [opt] -- First record transmitted by the FI
+4 ; IBKEY -- 1 ; 2, where
+5 ; 1 = Pointer to the rx in file #52
+6 ; 2 = Pointer to the refill in file #52.1,
+7 ; or 0 for the original fill
+8 ; IBKEYD -- 1 ^ 2 ^ 3 ^ 4, where
+9 ; 1 = Rx label printing device
+10 ; 2 = Pointer to the Pharmacy in file #59
+11 ; 3 = Pointer to the Pharmacy user in
+12 ; file #200
+13 ; 4 = Pointer to the billing transaction
+14 ; in file #351.5 (cancellations only)
+15 ;
+16 IF '$GET(IBERR)
SET IBERC=$EXTRACT(IBRESP(1),1,3)
+17 IF $GET(IBERR)
KILL ^IBA(351.5,"APOST",IBKEY)
SET IBERC=IBERR
+18 SET IBMACH=$SELECT($DATA(IBERR):"DHCP",1:"MLINK")
+19 KILL IBERR,IBTXT
+20 ;
+21 ; - expand the code if necessary
+22 IF $DATA(IBRESP(1))
IF $EXTRACT(IBRESP(1),1,3)=" "
SET IBERC="001"
+23 IF IBERC?1.N
SET IBERC=+IBERC
FOR
if $LENGTH(IBERC)>1
QUIT
SET IBERC="0"_IBERC
+24 SET IBERRP=$$ERRIEN(IBMACH,IBERC)
+25 ;
+26 ; - send bulletin to the Reject Notice group
+27 SET IBTXT(1)=IBMACH_" has detected error #"_IBERC_" while processing RX# "_$SELECT($GET(IBDRX("RX#"))]"":IBDRX("RX#"),1:"Unknown")
+28 SET IBTXT(2)="Error text: "_$$ERRTXT(IBERRP)
+29 SET XMDUN="TRICARE PHARMACY BILLING"
SET XMDUZ=.5
SET XMSUB="Tricare/IPS Billing Error"
+30 SET XMTEXT="IBTXT("
SET XMY("G.IB CHAMP RX REJ")=""
SET XMY(+$PIECE(IBKEYD,"^",3))=""
+31 NEW DIQUIET
SET DIQUIET=1
DO DT^DICRW
DO ^XMD
+32 ;
+33 ; - file the rejected transaction
+34 SET IBCHREJ=$ORDER(^IBA(351.52,"B",IBKEY,0))
+35 IF 'IBCHREJ
DO ADDREJ^IBECUS21
+36 IF IBCHREJ
SET $PIECE(^IBA(351.52,IBCHREJ,0),"^",3)=DT
SET ^(1)=IBERRP
+37 KILL IBERC,IBERRP,IBTXT,IBMACH,XMDUN,XMDUZ,XMSUB,XMTEXT,XMY,XMZ
+38 QUIT
+39 ;
+40 ;
DUP ; Act on duplicates.
+1 SET XQA("G.IB CHAMP RX REJ")=""
+2 SET XQAMSG="Prescription #"_$SELECT($GET(IBDRX("RX#"))]"":IBDRX("RX#"),1:"Unknown")_" is a duplicate submission."
+3 DO SETUP^XQALERT
+4 KILL ^IBA(351.5,"APOST",IBKEY)
+5 QUIT
+6 ;
+7 ;
DISP ; Display Universal errors on alerts.
+1 NEW ERR,TXT,X,Y
+2 SET Y=$GET(^DPT(+$PIECE(XQADATA,"^",3),0))
+3 WRITE !!,"RX# ",$PIECE(XQADATA,"^")," for ",$PIECE(Y,"^")," (",$EXTRACT($PIECE(Y,"^",9),6,10),") rejected because:"
+4 SET XQADATA=$PIECE(XQADATA,"^",2)
+5 FOR X=1:1
SET ERR=$PIECE(XQADATA,",",X)
if ERR=""
QUIT
Begin DoDot:1
+6 SET TXT=$$ERRTXT(ERR)
+7 IF TXT]""
WRITE !?3,TXT
End DoDot:1
+8 WRITE !!,"Press ENTER key to continue..."
READ X:DTIME
+9 QUIT
+10 ;
+11 ;
ERRTXT(IEN) ; Return Error Text.
+1 ; Input: IEN -- Pointer to the Error Text in file #351.51
+2 QUIT $PIECE($GET(^IBE(351.51,+$GET(IEN),0)),"^",3)
+3 ;
ERRIEN(MACH,CODE) ; Return Error File Entry Number.
+1 ; Input: MACH -- System on which the error occurred
+2 ; CODE -- Error Code
+3 NEW X
SET X=""
+4 IF $GET(MACH)=""
GOTO ERRIENQ
+5 IF $GET(CODE)=""
GOTO ERRIENQ
+6 SET X=$ORDER(^IBE(351.51,"AD",MACH,CODE,0))
ERRIENQ QUIT X
