ABME5L2.m

ABME5L2 ; IHS/ASDST/DMJ - Header 

 ;;2.6;IHS Third Party Billing System;**6,8,9,10,21,27**;NOV 12, 2009;Build 486

 ;Header Segments

 ;IHS/SD/SDR 2.6*21 HEAT172519 - Added MEDICAID FQHC and CD MEDICAID to WASHINGTON MEDICAID check

 ;IHS/SD/SDR 2.6*21 HEAT236026 - Added Dental Medicaid FQHC to check 2000A PRV segment

 ;IHS/SD/SDR 2.6*27 CR9867 For PRV segment removed hardcoding for specific insurers and added check for new parameter instead

 ;

START ;START HERE

 K ABMHLCNT

 S ABMLOOP="2000A"

 D EP^ABME5HL(20,1)

 D WR^ABMUTL8("HL")

 ;I ABMP("EXP")=31!((ABMRCID="NMMAD")&(ABMP("EXP")=32))!((ABMP("EXP")=32)&(ABMP("VTYP")=831)) D  ;abm*2.6*8 HEAT49305

 ;I ABMP("EXP")=31!((ABMRCID="NMMAD")&(ABMP("EXP")=32))!((ABMP("EXP")=32)&(ABMP("VTYP")=831))!($P($G(^AUTNINS(ABMP("INS"),0)),U)["WASHINGTON MEDICAID")!(ABMP("EXP")=33) D  ;abm*2.6*8 HEAT49305  ;abm*2.6*9 HEAT57952

 ;I ABMP("EXP")=31!((ABMRCID="NMMAD")&(ABMP("EXP")=32))!((ABMP("EXP")=32)&(ABMP("VTYP")=831))!($P($G(^AUTNINS(ABMP("INS"),0)),U)["WASHINGTON MEDICAID") D  ;abm*2.6*8 HEAT49305  ;abm*2.6*9 HEAT57952  ;abm*2.6*21 IHS/SD/SDR HEAT172519

 ;I ABMP("EXP")=31!((ABMRCID="NMMAD")&(ABMP("EXP")=32))!((ABMP("EXP")=32)&(ABMP("VTYP")=831))!("^WASHINGTON MEDICAID^MEDICAID FQHC^CD MEDICAID^"[("^"_($P($G(^AUTNINS(ABMP("INS"),0)),U)_"^"))) D  ;abm*2.6*9 HEAT57952  ;abm*2.6*21 IHS/SD/SDR HEAT172519  ;abm*2.6*21 IHS/SD/SDR HEAT236026

 ;start old abm*2.6*27 IHS/SD/AML CR9867

 ;;start new abm*2.6*21 IHS/SD/SDR HEAT172519, HEAT236026, HEAT206174

 ;S ABMDFLG=0

 ;I ABMP("EXP")=31!((ABMRCID="NMMAD")&(ABMP("EXP")=32))!((ABMP("EXP")=32)&(ABMP("VTYP")=831)) S ABMDFLG=1

 ;I ("^WASHINGTON MEDICAID^MEDICAID FQHC^CD MEDICAID^WISCONSIN MEDICAID^"[("^"_($P($G(^AUTNINS(ABMP("INS"),0)),U)_"^"))) S ABMDFLG=1

 ;I (ABMP("EXP")=33&($P($G(^AUTNINS(ABMP("INS"),0)),U)="WA MEDICAID DENTAL")) S ABMDFLG=1

 ;I ABMDFLG=1 D

 ;.D EP^ABME5PRV("BI",DUZ(2))

 ;.D WR^ABMUTL8("PRV")

 ;.;end new abm*2.6*21 IHS/SD/SDR HEAT172519, HEAT236026, HEAT206174

 ;end old start new abm*2.6*27 IHS/SD/AML CR9867

 D EP^ABME5PRV("BI",ABMP("LDFN"))

 I $P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,23)'=""  D

 .D WR^ABMUTL8("PRV")

 ;end new abm*2.6*27 IHS/SD/AML CR9867

 S ABMP("PAYDFN")=$P($G(^ABMDPARM(DUZ(2),1,2)),U,3)

 S ABMLOOP="2010AA"

 D EP^ABME5NM1(85)

 D WR^ABMUTL8("NM1")

 D EP^ABME5N3(4,DUZ(2))

 D WR^ABMUTL8("N3")

 D EP^ABME5N4(4,DUZ(2))

 D WR^ABMUTL8("N4")

 D EP^ABME5REF("EI",9999999.06,DUZ(2))

 D WR^ABMUTL8("REF")

 S ABMNPIU=$$NPIUSAGE^ABMUTLF(DUZ(2),ABMP("INS"))

 ;start new code abm*2.6*10 HEAT46645 IHS/SD/AML 6/1/12

 I ABMNPIU=""!(ABMNPIU="L")!(ABMNPIU="B") D

 .D EP^ABME5REF("0B",9999999.06,DUZ(2))

 .D WR^ABMUTL8("REF")

 ;end new code abm*2.6*10 HEAT46645 IHS/SD/AML 6/1/12

 K ABMIDCD

 I ABMP("PAYDFN")'=DUZ(2) D

 .;Q:$P($G(^AUTNINS(ABMP("INS"),2)),U)="D"&($P($G(^AUTNINS(ABMP("INS"),0)),U)["OK")  ;abm*2.6*10 HEAT73780

 .Q:$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")="D"&($P($G(^AUTNINS(ABMP("INS"),0)),U)["OK")  ;abm*2.6*10 HEAT73780

 .S ABMLOOP="2010AB"

 .D EP^ABME5NM1(87)

 .D WR^ABMUTL8("NM1")

 .D EP^ABME5N3(9999999.06,ABMP("PAYDFN"))

 .D WR^ABMUTL8("N3")

 .D EP^ABME5N4(9999999.06,ABMP("PAYDFN"))

 .D WR^ABMUTL8("N4")

 .K ABMIDCD

 .K ABMLOOP

 Q

PIREFID ;EP - Find EMC Ref ID for Private Ins.

 S:ABMP("ITYPE")="H" ABMIDCD="BQ"

 S:ABMP("ITYPE")="C" ABMIDCD="1H"

 I "M^P^W^F"[ABMP("ITYPE") S ABMIDCD="G2"

 I ABMIDCD="G2",ABMP("ITYPE")'="M" D

 .I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U)]"" D

 ..S ABMIDCD=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U)

 ..S ABMIDCD=$P($G(^ABMREFID(ABMIDCD,0)),U)

 ..S:ABMIDCD="" ABMIDCD="G2"

 Q

ABME5L2   ; IHS/ASDST/DMJ - Header 

 +1       ;;2.6;IHS Third Party Billing System;**6,8,9,10,21,27**;NOV 12, 2009;Build 486

 +2       ;Header Segments

 +3       ;IHS/SD/SDR 2.6*21 HEAT172519 - Added MEDICAID FQHC and CD MEDICAID to WASHINGTON MEDICAID check

 +4       ;IHS/SD/SDR 2.6*21 HEAT236026 - Added Dental Medicaid FQHC to check 2000A PRV segment

 +5       ;IHS/SD/SDR 2.6*27 CR9867 For PRV segment removed hardcoding for specific insurers and added check for new parameter instead

 +6       ;

START     ;START HERE

 +1        KILL ABMHLCNT

 +2        SET ABMLOOP="2000A"

 +3        DO EP^ABME5HL(20,1)

 +4        DO WR^ABMUTL8("HL")

 +5       ;I ABMP("EXP")=31!((ABMRCID="NMMAD")&(ABMP("EXP")=32))!((ABMP("EXP")=32)&(ABMP("VTYP")=831)) D  ;abm*2.6*8 HEAT49305

 +6       ;I ABMP("EXP")=31!((ABMRCID="NMMAD")&(ABMP("EXP")=32))!((ABMP("EXP")=32)&(ABMP("VTYP")=831))!($P($G(^AUTNINS(ABMP("INS"),0)),U)["WASHINGTON MEDICAID")!(ABMP("EXP")=33) D  ;abm*2.6*8 HEAT49305  ;abm*2.6*9 HEAT57952

 +7       ;I ABMP("EXP")=31!((ABMRCID="NMMAD")&(ABMP("EXP")=32))!((ABMP("EXP")=32)&(ABMP("VTYP")=831))!($P($G(^AUTNINS(ABMP("INS"),0)),U)["WASHINGTON MEDICAID") D  ;abm*2.6*8 HEAT49305  ;abm*2.6*9 HEAT57952  ;abm*2.6*21 IHS/SD/SDR HEAT172519

 +8       ;I ABMP("EXP")=31!((ABMRCID="NMMAD")&(ABMP("EXP")=32))!((ABMP("EXP")=32)&(ABMP("VTYP")=831))!("^WASHINGTON MEDICAID^MEDICAID FQHC^CD MEDICAID^"[("^"_($P($G(^AUTNINS(ABMP("INS"),0)),U)_"^"))) D  ;abm*2.6*9 HEAT57952  ;abm*2.6*21 IHS/SD/SDR HEAT17

2519  ;abm*2.6*21 IHS/SD/SDR HEAT236026

 +9       ;start old abm*2.6*27 IHS/SD/AML CR9867

 +10      ;;start new abm*2.6*21 IHS/SD/SDR HEAT172519, HEAT236026, HEAT206174

 +11      ;S ABMDFLG=0

 +12      ;I ABMP("EXP")=31!((ABMRCID="NMMAD")&(ABMP("EXP")=32))!((ABMP("EXP")=32)&(ABMP("VTYP")=831)) S ABMDFLG=1

 +13      ;I ("^WASHINGTON MEDICAID^MEDICAID FQHC^CD MEDICAID^WISCONSIN MEDICAID^"[("^"_($P($G(^AUTNINS(ABMP("INS"),0)),U)_"^"))) S ABMDFLG=1

 +14      ;I (ABMP("EXP")=33&($P($G(^AUTNINS(ABMP("INS"),0)),U)="WA MEDICAID DENTAL")) S ABMDFLG=1

 +15      ;I ABMDFLG=1 D

 +16      ;.D EP^ABME5PRV("BI",DUZ(2))

 +17      ;.D WR^ABMUTL8("PRV")

 +18      ;.;end new abm*2.6*21 IHS/SD/SDR HEAT172519, HEAT236026, HEAT206174

 +19      ;end old start new abm*2.6*27 IHS/SD/AML CR9867

 +20       DO EP^ABME5PRV("BI",ABMP("LDFN"))

 +21       IF $PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,23)'=""

               Begin DoDot:1

 +22               DO WR^ABMUTL8("PRV")

               End DoDot:1

 +23      ;end new abm*2.6*27 IHS/SD/AML CR9867

 +24       SET ABMP("PAYDFN")=$PIECE($GET(^ABMDPARM(DUZ(2),1,2)),U,3)

 +25       SET ABMLOOP="2010AA"

 +26       DO EP^ABME5NM1(85)

 +27       DO WR^ABMUTL8("NM1")

 +28       DO EP^ABME5N3(4,DUZ(2))

 +29       DO WR^ABMUTL8("N3")

 +30       DO EP^ABME5N4(4,DUZ(2))

 +31       DO WR^ABMUTL8("N4")

 +32       DO EP^ABME5REF("EI",9999999.06,DUZ(2))

 +33       DO WR^ABMUTL8("REF")

 +34       SET ABMNPIU=$$NPIUSAGE^ABMUTLF(DUZ(2),ABMP("INS"))

 +35      ;start new code abm*2.6*10 HEAT46645 IHS/SD/AML 6/1/12

 +36       IF ABMNPIU=""!(ABMNPIU="L")!(ABMNPIU="B")

               Begin DoDot:1

 +37               DO EP^ABME5REF("0B",9999999.06,DUZ(2))

 +38               DO WR^ABMUTL8("REF")

               End DoDot:1

 +39      ;end new code abm*2.6*10 HEAT46645 IHS/SD/AML 6/1/12

 +40       KILL ABMIDCD

 +41       IF ABMP("PAYDFN")'=DUZ(2)

               Begin DoDot:1

 +42      ;Q:$P($G(^AUTNINS(ABMP("INS"),2)),U)="D"&($P($G(^AUTNINS(ABMP("INS"),0)),U)["OK")  ;abm*2.6*10 HEAT73780

 +43      ;abm*2.6*10 HEAT73780

                   IF $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")="D"&($PIECE($GET(^AUTNINS(ABMP("INS"),0)),U)["OK")

                       QUIT 

 +44               SET ABMLOOP="2010AB"

 +45               DO EP^ABME5NM1(87)

 +46               DO WR^ABMUTL8("NM1")

 +47               DO EP^ABME5N3(9999999.06,ABMP("PAYDFN"))

 +48               DO WR^ABMUTL8("N3")

 +49               DO EP^ABME5N4(9999999.06,ABMP("PAYDFN"))

 +50               DO WR^ABMUTL8("N4")

 +51               KILL ABMIDCD

 +52               KILL ABMLOOP

               End DoDot:1

 +53       QUIT 

PIREFID   ;EP - Find EMC Ref ID for Private Ins.

 +1        IF ABMP("ITYPE")="H"

               SET ABMIDCD="BQ"

 +2        IF ABMP("ITYPE")="C"

               SET ABMIDCD="1H"

 +3        IF "M^P^W^F"[ABMP("ITYPE")

               SET ABMIDCD="G2"

 +4        IF ABMIDCD="G2"

               IF ABMP("ITYPE")'="M"

                   Begin DoDot:1

 +5                    IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U)]""

                           Begin DoDot:2

 +6                            SET ABMIDCD=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U)

 +7                            SET ABMIDCD=$PIECE($GET(^ABMREFID(ABMIDCD,0)),U)

 +8                            IF ABMIDCD=""

                                   SET ABMIDCD="G2"

                           End DoDot:2

                   End DoDot:1

 +9        QUIT