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

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

initial load of FOIAVistA 6/30/08 version
File size: 5.1 KB
Line 
1IBNCPDP3 ;OAK/ELZ - STORES NDC/AWP UPDATES ;20-JUN-2003
2 ;;2.0;INTEGRATED BILLING;**223,276,342,363**;21-MAR-94;Build 35
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;
6UPAWP(IBNDC,IBAWP,IBADT) ; updates AWP prices for NDCs
7 ;
8 N IBITEM,IBCS
9 ;
10 ;
11 S IBCS=$P($G(^IBE(350.9,1,9)),"^",12)
12 I 'IBCS Q "0^Unable to find Charge Set"
13 ;
14 S IBNDC=$$NDC^IBNCPDPU(IBNDC)
15 ;
16 S IBITEM=+$$ADDBI^IBCREF("NDC",IBNDC) I IBITEM Q "0^Unable to add item"
17 ;
18 I '$$ADDCI^IBCREF(IBCS,IBITEM,IBADT,IBAWP) Q "0^Unable to add charge"
19 ;
20 Q 1
21 ;
22 ;
23 ;
24 ;
25REVERSE(DFN,IBD,IBAUTO) ;process reversed claims
26 N IBIFN,I,IB,IBIL,IBCHG,IBCRES,IBY,X,Y,DA,DIE,DR,IBADT,IBLOCK,IBLDT
27 N IBNOW,IBDUZ,IBCR,IBRELC,IBCC,IBPAP,IBRXN,IBFIL,IBRTS,IBARES,IBUSR
28 S IBDUZ=.5
29 ;
30 S IBLOCK=0
31 ; find bill number
32 I 'DFN S IBY="0^No patient" G REVQ
33 I '$L($G(IBD("CLAIMID"))) S IBY="0^Missing ECME Number" G REVQ
34 S IBADT=+$G(IBD("FILL DATE")) I 'IBADT S IBY="0^Missing Fill Date" G REVQ
35 S IBRXN=+$G(IBD("PRESCRIPTION")) I 'IBRXN S IBY="0^No Rx IEN" G REVQ
36 S IBFIL=+$G(IBD("FILL NUMBER"),-1) I IBFIL<0 S IBY="0^No fill number" G REVQ
37 I $E($G(IBD("RESPONSE")),1)="R" D G REVQ:+'$G(IBRTS)
38 . S IBY="0^REVERSAL rejected by payer"
39 . S IBRTS=$$RTS(IBD("REVERSAL REASON"))
40 ;
41 S IBD("BCID")=(+IBD("CLAIMID"))_";"_IBADT ; BC ID Number
42 L +^DGCR(399,"AG",IBD("BCID")):15 E S IBY="0^Cannot lock ECME number" G REVQ
43 S IBLOCK=1
44 S IBUSR=$S(+$G(IBD("USER"))=0:DUZ,1:IBD("USER"))
45 I $D(^DGCR(399,"AG",IBD("BCID"))) S ^(IBD("BCID"))=""
46 S IBIFN=$$MATCH^IBNCPDP2(IBD("BCID"))
47 I $D(IBD("CLOSE REASON")),'$D(IBD("DROP TO PAPER")) S IBD("DROP TO PAPER")=""
48 S IBCR=+$G(IBD("CLOSE REASON"))
49 S IBPAP=$G(IBD("DROP TO PAPER"))
50 S IBRELC=$G(IBD("RELEASE COPAY"))
51 S IBCC=$G(IBD("CLOSE COMMENT"))
52 D NONBR^IBNCPNB(DFN,IBRXN,IBFIL,IBADT,IBCR,IBPAP,IBRELC,IBCC,IBUSR)
53 I 'IBIFN S IBY="0^"_$S(IBPAP:"Dropped to paper",IBCR>1:"Set non-billable reason in CT",1:"Cannot find the bill to reverse") G REVQ
54 ;
55 F I=0,"S" S IB(I)=$G(^DGCR(399,IBIFN,I))
56 I IB(0)="" S IBY="0^No data in bill" G REVQ
57 I +$P(IB("S"),U,16),$P(IB("S"),U,17)]"" S IBY="0^Bill already cancelled" G REVQ
58 ;
59 S:'$D(IBCRES) IBCRES="ECME PRESCRIPTION REVERSED"
60 S DA=IBIFN,DR="16////1;19////"_IBCRES,DIE="^DGCR(399,"
61 D ^DIE K DA,DIE,DR
62 ;
63 ; - decrease out the receivable in AR
64 S IB("U1")=$G(^DGCR(399,IBIFN,"U1"))
65 S IBIL=$P($G(^PRCA(430,IBIFN,0)),"^")
66 S IBCHG=$S(IB("U1")']"":0,$P(IB("U1"),"^",1)]"":$P(IB("U1"),"^",1),1:0)
67 ;
68 S X="21^"_IBCHG_"^"_IBIL_"^"_IBDUZ_"^"_DT_"^"_IBCRES
69 D ^PRCASER1
70 S IBARES=Y
71 I IBARES<0 S IBY=IBARES D BULL
72 ;
73 S IBY=$S(IBARES<0:"0^"_$P(IBARES,"^",2),1:1)
74 ;
75 I IBDUZ'=DUZ D ; set the real user
76 . N IBI,IBT S IBI=18,IBT(399,IBIFN_",",IBI)=IBDUZ D FILE^DIE("","IBT")
77 ;
78REVQ ; perform end of job tasks
79 D LOG^IBNCPDP2($S($G(IBAUTO)=1:"AUTO REVERSE",$G(IBAUTO)=2:"BILL CANCELLED",1:"REVERSE"),IBY)
80 I IBLOCK L -^DGCR(399,"AG",IBD("BCID"))
81 I IBY=1,$G(IBIFN) S IBY=+IBIFN
82 Q IBY
83 ;
84RTS(IBRR) ; Return to Stock processing on Released Rx
85 ; input - IBRR = reversal reason
86 ; IBCRSN = passed in by reference
87 ; output - 0 = reversal not due to a Rx RETURN TO STOCK or Rx DELETE
88 ; 1 = reversal due to a Rx RETURN TO STOCK or Rx DELETE
89 ; IBCRSN = charge removal reason
90 I IBRR'="RX RETURNED TO STOCK"&(IBRR'="RX DELETED") Q 0
91 N IBTRKRN,IBLOCK2,IBCMT,DA,DIE,DR
92 S IBTRKRN=+$O(^IBT(356,"ARXFL",IBRXN,IBFIL,0))
93 I 'IBTRKRN Q 0 ; CT record does not exist
94 I '$P($G(^IBT(356,IBTRKRN,0)),U,11) Q 0 ; BILL does not exist
95 S IBCRES=$$GETRSN(DFN,IBRXN,IBFIL) ; recorded in file 399 entry
96 L +^IBT(356,IBTRKRN):5 S IBLOCK2=$T
97 S DIE="^IBT(356,",DA=IBTRKRN,IBCMT="Rx RTS - May Need Refund"
98 S DR="1.08////"_IBCMT
99 D ^DIE
100 I IBLOCK2 L -^IBT(356,IBTRKRN)
101 Q 1
102 ;
103BULL ; Generate a bulletin if there is an error in cancelling the claim.
104 N IBC,IBT,IBPT,IBGRP,XMDUZ,XMTEXT,XMSUB,XMY
105 ;
106 S IBPT=$$PT^IBEFUNC(DFN)
107 S XMSUB=$E($P(IBPT,"^"),1,14)_" "_$P(IBPT,"^",3)_" - ERROR ENCOUNTERED"
108 S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="IBT("
109 S XMY(IBDUZ)=""
110 S XMY("G.IBCNR EPHARM")=""
111 ;
112 S IBT(1)="An error occurred while cancelling the Pharmacy claim from ECME"
113 S IBT(2)="fiscal intermediary for the following patient:"
114 S IBT(3)=" " S IBC=3
115 D PAT^IBAERR1 ; Accepts IBDUZ
116 S IBC=IBC+1,IBT(IBC)=" Bill #: "_IBIL
117 S IBC=IBC+1,IBT(IBC)=" "
118 S IBC=IBC+1,IBT(IBC)="The following error was encountered:"
119 S IBC=IBC+1,IBT(IBC)=" "
120 D ERR^IBAERR1
121 S IBC=IBC+1,IBT(IBC)=" "
122 S IBC=IBC+1,IBT(IBC)="Please review the circumstances surrounding this error and decrease"
123 S IBC=IBC+1,IBT(IBC)="out this receivable in Accounts Receivable if necessary."
124 D ^XMD
125 Q
126 ;
127GETRSN(DFN,IBRXN,IBFIL) ;
128 ; retrieve charge removal reason from file 354.71
129 ; input - DFN,IBRXN=Rx ien,IBFIL=fill number
130 ; output - charge removal reason
131 N IBDT,IBDA,IBXRSN,IBRXFIL,IB0
132 S (IBDT,IBDA)=0,IBXRSN=""
133 S IBRXFIL=$S('IBFIL:IBRXN,1:IBRXN_";"_IBFIL)
134 F S IBDT=$O(^IBAM(354.71,"AD",DFN,IBDT)) Q:'IBDT Q:IBXRSN]"" D
135 . F S IBDA=$O(^IBAM(354.71,"AD",DFN,IBDT,IBDA)) Q:'IBDA Q:IBXRSN]"" D
136 . . S IB0=^IBAM(354.71,IBDA,0)
137 . . Q:$P(IB0,"^",6)'[IBRXFIL
138 . . S IBXRSN=$$GET1^DIQ(354.71,IBDA_",",.19)
139 S:IBXRSN']"" IBXRSN="CHARGE REMOVAL REASON NOT FOUND"
140 Q "Reversal Rej, no pymt due<>"_IBXRSN
141 ;
142 ;IBNCPDP3
Note: See TracBrowser for help on using the repository browser.