IBCNBLE2 ;ALB/ESG - Expand ins buffer - ePharmacy entry ;14-Oct-2010
;;2.0;INTEGRATED BILLING;**435,822**;21-MAR-94;Build 21
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; References to BPS RESPONSES file (#9002313.03) in ICR #4813
;
; Called by IBCNBLE when expanding an ePharmacy buffer entry
; Variable IB0 is the 0 node of file 355.33
;IB*822/CKB - 'e-Pharmacy' has been changed to 'ePharmacy' throughout this routine
;
EN ; Entry point
N RESPIEN,RSPSUB,ZR,ZM,BPSR,BPSM,BPSMD,BPSMCOB,IBY,IBL,IBLINE,TEXT
;
S RESPIEN=+$P(IB0,U,17) I 'RESPIEN G EX
I '$D(^BPSR(RESPIEN,0)) G EX
;IB*822/CKB - moved the building of the display to DISPLAY tag
D DISPLAY
EX ;
Q
;
; EN1 is called by the action Pharmacy Elig (PE) under Policy Edit/View (VP)
; ??Variable IB0 is the 0 node of file 355.33??
;
EN1(RESPIEN) ;IB*822/CKB
N BPSM,BPSMD,BPSMCOB,BPSR,IBL,IBLINE,IBPE,IBY,RSPSUB,TEXT,ZM,ZR
;
S IBPE=1
D DISPLAY
EX1 ;
Q
;
;------------------------------------------------------------------------------------------------
;
DISPLAY ;IB*822/CKB - call from EN or EN1 to display the ePharmacy
S ZR=RESPIEN_","
D GETS^DIQ(9002313.03,ZR,".01:999","IEN","BPSR") ; get all fields at top level except raw data
;
;IB*822/CKB - from EN1, if BPS RESPONSE isn't found display "no data found"
I ($G(IBPE)=1)&('$D(BPSR)) D NODATA Q
;
S RSPSUB=+$O(^BPSR(RESPIEN,1000,0)),ZM=0
I RSPSUB D
. S ZM=RSPSUB_","_RESPIEN_","
. D GETS^DIQ(9002313.0301,ZM,"112;503;511*;130.01*;549;550;987","IEN","BPSM") ; get Response Status Segment data
. Q
;
D SET^IBCNBLE(" ")
S IBY=$J("",22)_"ePharmacy Eligibility Response Data" ;IB*822/CKB - removed the '-'
D SET^IBCNBLE(IBY,"B")
;
S IBL="Transmission Status: "
S IBY=$G(BPSR(9002313.03,ZR,501,"E"))
S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,24,55)
D SET^IBCNBLE(IBLINE)
;
S IBL="Transaction Status: "
S IBY=$G(BPSM(9002313.0301,ZM,112,"E"))
S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,24,55)
D SET^IBCNBLE(IBLINE)
;
S IBL="Date of Service: "
S IBY=$G(BPSR(9002313.03,ZR,401,"E"))
S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,24,55)
D SET^IBCNBLE(IBLINE)
;
; get 504 Message
S TEXT=$G(BPSR(9002313.03,ZR,504,"E"))
I TEXT'="" D
. D SET^IBCNBLE(" ")
. N IBZ,J,LEN,PCE,CHS,NEWCHS
. S LEN=30 ; break up big words
. F PCE=1:1 Q:PCE>$L(TEXT," ") S CHS=$P(TEXT," ",PCE) I $L(CHS)>LEN D
.. S NEWCHS=$E(CHS,1,LEN)_" "_$E(CHS,LEN+1,999)
.. S $P(TEXT," ",PCE)=NEWCHS
.. Q
. D FSTRNG^IBJU1(TEXT,71,.IBZ)
. S J=0 F S J=$O(IBZ(J)) Q:'J D
.. S IBLINE=$$SETL^IBCNBLE("",IBZ(J),"",2,999)
.. D SET^IBCNBLE(IBLINE)
.. Q
. Q
;
; display reject codes 511 if they exist
I $D(BPSM(9002313.03511)) D
. N ZJ
. D SET^IBCNBLE(" ")
. D SET^IBCNBLE(" Reject Codes:")
. S ZJ="" F S ZJ=$O(BPSM(9002313.03511,ZJ)) Q:ZJ="" D SET^IBCNBLE(" "_$G(BPSM(9002313.03511,ZJ,.01,"E")))
. Q
;
; display additional messages if they exist
I $D(BPSM(9002313.13001)) D
. N ZA,TEXT
. D SET^IBCNBLE(" ")
. D SET^IBCNBLE(" Additional Message:")
. S ZA="" F S ZA=$O(BPSM(9002313.13001,ZA)) Q:ZA="" S TEXT=$G(BPSM(9002313.13001,ZA,526,"E")) I TEXT'="" D
.. N IBZ,J,LEN,PCE,CHS,NEWCHS
.. S LEN=30 ; break up big words
.. F PCE=1:1 Q:PCE>$L(TEXT," ") S CHS=$P(TEXT," ",PCE) I $L(CHS)>LEN D
... S NEWCHS=$E(CHS,1,LEN)_" "_$E(CHS,LEN+1,999)
... S $P(TEXT," ",PCE)=NEWCHS
... Q
.. D FSTRNG^IBJU1(TEXT,71,.IBZ)
.. S J=0 F S J=$O(IBZ(J)) Q:'J D
... S IBLINE=$$SETL^IBCNBLE("",IBZ(J),"",5,999)
... D SET^IBCNBLE(IBLINE)
... Q
.. Q
. Q
D SET^IBCNBLE(" ")
;
; display response insurance segment data and responses patient segment data
S IBL="Group ID: "
S IBY=$G(BPSR(9002313.03,ZR,301,"E"))
S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
I IBY'="" D SET^IBCNBLE(IBLINE)
;
S IBL="Plan ID: "
S IBY=$G(BPSR(9002313.03,ZR,524,"E"))
S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
I IBY'="" D SET^IBCNBLE(IBLINE)
;
S IBL="Network Reimbursement ID: "
S IBY=$G(BPSR(9002313.03,ZR,545,"E"))
S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
I IBY'="" D SET^IBCNBLE(IBLINE)
;
S IBL="Cardholder ID: "
S IBY=$G(BPSR(9002313.03,ZR,302,"E"))
S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
I IBY'="" D SET^IBCNBLE(IBLINE)
;
S IBL="Payer-reported First Name: "
S IBY=$G(BPSR(9002313.03,ZR,310,"E"))
S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
I IBY'="" D SET^IBCNBLE(IBLINE)
;
S IBL="Payer-reported Last Name: "
S IBY=$G(BPSR(9002313.03,ZR,311,"E"))
S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
I IBY'="" D SET^IBCNBLE(IBLINE)
;
S IBL="Payer-reported DOB: "
S IBY=$G(BPSR(9002313.03,ZR,304,"E"))
;IB*822/CKB - if the date exists, formatted it to be readable
I IBY'="" S IBY=$$DATE(IBY)
S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
I IBY'="" D SET^IBCNBLE(IBLINE)
;
S IBL="Authorization Number: "
S IBY=$G(BPSM(9002313.0301,ZM,503,"E"))
S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
I IBY'="" D SET^IBCNBLE(IBLINE)
;
S IBL="Help Desk Phone: "
S IBY=$G(BPSM(9002313.0301,ZM,550,"E"))
;IB*822/CKB - get the description from file for the Help Desk Phone # qual, if it exists
I IBY'="" D
. N BPSIEN,DESC,HDPQ
. S HDPQ=$G(BPSM(9002313.0301,ZM,549,"E"))
. S BPSIEN=$O(^BPS(9002313.44,"B",HDPQ,""))
. I BPSIEN'="" D
.. S DESC=$$GET1^DIQ(9002313.44,BPSIEN,.02)
.. S IBY=IBY_" ("_DESC_")"
;I IBY'="" D
;. N HDPQ
;. S HDPQ=$G(BPSM(9002313.0301,ZM,549,"E")) Q:HDPQ="" ; help desk phone# qualifier
;. S HDPQ=$S(+HDPQ=1:"Switch",+HDPQ=2:"Intermediary",+HDPQ=3:"Processor/PBM",1:"Other")
;. S IBY=IBY_" ("_HDPQ_")"
;. Q
S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
I IBY'="" D SET^IBCNBLE(IBLINE)
;
S IBL="URL: "
S IBY=$G(BPSM(9002313.0301,ZM,987,"E"))
I IBY'="" D
. N COL,N,M,Z,URL,J
. S COL=28 ; column to start display
. S N=79-COL ; max length of each line
. S M=0 ; array subscript
. F Z=1:N:400 S M=M+1,URL(M)=$E(IBY,Z,Z+N-1) I URL(M)="" K URL(M) Q
. S IBLINE=$$SETL^IBCNBLE("",$G(URL(1)),IBL,COL,999) ; display line 1 w/label
. D SET^IBCNBLE(IBLINE)
. S J=1 F S J=$O(URL(J)) Q:'J D
.. S IBLINE=$$SETL^IBCNBLE("",URL(J),"",COL,999) ; display the rest
.. D SET^IBCNBLE(IBLINE)
.. Q
. Q
;
; Get the Response Insurance Additional Information Segment data
; Used only for Medicare Part D Eligibility transactions
D GETS^DIQ(9002313.0301,ZM,"139;138;240;926;757;140;141","IEN","BPSMD") ; get data
I $D(BPSMD(9002313.0301)) D
. D SET^IBCNBLE(" ")
. D SET^IBCNBLE(" MEDICARE PART D ELIGIBILITY INFORMATION")
. ;
. S IBL="Coverage Code: "
. S IBY=$G(BPSMD(9002313.0301,ZM,139,"E"))
. ;IB*822/CKB - add description of the Coverage code, if code exists
. I IBY'="" D
.. N BPSIEN,BPSDESC
.. S BPSIEN=$O(^BPS(9002313.45,"B",IBY,""))
.. I BPSIEN'="" D
... S BPSDESC=$$GET1^DIQ(9002313.45,BPSIEN,.02)
... S IBY=IBY_" ("_BPSDESC_")"
. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
. D SET^IBCNBLE(IBLINE)
. ;
. S IBL="CMS LICS Level: "
. S IBY=$G(BPSMD(9002313.0301,ZM,138,"E"))
. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
. D SET^IBCNBLE(IBLINE)
. ;
. S IBL="Contract Number: "
. S IBY=$G(BPSMD(9002313.0301,ZM,240,"E"))
. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
. D SET^IBCNBLE(IBLINE)
. ;
. S IBL="Forumulary ID: "
. S IBY=$G(BPSMD(9002313.0301,ZM,926,"E"))
. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
. D SET^IBCNBLE(IBLINE)
. ;
. S IBL="Benefit ID: "
. S IBY=$G(BPSMD(9002313.0301,ZM,757,"E"))
. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
. D SET^IBCNBLE(IBLINE)
. ;
. S IBL="Next Effective Date: "
. S IBY=$G(BPSMD(9002313.0301,ZM,140,"E"))
. ;IB*822/CKB - if the date exists, formatted it to be readable
. I IBY'="" S IBY=$$DATE(IBY)
. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
. D SET^IBCNBLE(IBLINE)
. ;
. S IBL="Next Termination Date: "
. S IBY=$G(BPSMD(9002313.0301,ZM,141,"E"))
. ;IB*822/CKB - if the date exists, formatted it to be readable
. I IBY'="" S IBY=$$DATE(IBY)
. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
. D SET^IBCNBLE(IBLINE)
. ;
. Q
;
; Display Response COB/Other Payers segment
; Data stored in 9002313.035501 subfile
D GETS^DIQ(9002313.0301,ZM,"355.01*","IEN","BPSMCOB") ; get data
I $D(BPSMCOB(9002313.035501)) D
. N ZC,ZCTOT,ZCN
. S ZC="" F ZCTOT=0:1 S ZC=$O(BPSMCOB(9002313.035501,ZC)) Q:ZC="" ; count how many entries exist
. S ZC="",ZCN=0 F S ZC=$O(BPSMCOB(9002313.035501,ZC)) Q:ZC="" D
.. S ZCN=ZCN+1
.. D SET^IBCNBLE(" ")
.. D SET^IBCNBLE(" COB/OTHER PAYER INFORMATION ("_ZCN_" of "_ZCTOT_")")
.. ;
.. S IBL="Coverage Type: "
.. S IBY=$G(BPSMCOB(9002313.035501,ZC,338,"E"))
.. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
.. I IBY'="" D SET^IBCNBLE(IBLINE)
.. ;
.. S IBL="Payer ID Qual: "
.. S IBY=$G(BPSMCOB(9002313.035501,ZC,339,"E"))
.. ;IB*822/CKB - add description of the Payer ID Qual code, if code exists
.. I IBY'="" D
... N BPSIEN,BPSDESC
... S BPSIEN=$O(^BPS(9002313.43,"B",IBY,""))
... I BPSIEN'="" D
.... S BPSDESC=$$GET1^DIQ(9002313.43,BPSIEN,.02)
.... S IBY=IBY_" ("_BPSDESC_")"
.. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
.. I IBY'="" D SET^IBCNBLE(IBLINE)
.. ;
.. S IBL="ID: " ;IB*822/CKB - changed from 'Payer ID' to 'ID'
.. S IBY=$G(BPSMCOB(9002313.035501,ZC,340,"E"))
.. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
.. I IBY'="" D SET^IBCNBLE(IBLINE)
.. ;
.. S IBL="Processor Cntrl#: "
.. S IBY=$G(BPSMCOB(9002313.035501,ZC,991,"E"))
.. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
.. I IBY'="" D SET^IBCNBLE(IBLINE)
.. ;
.. S IBL="Cardholder ID: "
.. S IBY=$G(BPSMCOB(9002313.035501,ZC,356,"E"))
.. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
.. I IBY'="" D SET^IBCNBLE(IBLINE)
.. ;
.. S IBL="Group ID: "
.. S IBY=$G(BPSMCOB(9002313.035501,ZC,992,"E"))
.. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
.. I IBY'="" D SET^IBCNBLE(IBLINE)
.. ;
.. S IBL="Person Code: "
.. S IBY=$G(BPSMCOB(9002313.035501,ZC,142,"E"))
.. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
.. I IBY'="" D SET^IBCNBLE(IBLINE)
.. ;
.. S IBL="Help Desk Phone: "
.. S IBY=$G(BPSMCOB(9002313.035501,ZC,127,"E"))
.. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
.. I IBY'="" D SET^IBCNBLE(IBLINE)
.. ;
.. S IBL="Patient Rel Code: "
.. S IBY=$G(BPSMCOB(9002313.035501,ZC,143,"E"))
.. ;IB*822/CKB - add description of the Patient Rel code, if code exists
.. I IBY'="" D
... N BPSIEN,BPSDESC
... S BPSIEN=$O(^BPS(9002313.19,"B",IBY,""))
... I BPSIEN'="" D
.... S BPSDESC=$$GET1^DIQ(9002313.19,BPSIEN,.02)
.... S IBY=IBY_" ("_BPSDESC_")"
.. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
.. I IBY'="" D SET^IBCNBLE(IBLINE)
.. ;
.. S IBL="Benefit Effective: "
.. S IBY=$G(BPSMCOB(9002313.035501,ZC,144,"E"))
.. ;IB*822/CKB - if the date exists, formatted it to be readable
.. I IBY'="" S IBY=$$DATE(IBY)
.. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
.. I IBY'="" D SET^IBCNBLE(IBLINE)
.. ;
.. S IBL="Benefit Term: "
.. S IBY=$G(BPSMCOB(9002313.035501,ZC,145,"E"))
.. ;IB*822/CKB - if the date exists, formatted it to be readable
.. I IBY'="" S IBY=$$DATE(IBY)
.. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
.. I IBY'="" D SET^IBCNBLE(IBLINE)
.. ;
.. Q
. Q
;
;IB*822/CKB - If called from Pharmacy Elig (PE) add a Blank line to the end
I $G(IBPE)=1 D SET^IBCNBLE(" ")
Q
;
DATE(X) ;IB*822/CKB - make the date readable, convert YYYYMMDD to MM/DD/YYYY
Q $E(X,5,6)_"/"_$E(X,7,8)_"/"_$E(X,1,4)
;
NODATA ;IB*822/CKB - if BPS RESPONSE is not found display no data found
;Display screen heading
D SET^IBCNBLE(" ")
S IBY=$J("",22)_"ePharmacy Eligibility Response Data"
D SET^IBCNBLE(IBY,"B")
;
D SET^IBCNBLE(" ")
S IBL="No ePharmacy Eligibility Data found."
S IBLINE=$$SETL^IBCNBLE("","",IBL,24,55)
D SET^IBCNBLE(IBLINE)
D SET^IBCNBLE(" ")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNBLE2 11971 printed Mar 25, 2026@15:38:52 Page 2
IBCNBLE2 ;ALB/ESG - Expand ins buffer - ePharmacy entry ;14-Oct-2010
+1 ;;2.0;INTEGRATED BILLING;**435,822**;21-MAR-94;Build 21
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; References to BPS RESPONSES file (#9002313.03) in ICR #4813
+5 ;
+6 ; Called by IBCNBLE when expanding an ePharmacy buffer entry
+7 ; Variable IB0 is the 0 node of file 355.33
+8 ;IB*822/CKB - 'e-Pharmacy' has been changed to 'ePharmacy' throughout this routine
+9 ;
EN ; Entry point
+1 NEW RESPIEN,RSPSUB,ZR,ZM,BPSR,BPSM,BPSMD,BPSMCOB,IBY,IBL,IBLINE,TEXT
+2 ;
+3 SET RESPIEN=+$PIECE(IB0,U,17)
IF 'RESPIEN
GOTO EX
+4 IF '$DATA(^BPSR(RESPIEN,0))
GOTO EX
+5 ;IB*822/CKB - moved the building of the display to DISPLAY tag
+6 DO DISPLAY
EX ;
+1 QUIT
+2 ;
+3 ; EN1 is called by the action Pharmacy Elig (PE) under Policy Edit/View (VP)
+4 ; ??Variable IB0 is the 0 node of file 355.33??
+5 ;
EN1(RESPIEN) ;IB*822/CKB
+1 NEW BPSM,BPSMD,BPSMCOB,BPSR,IBL,IBLINE,IBPE,IBY,RSPSUB,TEXT,ZM,ZR
+2 ;
+3 SET IBPE=1
+4 DO DISPLAY
EX1 ;
+1 QUIT
+2 ;
+3 ;------------------------------------------------------------------------------------------------
+4 ;
DISPLAY ;IB*822/CKB - call from EN or EN1 to display the ePharmacy
+1 SET ZR=RESPIEN_","
+2 ; get all fields at top level except raw data
DO GETS^DIQ(9002313.03,ZR,".01:999","IEN","BPSR")
+3 ;
+4 ;IB*822/CKB - from EN1, if BPS RESPONSE isn't found display "no data found"
+5 IF ($GET(IBPE)=1)&('$DATA(BPSR))
DO NODATA
QUIT
+6 ;
+7 SET RSPSUB=+$ORDER(^BPSR(RESPIEN,1000,0))
SET ZM=0
+8 IF RSPSUB
Begin DoDot:1
+9 SET ZM=RSPSUB_","_RESPIEN_","
+10 ; get Response Status Segment data
DO GETS^DIQ(9002313.0301,ZM,"112;503;511*;130.01*;549;550;987","IEN","BPSM")
+11 QUIT
End DoDot:1
+12 ;
+13 DO SET^IBCNBLE(" ")
+14 ;IB*822/CKB - removed the '-'
SET IBY=$JUSTIFY("",22)_"ePharmacy Eligibility Response Data"
+15 DO SET^IBCNBLE(IBY,"B")
+16 ;
+17 SET IBL="Transmission Status: "
+18 SET IBY=$GET(BPSR(9002313.03,ZR,501,"E"))
+19 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,24,55)
+20 DO SET^IBCNBLE(IBLINE)
+21 ;
+22 SET IBL="Transaction Status: "
+23 SET IBY=$GET(BPSM(9002313.0301,ZM,112,"E"))
+24 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,24,55)
+25 DO SET^IBCNBLE(IBLINE)
+26 ;
+27 SET IBL="Date of Service: "
+28 SET IBY=$GET(BPSR(9002313.03,ZR,401,"E"))
+29 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,24,55)
+30 DO SET^IBCNBLE(IBLINE)
+31 ;
+32 ; get 504 Message
+33 SET TEXT=$GET(BPSR(9002313.03,ZR,504,"E"))
+34 IF TEXT'=""
Begin DoDot:1
+35 DO SET^IBCNBLE(" ")
+36 NEW IBZ,J,LEN,PCE,CHS,NEWCHS
+37 ; break up big words
SET LEN=30
+38 FOR PCE=1:1
if PCE>$LENGTH(TEXT," ")
QUIT
SET CHS=$PIECE(TEXT," ",PCE)
IF $LENGTH(CHS)>LEN
Begin DoDot:2
+39 SET NEWCHS=$EXTRACT(CHS,1,LEN)_" "_$EXTRACT(CHS,LEN+1,999)
+40 SET $PIECE(TEXT," ",PCE)=NEWCHS
+41 QUIT
End DoDot:2
+42 DO FSTRNG^IBJU1(TEXT,71,.IBZ)
+43 SET J=0
FOR
SET J=$ORDER(IBZ(J))
if 'J
QUIT
Begin DoDot:2
+44 SET IBLINE=$$SETL^IBCNBLE("",IBZ(J),"",2,999)
+45 DO SET^IBCNBLE(IBLINE)
+46 QUIT
End DoDot:2
+47 QUIT
End DoDot:1
+48 ;
+49 ; display reject codes 511 if they exist
+50 IF $DATA(BPSM(9002313.03511))
Begin DoDot:1
+51 NEW ZJ
+52 DO SET^IBCNBLE(" ")
+53 DO SET^IBCNBLE(" Reject Codes:")
+54 SET ZJ=""
FOR
SET ZJ=$ORDER(BPSM(9002313.03511,ZJ))
if ZJ=""
QUIT
DO SET^IBCNBLE(" "_$GET(BPSM(9002313.03511,ZJ,.01,"E")))
+55 QUIT
End DoDot:1
+56 ;
+57 ; display additional messages if they exist
+58 IF $DATA(BPSM(9002313.13001))
Begin DoDot:1
+59 NEW ZA,TEXT
+60 DO SET^IBCNBLE(" ")
+61 DO SET^IBCNBLE(" Additional Message:")
+62 SET ZA=""
FOR
SET ZA=$ORDER(BPSM(9002313.13001,ZA))
if ZA=""
QUIT
SET TEXT=$GET(BPSM(9002313.13001,ZA,526,"E"))
IF TEXT'=""
Begin DoDot:2
+63 NEW IBZ,J,LEN,PCE,CHS,NEWCHS
+64 ; break up big words
SET LEN=30
+65 FOR PCE=1:1
if PCE>$LENGTH(TEXT," ")
QUIT
SET CHS=$PIECE(TEXT," ",PCE)
IF $LENGTH(CHS)>LEN
Begin DoDot:3
+66 SET NEWCHS=$EXTRACT(CHS,1,LEN)_" "_$EXTRACT(CHS,LEN+1,999)
+67 SET $PIECE(TEXT," ",PCE)=NEWCHS
+68 QUIT
End DoDot:3
+69 DO FSTRNG^IBJU1(TEXT,71,.IBZ)
+70 SET J=0
FOR
SET J=$ORDER(IBZ(J))
if 'J
QUIT
Begin DoDot:3
+71 SET IBLINE=$$SETL^IBCNBLE("",IBZ(J),"",5,999)
+72 DO SET^IBCNBLE(IBLINE)
+73 QUIT
End DoDot:3
+74 QUIT
End DoDot:2
+75 QUIT
End DoDot:1
+76 DO SET^IBCNBLE(" ")
+77 ;
+78 ; display response insurance segment data and responses patient segment data
+79 SET IBL="Group ID: "
+80 SET IBY=$GET(BPSR(9002313.03,ZR,301,"E"))
+81 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+82 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+83 ;
+84 SET IBL="Plan ID: "
+85 SET IBY=$GET(BPSR(9002313.03,ZR,524,"E"))
+86 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+87 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+88 ;
+89 SET IBL="Network Reimbursement ID: "
+90 SET IBY=$GET(BPSR(9002313.03,ZR,545,"E"))
+91 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+92 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+93 ;
+94 SET IBL="Cardholder ID: "
+95 SET IBY=$GET(BPSR(9002313.03,ZR,302,"E"))
+96 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+97 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+98 ;
+99 SET IBL="Payer-reported First Name: "
+100 SET IBY=$GET(BPSR(9002313.03,ZR,310,"E"))
+101 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+102 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+103 ;
+104 SET IBL="Payer-reported Last Name: "
+105 SET IBY=$GET(BPSR(9002313.03,ZR,311,"E"))
+106 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+107 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+108 ;
+109 SET IBL="Payer-reported DOB: "
+110 SET IBY=$GET(BPSR(9002313.03,ZR,304,"E"))
+111 ;IB*822/CKB - if the date exists, formatted it to be readable
+112 IF IBY'=""
SET IBY=$$DATE(IBY)
+113 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+114 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+115 ;
+116 SET IBL="Authorization Number: "
+117 SET IBY=$GET(BPSM(9002313.0301,ZM,503,"E"))
+118 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+119 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+120 ;
+121 SET IBL="Help Desk Phone: "
+122 SET IBY=$GET(BPSM(9002313.0301,ZM,550,"E"))
+123 ;IB*822/CKB - get the description from file for the Help Desk Phone # qual, if it exists
+124 IF IBY'=""
Begin DoDot:1
+125 NEW BPSIEN,DESC,HDPQ
+126 SET HDPQ=$GET(BPSM(9002313.0301,ZM,549,"E"))
+127 SET BPSIEN=$ORDER(^BPS(9002313.44,"B",HDPQ,""))
+128 IF BPSIEN'=""
Begin DoDot:2
+129 SET DESC=$$GET1^DIQ(9002313.44,BPSIEN,.02)
+130 SET IBY=IBY_" ("_DESC_")"
End DoDot:2
End DoDot:1
+131 ;I IBY'="" D
+132 ;. N HDPQ
+133 ;. S HDPQ=$G(BPSM(9002313.0301,ZM,549,"E")) Q:HDPQ="" ; help desk phone# qualifier
+134 ;. S HDPQ=$S(+HDPQ=1:"Switch",+HDPQ=2:"Intermediary",+HDPQ=3:"Processor/PBM",1:"Other")
+135 ;. S IBY=IBY_" ("_HDPQ_")"
+136 ;. Q
+137 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+138 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+139 ;
+140 SET IBL="URL: "
+141 SET IBY=$GET(BPSM(9002313.0301,ZM,987,"E"))
+142 IF IBY'=""
Begin DoDot:1
+143 NEW COL,N,M,Z,URL,J
+144 ; column to start display
SET COL=28
+145 ; max length of each line
SET N=79-COL
+146 ; array subscript
SET M=0
+147 FOR Z=1:N:400
SET M=M+1
SET URL(M)=$EXTRACT(IBY,Z,Z+N-1)
IF URL(M)=""
KILL URL(M)
QUIT
+148 ; display line 1 w/label
SET IBLINE=$$SETL^IBCNBLE("",$GET(URL(1)),IBL,COL,999)
+149 DO SET^IBCNBLE(IBLINE)
+150 SET J=1
FOR
SET J=$ORDER(URL(J))
if 'J
QUIT
Begin DoDot:2
+151 ; display the rest
SET IBLINE=$$SETL^IBCNBLE("",URL(J),"",COL,999)
+152 DO SET^IBCNBLE(IBLINE)
+153 QUIT
End DoDot:2
+154 QUIT
End DoDot:1
+155 ;
+156 ; Get the Response Insurance Additional Information Segment data
+157 ; Used only for Medicare Part D Eligibility transactions
+158 ; get data
DO GETS^DIQ(9002313.0301,ZM,"139;138;240;926;757;140;141","IEN","BPSMD")
+159 IF $DATA(BPSMD(9002313.0301))
Begin DoDot:1
+160 DO SET^IBCNBLE(" ")
+161 DO SET^IBCNBLE(" MEDICARE PART D ELIGIBILITY INFORMATION")
+162 ;
+163 SET IBL="Coverage Code: "
+164 SET IBY=$GET(BPSMD(9002313.0301,ZM,139,"E"))
+165 ;IB*822/CKB - add description of the Coverage code, if code exists
+166 IF IBY'=""
Begin DoDot:2
+167 NEW BPSIEN,BPSDESC
+168 SET BPSIEN=$ORDER(^BPS(9002313.45,"B",IBY,""))
+169 IF BPSIEN'=""
Begin DoDot:3
+170 SET BPSDESC=$$GET1^DIQ(9002313.45,BPSIEN,.02)
+171 SET IBY=IBY_" ("_BPSDESC_")"
End DoDot:3
End DoDot:2
+172 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+173 DO SET^IBCNBLE(IBLINE)
+174 ;
+175 SET IBL="CMS LICS Level: "
+176 SET IBY=$GET(BPSMD(9002313.0301,ZM,138,"E"))
+177 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+178 DO SET^IBCNBLE(IBLINE)
+179 ;
+180 SET IBL="Contract Number: "
+181 SET IBY=$GET(BPSMD(9002313.0301,ZM,240,"E"))
+182 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+183 DO SET^IBCNBLE(IBLINE)
+184 ;
+185 SET IBL="Forumulary ID: "
+186 SET IBY=$GET(BPSMD(9002313.0301,ZM,926,"E"))
+187 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+188 DO SET^IBCNBLE(IBLINE)
+189 ;
+190 SET IBL="Benefit ID: "
+191 SET IBY=$GET(BPSMD(9002313.0301,ZM,757,"E"))
+192 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+193 DO SET^IBCNBLE(IBLINE)
+194 ;
+195 SET IBL="Next Effective Date: "
+196 SET IBY=$GET(BPSMD(9002313.0301,ZM,140,"E"))
+197 ;IB*822/CKB - if the date exists, formatted it to be readable
+198 IF IBY'=""
SET IBY=$$DATE(IBY)
+199 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+200 DO SET^IBCNBLE(IBLINE)
+201 ;
+202 SET IBL="Next Termination Date: "
+203 SET IBY=$GET(BPSMD(9002313.0301,ZM,141,"E"))
+204 ;IB*822/CKB - if the date exists, formatted it to be readable
+205 IF IBY'=""
SET IBY=$$DATE(IBY)
+206 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+207 DO SET^IBCNBLE(IBLINE)
+208 ;
+209 QUIT
End DoDot:1
+210 ;
+211 ; Display Response COB/Other Payers segment
+212 ; Data stored in 9002313.035501 subfile
+213 ; get data
DO GETS^DIQ(9002313.0301,ZM,"355.01*","IEN","BPSMCOB")
+214 IF $DATA(BPSMCOB(9002313.035501))
Begin DoDot:1
+215 NEW ZC,ZCTOT,ZCN
+216 ; count how many entries exist
SET ZC=""
FOR ZCTOT=0:1
SET ZC=$ORDER(BPSMCOB(9002313.035501,ZC))
if ZC=""
QUIT
+217 SET ZC=""
SET ZCN=0
FOR
SET ZC=$ORDER(BPSMCOB(9002313.035501,ZC))
if ZC=""
QUIT
Begin DoDot:2
+218 SET ZCN=ZCN+1
+219 DO SET^IBCNBLE(" ")
+220 DO SET^IBCNBLE(" COB/OTHER PAYER INFORMATION ("_ZCN_" of "_ZCTOT_")")
+221 ;
+222 SET IBL="Coverage Type: "
+223 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,338,"E"))
+224 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+225 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+226 ;
+227 SET IBL="Payer ID Qual: "
+228 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,339,"E"))
+229 ;IB*822/CKB - add description of the Payer ID Qual code, if code exists
+230 IF IBY'=""
Begin DoDot:3
+231 NEW BPSIEN,BPSDESC
+232 SET BPSIEN=$ORDER(^BPS(9002313.43,"B",IBY,""))
+233 IF BPSIEN'=""
Begin DoDot:4
+234 SET BPSDESC=$$GET1^DIQ(9002313.43,BPSIEN,.02)
+235 SET IBY=IBY_" ("_BPSDESC_")"
End DoDot:4
End DoDot:3
+236 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+237 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+238 ;
+239 ;IB*822/CKB - changed from 'Payer ID' to 'ID'
SET IBL="ID: "
+240 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,340,"E"))
+241 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+242 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+243 ;
+244 SET IBL="Processor Cntrl#: "
+245 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,991,"E"))
+246 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+247 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+248 ;
+249 SET IBL="Cardholder ID: "
+250 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,356,"E"))
+251 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+252 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+253 ;
+254 SET IBL="Group ID: "
+255 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,992,"E"))
+256 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+257 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+258 ;
+259 SET IBL="Person Code: "
+260 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,142,"E"))
+261 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+262 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+263 ;
+264 SET IBL="Help Desk Phone: "
+265 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,127,"E"))
+266 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+267 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+268 ;
+269 SET IBL="Patient Rel Code: "
+270 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,143,"E"))
+271 ;IB*822/CKB - add description of the Patient Rel code, if code exists
+272 IF IBY'=""
Begin DoDot:3
+273 NEW BPSIEN,BPSDESC
+274 SET BPSIEN=$ORDER(^BPS(9002313.19,"B",IBY,""))
+275 IF BPSIEN'=""
Begin DoDot:4
+276 SET BPSDESC=$$GET1^DIQ(9002313.19,BPSIEN,.02)
+277 SET IBY=IBY_" ("_BPSDESC_")"
End DoDot:4
End DoDot:3
+278 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+279 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+280 ;
+281 SET IBL="Benefit Effective: "
+282 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,144,"E"))
+283 ;IB*822/CKB - if the date exists, formatted it to be readable
+284 IF IBY'=""
SET IBY=$$DATE(IBY)
+285 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+286 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+287 ;
+288 SET IBL="Benefit Term: "
+289 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,145,"E"))
+290 ;IB*822/CKB - if the date exists, formatted it to be readable
+291 IF IBY'=""
SET IBY=$$DATE(IBY)
+292 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+293 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+294 ;
+295 QUIT
End DoDot:2
+296 QUIT
End DoDot:1
+297 ;
+298 ;IB*822/CKB - If called from Pharmacy Elig (PE) add a Blank line to the end
+299 IF $GET(IBPE)=1
DO SET^IBCNBLE(" ")
+300 QUIT
+301 ;
DATE(X) ;IB*822/CKB - make the date readable, convert YYYYMMDD to MM/DD/YYYY
+1 QUIT $EXTRACT(X,5,6)_"/"_$EXTRACT(X,7,8)_"/"_$EXTRACT(X,1,4)
+2 ;
NODATA ;IB*822/CKB - if BPS RESPONSE is not found display no data found
+1 ;Display screen heading
+2 DO SET^IBCNBLE(" ")
+3 SET IBY=$JUSTIFY("",22)_"ePharmacy Eligibility Response Data"
+4 DO SET^IBCNBLE(IBY,"B")
+5 ;
+6 DO SET^IBCNBLE(" ")
+7 SET IBL="No ePharmacy Eligibility Data found."
+8 SET IBLINE=$$SETL^IBCNBLE("","",IBL,24,55)
+9 DO SET^IBCNBLE(IBLINE)
+10 DO SET^IBCNBLE(" ")
+11 QUIT
