IBNCPDS1 ;ALB/BDB - DISPLAY RX COB DETERMINATION ;30-NOV-07
;;2.0;INTEGRATED BILLING;**411,452,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
% ; -- main entry point to display rx cob determination
EN ;
S U="^"
D FULL^VALM1
N DIROUT,DIRUT,DTOUT,DUOUT,IBADT,IBANY,IBINS,IBQUIT,IBT,IBX,X,Y
S IBQUIT=0
S DIR("?",1)="Enter the date for which you want to see active insurances."
S DIR("?",2)="A valid date entry is required, or"
S DIR("?")="enter up-arrow ( ^ ) to return to the main display screen."
S DIR("A")="Date of Service",DIR("A",1)=" ",DIR("B")="TODAY",DIR(0)="D"
F D ^DIR Q:$D(DTOUT)!$D(DUOUT) S IBADT=Y,IBQUIT=1 Q:IBQUIT
K DIR
G:'IBQUIT COBQ
; -- look up insurance for patient
K IBINS S IBINS=0
D ALL^IBCNS1(DFN,"IBINS",1,IBADT,1)
;
; -- no pharmacy coverage, quit
I '$$PTCOV^IBCNSU3(DFN,IBADT,"PHARMACY",.IBANY) G COBQ
D EN^DDIOL("Insurance Co.COB Type of Policy Group Holder Effect. Expires Elec/Paper","","!!?1")
;
S IBX=0
F S IBX=$O(IBINS("S",IBX)) Q:'IBX D
. S IBT=0 F S IBT=$O(IBINS("S",IBX,IBT)) Q:'IBT D
.. N IBCAT,IBCOB,IBDAT,IBEFFDT,IBELEC,IBEXPDT,IBGRPN,IBHOLD,IBINSN,IBPIEN,IBPL,IBPTYPE,IBY,IBZ
.. S IBQUIT=1
.. Q:'$G(IBINS(IBT,0))
.. S IBPL=$$GET1^DIQ(2.312,IBT_","_DFN_",",.18,"I") ; plan
.. Q:'IBPL
.. S IBCAT=$O(^IBE(355.31,"B","PHARMACY","")) I '$G(IBCAT)!'$$PLCOV^IBCNSU3(IBPL,IBADT,IBCAT) Q ; not covered
.. S IBINSN=$$GET1^DIQ(2.312,IBT_","_DFN_",",.01) ; ins name
.. S IBPTYPE=$$GET1^DIQ(355.3,IBPL_",",.09) ; plan type
.. S IBCOB=$$GET1^DIQ(2.312,IBT_","_DFN_",",.2,"I"),IBCOB=$S(IBCOB=1:"p",IBCOB=2:"s",IBCOB=3:"t",1:"p") ; cob indicator
.. ;IB*2.0*516/baa - Use HIPAA compliant Group ID
.. ;S IBGRPN=$$GET1^DIQ(355.3,$$GET1^DIQ(2.312,IBT_","_DFN_",",.18,"I")_",",.04) ; group id
.. S IBGRPN=$$GET1^DIQ(355.3,$$GET1^DIQ(2.312,IBT_","_DFN_",",.18,"I")_",",2.02) ; group id ; 516 - baa
.. S IBHOLD=$$GET1^DIQ(2.312,IBT_","_DFN_",",6,"I") ; subscriber id
.. S IBHOLD=$S(IBHOLD="v":"SELF",IBHOLD="s":"SPOUSE",IBHOLD="o":"OTHER",1:"")
.. S IBEFFDT=$P(IBINS(IBT,0),U,8) I IBEFFDT]"" S IBEFFDT=$$DFORMAT(IBEFFDT) ; effective date
.. S IBEXPDT=$P(IBINS(IBT,0),U,4) I IBEXPDT]"" S IBEXPDT=$$DFORMAT(IBEXPDT) ; expiration date
.. S IBELEC="P" D
... S IBPIEN=$$GET1^DIQ(355.3,$$GET1^DIQ(2.312,IBT_","_DFN_",",.18,"I")_",",6.01,"I")
... I 'IBPIEN Q ; Not linked
... D STCHK^IBCNRU1(IBPIEN,.IBY)
... I $E($G(IBY(1)))'="A" Q ; not active
... S IBELEC="E" ;Both linked and active, so electronic submit
.. D EN^DDIOL($E(IBINSN,1,10),"","!?1")
.. D EN^DDIOL(IBCOB,"","?14")
.. D EN^DDIOL($E(IBPTYPE,1,12),"","?18")
.. D EN^DDIOL($E(IBGRPN,1,7),"","?33")
.. D EN^DDIOL($E(IBHOLD,1,9),"","?43")
.. D EN^DDIOL($E(IBEFFDT,1,8),"","?52")
.. D EN^DDIOL($E(IBEXPDT,1,8),"","?61")
.. D EN^DDIOL(IBELEC,"","?70")
;
COBQ ;
D PAUSE^IBNCPBB("")
S VALMBCK="R"
Q
;
DFORMAT(DF) ; Format date with slashes
Q $E(DF,4,5)_"/"_$E(DF,6,7)_"/"_$E(DF,2,3)
; end of IBNCPDS1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBNCPDS1 3054 printed Sep 23, 2025@20:01:16 Page 2
IBNCPDS1 ;ALB/BDB - DISPLAY RX COB DETERMINATION ;30-NOV-07
+1 ;;2.0;INTEGRATED BILLING;**411,452,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
% ; -- main entry point to display rx cob determination
EN ;
+1 SET U="^"
+2 DO FULL^VALM1
+3 NEW DIROUT,DIRUT,DTOUT,DUOUT,IBADT,IBANY,IBINS,IBQUIT,IBT,IBX,X,Y
+4 SET IBQUIT=0
+5 SET DIR("?",1)="Enter the date for which you want to see active insurances."
+6 SET DIR("?",2)="A valid date entry is required, or"
+7 SET DIR("?")="enter up-arrow ( ^ ) to return to the main display screen."
+8 SET DIR("A")="Date of Service"
SET DIR("A",1)=" "
SET DIR("B")="TODAY"
SET DIR(0)="D"
+9 FOR
DO ^DIR
if $DATA(DTOUT)!$DATA(DUOUT)
QUIT
SET IBADT=Y
SET IBQUIT=1
if IBQUIT
QUIT
+10 KILL DIR
+11 if 'IBQUIT
GOTO COBQ
+12 ; -- look up insurance for patient
+13 KILL IBINS
SET IBINS=0
+14 DO ALL^IBCNS1(DFN,"IBINS",1,IBADT,1)
+15 ;
+16 ; -- no pharmacy coverage, quit
+17 IF '$$PTCOV^IBCNSU3(DFN,IBADT,"PHARMACY",.IBANY)
GOTO COBQ
+18 DO EN^DDIOL("Insurance Co.COB Type of Policy Group Holder Effect. Expires Elec/Paper","","!!?1")
+19 ;
+20 SET IBX=0
+21 FOR
SET IBX=$ORDER(IBINS("S",IBX))
if 'IBX
QUIT
Begin DoDot:1
+22 SET IBT=0
FOR
SET IBT=$ORDER(IBINS("S",IBX,IBT))
if 'IBT
QUIT
Begin DoDot:2
+23 NEW IBCAT,IBCOB,IBDAT,IBEFFDT,IBELEC,IBEXPDT,IBGRPN,IBHOLD,IBINSN,IBPIEN,IBPL,IBPTYPE,IBY,IBZ
+24 SET IBQUIT=1
+25 if '$GET(IBINS(IBT,0))
QUIT
+26 ; plan
SET IBPL=$$GET1^DIQ(2.312,IBT_","_DFN_",",.18,"I")
+27 if 'IBPL
QUIT
+28 ; not covered
SET IBCAT=$ORDER(^IBE(355.31,"B","PHARMACY",""))
IF '$GET(IBCAT)!'$$PLCOV^IBCNSU3(IBPL,IBADT,IBCAT)
QUIT
+29 ; ins name
SET IBINSN=$$GET1^DIQ(2.312,IBT_","_DFN_",",.01)
+30 ; plan type
SET IBPTYPE=$$GET1^DIQ(355.3,IBPL_",",.09)
+31 ; cob indicator
SET IBCOB=$$GET1^DIQ(2.312,IBT_","_DFN_",",.2,"I")
SET IBCOB=$SELECT(IBCOB=1:"p",IBCOB=2:"s",IBCOB=3:"t",1:"p")
+32 ;IB*2.0*516/baa - Use HIPAA compliant Group ID
+33 ;S IBGRPN=$$GET1^DIQ(355.3,$$GET1^DIQ(2.312,IBT_","_DFN_",",.18,"I")_",",.04) ; group id
+34 ; group id ; 516 - baa
SET IBGRPN=$$GET1^DIQ(355.3,$$GET1^DIQ(2.312,IBT_","_DFN_",",.18,"I")_",",2.02)
+35 ; subscriber id
SET IBHOLD=$$GET1^DIQ(2.312,IBT_","_DFN_",",6,"I")
+36 SET IBHOLD=$SELECT(IBHOLD="v":"SELF",IBHOLD="s":"SPOUSE",IBHOLD="o":"OTHER",1:"")
+37 ; effective date
SET IBEFFDT=$PIECE(IBINS(IBT,0),U,8)
IF IBEFFDT]""
SET IBEFFDT=$$DFORMAT(IBEFFDT)
+38 ; expiration date
SET IBEXPDT=$PIECE(IBINS(IBT,0),U,4)
IF IBEXPDT]""
SET IBEXPDT=$$DFORMAT(IBEXPDT)
+39 SET IBELEC="P"
Begin DoDot:3
+40 SET IBPIEN=$$GET1^DIQ(355.3,$$GET1^DIQ(2.312,IBT_","_DFN_",",.18,"I")_",",6.01,"I")
+41 ; Not linked
IF 'IBPIEN
QUIT
+42 DO STCHK^IBCNRU1(IBPIEN,.IBY)
+43 ; not active
IF $EXTRACT($GET(IBY(1)))'="A"
QUIT
+44 ;Both linked and active, so electronic submit
SET IBELEC="E"
End DoDot:3
+45 DO EN^DDIOL($EXTRACT(IBINSN,1,10),"","!?1")
+46 DO EN^DDIOL(IBCOB,"","?14")
+47 DO EN^DDIOL($EXTRACT(IBPTYPE,1,12),"","?18")
+48 DO EN^DDIOL($EXTRACT(IBGRPN,1,7),"","?33")
+49 DO EN^DDIOL($EXTRACT(IBHOLD,1,9),"","?43")
+50 DO EN^DDIOL($EXTRACT(IBEFFDT,1,8),"","?52")
+51 DO EN^DDIOL($EXTRACT(IBEXPDT,1,8),"","?61")
+52 DO EN^DDIOL(IBELEC,"","?70")
End DoDot:2
End DoDot:1
+53 ;
COBQ ;
+1 DO PAUSE^IBNCPBB("")
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
DFORMAT(DF) ; Format date with slashes
+1 QUIT $EXTRACT(DF,4,5)_"/"_$EXTRACT(DF,6,7)_"/"_$EXTRACT(DF,2,3)
+2 ; end of IBNCPDS1
