ABMDE2E ; IHS/SD/SDR - DSD/DMJ - Check visit for elig ;
;;2.6;IHS 3P BILLING SYSTEM;**8,10,21**;NOV 12, 2009;Build 379
;
; IHS/ASDS/SDH - 06/08/01 - V2.4 Patch 9 - NOIS QDA-0399-130023
; Modified to update Mode of Export in Insurer has changed.
; IHS/ASDS/LSL - 07/25/01 - V2.4 Patch 9 - NOIS HQW-0798-100082
; Loop through all of ABML to update claim with unbillable
; insurers. Currently only loops if at least one good insurer.
; Only create new entry in Insurer multiple if billable insurer.
; Loop all eligibility occurances for PI (08/29/01)
; IHS/ASDS/SDH - 9/27/01 - V2.4 Patch 9 - NOIS XAA-0901-200095
; After moving Kidscare to Page 5 from Page 7 found that there are
; checks that are done for Medicaid that should also be done for
; Kidscare.
; IHS/ASDS/DMJ - 12/10/01 - V2.4 Patch 10 - NOIS HQW-1201-100014
; Loop PCC visit multiple (11) ignoring those that have been
; merged/deleted.
;
; IHS/SD/SDR - v2.5 p3 - 2/28/03 - QEA-0702-130030
; Modified to check for manually entered insurer
; IHS/SD/SDR V2.5 P5 - 3/10/2004
; Jim Gray provided code change to fix problem with with array not
; being killed before use.
; IHS/SD/SDR - v2.5 p8 - task 8
; Added code to check for replacment insurer
; IHS/SD/SDR - v2.5 p9 - IM17864
; Check if insurer is merged
; IHS/SD/SDR - v2.5 p10 - IM20320
; Added check to MERGECK to see if manually added insurer; if so,
; don't delete
;
;IHS/SD/SDR - 2.6*21 - HEAT137034 - Fixed code for DISPLAY UNBILLABLE INSURER site parameter. The check wasn't being
; done correctly so unbillable insurers were displaying all the time instead of when specified by parameter.
;IHS/SD/SDR - 2.6*21 - VMBP - RQMT_90 - Added code for 'V' insurer type.
;
; *********************************************************************
;
S ABMP("VDT")=$P(ABMP("C0"),U,2)
S ABMP("CLN")=$P(ABMP("C0"),U,6)
S DFN=ABMP("PDFN")
S ABMVDT=ABMP("VDT")
S I=0
F S I=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),11,"AC","P",I)) Q:'I D
.Q:$P($G(^AUPNVSIT(I,0)),"^",11)
.S ABMVDFN=I
S:'$G(ABMVDFN) ABMVDFN=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),11,0))
D ELG^ABMDLCK(ABMVDFN,.ABML,DFN,ABMVDT)
D MERGECK
;
ENT ;EP - Entry Point to update Elig Info
S ABM("PRI")=""
F S ABM("PRI")=$O(ABML(ABM("PRI"))) Q:'ABM("PRI") D INS
;
HITCHK ;HIT CHECK
N I
;start old code abm*2.6*8
;S I=0
;F S I=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I)) Q:'I D
;.I '$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U) D Q
;..K ^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0)
;.S ABM("INS")=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U)
;.S ABM("ITYPE")=$P($G(^AUTNINS(ABM("INS"),2)),U)
;.I ABM("ITYPE")="D"!(ABM("ITYPE")="K") D DCFX^ABMDEFIP(ABMP("CDFN"),I)
;.D HITCHK2
;end old code start new code
N K
S K=0
F S K=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",K)) Q:'K D
.S I=0
.F S I=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",K,I)) Q:'I D
..I '$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U) D Q
...K ^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0)
..S ABM("INS")=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U)
..;S ABM("ITYPE")=$P($G(^AUTNINS(ABM("INS"),2)),U) ;abm*2.6*10 HEAT73780
..S ABM("ITYPE")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABM("INS"),".211","I"),1,"I") ;abm*2.6*10 HEAT73780
..I ABM("ITYPE")="D"!(ABM("ITYPE")="K") D DCFX^ABMDEFIP(ABMP("CDFN"),I)
..D HITCHK2
;end new code
G PRIM
;
; *********************************************************************
HITCHK2 ;
K ABM("HIT")
S ABM("PRI")=""
F S ABM("PRI")=$O(ABML(ABM("PRI"))) Q:'ABM("PRI") D HITCHK3
I $D(ABM("HIT")) Q
I $G(ABMP("DERP OPT")) Q ;No editing from inq
I $P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),9)),U)'="Y" D
.I '$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),8)),U,3) D
..I "FPUI"[$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U,3),$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0)),U,9)!($P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,4)="F") D
...S DA=I
...D KILL
..;I ABM("INS")'=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8) D ;abm*2.6*8
..I ABM("INS")=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8),($P(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U,3)="U") D ;abm*2.6*8
...S DA=ABMP("CDFN")
...S DIE="^ABMDCLM(DUZ(2),"
...S DR=".08///@"
...D ^DIE
...K DR
Q
;
; *********************************************************************
HITCHK3 ;
S ABM("FINS")=""
F S ABM("FINS")=$O(ABML(ABM("PRI"),ABM("FINS"))) Q:'ABM("FINS") D
. I ABM("FINS")=ABM("INS") S ABM("HIT")=""
Q
;
; *********************************************************************
INS ;
S ABM("INS")=""
F S ABM("INS")=$O(ABML(ABM("PRI"),ABM("INS"))) Q:'ABM("INS") D ADDCHK
Q
;
MERGECK ;mark entries unbillable that aren't in eligibility array
Q:("CU"[$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,4)) ;quit if billed/complete
S ABMIIEN=0
F S ABMIIEN=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABMIIEN)) Q:+ABMIIEN=0 D
.S ABMPRI=0,ABMMATCH=0
.F S ABMPRI=$O(ABML(ABMPRI)) Q:+ABMPRI=0 D
..I $O(ABML(ABMPRI,0))=ABMIIEN S ABMMATCH=1
.I ABMMATCH'=1 D
..;start old code abm*2.6*8 HEAT37612
..;S DA(1)=ABMP("CDFN")
..;S DA=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABMIIEN,0))
..;Q:$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,DA,0)),U,9)="Y"
..;S DIK="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
..;D ^DIK
..;end old code start new code HEAT37612
..S DA(1)=ABMP("CDFN")
..S DA=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABMIIEN,0))
..Q:$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,DA,0)),U,9)="Y"
..Q:$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,DA,0)),U,3)="C"
..S DIE="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
..S DR=".03////U" ;set status to unbillable if not returned in elig array
..D ^DIE
..;end new code HEAT37612
Q
; *********************************************************************
ADDCHK ; EP
I (ABM("PRI")>96)&'$D(^ABMDPARM(DUZ(2),1,6,ABM("INS")))&(+$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABM("INS"),0))=0) Q ;abm*2.6*21 IHS/SD/SDR HEAT137034
I '$D(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABM("INS"))) D Q
.;I ABM("PRI")>96,'$D(^ABMDPARM(DUZ(2),1,6,ABM("INS"))) Q ;abm*2.6*21 IHS/SD/SDR HEAT137034
.D ADD
.D COVCHK
I $P(ABML(ABM("PRI"),ABM("INS")),"^",3)="P" D
.N I
.S I=0
.S ABM("ADD")=1
.F S I=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I)) Q:'I D
..Q:$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U)'=ABM("INS")
..I $P(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),"^",8)=$P(ABML(ABM("PRI"),ABM("INS")),"^",2) K ABM("ADD")
;I $G(ABM("ADD")),ABM("PRI")<97 D Q ;abm*2.6*21 IHS/SD/SDR HEAT137034
I $G(ABM("ADD"))&((ABM("PRI")<97)!((ABM("PRI")>96)&($D(^ABMDPARM(DUZ(2),1,6,ABM("INS")))))) D Q ;if priority is <97 or if priority is greater than 96 and display unbillable insurer ;abm*2.6*21 IHS/SD/SDR HEAT137034
.D ADD
.D COVCHK
S DA(1)=ABMP("CDFN")
S DIE="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
I '$G(ADD),$P(ABML(ABM("PRI"),ABM("INS")),U,3)="P" D Q
.S DA=0
.F S DA=$O(^ABMDCLM(DUZ(2),DA(1),13,"B",ABM("INS"),DA)) Q:'+DA D
..Q:$P(^ABMDCLM(DUZ(2),DA(1),13,DA,0),U,8)'=$P(ABML(ABM("PRI"),ABM("INS")),U,2)
..D UPDATE
S DA=$O(^ABMDCLM(DUZ(2),DA(1),13,"B",ABM("INS"),0))
Q:'+DA
D UPDATE
Q
;
; *********************************************************************
UPDATE ;
K ^ABMDCLM(DUZ(2),DA(1),13,DA,11)
I $P(^ABMDCLM(DUZ(2),DA(1),13,DA,0),U,3)="U",ABM("PRI")<97 D G COVCHK
.S DR=".03////P"
.D ^DIE
I "IP"[$P(^ABMDCLM(DUZ(2),DA(1),13,DA,0),U,3),ABM("PRI")>96 D
.S DR=".03////U"
.D ^DIE
;
COVCHK ;
S ABM("C")=""
F S ABM("C")=$O(ABML(ABM("PRI"),ABM("INS"),"COV",ABM("C"))) Q:'ABM("C") D
.I '$D(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,DA,11,ABM("C"),0)) D ADDCOV
Q
;
; *********************************************************************
ADD ;EP - Entry Pont for adding Elig Info to Claim
K DIC
S (ABM("L"),ABML("I"))=0
F S ABML("I")=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABML("I"))) Q:'ABML("I") S:$P(^(ABML("I"),0),U,2)>ABM("L") ABM("L")=$P(^(0),U,2)
K ABML("I")
S ABM("L")=ABM("L")+1
S DA(1)=ABMP("CDFN")
S DIC="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
S DIC(0)="LE"
S DIC("P")=$P(^DD(9002274.3,13,0),U,2)
I ABM("L")=1,'$D(ABML(97)) S ABM("STATUS")="I"
E S ABM("STATUS")="P"
S:ABM("PRI")>96 ABM("STATUS")="U"
S X=ABM("INS")
S DIC("DR")=".02///"_ABM("L")_";.03///"_ABM("STATUS")
I $P(ABML(ABM("PRI"),ABM("INS")),U,3)?1(1"P",1"A",1"W") D
.S DIC("DR")=DIC("DR")_";.08////"_$P(ABML(ABM("PRI"),ABM("INS")),U,2)
I $P(ABML(ABM("PRI"),ABM("INS")),U,3)="M" D
.S DIC("DR")=DIC("DR")_";.04////"_$P(ABML(ABM("PRI"),ABM("INS")),U,2)
I $P(ABML(ABM("PRI"),ABM("INS")),U,3)="R" D
.S DIC("DR")=DIC("DR")_";.05////"_$P(ABML(ABM("PRI"),ABM("INS")),U,2)
I $P(ABML(ABM("PRI"),ABM("INS")),U,3)="D" D
.S DIC("DR")=DIC("DR")_";.06////"_$P(ABML(ABM("PRI"),ABM("INS")),U,1)
.S DIC("DR")=DIC("DR")_";.07////"_$P(ABML(ABM("PRI"),ABM("INS")),U,2)
I $P(ABML(ABM("PRI"),ABM("INS")),U,7)="M" D
.S DIC("DR")=DIC("DR")_";.09////Y"
;start new abm*2.6*21 IHS/SD/SDR VMBP RQMT_90
I $P(ABML(ABM("PRI"),ABM("INS")),U,3)="V" D
.S DIC("DR")=DIC("DR")_";.013////"_$P(ABML(ABM("PRI"),ABM("INS")),U,2)
;end new abm*2.6*21 IHS/SD/SDR VMBP RQMT_90
K DD,DO
D FILE^DICN
S (DA,ABM("XIEN"))=+Y
K DIC
Q
;
; *********************************************************************
ADDCOV ; EP for adding Coverage Types
I ABM("C")]"",$D(^AUTTPIC(ABM("C"),0)),$P(^(0),U,2)=ABM("INS")
E Q
K DIC
S DA(1)=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABM("INS"),0))
S DA(2)=ABMP("CDFN")
S DIC="^ABMDCLM(DUZ(2),"_DA(2)_",13,"_DA(1)_",11,"
S DIC(0)="LE"
S DIC("P")=$P(^DD(9002274.3013,11,0),U,2)
K DD,DO,DR,DIC("DR")
S (X,DINUM)=ABM("C")
K DD,DO
D FILE^DICN
K DIC
Q
;
; *********************************************************************
KILL ;
S DA(1)=ABMP("CDFN")
S DIK="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
D ^DIK
I $P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8)=ABM("INS") D
.S DA=ABMP("CDFN")
.S DIE="^ABMDCLM(DUZ(2),"
.S DR=".08///@"
.D ^DIE
.K DR
Q
;
; *********************************************************************
PRIM ; Changed code under this line tag for readability in addition to those
; changes documented.
;
S ABMYES=0
S ABMP("INS")=""
S ABM("DR")=""
F S ABM("DR")=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",ABM("DR"))) Q:'ABM("DR") D Q:'ABM("DR")
.S ABM("DA")=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",ABM("DR"),""))
.Q:ABM("DA")=""
.Q:'$D(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABM("DA"),0))
.K ABM("DRI")
.S ABM("I0")=$G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABM("DA"),0))
.I "UCB"[$P(ABM("I0"),U,3) Q
.S ABM("INSCO")=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABM("DA"),0),U)
.I +ABMYES,$P(ABM("I0"),U,3)="I" S ABM("DRI")=".03////P"
.I '+ABMYES D
..I $P(ABM("I0"),U,3)'="I" D
...S ABM("DRI")=".03////I"
..S ABMYES=1
..I $P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8)'=ABM("INSCO") D
...S ABMINSCK=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABM("INSCO"),0))
...;replacement insurer?
...Q:$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8)=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINSCK,0)),U,11)
...S DIE="^ABMDCLM(DUZ(2),"
...S DA=ABMP("CDFN")
...S DR=".08////^S X=ABM(""INSCO"")"
...D ^DIE
...K DR
.I $D(ABM("DRI")) D
..S DA(1)=ABMP("CDFN")
..S DA=ABM("DA")
..S DR=ABM("DRI")
..S DIE="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
..D ^DIE
..K DR
S ABMP("C0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),0)
I $P(ABMP("C0"),U,8)="" S ABME(111)="" G XIT
S ABMP("INS")=$P(ABMP("C0"),U,8)
S ABMTEXP=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,4)
Q:ABMTEXP=""
S ABMP("EXP")=ABMTEXP
S DIE="^ABMDCLM(DUZ(2),"
S DA=ABMP("CDFN")
S DR=".14////"_ABMP("EXP")
D ^DIE
K DR
;
XIT ;
K ABML
Q
ABMDE2E ; IHS/SD/SDR - DSD/DMJ - Check visit for elig ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**8,10,21**;NOV 12, 2009;Build 379
+2 ;
+3 ; IHS/ASDS/SDH - 06/08/01 - V2.4 Patch 9 - NOIS QDA-0399-130023
+4 ; Modified to update Mode of Export in Insurer has changed.
+5 ; IHS/ASDS/LSL - 07/25/01 - V2.4 Patch 9 - NOIS HQW-0798-100082
+6 ; Loop through all of ABML to update claim with unbillable
+7 ; insurers. Currently only loops if at least one good insurer.
+8 ; Only create new entry in Insurer multiple if billable insurer.
+9 ; Loop all eligibility occurances for PI (08/29/01)
+10 ; IHS/ASDS/SDH - 9/27/01 - V2.4 Patch 9 - NOIS XAA-0901-200095
+11 ; After moving Kidscare to Page 5 from Page 7 found that there are
+12 ; checks that are done for Medicaid that should also be done for
+13 ; Kidscare.
+14 ; IHS/ASDS/DMJ - 12/10/01 - V2.4 Patch 10 - NOIS HQW-1201-100014
+15 ; Loop PCC visit multiple (11) ignoring those that have been
+16 ; merged/deleted.
+17 ;
+18 ; IHS/SD/SDR - v2.5 p3 - 2/28/03 - QEA-0702-130030
+19 ; Modified to check for manually entered insurer
+20 ; IHS/SD/SDR V2.5 P5 - 3/10/2004
+21 ; Jim Gray provided code change to fix problem with with array not
+22 ; being killed before use.
+23 ; IHS/SD/SDR - v2.5 p8 - task 8
+24 ; Added code to check for replacment insurer
+25 ; IHS/SD/SDR - v2.5 p9 - IM17864
+26 ; Check if insurer is merged
+27 ; IHS/SD/SDR - v2.5 p10 - IM20320
+28 ; Added check to MERGECK to see if manually added insurer; if so,
+29 ; don't delete
+30 ;
+31 ;IHS/SD/SDR - 2.6*21 - HEAT137034 - Fixed code for DISPLAY UNBILLABLE INSURER site parameter. The check wasn't being
+32 ; done correctly so unbillable insurers were displaying all the time instead of when specified by parameter.
+33 ;IHS/SD/SDR - 2.6*21 - VMBP - RQMT_90 - Added code for 'V' insurer type.
+34 ;
+35 ; *********************************************************************
+36 ;
+37 SET ABMP("VDT")=$PIECE(ABMP("C0"),U,2)
+38 SET ABMP("CLN")=$PIECE(ABMP("C0"),U,6)
+39 SET DFN=ABMP("PDFN")
+40 SET ABMVDT=ABMP("VDT")
+41 SET I=0
+42 FOR
SET I=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),11,"AC","P",I))
IF 'I
QUIT
Begin DoDot:1
+43 IF $PIECE($GET(^AUPNVSIT(I,0)),"^",11)
QUIT
+44 SET ABMVDFN=I
End DoDot:1
+45 IF '$GET(ABMVDFN)
SET ABMVDFN=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),11,0))
+46 DO ELG^ABMDLCK(ABMVDFN,.ABML,DFN,ABMVDT)
+47 DO MERGECK
+48 ;
ENT ;EP - Entry Point to update Elig Info
+1 SET ABM("PRI")=""
+2 FOR
SET ABM("PRI")=$ORDER(ABML(ABM("PRI")))
IF 'ABM("PRI")
QUIT
DO INS
+3 ;
HITCHK ;HIT CHECK
+1 NEW I
+2 ;start old code abm*2.6*8
+3 ;S I=0
+4 ;F S I=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I)) Q:'I D
+5 ;.I '$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U) D Q
+6 ;..K ^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0)
+7 ;.S ABM("INS")=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U)
+8 ;.S ABM("ITYPE")=$P($G(^AUTNINS(ABM("INS"),2)),U)
+9 ;.I ABM("ITYPE")="D"!(ABM("ITYPE")="K") D DCFX^ABMDEFIP(ABMP("CDFN"),I)
+10 ;.D HITCHK2
+11 ;end old code start new code
+12 NEW K
+13 SET K=0
+14 FOR
SET K=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",K))
IF 'K
QUIT
Begin DoDot:1
+15 SET I=0
+16 FOR
SET I=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",K,I))
IF 'I
QUIT
Begin DoDot:2
+17 IF '$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U)
Begin DoDot:3
+18 KILL ^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0)
End DoDot:3
QUIT
+19 SET ABM("INS")=$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U)
+20 ;S ABM("ITYPE")=$P($G(^AUTNINS(ABM("INS"),2)),U) ;abm*2.6*10 HEAT73780
+21 ;abm*2.6*10 HEAT73780
SET ABM("ITYPE")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABM("INS"),".211","I"),1,"I")
+22 IF ABM("ITYPE")="D"!(ABM("ITYPE")="K")
DO DCFX^ABMDEFIP(ABMP("CDFN"),I)
+23 DO HITCHK2
End DoDot:2
End DoDot:1
+24 ;end new code
+25 GOTO PRIM
+26 ;
+27 ; *********************************************************************
HITCHK2 ;
+1 KILL ABM("HIT")
+2 SET ABM("PRI")=""
+3 FOR
SET ABM("PRI")=$ORDER(ABML(ABM("PRI")))
IF 'ABM("PRI")
QUIT
DO HITCHK3
+4 IF $DATA(ABM("HIT"))
QUIT
+5 ;No editing from inq
IF $GET(ABMP("DERP OPT"))
QUIT
+6 IF $PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),9)),U)'="Y"
Begin DoDot:1
+7 IF '$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),8)),U,3)
Begin DoDot:2
+8 IF "FPUI"[$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U,3)
IF $PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0)),U,9)!($PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,4)="F")
Begin DoDot:3
+9 SET DA=I
+10 DO KILL
End DoDot:3
+11 ;I ABM("INS")'=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8) D ;abm*2.6*8
+12 ;abm*2.6*8
IF ABM("INS")=$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8)
IF ($PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U,3)="U")
Begin DoDot:3
+13 SET DA=ABMP("CDFN")
+14 SET DIE="^ABMDCLM(DUZ(2),"
+15 SET DR=".08///@"
+16 DO ^DIE
+17 KILL DR
End DoDot:3
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
+20 ; *********************************************************************
HITCHK3 ;
+1 SET ABM("FINS")=""
+2 FOR
SET ABM("FINS")=$ORDER(ABML(ABM("PRI"),ABM("FINS")))
IF 'ABM("FINS")
QUIT
Begin DoDot:1
+3 IF ABM("FINS")=ABM("INS")
SET ABM("HIT")=""
End DoDot:1
+4 QUIT
+5 ;
+6 ; *********************************************************************
INS ;
+1 SET ABM("INS")=""
+2 FOR
SET ABM("INS")=$ORDER(ABML(ABM("PRI"),ABM("INS")))
IF 'ABM("INS")
QUIT
DO ADDCHK
+3 QUIT
+4 ;
MERGECK ;mark entries unbillable that aren't in eligibility array
+1 ;quit if billed/complete
IF ("CU"[$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),0)),U,4))
QUIT
+2 SET ABMIIEN=0
+3 FOR
SET ABMIIEN=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABMIIEN))
IF +ABMIIEN=0
QUIT
Begin DoDot:1
+4 SET ABMPRI=0
SET ABMMATCH=0
+5 FOR
SET ABMPRI=$ORDER(ABML(ABMPRI))
IF +ABMPRI=0
QUIT
Begin DoDot:2
+6 IF $ORDER(ABML(ABMPRI,0))=ABMIIEN
SET ABMMATCH=1
End DoDot:2
+7 IF ABMMATCH'=1
Begin DoDot:2
+8 ;start old code abm*2.6*8 HEAT37612
+9 ;S DA(1)=ABMP("CDFN")
+10 ;S DA=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABMIIEN,0))
+11 ;Q:$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,DA,0)),U,9)="Y"
+12 ;S DIK="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
+13 ;D ^DIK
+14 ;end old code start new code HEAT37612
+15 SET DA(1)=ABMP("CDFN")
+16 SET DA=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABMIIEN,0))
+17 IF $PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,DA,0)),U,9)="Y"
QUIT
+18 IF $PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,DA,0)),U,3)="C"
QUIT
+19 SET DIE="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
+20 ;set status to unbillable if not returned in elig array
SET DR=".03////U"
+21 DO ^DIE
+22 ;end new code HEAT37612
End DoDot:2
End DoDot:1
+23 QUIT
+24 ; *********************************************************************
ADDCHK ; EP
+1 ;abm*2.6*21 IHS/SD/SDR HEAT137034
IF (ABM("PRI")>96)&'$DATA(^ABMDPARM(DUZ(2),1,6,ABM("INS")))&(+$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABM("INS"),0))=0)
QUIT
+2 IF '$DATA(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABM("INS")))
Begin DoDot:1
+3 ;I ABM("PRI")>96,'$D(^ABMDPARM(DUZ(2),1,6,ABM("INS"))) Q ;abm*2.6*21 IHS/SD/SDR HEAT137034
+4 DO ADD
+5 DO COVCHK
End DoDot:1
QUIT
+6 IF $PIECE(ABML(ABM("PRI"),ABM("INS")),"^",3)="P"
Begin DoDot:1
+7 NEW I
+8 SET I=0
+9 SET ABM("ADD")=1
+10 FOR
SET I=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I))
IF 'I
QUIT
Begin DoDot:2
+11 IF $PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),U)'=ABM("INS")
QUIT
+12 IF $PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,I,0),"^",8)=$PIECE(ABML(ABM("PRI"),ABM("INS")),"^",2)
KILL ABM("ADD")
End DoDot:2
End DoDot:1
+13 ;I $G(ABM("ADD")),ABM("PRI")<97 D Q ;abm*2.6*21 IHS/SD/SDR HEAT137034
+14 ;if priority is <97 or if priority is greater than 96 and display unbillable insurer ;abm*2.6*21 IHS/SD/SDR HEAT137034
IF $GET(ABM("ADD"))&((ABM("PRI")<97)!((ABM("PRI")>96)&($DATA(^ABMDPARM(DUZ(2),1,6,ABM("INS"))))))
Begin DoDot:1
+15 DO ADD
+16 DO COVCHK
End DoDot:1
QUIT
+17 SET DA(1)=ABMP("CDFN")
+18 SET DIE="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
+19 IF '$GET(ADD)
IF $PIECE(ABML(ABM("PRI"),ABM("INS")),U,3)="P"
Begin DoDot:1
+20 SET DA=0
+21 FOR
SET DA=$ORDER(^ABMDCLM(DUZ(2),DA(1),13,"B",ABM("INS"),DA))
IF '+DA
QUIT
Begin DoDot:2
+22 IF $PIECE(^ABMDCLM(DUZ(2),DA(1),13,DA,0),U,8)'=$PIECE(ABML(ABM("PRI"),ABM("INS")),U,2)
QUIT
+23 DO UPDATE
End DoDot:2
End DoDot:1
QUIT
+24 SET DA=$ORDER(^ABMDCLM(DUZ(2),DA(1),13,"B",ABM("INS"),0))
+25 IF '+DA
QUIT
+26 DO UPDATE
+27 QUIT
+28 ;
+29 ; *********************************************************************
UPDATE ;
+1 KILL ^ABMDCLM(DUZ(2),DA(1),13,DA,11)
+2 IF $PIECE(^ABMDCLM(DUZ(2),DA(1),13,DA,0),U,3)="U"
IF ABM("PRI")<97
Begin DoDot:1
+3 SET DR=".03////P"
+4 DO ^DIE
End DoDot:1
GOTO COVCHK
+5 IF "IP"[$PIECE(^ABMDCLM(DUZ(2),DA(1),13,DA,0),U,3)
IF ABM("PRI")>96
Begin DoDot:1
+6 SET DR=".03////U"
+7 DO ^DIE
End DoDot:1
+8 ;
COVCHK ;
+1 SET ABM("C")=""
+2 FOR
SET ABM("C")=$ORDER(ABML(ABM("PRI"),ABM("INS"),"COV",ABM("C")))
IF 'ABM("C")
QUIT
Begin DoDot:1
+3 IF '$DATA(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,DA,11,ABM("C"),0))
DO ADDCOV
End DoDot:1
+4 QUIT
+5 ;
+6 ; *********************************************************************
ADD ;EP - Entry Pont for adding Elig Info to Claim
+1 KILL DIC
+2 SET (ABM("L"),ABML("I"))=0
+3 FOR
SET ABML("I")=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABML("I")))
IF 'ABML("I")
QUIT
IF $PIECE(^(ABML("I"),0),U,2)>ABM("L")
SET ABM("L")=$PIECE(^(0),U,2)
+4 KILL ABML("I")
+5 SET ABM("L")=ABM("L")+1
+6 SET DA(1)=ABMP("CDFN")
+7 SET DIC="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
+8 SET DIC(0)="LE"
+9 SET DIC("P")=$PIECE(^DD(9002274.3,13,0),U,2)
+10 IF ABM("L")=1
IF '$DATA(ABML(97))
SET ABM("STATUS")="I"
+11 IF '$TEST
SET ABM("STATUS")="P"
+12 IF ABM("PRI")>96
SET ABM("STATUS")="U"
+13 SET X=ABM("INS")
+14 SET DIC("DR")=".02///"_ABM("L")_";.03///"_ABM("STATUS")
+15 IF $PIECE(ABML(ABM("PRI"),ABM("INS")),U,3)?1(1"P",1"A",1"W")
Begin DoDot:1
+16 SET DIC("DR")=DIC("DR")_";.08////"_$PIECE(ABML(ABM("PRI"),ABM("INS")),U,2)
End DoDot:1
+17 IF $PIECE(ABML(ABM("PRI"),ABM("INS")),U,3)="M"
Begin DoDot:1
+18 SET DIC("DR")=DIC("DR")_";.04////"_$PIECE(ABML(ABM("PRI"),ABM("INS")),U,2)
End DoDot:1
+19 IF $PIECE(ABML(ABM("PRI"),ABM("INS")),U,3)="R"
Begin DoDot:1
+20 SET DIC("DR")=DIC("DR")_";.05////"_$PIECE(ABML(ABM("PRI"),ABM("INS")),U,2)
End DoDot:1
+21 IF $PIECE(ABML(ABM("PRI"),ABM("INS")),U,3)="D"
Begin DoDot:1
+22 SET DIC("DR")=DIC("DR")_";.06////"_$PIECE(ABML(ABM("PRI"),ABM("INS")),U,1)
+23 SET DIC("DR")=DIC("DR")_";.07////"_$PIECE(ABML(ABM("PRI"),ABM("INS")),U,2)
End DoDot:1
+24 IF $PIECE(ABML(ABM("PRI"),ABM("INS")),U,7)="M"
Begin DoDot:1
+25 SET DIC("DR")=DIC("DR")_";.09////Y"
End DoDot:1
+26 ;start new abm*2.6*21 IHS/SD/SDR VMBP RQMT_90
+27 IF $PIECE(ABML(ABM("PRI"),ABM("INS")),U,3)="V"
Begin DoDot:1
+28 SET DIC("DR")=DIC("DR")_";.013////"_$PIECE(ABML(ABM("PRI"),ABM("INS")),U,2)
End DoDot:1
+29 ;end new abm*2.6*21 IHS/SD/SDR VMBP RQMT_90
+30 KILL DD,DO
+31 DO FILE^DICN
+32 SET (DA,ABM("XIEN"))=+Y
+33 KILL DIC
+34 QUIT
+35 ;
+36 ; *********************************************************************
ADDCOV ; EP for adding Coverage Types
+1 IF ABM("C")]""
IF $DATA(^AUTTPIC(ABM("C"),0))
IF $PIECE(^(0),U,2)=ABM("INS")
+2 IF '$TEST
QUIT
+3 KILL DIC
+4 SET DA(1)=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABM("INS"),0))
+5 SET DA(2)=ABMP("CDFN")
+6 SET DIC="^ABMDCLM(DUZ(2),"_DA(2)_",13,"_DA(1)_",11,"
+7 SET DIC(0)="LE"
+8 SET DIC("P")=$PIECE(^DD(9002274.3013,11,0),U,2)
+9 KILL DD,DO,DR,DIC("DR")
+10 SET (X,DINUM)=ABM("C")
+11 KILL DD,DO
+12 DO FILE^DICN
+13 KILL DIC
+14 QUIT
+15 ;
+16 ; *********************************************************************
KILL ;
+1 SET DA(1)=ABMP("CDFN")
+2 SET DIK="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
+3 DO ^DIK
+4 IF $PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8)=ABM("INS")
Begin DoDot:1
+5 SET DA=ABMP("CDFN")
+6 SET DIE="^ABMDCLM(DUZ(2),"
+7 SET DR=".08///@"
+8 DO ^DIE
+9 KILL DR
End DoDot:1
+10 QUIT
+11 ;
+12 ; *********************************************************************
PRIM ; Changed code under this line tag for readability in addition to those
+1 ; changes documented.
+2 ;
+3 SET ABMYES=0
+4 SET ABMP("INS")=""
+5 SET ABM("DR")=""
+6 FOR
SET ABM("DR")=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",ABM("DR")))
IF 'ABM("DR")
QUIT
Begin DoDot:1
+7 SET ABM("DA")=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",ABM("DR"),""))
+8 IF ABM("DA")=""
QUIT
+9 IF '$DATA(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABM("DA"),0))
QUIT
+10 KILL ABM("DRI")
+11 SET ABM("I0")=$GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABM("DA"),0))
+12 IF "UCB"[$PIECE(ABM("I0"),U,3)
QUIT
+13 SET ABM("INSCO")=$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABM("DA"),0),U)
+14 IF +ABMYES
IF $PIECE(ABM("I0"),U,3)="I"
SET ABM("DRI")=".03////P"
+15 IF '+ABMYES
Begin DoDot:2
+16 IF $PIECE(ABM("I0"),U,3)'="I"
Begin DoDot:3
+17 SET ABM("DRI")=".03////I"
End DoDot:3
+18 SET ABMYES=1
+19 IF $PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8)'=ABM("INSCO")
Begin DoDot:3
+20 SET ABMINSCK=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",ABM("INSCO"),0))
+21 ;replacement insurer?
+22 IF $PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8)=$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,ABMINSCK,0)),U,11)
QUIT
+23 SET DIE="^ABMDCLM(DUZ(2),"
+24 SET DA=ABMP("CDFN")
+25 SET DR=".08////^S X=ABM(""INSCO"")"
+26 DO ^DIE
+27 KILL DR
End DoDot:3
End DoDot:2
+28 IF $DATA(ABM("DRI"))
Begin DoDot:2
+29 SET DA(1)=ABMP("CDFN")
+30 SET DA=ABM("DA")
+31 SET DR=ABM("DRI")
+32 SET DIE="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
+33 DO ^DIE
+34 KILL DR
End DoDot:2
End DoDot:1
IF 'ABM("DR")
QUIT
+35 SET ABMP("C0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),0)
+36 IF $PIECE(ABMP("C0"),U,8)=""
SET ABME(111)=""
GOTO XIT
+37 SET ABMP("INS")=$PIECE(ABMP("C0"),U,8)
+38 SET ABMTEXP=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,4)
+39 IF ABMTEXP=""
QUIT
+40 SET ABMP("EXP")=ABMTEXP
+41 SET DIE="^ABMDCLM(DUZ(2),"
+42 SET DA=ABMP("CDFN")
+43 SET DR=".14////"_ABMP("EXP")
+44 DO ^DIE
+45 KILL DR
+46 ;
XIT ;
+1 KILL ABML
+2 QUIT
