IBATEP ;ALB/BGA - TRANSFER PRICING RX TRACKER ; 09-APRIL-99
;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; This routine is invoked by the Rx Pharmacy Event driver interface
; PS EVSEND OR. This routine monitors in real time
; any Rx that has been released from Pharmacy and determines if the DFN
; is a transfer pricing patient. If TP than the routine will price
; the Rx and file the transaction in ^IBAT(351.61
;
;
EN ; Entry point for Rx Transfer Pricing.
; Required Pharm 7.0 and Patch PSO*7*27 (Give us the new MSG(6) node)
; Only select records that are return to storage or released
I '$P($G(^IBE(350.9,1,10)),"^",4) Q ; transfer pricing turned off
I $G(MSG(1))']" "!($G(MSG(2))']" ")!($G(MSG(3))']" ")!($G(MSG(4))']" ")!($G(MSG(6))']" ") Q
; Proposed solution to the partial problem
Q:$P(MSG(6),"|",7)="P" ; quit if this is a partial.
N IBRXIEN,IBRXSTAT,IBDFN,D,IBPREF,IBSOURCE,IBDETM,IBATIEN,IBREL,IBIND
N IBEDT,IBDRUG,IBQTY,IBCOST,LASTREF
S D="|" Q:$P(MSG(1),D,3)'="PHARMACY"!($P(MSG(3),D,3)'="O")
S IBRXIEN=$P($P(MSG(4),D,4),U) Q:IBRXIEN<1
S IBRXSTAT=$P(MSG(4),D,2) Q:IBRXSTAT'="ZD"
S IBDFN=$P(MSG(2),D,4) Q:IBDFN<1
;============================================================
; Check to see if the dfn is a tp member and has a valid facility
Q:'$$TPP^IBATUTL(IBDFN)
S IBPREF=$$PPF^IBATUTL(IBDFN) Q:'IBPREF
;============================================================
; Get the Rx data
D EN^PSOORDER(IBDFN,IBRXIEN) Q:'$D(^TMP("PSOR",$J,IBRXIEN,0))
; Determine if this is a refill or original and
; Return to stock or release from stock
S IBSEL=$$IBDETM(IBRXIEN) Q:$P(IBSEL,U)="Q"
; I IBREL=1 Return to stock ; IBREL=0 Release from stock
; I IBIND>0 this is a Refill
S IBIND=$P($P(IBSEL,U),"|"),IBREL=$P($P(IBSEL,U),"|",2)
S IBSOURCE=IBRXIEN_";PSRX(;"_IBIND
Q:'$D(^TMP("PSOR",$J,IBRXIEN,"DRUG",0)) S IBDRUG=$P($P($G(^(0)),U),";")
;==============================================================
; if transaction already exists and this is a return to stock
I $D(^IBAT(351.61,"AD",IBSOURCE)),(IBREL) D Q
. S IBATIEN=$O(^IBAT(351.61,"AD",IBSOURCE,""))
. D DEL^IBATFILE(IBATIEN)
;==============================================================
; Original Rx and Released from stock
I '$D(^IBAT(351.61,"AD",IBSOURCE)),('IBREL),('IBIND) D Q
. S IBQTY=$P(IBSEL,U,7),IBCOST=$P(IBSEL,U,11),IBEDT=$P(IBSEL,U,4)
. S IBATFILE=$$RX^IBATFILE(IBDFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST)
;==============================================================
; Refill Rx and Released from stock
I '$D(^IBAT(351.61,"AD",IBSOURCE)),('IBREL),(IBIND) D Q
. S IBQTY=$P(IBSEL,U,5),IBCOST=$P(IBSEL,U,7),IBEDT=$P(IBSEL,U,2)
. S IBATFILE=$$RX^IBATFILE(IBDFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST)
;==============================================================
Q
IBDETM(X) ; Check to see if we have a original or refill
; if original return 0|0 or 1 ^the node ^TMP("PSOR",$J,RXIEN,0)
; if refill return n=refill#|0 or 1^the node ^TMP("PSOR",$J,RXIEN,"REF",n,0)
; piece 1 0|0 means we have a original fill and released from stock
; piece 1 0|1 means we have a original fill and returned to stock
; ==========================================
; If this is a refill return the following:
; piece 1 (n|0 or 1) where "n" is the refill number and
; 0="released from stock" and 1="returned to stock"
; ==========================================
; all other conditions return "Q"
; Note: You need to Invoke EN^PSOORDER first
;
N RX0,FND,REFILL,Z,REFILLN,RTSFILL,ACT,ACTN,ACTON
I '$D(^TMP("PSOR",$J,X,0)) S IBDETM="Q^Could not fine the global TMP('PSOR',$J) for RXIEN="_X Q IBDETM
S RX0=$G(^TMP("PSOR",$J,X,0)) I $P(RX0,U,4)'["A;" S IBDETM="Q^This RXIEN="_X_" is not active." Q IBDETM
;====================================================================
; (1). Determine if the Orig RX was Returned to Stock (rts)
S (RTSFILL,ACTON)=" "
I $D(^TMP("PSOR",$J,X,"ACT")) D
. S ACT=$O(^TMP("PSOR",$J,X,"ACT",""),-1) Q:'$G(ACT)
. S ACTN=$G(^TMP("PSOR",$J,X,"ACT",ACT,0)),ACTON=1
. ; P14 is only for ORIG Rx's that have been rts, check no refill, orig rts
. I $P(RX0,U,14),'$D(^TMP("PSOR",$J,X,"REF",1,0)),$P(ACTN,U,2)["RETURN",$P(ACTN,U,4)["ORIGINAL" S IBDETM="0|1^"_X,RTSFILL=1 Q
. ;
. ;=================Decision code for Refill or RTS====================
. I "^DELETED^RETURNED TO STOCK^"[(U_$P(ACTN,U,2)_U),$P(ACTN,U,4)["REFILL" D Q
. . S RTSFILL=$P($P(ACTN,U,4)," ",2) Q:'RTSFILL
. . S LASTREF=$O(^TMP("PSOR",$J,X,"REF",""),-1) ;always compare the last ref node
. . I LASTREF,$D(^TMP("PSOR",$J,X,"REF",LASTREF,0)),(LASTREF'<RTSFILL) D
. . . ; REFILL:
. . . ; must compare the last REFILL node with the last return to stock date on the "ACT" node
. . . ; if this is a REFILL than the LASTREF'<RTSFILL
. . . ; otherwise your last activity shows a rts for x refill
. . . ; and you have a remaining refill node x-1
. . . S REFILLN=$G(^TMP("PSOR",$J,X,"REF",LASTREF,0))
. . . S IBDETM=LASTREF_"|0^"_REFILLN Q
. . E S IBDETM=RTSFILL_"|1^"_X Q
. I $P(ACTN,U,2)["RETURN",$P(ACTN,U,4)["ORIG",$D(^TMP("PSOR",$J,X,"REF",1,0)) D Q
. . ; Case where the previous action was a return to stock of the orig
. . ; the new action is a FILL 1
. . S RTSFILL=1,REFILLN=$G(^TMP("PSOR",$J,X,"REF",1,0)),IBDETM=RTSFILL_"|0^"_REFILLN Q
I RTSFILL Q IBDETM
;====================================================================
; (2). Check for an original Rx. [last fill dt=Fill dt]
I $P(RX0,U,2)=$P(RX0,U,3),'ACTON D Q IBDETM
. S IBDETM="0|0^"_RX0 ; Case of released from stock.
;====================================================================
; (3). Check for Refills
S (FND,REFILL)=0
F S REFILL=$O(^TMP("PSOR",$J,X,"REF",REFILL)) Q:'REFILL!(FND)!(ACTON) D
. S Z="",Z=$O(^TMP("PSOR",$J,X,"REF",REFILL,Z)) Q:Z=""
. S REFILLN=$G(^TMP("PSOR",$J,X,"REF",REFILL,Z))
. ; i lastfill date=the refill date [we have a refill]
. I $P(RX0,U,3)=$P(REFILLN,U) S FND=1 D
. . S IBDETM=REFILL_"|0^"_REFILLN
;====================================================================
I 'FND S IBDETM="Q^No Refill or Original found for RXIEN="_X
Q IBDETM
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBATEP 6310 printed Apr 09, 2024@21:25:28 Page 2
IBATEP ;ALB/BGA - TRANSFER PRICING RX TRACKER ; 09-APRIL-99
+1 ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; This routine is invoked by the Rx Pharmacy Event driver interface
+5 ; PS EVSEND OR. This routine monitors in real time
+6 ; any Rx that has been released from Pharmacy and determines if the DFN
+7 ; is a transfer pricing patient. If TP than the routine will price
+8 ; the Rx and file the transaction in ^IBAT(351.61
+9 ;
+10 ;
EN ; Entry point for Rx Transfer Pricing.
+1 ; Required Pharm 7.0 and Patch PSO*7*27 (Give us the new MSG(6) node)
+2 ; Only select records that are return to storage or released
+3 ; transfer pricing turned off
IF '$PIECE($GET(^IBE(350.9,1,10)),"^",4)
QUIT
+4 IF $GET(MSG(1))']" "!($GET(MSG(2))']" ")!($GET(MSG(3))']" ")!($GET(MSG(4))']" ")!($GET(MSG(6))']" ")
QUIT
+5 ; Proposed solution to the partial problem
+6 ; quit if this is a partial.
if $PIECE(MSG(6),"|",7)="P"
QUIT
+7 NEW IBRXIEN,IBRXSTAT,IBDFN,D,IBPREF,IBSOURCE,IBDETM,IBATIEN,IBREL,IBIND
+8 NEW IBEDT,IBDRUG,IBQTY,IBCOST,LASTREF
+9 SET D="|"
if $PIECE(MSG(1),D,3)'="PHARMACY"!($PIECE(MSG(3),D,3)'="O")
QUIT
+10 SET IBRXIEN=$PIECE($PIECE(MSG(4),D,4),U)
if IBRXIEN<1
QUIT
+11 SET IBRXSTAT=$PIECE(MSG(4),D,2)
if IBRXSTAT'="ZD"
QUIT
+12 SET IBDFN=$PIECE(MSG(2),D,4)
if IBDFN<1
QUIT
+13 ;============================================================
+14 ; Check to see if the dfn is a tp member and has a valid facility
+15 if '$$TPP^IBATUTL(IBDFN)
QUIT
+16 SET IBPREF=$$PPF^IBATUTL(IBDFN)
if 'IBPREF
QUIT
+17 ;============================================================
+18 ; Get the Rx data
+19 DO EN^PSOORDER(IBDFN,IBRXIEN)
if '$DATA(^TMP("PSOR",$JOB,IBRXIEN,0))
QUIT
+20 ; Determine if this is a refill or original and
+21 ; Return to stock or release from stock
+22 SET IBSEL=$$IBDETM(IBRXIEN)
if $PIECE(IBSEL,U)="Q"
QUIT
+23 ; I IBREL=1 Return to stock ; IBREL=0 Release from stock
+24 ; I IBIND>0 this is a Refill
+25 SET IBIND=$PIECE($PIECE(IBSEL,U),"|")
SET IBREL=$PIECE($PIECE(IBSEL,U),"|",2)
+26 SET IBSOURCE=IBRXIEN_";PSRX(;"_IBIND
+27 if '$DATA(^TMP("PSOR",$JOB,IBRXIEN,"DRUG",0))
QUIT
SET IBDRUG=$PIECE($PIECE($GET(^(0)),U),";")
+28 ;==============================================================
+29 ; if transaction already exists and this is a return to stock
+30 IF $DATA(^IBAT(351.61,"AD",IBSOURCE))
IF (IBREL)
Begin DoDot:1
+31 SET IBATIEN=$ORDER(^IBAT(351.61,"AD",IBSOURCE,""))
+32 DO DEL^IBATFILE(IBATIEN)
End DoDot:1
QUIT
+33 ;==============================================================
+34 ; Original Rx and Released from stock
+35 IF '$DATA(^IBAT(351.61,"AD",IBSOURCE))
IF ('IBREL)
IF ('IBIND)
Begin DoDot:1
+36 SET IBQTY=$PIECE(IBSEL,U,7)
SET IBCOST=$PIECE(IBSEL,U,11)
SET IBEDT=$PIECE(IBSEL,U,4)
+37 SET IBATFILE=$$RX^IBATFILE(IBDFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST)
End DoDot:1
QUIT
+38 ;==============================================================
+39 ; Refill Rx and Released from stock
+40 IF '$DATA(^IBAT(351.61,"AD",IBSOURCE))
IF ('IBREL)
IF (IBIND)
Begin DoDot:1
+41 SET IBQTY=$PIECE(IBSEL,U,5)
SET IBCOST=$PIECE(IBSEL,U,7)
SET IBEDT=$PIECE(IBSEL,U,2)
+42 SET IBATFILE=$$RX^IBATFILE(IBDFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST)
End DoDot:1
QUIT
+43 ;==============================================================
+44 QUIT
IBDETM(X) ; Check to see if we have a original or refill
+1 ; if original return 0|0 or 1 ^the node ^TMP("PSOR",$J,RXIEN,0)
+2 ; if refill return n=refill#|0 or 1^the node ^TMP("PSOR",$J,RXIEN,"REF",n,0)
+3 ; piece 1 0|0 means we have a original fill and released from stock
+4 ; piece 1 0|1 means we have a original fill and returned to stock
+5 ; ==========================================
+6 ; If this is a refill return the following:
+7 ; piece 1 (n|0 or 1) where "n" is the refill number and
+8 ; 0="released from stock" and 1="returned to stock"
+9 ; ==========================================
+10 ; all other conditions return "Q"
+11 ; Note: You need to Invoke EN^PSOORDER first
+12 ;
+13 NEW RX0,FND,REFILL,Z,REFILLN,RTSFILL,ACT,ACTN,ACTON
+14 IF '$DATA(^TMP("PSOR",$JOB,X,0))
SET IBDETM="Q^Could not fine the global TMP('PSOR',$J) for RXIEN="_X
QUIT IBDETM
+15 SET RX0=$GET(^TMP("PSOR",$JOB,X,0))
IF $PIECE(RX0,U,4)'["A;"
SET IBDETM="Q^This RXIEN="_X_" is not active."
QUIT IBDETM
+16 ;====================================================================
+17 ; (1). Determine if the Orig RX was Returned to Stock (rts)
+18 SET (RTSFILL,ACTON)=" "
+19 IF $DATA(^TMP("PSOR",$JOB,X,"ACT"))
Begin DoDot:1
+20 SET ACT=$ORDER(^TMP("PSOR",$JOB,X,"ACT",""),-1)
if '$GET(ACT)
QUIT
+21 SET ACTN=$GET(^TMP("PSOR",$JOB,X,"ACT",ACT,0))
SET ACTON=1
+22 ; P14 is only for ORIG Rx's that have been rts, check no refill, orig rts
+23 IF $PIECE(RX0,U,14)
IF '$DATA(^TMP("PSOR",$JOB,X,"REF",1,0))
IF $PIECE(ACTN,U,2)["RETURN"
IF $PIECE(ACTN,U,4)["ORIGINAL"
SET IBDETM="0|1^"_X
SET RTSFILL=1
QUIT
+24 ;
+25 ;=================Decision code for Refill or RTS====================
+26 IF "^DELETED^RETURNED TO STOCK^"[(U_$PIECE(ACTN,U,2)_U)
IF $PIECE(ACTN,U,4)["REFILL"
Begin DoDot:2
+27 SET RTSFILL=$PIECE($PIECE(ACTN,U,4)," ",2)
if 'RTSFILL
QUIT
+28 ;always compare the last ref node
SET LASTREF=$ORDER(^TMP("PSOR",$JOB,X,"REF",""),-1)
+29 IF LASTREF
IF $DATA(^TMP("PSOR",$JOB,X,"REF",LASTREF,0))
IF (LASTREF'<RTSFILL)
Begin DoDot:3
+30 ; REFILL:
+31 ; must compare the last REFILL node with the last return to stock date on the "ACT" node
+32 ; if this is a REFILL than the LASTREF'<RTSFILL
+33 ; otherwise your last activity shows a rts for x refill
+34 ; and you have a remaining refill node x-1
+35 SET REFILLN=$GET(^TMP("PSOR",$JOB,X,"REF",LASTREF,0))
+36 SET IBDETM=LASTREF_"|0^"_REFILLN
QUIT
End DoDot:3
+37 IF '$TEST
SET IBDETM=RTSFILL_"|1^"_X
QUIT
End DoDot:2
QUIT
+38 IF $PIECE(ACTN,U,2)["RETURN"
IF $PIECE(ACTN,U,4)["ORIG"
IF $DATA(^TMP("PSOR",$JOB,X,"REF",1,0))
Begin DoDot:2
+39 ; Case where the previous action was a return to stock of the orig
+40 ; the new action is a FILL 1
+41 SET RTSFILL=1
SET REFILLN=$GET(^TMP("PSOR",$JOB,X,"REF",1,0))
SET IBDETM=RTSFILL_"|0^"_REFILLN
QUIT
End DoDot:2
QUIT
End DoDot:1
+42 IF RTSFILL
QUIT IBDETM
+43 ;====================================================================
+44 ; (2). Check for an original Rx. [last fill dt=Fill dt]
+45 IF $PIECE(RX0,U,2)=$PIECE(RX0,U,3)
IF 'ACTON
Begin DoDot:1
+46 ; Case of released from stock.
SET IBDETM="0|0^"_RX0
End DoDot:1
QUIT IBDETM
+47 ;====================================================================
+48 ; (3). Check for Refills
+49 SET (FND,REFILL)=0
+50 FOR
SET REFILL=$ORDER(^TMP("PSOR",$JOB,X,"REF",REFILL))
if 'REFILL!(FND)!(ACTON)
QUIT
Begin DoDot:1
+51 SET Z=""
SET Z=$ORDER(^TMP("PSOR",$JOB,X,"REF",REFILL,Z))
if Z=""
QUIT
+52 SET REFILLN=$GET(^TMP("PSOR",$JOB,X,"REF",REFILL,Z))
+53 ; i lastfill date=the refill date [we have a refill]
+54 IF $PIECE(RX0,U,3)=$PIECE(REFILLN,U)
SET FND=1
Begin DoDot:2
+55 SET IBDETM=REFILL_"|0^"_REFILLN
End DoDot:2
End DoDot:1
+56 ;====================================================================
+57 IF 'FND
SET IBDETM="Q^No Refill or Original found for RXIEN="_X
+58 QUIT IBDETM
