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
SET ABMFLAG=1
QUIT
+85 SET ABMMSPSV=ABMMSP
End DoDot:3
IF ABMFLAG=1
QUIT
+86 ; write the entry with date
+87 IF ABMFLAG=1
Begin DoDot:3
+88 ;abm*2.6*8
KILL %DT
+89 SET Y=ABMMSP
+90 DO DD^%DT
+91 SET ABMMSPDT=Y
+92 ;abm*2.6*8
KILL %DT
+93 SET ABMMSPRS=$SELECT($GET(ABMMSPSV)="":"NO REASON ENTERED",$PIECE($GET(^AUPNMSP(ABMMSPSV,0)),U,4)'="":$PIECE($GET(^AUPNMSP(ABMMSPSV,0)),U,4),1:"NO REASON ENTERED")
End DoDot:3
End DoDot:2
+94 ;end new code HEAT68467
+95 ; no MSP and inpatient
+96 IF $GET(ABMMSPRS)=""
IF ABMP("BTYP")=111
SET ABMG(194)=""
+97 ;
+98 ;I ABMP("BTYP")'=111,($G(ABMMSP)="") S ABMG(218)="" ;abm*2.6*11 HEAT104470
+99 ;I ABMP("BTYP")'=111,($G(ABMMSP)="") S ABME(218)="" ;abm*2.6*11 HEAT104470 ;abm*2.6*21 IHS/SD/SDR HEAT145126
+100 ;abm*2.6*11 HEAT104470 ;abm*2.6*21 IHS/SD/SDR HEAT145126
IF ABMP("BTYP")'=111
IF ($GET(ABMMSPRS)="")
SET ABME(218)=""
+101 ;
+102 ;not inpatient and >90 days since form signed
+103 IF ABMP("BTYP")'=111
IF ($GET(ABMMSP)'="")
Begin DoDot:2
+104 SET X=ABMMSP
+105 KILL %DT
+106 DO ^%DT
+107 SET X1=ABMP("VDT")
SET X2=Y
+108 DO ^%DTC
+109 IF X>90
SET ABME(195)=""
End DoDot:2
+110 ;
+111 ;no MSP and Medicare is secondary
+112 ;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
+113 ;abm*2.6*10 HEAT73780
IF $GET(ABMMSPRS)=""
IF $DATA(ABMZ(2))
IF ($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,$PIECE($GET(ABMZ(2)),U,2),".211","I"),1,"I")="R")
SET ABMG(196)=""
+114 ;
+115 ; MSP but Medicare not secondary
+116 ;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
+117 ;abm*2.6*10 HEAT73780
IF $GET(ABMMSPRS)'=""
IF $DATA(ABMZ(2))
IF ($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,$PIECE($GET(ABMZ(2)),U,2),".211","I"),1,"I")'="R")
IF ($GET(ABMMSP)'="")
Begin DoDot:2
+118 IF ABMP("BTYP")'=111
SET ABMG(197)=""
+119 SET X=ABMMSP
+120 DO ^%DT
+121 SET X1=ABMP("VDT")
SET X2=Y
+122 DO ^%DTC
+123 IF X>90
SET ABMG(197)=""
End DoDot:2
End DoDot:1
+124 IF '$TEST
IF ABMP("LDFN")]""
IF $DATA(^AUTNINS(ABMX("INS"),15,ABMP("LDFN"),0))
IF $PIECE(^(0),U,2)]""
SET $PIECE(ABMV("X1"),U,7)=$PIECE(^(0),U,2)
+125 IF '$TEST
IF $PIECE(ABMV("X1"),U,7)=""
SET ABME(5)=""
+126 IF ABMV("X2")]""
DO ^ABMDE2X2
+127 DO ^ABMDE2X3
+128 IF $GET(ABMP("INS"))=""
SET ABMP("INS")=$PIECE($GET(ABMV("X1")),";")
+129 ;I $P($G(^AUTNINS(ABMP("INS"),2)),U)="R"!($P($G(^AUTNINS(ABMP("INS"),2)),U)="D") D ;abm*2.6*10 HEAT73780
+130 ;abm*2.6*27 IHS/SD/SDR CR10170
IF ABMP("INS")'=$PIECE($GET(ABMV("X1")),";")
SET ABMISV=ABMP("INS")
SET ABMP("INS")=$PIECE($GET(ABMV("X1")),";")
+131 ;abm*2.6*10 HEAT73780
SET ABMITYP=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")
+132 ;abm*2.6*10 HEAT73780
IF ABMITYP="R"!(ABMITYP="D")
Begin DoDot:1
+133 SET ABMCK=$PIECE(ABMV("X1"),U,5)
+134 DO NAME
+135 IF $GET(ABMCK)=""
SET ABME(203)=""
End DoDot:1
+136 ;I $P($G(^AUTNINS(ABMP("INS"),2)),U)="R",($P($G(ABMV("X1")),U,6)="") S ABME(219)="" ;abm*2.6*10 HEAT73780
+137 ;abm*2.6*10 HEAT73780
IF ABMITYP="R"
IF ($PIECE($GET(ABMV("X1")),U,6)="")
SET ABME(219)=""
+138 ;abm*2.6*27 IHS/SD/SDR CR10170
IF (+$GET(ABMISV)'=0)
SET ABMP("INS")=ABMISV
SET ABMITYP=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")
+139 ;abm*2.6*3 HEAT7574
IF $PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),0)),U,11)="Y"
SET ABME(234)=""
+140 ;abm*2.6*6 5010
IF $PIECE(ABMV("X1"),U,4)=""
SET ABME(236)=""
+141 ;start new abm*2.6*21 IHS/SD/SDR VMBP RQMT_91
+142 IF "^D^R^"[("^"_$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+$GET(ABMP("INS")),".211","I"),1,"I")_"^")
Begin DoDot:1
+143 SET ABM("DR")=0
+144 FOR
SET ABM("DR")=$ORDER(@(ABMP("GL")_"13,"_ABM("DR")_")"))
IF 'ABM("DR")
QUIT
Begin DoDot:2
+145 SET ABM("DRI")=+$PIECE(@(ABMP("GL")_"13,"_ABM("DR")_",0)"),U)
+146 IF $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABM("DRI"),".211","I"),1,"I")="V"
SET ABME(253)=""
End DoDot:2
End DoDot:1
+147 ;end new abm*2.6*21 IHS/SD/SDR VMBP RQMT_91
+148 ;
XIT ;
+1 KILL ABMX,ABMP("ERR")
+2 QUIT
+3 ;
+4 ; *********************************************************************
MERGE ;CHECK IF INSURER HAS BEEN MERGED
+1 SET ABMX("MRGDT")=$PIECE($GET(^AUTNINS(+Y,2)),U,7)
+2 IF 'ABMX("MRGDT")
QUIT
+3 IF ABMX("MRGDT")=+Y
QUIT
+4 SET ABMX("MRGDF")=+Y
+5 IF $PIECE(@(ABMP("GL")_"0)"),U,8)=ABMX("MRGDF")
Begin DoDot:1
+6 SET DIE=$PIECE(ABMP("GL"),",",1)_","
+7 SET DA=$PIECE(ABMP("GL"),",",2)
+8 SET DR=".08///`"_ABMX("MRGDT")
+9 DO ^DIE
End DoDot:1
+10 SET %X=ABMP("GL")_"13,"_ABMX("MRGDF")_","
+11 SET %Y=ABMP("GL")_"13,"_ABMX("MRGDT")_","
+12 DO %XY^%RCR
+13 SET $PIECE(@(ABMP("GL")_"13,"_ABMX("MRGDT")_",0)"),U)=ABMX("MRGDT")
+14 SET $PIECE(@(ABMP("GL")_"13,0)"),U,3)=ABMX("MRGDT")
SET $PIECE(^(0),U,4)=$PIECE(^(0),U,4)+1
IF ABMP("GL")["ABMDBILL"
IF $PIECE(^(0),U,2)="9002274.3013P"
SET $PIECE(^(0),U,2)="9002274.4013P"
+15 SET DIK=ABMP("GL")_"13,"
+16 SET DA(1)=$PIECE(ABMP("GL"),",",2)
+17 SET DA=ABMX("MRGDF")
+18 DO ^DIK
+19 SET DA=ABMX("MRGDT")
+20 DO IX1^DIK
+21 SET Y=ABMX("MRGDT")
+22 IF $DATA(ABM("X"))
IF ABM("X")=ABMX("MRGDF")
SET ABM("X")=ABMX("MRGDT")
+23 QUIT
NAME ; entry point for name
+1 IF ABMCK[""""!(ABMCK'?1U.AP)!(ABMCK'[",")!(ABMCK?.E1","." ")!(ABMCK?.E1","." "1",".E)!($LENGTH(ABMCK,",")>3)!($LENGTH(ABMCK,".")>3)!($LENGTH(ABMCK,"-")>6)!($LENGTH(ABMCK,"(")>2)!($LENGTH(ABMCK,")")>2)!($LENGTH(ABMCK)>30)!(...
... $LENGTH(ABMCK)<3)!(ABMCK?.E1", ".E)
KILL ABMCK
QUIT
+2 FOR L=1:0
SET L=$FIND(ABMCK," ",L)
IF L=0
QUIT
IF $EXTRACT(ABMCK,L-2)?1P!($EXTRACT(ABMCK,L)?1P)!(L>$LENGTH(ABMCK))
SET ABMCK=$EXTRACT(ABMCK,1,L-2)_$EXTRACT(ABMCK,L,99)
SET L=L-1
+3 SET ABMNAMX=ABMCK
+4 FOR ABMII=$LENGTH(ABMNAMX):-1:1
IF "/
SET ABMNAMX=$EXTRACT(ABMNAMX,1,ABMII-1)_$EXTRACT(ABMNAMX,ABMII+1,245)
+5 IF ABMNAMX'=ABMCK
KILL ABMCK
+6 IF $DATA(ABMCK)
SET ABMCK=$$UP^XLFSTR(ABMCK)
+7 KILL ABMNAMX,ABMII
+8 QUIT
