IBCNBLE2 ;ALB/ESG - Expand ins buffer - e-Pharmacy entry ;14-Oct-2010
;;2.0;INTEGRATED BILLING;**435**;21-MAR-94;Build 27
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; References to BPS RESPONSES file (#9002313.03) supported by IA 4813
; Called by IBCNBLE when expanding an e-Pharmacy buffer entry
; Variable IB0 is the 0 node of file 355.33
;
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
S ZR=RESPIEN_","
D GETS^DIQ(9002313.03,ZR,".01:999","IEN","BPSR") ; get all fields at top level except raw data
;
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)_"e-Pharmacy Eligibility Response Data"
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"))
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"))
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"))
. 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"))
. 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"))
. 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"))
.. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
.. I IBY'="" D SET^IBCNBLE(IBLINE)
.. ;
.. S IBL="Payer 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"))
.. 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"))
.. 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"))
.. S IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
.. I IBY'="" D SET^IBCNBLE(IBLINE)
.. ;
.. Q
. Q
;
EX ;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNBLE2 8927 printed Dec 13, 2024@02:14:05 Page 2
IBCNBLE2 ;ALB/ESG - Expand ins buffer - e-Pharmacy entry ;14-Oct-2010
+1 ;;2.0;INTEGRATED BILLING;**435**;21-MAR-94;Build 27
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; References to BPS RESPONSES file (#9002313.03) supported by IA 4813
+5 ; Called by IBCNBLE when expanding an e-Pharmacy buffer entry
+6 ; Variable IB0 is the 0 node of file 355.33
+7 ;
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 SET ZR=RESPIEN_","
+6 ; get all fields at top level except raw data
DO GETS^DIQ(9002313.03,ZR,".01:999","IEN","BPSR")
+7 ;
+8 SET RSPSUB=+$ORDER(^BPSR(RESPIEN,1000,0))
SET ZM=0
+9 IF RSPSUB
Begin DoDot:1
+10 SET ZM=RSPSUB_","_RESPIEN_","
+11 ; get Response Status Segment data
DO GETS^DIQ(9002313.0301,ZM,"112;503;511*;130.01*;549;550;987","IEN","BPSM")
+12 QUIT
End DoDot:1
+13 ;
+14 DO SET^IBCNBLE(" ")
+15 SET IBY=$JUSTIFY("",22)_"e-Pharmacy Eligibility Response Data"
+16 DO SET^IBCNBLE(IBY,"B")
+17 ;
+18 SET IBL="Transmission Status: "
+19 SET IBY=$GET(BPSR(9002313.03,ZR,501,"E"))
+20 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,24,55)
+21 DO SET^IBCNBLE(IBLINE)
+22 ;
+23 SET IBL="Transaction Status: "
+24 SET IBY=$GET(BPSM(9002313.0301,ZM,112,"E"))
+25 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,24,55)
+26 DO SET^IBCNBLE(IBLINE)
+27 ;
+28 SET IBL="Date of Service: "
+29 SET IBY=$GET(BPSR(9002313.03,ZR,401,"E"))
+30 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,24,55)
+31 DO SET^IBCNBLE(IBLINE)
+32 ;
+33 ; get 504 Message
+34 SET TEXT=$GET(BPSR(9002313.03,ZR,504,"E"))
+35 IF TEXT'=""
Begin DoDot:1
+36 DO SET^IBCNBLE(" ")
+37 NEW IBZ,J,LEN,PCE,CHS,NEWCHS
+38 ; break up big words
SET LEN=30
+39 FOR PCE=1:1
if PCE>$LENGTH(TEXT," ")
QUIT
SET CHS=$PIECE(TEXT," ",PCE)
IF $LENGTH(CHS)>LEN
Begin DoDot:2
+40 SET NEWCHS=$EXTRACT(CHS,1,LEN)_" "_$EXTRACT(CHS,LEN+1,999)
+41 SET $PIECE(TEXT," ",PCE)=NEWCHS
+42 QUIT
End DoDot:2
+43 DO FSTRNG^IBJU1(TEXT,71,.IBZ)
+44 SET J=0
FOR
SET J=$ORDER(IBZ(J))
if 'J
QUIT
Begin DoDot:2
+45 SET IBLINE=$$SETL^IBCNBLE("",IBZ(J),"",2,999)
+46 DO SET^IBCNBLE(IBLINE)
+47 QUIT
End DoDot:2
+48 QUIT
End DoDot:1
+49 ;
+50 ; display reject codes 511 if they exist
+51 IF $DATA(BPSM(9002313.03511))
Begin DoDot:1
+52 NEW ZJ
+53 DO SET^IBCNBLE(" ")
+54 DO SET^IBCNBLE(" Reject Codes:")
+55 SET ZJ=""
FOR
SET ZJ=$ORDER(BPSM(9002313.03511,ZJ))
if ZJ=""
QUIT
DO SET^IBCNBLE(" "_$GET(BPSM(9002313.03511,ZJ,.01,"E")))
+56 QUIT
End DoDot:1
+57 ;
+58 ; display additional messages if they exist
+59 IF $DATA(BPSM(9002313.13001))
Begin DoDot:1
+60 NEW ZA,TEXT
+61 DO SET^IBCNBLE(" ")
+62 DO SET^IBCNBLE(" Additional Message:")
+63 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
+64 NEW IBZ,J,LEN,PCE,CHS,NEWCHS
+65 ; break up big words
SET LEN=30
+66 FOR PCE=1:1
if PCE>$LENGTH(TEXT," ")
QUIT
SET CHS=$PIECE(TEXT," ",PCE)
IF $LENGTH(CHS)>LEN
Begin DoDot:3
+67 SET NEWCHS=$EXTRACT(CHS,1,LEN)_" "_$EXTRACT(CHS,LEN+1,999)
+68 SET $PIECE(TEXT," ",PCE)=NEWCHS
+69 QUIT
End DoDot:3
+70 DO FSTRNG^IBJU1(TEXT,71,.IBZ)
+71 SET J=0
FOR
SET J=$ORDER(IBZ(J))
if 'J
QUIT
Begin DoDot:3
+72 SET IBLINE=$$SETL^IBCNBLE("",IBZ(J),"",5,999)
+73 DO SET^IBCNBLE(IBLINE)
+74 QUIT
End DoDot:3
+75 QUIT
End DoDot:2
+76 QUIT
End DoDot:1
+77 DO SET^IBCNBLE(" ")
+78 ;
+79 ; display response insurance segment data and responses patient segment data
+80 SET IBL="Group ID: "
+81 SET IBY=$GET(BPSR(9002313.03,ZR,301,"E"))
+82 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+83 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+84 ;
+85 SET IBL="Plan ID: "
+86 SET IBY=$GET(BPSR(9002313.03,ZR,524,"E"))
+87 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+88 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+89 ;
+90 SET IBL="Network Reimbursement ID: "
+91 SET IBY=$GET(BPSR(9002313.03,ZR,545,"E"))
+92 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+93 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+94 ;
+95 SET IBL="Cardholder ID: "
+96 SET IBY=$GET(BPSR(9002313.03,ZR,302,"E"))
+97 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+98 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+99 ;
+100 SET IBL="Payer-reported First Name: "
+101 SET IBY=$GET(BPSR(9002313.03,ZR,310,"E"))
+102 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+103 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+104 ;
+105 SET IBL="Payer-reported Last Name: "
+106 SET IBY=$GET(BPSR(9002313.03,ZR,311,"E"))
+107 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+108 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+109 ;
+110 SET IBL="Payer-reported DOB: "
+111 SET IBY=$GET(BPSR(9002313.03,ZR,304,"E"))
+112 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+113 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+114 ;
+115 SET IBL="Authorization Number: "
+116 SET IBY=$GET(BPSM(9002313.0301,ZM,503,"E"))
+117 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+118 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+119 ;
+120 SET IBL="Help Desk Phone: "
+121 SET IBY=$GET(BPSM(9002313.0301,ZM,550,"E"))
+122 IF IBY'=""
Begin DoDot:1
+123 NEW HDPQ
+124 ; help desk phone# qualifier
SET HDPQ=$GET(BPSM(9002313.0301,ZM,549,"E"))
if HDPQ=""
QUIT
+125 SET HDPQ=$SELECT(+HDPQ=1:"Switch",+HDPQ=2:"Intermediary",+HDPQ=3:"Processor/PBM",1:"Other")
+126 SET IBY=IBY_" ("_HDPQ_")"
+127 QUIT
End DoDot:1
+128 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,28,51)
+129 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+130 ;
+131 SET IBL="URL: "
+132 SET IBY=$GET(BPSM(9002313.0301,ZM,987,"E"))
+133 IF IBY'=""
Begin DoDot:1
+134 NEW COL,N,M,Z,URL,J
+135 ; column to start display
SET COL=28
+136 ; max length of each line
SET N=79-COL
+137 ; array subscript
SET M=0
+138 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
+139 ; display line 1 w/label
SET IBLINE=$$SETL^IBCNBLE("",$GET(URL(1)),IBL,COL,999)
+140 DO SET^IBCNBLE(IBLINE)
+141 SET J=1
FOR
SET J=$ORDER(URL(J))
if 'J
QUIT
Begin DoDot:2
+142 ; display the rest
SET IBLINE=$$SETL^IBCNBLE("",URL(J),"",COL,999)
+143 DO SET^IBCNBLE(IBLINE)
+144 QUIT
End DoDot:2
+145 QUIT
End DoDot:1
+146 ;
+147 ; Get the Response Insurance Additional Information Segment data
+148 ; Used only for Medicare Part D Eligibility transactions
+149 ; get data
DO GETS^DIQ(9002313.0301,ZM,"139;138;240;926;757;140;141","IEN","BPSMD")
+150 IF $DATA(BPSMD(9002313.0301))
Begin DoDot:1
+151 DO SET^IBCNBLE(" ")
+152 DO SET^IBCNBLE(" MEDICARE PART D ELIGIBILITY INFORMATION")
+153 ;
+154 SET IBL="Coverage Code: "
+155 SET IBY=$GET(BPSMD(9002313.0301,ZM,139,"E"))
+156 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+157 DO SET^IBCNBLE(IBLINE)
+158 ;
+159 SET IBL="CMS LICS Level: "
+160 SET IBY=$GET(BPSMD(9002313.0301,ZM,138,"E"))
+161 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+162 DO SET^IBCNBLE(IBLINE)
+163 ;
+164 SET IBL="Contract Number: "
+165 SET IBY=$GET(BPSMD(9002313.0301,ZM,240,"E"))
+166 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+167 DO SET^IBCNBLE(IBLINE)
+168 ;
+169 SET IBL="Forumulary ID: "
+170 SET IBY=$GET(BPSMD(9002313.0301,ZM,926,"E"))
+171 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+172 DO SET^IBCNBLE(IBLINE)
+173 ;
+174 SET IBL="Benefit ID: "
+175 SET IBY=$GET(BPSMD(9002313.0301,ZM,757,"E"))
+176 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+177 DO SET^IBCNBLE(IBLINE)
+178 ;
+179 SET IBL="Next Effective Date: "
+180 SET IBY=$GET(BPSMD(9002313.0301,ZM,140,"E"))
+181 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+182 DO SET^IBCNBLE(IBLINE)
+183 ;
+184 SET IBL="Next Termination Date: "
+185 SET IBY=$GET(BPSMD(9002313.0301,ZM,141,"E"))
+186 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,25,54)
+187 DO SET^IBCNBLE(IBLINE)
+188 ;
+189 QUIT
End DoDot:1
+190 ;
+191 ; Display Response COB/Other Payers segment
+192 ; Data stored in 9002313.035501 subfile
+193 ; get data
DO GETS^DIQ(9002313.0301,ZM,"355.01*","IEN","BPSMCOB")
+194 IF $DATA(BPSMCOB(9002313.035501))
Begin DoDot:1
+195 NEW ZC,ZCTOT,ZCN
+196 ; count how many entries exist
SET ZC=""
FOR ZCTOT=0:1
SET ZC=$ORDER(BPSMCOB(9002313.035501,ZC))
if ZC=""
QUIT
+197 SET ZC=""
SET ZCN=0
FOR
SET ZC=$ORDER(BPSMCOB(9002313.035501,ZC))
if ZC=""
QUIT
Begin DoDot:2
+198 SET ZCN=ZCN+1
+199 DO SET^IBCNBLE(" ")
+200 DO SET^IBCNBLE(" COB/OTHER PAYER INFORMATION ("_ZCN_" of "_ZCTOT_")")
+201 ;
+202 SET IBL="Coverage Type: "
+203 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,338,"E"))
+204 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+205 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+206 ;
+207 SET IBL="Payer ID Qual: "
+208 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,339,"E"))
+209 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+210 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+211 ;
+212 SET IBL="Payer ID: "
+213 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,340,"E"))
+214 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+215 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+216 ;
+217 SET IBL="Processor Cntrl#: "
+218 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,991,"E"))
+219 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+220 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+221 ;
+222 SET IBL="Cardholder ID: "
+223 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,356,"E"))
+224 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+225 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+226 ;
+227 SET IBL="Group ID: "
+228 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,992,"E"))
+229 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+230 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+231 ;
+232 SET IBL="Person Code: "
+233 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,142,"E"))
+234 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+235 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+236 ;
+237 SET IBL="Help Desk Phone: "
+238 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,127,"E"))
+239 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+240 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+241 ;
+242 SET IBL="Patient Rel Code: "
+243 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,143,"E"))
+244 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+245 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+246 ;
+247 SET IBL="Benefit Effective: "
+248 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,144,"E"))
+249 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+250 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+251 ;
+252 SET IBL="Benefit Term: "
+253 SET IBY=$GET(BPSMCOB(9002313.035501,ZC,145,"E"))
+254 SET IBLINE=$$SETL^IBCNBLE("",IBY,IBL,22,57)
+255 IF IBY'=""
DO SET^IBCNBLE(IBLINE)
+256 ;
+257 QUIT
End DoDot:2
+258 QUIT
End DoDot:1
+259 ;
EX ;
+1 QUIT
+2 ;
