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

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

initial load of FOIAVistA 6/30/08 version
File size: 4.6 KB
Line 
1IBCNRU1 ;BHAM ISC/CMW - IB Utilities ;15-OCT-04
2 ;;2.0;INTEGRATED BILLING;**251,276**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 Q
6 ;
7 ;return array definition
8 ;(1) - "A"ctive or "I"nactive flag.
9 ;(2) - BIN #.
10 ;(3) - PCN #.
11 ;(4) - Vender Cert ID.
12 ;(5) - Payer Sheets. (B1,B2,B3) (comma separated string).
13 ;(6) - Status codes (comma separated string).
14 ;
15STCHK(PIEN,IBARAY) ;Review status flags for all files related to this pharmacy plan
16 ;
17 NEW I,IBBIN,IBPCN,IB1,IB2,IB3,IBPBM,IBPRO,IBSTA,IBPAY,IBPST
18 NEW IBAPP,IBCODE,IBCERT
19 NEW PLN0,PLN10,AIEN,APDAT,APIEN
20 NEW NA1,NA2,NA3,NA4,LA1,LA2,LA3,LA4,DA1,DA2,DA3,DA4,FLN
21 ;
22 K IBARAY
23 ;
24 I '$G(PIEN) D G EXT
25 . S IBSTA="" D IBC(299)
26 I '$D(^IBCNR(366.03,PIEN)) D G EXT
27 . S IBSTA="" D IBC(299)
28 ;
29 S IBAPP="E-PHARM",IBSTA=1,IBCODE=""
30 S PLN0=$G(^IBCNR(366.03,PIEN,0)) D
31 . ;
32PAY . ;get PAYER
33 . S IBPAY=$P(PLN0,U,3) D
34 .. I 'IBPAY Q
35 .. ;check payer active
36 .. S AIEN=$O(^IBE(365.13,"B",IBAPP,"")) I AIEN="" Q
37 .. S APIEN=$O(^IBE(365.12,IBPAY,1,"B",AIEN,"")) I APIEN="" Q
38 .. S APDAT=$G(^IBE(365.12,IBPAY,1,APIEN,0))
39 .. S NA1=$P(APDAT,U,2) I NA1=0 S IBSTA="" D IBC(101)
40 .. S LA1=$P(APDAT,U,3) I LA1=0 S IBSTA="" D IBC(102)
41 .. S DA1=$P(APDAT,U,11) I DA1=1 S IBSTA="" D IBC(103)
42 .. ;
43PLN . ;check Plan active
44 . S AIEN=$O(^IBCNR(366.13,"B",IBAPP,"")) I AIEN="" Q
45 . S APIEN=$O(^IBCNR(366.03,PIEN,3,"B",AIEN,"")) I APIEN="" Q
46 . S APDAT=$G(^IBCNR(366.03,PIEN,3,APIEN,0))
47 . S NA2=$P(APDAT,U,2) I NA2=0 S IBSTA="" D IBC(201)
48 . S LA2=$P(APDAT,U,3) I LA2=0 S IBSTA="" D IBC(202)
49 . S DA2=$P(APDAT,U,11) I DA2=1 S IBSTA="" D IBC(203)
50 . ;
51PHM . ;check pharmacy data
52 . I '$D(^IBCNR(366.03,PIEN,10)) D
53 .. S IBSTA="" D IBC(599) Q
54 .. ;
55 . S PLN10=$G(^IBCNR(366.03,PIEN,10)) D
56 .. ;
57BIN .. ;get BIN
58 .. S IBBIN=$P(PLN10,U,2)
59 .. S IBARAY(2)=IBBIN
60 .. ;
61PCN .. ;get PCN
62 .. S IBPCN=$P(PLN10,U,3)
63 .. S IBARAY(3)=IBPCN
64 .. ;
65PBM .. ;get PBM
66 .. S IBPBM=$P(PLN10,U,1) D
67 ... I 'IBPBM Q
68 ... ;check PBM active
69 ... S AIEN=$O(^IBCNR(366.12,"B",IBAPP,"")) I AIEN="" Q
70 ... S APIEN=$O(^IBCNR(366.02,IBPBM,3,"B",AIEN,"")) I APIEN="" Q
71 ... S APDAT=$G(^IBCNR(366.02,IBPBM,3,APIEN,0))
72 ... S NA3=$P(APDAT,U,2) I NA3=0 D IBC(301) S IBSTA=""
73 ... S LA3=$P(APDAT,U,3) I LA3=0 D IBC(302) S IBSTA=""
74 ... S DA3=$P(APDAT,U,11) I DA3=1 D IBC(303) S IBSTA=""
75 ... ;
76PRO .. ;get Processor
77 .. S IBPRO=$P(PLN10,U,4) D
78 ... I 'IBPRO Q
79 ... ;check Processor active flags here
80 ... S AIEN=$O(^IBCNR(366.11,"B",IBAPP,"")) I AIEN="" Q
81 ... S APIEN=$O(^IBCNR(366.01,IBPRO,3,"B",AIEN,"")) I APIEN="" Q
82 ... S APDAT=$G(^IBCNR(366.01,IBPRO,3,APIEN,0))
83 ... S NA4=$P(APDAT,U,2) I NA4=0 D IBC(401) S IBSTA=""
84 ... S LA4=$P(APDAT,U,3) I LA4=0 D IBC(402) S IBSTA=""
85 ... S DA4=$P(APDAT,U,11) I DA4=1 D IBC(403) S IBSTA=""
86 ... ;
87VND .. ;get Vender Cert
88 .. S IBCERT=$P(PLN10,U,6)
89 .. S IBARAY(4)=IBCERT
90 .. ;
91PST .. ; Check payer sheets
92 .. N BPS,PST,PSP
93 .. N B1,B2,B3
94 .. S PST=""
95 .. ;check for test/production sheets
96 .. S (B1,B2,B3)=""
97 .. S B1=$P(PLN10,U,11),B2=$P(PLN10,U,12),B3=$P(PLN10,U,13)
98 .. I $G(B1)="" S B1=$P(PLN10,U,7)
99 .. I $G(B2)="" S B2=$P(PLN10,U,8)
100 .. I $G(B3)="" S B3=$P(PLN10,U,9)
101 .. S PST=B1_","_B2_","_B3
102 .. ;
103 .. I $G(B1)="",$G(B2)="" S IBSTA="" D IBC(699) G PSX
104 .. I $G(B1) D PSD(B1) I PSP=0 S IBSTA="" D IBC(601)
105 .. I $G(B2) D PSD(B2) I PSP=0 S IBSTA="" D IBC(602)
106 .. I $G(B1)="" S IBSTA="" D IBC(603)
107 .. I $G(B2)="" S IBSTA="" D IBC(604)
108 .. ;
109PSX .. S IBARAY(5)=PST
110 . ;
111 . ;check HIPAA NCPDP flag
112 . I '$P($G(^IBE(350.9,1,11)),U) D
113 .. S IBSTA="" D IBC(999)
114 ;
115EXT ;
116 S IBARAY(1)=$S(IBSTA="":"I",1:"A")
117 I IBCODE="" S IBCODE=200
118 S IBARAY(6)=IBCODE
119 Q
120 ;
121PSD(PS) ; check for disabled payersheet
122 S PSP=1
123 S BPS=$G(^BPSF(9002313.92,PS,1)) I $P(BPS,U,6)=0 S PSP=0
124 Q
125 ;
126IBC(CD) ;set IBCODE
127 I '$G(IBCODE) S IBCODE=CD Q
128 S IBCODE=IBCODE_","_CD
129 Q
130 ;
131STATAR(AR) ;
132 ; setup status code definition array
133 K AR
134 ; payer
135 S AR(101)="Payer not active, national."
136 S AR(102)="Payer not active, local."
137 S AR(103)="Payer Deactivated."
138 ; plan
139 S AR(200)="Plan Active"
140 S AR(201)="Plan not active, national."
141 S AR(202)="Plan not active, local."
142 S AR(203)="Plan Deactivated."
143 S AR(299)="Plan not found."
144 ; pbm
145 S AR(301)="PBM not active, national."
146 S AR(302)="PBM not active, local."
147 S AR(303)="PBM Deactivated."
148 ; processor
149 S AR(401)="Processor not active, national."
150 S AR(402)="Processor not active, local."
151 S AR(403)="Processor Deactivated."
152 ; pharmacy plan
153 S AR(599)="Pharmacy Plan not found."
154 ; payer sheets
155 S AR(601)="Billing PayerSheet Disabled."
156 S AR(602)="Reversal PayerSheet Disabled."
157 S AR(603)="Billing PayerSheet Not Found."
158 S AR(604)="Reversal PayerSheet Not Found."
159 S AR(699)="No Payer Sheets found."
160 ;
161 S AR(999)="HIPAA NCPDP Inactive."
162 ;
163 Q
Note: See TracBrowser for help on using the repository browser.