- 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