ABMDFUTL ; IHS/SD/DMJ - Export Forms Utility ;
;;2.6;IHS Third Party Billing System;**2,6,8,9,10,13,14,21**;NOV 12, 2009;Build 379
;Original;TMD;
;
; IHS/ASDS/DMJ - 05/15/00 - V2.4 Patch 1 - NOIS HQW-0500-100032 - Modified to allow population of the PIN number for KIDSCARE
; as well as visit type 999.
; IHS/ASDS/SDH - 08/14/01 - V2.4 Patch 9 - NOIS NDA-1199-180065 - Modified routine to get grouper allowance, non-covered, and penalties.
; IHS/ASDS/SDH - 11/20/01 - V2.4. Patch 10 - NOIS QXX-1101-130059 - Modified to get billed amount even if there are no payments
;
; IHS/SD/SDR - 10/10/02 V2.5 P2 - NGA-0902-180106 - Modified to put provider number in 24k if Medicare/Railroad insurer
;IHS/SD/SDR - V2.5 P8 - IM10618/IM11164 - utility to return provider for line item
;IHS/SD/SDR - v2.5 p11 - NPI
;IHS/SD/SDR - v2.5 p12 - IM24799 - Made change for <UNDEF>K24N+9^ABMDFUTL
;IHS/SD/SDR - v2.5 p12 - IM25017 - Made changes for 1st line of block 24J
;IHS/SD/SDR - v2.5 p13 - IM26203 - Print loc NPI in block 33A
;IHS/SD/SDR - v2.5 p13 - IM26299 - Fix if insurer type is <UNDEF>
;IHS/SD/SDR - v2.5 p13 - NO IM - Change to use LDFN instead of DUZ(2)
;
;IHS/SD/SDR - abm*2.6*2 - HEAT10900 - ck if Medicare and primary
;IHS/SD/SDR - 2.6*9 - HEAT46390 - fixed writeoff amount to include all bills
;IHS/SD/SDR - 2.6*13 - Added check for new export mode 35; Also added lookup for provider
;IHS/SD/SDR - 2.6*14 - HEAT163697 - changed message in provider lookup if provider is not in New Person file; Also updated lookup so it wouldn't allow special characters if name
; is not in New Person file.
;IHS/SD/SDR - 2.6*14 - HEAT165324 - Fixed NPI for PRVLKUP so it will force NPI to be numeric; displays message and prompts again if not
;IHS/SD/SDR - 2.6*21 - HEAT196358 - For page 3 question Ord/Ref/Sup Phys (FL17), made change so no NPI can be entered but if none is
; entered, the name that was entered won't be saved either.
;
; *********************************************************************
;
TXST ;EP for obtaining or adding 3P TX STATUS entry
; - input variables: ABMP("EXP") - export form
; ABMY("INS") - insurer (optional)
; ABMY("TYP") - insurer type (optional)
; - output variable: ABMP("XMIT") - export batch
;
N ABMX
S ABMX="",ABMP("XMIT")=0
F S ABMX=$O(^ABMDTXST(DUZ(2),"B",DT,ABMX)) Q:'ABMX D Q:ABMP("XMIT")
.Q:'$D(^ABMDTXST(DUZ(2),ABMX,0)) Q:$P(^(0),U,2)'=ABMP("EXP")
.I $D(ABMY("TYP")),$P(^ABMDTXST(DUZ(2),ABMX,0),U,3)=ABMY("TYP") S ABMP("XMIT")=ABMX
.I $D(ABMY("INS")),$P(^ABMDTXST(DUZ(2),ABMX,0),U,4)=ABMY("INS") S ABMP("XMIT")=ABMX
Q:ABMP("XMIT")
S DIC="^ABMDTXST(DUZ(2),",DIC(0)="L",X=DT
S DIC("DR")=".02////"_ABMP("EXP")_";.07////1;.08////1;"_$S($D(ABMY("TYP")):".03////"_$P(ABMY("TYP"),U),$D(ABMY("INS")):".04////"_ABMY("INS"),1:".03////A")_";.05////"_DUZ
K DD,DO,DINUM D FILE^DICN S:Y>0 ABMP("XMIT")=+Y
Q
;
YTOT ;EP for updating ABMY("TOT") variable
; - input variables: ABM("YTOT") = $ amount of each bill
; - output variable: ABMY("TOT") = # bills ^ $ amount ^ # insurers
;
S $P(ABMY("TOT"),U)=$P($G(ABMY("TOT")),U)+1
S $P(ABMY("TOT"),U,2)=$P(ABMY("TOT"),U,2)+$G(ABM("YTOT"))
I '$D(ABMY("TINS",$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),U,8))) S ABMY("TINS",$P(^(0),U,8))="",$P(ABMY("TOT"),U,3)=$P(ABMY("TOT"),U,3)+1
Q
;
WTOT ;EP for writing Summary totals
Q:$D(ZTQUEUED)
W !!?16,"(All Print-outs are Complete)"
I $G(ABMP("XMIT")) W !!?5,"For Printing Mailing Labels, Worksheets or a Transmittal Listing...",!?5,"...refer to EXPORT BATCH: ",ABMP("XMIT") D
.S:'$D(ABMY("TOT")) ABMY("TOT")="0^0^0"
W !?17,"==========================="
W !?17,"Number of Records Exported: ",$P(ABMY("TOT"),U)
W !?17,"Number of Insurers........: ",$P(ABMY("TOT"),U,3)
W !?17,"Total Amount Billed.......: ",$FN($P(ABMY("TOT"),U,2),",",2),!
K DIR S DIR(0)="E" D ^DIR K DIR
Q
;
TXUPDT ;EP for updating the TXST file
Q:'ABMP("XMIT")
S DA=ABMP("XMIT")
Q:'$D(^ABMDTXST(DUZ(2),ABMP("XMIT"),0)) S ABM(0)=^(0),ABM(1)=$G(^(1))
S DIE="^ABMDTXST(DUZ(2),"
S DR=".09////"_(ABMY("TOT")+$P(ABM(0),U,9))_";.11////"_($P(ABMY("TOT"),U,2)+ABM(1))_";.12////"_($P(ABMY("TOT"),U,3)+$P(ABM(1),U,2))
D ^ABMDDIE
Q
;
PREV ;EP for obtaining previous payment info
;
; output vars: ABMP("PD") - amount of payments
; ABMP("WO") - amount of write-offs
;
S (ABMP("GRP"),ABMP("NONC"),ABMP("PENS"),ABMP("COI"),ABMP("DED"),ABMP("REF"))=0
K ABMP("BILL")
N ABM
I $D(ABMPM) M ABMP=ABMPM K ABMPM Q
S (ABMP("PD"),ABMP("WO"))=0
S ABM("W")=0 ;abm*2.6*9 HEAT46390
I $G(ABMAFLG)=1,($G(ABMMFLG)=1),(ABMP("EXP")>30) Q ;treat as primary if tribal self insured and Medicare ;abm*2.6*10 COB billing
S ABM("CLM")=$S($G(ABMP("BDFN")):+$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),U),1:ABMP("CDFN"))
S ABM("BIL")=$S($G(ABMP("BDFN")):ABMP("BDFN"),1:0)
S ABM("A")="" F S ABM("A")=$O(^ABMDBILL(DUZ(2),"AS",ABM("CLM"),ABM("A"))) Q:ABM("A")="" D
.F ABM=0:0 S ABM=$O(^ABMDBILL(DUZ(2),"AS",ABM("CLM"),ABM("A"),ABM)) Q:'ABM D
..Q:$D(ABM(ABM))
..Q:$P($G(^ABMDBILL(DUZ(2),ABM,0)),U,5)'=ABMP("PDFN")
..Q:$P($G(^ABMDBILL(DUZ(2),ABM,0)),"^",4)="X"
..;Q:($P($G(^AUTNINS(ABMP("INS"),2)),U)="R") ;abm*2.6*2 HEAT10900
..;Q:(($P($G(^AUTNINS(ABMP("INS"),2)),U)="R")&($G(ABMR("SBR",30))="P")) ;abm*2.6*2 HEAT10900 ;abm*2.6*10 HEAT73780
..Q:(($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")="R")&($G(ABMR("SBR",30))="P")) ;abm*2.6*2 HEAT10900 ;abm*2.6*10 HEAT73780
..;S ABM("W")=0,ABM(ABM)="" ;abm*2.6*9 HEAT46390
..S ABM(ABM)="" ;abm*2.6*9 HEAT46390
..F ABM("J")=0:0 S ABM("J")=$O(^ABMDBILL(DUZ(2),ABM,3,ABM("J"))) Q:'ABM("J") D
...S ABMP("PD")=$P(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0),U,2)+ABMP("PD"),ABM("W")=ABM("W")+$P(^(0),U,6)
...;S ABMP("WO")=ABM("W") ;abm*2.6*9 HEAT46390
...S ABMP("GRP")=$P($G(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,12)
...;S ABMP("NONC")=$P($G(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,7) ;abm*2.6*9 HEAT46390
...S ABMP("NONC")=ABMP("NONC")+$P($G(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,7) ;abm*2.6*9 HEAT46390
...S ABMP("PENS")=$P($G(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,9)
...S ABMP("COI")=$P($G(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,4)
...S ABMP("DED")=$P($G(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,3)
...S ABMP("REF")=$P($G(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,13)
...;S ABMP("WO")=ABMP("WO")+ABM("W")+ABMP("GRP")+ABMP("NONC")+ABMP("PENS") ;abm*2.6*9 HEAT46390
..I $D(ABMP("BDFN")) S ABMP("BILL")=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),2)),U)
..I $P($G(^ABMDBILL(DUZ(2),ABM,2)),U,4)=0 S ABMP("WO")=ABMP("WO")+ABM("W")
Q
GETPRV() ;EP - get attending or rendering provider for line
; item if not one on indiv. page
I $G(ABMP("GL"))="" Q 0
S ABMPRV=0
;S ABMPRVT=ABMP("GL")_"41,"_"""C"""_","_"""A"""_","_"0)" ;abm*2.6*6 NOHEAT
S ABMPRVT=ABMP("GL")_"41,"_"""C"",""A"",0)" ;abm*2.6*6 NOHEAT
S ABMPRV=$O(@ABMPRVT)
;I ABMPRV="" S ABMPRVT=ABMP("GL")_"41,""C"",""R"","_"0)",ABMPRV=$O(@ABMPRVT) ;abm*2.6*6 NOHEAT
I ABMPRV="" S ABMPRVT=ABMP("GL")_"41,""C"",""R"",0)",ABMPRV=$O(@ABMPRVT) ;abm*2.6*6 NOHEAT
S ABMPRVT=ABMP("GL")_"41,"_ABMPRV_",0)"
S ABMPRVT=$P(@ABMPRVT,"^")
Q ABMPRVT
K24() ;EP - box 24k hcfa form
;start old code abm*2.6*13 export mode 35
;I $G(ABMP("EXP"))'=27,($P($G(^ABMNINS(DUZ(2),+ABMP("INS"),1,ABMP("VTYP"),0)),"^",15)="MD") Q 1
;I $G(ABMP("EXP"))=27 Q 1
;end old code start new code export mode 35
I ($G(ABMP("EXP"))'=27&(ABMP("EXP")'=35)),($P($G(^ABMNINS(DUZ(2),+ABMP("INS"),1,ABMP("VTYP"),0)),"^",15)="MD") Q 1
I $G(ABMP("EXP"))=27!(ABMP("EXP")=35) Q 1
;end new code export mode 35
Q 0
K24N(X) ;EP - get payer assigned number (x=provider file 200 ien)
N Y
I '$G(ABMP("BDFN")) S Y="" Q Y
I '$G(ABMP("INS")) S Y="" Q Y
S Y=$P($G(^VA(200,+X,9999999.18,ABMP("INS"),0)),"^",2)
I Y=""&($G(ABMP("VTYP"))=999)&($P($G(^AUTNINS(ABMP("INS"),0)),U)="OKLAHOMA MEDICAID") S Y=$P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),3,X,0)),U,2)
I $P($G(^AUTNINS(ABMP("INS"),0)),U)["MEDICARE"!($P($G(^AUTNINS(ABMP("INS"),0)),U)["RAILROAD")!($P($G(^AUTNINS(ABMP("INS"),0)),U)["BLUE") D
.;I $G(ABMP("EXP"))=27 D ;abm*2.6*13 export mode 35
.I $G(ABMP("EXP"))=27!(ABMP("EXP")=35) D ;abm*2.6*13 export mode 35
..S:+$G(ABMDUZ2)=0 ABMDUZ2=DUZ(2)
..S ABMPQ=$S(ABMP("ITYPE")="R":"1C"_" ",ABMP("ITYPE")="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"_" ")
.S Y=$P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),3,X,0)),U,2)
;I $G(ABMP("EXP"))=27 D ;abm*2.6*13 export mode 35
I $G(ABMP("EXP"))=27!(ABMP("EXP")=35) D ;abm*2.6*13 export mode 35
.S:+$G(ABMDUZ2)=0 ABMDUZ2=DUZ(2)
.S ABMPQ=$S(ABMP("ITYPE")="R":"1C"_" ",ABMP("ITYPE")="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 $G(ABMP("ITYPE"))'="",($G(ABMP("ITYPE"))'="R"),($G(ABMP("ITYPE"))'="D"),($G(ABMP("ITYPE"))'="K") D
.S ABMIDCD=""
.D PIREFID^ABME8L2
.S:$G(ABMPQ)="" ABMPQ=ABMIDCD
S:$G(ABMPQ)="" ABMPQ="G2"
;S Y=$S(ABMP("EXP")=27&($G(Y)'=""):$G(ABMPQ),1:"")_Y K ABMPQ ;abm*2.6*8 HEAT31586
Q Y
F54() ;EP - flag 54 HCFA BOX 33
I $G(ABMP("ITYPE"))="K" Q 1
I $G(ABMP("VTYP"))=999 Q 1
I $$RCID^ABMERUTL(ABMP("INS"))=99999 Q 1
Q 0
;start new code abm*2.6*13 export mode 35
PRVLKUP(ABMX,ABMY) ;EP
;user will be prompted for name; if found in New Person file, it will retrieve NPI. If not found,
;user will be prompted for NPI as well
N DIC,DIE,DIR,X,Y,DR,DA
S DIR(0)="FAO^2:30^D NAME^AUPNPED"
S DIR("A")="Enter Provider Name: "
I ABMX'="" S DIR("B")=ABMX
D ^DIR
Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT) ""
I Y="" Q ""
S ABM("PROVIDER")=Y
N DIC,DIE,DIR,X,Y,DR,DA
S DIC="^VA(200,"
S DIC(0)="EQM"
S DIC("S")="I $D(^(""PS""))"
S X=ABM("PROVIDER")
D ^DIC
I Y>0 D Q ABM("PROVIDER")
.S $P(ABM("PROVIDER"),U)=$P(Y,U,2)
.S $P(ABM("PROVIDER"),U,2)=$S($P($$NPI^XUSNPI("Individual_ID",+Y),U)>0:$P($$NPI^XUSNPI("Individual_ID",+Y),U),1:"")
S ABMNFLG=1 ;abm*2.6*21 IHS/SD/SDR HEAT196358
NPI ;
I +$G(ABMNFLG)=0 K ABM("PROVIDER") Q 0 ;if no NPI when it gets here from below quit ;abm*2.6*21 IHS/SD/SDR HEAT196358
;I Y<0 D ;abm*2.6*14 HEAT165324
I +$G(Y)<1 D ;abm*2.6*14 HEAT165324
.;W " Name not in New Person file" ;abm*2.6*14 HEAT163697
.W " Entry NOT found" ;abm*2.6*14 HEAT163697
.N DIC,DIE,DIR,X,Y,DR,DA
.;S DIR(0)="FA^10:10" ;abm*2.6*14 HEAT163697
.S DIR(0)="FO^10:10" ;abm*2.6*14 HEAT163697
.;S DIR("A")="Enter Provider NPI: " ;abm*2.6*14 HEAT163697
.S DIR("A")="Enter Provider NPI" ;abm*2.6*14 HEAT163697
.I ABM("PROVIDER")=ABMX,ABMY'="" S DIR("B")=ABMY
.;S DIR("S")="I $$CHKDGT^XUSNPI(X))" ;abm*2.6*14 HEAT165324
.D ^DIR
.;start new abm*2.6*14 HEAT165324
.I Y="" W !,"No NPI entered - nothing saved" S ABMNFLG=0 S ABM("PROVIDER")="" H 1 Q ;abm*2.6*21 IHS/SD/SDR HEAT196358
.I +$$CHKDGT^XUSNPI(Y)'=1 D G NPI
..W !,"NPI must be 10 numeric characters"
..K Y
.;end new HEAT165324
.S $P(ABM("PROVIDER"),U,2)=Y
Q ABM("PROVIDER")
;end new code export mode 35
ABMDFUTL ; IHS/SD/DMJ - Export Forms Utility ;
+1 ;;2.6;IHS Third Party Billing System;**2,6,8,9,10,13,14,21**;NOV 12, 2009;Build 379
+2 ;Original;TMD;
+3 ;
+4 ; IHS/ASDS/DMJ - 05/15/00 - V2.4 Patch 1 - NOIS HQW-0500-100032 - Modified to allow population of the PIN number for KIDSCARE
+5 ; as well as visit type 999.
+6 ; IHS/ASDS/SDH - 08/14/01 - V2.4 Patch 9 - NOIS NDA-1199-180065 - Modified routine to get grouper allowance, non-covered, and penalties.
+7 ; IHS/ASDS/SDH - 11/20/01 - V2.4. Patch 10 - NOIS QXX-1101-130059 - Modified to get billed amount even if there are no payments
+8 ;
+9 ; IHS/SD/SDR - 10/10/02 V2.5 P2 - NGA-0902-180106 - Modified to put provider number in 24k if Medicare/Railroad insurer
+10 ;IHS/SD/SDR - V2.5 P8 - IM10618/IM11164 - utility to return provider for line item
+11 ;IHS/SD/SDR - v2.5 p11 - NPI
+12 ;IHS/SD/SDR - v2.5 p12 - IM24799 - Made change for <UNDEF>K24N+9^ABMDFUTL
+13 ;IHS/SD/SDR - v2.5 p12 - IM25017 - Made changes for 1st line of block 24J
+14 ;IHS/SD/SDR - v2.5 p13 - IM26203 - Print loc NPI in block 33A
+15 ;IHS/SD/SDR - v2.5 p13 - IM26299 - Fix if insurer type is <UNDEF>
+16 ;IHS/SD/SDR - v2.5 p13 - NO IM - Change to use LDFN instead of DUZ(2)
+17 ;
+18 ;IHS/SD/SDR - abm*2.6*2 - HEAT10900 - ck if Medicare and primary
+19 ;IHS/SD/SDR - 2.6*9 - HEAT46390 - fixed writeoff amount to include all bills
+20 ;IHS/SD/SDR - 2.6*13 - Added check for new export mode 35; Also added lookup for provider
+21 ;IHS/SD/SDR - 2.6*14 - HEAT163697 - changed message in provider lookup if provider is not in New Person file; Also updated lookup so it wouldn't allow special characters if name
+22 ; is not in New Person file.
+23 ;IHS/SD/SDR - 2.6*14 - HEAT165324 - Fixed NPI for PRVLKUP so it will force NPI to be numeric; displays message and prompts again if not
+24 ;IHS/SD/SDR - 2.6*21 - HEAT196358 - For page 3 question Ord/Ref/Sup Phys (FL17), made change so no NPI can be entered but if none is
+25 ; entered, the name that was entered won't be saved either.
+26 ;
+27 ; *********************************************************************
+28 ;
TXST ;EP for obtaining or adding 3P TX STATUS entry
+1 ; - input variables: ABMP("EXP") - export form
+2 ; ABMY("INS") - insurer (optional)
+3 ; ABMY("TYP") - insurer type (optional)
+4 ; - output variable: ABMP("XMIT") - export batch
+5 ;
+6 NEW ABMX
+7 SET ABMX=""
SET ABMP("XMIT")=0
+8 FOR
SET ABMX=$ORDER(^ABMDTXST(DUZ(2),"B",DT,ABMX))
IF 'ABMX
QUIT
Begin DoDot:1
+9 IF '$DATA(^ABMDTXST(DUZ(2),ABMX,0))
QUIT
IF $PIECE(^(0),U,2)'=ABMP("EXP")
QUIT
+10 IF $DATA(ABMY("TYP"))
IF $PIECE(^ABMDTXST(DUZ(2),ABMX,0),U,3)=ABMY("TYP")
SET ABMP("XMIT")=ABMX
+11 IF $DATA(ABMY("INS"))
IF $PIECE(^ABMDTXST(DUZ(2),ABMX,0),U,4)=ABMY("INS")
SET ABMP("XMIT")=ABMX
End DoDot:1
IF ABMP("XMIT")
QUIT
+12 IF ABMP("XMIT")
QUIT
+13 SET DIC="^ABMDTXST(DUZ(2),"
SET DIC(0)="L"
SET X=DT
+14 SET DIC("DR")=".02////"_ABMP("EXP")_";.07////1;.08////1;"_$SELECT($DATA(ABMY("TYP")):".03////"_$PIECE(ABMY("TYP"),U),$DATA(ABMY("INS")):".04////"_ABMY("INS"),1:".03////A")_";.05////"_DUZ
+15 KILL DD,DO,DINUM
DO FILE^DICN
IF Y>0
SET ABMP("XMIT")=+Y
+16 QUIT
+17 ;
YTOT ;EP for updating ABMY("TOT") variable
+1 ; - input variables: ABM("YTOT") = $ amount of each bill
+2 ; - output variable: ABMY("TOT") = # bills ^ $ amount ^ # insurers
+3 ;
+4 SET $PIECE(ABMY("TOT"),U)=$PIECE($GET(ABMY("TOT")),U)+1
+5 SET $PIECE(ABMY("TOT"),U,2)=$PIECE(ABMY("TOT"),U,2)+$GET(ABM("YTOT"))
+6 IF '$DATA(ABMY("TINS",$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),U,8)))
SET ABMY("TINS",$PIECE(^(0),U,8))=""
SET $PIECE(ABMY("TOT"),U,3)=$PIECE(ABMY("TOT"),U,3)+1
+7 QUIT
+8 ;
WTOT ;EP for writing Summary totals
+1 IF $DATA(ZTQUEUED)
QUIT
+2 WRITE !!?16,"(All Print-outs are Complete)"
+3 IF $GET(ABMP("XMIT"))
WRITE !!?5,"For Printing Mailing Labels, Worksheets or a Transmittal Listing...",!?5,"...refer to EXPORT BATCH: ",ABMP("XMIT")
Begin DoDot:1
+4 IF '$DATA(ABMY("TOT"))
SET ABMY("TOT")="0^0^0"
End DoDot:1
+5 WRITE !?17,"==========================="
+6 WRITE !?17,"Number of Records Exported: ",$PIECE(ABMY("TOT"),U)
+7 WRITE !?17,"Number of Insurers........: ",$PIECE(ABMY("TOT"),U,3)
+8 WRITE !?17,"Total Amount Billed.......: ",$FNUMBER($PIECE(ABMY("TOT"),U,2),",",2),!
+9 KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
+10 QUIT
+11 ;
TXUPDT ;EP for updating the TXST file
+1 IF 'ABMP("XMIT")
QUIT
+2 SET DA=ABMP("XMIT")
+3 IF '$DATA(^ABMDTXST(DUZ(2),ABMP("XMIT"),0))
QUIT
SET ABM(0)=^(0)
SET ABM(1)=$GET(^(1))
+4 SET DIE="^ABMDTXST(DUZ(2),"
+5 SET DR=".09////"_(ABMY("TOT")+$PIECE(ABM(0),U,9))_";.11////"_($PIECE(ABMY("TOT"),U,2)+ABM(1))_";.12////"_($PIECE(ABMY("TOT"),U,3)+$PIECE(ABM(1),U,2))
+6 DO ^ABMDDIE
+7 QUIT
+8 ;
PREV ;EP for obtaining previous payment info
+1 ;
+2 ; output vars: ABMP("PD") - amount of payments
+3 ; ABMP("WO") - amount of write-offs
+4 ;
+5 SET (ABMP("GRP"),ABMP("NONC"),ABMP("PENS"),ABMP("COI"),ABMP("DED"),ABMP("REF"))=0
+6 KILL ABMP("BILL")
+7 NEW ABM
+8 IF $DATA(ABMPM)
MERGE ABMP=ABMPM
KILL ABMPM
QUIT
+9 SET (ABMP("PD"),ABMP("WO"))=0
+10 ;abm*2.6*9 HEAT46390
SET ABM("W")=0
+11 ;treat as primary if tribal self insured and Medicare ;abm*2.6*10 COB billing
IF $GET(ABMAFLG)=1
IF ($GET(ABMMFLG)=1)
IF (ABMP("EXP")>30)
QUIT
+12 SET ABM("CLM")=$SELECT($GET(ABMP("BDFN")):+$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),0),U),1:ABMP("CDFN"))
+13 SET ABM("BIL")=$SELECT($GET(ABMP("BDFN")):ABMP("BDFN"),1:0)
+14 SET ABM("A")=""
FOR
SET ABM("A")=$ORDER(^ABMDBILL(DUZ(2),"AS",ABM("CLM"),ABM("A")))
IF ABM("A")=""
QUIT
Begin DoDot:1
+15 FOR ABM=0:0
SET ABM=$ORDER(^ABMDBILL(DUZ(2),"AS",ABM("CLM"),ABM("A"),ABM))
IF 'ABM
QUIT
Begin DoDot:2
+16 IF $DATA(ABM(ABM))
QUIT
+17 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABM,0)),U,5)'=ABMP("PDFN")
QUIT
+18 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABM,0)),"^",4)="X"
QUIT
+19 ;Q:($P($G(^AUTNINS(ABMP("INS"),2)),U)="R") ;abm*2.6*2 HEAT10900
+20 ;Q:(($P($G(^AUTNINS(ABMP("INS"),2)),U)="R")&($G(ABMR("SBR",30))="P")) ;abm*2.6*2 HEAT10900 ;abm*2.6*10 HEAT73780
+21 ;abm*2.6*2 HEAT10900 ;abm*2.6*10 HEAT73780
IF (($$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")="R")&($GET(ABMR("SBR",30))="P"))
QUIT
+22 ;S ABM("W")=0,ABM(ABM)="" ;abm*2.6*9 HEAT46390
+23 ;abm*2.6*9 HEAT46390
SET ABM(ABM)=""
+24 FOR ABM("J")=0:0
SET ABM("J")=$ORDER(^ABMDBILL(DUZ(2),ABM,3,ABM("J")))
IF 'ABM("J")
QUIT
Begin DoDot:3
+25 SET ABMP("PD")=$PIECE(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0),U,2)+ABMP("PD")
SET ABM("W")=ABM("W")+$PIECE(^(0),U,6)
+26 ;S ABMP("WO")=ABM("W") ;abm*2.6*9 HEAT46390
+27 SET ABMP("GRP")=$PIECE($GET(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,12)
+28 ;S ABMP("NONC")=$P($G(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,7) ;abm*2.6*9 HEAT46390
+29 ;abm*2.6*9 HEAT46390
SET ABMP("NONC")=ABMP("NONC")+$PIECE($GET(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,7)
+30 SET ABMP("PENS")=$PIECE($GET(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,9)
+31 SET ABMP("COI")=$PIECE($GET(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,4)
+32 SET ABMP("DED")=$PIECE($GET(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,3)
+33 SET ABMP("REF")=$PIECE($GET(^ABMDBILL(DUZ(2),ABM,3,ABM("J"),0)),U,13)
+34 ;S ABMP("WO")=ABMP("WO")+ABM("W")+ABMP("GRP")+ABMP("NONC")+ABMP("PENS") ;abm*2.6*9 HEAT46390
End DoDot:3
+35 IF $DATA(ABMP("BDFN"))
SET ABMP("BILL")=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),2)),U)
+36 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABM,2)),U,4)=0
SET ABMP("WO")=ABMP("WO")+ABM("W")
End DoDot:2
End DoDot:1
+37 QUIT
GETPRV() ;EP - get attending or rendering provider for line
+1 ; item if not one on indiv. page
+2 IF $GET(ABMP("GL"))=""
QUIT 0
+3 SET ABMPRV=0
+4 ;S ABMPRVT=ABMP("GL")_"41,"_"""C"""_","_"""A"""_","_"0)" ;abm*2.6*6 NOHEAT
+5 ;abm*2.6*6 NOHEAT
SET ABMPRVT=ABMP("GL")_"41,"_"""C"",""A"",0)"
+6 SET ABMPRV=$ORDER(@ABMPRVT)
+7 ;I ABMPRV="" S ABMPRVT=ABMP("GL")_"41,""C"",""R"","_"0)",ABMPRV=$O(@ABMPRVT) ;abm*2.6*6 NOHEAT
+8 ;abm*2.6*6 NOHEAT
IF ABMPRV=""
SET ABMPRVT=ABMP("GL")_"41,""C"",""R"",0)"
SET ABMPRV=$ORDER(@ABMPRVT)
+9 SET ABMPRVT=ABMP("GL")_"41,"_ABMPRV_",0)"
+10 SET ABMPRVT=$PIECE(@ABMPRVT,"^")
+11 QUIT ABMPRVT
K24() ;EP - box 24k hcfa form
+1 ;start old code abm*2.6*13 export mode 35
+2 ;I $G(ABMP("EXP"))'=27,($P($G(^ABMNINS(DUZ(2),+ABMP("INS"),1,ABMP("VTYP"),0)),"^",15)="MD") Q 1
+3 ;I $G(ABMP("EXP"))=27 Q 1
+4 ;end old code start new code export mode 35
+5 IF ($GET(ABMP("EXP"))'=27&(ABMP("EXP")'=35))
IF ($PIECE($GET(^ABMNINS(DUZ(2),+ABMP("INS"),1,ABMP("VTYP"),0)),"^",15)="MD")
QUIT 1
+6 IF $GET(ABMP("EXP"))=27!(ABMP("EXP")=35)
QUIT 1
+7 ;end new code export mode 35
+8 QUIT 0
K24N(X) ;EP - get payer assigned number (x=provider file 200 ien)
+1 NEW Y
+2 IF '$GET(ABMP("BDFN"))
SET Y=""
QUIT Y
+3 IF '$GET(ABMP("INS"))
SET Y=""
QUIT Y
+4 SET Y=$PIECE($GET(^VA(200,+X,9999999.18,ABMP("INS"),0)),"^",2)
+5 IF Y=""&($GET(ABMP("VTYP"))=999)&($PIECE($GET(^AUTNINS(ABMP("INS"),0)),U)="OKLAHOMA MEDICAID")
SET Y=$PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),3,X,0)),U,2)
+6 IF $PIECE($GET(^AUTNINS(ABMP("INS"),0)),U)["MEDICARE"!($PIECE($GET(^AUTNINS(ABMP("INS"),0)),U)["RAILROAD")!($PIECE($GET(^AUTNINS(ABMP("INS"),0)),U)["BLUE")
Begin DoDot:1
+7 ;I $G(ABMP("EXP"))=27 D ;abm*2.6*13 export mode 35
+8 ;abm*2.6*13 export mode 35
IF $GET(ABMP("EXP"))=27!(ABMP("EXP")=35)
Begin DoDot:2
+9 IF +$GET(ABMDUZ2)=0
SET ABMDUZ2=DUZ(2)
+10 SET ABMPQ=$SELECT(ABMP("ITYPE")="R":"1C"_" ",ABMP("ITYPE")="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"_" ")
End DoDot:2
+11 SET Y=$PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),3,X,0)),U,2)
End DoDot:1
+12 ;I $G(ABMP("EXP"))=27 D ;abm*2.6*13 export mode 35
+13 ;abm*2.6*13 export mode 35
IF $GET(ABMP("EXP"))=27!(ABMP("EXP")=35)
Begin DoDot:1
+14 IF +$GET(ABMDUZ2)=0
SET ABMDUZ2=DUZ(2)
+15 SET ABMPQ=$SELECT(ABMP("ITYPE")="R":"1C"_" ",ABMP("ITYPE")="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
"_" ")
End DoDot:1
+16 IF $GET(ABMP("ITYPE"))'=""
IF ($GET(ABMP("ITYPE"))'="R")
IF ($GET(ABMP("ITYPE"))'="D")
IF ($GET(ABMP("ITYPE"))'="K")
Begin DoDot:1
+17 SET ABMIDCD=""
+18 DO PIREFID^ABME8L2
+19 IF $GET(ABMPQ)=""
SET ABMPQ=ABMIDCD
End DoDot:1
+20 IF $GET(ABMPQ)=""
SET ABMPQ="G2"
+21 ;S Y=$S(ABMP("EXP")=27&($G(Y)'=""):$G(ABMPQ),1:"")_Y K ABMPQ ;abm*2.6*8 HEAT31586
+22 QUIT Y
F54() ;EP - flag 54 HCFA BOX 33
+1 IF $GET(ABMP("ITYPE"))="K"
QUIT 1
+2 IF $GET(ABMP("VTYP"))=999
QUIT 1
+3 IF $$RCID^ABMERUTL(ABMP("INS"))=99999
QUIT 1
+4 QUIT 0
+5 ;start new code abm*2.6*13 export mode 35
PRVLKUP(ABMX,ABMY) ;EP
+1 ;user will be prompted for name; if found in New Person file, it will retrieve NPI. If not found,
+2 ;user will be prompted for NPI as well
+3 NEW DIC,DIE,DIR,X,Y,DR,DA
+4 SET DIR(0)="FAO^2:30^D NAME^AUPNPED"
+5 SET DIR("A")="Enter Provider Name: "
+6 IF ABMX'=""
SET DIR("B")=ABMX
+7 DO ^DIR
+8 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT ""
+9 IF Y=""
QUIT ""
+10 SET ABM("PROVIDER")=Y
+11 NEW DIC,DIE,DIR,X,Y,DR,DA
+12 SET DIC="^VA(200,"
+13 SET DIC(0)="EQM"
+14 SET DIC("S")="I $D(^(""PS""))"
+15 SET X=ABM("PROVIDER")
+16 DO ^DIC
+17 IF Y>0
Begin DoDot:1
+18 SET $PIECE(ABM("PROVIDER"),U)=$PIECE(Y,U,2)
+19 SET $PIECE(ABM("PROVIDER"),U,2)=$SELECT($PIECE($$NPI^XUSNPI("Individual_ID",+Y),U)>0:$PIECE($$NPI^XUSNPI("Individual_ID",+Y),U),1:"")
End DoDot:1
QUIT ABM("PROVIDER")
+20 ;abm*2.6*21 IHS/SD/SDR HEAT196358
SET ABMNFLG=1
NPI ;
+1 ;if no NPI when it gets here from below quit ;abm*2.6*21 IHS/SD/SDR HEAT196358
IF +$GET(ABMNFLG)=0
KILL ABM("PROVIDER")
QUIT 0
+2 ;I Y<0 D ;abm*2.6*14 HEAT165324
+3 ;abm*2.6*14 HEAT165324
IF +$GET(Y)<1
Begin DoDot:1
+4 ;W " Name not in New Person file" ;abm*2.6*14 HEAT163697
+5 ;abm*2.6*14 HEAT163697
WRITE " Entry NOT found"
+6 NEW DIC,DIE,DIR,X,Y,DR,DA
+7 ;S DIR(0)="FA^10:10" ;abm*2.6*14 HEAT163697
+8 ;abm*2.6*14 HEAT163697
SET DIR(0)="FO^10:10"
+9 ;S DIR("A")="Enter Provider NPI: " ;abm*2.6*14 HEAT163697
+10 ;abm*2.6*14 HEAT163697
SET DIR("A")="Enter Provider NPI"
+11 IF ABM("PROVIDER")=ABMX
IF ABMY'=""
SET DIR("B")=ABMY
+12 ;S DIR("S")="I $$CHKDGT^XUSNPI(X))" ;abm*2.6*14 HEAT165324
+13 DO ^DIR
+14 ;start new abm*2.6*14 HEAT165324
+15 ;abm*2.6*21 IHS/SD/SDR HEAT196358
IF Y=""
WRITE !,"No NPI entered - nothing saved"
SET ABMNFLG=0
SET ABM("PROVIDER")=""
HANG 1
QUIT
+16 IF +$$CHKDGT^XUSNPI(Y)'=1
Begin DoDot:2
+17 WRITE !,"NPI must be 10 numeric characters"
+18 KILL Y
End DoDot:2
GOTO NPI
+19 ;end new HEAT165324
+20 SET $PIECE(ABM("PROVIDER"),U,2)=Y
End DoDot:1
+21 QUIT ABM("PROVIDER")
+22 ;end new code export mode 35
