Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBATEP

IBATEP.m

Go to the documentation of this file. 
  1. IBATEP ;ALB/BGA - TRANSFER PRICING RX TRACKER ; 09-APRIL-99
  1.  ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  ; This routine is invoked by the Rx Pharmacy Event driver interface
  1.  ; PS EVSEND OR. This routine monitors in real time
  1.  ; any Rx that has been released from Pharmacy and determines if the DFN
  1.  ; is a transfer pricing patient. If TP than the routine will price
  1.  ; the Rx and file the transaction in ^IBAT(351.61
  1.  ;
  1.  ;
  1. EN ; Entry point for Rx Transfer Pricing.
  1.  ; Required Pharm 7.0 and Patch PSO*7*27 (Give us the new MSG(6) node)
  1.  ; Only select records that are return to storage or released
  1.  I '$P($G(^IBE(350.9,1,10)),"^",4) Q  ; transfer pricing turned off
  1.  I $G(MSG(1))']" "!($G(MSG(2))']" ")!($G(MSG(3))']" ")!($G(MSG(4))']" ")!($G(MSG(6))']" ") Q
  1.  ; Proposed solution to the partial problem
  1.  Q:$P(MSG(6),"|",7)="P"  ; quit if this is a partial.
  1.  N IBRXIEN,IBRXSTAT,IBDFN,D,IBPREF,IBSOURCE,IBDETM,IBATIEN,IBREL,IBIND
  1.  N IBEDT,IBDRUG,IBQTY,IBCOST,LASTREF
  1.  S D="|" Q:$P(MSG(1),D,3)'="PHARMACY"!($P(MSG(3),D,3)'="O")
  1.  S IBRXIEN=$P($P(MSG(4),D,4),U) Q:IBRXIEN<1
  1.  S IBRXSTAT=$P(MSG(4),D,2) Q:IBRXSTAT'="ZD"
  1.  S IBDFN=$P(MSG(2),D,4) Q:IBDFN<1
  1.  ;============================================================
  1.  ; Check to see if the dfn is a tp member and has a valid facility
  1.  Q:'$$TPP^IBATUTL(IBDFN)
  1.  S IBPREF=$$PPF^IBATUTL(IBDFN) Q:'IBPREF
  1.  ;============================================================
  1.  ; Get the Rx data
  1.  D EN^PSOORDER(IBDFN,IBRXIEN) Q:'$D(^TMP("PSOR",$J,IBRXIEN,0))
  1.  ; Determine if this is a refill or original and 
  1.  ; Return to stock or release from stock
  1.  S IBSEL=$$IBDETM(IBRXIEN) Q:$P(IBSEL,U)="Q"
  1.  ; I IBREL=1 Return to stock ; IBREL=0 Release from stock
  1.  ; I IBIND>0 this is a Refill
  1.  S IBIND=$P($P(IBSEL,U),"|"),IBREL=$P($P(IBSEL,U),"|",2)
  1.  S IBSOURCE=IBRXIEN_";PSRX(;"_IBIND
  1.  Q:'$D(^TMP("PSOR",$J,IBRXIEN,"DRUG",0))  S IBDRUG=$P($P($G(^(0)),U),";")
  1.  ;==============================================================
  1.  ; if transaction already exists and this is a return to stock
  1.  I $D(^IBAT(351.61,"AD",IBSOURCE)),(IBREL) D  Q
  1.  . S IBATIEN=$O(^IBAT(351.61,"AD",IBSOURCE,""))
  1.  . D DEL^IBATFILE(IBATIEN)
  1.  ;==============================================================
  1.  ; Original Rx and Released from stock
  1.  I '$D(^IBAT(351.61,"AD",IBSOURCE)),('IBREL),('IBIND) D  Q
  1.  . S IBQTY=$P(IBSEL,U,7),IBCOST=$P(IBSEL,U,11),IBEDT=$P(IBSEL,U,4)
  1.  . S IBATFILE=$$RX^IBATFILE(IBDFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST)
  1.  ;==============================================================
  1.  ; Refill Rx and Released from stock
  1.  I '$D(^IBAT(351.61,"AD",IBSOURCE)),('IBREL),(IBIND) D  Q
  1.  . S IBQTY=$P(IBSEL,U,5),IBCOST=$P(IBSEL,U,7),IBEDT=$P(IBSEL,U,2)
  1.  . S IBATFILE=$$RX^IBATFILE(IBDFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST)
  1.  ;==============================================================
  1.  Q
  1. 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)
  1.  ;  if refill return n=refill#|0 or 1^the node ^TMP("PSOR",$J,RXIEN,"REF",n,0)
  1.  ;  piece 1 0|0 means we have a original fill and released from stock
  1.  ;  piece 1 0|1 means we have a original fill and returned to stock
  1.  ;  ==========================================
  1.  ;  If this is a refill return the following:
  1.  ;  piece 1 (n|0 or 1) where "n" is the refill number and 
  1.  ;  0="released from stock" and 1="returned to stock"
  1.  ;  ==========================================
  1.  ;  all other conditions return "Q"
  1.  ; Note: You need to Invoke EN^PSOORDER first
  1.  ;
  1.  N RX0,FND,REFILL,Z,REFILLN,RTSFILL,ACT,ACTN,ACTON
  1.  I '$D(^TMP("PSOR",$J,X,0)) S IBDETM="Q^Could not fine the global TMP('PSOR',$J) for RXIEN="_X Q IBDETM
  1.  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.  ;====================================================================
  1.  ; (1). Determine if the Orig RX was Returned to Stock (rts)
  1.  S (RTSFILL,ACTON)=" "
  1.  I $D(^TMP("PSOR",$J,X,"ACT")) D
  1.  . S ACT=$O(^TMP("PSOR",$J,X,"ACT",""),-1) Q:'$G(ACT)
  1.  . S ACTN=$G(^TMP("PSOR",$J,X,"ACT",ACT,0)),ACTON=1
  1.  . ; P14 is only for ORIG Rx's that have been rts, check no refill, orig rts
  1.  . 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
  1.  . ;
  1.  . ;=================Decision code for Refill or RTS====================
  1.  . I "^DELETED^RETURNED TO STOCK^"[(U_$P(ACTN,U,2)_U),$P(ACTN,U,4)["REFILL" D  Q
  1.  . . S RTSFILL=$P($P(ACTN,U,4)," ",2) Q:'RTSFILL
  1.  . . S LASTREF=$O(^TMP("PSOR",$J,X,"REF",""),-1)  ;always compare the last ref node 
  1.  . . I LASTREF,$D(^TMP("PSOR",$J,X,"REF",LASTREF,0)),(LASTREF'<RTSFILL) D
  1.  . . . ; REFILL:
  1.  . . . ; must compare the last REFILL node with the last return to stock date on the "ACT" node
  1.  . . . ;  if this is a REFILL than the LASTREF'<RTSFILL
  1.  . . . ;  otherwise your last activity shows a rts for x refill
  1.  . . . ;  and you have a remaining refill node x-1
  1.  . . . S REFILLN=$G(^TMP("PSOR",$J,X,"REF",LASTREF,0))
  1.  . . . S IBDETM=LASTREF_"|0^"_REFILLN Q
  1.  . . E  S IBDETM=RTSFILL_"|1^"_X Q
  1.  . I $P(ACTN,U,2)["RETURN",$P(ACTN,U,4)["ORIG",$D(^TMP("PSOR",$J,X,"REF",1,0)) D  Q
  1.  . . ; Case where the previous action was a return to stock of the orig
  1.  . . ; the new action is a FILL 1
  1.  . . S RTSFILL=1,REFILLN=$G(^TMP("PSOR",$J,X,"REF",1,0)),IBDETM=RTSFILL_"|0^"_REFILLN Q
  1.  I RTSFILL Q IBDETM
  1.  ;====================================================================
  1.  ; (2). Check for an original Rx.  [last fill dt=Fill dt]
  1.  I $P(RX0,U,2)=$P(RX0,U,3),'ACTON D  Q IBDETM
  1.  . S IBDETM="0|0^"_RX0 ; Case of released from stock.
  1.  ;====================================================================
  1.  ; (3). Check for Refills
  1.  S (FND,REFILL)=0
  1.  F  S REFILL=$O(^TMP("PSOR",$J,X,"REF",REFILL)) Q:'REFILL!(FND)!(ACTON)  D
  1.  . S Z="",Z=$O(^TMP("PSOR",$J,X,"REF",REFILL,Z)) Q:Z=""
  1.  . S REFILLN=$G(^TMP("PSOR",$J,X,"REF",REFILL,Z))
  1.  . ; i lastfill date=the refill date [we have a refill]
  1.  . I $P(RX0,U,3)=$P(REFILLN,U) S FND=1 D
  1.  . . S IBDETM=REFILL_"|0^"_REFILLN
  1.  ;====================================================================
  1.  I 'FND S IBDETM="Q^No Refill or Original found for RXIEN="_X
  1.  Q IBDETM