IBCNRU1 ;BHAM ISC/CMW - IB Utilities ;15-OCT-04
;;2.0;INTEGRATED BILLING;**251,276,435,550**;21-MAR-94;Build 25
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
;return array definition
;(1) - "A"ctive or "I"nactive flag.
;(2) - BIN #.
;(3) - PCN #.
;(4) - Vender Cert ID.
;(5) - Payer Sheets. (B1,B2,B3,E1) (comma separated string).
;(6) - Status codes (comma separated string).
;
STCHK(PIEN,IBARAY,ELIG) ;Review status flags for all files related to this pharmacy plan
;
; PIEN - plan ien to file# 366.03
; IBARAY - output array pass by reference
; ELIG - eligibility request flag
; 1=eligibility request
; 0=claim request (default)
;
NEW I,IBBIN,IBPCN,IBPBM,IBPRO,IBSTA,IBPAY
NEW IBAPP,IBCODE,IBCERT
NEW PLN0,PLN10,AIEN,APDAT,APIEN
NEW NA1,NA2,NA3,NA4,LA1,LA2,LA3,LA4,DA1,DA2,DA3,DA4
;
K IBARAY
S ELIG=$G(ELIG,0)
;
I '$G(PIEN) S IBSTA="" D IBC(299) G EXT
I '$D(^IBCNR(366.03,PIEN)) S IBSTA="" D IBC(299) G EXT
;
S IBAPP="E-PHARM",IBSTA=1,IBCODE=""
S PLN0=$G(^IBCNR(366.03,PIEN,0)) D
. ; check Plan active
. S AIEN=$O(^IBCNR(366.13,"B",IBAPP,"")) I AIEN="" Q
. S APIEN=$O(^IBCNR(366.03,PIEN,3,"B",AIEN,"")) I APIEN="" Q
. S APDAT=$G(^IBCNR(366.03,PIEN,3,APIEN,0))
. S NA2=$P(APDAT,U,2) I NA2=0 S IBSTA="" D IBC(201)
. S LA2=$P(APDAT,U,3) I LA2=0 S IBSTA="" D IBC(202)
. S DA2=$P(APDAT,U,11) I DA2=1 S IBSTA="" D IBC(203)
. ;
. ; check pharmacy data
. I '$D(^IBCNR(366.03,PIEN,10)) S IBSTA="" D IBC(599)
. ;
. S PLN10=$G(^IBCNR(366.03,PIEN,10)) D
.. ;
.. ; get BIN
.. S IBBIN=$P(PLN10,U,2)
.. S IBARAY(2)=IBBIN
.. ;
.. ; get PCN
.. S IBPCN=$P(PLN10,U,3)
.. S IBARAY(3)=IBPCN
.. ;
.. ; get PBM
.. S IBPBM=$P(PLN10,U,1) D
... I 'IBPBM Q
... ;check PBM active
... S AIEN=$O(^IBCNR(366.12,"B",IBAPP,"")) I AIEN="" Q
... S APIEN=$O(^IBCNR(366.02,IBPBM,3,"B",AIEN,"")) I APIEN="" Q
... S APDAT=$G(^IBCNR(366.02,IBPBM,3,APIEN,0))
... S NA3=$P(APDAT,U,2) I NA3=0 D IBC(301) S IBSTA=""
... S LA3=$P(APDAT,U,3) I LA3=0 D IBC(302) S IBSTA=""
... S DA3=$P(APDAT,U,11) I DA3=1 D IBC(303) S IBSTA=""
... Q
.. ;
.. ; get Processor
.. S IBPRO=$P(PLN10,U,4) D
... I 'IBPRO Q
... ;check Processor active flags here
... S AIEN=$O(^IBCNR(366.11,"B",IBAPP,"")) I AIEN="" Q
... S APIEN=$O(^IBCNR(366.01,IBPRO,3,"B",AIEN,"")) I APIEN="" Q
... S APDAT=$G(^IBCNR(366.01,IBPRO,3,APIEN,0))
... S NA4=$P(APDAT,U,2) I NA4=0 D IBC(401) S IBSTA=""
... S LA4=$P(APDAT,U,3) I LA4=0 D IBC(402) S IBSTA=""
... S DA4=$P(APDAT,U,11) I DA4=1 D IBC(403) S IBSTA=""
... Q
.. ;
.. ; get Vender Cert
.. S IBCERT=$P(PLN10,U,6)
.. S IBARAY(4)=IBCERT
.. ;
.. ; Check payer sheets
.. N BPS,PST,PSP
.. N B1,B2,B3,E1
.. S PST=""
.. ;
.. ; check for test/production sheets
.. ; get the test payer sheet first. If nil, then get the regular payer sheet
.. S (B1,B2,B3,E1)=""
.. S B1=$P(PLN10,U,11),B2=$P(PLN10,U,12),B3=$P(PLN10,U,13),E1=$P(PLN10,U,14)
.. I 'B1 S B1=$P(PLN10,U,7) ; billing
.. I 'B2 S B2=$P(PLN10,U,8) ; reversal
.. I 'B3 S B3=$P(PLN10,U,9) ; rebill (not currently validated)
.. I 'E1 S E1=$P(PLN10,U,15) ; eligibility
.. S PST=B1_","_B2_","_B3_","_E1
.. S IBARAY(5)=PST ; save the payer sheet iens
.. ;
.. ; perform payer sheet validation for claim request
.. I 'ELIG D
... I 'B1,'B2 S IBSTA="" D IBC(699) Q
... I B1 D PSD(B1) I PSP=0 S IBSTA="" D IBC(601)
... I B2 D PSD(B2) I PSP=0 S IBSTA="" D IBC(602)
... I 'B1 S IBSTA="" D IBC(603)
... I 'B2 S IBSTA="" D IBC(604)
... Q
.. ;
.. ; perform payer sheet validation for eligibility request
.. I ELIG D
... I E1 D PSD(E1) I PSP=0 S IBSTA="" D IBC(605)
... I 'E1 S IBSTA="" D IBC(606)
... Q
.. Q
. ;
. ;check HIPAA NCPDP flag
. I '$P($G(^IBE(350.9,1,11)),U,1) S IBSTA="" D IBC(999)
. Q
;
EXT ;
S IBARAY(1)=$S(IBSTA="":"I",1:"A")
I IBCODE="" S IBCODE=200 ; all is well
S IBARAY(6)=IBCODE
Q
;
PSD(PS) ; check for disabled payersheet
S PSP=1
S BPS=$G(^BPSF(9002313.92,PS,1)) I $P(BPS,U,6)=0 S PSP=0
Q
;
IBC(CD) ;set IBCODE
I '$G(IBCODE) S IBCODE=CD Q
S IBCODE=IBCODE_","_CD
Q
;
STATAR(AR) ;
; setup status code definition array
K AR
; plan
S AR(200)="Plan Active"
S AR(201)="Plan not active, national."
S AR(202)="Plan not active, local."
S AR(203)="Plan Deactivated."
S AR(299)="Plan not found."
; pbm
S AR(301)="PBM not active, national."
S AR(302)="PBM not active, local."
S AR(303)="PBM Deactivated."
; processor
S AR(401)="Processor not active, national."
S AR(402)="Processor not active, local."
S AR(403)="Processor Deactivated."
; pharmacy plan
S AR(599)="Pharmacy Plan not found."
; payer sheets
S AR(601)="Billing PayerSheet Disabled."
S AR(602)="Reversal PayerSheet Disabled."
S AR(603)="Billing PayerSheet Not Found."
S AR(604)="Reversal PayerSheet Not Found."
S AR(605)="Eligibility PayerSheet Disabled."
S AR(606)="Eligibility PayerSheet Not Found."
S AR(699)="No Payer Sheets found."
;
S AR(999)="HIPAA NCPDP Inactive."
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNRU1 5173 printed Mar 13, 2025@21:21:32 Page 2
IBCNRU1 ;BHAM ISC/CMW - IB Utilities ;15-OCT-04
+1 ;;2.0;INTEGRATED BILLING;**251,276,435,550**;21-MAR-94;Build 25
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
+6 ;return array definition
+7 ;(1) - "A"ctive or "I"nactive flag.
+8 ;(2) - BIN #.
+9 ;(3) - PCN #.
+10 ;(4) - Vender Cert ID.
+11 ;(5) - Payer Sheets. (B1,B2,B3,E1) (comma separated string).
+12 ;(6) - Status codes (comma separated string).
+13 ;
STCHK(PIEN,IBARAY,ELIG) ;Review status flags for all files related to this pharmacy plan
+1 ;
+2 ; PIEN - plan ien to file# 366.03
+3 ; IBARAY - output array pass by reference
+4 ; ELIG - eligibility request flag
+5 ; 1=eligibility request
+6 ; 0=claim request (default)
+7 ;
+8 NEW I,IBBIN,IBPCN,IBPBM,IBPRO,IBSTA,IBPAY
+9 NEW IBAPP,IBCODE,IBCERT
+10 NEW PLN0,PLN10,AIEN,APDAT,APIEN
+11 NEW NA1,NA2,NA3,NA4,LA1,LA2,LA3,LA4,DA1,DA2,DA3,DA4
+12 ;
+13 KILL IBARAY
+14 SET ELIG=$GET(ELIG,0)
+15 ;
+16 IF '$GET(PIEN)
SET IBSTA=""
DO IBC(299)
GOTO EXT
+17 IF '$DATA(^IBCNR(366.03,PIEN))
SET IBSTA=""
DO IBC(299)
GOTO EXT
+18 ;
+19 SET IBAPP="E-PHARM"
SET IBSTA=1
SET IBCODE=""
+20 SET PLN0=$GET(^IBCNR(366.03,PIEN,0))
Begin DoDot:1
+21 ; check Plan active
+22 SET AIEN=$ORDER(^IBCNR(366.13,"B",IBAPP,""))
IF AIEN=""
QUIT
+23 SET APIEN=$ORDER(^IBCNR(366.03,PIEN,3,"B",AIEN,""))
IF APIEN=""
QUIT
+24 SET APDAT=$GET(^IBCNR(366.03,PIEN,3,APIEN,0))
+25 SET NA2=$PIECE(APDAT,U,2)
IF NA2=0
SET IBSTA=""
DO IBC(201)
+26 SET LA2=$PIECE(APDAT,U,3)
IF LA2=0
SET IBSTA=""
DO IBC(202)
+27 SET DA2=$PIECE(APDAT,U,11)
IF DA2=1
SET IBSTA=""
DO IBC(203)
+28 ;
+29 ; check pharmacy data
+30 IF '$DATA(^IBCNR(366.03,PIEN,10))
SET IBSTA=""
DO IBC(599)
+31 ;
+32 SET PLN10=$GET(^IBCNR(366.03,PIEN,10))
Begin DoDot:2
+33 ;
+34 ; get BIN
+35 SET IBBIN=$PIECE(PLN10,U,2)
+36 SET IBARAY(2)=IBBIN
+37 ;
+38 ; get PCN
+39 SET IBPCN=$PIECE(PLN10,U,3)
+40 SET IBARAY(3)=IBPCN
+41 ;
+42 ; get PBM
+43 SET IBPBM=$PIECE(PLN10,U,1)
Begin DoDot:3
+44 IF 'IBPBM
QUIT
+45 ;check PBM active
+46 SET AIEN=$ORDER(^IBCNR(366.12,"B",IBAPP,""))
IF AIEN=""
QUIT
+47 SET APIEN=$ORDER(^IBCNR(366.02,IBPBM,3,"B",AIEN,""))
IF APIEN=""
QUIT
+48 SET APDAT=$GET(^IBCNR(366.02,IBPBM,3,APIEN,0))
+49 SET NA3=$PIECE(APDAT,U,2)
IF NA3=0
DO IBC(301)
SET IBSTA=""
+50 SET LA3=$PIECE(APDAT,U,3)
IF LA3=0
DO IBC(302)
SET IBSTA=""
+51 SET DA3=$PIECE(APDAT,U,11)
IF DA3=1
DO IBC(303)
SET IBSTA=""
+52 QUIT
End DoDot:3
+53 ;
+54 ; get Processor
+55 SET IBPRO=$PIECE(PLN10,U,4)
Begin DoDot:3
+56 IF 'IBPRO
QUIT
+57 ;check Processor active flags here
+58 SET AIEN=$ORDER(^IBCNR(366.11,"B",IBAPP,""))
IF AIEN=""
QUIT
+59 SET APIEN=$ORDER(^IBCNR(366.01,IBPRO,3,"B",AIEN,""))
IF APIEN=""
QUIT
+60 SET APDAT=$GET(^IBCNR(366.01,IBPRO,3,APIEN,0))
+61 SET NA4=$PIECE(APDAT,U,2)
IF NA4=0
DO IBC(401)
SET IBSTA=""
+62 SET LA4=$PIECE(APDAT,U,3)
IF LA4=0
DO IBC(402)
SET IBSTA=""
+63 SET DA4=$PIECE(APDAT,U,11)
IF DA4=1
DO IBC(403)
SET IBSTA=""
+64 QUIT
End DoDot:3
+65 ;
+66 ; get Vender Cert
+67 SET IBCERT=$PIECE(PLN10,U,6)
+68 SET IBARAY(4)=IBCERT
+69 ;
+70 ; Check payer sheets
+71 NEW BPS,PST,PSP
+72 NEW B1,B2,B3,E1
+73 SET PST=""
+74 ;
+75 ; check for test/production sheets
+76 ; get the test payer sheet first. If nil, then get the regular payer sheet
+77 SET (B1,B2,B3,E1)=""
+78 SET B1=$PIECE(PLN10,U,11)
SET B2=$PIECE(PLN10,U,12)
SET B3=$PIECE(PLN10,U,13)
SET E1=$PIECE(PLN10,U,14)
+79 ; billing
IF 'B1
SET B1=$PIECE(PLN10,U,7)
+80 ; reversal
IF 'B2
SET B2=$PIECE(PLN10,U,8)
+81 ; rebill (not currently validated)
IF 'B3
SET B3=$PIECE(PLN10,U,9)
+82 ; eligibility
IF 'E1
SET E1=$PIECE(PLN10,U,15)
+83 SET PST=B1_","_B2_","_B3_","_E1
+84 ; save the payer sheet iens
SET IBARAY(5)=PST
+85 ;
+86 ; perform payer sheet validation for claim request
+87 IF 'ELIG
Begin DoDot:3
+88 IF 'B1
IF 'B2
SET IBSTA=""
DO IBC(699)
QUIT
+89 IF B1
DO PSD(B1)
IF PSP=0
SET IBSTA=""
DO IBC(601)
+90 IF B2
DO PSD(B2)
IF PSP=0
SET IBSTA=""
DO IBC(602)
+91 IF 'B1
SET IBSTA=""
DO IBC(603)
+92 IF 'B2
SET IBSTA=""
DO IBC(604)
+93 QUIT
End DoDot:3
+94 ;
+95 ; perform payer sheet validation for eligibility request
+96 IF ELIG
Begin DoDot:3
+97 IF E1
DO PSD(E1)
IF PSP=0
SET IBSTA=""
DO IBC(605)
+98 IF 'E1
SET IBSTA=""
DO IBC(606)
+99 QUIT
End DoDot:3
+100 QUIT
End DoDot:2
+101 ;
+102 ;check HIPAA NCPDP flag
+103 IF '$PIECE($GET(^IBE(350.9,1,11)),U,1)
SET IBSTA=""
DO IBC(999)
+104 QUIT
End DoDot:1
+105 ;
EXT ;
+1 SET IBARAY(1)=$SELECT(IBSTA="":"I",1:"A")
+2 ; all is well
IF IBCODE=""
SET IBCODE=200
+3 SET IBARAY(6)=IBCODE
+4 QUIT
+5 ;
PSD(PS) ; check for disabled payersheet
+1 SET PSP=1
+2 SET BPS=$GET(^BPSF(9002313.92,PS,1))
IF $PIECE(BPS,U,6)=0
SET PSP=0
+3 QUIT
+4 ;
IBC(CD) ;set IBCODE
+1 IF '$GET(IBCODE)
SET IBCODE=CD
QUIT
+2 SET IBCODE=IBCODE_","_CD
+3 QUIT
+4 ;
STATAR(AR) ;
+1 ; setup status code definition array
+2 KILL AR
+3 ; plan
+4 SET AR(200)="Plan Active"
+5 SET AR(201)="Plan not active, national."
+6 SET AR(202)="Plan not active, local."
+7 SET AR(203)="Plan Deactivated."
+8 SET AR(299)="Plan not found."
+9 ; pbm
+10 SET AR(301)="PBM not active, national."
+11 SET AR(302)="PBM not active, local."
+12 SET AR(303)="PBM Deactivated."
+13 ; processor
+14 SET AR(401)="Processor not active, national."
+15 SET AR(402)="Processor not active, local."
+16 SET AR(403)="Processor Deactivated."
+17 ; pharmacy plan
+18 SET AR(599)="Pharmacy Plan not found."
+19 ; payer sheets
+20 SET AR(601)="Billing PayerSheet Disabled."
+21 SET AR(602)="Reversal PayerSheet Disabled."
+22 SET AR(603)="Billing PayerSheet Not Found."
+23 SET AR(604)="Reversal PayerSheet Not Found."
+24 SET AR(605)="Eligibility PayerSheet Disabled."
+25 SET AR(606)="Eligibility PayerSheet Not Found."
+26 SET AR(699)="No Payer Sheets found."
+27 ;
+28 SET AR(999)="HIPAA NCPDP Inactive."
+29 ;
+30 QUIT
