IBCNSMM1 ;ALB/CMS -MEDICARE INSURANCE INTAKE (CONT) ; 11/8/06 9:32am
;;2.0;INTEGRATED BILLING;**103,359,497,602**;21-MAR-94;Build 22
;;Per VA Directive 6402, this routine should not be modified.
;;(THIS ROUTINE WAS DEACTIVATED VIA PATCH 497...AND SHOULD BE RESEARCHED
;;IF REACTIVATED...REFER TO FIELDS (40.02, 40.03, 60.04, 60.07 OF THE
;;355.33 FILE.)
Q
;
SETP(IBP) ; -- Stuff data fields in patient policy
; Required Input:
; IBP =A for Part A, B for Part B
; DFN =pt. ien
; IBCDFN =patient policy ien
; IBNAME =Name of Insured
; IBHICN =Subscriber ID - as of IB*601 could also be a MBI Number
; IBAEFF =Effective Date of Plan A
; IBBEFF =Effective Date of Plan B
; IBCNSP =Medicare (WNR) ien ^Part A ien ^Part B ien
; IBCOBI =Coordination of Benefits (Internal value)
;
N D,DA,DIE,DR,IBBDA,X,Y
I '$D(^DPT(DFN,.312,+IBCDFN,0)) G SETPQ
;
; -- Stuff the pt. policy fields
; #2 *Group Number #.18 Group Plan
; #6 Whose Ins. #.2 COB
; #8 Effective Date of Policy #7.02 Sub. ID
; #15 *Group Name #7.01 Name of Insured
; #16 Pt. Relationship to Insured
;
S DIE="^DPT("_DFN_",.312,",DA=+IBCDFN,DA(1)=DFN
S DR="2///"_$S(IBP="A":$P(IBCNSP,U,4),IBP="B":$P(IBCNSP,U,6),1:"")
S DR=DR_";7.01///"_IBNAME_";7.02///"_IBHICN ; IB*2.0*497 (vd)
S DR=DR_";6///v;8///"_$S(IBP="A":$G(IBAEFF),IBP="B":$G(IBBEFF),1:"")
S DR=DR_";.2////"_IBCOBI_";15///"_$S(IBP="A":"PART A",IBP="B":"PART B",1:"")
S DR=DR_";16///01;.18////"_$S(IBP="A":+$P(IBCNSP,U,3),IBP="B":+$P(IBCNSP,U,5),1:"")
D ^DIE
;
; -- Update Insurance Event
S IBCOVP=$P($G(^DPT(DFN,.31)),U,11)
D BEFORE^IBCNSEVT S IBNEW=1
;
; -- Ask to Verify at this time
K DIR S DIR("A")="Verify Medicare (WNR) Part "_IBP_" Coverage Now"
S DIR("?")="Enter 'No' to not Verify Coverage at this time."
W ! S IBOK=0 D OK I 'IBOK G SETEV
;
; -- Check to see if Pt. Name = name of Insured
I IBNAME'=$P($G(^DPT(DFN,0)),U,1) D
.W !!,"WARNING: Patient Name: '"_$P($G(^DPT(DFN,0)),U,1)_"' DOES NOT MATCH"
.W !," Name of Insured: '"_IBNAME_"'.",!
;
; -- verify policy
S DIE="^DPT("_DFN_",.312,",DA=IBCDFN,DA(1)=DFN
S DR="1.03///NOW;1.04////"_DUZ D ^DIE
W !," PART "_IBP_" COVERAGE VERIFIED."
;
SETEV ; -- Update Insurance event
N X,Y
D COVERED^IBCNSM31(DFN,IBCOVP)
I $G(IBCDFN)>0,IBNEW=1 D AFTER^IBCNSEVT,^IBCNSEVT
;
SETPQ Q
;
;
BUFF(IBP) ; -- Set IBBUF array with policy info for Buffer File
; Return: IBBUF array
; IBBUF(355.33 field #s)=corresponding policy, plan and company data
; i.e. IBBUF(20.01)=Insurance Company Name
; IBBUF(90.01)=Group Name
; IBBUF(60.01)=DFN
;
; Input: DFN, IBCNSP, IBNAME, IBHICN, IBAEFF, IBBEFF, IBCOBI
;
; Auto stuff other fields
;
N IBP0 K IBBUF S IBBUF=""
S IBBUF(.03)=$G(IBSOUR)
S IBBUF(20.01)=$P(IBCNSP,U,2)
S IBBUF(90.01)=$S(IBP="A":$P(IBCNSP,U,4),IBP="B":$P(IBCNSP,U,6),1:"") ; IB*2.0*497 (vd)
S IBBUF(90.02)=IBBUF(90.01) ; IB*2.0*497 (vd)
S IBBUF(60.01)=+DFN
S IBBUF(60.02)=$S(IBP="A":IBAEFF,IBP="B":IBBEFF,1:"")
S IBBUF(90.03)=IBHICN ; IB*2.0*497 (vd)
S IBBUF(60.05)="v"
S IBBUF(60.06)="01"
S IBBUF(91.01)=IBNAME ; IB*2.0*497 (vd)
S IBBUF(60.12)=IBCOBI
S IBBDA=$$ADDSTF^IBCNBES(1,DFN,.IBBUF)
I +IBBDA W !,?3,$P(IBCNSP,U,2)," PART "_IBP_" entry #"_+IBBDA_" added to Insurance Buffer File."
I 'IBBDA W !,*7,?3,"Warning: Could not add new policy Part "_IBP_" in Buffer File.",!,?13,"("_$P(IBBDA,U,2)_")",!
Q
;
OK ; -- ask okay
N DTOUT,DIROUT,DIRUT,DUOUT,X,Y
; Returns:
; IBQUIT=1 Exit user timedout
; IBOK=1 Yes
; IBOK=0 No
S IBQUIT=0,DIR(0)="Y",DIR("B")="YES" W !
I $G(DIR("A"))="" S DIR("A")="Is this Data Correct"
I $G(DIR("?"))="" S DIR("?")="Enter 'No' to edit Medicare Card information"
D ^DIR K DIR
I $D(DTOUT) S IBQUIT=1
S IBOK=$G(Y) I IBOK["^" S IBQUIT=1
Q
;
GETWNR() ; -- Find and return the MEDICARE (WNR) ien
; -- Returns Error message or
; DIC(36 IEN ^"MEDICARE (WNR)"^IBA(355.3 PART A IEN ^"PART A"^ IBA(355.3 PART B IEN ^"PART B"
;
N IBWNR,IB0,IBP0,IBQ,IBPQ,IBPX,IBX,IBY,IBPGN
S IBY="MEDICARE (WNR)",IBQ=0
S IBX=0 F S IBX=$O(^DIC(36,"B",IBY,IBX)) Q:('IBX) D Q:IBQ
.S IB0=$G(^DIC(36,IBX,0))
.K IBWNR("INS")
.I $P(IB0,U,1)'=IBY Q ;name
.I $P(IB0,U,2)'="N" Q ;Reimb?
.;I '$P(IB0,U,3) Q ;Sig Req. --> removed edit, cm, 5/18/99
.I $P(IB0,U,5) Q ;Inactive
.I $P($G(^IBE(355.2,+$P(IB0,U,13),0)),U)'="MEDICARE" Q ;Major Cat.
.S IBWNR("INS")=IBX_U_IBY
.;
.; -- Must have Active Group Plan Category Medicare Part A and B
.;
.K IBWNR("A"),IBWNR("B")
.S IBPX=0 F S IBPX=$O(^IBA(355.3,"B",IBX,IBPX)) Q:('IBPX)!(IBQ) D
..S IBP0=$G(^IBA(355.3,IBPX,0))
..I $P(IBP0,U,11) Q ;Inactive
..I $P(IBP0,U,14)'="A",$P(IBP0,U,14)'="B" Q ;Not Plan Category Part A or B
..S IBPGN=$TR($P(IBP0,U,3),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
..I IBPGN'="PART A",IBPGN'="PART B" Q ;excludes non PART A and PART B plans
..S IBWNR($P(IBP0,U,14))=IBPX_U_$P(IBP0,U,3)
..I $G(IBWNR("A")),$G(IBWNR("B")) S IBQ=1
;
S IBX=$G(IBWNR("INS"))_U_$G(IBWNR("A"))_U_$G(IBWNR("B"))
I 'IBX S IBX="Error: Standard Medicare (WNR) Insurance Company not setup properly." G GETWNRQ
I '$P(IBX,U,3) S IBX="Error: Standard Medicare (WNR) plan PART A not setup properly." G GETWNRQ
I '$G(IBWNR("B")) S IBX="Error: Standard Medicare (WNR) plan PART B not setup properly."
GETWNRQ Q IBX
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSMM1 5589 printed Nov 22, 2024@17:27:41 Page 2
IBCNSMM1 ;ALB/CMS -MEDICARE INSURANCE INTAKE (CONT) ; 11/8/06 9:32am
+1 ;;2.0;INTEGRATED BILLING;**103,359,497,602**;21-MAR-94;Build 22
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;(THIS ROUTINE WAS DEACTIVATED VIA PATCH 497...AND SHOULD BE RESEARCHED
+4 ;;IF REACTIVATED...REFER TO FIELDS (40.02, 40.03, 60.04, 60.07 OF THE
+5 ;;355.33 FILE.)
+6 QUIT
+7 ;
SETP(IBP) ; -- Stuff data fields in patient policy
+1 ; Required Input:
+2 ; IBP =A for Part A, B for Part B
+3 ; DFN =pt. ien
+4 ; IBCDFN =patient policy ien
+5 ; IBNAME =Name of Insured
+6 ; IBHICN =Subscriber ID - as of IB*601 could also be a MBI Number
+7 ; IBAEFF =Effective Date of Plan A
+8 ; IBBEFF =Effective Date of Plan B
+9 ; IBCNSP =Medicare (WNR) ien ^Part A ien ^Part B ien
+10 ; IBCOBI =Coordination of Benefits (Internal value)
+11 ;
+12 NEW D,DA,DIE,DR,IBBDA,X,Y
+13 IF '$DATA(^DPT(DFN,.312,+IBCDFN,0))
GOTO SETPQ
+14 ;
+15 ; -- Stuff the pt. policy fields
+16 ; #2 *Group Number #.18 Group Plan
+17 ; #6 Whose Ins. #.2 COB
+18 ; #8 Effective Date of Policy #7.02 Sub. ID
+19 ; #15 *Group Name #7.01 Name of Insured
+20 ; #16 Pt. Relationship to Insured
+21 ;
+22 SET DIE="^DPT("_DFN_",.312,"
SET DA=+IBCDFN
SET DA(1)=DFN
+23 SET DR="2///"_$SELECT(IBP="A":$PIECE(IBCNSP,U,4),IBP="B":$PIECE(IBCNSP,U,6),1:"")
+24 ; IB*2.0*497 (vd)
SET DR=DR_";7.01///"_IBNAME_";7.02///"_IBHICN
+25 SET DR=DR_";6///v;8///"_$SELECT(IBP="A":$GET(IBAEFF),IBP="B":$GET(IBBEFF),1:"")
+26 SET DR=DR_";.2////"_IBCOBI_";15///"_$SELECT(IBP="A":"PART A",IBP="B":"PART B",1:"")
+27 SET DR=DR_";16///01;.18////"_$SELECT(IBP="A":+$PIECE(IBCNSP,U,3),IBP="B":+$PIECE(IBCNSP,U,5),1:"")
+28 DO ^DIE
+29 ;
+30 ; -- Update Insurance Event
+31 SET IBCOVP=$PIECE($GET(^DPT(DFN,.31)),U,11)
+32 DO BEFORE^IBCNSEVT
SET IBNEW=1
+33 ;
+34 ; -- Ask to Verify at this time
+35 KILL DIR
SET DIR("A")="Verify Medicare (WNR) Part "_IBP_" Coverage Now"
+36 SET DIR("?")="Enter 'No' to not Verify Coverage at this time."
+37 WRITE !
SET IBOK=0
DO OK
IF 'IBOK
GOTO SETEV
+38 ;
+39 ; -- Check to see if Pt. Name = name of Insured
+40 IF IBNAME'=$PIECE($GET(^DPT(DFN,0)),U,1)
Begin DoDot:1
+41 WRITE !!,"WARNING: Patient Name: '"_$PIECE($GET(^DPT(DFN,0)),U,1)_"' DOES NOT MATCH"
+42 WRITE !," Name of Insured: '"_IBNAME_"'.",!
End DoDot:1
+43 ;
+44 ; -- verify policy
+45 SET DIE="^DPT("_DFN_",.312,"
SET DA=IBCDFN
SET DA(1)=DFN
+46 SET DR="1.03///NOW;1.04////"_DUZ
DO ^DIE
+47 WRITE !," PART "_IBP_" COVERAGE VERIFIED."
+48 ;
SETEV ; -- Update Insurance event
+1 NEW X,Y
+2 DO COVERED^IBCNSM31(DFN,IBCOVP)
+3 IF $GET(IBCDFN)>0
IF IBNEW=1
DO AFTER^IBCNSEVT
DO ^IBCNSEVT
+4 ;
SETPQ QUIT
+1 ;
+2 ;
BUFF(IBP) ; -- Set IBBUF array with policy info for Buffer File
+1 ; Return: IBBUF array
+2 ; IBBUF(355.33 field #s)=corresponding policy, plan and company data
+3 ; i.e. IBBUF(20.01)=Insurance Company Name
+4 ; IBBUF(90.01)=Group Name
+5 ; IBBUF(60.01)=DFN
+6 ;
+7 ; Input: DFN, IBCNSP, IBNAME, IBHICN, IBAEFF, IBBEFF, IBCOBI
+8 ;
+9 ; Auto stuff other fields
+10 ;
+11 NEW IBP0
KILL IBBUF
SET IBBUF=""
+12 SET IBBUF(.03)=$GET(IBSOUR)
+13 SET IBBUF(20.01)=$PIECE(IBCNSP,U,2)
+14 ; IB*2.0*497 (vd)
SET IBBUF(90.01)=$SELECT(IBP="A":$PIECE(IBCNSP,U,4),IBP="B":$PIECE(IBCNSP,U,6),1:"")
+15 ; IB*2.0*497 (vd)
SET IBBUF(90.02)=IBBUF(90.01)
+16 SET IBBUF(60.01)=+DFN
+17 SET IBBUF(60.02)=$SELECT(IBP="A":IBAEFF,IBP="B":IBBEFF,1:"")
+18 ; IB*2.0*497 (vd)
SET IBBUF(90.03)=IBHICN
+19 SET IBBUF(60.05)="v"
+20 SET IBBUF(60.06)="01"
+21 ; IB*2.0*497 (vd)
SET IBBUF(91.01)=IBNAME
+22 SET IBBUF(60.12)=IBCOBI
+23 SET IBBDA=$$ADDSTF^IBCNBES(1,DFN,.IBBUF)
+24 IF +IBBDA
WRITE !,?3,$PIECE(IBCNSP,U,2)," PART "_IBP_" entry #"_+IBBDA_" added to Insurance Buffer File."
+25 IF 'IBBDA
WRITE !,*7,?3,"Warning: Could not add new policy Part "_IBP_" in Buffer File.",!,?13,"("_$PIECE(IBBDA,U,2)_")",!
+26 QUIT
+27 ;
OK ; -- ask okay
+1 NEW DTOUT,DIROUT,DIRUT,DUOUT,X,Y
+2 ; Returns:
+3 ; IBQUIT=1 Exit user timedout
+4 ; IBOK=1 Yes
+5 ; IBOK=0 No
+6 SET IBQUIT=0
SET DIR(0)="Y"
SET DIR("B")="YES"
WRITE !
+7 IF $GET(DIR("A"))=""
SET DIR("A")="Is this Data Correct"
+8 IF $GET(DIR("?"))=""
SET DIR("?")="Enter 'No' to edit Medicare Card information"
+9 DO ^DIR
KILL DIR
+10 IF $DATA(DTOUT)
SET IBQUIT=1
+11 SET IBOK=$GET(Y)
IF IBOK["^"
SET IBQUIT=1
+12 QUIT
+13 ;
GETWNR() ; -- Find and return the MEDICARE (WNR) ien
+1 ; -- Returns Error message or
+2 ; DIC(36 IEN ^"MEDICARE (WNR)"^IBA(355.3 PART A IEN ^"PART A"^ IBA(355.3 PART B IEN ^"PART B"
+3 ;
+4 NEW IBWNR,IB0,IBP0,IBQ,IBPQ,IBPX,IBX,IBY,IBPGN
+5 SET IBY="MEDICARE (WNR)"
SET IBQ=0
+6 SET IBX=0
FOR
SET IBX=$ORDER(^DIC(36,"B",IBY,IBX))
if ('IBX)
QUIT
Begin DoDot:1
+7 SET IB0=$GET(^DIC(36,IBX,0))
+8 KILL IBWNR("INS")
+9 ;name
IF $PIECE(IB0,U,1)'=IBY
QUIT
+10 ;Reimb?
IF $PIECE(IB0,U,2)'="N"
QUIT
+11 ;I '$P(IB0,U,3) Q ;Sig Req. --> removed edit, cm, 5/18/99
+12 ;Inactive
IF $PIECE(IB0,U,5)
QUIT
+13 ;Major Cat.
IF $PIECE($GET(^IBE(355.2,+$PIECE(IB0,U,13),0)),U)'="MEDICARE"
QUIT
+14 SET IBWNR("INS")=IBX_U_IBY
+15 ;
+16 ; -- Must have Active Group Plan Category Medicare Part A and B
+17 ;
+18 KILL IBWNR("A"),IBWNR("B")
+19 SET IBPX=0
FOR
SET IBPX=$ORDER(^IBA(355.3,"B",IBX,IBPX))
if ('IBPX)!(IBQ)
QUIT
Begin DoDot:2
+20 SET IBP0=$GET(^IBA(355.3,IBPX,0))
+21 ;Inactive
IF $PIECE(IBP0,U,11)
QUIT
+22 ;Not Plan Category Part A or B
IF $PIECE(IBP0,U,14)'="A"
IF $PIECE(IBP0,U,14)'="B"
QUIT
+23 SET IBPGN=$TRANSLATE($PIECE(IBP0,U,3),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+24 ;excludes non PART A and PART B plans
IF IBPGN'="PART A"
IF IBPGN'="PART B"
QUIT
+25 SET IBWNR($PIECE(IBP0,U,14))=IBPX_U_$PIECE(IBP0,U,3)
+26 IF $GET(IBWNR("A"))
IF $GET(IBWNR("B"))
SET IBQ=1
End DoDot:2
End DoDot:1
if IBQ
QUIT
+27 ;
+28 SET IBX=$GET(IBWNR("INS"))_U_$GET(IBWNR("A"))_U_$GET(IBWNR("B"))
+29 IF 'IBX
SET IBX="Error: Standard Medicare (WNR) Insurance Company not setup properly."
GOTO GETWNRQ
+30 IF '$PIECE(IBX,U,3)
SET IBX="Error: Standard Medicare (WNR) plan PART A not setup properly."
GOTO GETWNRQ
+31 IF '$GET(IBWNR("B"))
SET IBX="Error: Standard Medicare (WNR) plan PART B not setup properly."
GETWNRQ QUIT IBX
