ABMDE2X.m

ABMDE2X ; IHS/ASDST/DMJ - PAGE 2 - INSURER data chk ;  

 ;;2.6;IHS 3P BILLING SYSTEM;**3,6,8,9,10,11,21,27**;NOV 12, 2009;Build 486

 ;

 ; IHS/SD/SDR - V2.5 P3 - 1/24/03 - NOIS NEA-0301-180044

 ;     Modified routine to display patient info when workers comp

 ;

 ;IHS/SD/SDR 2.5 p8 IM15307/IM14092 - Modified to check for new MSP errors 194-197

 ;IHS/SD/SDR 2.5 p8 IM15111 - Check format of Medicare name

 ;IHS/SD/SDR 2.5 p10 IM20000 - Added code to use CARD NAME for Policy Holder

 ;IHS/SD/SDR 2.5 p10 IM20593 - Added new warning for NO MSP FOR MEDICARE PATIENT

 ;IHS/SD/SDR 2.5 p10 IM20311 - Added new error for missing DOB when Medicare active (219)

 ;IHS/SD/SDR 2.5 p12 UFMS - Added new warning/errors 225 and 226 for pseudo/missing TIN

 ;IHS/SD/SDR v2.5 p13 NO IM

 ;

 ;IHS/SD/SDR 2.6*3 HEAT7574 - added tribal self-insured warning

 ;IHS/SD/SDR 2.6*6 5010 - added error 236

 ;IHS/SD/SDR 2.6*21 HEAT145126 - Made correction to error 218 so it would display correctly.

 ;IHS/SD/SDR 2.6*21 VMBP RQMT_91 - Added error 253 if Mcr/Mcd and V insurer type exists on claim also

 ;IHS/SD/SDR 2.6*21 VMBP RQMT_109 - Added code to get data from the VAMB Eligible file

 ;IHS/SD/SDR 2.6*27 CR10170 When replacement insurer is Medicaid it tries to do the NAME check but fails and drops error 203; fixed to use

 ;  the original insurer type for check.

 ;

 ; *********************************************************************

ERR ;

 I '$D(ABMC("QUE")),'$G(ABMQUIET) D

 .S ABME("TITL")="PAGE 2 - INSURER INFORMATION"

 .W !?26,ABME("TITL"),!

 S ABM=""""""

 F ABM("I")=1:1 S ABM=$O(@(ABMP("GL")_"13,""C"","_ABM_")")) Q:'ABM

 I ABM("I")=1 S ABME(110)=""

 ;

PRIM ;

 S ABMP("GL")="^ABMDCLM(DUZ(2),"_ABMP("CDFN")_","

 D ^ABMDE2X1

 I ABMP("INS")]"" D

 .S Y=ABMP("INS")

 .S ABM("XIEN")=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABMP("INS"),0))

 .Q:'ABM("XIEN")

 .D COV^ABMDE2X5

 .D SEL

 K ABM,ABMV

 G XIT

 ;

 ; *********************************************************************

QUE ;

 S ABMP("GL")="^ABMDCLM(DUZ(2),"_ABMP("CDFN")_","

 D ^ABMDE2X1

 S ABM=0

 F ABM("I")=1:1 S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",ABM)) Q:'ABM!($G(ABMC("CTR"))>0)  D

 .S ABM("XIEN")=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",ABM,0))

 .S Y=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABM("XIEN"),0),U)

 .D SEL

 .Q:'+$O(ABME(0))

 .S ABME("CHK")=""

 .D QUE^ABMDERR

 K ABM,ABMV

 G XIT

 ;

 ; *********************************************************************

 ; X1=IDFN;INSURER^PHONE^CONTACT^POLICY #^NAME^DOB^PROV #^COVERAGE(S)

 ;

SEL ;EP - Entry Point for Checking Select Insurer for Errors

 K ABMV,ABME

 D MERGE

 I $D(ABMP("ERR",Y)) S ABMX="" F  S ABMX=$O(ABMP("ERR",Y,ABMX)) Q:'ABMX  S ABME(ABMX)=""

 I $D(@(ABMP("GL")_"13,"_+ABM("XIEN")_",0)")) S ABMX("I0")=^(0)

 E  S ABMP("QUIT")="" G XIT

 S ABMX("INS")=$P(ABMX("I0"),U)

 ;

 I $P($G(^ABMDPARM(DUZ(2),1,4)),U,14)=1 D  ;export

 .S ABMTIN=$P($G(^AUTNINS(ABMX("INS"),0)),U,11)

 .;if no TIN and anything except Ben Patient

 .;I ABMTIN="",($P($G(^AUTNINS(ABMX("INS"),2)),U)'="I") S ABME(225)=$S('$D(ABME(225)):$P(ABMX("I0"),U,2),1:ABME(225)_","_$P(ABMX("I0"),U,2))  ;abm*2.6*10 HEAT73780

 .I ABMTIN="",($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMX("INS"),".211","I"),1,"I")'="I") S ABME(225)=$S('$D(ABME(225)):$P(ABMX("I0"),U,2),1:ABME(225)_","_$P(ABMX("I0"),U,2))  ;abm*2.6*10 HEAT73780

 .I $A($E(ABMTIN,9))>64,$A($E(ABMTIN,9))<91 S ABME(226)=$S('$D(ABME(226)):$P(ABMX("I0"),U,2),1:ABME(226)_","_$P(ABMX("I0"),U,2))

 .K ABMTIN

 ;

 S ABMV("X1")=+Y_";"_$P(^AUTNINS(+Y,0),U)_U_$P(^(0),U,6)_U_$P(^(0),U,9)

 S (ABMV("X2"),ABMV("X3"))=""

 K DR

 I $L(ABMX("I0"),U)=3,$P(ABMX("I0"),U,3)'="U",$P(^AUTNINS(+Y,0),U)'="RAILROAD RETIREMENT" D

 .S ABMVDFN=$G(ABMP("VDFN"))

 .S DFN=ABMP("PDFN")

 .S ABMVDT=ABMP("VDT")

 .D ELG^ABMDLCK(ABMVDFN,.ABML,DFN,ABMVDT)

 .;start new code abm*2.6*11 HEAT86262

 .S ABM("PRI")=""

 .S ABMMCR=0

 .I $D(ABML(1,2))!($D(ABML(3,2))) S ABMMCR=1

 .F  S ABM("PRI")=$O(ABML(ABM("PRI"))) Q:'ABM("PRI")  D

 ..I ABMMCR,$D(ABML(ABM("PRI"),ABMP("INS"),"COV")),$$GET1^DIQ(9999999.65,$O(ABML(ABM("PRI"),ABMP("INS"),"COV",0)),".01","E")["MEDICARE SUPPL" S ABMG(47)=""

 ..I $D(ABML(99,2)),$D(ABML(ABM("PRI"),ABMP("INS"),"COV")),$$GET1^DIQ(9999999.65,$O(ABML(ABM("PRI"),ABMP("INS"),"COV",0)),".01","E")["MEDICARE SUPPL" S ABMG(48)=""

 .;end new code HEAT86262

 .S ABM("PRI")=""

 .F  S ABM("PRI")=$O(ABML(ABM("PRI"))) Q:'ABM("PRI")  I $D(ABML(ABM("PRI"),ABMX("INS"))) D  Q

 ..;Q:"PMRDAW"'[$P(ABML(ABM("PRI"),ABMX("INS")),U,3)  ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_109

 ..Q:"PMRDAWV"'[$P(ABML(ABM("PRI"),ABMX("INS")),U,3)  ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_109

 ..Q:$P(ABML(ABM("PRI"),ABMX("INS")),U,3)=""

 ..I $P(ABML(ABM("PRI"),ABMX("INS")),U,3)?1(1"P",1"A",1"W") S DR=".08////"_$P(ABML(ABM("PRI"),ABMX("INS")),U,2)

 ..I $P(ABML(ABM("PRI"),ABMX("INS")),U,3)="M" S DR=".04////"_$P(ABML(ABM("PRI"),ABMX("INS")),U,2)

 ..I $P(ABML(ABM("PRI"),ABMX("INS")),U,3)="R" S DR=".05////"_$P(ABML(ABM("PRI"),ABMX("INS")),U,2)

 ..I $P(ABML(ABM("PRI"),ABMX("INS")),U,3)="D" S DR=".06////"_$P(ABML(ABM("PRI"),ABMX("INS")),U,1)_";.07////"_$P(ABML(ABM("PRI"),ABMX("INS")),U,2)

 ..I $P(ABML(ABM("PRI"),ABMX("INS")),U,3)="V" S DR=".013////"_$P(ABML(ABM("PRI"),ABMX("INS")),U,2)  ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_109

 ..S DA(1)=$S(ABMP("GL")["CLM":ABMP("CDFN"),1:ABMP("BDFN"))

 ..I $D(DR) D

 ...S DIE=ABMP("GL")_"13,"

 ...S DA=ABM("XIEN")

 ...D ^DIE

 ..S ABMX("I0")=@(ABMP("GL")_"13,"_ABM("XIEN")_",0)")

 ..K ABML

 ;I "INW"[$P($G(^AUTNINS(ABMX("INS"),2)),U),$P(^(2),U)]"" D ^ABMDE2X3 G XIT  ;abm*2.6*10 HEAT73780

 S ABMITYP=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMX("INS"),".211","I"),1,"I")  ;abm*2.6*10 HEAT73780

 I "INW"[ABMITYP,ABMITYP]"" D ^ABMDE2X3 G XIT  ;abm*2.6*10 HEAT73780

 ;I $P($G(^AUTNINS(ABMX("INS"),2)),U)="P",('$D(^AUPNPRVT(ABMP("PDFN"),11,"B",ABMX("INS")))) D ^ABMDE2X3 G XIT  ;abm*2.6*6 HEAT30524

 ;I $P($G(^AUTNINS(ABMX("INS"),2)),U)="P",('$D(^AUPNPRVT(ABMP("PDFN"),11,"B",ABMX("INS")))) D ^ABMDE2X3  ;abm*2.6*6 HEAT30524  ;abm*2.6*10 HEAT73780

 I $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMX("INS"),".211","I"),1,"I")="P",('$D(^AUPNPRVT(ABMP("PDFN"),11,"B",ABMX("INS")))) D ^ABMDE2X3  ;abm*2.6*6 HEAT30524  ;abm*2.6*10 HEAT73780

 ;S ABMX("DIC")=$S($P(ABMX("I0"),U,6)]"":"^AUPNMCD(",$P(ABMX("I0"),U,8)]"":"^AUPNPRVT(",$P(ABMX("I0"),U,4)]"":"^AUPNMCR(",1:"^AUPNRRE("),ABMX("SUB")=$S($P(ABMX("I0"),U,7)]"":$P(ABMX("I0"),U,7),1:"")  ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_109

 S ABMX("DIC")=$S($P(ABMX("I0"),U,6)]"":"^AUPNMCD(",$P(ABMX("I0"),U,8)]"":"^AUPNPRVT(",$P(ABMX("I0"),U,4)]"":"^AUPNMCR(",$P(ABMX("I0"),U,13)]"":"^AUPNVAMB(",1:"^AUPNRRE(")  ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_109

 S ABMX("SUB")=$S($P(ABMX("I0"),U,7)]"":$P(ABMX("I0"),U,7),1:"")

 S ABMX(2)=$S(ABMX("DIC")="^AUPNMCD(":$P(ABMX("I0"),U,6),1:ABMP("PDFN"))

 I ABMX("DIC")="^AUPNPRVT(" S ABMX(1)=$P(ABMX("I0"),"^",8) G XIT:'ABMX(1)

 I ABMX("DIC")="^AUPNMCD(" S ABMX(1)=$P(ABMX("I0"),U,7)

 S ABMX("REC")=ABMX("DIC")_ABMX(2)_",0)"

 Q:'$D(@ABMX("REC"))

 S ABMX("REC")=@ABMX("REC")

 S ABMX("LBL")=$E($P(ABMX("DIC"),"("),6,10)

 D @(ABMX("LBL")_"^ABMDE2XA")

 D COV^ABMDE2XA

 I +ABMV("X2"),$D(^AUPN3PPH(+ABMV("X2"),0)) D

 .S $P(ABMV("X2"),U)=$P(ABMV("X2"),U)_";"_$S($P($G(^AUPN3PPH($P(ABMV("X2"),U),1)),U)'="":$P($G(^AUPN3PPH($P(ABMV("X2"),U),1)),U),1:$P($G(^AUPN3PPH($P(ABMV("X2"),U),0)),U))

 .S:$P(ABMV("X2"),U,2)]"" $P(ABMV("X2"),U,2)=$S($D(^AUTTRLSH($P(ABMV("X2"),U,2),0)):$P(ABMV("X2"),U,2)_";"_$P(^(0),U),1:"")

 S:$P(ABMV("X1"),U,4)="" ABME(68)=""

 I $P(ABMP("C0"),U,8)="" S ABME(111)=""  ;abm*2.6*8 HEAT37612

 ;I $P($G(^AUTNINS(ABMX("INS"),2)),U)="R" D  ;abm*2.6*10 HEAT73780

 I $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMX("INS"),".211","I"),1,"I")="R" D  ;abm*2.6*10 HEAT73780

 .S $P(ABMV("X1"),U,7)=$P(^AUTTLOC(ABMP("LDFN"),0),U,19)

 .S:$P($G(^AUTTLOC(ABMP("LDFN"),0)),U,19)="" ABME(173)=""

 .;start new code abm*2.6*10 HEAT68467

 .I $D(^AUPNMSP("C",ABMP("PDFN"))) D

 ..K ABMMSP,ABMFLAG,ABMMSPSV

 ..; get correct entry based on visit date

 ..S ABMMSP=9999999,ABMFLAG="",ABMMSPSV=9999999

 ..F  S ABMMSP=$O(^AUPNMSP("C",ABMP("PDFN"),ABMMSP),-1) Q:ABMMSP=""  D  Q:ABMFLAG=1

 ...I $G(ABMMSPSV)="" S ABMMSPSV=ABMMSP

 ...I (ABMP("VDT")<ABMMSPSV&(ABMP("VDT")>ABMMSP))!(ABMMSP=ABMP("VDT")) S ABMMSPSV=$O(^AUPNMSP("C",ABMP("PDFN"),ABMMSP,0)),ABMFLAG=1 Q

 ...I ABMP("VDT")=ABMMSP S ABMFLAG=1 Q

 ...S ABMMSPSV=ABMMSP

 ..; write the entry with date

 ..I ABMFLAG=1 D

 ...K %DT  ;abm*2.6*8

 ...S Y=ABMMSP

 ...D DD^%DT

 ...S ABMMSPDT=Y

 ...K %DT  ;abm*2.6*8

 ...S ABMMSPRS=$S($G(ABMMSPSV)="":"NO REASON ENTERED",$P($G(^AUPNMSP(ABMMSPSV,0)),U,4)'="":$P($G(^AUPNMSP(ABMMSPSV,0)),U,4),1:"NO REASON ENTERED")

 .;end new code HEAT68467

 .; no MSP and inpatient

 .I $G(ABMMSPRS)="",ABMP("BTYP")=111 S ABMG(194)=""

 .;

 .;I ABMP("BTYP")'=111,($G(ABMMSP)="") S ABMG(218)=""  ;abm*2.6*11 HEAT104470

 .;I ABMP("BTYP")'=111,($G(ABMMSP)="") S ABME(218)=""  ;abm*2.6*11 HEAT104470  ;abm*2.6*21 IHS/SD/SDR HEAT145126

 .I ABMP("BTYP")'=111,($G(ABMMSPRS)="") S ABME(218)=""  ;abm*2.6*11 HEAT104470  ;abm*2.6*21 IHS/SD/SDR HEAT145126

 .;

 .;not inpatient and >90 days since form signed

 .I ABMP("BTYP")'=111,($G(ABMMSP)'="") D

 ..S X=ABMMSP

 ..K %DT

 ..D ^%DT

 ..S X1=ABMP("VDT"),X2=Y

 ..D ^%DTC

 ..I X>90 S ABME(195)=""

 .;

 .;no MSP and Medicare is secondary

 .;I $G(ABMMSPRS)="",$D(ABMZ(2)),($P($G(^AUTNINS($P($G(ABMZ(2)),U,2),2)),U))="R" S ABMG(196)=""  ;abm*2.6*10 HEAT73780

 .I $G(ABMMSPRS)="",$D(ABMZ(2)),($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,$P($G(ABMZ(2)),U,2),".211","I"),1,"I")="R") S ABMG(196)=""  ;abm*2.6*10 HEAT73780

 .;

 .; MSP but Medicare not secondary

 .;I $G(ABMMSPRS)'="",$D(ABMZ(2)),($P($G(^AUTNINS($P($G(ABMZ(2)),U,2),2)),U)'="R"),($G(ABMMSP)'="") D  ;abm*2.6*10 HEAT73780

 .I $G(ABMMSPRS)'="",$D(ABMZ(2)),($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,$P($G(ABMZ(2)),U,2),".211","I"),1,"I")'="R"),($G(ABMMSP)'="") D  ;abm*2.6*10 HEAT73780

 ..I ABMP("BTYP")'=111 S ABMG(197)=""

 ..S X=ABMMSP

 ..D ^%DT

 ..S X1=ABMP("VDT"),X2=Y

 ..D ^%DTC

 ..I X>90 S ABMG(197)=""

 E  I ABMP("LDFN")]"",$D(^AUTNINS(ABMX("INS"),15,ABMP("LDFN"),0)),$P(^(0),U,2)]"" S $P(ABMV("X1"),U,7)=$P(^(0),U,2)

 E  I $P(ABMV("X1"),U,7)="" S ABME(5)=""

 I ABMV("X2")]"" D ^ABMDE2X2

 D ^ABMDE2X3

 S:$G(ABMP("INS"))="" ABMP("INS")=$P($G(ABMV("X1")),";")

 ;I $P($G(^AUTNINS(ABMP("INS"),2)),U)="R"!($P($G(^AUTNINS(ABMP("INS"),2)),U)="D") D  ;abm*2.6*10 HEAT73780

 I ABMP("INS")'=$P($G(ABMV("X1")),";") S ABMISV=ABMP("INS"),ABMP("INS")=$P($G(ABMV("X1")),";")  ;abm*2.6*27 IHS/SD/SDR CR10170

 S ABMITYP=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")  ;abm*2.6*10 HEAT73780

 I ABMITYP="R"!(ABMITYP="D") D  ;abm*2.6*10 HEAT73780

 .S ABMCK=$P(ABMV("X1"),U,5)

 .D NAME

 .I $G(ABMCK)="" S ABME(203)=""

 ;I $P($G(^AUTNINS(ABMP("INS"),2)),U)="R",($P($G(ABMV("X1")),U,6)="") S ABME(219)=""  ;abm*2.6*10 HEAT73780

 I ABMITYP="R",($P($G(ABMV("X1")),U,6)="") S ABME(219)=""  ;abm*2.6*10 HEAT73780

 S:(+$G(ABMISV)'=0) ABMP("INS")=ABMISV,ABMITYP=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")  ;abm*2.6*27 IHS/SD/SDR CR10170

 I $P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),0)),U,11)="Y" S ABME(234)=""  ;abm*2.6*3 HEAT7574

 I $P(ABMV("X1"),U,4)="" S ABME(236)=""  ;abm*2.6*6 5010

 ;start new abm*2.6*21 IHS/SD/SDR VMBP RQMT_91

 I "^D^R^"[("^"_$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+$G(ABMP("INS")),".211","I"),1,"I")_"^") D

 .S ABM("DR")=0

 .F  S ABM("DR")=$O(@(ABMP("GL")_"13,"_ABM("DR")_")")) Q:'ABM("DR")  D

 ..S ABM("DRI")=+$P(@(ABMP("GL")_"13,"_ABM("DR")_",0)"),U)

 ..I $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABM("DRI"),".211","I"),1,"I")="V" S ABME(253)=""

 ;end new abm*2.6*21 IHS/SD/SDR VMBP RQMT_91

 ;

XIT ;

 K ABMX,ABMP("ERR")

 Q

 ;

 ; *********************************************************************

MERGE ;CHECK IF INSURER HAS BEEN MERGED

 S ABMX("MRGDT")=$P($G(^AUTNINS(+Y,2)),U,7)

 Q:'ABMX("MRGDT")

 Q:ABMX("MRGDT")=+Y

 S ABMX("MRGDF")=+Y

 I $P(@(ABMP("GL")_"0)"),U,8)=ABMX("MRGDF") D

 .S DIE=$P(ABMP("GL"),",",1)_","

 .S DA=$P(ABMP("GL"),",",2)

 .S DR=".08///`"_ABMX("MRGDT")

 .D ^DIE

 S %X=ABMP("GL")_"13,"_ABMX("MRGDF")_","

 S %Y=ABMP("GL")_"13,"_ABMX("MRGDT")_","

 D %XY^%RCR

 S $P(@(ABMP("GL")_"13,"_ABMX("MRGDT")_",0)"),U)=ABMX("MRGDT")

 S $P(@(ABMP("GL")_"13,0)"),U,3)=ABMX("MRGDT"),$P(^(0),U,4)=$P(^(0),U,4)+1 I ABMP("GL")["ABMDBILL",$P(^(0),U,2)="9002274.3013P" S $P(^(0),U,2)="9002274.4013P"

 S DIK=ABMP("GL")_"13,"

 S DA(1)=$P(ABMP("GL"),",",2)

 S DA=ABMX("MRGDF")

 D ^DIK

 S DA=ABMX("MRGDT")

 D IX1^DIK

 S Y=ABMX("MRGDT")

 I $D(ABM("X")),ABM("X")=ABMX("MRGDF") S ABM("X")=ABMX("MRGDT")

 Q

NAME ; entry point for name

 I ABMCK[""""!(ABMCK'?1U.AP)!(ABMCK'[",")!(ABMCK?.E1","." ")!(ABMCK?.E1","." "1",".E)!($L(ABMCK,",")>3)!($L(ABMCK,".")>3)!($L(ABMCK,"-")>6)!($L(ABMCK,"(")>2)!($L(ABMCK,")")>2)!($L(ABMCK)>30)!($L(ABMCK)<3)!(ABMCK?.E1", ".E) K ABMCK Q

 F L=1:0 S L=$F(ABMCK," ",L) Q:L=0  S:$E(ABMCK,L-2)?1P!($E(ABMCK,L)?1P)!(L>$L(ABMCK)) ABMCK=$E(ABMCK,1,L-2)_$E(ABMCK,L,99),L=L-1

 S ABMNAMX=ABMCK

 F ABMII=$L(ABMNAMX):-1:1 S:"/:;'*()_+=&%$#@![]{}|\?<>~"""[$E(ABMNAMX,ABMII) ABMNAMX=$E(ABMNAMX,1,ABMII-1)_$E(ABMNAMX,ABMII+1,245)

 I ABMNAMX'=ABMCK K ABMCK

 I $D(ABMCK) S ABMCK=$$UP^XLFSTR(ABMCK)

 K ABMNAMX,ABMII

 Q

ABMDE2X   ; IHS/ASDST/DMJ - PAGE 2 - INSURER data chk ;  

 +1       ;;2.6;IHS 3P BILLING SYSTEM;**3,6,8,9,10,11,21,27**;NOV 12, 2009;Build 486

 +2       ;

 +3       ; IHS/SD/SDR - V2.5 P3 - 1/24/03 - NOIS NEA-0301-180044

 +4       ;     Modified routine to display patient info when workers comp

 +5       ;

 +6       ;IHS/SD/SDR 2.5 p8 IM15307/IM14092 - Modified to check for new MSP errors 194-197

 +7       ;IHS/SD/SDR 2.5 p8 IM15111 - Check format of Medicare name

 +8       ;IHS/SD/SDR 2.5 p10 IM20000 - Added code to use CARD NAME for Policy Holder

 +9       ;IHS/SD/SDR 2.5 p10 IM20593 - Added new warning for NO MSP FOR MEDICARE PATIENT

 +10      ;IHS/SD/SDR 2.5 p10 IM20311 - Added new error for missing DOB when Medicare active (219)

 +11      ;IHS/SD/SDR 2.5 p12 UFMS - Added new warning/errors 225 and 226 for pseudo/missing TIN

 +12      ;IHS/SD/SDR v2.5 p13 NO IM

 +13      ;

 +14      ;IHS/SD/SDR 2.6*3 HEAT7574 - added tribal self-insured warning

 +15      ;IHS/SD/SDR 2.6*6 5010 - added error 236

 +16      ;IHS/SD/SDR 2.6*21 HEAT145126 - Made correction to error 218 so it would display correctly.

 +17      ;IHS/SD/SDR 2.6*21 VMBP RQMT_91 - Added error 253 if Mcr/Mcd and V insurer type exists on claim also

 +18      ;IHS/SD/SDR 2.6*21 VMBP RQMT_109 - Added code to get data from the VAMB Eligible file

 +19      ;IHS/SD/SDR 2.6*27 CR10170 When replacement insurer is Medicaid it tries to do the NAME check but fails and drops error 203; fixed to use

 +20      ;  the original insurer type for check.

 +21      ;

 +22      ; *********************************************************************

ERR       ;

 +1        IF '$DATA(ABMC("QUE"))

               IF '$GET(ABMQUIET)

                   Begin DoDot:1

 +2                    SET ABME("TITL")="PAGE 2 - INSURER INFORMATION"

 +3                    WRITE !?26,ABME("TITL"),!

                   End DoDot:1

 +4        SET ABM=""""""

 +5        FOR ABM("I")=1:1

               SET ABM=$ORDER(@(ABMP("GL")_"13,""C"","_ABM_")"))

               IF 'ABM

                   QUIT 

 +6        IF ABM("I")=1

               SET ABME(110)=""

 +7       ;

PRIM      ;

 +1        SET ABMP("GL")="^ABMDCLM(DUZ(2),"_ABMP("CDFN")_","

 +2        DO ^ABMDE2X1

 +3        IF ABMP("INS")]""

               Begin DoDot:1

 +4                SET Y=ABMP("INS")

 +5                SET ABM("XIEN")=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABMP("INS"),0))

 +6                IF 'ABM("XIEN")

                       QUIT 

 +7                DO COV^ABMDE2X5

 +8                DO SEL

               End DoDot:1

 +9        KILL ABM,ABMV

 +10       GOTO XIT

 +11      ;

 +12      ; *********************************************************************

QUE       ;

 +1        SET ABMP("GL")="^ABMDCLM(DUZ(2),"_ABMP("CDFN")_","

 +2        DO ^ABMDE2X1

 +3        SET ABM=0

 +4        FOR ABM("I")=1:1

               SET ABM=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",ABM))

               IF 'ABM!($GET(ABMC("CTR"))>0)

                   QUIT 

               Begin DoDot:1

 +5                SET ABM("XIEN")=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",ABM,0))

 +6                SET Y=$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABM("XIEN"),0),U)

 +7                DO SEL

 +8                IF '+$ORDER(ABME(0))

                       QUIT 

 +9                SET ABME("CHK")=""

 +10               DO QUE^ABMDERR

               End DoDot:1

 +11       KILL ABM,ABMV

 +12       GOTO XIT

 +13      ;

 +14      ; *********************************************************************

 +15      ; X1=IDFN;INSURER^PHONE^CONTACT^POLICY #^NAME^DOB^PROV #^COVERAGE(S)

 +16      ;

SEL       ;EP - Entry Point for Checking Select Insurer for Errors

 +1        KILL ABMV,ABME

 +2        DO MERGE

 +3        IF $DATA(ABMP("ERR",Y))

               SET ABMX=""

               FOR 

                   SET ABMX=$ORDER(ABMP("ERR",Y,ABMX))

                   IF 'ABMX

                       QUIT 

                   SET ABME(ABMX)=""

 +4        IF $DATA(@(ABMP("GL")_"13,"_+ABM("XIEN")_",0)"))

               SET ABMX("I0")=^(0)

 +5       IF '$TEST

               SET ABMP("QUIT")=""

               GOTO XIT

 +6        SET ABMX("INS")=$PIECE(ABMX("I0"),U)

 +7       ;

 +8       ;export

           IF $PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,14)=1

               Begin DoDot:1

 +9                SET ABMTIN=$PIECE($GET(^AUTNINS(ABMX("INS"),0)),U,11)

 +10      ;if no TIN and anything except Ben Patient

 +11      ;I ABMTIN="",($P($G(^AUTNINS(ABMX("INS"),2)),U)'="I") S ABME(225)=$S('$D(ABME(225)):$P(ABMX("I0"),U,2),1:ABME(225)_","_$P(ABMX("I0"),U,2))  ;abm*2.6*10 HEAT73780

 +12      ;abm*2.6*10 HEAT73780

                   IF ABMTIN=""

                       IF ($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMX("INS"),".211","I"),1,"I")'="I")

                           SET ABME(225)=$SELECT('$DATA(ABME(225)):$PIECE(ABMX("I0"),U,2),1:ABME(225)_","_$PIECE(ABMX("I0"),U,2))

 +13               IF $ASCII($EXTRACT(ABMTIN,9))>64

                       IF $ASCII($EXTRACT(ABMTIN,9))<91

                           SET ABME(226)=$SELECT('$DATA(ABME(226)):$PIECE(ABMX("I0"),U,2),1:ABME(226)_","_$PIECE(ABMX("I0"),U,2))

 +14               KILL ABMTIN

               End DoDot:1

 +15      ;

 +16       SET ABMV("X1")=+Y_";"_$PIECE(^AUTNINS(+Y,0),U)_U_$PIECE(^(0),U,6)_U_$PIECE(^(0),U,9)

 +17       SET (ABMV("X2"),ABMV("X3"))=""

 +18       KILL DR

 +19       IF $LENGTH(ABMX("I0"),U)=3

               IF $PIECE(ABMX("I0"),U,3)'="U"

                   IF $PIECE(^AUTNINS(+Y,0),U)'="RAILROAD RETIREMENT"

                       Begin DoDot:1

 +20                       SET ABMVDFN=$GET(ABMP("VDFN"))

 +21                       SET DFN=ABMP("PDFN")

 +22                       SET ABMVDT=ABMP("VDT")

 +23                       DO ELG^ABMDLCK(ABMVDFN,.ABML,DFN,ABMVDT)

 +24      ;start new code abm*2.6*11 HEAT86262

 +25                       SET ABM("PRI")=""

 +26                       SET ABMMCR=0

 +27                       IF $DATA(ABML(1,2))!($DATA(ABML(3,2)))

                               SET ABMMCR=1

 +28                       FOR 

                               SET ABM("PRI")=$ORDER(ABML(ABM("PRI")))

                               IF 'ABM("PRI")

                                   QUIT 

                               Begin DoDot:2

 +29                               IF ABMMCR

                                       IF $DATA(ABML(ABM("PRI"),ABMP("INS"),"COV"))

                                           IF $$GET1^DIQ(9999999.65,$ORDER(ABML(ABM("PRI"),ABMP("INS"),"COV",0)),".01","E")["MEDICARE SUPPL"

                                               SET ABMG(47)=""

 +30                               IF $DATA(ABML(99,2))

                                       IF $DATA(ABML(ABM("PRI"),ABMP("INS"),"COV"))

                                           IF $$GET1^DIQ(9999999.65,$ORDER(ABML(ABM("PRI"),ABMP("INS"),"COV",0)),".01","E")["MEDICARE SUPPL"

                                               SET ABMG(48)=""

                               End DoDot:2

 +31      ;end new code HEAT86262

 +32                       SET ABM("PRI")=""

 +33                       FOR 

                               SET ABM("PRI")=$ORDER(ABML(ABM("PRI")))

                               IF 'ABM("PRI")

                                   QUIT 

                               IF $DATA(ABML(ABM("PRI"),ABMX("INS")))

                                   Begin DoDot:2

 +34      ;Q:"PMRDAW"'[$P(ABML(ABM("PRI"),ABMX("INS")),U,3)  ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_109

 +35      ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_109

                                       IF "PMRDAWV"'[$PIECE(ABML(ABM("PRI"),ABMX("INS")),U,3)

                                           QUIT 

 +36                                   IF $PIECE(ABML(ABM("PRI"),ABMX("INS")),U,3)=""

                                           QUIT 

 +37                                   IF $PIECE(ABML(ABM("PRI"),ABMX("INS")),U,3)?1(1"P",1"A",1"W")

                                           SET DR=".08////"_$PIECE(ABML(ABM("PRI"),ABMX("INS")),U,2)

 +38                                   IF $PIECE(ABML(ABM("PRI"),ABMX("INS")),U,3)="M"

                                           SET DR=".04////"_$PIECE(ABML(ABM("PRI"),ABMX("INS")),U,2)

 +39                                   IF $PIECE(ABML(ABM("PRI"),ABMX("INS")),U,3)="R"

                                           SET DR=".05////"_$PIECE(ABML(ABM("PRI"),ABMX("INS")),U,2)

 +40                                   IF $PIECE(ABML(ABM("PRI"),ABMX("INS")),U,3)="D"

                                           SET DR=".06////"_$PIECE(ABML(ABM("PRI"),ABMX("INS")),U,1)_";.07////"_$PIECE(ABML(ABM("PRI"),ABMX("INS")),U,2)

 +41      ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_109

                                       IF $PIECE(ABML(ABM("PRI"),ABMX("INS")),U,3)="V"

                                           SET DR=".013////"_$PIECE(ABML(ABM("PRI"),ABMX("INS")),U,2)

 +42                                   SET DA(1)=$SELECT(ABMP("GL")["CLM":ABMP("CDFN"),1:ABMP("BDFN"))

 +43                                   IF $DATA(DR)

                                           Begin DoDot:3

 +44                                           SET DIE=ABMP("GL")_"13,"

 +45                                           SET DA=ABM("XIEN")

 +46                                           DO ^DIE

                                           End DoDot:3

 +47                                   SET ABMX("I0")=@(ABMP("GL")_"13,"_ABM("XIEN")_",0)")

 +48                                   KILL ABML

                                   End DoDot:2

                                   QUIT 

                       End DoDot:1

 +49      ;I "INW"[$P($G(^AUTNINS(ABMX("INS"),2)),U),$P(^(2),U)]"" D ^ABMDE2X3 G XIT  ;abm*2.6*10 HEAT73780

 +50      ;abm*2.6*10 HEAT73780

           SET ABMITYP=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMX("INS"),".211","I"),1,"I")

 +51      ;abm*2.6*10 HEAT73780

           IF "INW"[ABMITYP

               IF ABMITYP]""

                   DO ^ABMDE2X3

                   GOTO XIT

 +52      ;I $P($G(^AUTNINS(ABMX("INS"),2)),U)="P",('$D(^AUPNPRVT(ABMP("PDFN"),11,"B",ABMX("INS")))) D ^ABMDE2X3 G XIT  ;abm*2.6*6 HEAT30524

 +53      ;I $P($G(^AUTNINS(ABMX("INS"),2)),U)="P",('$D(^AUPNPRVT(ABMP("PDFN"),11,"B",ABMX("INS")))) D ^ABMDE2X3  ;abm*2.6*6 HEAT30524  ;abm*2.6*10 HEAT73780

 +54      ;abm*2.6*6 HEAT30524  ;abm*2.6*10 HEAT73780

           IF $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMX("INS"),".211","I"),1,"I")="P"

               IF ('$DATA(^AUPNPRVT(ABMP("PDFN"),11,"B",ABMX("INS"))))

                   DO ^ABMDE2X3

 +55      ;S ABMX("DIC")=$S($P(ABMX("I0"),U,6)]"":"^AUPNMCD(",$P(ABMX("I0"),U,8)]"":"^AUPNPRVT(",$P(ABMX("I0"),U,4)]"":"^AUPNMCR(",1:"^AUPNRRE("),ABMX("SUB")=$S($P(ABMX("I0"),U,7)]"":$P(ABMX("I0"),U,7),1:"")  ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_109

 +56      ;abm*2.6*21 IHS/SD/SDR VMBP RQMT_109

           SET ABMX("DIC")=$SELECT($PIECE(ABMX("I0"),U,6)]"":"^AUPNMCD(",$PIECE(ABMX("I0"),U,8)]"":"^AUPNPRVT(",$PIECE(ABMX("I0"),U,4)]"":"^AUPNMCR(",$PIECE(ABMX("I0"),U,13)]"":"^AUPNVAMB(",1:"^AUPNRRE(")

 +57       SET ABMX("SUB")=$SELECT($PIECE(ABMX("I0"),U,7)]"":$PIECE(ABMX("I0"),U,7),1:"")

 +58       SET ABMX(2)=$SELECT(ABMX("DIC")="^AUPNMCD(":$PIECE(ABMX("I0"),U,6),1:ABMP("PDFN"))

 +59       IF ABMX("DIC")="^AUPNPRVT("

               SET ABMX(1)=$PIECE(ABMX("I0"),"^",8)

               IF 'ABMX(1)

                   GOTO XIT

 +60       IF ABMX("DIC")="^AUPNMCD("

               SET ABMX(1)=$PIECE(ABMX("I0"),U,7)

 +61       SET ABMX("REC")=ABMX("DIC")_ABMX(2)_",0)"

 +62       IF '$DATA(@ABMX("REC"))

               QUIT 

 +63       SET ABMX("REC")=@ABMX("REC")

 +64       SET ABMX("LBL")=$EXTRACT($PIECE(ABMX("DIC"),"("),6,10)

 +65       DO @(ABMX("LBL")_"^ABMDE2XA")

 +66       DO COV^ABMDE2XA

 +67       IF +ABMV("X2")

               IF $DATA(^AUPN3PPH(+ABMV("X2"),0))

                   Begin DoDot:1

 +68                   SET $PIECE(ABMV("X2"),U)=$PIECE(ABMV("X2"),U)_";"_$SELECT($PIECE($GET(^AUPN3PPH($PIECE(ABMV("X2"),U),1)),U)'="":$PIECE($GET(^AUPN3PPH($PIECE(ABMV("X2"),U),1)),U),1:$PIECE($GET(^AUPN3PPH($PIECE(ABMV("X2"),U),0)),U))

 +69                   IF $PIECE(ABMV("X2"),U,2)]""

                           SET $PIECE(ABMV("X2"),U,2)=$SELECT($DATA(^AUTTRLSH($PIECE(ABMV("X2"),U,2),0)):$PIECE(ABMV("X2"),U,2)_";"_$PIECE(^(0),U),1:"")

                   End DoDot:1

 +70       IF $PIECE(ABMV("X1"),U,4)=""

               SET ABME(68)=""

 +71      ;abm*2.6*8 HEAT37612

           IF $PIECE(ABMP("C0"),U,8)=""

               SET ABME(111)=""

 +72      ;I $P($G(^AUTNINS(ABMX("INS"),2)),U)="R" D  ;abm*2.6*10 HEAT73780

 +73      ;abm*2.6*10 HEAT73780

           IF $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMX("INS"),".211","I"),1,"I")="R"

               Begin DoDot:1

 +74               SET $PIECE(ABMV("X1"),U,7)=$PIECE(^AUTTLOC(ABMP("LDFN"),0),U,19)

 +75               IF $PIECE($GET(^AUTTLOC(ABMP("LDFN"),0)),U,19)=""

                       SET ABME(173)=""

 +76      ;start new code abm*2.6*10 HEAT68467

 +77               IF $DATA(^AUPNMSP("C",ABMP("PDFN")))

                       Begin DoDot:2

 +78                       KILL ABMMSP,ABMFLAG,ABMMSPSV

 +79      ; get correct entry based on visit date

 +80                       SET ABMMSP=9999999

                           SET ABMFLAG=""

                           SET ABMMSPSV=9999999

 +81                       FOR 

                               SET ABMMSP=$ORDER(^AUPNMSP("C",ABMP("PDFN"),ABMMSP),-1)

                               IF ABMMSP=""

                                   QUIT 

                               Begin DoDot:3

 +82                               IF $GET(ABMMSPSV)=""

                                       SET ABMMSPSV=ABMMSP

 +83                               IF (ABMP("VDT")<ABMMSPSV&(ABMP("VDT")>ABMMSP))!(ABMMSP=ABMP("VDT"))

                                       SET ABMMSPSV=$ORDER(^AUPNMSP("C",ABMP("PDFN"),ABMMSP,0))

                                       SET ABMFLAG=1

                                       QUIT 

 +84                               IF ABMP("VDT")=ABMMSP