IBECUS21 ;RLM/DVAMC - FILE TRICARE PHARMACY TRANSACTIONS ; 14-AUG-96
;;2.0;INTEGRATED BILLING;**52,240,274**;21-MAR-94
;
TRAN ; File a Pharmacy Billing transaction in file #351.5.
; Input: DFN -- Pointer to the patient in file #2
; IBLINE -- Array of data transmitted to the FI
; IBRESP -- Array of data received from the FI
; 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)
;
; - don't process duplicate transactions
I $E(IBRESP(1),17)="D" Q
;
; - find transaction entry or create a new one
S IBCHTRN=$O(^IBA(351.5,"B",IBKEY,0))
I 'IBCHTRN D
.S I=$P(^IBA(351.5,0),"^",3)
.F S I=I+1 L +^IBA(351.5,I):1 Q:$T&'$D(^IBA(351.5,I)) L -^IBA(351.5,I)
.S ^IBA(351.5,I,0)=IBKEY,^IBA(351.5,"B",IBKEY,I)=""
.S ^IBA(351.5,0)=$P(^IBA(351.5,0),"^",1,2)_"^"_I_"^"_($P(^IBA(351.5,0),"^",4)+1)
.S IBCHTRN=I L -^IBA(351.5,IBCHTRN)
;
; - prepare i/o for filing
S IBPROC("I")="" F IBI=1:1:2 S IBPROC("I")=IBPROC("I")_$G(IBRESP(IBI))
S IBPROC("O")="" F IBI=1:1:5 S IBPROC("O")=IBPROC("O")_$G(IBLINE(IBI))
S IBPROC("O")=$E(IBPROC("O"),3,999)
;
; - file transaction data
S $P(^IBA(351.5,IBCHTRN,0),"^",2,6)=DFN_"^"_$P(IBCDFND,"^",2)_"^"_$TR(IBDRX("NDC"),"-","")_"^"_$J((+IBUAC/100),0,2)_"^"_IBDRX("QTY")
F IBI=1:1 S IBTABLE=$T(TABLE+IBI) Q:$P(IBTABLE,";",3)="$END" D
.Q:$P(IBTABLE,";",4)<2
.;
.; - file only the 0th node for rejects
.I $E(IBRESP(1),17)="R",$P(IBTABLE,";",4)>1 Q
.;
.S X="" I $P(IBTABLE,";",6)'?1.N X $P(IBTABLE,";",6)
.I X="" S X=$E(IBPROC($P(IBTABLE,";",3)),$P(IBTABLE,";",6),$P(IBTABLE,";",7))
.I $P(IBTABLE,";",2)["D" Q:'X D DOLLAR
.;
.; - file each field individually
.I X]"" S $P(^IBA(351.5,IBCHTRN,$P(IBTABLE,";",4)),"^",$P(IBTABLE,";",5))=X
;
; - delete cancellation authorization number
S $P(^IBA(351.5,IBCHTRN,6),"^")=""
;
; - handle rejects, update transaction date and cross reference
D REJECT
N DIQUIET S DIQUIET=1 D DT^DICRW S $P(^IBA(351.5,IBCHTRN,0),U,7)=DT
S DA=IBCHTRN,DIK="^IBA(351.5," D IX^DIK
Q
;
;
DOLLAR ; Convert cents to dollars.
S X=$E(X,1,($L(X)-2))_"."_$E(X,($L(X)-1),$L(X))
F Q:$E(X,1)'=0 S X=$E(X,2,999)
Q
;
;
REJECT ; Act on billing rejects.
;
; - file reject information
S IBREJ="" I $E(IBRESP(1),17)="R" D
.F IBJ=20:2 S IBJA=$E(IBRESP(1),IBJ,IBJ+1) Q:IBJA=" "!(IBJA="") D
..S IBERRP=$$ERRIEN^IBECUS22("UNIVERSAL",IBJA)
..I IBERRP S IBREJ=IBREJ_","_IBERRP
S:$L(IBREJ) IBREJ=$E(IBREJ,2,999)
S ^IBA(351.5,IBCHTRN,5)=IBREJ
;
; - if the transaction was not rejected, delete the existing
; reject entry if it exists
S IBCHREJ=$O(^IBA(351.52,"B",IBKEY,0))
I IBREJ="" D G REJECTQ
.I IBCHREJ S DA=IBCHREJ,DIK="^IBA(351.52," D ^DIK K DA,DIK
;
; - add a new reject entry if necessary
I 'IBCHREJ D ADDREJ
;
; - update reject file
S DA=IBCHTRN,DIE="^IBA(351.52,",DR=".02////"_IBCHTRN_";.03////"_DT
D ^DIE K DA,DIE,DR
S ^IBA(351.52,IBCHREJ,1)=IBREJ
;
; - generate a reject alert
S XQA("G.IB CHAMP RX REJ")="",XQA(+$P(IBKEYD,"^",3))=""
S XQAMSG="Prescription #"_IBDRX("RX#")_" rejected for reason #"_IBREJ
S XQADATA=IBDRX("RX#")_"^"_IBREJ_"^"_DFN,XQAROU="DISP^IBECUS22"
D SETUP^XQALERT
;
; - remove prescription from queue
I $P($G(^IBE(351.51,+IBREJ,0)),"^",2)<89 K ^IBA(351.5,"APOST",IBKEY)
REJECTQ Q
;
;
ADDREJ ; Add stub entry to the Reject file.
S I=$P(^IBA(351.52,0),"^",3)
F S I=I+1 L +^IBA(351.52,I):1 Q:$T&'$D(^IBA(351.52,I)) L -^IBA(351.52,I)
S ^IBA(351.52,I,0)=IBKEY,^IBA(351.52,"B",IBKEY,I)=""
S ^IBA(351.52,0)=$P(^IBA(351.52,0),"^",1,2)_"^"_I_"^"_($P(^IBA(351.52,0),"^",4)+1)
S IBCHREJ=I L -^IBA(351.52,I)
Q
;
;
TABLE ; Table of field positions and file locations in file #351.5.
;;O;0;2;S X=DFN
;;O;0;3;48;65
;;O;0;4;268;278
;D;O;0;5;280;285
;;O;0;6;259;263
;D;I;2;1;18;23
;D;I;2;2;24;29
;D;I;2;3;30;35
;D;I;2;4;36;41
;D;I;2;5;42;47
;;I;2;6;48;61
;;I;2;7;62;101
;D;I;3;1;102;109
;D;I;3;2;110;117
;D;I;3;3;118;125
;D;I;3;4;126;131
;D;I;3;5;132;137
;D;I;3;6;138;143
;D;I;3;7;144;149
;D;I;3;8;150;155
;;I;3;9;156;157
;D;I;3;10;158;163
;;I;7;1;164;323
;;I;8;1;324;403
;;$END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECUS21 4754 printed Oct 16, 2024@18:22:25 Page 2
IBECUS21 ;RLM/DVAMC - FILE TRICARE PHARMACY TRANSACTIONS ; 14-AUG-96
+1 ;;2.0;INTEGRATED BILLING;**52,240,274**;21-MAR-94
+2 ;
TRAN ; File a Pharmacy Billing transaction in file #351.5.
+1 ; Input: DFN -- Pointer to the patient in file #2
+2 ; IBLINE -- Array of data transmitted to the FI
+3 ; IBRESP -- Array of data received from the FI
+4 ; IBKEY -- 1 ; 2, where
+5 ; 1 = Pointer to the prescription in file #52
+6 ; 2 = Pointer to the refill in file #52.1, or
+7 ; 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 file #200
+12 ; 4 = Pointer to the billing transaction
+13 ; in file #351.5 (cancellations only)
+14 ;
+15 ; - don't process duplicate transactions
+16 IF $EXTRACT(IBRESP(1),17)="D"
QUIT
+17 ;
+18 ; - find transaction entry or create a new one
+19 SET IBCHTRN=$ORDER(^IBA(351.5,"B",IBKEY,0))
+20 IF 'IBCHTRN
Begin DoDot:1
+21 SET I=$PIECE(^IBA(351.5,0),"^",3)
+22 FOR
SET I=I+1
LOCK +^IBA(351.5,I):1
if $TEST&'$DATA(^IBA(351.5,I))
QUIT
LOCK -^IBA(351.5,I)
+23 SET ^IBA(351.5,I,0)=IBKEY
SET ^IBA(351.5,"B",IBKEY,I)=""
+24 SET ^IBA(351.5,0)=$PIECE(^IBA(351.5,0),"^",1,2)_"^"_I_"^"_($PIECE(^IBA(351.5,0),"^",4)+1)
+25 SET IBCHTRN=I
LOCK -^IBA(351.5,IBCHTRN)
End DoDot:1
+26 ;
+27 ; - prepare i/o for filing
+28 SET IBPROC("I")=""
FOR IBI=1:1:2
SET IBPROC("I")=IBPROC("I")_$GET(IBRESP(IBI))
+29 SET IBPROC("O")=""
FOR IBI=1:1:5
SET IBPROC("O")=IBPROC("O")_$GET(IBLINE(IBI))
+30 SET IBPROC("O")=$EXTRACT(IBPROC("O"),3,999)
+31 ;
+32 ; - file transaction data
+33 SET $PIECE(^IBA(351.5,IBCHTRN,0),"^",2,6)=DFN_"^"_$PIECE(IBCDFND,"^",2)_"^"_$TRANSLATE(IBDRX("NDC"),"-","")_"^"_$JUSTIFY((+IBUAC/100),0,2)_"^"_IBDRX("QTY")
+34 FOR IBI=1:1
SET IBTABLE=$TEXT(TABLE+IBI)
if $PIECE(IBTABLE,";",3)="$END"
QUIT
Begin DoDot:1
+35 if $PIECE(IBTABLE,";",4)<2
QUIT
+36 ;
+37 ; - file only the 0th node for rejects
+38 IF $EXTRACT(IBRESP(1),17)="R"
IF $PIECE(IBTABLE,";",4)>1
QUIT
+39 ;
+40 SET X=""
IF $PIECE(IBTABLE,";",6)'?1.N
XECUTE $PIECE(IBTABLE,";",6)
+41 IF X=""
SET X=$EXTRACT(IBPROC($PIECE(IBTABLE,";",3)),$PIECE(IBTABLE,";",6),$PIECE(IBTABLE,";",7))
+42 IF $PIECE(IBTABLE,";",2)["D"
if 'X
QUIT
DO DOLLAR
+43 ;
+44 ; - file each field individually
+45 IF X]""
SET $PIECE(^IBA(351.5,IBCHTRN,$PIECE(IBTABLE,";",4)),"^",$PIECE(IBTABLE,";",5))=X
End DoDot:1
+46 ;
+47 ; - delete cancellation authorization number
+48 SET $PIECE(^IBA(351.5,IBCHTRN,6),"^")=""
+49 ;
+50 ; - handle rejects, update transaction date and cross reference
+51 DO REJECT
+52 NEW DIQUIET
SET DIQUIET=1
DO DT^DICRW
SET $PIECE(^IBA(351.5,IBCHTRN,0),U,7)=DT
+53 SET DA=IBCHTRN
SET DIK="^IBA(351.5,"
DO IX^DIK
+54 QUIT
+55 ;
+56 ;
DOLLAR ; Convert cents to dollars.
+1 SET X=$EXTRACT(X,1,($LENGTH(X)-2))_"."_$EXTRACT(X,($LENGTH(X)-1),$LENGTH(X))
+2 FOR
if $EXTRACT(X,1)'=0
QUIT
SET X=$EXTRACT(X,2,999)
+3 QUIT
+4 ;
+5 ;
REJECT ; Act on billing rejects.
+1 ;
+2 ; - file reject information
+3 SET IBREJ=""
IF $EXTRACT(IBRESP(1),17)="R"
Begin DoDot:1
+4 FOR IBJ=20:2
SET IBJA=$EXTRACT(IBRESP(1),IBJ,IBJ+1)
if IBJA=" "!(IBJA="")
QUIT
Begin DoDot:2
+5 SET IBERRP=$$ERRIEN^IBECUS22("UNIVERSAL",IBJA)
+6 IF IBERRP
SET IBREJ=IBREJ_","_IBERRP
End DoDot:2
End DoDot:1
+7 if $LENGTH(IBREJ)
SET IBREJ=$EXTRACT(IBREJ,2,999)
+8 SET ^IBA(351.5,IBCHTRN,5)=IBREJ
+9 ;
+10 ; - if the transaction was not rejected, delete the existing
+11 ; reject entry if it exists
+12 SET IBCHREJ=$ORDER(^IBA(351.52,"B",IBKEY,0))
+13 IF IBREJ=""
Begin DoDot:1
+14 IF IBCHREJ
SET DA=IBCHREJ
SET DIK="^IBA(351.52,"
DO ^DIK
KILL DA,DIK
End DoDot:1
GOTO REJECTQ
+15 ;
+16 ; - add a new reject entry if necessary
+17 IF 'IBCHREJ
DO ADDREJ
+18 ;
+19 ; - update reject file
+20 SET DA=IBCHTRN
SET DIE="^IBA(351.52,"
SET DR=".02////"_IBCHTRN_";.03////"_DT
+21 DO ^DIE
KILL DA,DIE,DR
+22 SET ^IBA(351.52,IBCHREJ,1)=IBREJ
+23 ;
+24 ; - generate a reject alert
+25 SET XQA("G.IB CHAMP RX REJ")=""
SET XQA(+$PIECE(IBKEYD,"^",3))=""
+26 SET XQAMSG="Prescription #"_IBDRX("RX#")_" rejected for reason #"_IBREJ
+27 SET XQADATA=IBDRX("RX#")_"^"_IBREJ_"^"_DFN
SET XQAROU="DISP^IBECUS22"
+28 DO SETUP^XQALERT
+29 ;
+30 ; - remove prescription from queue
+31 IF $PIECE($GET(^IBE(351.51,+IBREJ,0)),"^",2)<89
KILL ^IBA(351.5,"APOST",IBKEY)
REJECTQ QUIT
+1 ;
+2 ;
ADDREJ ; Add stub entry to the Reject file.
+1 SET I=$PIECE(^IBA(351.52,0),"^",3)
+2 FOR
SET I=I+1
LOCK +^IBA(351.52,I):1
if $TEST&'$DATA(^IBA(351.52,I))
QUIT
LOCK -^IBA(351.52,I)
+3 SET ^IBA(351.52,I,0)=IBKEY
SET ^IBA(351.52,"B",IBKEY,I)=""
+4 SET ^IBA(351.52,0)=$PIECE(^IBA(351.52,0),"^",1,2)_"^"_I_"^"_($PIECE(^IBA(351.52,0),"^",4)+1)
+5 SET IBCHREJ=I
LOCK -^IBA(351.52,I)
+6 QUIT
+7 ;
+8 ;
TABLE ; Table of field positions and file locations in file #351.5.
+1 ;;O;0;2;S X=DFN
+2 ;;O;0;3;48;65
+3 ;;O;0;4;268;278
+4 ;D;O;0;5;280;285
+5 ;;O;0;6;259;263
+6 ;D;I;2;1;18;23
+7 ;D;I;2;2;24;29
+8 ;D;I;2;3;30;35
+9 ;D;I;2;4;36;41
+10 ;D;I;2;5;42;47
+11 ;;I;2;6;48;61
+12 ;;I;2;7;62;101
+13 ;D;I;3;1;102;109
+14 ;D;I;3;2;110;117
+15 ;D;I;3;3;118;125
+16 ;D;I;3;4;126;131
+17 ;D;I;3;5;132;137
+18 ;D;I;3;6;138;143
+19 ;D;I;3;7;144;149
+20 ;D;I;3;8;150;155
+21 ;;I;3;9;156;157
+22 ;D;I;3;10;158;163
+23 ;;I;7;1;164;323
+24 ;;I;8;1;324;403
+25 ;;$END
