source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATEP.m@ 1582

Last change on this file since 1582 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1IBATEP ;ALB/BGA - TRANSFER PRICING RX TRACKER ; 09-APRIL-99
2 ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; This routine is invoked by the Rx Pharmacy Event driver interface
6 ; PS EVSEND OR. This routine monitors in real time
7 ; any Rx that has been released from Pharmacy and determines if the DFN
8 ; is a transfer pricing patient. If TP than the routine will price
9 ; the Rx and file the transaction in ^IBAT(351.61
10 ;
11 ;
12EN ; Entry point for Rx Transfer Pricing.
13 ; Required Pharm 7.0 and Patch PSO*7*27 (Give us the new MSG(6) node)
14 ; Only select records that are return to storage or released
15 I '$P($G(^IBE(350.9,1,10)),"^",4) Q ; transfer pricing turned off
16 I $G(MSG(1))']" "!($G(MSG(2))']" ")!($G(MSG(3))']" ")!($G(MSG(4))']" ")!($G(MSG(6))']" ") Q
17 ; Proposed solution to the partial problem
18 Q:$P(MSG(6),"|",7)="P" ; quit if this is a partial.
19 N IBRXIEN,IBRXSTAT,IBDFN,D,IBPREF,IBSOURCE,IBDETM,IBATIEN,IBREL,IBIND
20 N IBEDT,IBDRUG,IBQTY,IBCOST,LASTREF
21 S D="|" Q:$P(MSG(1),D,3)'="PHARMACY"!($P(MSG(3),D,3)'="O")
22 S IBRXIEN=$P($P(MSG(4),D,4),U) Q:IBRXIEN<1
23 S IBRXSTAT=$P(MSG(4),D,2) Q:IBRXSTAT'="ZD"
24 S IBDFN=$P(MSG(2),D,4) Q:IBDFN<1
25 ;============================================================
26 ; Check to see if the dfn is a tp member and has a valid facility
27 Q:'$$TPP^IBATUTL(IBDFN)
28 S IBPREF=$$PPF^IBATUTL(IBDFN) Q:'IBPREF
29 ;============================================================
30 ; Get the Rx data
31 D EN^PSOORDER(IBDFN,IBRXIEN) Q:'$D(^TMP("PSOR",$J,IBRXIEN,0))
32 ; Determine if this is a refill or original and
33 ; Return to stock or release from stock
34 S IBSEL=$$IBDETM(IBRXIEN) Q:$P(IBSEL,U)="Q"
35 ; I IBREL=1 Return to stock ; IBREL=0 Release from stock
36 ; I IBIND>0 this is a Refill
37 S IBIND=$P($P(IBSEL,U),"|"),IBREL=$P($P(IBSEL,U),"|",2)
38 S IBSOURCE=IBRXIEN_";PSRX(;"_IBIND
39 Q:'$D(^TMP("PSOR",$J,IBRXIEN,"DRUG",0)) S IBDRUG=$P($P($G(^(0)),U),";")
40 ;==============================================================
41 ; if transaction already exists and this is a return to stock
42 I $D(^IBAT(351.61,"AD",IBSOURCE)),(IBREL) D Q
43 . S IBATIEN=$O(^IBAT(351.61,"AD",IBSOURCE,""))
44 . D DEL^IBATFILE(IBATIEN)
45 ;==============================================================
46 ; Original Rx and Released from stock
47 I '$D(^IBAT(351.61,"AD",IBSOURCE)),('IBREL),('IBIND) D Q
48 . S IBQTY=$P(IBSEL,U,7),IBCOST=$P(IBSEL,U,11),IBEDT=$P(IBSEL,U,4)
49 . S IBATFILE=$$RX^IBATFILE(IBDFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST)
50 ;==============================================================
51 ; Refill Rx and Released from stock
52 I '$D(^IBAT(351.61,"AD",IBSOURCE)),('IBREL),(IBIND) D Q
53 . S IBQTY=$P(IBSEL,U,5),IBCOST=$P(IBSEL,U,7),IBEDT=$P(IBSEL,U,2)
54 . S IBATFILE=$$RX^IBATFILE(IBDFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST)
55 ;==============================================================
56 Q
57IBDETM(X) ; Check to see if we have a original or refill
58 ; if original return 0|0 or 1 ^the node ^TMP("PSOR",$J,RXIEN,0)
59 ; if refill return n=refill#|0 or 1^the node ^TMP("PSOR",$J,RXIEN,"REF",n,0)
60 ; piece 1 0|0 means we have a original fill and released from stock
61 ; piece 1 0|1 means we have a original fill and returned to stock
62 ; ==========================================
63 ; If this is a refill return the following:
64 ; piece 1 (n|0 or 1) where "n" is the refill number and
65 ; 0="released from stock" and 1="returned to stock"
66 ; ==========================================
67 ; all other conditions return "Q"
68 ; Note: You need to Invoke EN^PSOORDER first
69 ;
70 N RX0,FND,REFILL,Z,REFILLN,RTSFILL,ACT,ACTN,ACTON
71 I '$D(^TMP("PSOR",$J,X,0)) S IBDETM="Q^Could not fine the global TMP('PSOR',$J) for RXIEN="_X Q IBDETM
72 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
73 ;====================================================================
74 ; (1). Determine if the Orig RX was Returned to Stock (rts)
75 S (RTSFILL,ACTON)=" "
76 I $D(^TMP("PSOR",$J,X,"ACT")) D
77 . S ACT=$O(^TMP("PSOR",$J,X,"ACT",""),-1) Q:'$G(ACT)
78 . S ACTN=$G(^TMP("PSOR",$J,X,"ACT",ACT,0)),ACTON=1
79 . ; P14 is only for ORIG Rx's that have been rts, check no refill, orig rts
80 . 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
81 . ;
82 . ;=================Decision code for Refill or RTS====================
83 . I "^DELETED^RETURNED TO STOCK^"[(U_$P(ACTN,U,2)_U),$P(ACTN,U,4)["REFILL" D Q
84 . . S RTSFILL=$P($P(ACTN,U,4)," ",2) Q:'RTSFILL
85 . . S LASTREF=$O(^TMP("PSOR",$J,X,"REF",""),-1) ;always compare the last ref node
86 . . I LASTREF,$D(^TMP("PSOR",$J,X,"REF",LASTREF,0)),(LASTREF'<RTSFILL) D
87 . . . ; REFILL:
88 . . . ; must compare the last REFILL node with the last return to stock date on the "ACT" node
89 . . . ; if this is a REFILL than the LASTREF'<RTSFILL
90 . . . ; otherwise your last activity shows a rts for x refill
91 . . . ; and you have a remaining refill node x-1
92 . . . S REFILLN=$G(^TMP("PSOR",$J,X,"REF",LASTREF,0))
93 . . . S IBDETM=LASTREF_"|0^"_REFILLN Q
94 . . E S IBDETM=RTSFILL_"|1^"_X Q
95 . I $P(ACTN,U,2)["RETURN",$P(ACTN,U,4)["ORIG",$D(^TMP("PSOR",$J,X,"REF",1,0)) D Q
96 . . ; Case where the previous action was a return to stock of the orig
97 . . ; the new action is a FILL 1
98 . . S RTSFILL=1,REFILLN=$G(^TMP("PSOR",$J,X,"REF",1,0)),IBDETM=RTSFILL_"|0^"_REFILLN Q
99 I RTSFILL Q IBDETM
100 ;====================================================================
101 ; (2). Check for an original Rx. [last fill dt=Fill dt]
102 I $P(RX0,U,2)=$P(RX0,U,3),'ACTON D Q IBDETM
103 . S IBDETM="0|0^"_RX0 ; Case of released from stock.
104 ;====================================================================
105 ; (3). Check for Refills
106 S (FND,REFILL)=0
107 F S REFILL=$O(^TMP("PSOR",$J,X,"REF",REFILL)) Q:'REFILL!(FND)!(ACTON) D
108 . S Z="",Z=$O(^TMP("PSOR",$J,X,"REF",REFILL,Z)) Q:Z=""
109 . S REFILLN=$G(^TMP("PSOR",$J,X,"REF",REFILL,Z))
110 . ; i lastfill date=the refill date [we have a refill]
111 . I $P(RX0,U,3)=$P(REFILLN,U) S FND=1 D
112 . . S IBDETM=REFILL_"|0^"_REFILLN
113 ;====================================================================
114 I 'FND S IBDETM="Q^No Refill or Original found for RXIEN="_X
115 Q IBDETM
Note: See TracBrowser for help on using the repository browser.