IBJTU31 ;ALB/ARH - TPI UTILITIES - INS ; 2/14/95
;;2.0;INTEGRATED BILLING;**39,61,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
BPP(IBIFN,ARRAY) ; returns array of patient policy info on all of a bill's carriers
; returns PPIFN ^ p/s/t ^ policy node from patient insurance record (2,.312), also adds correct group #/name
N DFN,IBDM,IBI,IBDFN,IBCDFN,IBGRP K ARRAY S ARRAY=0
S DFN=$P($G(^DGCR(399,+$G(IBIFN),0)),U,2) I 'DFN G BPPQ
S IBDM=$G(^DGCR(399,IBIFN,"M")) I 'IBDM G BPPQ
;
F IBI=1,2,3 S IBCDFN="" D I +IBCDFN S ARRAY(IBI)=IBDFN_U_IBI_U_IBCDFN,ARRAY=IBI
. S IBDFN=$P(IBDM,U,(IBI+11)) I 'IBDFN,+$P(IBDM,U,IBI) S IBDFN=$O(^DPT(DFN,.312,"B",+$P(IBDM,U,IBI),0))
. ;IB*2.0*516/TAZ - Use HIPAA compliant fields
. ;Q:'IBDFN S IBCDFN=$G(^DPT(DFN,.312,+IBDFN,0)) I 'IBCDFN Q
. Q:'IBDFN S IBCDFN=$$ZND^IBCNS1(DFN,+IBDFN) I 'IBCDFN Q ; 516 - baa
. ;The following line is no longer necessary since the move is completed in the $$ZND^IBCNS1 function.
. ;S IBGRP=$G(^IBA(355.3,+$P(IBCDFN,U,18),0)) S:IBGRP'="" $P(IBCDFN,U,3)=$P(IBGRP,U,4),$P(IBCDFN,U,15)=$P(IBGRP,U,3) ;516 - baa
BPPQ Q
;
PST(IBIFN) ; called by insurance screens ACTION PROTOCOL ENTRY ACTION code, allow user to choose which policy
; to display ins screens for default will be either the primary or last viewed
; IBPOLICY used by this procedure to define last viewed, must be killed when exiting primary screen (CI)
;
N IBY,IBX,X,Y S IBY=0
D BPP(IBIFN,.IBX)
I IBX<1 S IBY=-1 G PSTQ ; bill has no policies
I IBX=1 S IBY=$O(IBX(0)),IBY=IBX(IBY) G PSTQ ; bill has only primary policy
S IBPOLICY=$S($G(IBPOLICY):IBPOLICY,1:$O(IBX(0))) I 'IBPOLICY G PSTQ
W ! D DBPOL(.IBX)
S DIR("?")="Only policies associated with this bill may be chosen: Primary, Secondary, or Tertiary."
S DIR(0)="SOB^P:Primary;S:Secondary;T:Tertiary",DIR(0)=$P(DIR(0),";",1,IBX)
S DIR("A")="Select Policy",DIR("B")=$S(IBPOLICY=2:"S",IBPOLICY=3:"T",1:"P") D ^DIR K DIR
I Y?1U S IBY=$S(Y="P":1,Y="S":2,Y="T":3,1:0),IBPOLICY=IBY,IBY=$G(IBX(IBY))
PSTQ Q IBY
;
DBPOL(IBINS) ; display patient policy info for all carriers of a bill, input array from BPP
;
N IBI,IBCDFN,IBCNS0
W !,?12,"Carrier",?39,"Subscriber ID",?62,"Group #",!,?12,"--------------------------------------------------------------------"
;
S IBI=0 F S IBI=$O(IBINS(IBI)) Q:'IBI D
. S IBCDFN=$P(IBINS(IBI),U,3,99),IBCNS0=$G(^DIC(36,+IBCDFN,0))
. W !,$S(IBI=2:"Secondary",IBI=3:"Tertiary",1:"Primary")_": ",?12,$E($P(IBCNS0,U,1),1,25),?39,$P(IBCDFN,U,2),?62,$P(IBCDFN,U,3)
W !
DBPOLQ Q
;
MINS(IBIFN) ;Called by IBJT LIST TEMPLATE screens and RCRC LIST TEMPLATES
; Return true if Bill has multiple Insurance Policies
N IBDM,IBY S IBY=0
S IBDM=$G(^DGCR(399,IBIFN,"M"))
S IBY=$S(+$P(IBDM,U,13):1,+$P(IBDM,U,14):1,1:0)
MINSQ Q IBY
;
REF(IBIFN) ;Called by IBJT LIST TEMPLATE screens
;Return Referral Date if Bill is Referred
N IBRDT,X
S IBRDT="IBRDT"
D DIQ^RCJIBFN2(IBIFN,64,.IBRDT)
REFQ Q +$G(IBRDT(430,IBIFN,64,"I"))
;IBJTU31
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJTU31 3065 printed Dec 13, 2024@02:24:15 Page 2
IBJTU31 ;ALB/ARH - TPI UTILITIES - INS ; 2/14/95
+1 ;;2.0;INTEGRATED BILLING;**39,61,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
BPP(IBIFN,ARRAY) ; returns array of patient policy info on all of a bill's carriers
+1 ; returns PPIFN ^ p/s/t ^ policy node from patient insurance record (2,.312), also adds correct group #/name
+2 NEW DFN,IBDM,IBI,IBDFN,IBCDFN,IBGRP
KILL ARRAY
SET ARRAY=0
+3 SET DFN=$PIECE($GET(^DGCR(399,+$GET(IBIFN),0)),U,2)
IF 'DFN
GOTO BPPQ
+4 SET IBDM=$GET(^DGCR(399,IBIFN,"M"))
IF 'IBDM
GOTO BPPQ
+5 ;
+6 FOR IBI=1,2,3
SET IBCDFN=""
Begin DoDot:1
+7 SET IBDFN=$PIECE(IBDM,U,(IBI+11))
IF 'IBDFN
IF +$PIECE(IBDM,U,IBI)
SET IBDFN=$ORDER(^DPT(DFN,.312,"B",+$PIECE(IBDM,U,IBI),0))
+8 ;IB*2.0*516/TAZ - Use HIPAA compliant fields
+9 ;Q:'IBDFN S IBCDFN=$G(^DPT(DFN,.312,+IBDFN,0)) I 'IBCDFN Q
+10 ; 516 - baa
if 'IBDFN
QUIT
SET IBCDFN=$$ZND^IBCNS1(DFN,+IBDFN)
IF 'IBCDFN
QUIT
+11 ;The following line is no longer necessary since the move is completed in the $$ZND^IBCNS1 function.
+12 ;S IBGRP=$G(^IBA(355.3,+$P(IBCDFN,U,18),0)) S:IBGRP'="" $P(IBCDFN,U,3)=$P(IBGRP,U,4),$P(IBCDFN,U,15)=$P(IBGRP,U,3) ;516 - baa
End DoDot:1
IF +IBCDFN
SET ARRAY(IBI)=IBDFN_U_IBI_U_IBCDFN
SET ARRAY=IBI
BPPQ QUIT
+1 ;
PST(IBIFN) ; called by insurance screens ACTION PROTOCOL ENTRY ACTION code, allow user to choose which policy
+1 ; to display ins screens for default will be either the primary or last viewed
+2 ; IBPOLICY used by this procedure to define last viewed, must be killed when exiting primary screen (CI)
+3 ;
+4 NEW IBY,IBX,X,Y
SET IBY=0
+5 DO BPP(IBIFN,.IBX)
+6 ; bill has no policies
IF IBX<1
SET IBY=-1
GOTO PSTQ
+7 ; bill has only primary policy
IF IBX=1
SET IBY=$ORDER(IBX(0))
SET IBY=IBX(IBY)
GOTO PSTQ
+8 SET IBPOLICY=$SELECT($GET(IBPOLICY):IBPOLICY,1:$ORDER(IBX(0)))
IF 'IBPOLICY
GOTO PSTQ
+9 WRITE !
DO DBPOL(.IBX)
+10 SET DIR("?")="Only policies associated with this bill may be chosen: Primary, Secondary, or Tertiary."
+11 SET DIR(0)="SOB^P:Primary;S:Secondary;T:Tertiary"
SET DIR(0)=$PIECE(DIR(0),";",1,IBX)
+12 SET DIR("A")="Select Policy"
SET DIR("B")=$SELECT(IBPOLICY=2:"S",IBPOLICY=3:"T",1:"P")
DO ^DIR
KILL DIR
+13 IF Y?1U
SET IBY=$SELECT(Y="P":1,Y="S":2,Y="T":3,1:0)
SET IBPOLICY=IBY
SET IBY=$GET(IBX(IBY))
PSTQ QUIT IBY
+1 ;
DBPOL(IBINS) ; display patient policy info for all carriers of a bill, input array from BPP
+1 ;
+2 NEW IBI,IBCDFN,IBCNS0
+3 WRITE !,?12,"Carrier",?39,"Subscriber ID",?62,"Group #",!,?12,"--------------------------------------------------------------------"
+4 ;
+5 SET IBI=0
FOR
SET IBI=$ORDER(IBINS(IBI))
if 'IBI
QUIT
Begin DoDot:1
+6 SET IBCDFN=$PIECE(IBINS(IBI),U,3,99)
SET IBCNS0=$GET(^DIC(36,+IBCDFN,0))
+7 WRITE !,$SELECT(IBI=2:"Secondary",IBI=3:"Tertiary",1:"Primary")_": ",?12,$EXTRACT($PIECE(IBCNS0,U,1),1,25),?39,$PIECE(IBCDFN,U,2),?62,$PIECE(IBCDFN,U,3)
End DoDot:1
+8 WRITE !
DBPOLQ QUIT
+1 ;
MINS(IBIFN) ;Called by IBJT LIST TEMPLATE screens and RCRC LIST TEMPLATES
+1 ; Return true if Bill has multiple Insurance Policies
+2 NEW IBDM,IBY
SET IBY=0
+3 SET IBDM=$GET(^DGCR(399,IBIFN,"M"))
+4 SET IBY=$SELECT(+$PIECE(IBDM,U,13):1,+$PIECE(IBDM,U,14):1,1:0)
MINSQ QUIT IBY
+1 ;
REF(IBIFN) ;Called by IBJT LIST TEMPLATE screens
+1 ;Return Referral Date if Bill is Referred
+2 NEW IBRDT,X
+3 SET IBRDT="IBRDT"
+4 DO DIQ^RCJIBFN2(IBIFN,64,.IBRDT)
REFQ QUIT +$GET(IBRDT(430,IBIFN,64,"I"))
+1 ;IBJTU31
