ABME5L16.m

ABME5L16 ; IHS/ASDST/DMJ - Header 

 ;;2.6;IHS Third Party Billing System;**6,9,10,11**;NOV 12, 2009;Build 133

 ;Header Segments

 ;

START ;START HERE

 S ABMLOOP=2320

 D PAYED^ABMUTLP

 N ABMI

 S ABMI=0

 F  S ABMI=$O(ABMP("INS",ABMI)) Q:'ABMI  D

 .S ABMLINE=ABMP("INS",ABMI)

 .I $P(ABMLINE,U)=ABMP("INS")!($P(ABMLINE,"^",11)=ABMP("INS")),$P(ABMLINE,"^",3)="I" Q

 .D EP^ABME5SBR(ABMI)

 .D WR^ABMUTL8("SBR")

 .F ABML="OA","PR","CO" D

 ..Q:'$D(ABMP(+ABMLINE,ABML))  ;quit if no data for insurer in ABMP adj array

 ..D EP^ABME5CAS

 ..D WR^ABMUTL8("CAS")

 .;start old code abm*2.6*9 NOHEAT

 .;printing AMT twice

 .;I $G(ABMP("PAYED",+ABMLINE)) D

 .;.D EP^ABME5AMT("D")

 .;.D WR^ABMUTL8("AMT")

 .;end old code

 .I ($G(ABMP("PAYED",+ABMLINE))!($P($G(^ABMNINS(ABMP("LDFN"),+ABMLINE,0)),U,11)="Y")) D

 ..D EP^ABME5AMT("D")

 ..D WR^ABMUTL8("AMT")

 .;start new code abm*2.6*10 COB billing

 .;I ABMPSQ'=1,$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMP("INS"),".211","I"),1,"I")="R" D

 ..S ABMAMT=0

 ..D EP^ABME5AMT("B6")

 ..D WR^ABMUTL8("AMT")

 ..;end new code abm*2.6*10 COB billing

 .D ^ABME5OI

 .D WR^ABMUTL8("OI")

 .;

 .S ABMLOOP="2330A"

 .I $G(ABMSBR(ABMI)) D

 ..S ABMSFILE=$P(ABMSBR(ABMI),"-",1)

 ..S ABMSIEN=$P(ABMSBR(ABMI),"-",2)

 .D EP^ABME5NM1("IL")

 .D WR^ABMUTL8("NM1")

 .D EP^ABME5N3(ABMSFILE,ABMSIEN)

 .D WR^ABMUTL8("N3")

 .D EP^ABME5N4(ABMSFILE,ABMSIEN)

 .D WR^ABMUTL8("N4")

 .;

 .S ABMLOOP="2330B"

 .D EP^ABME5NM1("PR",+ABMLINE)

 .D WR^ABMUTL8("NM1")

 .D EP^ABME5N3(9999999.18,+ABMLINE)

 .D WR^ABMUTL8("N3")

 .D EP^ABME5N4(9999999.18,+ABMLINE)

 .D WR^ABMUTL8("N4")

 .I $G(ABMP("PAYED",+ABMLINE))'="" D

 ..;S ABMPDT=$S($P($G(ABMP("PAYED",+ABMLINE)),U,2)'="":$P(ABMP("PAYED",+ABMLINE),U,2),$G(ABMP("PDT",+ABMLINE))'="":ABMP("PDT",+ABMLINE),1:"")  ;abm*2.6*10 COB billing

 ..S ABMPDT=$S($P($G(ABMP("PAYED",+ABMLINE)),U,2)'="":$P(ABMP("PAYED",+ABMLINE),U,2),$G(ABMP("PDT",+ABMLINE))'="":ABMP("PDT",+ABMLINE),1:DT)  ;abm*2.6*10 COB billing

 ..D EP^ABME5DTP(573,"D8",ABMPDT)

 ..D WR^ABMUTL8("DTP")

 ..K ABMPDT

 .;D OTHR  ;abm*2.6*9 HEAT58542

 Q

OTHR ;other payer info

 ;loops 2330C through 2330G

 N J

 F J=1:1:4 D

 .S ABMPTYP=$E("FRPS",J)

 .Q:($G(ABMP("CLIN"))="A3")&(J="R")

 .S ABMPROV=$O(ABMP("PRV",ABMPTYP,0))

 .I ABMPROV D

 ..S ABMPNBR=$$NPI^ABMEEPRV(ABMPROV,ABMP("LDFN"),+ABMLINE)

 ..Q:ABMPNBR=""

 ..D EP^ABME5NM2($P("DN^82^QB^DQ","^",J))

 ..D WR^ABMUTL8("NM1")

 ..S ABMITYP=$P(ABMLINE,"^",2)

 ..S ABMP("RTYPE")=$S(ABMITYP="R":"1G",ABMITYP="D":"1D",$P($G(^ABMNINS(ABMDUZ2,ABMP("INS"),1,ABMP("VTYP"),1)),U)'="":$P($G(^ABMREFID($P($G(^ABMNINS(ABMDUZ2,ABMP("INS"),1,ABMP("VTYP"),1)),U),0)),U),1:"0B")

 ..;I ABMP("EXP")=32,ABMP("RTYPE")="1G" S ABMP("RTYPE")="1C"

 ..;D EP^ABME5RF2(ABMP("RTYPE"))

 ..;I ABMNPIU="B"!(ABMNPIU="N") D

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

 ..;D WR^ABMUTL8("REF")

 Q

ABME5L16  ; IHS/ASDST/DMJ - Header 

 +1       ;;2.6;IHS Third Party Billing System;**6,9,10,11**;NOV 12, 2009;Build 133

 +2       ;Header Segments

 +3       ;

START     ;START HERE

 +1        SET ABMLOOP=2320

 +2        DO PAYED^ABMUTLP

 +3        NEW ABMI

 +4        SET ABMI=0

 +5        FOR 

               SET ABMI=$ORDER(ABMP("INS",ABMI))

               IF 'ABMI

                   QUIT 

               Begin DoDot:1

 +6                SET ABMLINE=ABMP("INS",ABMI)

 +7                IF $PIECE(ABMLINE,U)=ABMP("INS")!($PIECE(ABMLINE,"^",11)=ABMP("INS"))

                       IF $PIECE(ABMLINE,"^",3)="I"

                           QUIT 

 +8                DO EP^ABME5SBR(ABMI)

 +9                DO WR^ABMUTL8("SBR")

 +10               FOR ABML="OA","PR","CO"

                       Begin DoDot:2

 +11      ;quit if no data for insurer in ABMP adj array

                           IF '$DATA(ABMP(+ABMLINE,ABML))

                               QUIT 

 +12                       DO EP^ABME5CAS

 +13                       DO WR^ABMUTL8("CAS")

                       End DoDot:2

 +14      ;start old code abm*2.6*9 NOHEAT

 +15      ;printing AMT twice

 +16      ;I $G(ABMP("PAYED",+ABMLINE)) D

 +17      ;.D EP^ABME5AMT("D")

 +18      ;.D WR^ABMUTL8("AMT")

 +19      ;end old code

 +20               IF ($GET(ABMP("PAYED",+ABMLINE))!($PIECE($GET(^ABMNINS(ABMP("LDFN"),+ABMLINE,0)),U,11)="Y"))

                       Begin DoDot:2

 +21                       DO EP^ABME5AMT("D")

 +22                       DO WR^ABMUTL8("AMT")

                       End DoDot:2

 +23      ;start new code abm*2.6*10 COB billing

 +24      ;I ABMPSQ'=1,$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,+ABMP("INS"),".211","I"),1,"I")="R" D

 +25               SET ABMAMT=0

 +26               DO EP^ABME5AMT("B6")

 +27               DO WR^ABMUTL8("AMT")

 +28      ;end new code abm*2.6*10 COB billing

 +29               DO ^ABME5OI

 +30               DO WR^ABMUTL8("OI")

 +31      ;

 +32               SET ABMLOOP="2330A"

 +33               IF $GET(ABMSBR(ABMI))

                       Begin DoDot:2

 +34                       SET ABMSFILE=$PIECE(ABMSBR(ABMI),"-",1)

 +35                       SET ABMSIEN=$PIECE(ABMSBR(ABMI),"-",2)

                       End DoDot:2

 +36               DO EP^ABME5NM1("IL")

 +37               DO WR^ABMUTL8("NM1")

 +38               DO EP^ABME5N3(ABMSFILE,ABMSIEN)

 +39               DO WR^ABMUTL8("N3")

 +40               DO EP^ABME5N4(ABMSFILE,ABMSIEN)

 +41               DO WR^ABMUTL8("N4")

 +42      ;

 +43               SET ABMLOOP="2330B"

 +44               DO EP^ABME5NM1("PR",+ABMLINE)

 +45               DO WR^ABMUTL8("NM1")

 +46               DO EP^ABME5N3(9999999.18,+ABMLINE)

 +47               DO WR^ABMUTL8("N3")

 +48               DO EP^ABME5N4(9999999.18,+ABMLINE)

 +49               DO WR^ABMUTL8("N4")

 +50               IF $GET(ABMP("PAYED",+ABMLINE))'=""

                       Begin DoDot:2

 +51      ;S ABMPDT=$S($P($G(ABMP("PAYED",+ABMLINE)),U,2)'="":$P(ABMP("PAYED",+ABMLINE),U,2),$G(ABMP("PDT",+ABMLINE))'="":ABMP("PDT",+ABMLINE),1:"")  ;abm*2.6*10 COB billing

 +52      ;abm*2.6*10 COB billing

                           SET ABMPDT=$SELECT($PIECE($GET(ABMP("PAYED",+ABMLINE)),U,2)'="":$PIECE(ABMP("PAYED",+ABMLINE),U,2),$GET(ABMP("PDT",+ABMLINE))'="":ABMP("PDT",+ABMLINE),1:DT)

 +53                       DO EP^ABME5DTP(573,"D8",ABMPDT)

 +54                       DO WR^ABMUTL8("DTP")

 +55                       KILL ABMPDT

                       End DoDot:2

 +56      ;D OTHR  ;abm*2.6*9 HEAT58542

               End DoDot:1

 +57       QUIT 

OTHR      ;other payer info

 +1       ;loops 2330C through 2330G

 +2        NEW J

 +3        FOR J=1:1:4

               Begin DoDot:1

 +4                SET ABMPTYP=$EXTRACT("FRPS",J)

 +5                IF ($GET(ABMP("CLIN"))="A3")&(J="R")

                       QUIT 

 +6                SET ABMPROV=$ORDER(ABMP("PRV",ABMPTYP,0))

 +7                IF ABMPROV

                       Begin DoDot:2

 +8                        SET ABMPNBR=$$NPI^ABMEEPRV(ABMPROV,ABMP("LDFN"),+ABMLINE)

 +9                        IF ABMPNBR=""

                               QUIT 

 +10                       DO EP^ABME5NM2($PIECE("DN^82^QB^DQ","^",J))

 +11                       DO WR^ABMUTL8("NM1")

 +12                       SET ABMITYP=$PIECE(ABMLINE,"^",2)

 +13                       SET ABMP("RTYPE")=$SELECT(ABMITYP="R":"1G",ABMITYP="D":"1D",$PIECE($GET(^ABMNINS(ABMDUZ2,ABMP("INS"),1,ABMP("VTYP"),1)),U)'="":$PIECE($GET(^ABMREFID($PIECE($GET(^ABMNINS(ABMDUZ2,ABMP("INS"),1,ABMP("VTYP"),1)),U),0)),U),1:"0B")

 +14      ;I ABMP("EXP")=32,ABMP("RTYPE")="1G" S ABMP("RTYPE")="1C"

 +15      ;D EP^ABME5RF2(ABMP("RTYPE"))

 +16      ;I ABMNPIU="B"!(ABMNPIU="N") D

 +17      ;.D EP^ABME5REF("EI",9999999.06,DUZ(2))

 +18      ;D WR^ABMUTL8("REF")

                       End DoDot:2

               End DoDot:1

 +19       QUIT