IBCNSMM ;ALB/CMS -MEDICARE INSURANCE INTAKE ; 18-OCT-98
;;2.0;INTEGRATED BILLING;**103,133,184,516,601,595,602**;21-MAR-94;Build 22
;;Per VA Directive 6402, this routine should not be modified.
Q
;
EN ; -- Entry point from Medicare Intake Standalone option
N DIC,DIR,DA,%A,DFN,X,Y,IBQUIT,IBCNSP,IBSOURCE
S (IBQUIT,IBCNSP)=0 D GETWNR I IBQUIT G ENQ
;
; - allow the user to enter the Source of Information for the policies
W !!,"You may enter the 'Source of Information' that will be filed with all"
W !,"Medicare insurance coverage policies that are created.",!
;
S DIR(0)="2.312,1.09"
S DIR("A")="Enter Source of Information"
S DIR("B")="INTERVIEW"
D ^DIR K DUOUT,DTOUT,DIRUT,DIROUT,DIR
S IBSOURCE=+Y I Y<1 G ENQ
W !
;
; - loop to select patients
ENA S DIC(0)="AEQMN",DIC="^DPT(" D ^DIC
I +Y<1 G ENQ
S DFN=+Y
I $G(^DPT(DFN,.35)) W *7,!!,?10,"Patient Expired on ",$$FMTE^XLFDT($P(^DPT(DFN,.35),U))
W ! D DISP^IBCNS W !,?3 S X="",$P(X,"=",76)="" W X
D ENR(DFN,IBSOURCE,1) K DIC W !! G ENA
;
ENQ Q
;
;
ENR(DFN,IBSOUR,IBOPT) ; -- Entry point from IBCNBME Patient Registration or Pre-Registration
; Input Variable DFN Required and IBSOUR =Source of Information
; IBOPT =1 if coming from MII Standalone Option
;
N D,DIE,DA,DIR,DIC,E,IBCPOL,IBCNSP,IBCDFN,IBQUIT,IBOK,IBC0,IBAD,IBGRP,IBADPOL
N IBNAME,IBHICN,IBAEFF,IBBEFF,IBCOVP,IBGNA,IBGNU,IBBUF,IBNEW,IBP,X,Y
N IBPOLA,IBPOLB,IBARR,IBHIT,IBHITA,IBHITB,IBCOB,IBCOBI
;
; IB*602 - IBHICN could also be a Medicare Beneficiary ID
S (IBAEFF,IBBEFF,IBCNSP,IBCDFN,IBNEW,IBQUIT)=0,IBADPOL=1
S (IBNAME,IBHICN)=""
;
; -- Get Standard Medicare Insurance Company and plans in IBCNSP
D GETWNR I IBQUIT G ENRQ
;
; -- get the patient's Medicare policies
S (IBPOLA,IBPOLB)=0
S IBCDFN=0 F S IBCDFN=$O(^DPT(DFN,.312,"B",+IBCNSP,IBCDFN)) Q:'IBCDFN D
.;IB*2.0*516/TAZ - Retrieve Data from HIPAA compliant fields.
.;S IBCPOL=$G(^DPT(DFN,.312,IBCDFN,0)) ;516 - baa
.S IBCPOL=$$ZND^IBCNS1(DFN,IBCDFN) ;516 - baa
.;
.; - is the policy for Part A?
.I $P(IBCNSP,U,3)=$P(IBCPOL,U,18) D Q
..S IBPOLA=IBPOLA+1,IBARR("A",IBPOLA)=IBCDFN_"^"_IBCPOL
.;
.; - is the policy for Part B?
.I $P(IBCNSP,U,5)=$P(IBCPOL,U,18) D
..S IBPOLB=IBPOLB+1,IBARR("B",IBPOLB)=IBCDFN_"^"_IBCPOL
;
; - can't edit here if there is more than one policy
I $D(IBARR("A",2)) K IBARR("A") D
.W !!,"This patient has more than one Part A policy. Please edit in Ins Mgmt."
;
I $D(IBARR("B",2)) K IBARR("B") D
.W !!,"This patient has more than one Part B policy. Please edit in Ins Mgmt."
;
I (IBPOLA!IBPOLB),'$D(IBARR) G ENRQ
;
; -- Ask for Medicare Insurance Card information
; Return IBNAME, IBHICN, IBAEFF, IBBEFF, IBCOB/IBCOBI
D MII^IBCNSMM2 I IBQUIT G ENRQ
;
; - if Part A or B exists, but no changes, quit
I $D(IBARR("A",1)) D COM($P(IBARR("A",1),"^",2,99),"A") I IBHIT D
.S IBHITA=1 W !," * No Part A changes made..."
;
I $D(IBARR("B",1)) D COM($P(IBARR("B",1),"^",2,99),"B") I IBHIT D
.S IBHITB=1 W !," * No Part B changes made..."
;
I $G(IBHITA),$G(IBHITB) G ENRQ
I $G(IBHITA),'$G(IBBEFF) G ENRQ
I $G(IBHITB),'$G(IBAEFF) G ENRQ
;
;IB*595 Removed ability to file directly into Insurance Type File
I IBAEFF,'$G(IBHITA) D BUFF^IBCNSMM1("A")
I IBBEFF,'$G(IBHITB) D BUFF^IBCNSMM1("B")
;
; -- If user not holding key set data in Buffer File
;I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D G ENRQ
;.I IBAEFF,'$G(IBHITA) D BUFF^IBCNSMM1("A")
;.I IBBEFF,'$G(IBHITB) D BUFF^IBCNSMM1("B")
;
; -- Otherwise, set data into permanent files
;I IBAEFF,'$G(IBHITA) D
;.I IBPOLA,'$D(IBARR("A")) Q ; can't update Part A policy
;.I '$D(IBARR("A",1)) D ADDP("A") Q
;.S IBCDFN=+IBARR("A",1) D SETP^IBCNSMM1("A")
;I IBBEFF,'$G(IBHITB) D
;.I IBPOLB,'$D(IBARR("B")) Q ; can't update Part B policy
;.I '$D(IBARR("B",1)) D ADDP("B") Q
;.S IBCDFN=+IBARR("B",1) D SETP^IBCNSMM1("B")
;IB*595 END
;
ENRQ W ! Q
;
;
;
ADDP(IBP) ; -- Create a new patient policy
; Input: DFN
; IBCNSP=MED WNR INS IEN^MEDICARE (WNR)
; ^PART A IEN^PART A
; ^PART B IEN^PART A
; IBP = "A" or "B" for medicare part
; IBSOUR = Source of Information
; Return: IBCDFN=-1 could not add OR Policy ien
; IBCOVP= Covered by Health Insurance
;
N X,Y,DO,DD,DA,DR,DIC,DIE,DIK,DIR,DIRUT,IBSPEC
; -- Create a New patient policy
S IBCOVP=$P($G(^DPT(DFN,.31)),U,11)
;
D FIELD^DID(2,.3121,"","SPECIFIER","IBSPEC")
S DIC("DR")="1.09////"_IBSOUR_";1.05///NOW;1.06////"_DUZ,DIC("P")=$G(IBSPEC("SPECIFIER"))
K DD,DO S DA(1)=DFN,DIC="^DPT("_DFN_",.312,",DIC(0)="L",X=+IBCNSP,DLAYGO=2.312
D FILE^DICN K DD,DO,DLAYGO,DIC
S IBCDFN=+Y
I IBCDFN<1 W !!,*7," <Could not create new policy at this time. Try Later!>",! G ADDPQ
;
; -- Set Medicare policy data
D SETP^IBCNSMM1(IBP)
ADDPQ Q
;
;
GETWNR ;
; -- Get Medicare (WNR) insurance company and plan data
; Returns IBCNSP or IBQUIT
; IBCNSP="Error: Medicare (WNR) ... not setup properly"
; if Medicare WNR entry or plans not setup properly
;
; IBCNSP=INS CO. (36) IEN^"MEDICARE (WNR)"
; ^PLAN (355.3) PARTA IEN^"PART A"
; ^PLAN (355.3) PARTB IEN^"PART B"
;
I 'IBCNSP S IBCNSP=$$GETWNR^IBCNSMM1
I 'IBCNSP W !!,*7,?3,IBCNSP S IBQUIT=1
Q
;
VALHIC(X) ; Edits for validating HIC #
; X = the HIC # to be validated
;IB*2.0*601 JRA Remove special HIC # validation - use existing error messages IB356/IB357/IB358 when the
; Primary/Secondary/Tertiary insurance subscriber's ID number is missing (as with other insurances).
;
;IB*2.0*601 JRA QUIT '1' to remove special validation for HIC #, which will prevent the display of IB Error
; message IB215 and the HIC # help text at HLP^IBCNSM32.
Q 1 ;IB*2.0*601 JRA
N VAL
S VAL=1
I X'?9N1A.1AN,X'?1.3A6N,X'?1.3A9N S VAL=0
Q VAL
;
COM(X,Y) ; Compare X with the intake variables.
; Input: X => 0th node of policy in file #2.312
; Y => A (Part A) or B (part B)
; Output: IBHIT=1 (no changes made)
S IBHIT=0
I $P(X,"^",17)'=IBNAME G COMQ
I $P(X,"^",2)'=IBHICN G COMQ
I $P(X,"^",8)'=$S(Y="A":IBAEFF,1:IBBEFF) G COMQ
I $P(X,"^",20)'=IBCOBI G COMQ
;
S IBHIT=1
COMQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSMM 6359 printed Sep 23, 2025@19:53:51 Page 2
IBCNSMM ;ALB/CMS -MEDICARE INSURANCE INTAKE ; 18-OCT-98
+1 ;;2.0;INTEGRATED BILLING;**103,133,184,516,601,595,602**;21-MAR-94;Build 22
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 QUIT
+4 ;
EN ; -- Entry point from Medicare Intake Standalone option
+1 NEW DIC,DIR,DA,%A,DFN,X,Y,IBQUIT,IBCNSP,IBSOURCE
+2 SET (IBQUIT,IBCNSP)=0
DO GETWNR
IF IBQUIT
GOTO ENQ
+3 ;
+4 ; - allow the user to enter the Source of Information for the policies
+5 WRITE !!,"You may enter the 'Source of Information' that will be filed with all"
+6 WRITE !,"Medicare insurance coverage policies that are created.",!
+7 ;
+8 SET DIR(0)="2.312,1.09"
+9 SET DIR("A")="Enter Source of Information"
+10 SET DIR("B")="INTERVIEW"
+11 DO ^DIR
KILL DUOUT,DTOUT,DIRUT,DIROUT,DIR
+12 SET IBSOURCE=+Y
IF Y<1
GOTO ENQ
+13 WRITE !
+14 ;
+15 ; - loop to select patients
ENA SET DIC(0)="AEQMN"
SET DIC="^DPT("
DO ^DIC
+1 IF +Y<1
GOTO ENQ
+2 SET DFN=+Y
+3 IF $GET(^DPT(DFN,.35))
WRITE *7,!!,?10,"Patient Expired on ",$$FMTE^XLFDT($PIECE(^DPT(DFN,.35),U))
+4 WRITE !
DO DISP^IBCNS
WRITE !,?3
SET X=""
SET $PIECE(X,"=",76)=""
WRITE X
+5 DO ENR(DFN,IBSOURCE,1)
KILL DIC
WRITE !!
GOTO ENA
+6 ;
ENQ QUIT
+1 ;
+2 ;
ENR(DFN,IBSOUR,IBOPT) ; -- Entry point from IBCNBME Patient Registration or Pre-Registration
+1 ; Input Variable DFN Required and IBSOUR =Source of Information
+2 ; IBOPT =1 if coming from MII Standalone Option
+3 ;
+4 NEW D,DIE,DA,DIR,DIC,E,IBCPOL,IBCNSP,IBCDFN,IBQUIT,IBOK,IBC0,IBAD,IBGRP,IBADPOL
+5 NEW IBNAME,IBHICN,IBAEFF,IBBEFF,IBCOVP,IBGNA,IBGNU,IBBUF,IBNEW,IBP,X,Y
+6 NEW IBPOLA,IBPOLB,IBARR,IBHIT,IBHITA,IBHITB,IBCOB,IBCOBI
+7 ;
+8 ; IB*602 - IBHICN could also be a Medicare Beneficiary ID
+9 SET (IBAEFF,IBBEFF,IBCNSP,IBCDFN,IBNEW,IBQUIT)=0
SET IBADPOL=1
+10 SET (IBNAME,IBHICN)=""
+11 ;
+12 ; -- Get Standard Medicare Insurance Company and plans in IBCNSP
+13 DO GETWNR
IF IBQUIT
GOTO ENRQ
+14 ;
+15 ; -- get the patient's Medicare policies
+16 SET (IBPOLA,IBPOLB)=0
+17 SET IBCDFN=0
FOR
SET IBCDFN=$ORDER(^DPT(DFN,.312,"B",+IBCNSP,IBCDFN))
if 'IBCDFN
QUIT
Begin DoDot:1
+18 ;IB*2.0*516/TAZ - Retrieve Data from HIPAA compliant fields.
+19 ;S IBCPOL=$G(^DPT(DFN,.312,IBCDFN,0)) ;516 - baa
+20 ;516 - baa
SET IBCPOL=$$ZND^IBCNS1(DFN,IBCDFN)
+21 ;
+22 ; - is the policy for Part A?
+23 IF $PIECE(IBCNSP,U,3)=$PIECE(IBCPOL,U,18)
Begin DoDot:2
+24 SET IBPOLA=IBPOLA+1
SET IBARR("A",IBPOLA)=IBCDFN_"^"_IBCPOL
End DoDot:2
QUIT
+25 ;
+26 ; - is the policy for Part B?
+27 IF $PIECE(IBCNSP,U,5)=$PIECE(IBCPOL,U,18)
Begin DoDot:2
+28 SET IBPOLB=IBPOLB+1
SET IBARR("B",IBPOLB)=IBCDFN_"^"_IBCPOL
End DoDot:2
End DoDot:1
+29 ;
+30 ; - can't edit here if there is more than one policy
+31 IF $DATA(IBARR("A",2))
KILL IBARR("A")
Begin DoDot:1
+32 WRITE !!,"This patient has more than one Part A policy. Please edit in Ins Mgmt."
End DoDot:1
+33 ;
+34 IF $DATA(IBARR("B",2))
KILL IBARR("B")
Begin DoDot:1
+35 WRITE !!,"This patient has more than one Part B policy. Please edit in Ins Mgmt."
End DoDot:1
+36 ;
+37 IF (IBPOLA!IBPOLB)
IF '$DATA(IBARR)
GOTO ENRQ
+38 ;
+39 ; -- Ask for Medicare Insurance Card information
+40 ; Return IBNAME, IBHICN, IBAEFF, IBBEFF, IBCOB/IBCOBI
+41 DO MII^IBCNSMM2
IF IBQUIT
GOTO ENRQ
+42 ;
+43 ; - if Part A or B exists, but no changes, quit
+44 IF $DATA(IBARR("A",1))
DO COM($PIECE(IBARR("A",1),"^",2,99),"A")
IF IBHIT
Begin DoDot:1
+45 SET IBHITA=1
WRITE !," * No Part A changes made..."
End DoDot:1
+46 ;
+47 IF $DATA(IBARR("B",1))
DO COM($PIECE(IBARR("B",1),"^",2,99),"B")
IF IBHIT
Begin DoDot:1
+48 SET IBHITB=1
WRITE !," * No Part B changes made..."
End DoDot:1
+49 ;
+50 IF $GET(IBHITA)
IF $GET(IBHITB)
GOTO ENRQ
+51 IF $GET(IBHITA)
IF '$GET(IBBEFF)
GOTO ENRQ
+52 IF $GET(IBHITB)
IF '$GET(IBAEFF)
GOTO ENRQ
+53 ;
+54 ;IB*595 Removed ability to file directly into Insurance Type File
+55 IF IBAEFF
IF '$GET(IBHITA)
DO BUFF^IBCNSMM1("A")
+56 IF IBBEFF
IF '$GET(IBHITB)
DO BUFF^IBCNSMM1("B")
+57 ;
+58 ; -- If user not holding key set data in Buffer File
+59 ;I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D G ENRQ
+60 ;.I IBAEFF,'$G(IBHITA) D BUFF^IBCNSMM1("A")
+61 ;.I IBBEFF,'$G(IBHITB) D BUFF^IBCNSMM1("B")
+62 ;
+63 ; -- Otherwise, set data into permanent files
+64 ;I IBAEFF,'$G(IBHITA) D
+65 ;.I IBPOLA,'$D(IBARR("A")) Q ; can't update Part A policy
+66 ;.I '$D(IBARR("A",1)) D ADDP("A") Q
+67 ;.S IBCDFN=+IBARR("A",1) D SETP^IBCNSMM1("A")
+68 ;I IBBEFF,'$G(IBHITB) D
+69 ;.I IBPOLB,'$D(IBARR("B")) Q ; can't update Part B policy
+70 ;.I '$D(IBARR("B",1)) D ADDP("B") Q
+71 ;.S IBCDFN=+IBARR("B",1) D SETP^IBCNSMM1("B")
+72 ;IB*595 END
+73 ;
ENRQ WRITE !
QUIT
+1 ;
+2 ;
+3 ;
ADDP(IBP) ; -- Create a new patient policy
+1 ; Input: DFN
+2 ; IBCNSP=MED WNR INS IEN^MEDICARE (WNR)
+3 ; ^PART A IEN^PART A
+4 ; ^PART B IEN^PART A
+5 ; IBP = "A" or "B" for medicare part
+6 ; IBSOUR = Source of Information
+7 ; Return: IBCDFN=-1 could not add OR Policy ien
+8 ; IBCOVP= Covered by Health Insurance
+9 ;
+10 NEW X,Y,DO,DD,DA,DR,DIC,DIE,DIK,DIR,DIRUT,IBSPEC
+11 ; -- Create a New patient policy
+12 SET IBCOVP=$PIECE($GET(^DPT(DFN,.31)),U,11)
+13 ;
+14 DO FIELD^DID(2,.3121,"","SPECIFIER","IBSPEC")
+15 SET DIC("DR")="1.09////"_IBSOUR_";1.05///NOW;1.06////"_DUZ
SET DIC("P")=$GET(IBSPEC("SPECIFIER"))
+16 KILL DD,DO
SET DA(1)=DFN
SET DIC="^DPT("_DFN_",.312,"
SET DIC(0)="L"
SET X=+IBCNSP
SET DLAYGO=2.312
+17 DO FILE^DICN
KILL DD,DO,DLAYGO,DIC
+18 SET IBCDFN=+Y
+19 IF IBCDFN<1
WRITE !!,*7," <Could not create new policy at this time. Try Later!>",!
GOTO ADDPQ
+20 ;
+21 ; -- Set Medicare policy data
+22 DO SETP^IBCNSMM1(IBP)
ADDPQ QUIT
+1 ;
+2 ;
GETWNR ;
+1 ; -- Get Medicare (WNR) insurance company and plan data
+2 ; Returns IBCNSP or IBQUIT
+3 ; IBCNSP="Error: Medicare (WNR) ... not setup properly"
+4 ; if Medicare WNR entry or plans not setup properly
+5 ;
+6 ; IBCNSP=INS CO. (36) IEN^"MEDICARE (WNR)"
+7 ; ^PLAN (355.3) PARTA IEN^"PART A"
+8 ; ^PLAN (355.3) PARTB IEN^"PART B"
+9 ;
+10 IF 'IBCNSP
SET IBCNSP=$$GETWNR^IBCNSMM1
+11 IF 'IBCNSP
WRITE !!,*7,?3,IBCNSP
SET IBQUIT=1
+12 QUIT
+13 ;
VALHIC(X) ; Edits for validating HIC #
+1 ; X = the HIC # to be validated
+2 ;IB*2.0*601 JRA Remove special HIC # validation - use existing error messages IB356/IB357/IB358 when the
+3 ; Primary/Secondary/Tertiary insurance subscriber's ID number is missing (as with other insurances).
+4 ;
+5 ;IB*2.0*601 JRA QUIT '1' to remove special validation for HIC #, which will prevent the display of IB Error
+6 ; message IB215 and the HIC # help text at HLP^IBCNSM32.
+7 ;IB*2.0*601 JRA
QUIT 1
+8 NEW VAL
+9 SET VAL=1
+10 IF X'?9N1A.1AN
IF X'?1.3A6N
IF X'?1.3A9N
SET VAL=0
+11 QUIT VAL
+12 ;
COM(X,Y) ; Compare X with the intake variables.
+1 ; Input: X => 0th node of policy in file #2.312
+2 ; Y => A (Part A) or B (part B)
+3 ; Output: IBHIT=1 (no changes made)
+4 SET IBHIT=0
+5 IF $PIECE(X,"^",17)'=IBNAME
GOTO COMQ
+6 IF $PIECE(X,"^",2)'=IBHICN
GOTO COMQ
+7 IF $PIECE(X,"^",8)'=$SELECT(Y="A":IBAEFF,1:IBBEFF)
GOTO COMQ
+8 IF $PIECE(X,"^",20)'=IBCOBI
GOTO COMQ
+9 ;
+10 SET IBHIT=1
COMQ QUIT
