ABMDE2P ; IHS/ASDST/DMJ - Edit Page 2 - PICK PAYER ;
;;2.6;IHS 3P BILLING SYSTEM;**6,24,27**;NOV 12, 2009;Build 486
;
; IHS/SD/SDR - v2.5 p8 - task 8
; Added code for replacement insurer
;
;IHS/SD/SDR v2.5 p9 - IM13815 - change bill type when different insurer is picked
;
;IHS/SD/SDR 2.6*6 NOHEAT allow a 10th insurer to be selected; if 10th was selected it was putting 1st
;IHS/SD/SDR 2.6*24 CR9823 Added code to update fees if an insurer is Picked that has a different fee table setup than the one on the claim originally
;IHS/SD/SDR 2.6*27 CR8894 Updated fee table change from p24 to use CPT, not CPT IEN for lookup
; *********************************************************************
;
P1 ; Pick Insurer
W !
I $E(Y,2)>0&($E(Y,2)<(ABMZ("NUM")+1)) S Y=$E(Y,2) G P2
I ABMZ("NUM")=1 S Y=1 G P2
K DIR
S DIR(0)="NO^1:"_ABMZ("NUM")_":0"
S DIR("?")="Enter the Sequence Number of "_ABMZ("ITEM")_" to BILL"
S DIR("A")="Sequence Number of "_ABMZ("ITEM")_" to BILL"
D ^DIR
K DIR
Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(Y'>0)
;
P2 ;
Q:'$D(ABMZ(Y))
;S ABM("ANS")=$E(Y) ;abm*2.6*6 NOHEAT
S ABM("ANS")=+$G(Y) ;abm*2.6*6 NOHEAT
I $P(ABMZ(ABM("ANS")),U,4)="U" D Q
. W !!,*7,$P(ABMZ(ABM("ANS")),U)," is Designated as UNBILLABLE!",!
. D PAZ
I '$D(ABMZ("UNBILL",ABM("ANS"))) G PA
W !!,$P(ABMZ(ABM("ANS")),U)," has Already been Billed!"
W !
K DIR
S DIR(0)="YO"
S DIR("A")="Do you wish to bill "_$P(ABMZ(ABM("ANS")),U,1)_" Again"
D ^DIR
K DIR
Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(Y'=1)
;
PA ;
I $P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8)]"" D
.W !!,$P(^AUTNINS($P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8),0),U)
.W " is Currently the Billing Source!"
W !
K DIR
S DIR(0)="YO"
S DIR("A")="Do you wish to bill "_$P(ABMZ(ABM("ANS")),U,1)
D ^DIR
K DIR
Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)!(Y'=1)
;
P3 ;
N ABMVIST,ABMMODE
S ABMP("INS")=$P(ABMZ(ABM("ANS")),U,2)
S DA=ABMP("CDFN")
S DIE="^ABMDCLM(DUZ(2),"
S ABMVIST=$P(^ABMDCLM(DUZ(2),DA,0),U,7)
S ABMMODE=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMVIST,0)),U,4)
S DR=".08////"_ABMP("INS")_$S(ABMMODE:";.14///"_ABMMODE,1:"")
S ABMP("BTYP")=$S($P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,11)'="":$P($G(^ABMDCODE($P(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0),U,11),0)),U),1:ABMP("VTYP"))
S DR=DR_";.12////"_ABMP("BTYP")
D ^DIE
K DR
K ^ABMDCLM(DUZ(2),DA,13,"C")
S ABMP("C0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),0)
S ABMX("INS")=$P(ABMZ(ABM("ANS")),"^",3)
D COV^ABMDE2X5
K ABMX
S Y="",ABM("T")=""
I ABMZ("UNBILL") D
.F ABM("I")=1:1 S ABM("T")=$O(ABMZ("UNBILL",ABM("T"))) Q:'ABM("T") D
..I ABM("T")'=ABM("ANS") D
...S Y=$S(Y]"":Y_","_ABM("T"),1:ABM("T"))
S Y=$S(Y]"":Y_","_ABM("ANS"),1:ABM("ANS"))
F ABM("I")=1:1 S ABM("T")=$O(ABMZ(ABM("T"))) Q:'ABM("T") D
.I ABM("T")'=ABM("ANS") D
..I '$D(ABMZ("UNBILL",ABM("T"))) D
...S Y=Y_","_ABM("T")
S DA(1)=ABMP("CDFN")
S DIE="^ABMDCLM(DUZ(2),"_DA(1)_","_ABMZ("SUB")_","
I ABM("I")'=1 D
.K ABMX
.F ABMX=1:1 S ABMX("Y")=$P(Y,",",ABMX) Q:ABMX("Y")="" Q:+ABMX("Y")'>0!(ABMX("Y")'<(ABMZ("NUM")+1)) D
..S:'$D(ABMX(ABMX("Y"))) ABMX(ABMX("Y"))=ABMX
I ABM("I")'=1 D
.F ABMX=1:1:ABMZ("NUM") D
..S DA=$P(ABMZ(ABMX),U,3)
..S DR=".02////"_$S($D(ABMX(ABMX)):ABMX(ABMX),1:ABMX)
..D ^DIE
S DA(1)=ABMP("CDFN")
S DA=$P(ABMZ(ABM("ANS")),U,3)
S DIE="^ABMDCLM(DUZ(2),"_DA(1)_","_ABMZ("SUB")_","
S DR=".03///I"
D ^DIE
K DR
S DA(1)=ABMP("CDFN")
S DIE="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
S DR=".03///P"
S DA=0
F S DA=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,DA)) Q:'DA D
.I "CU"'[$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,DA,0),U,3) D
.. I DA'=$P(ABMZ(ABM("ANS")),U,3) D ^DIE
S ABMPS("FEE")=ABMP("FEE") ;abm*2.6*24 IHS/SD/SDR CR9823
D TPICHECK^ABMDE1
;start new abm*2.6*24 IHS/SD/SDR CR9823
NEWFETBL ;
;if a fee table is setup for the insurer/visit type and it's not the one already defined
S ABMFTST=0
I +$P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),0)),U,5)'=0&(+$G(ABMPS("FEE"))'=+$P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),0)),U,5)) S ABMFTST=1
I ABMFTST=0&(+$P($G(^ABMDPARM(DUZ(2),1,0)),U,9)'=0)&(+$G(ABMPS("FEE"))'=+$P($G(^ABMDPARM(DUZ(2),1,0)),U,9)) S ABMFTST=1
I ABMFTST=1 D
.W !!,$$EN^ABMVDF("HIN"),"**Note**",$$EN^ABMVDF("HIF")
.W " A different fee schedule (#"_ABMP("FEE")_") has been identified for this"
.W !,"visit type ("_ABMP("VTYP")_").",!
.D ^XBFMK
.S DIR(0)="Y"
.S DIR("A")="Do you wish to import those fees into this claim"
.S DIR("B")="Yes"
.D ^DIR
.K DIR
.Q:$D(DTOUT)!$D(DUOUT)!$D(DIROUT)
.I Y=0 W !!,"Fees will be left as is then.." H 1 Q ;don't want to import; leave fees as is
.S ABMI=19 ;skip everything prior to 21 (starting at 19)
.F S ABMI=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMI)) Q:'ABMI!(ABMI>47) D
..Q:ABMI=41 ;skip provider multiple
..S ABMTT=0
..F S ABMTT=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMI,ABMTT)) Q:'ABMTT D
...I $P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMI,ABMTT,0)),U,17)["|TC" Q ;skip any entry that are from the V Trans Code file; these are from charge master and should be left alone
...K ABMT
...D ^XBFMK
...S DA(1)=ABMP("CDFN")
...S DA=ABMTT
...S DIE="^ABMDCLM("_DUZ(2)_","_DA(1)_","_ABMI_","
...;S ABMT("CD")=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMI,ABMTT,0)),U) ;abm*2.6*27 IHS/SD/SDR CR8894
...S ABMT("CD")=$P($$CPT^ABMCVAPI($P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMI,ABMTT,0)),U),ABMP("VDT")),U,2) ;abm*2.6*27 IHS/SD/SDR CR8894
...S ABMMLT=$S(ABMI=21:11,ABMI=23:25,ABMI=25:31,ABMI=27:19,ABMI=33:21,ABMI=35:15,ABMI=37:17,ABMI=39:23,ABMI=43:13,ABMI=45:32,ABMI=47:13,1:13)
...I ABMI=33 S ABMR("CODE")=$$GET1^DIQ(9999999.31,ABMT("CD"),".01","E"),ABMT("CD")="1"_ABMR("CODE")
...S ABMT("FEE")=+$$ONE^ABMFEAPI(ABMP("FEE"),ABMMLT,ABMT("CD"),ABMP("VDT"))
...I ABMI=21 S DR=".07"
...I "^23^27^35^37^39^43^47^"[("^"_ABMI_"^") S DR=".04"
...I ABMI=25 S DR=".03"
...I ABMI=33 S DR=".08"
...S DR=DR_"////"_+ABMT("FEE")
...D ^DIE
.W !!,"Updates complete" H 1
;end new abm*2.6*24 IHS/SD/SDR CR9823
Q
;
PAZ ;
K DIR
S DIR(0)="E"
D ^DIR
K DIRUT,DUOUT
Q
ABMDE2P ; IHS/ASDST/DMJ - Edit Page 2 - PICK PAYER ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**6,24,27**;NOV 12, 2009;Build 486
+2 ;
+3 ; IHS/SD/SDR - v2.5 p8 - task 8
+4 ; Added code for replacement insurer
+5 ;
+6 ;IHS/SD/SDR v2.5 p9 - IM13815 - change bill type when different insurer is picked
+7 ;
+8 ;IHS/SD/SDR 2.6*6 NOHEAT allow a 10th insurer to be selected; if 10th was selected it was putting 1st
+9 ;IHS/SD/SDR 2.6*24 CR9823 Added code to update fees if an insurer is Picked that has a different fee table setup than the one on the claim originally
+10 ;IHS/SD/SDR 2.6*27 CR8894 Updated fee table change from p24 to use CPT, not CPT IEN for lookup
+11 ; *********************************************************************
+12 ;
P1 ; Pick Insurer
+1 WRITE !
+2 IF $EXTRACT(Y,2)>0&($EXTRACT(Y,2)<(ABMZ("NUM")+1))
SET Y=$EXTRACT(Y,2)
GOTO P2
+3 IF ABMZ("NUM")=1
SET Y=1
GOTO P2
+4 KILL DIR
+5 SET DIR(0)="NO^1:"_ABMZ("NUM")_":0"
+6 SET DIR("?")="Enter the Sequence Number of "_ABMZ("ITEM")_" to BILL"
+7 SET DIR("A")="Sequence Number of "_ABMZ("ITEM")_" to BILL"
+8 DO ^DIR
+9 KILL DIR
+10 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)!(Y'>0)
QUIT
+11 ;
P2 ;
+1 IF '$DATA(ABMZ(Y))
QUIT
+2 ;S ABM("ANS")=$E(Y) ;abm*2.6*6 NOHEAT
+3 ;abm*2.6*6 NOHEAT
SET ABM("ANS")=+$GET(Y)
+4 IF $PIECE(ABMZ(ABM("ANS")),U,4)="U"
Begin DoDot:1
+5 WRITE !!,*7,$PIECE(ABMZ(ABM("ANS")),U)," is Designated as UNBILLABLE!",!
+6 DO PAZ
End DoDot:1
QUIT
+7 IF '$DATA(ABMZ("UNBILL",ABM("ANS")))
GOTO PA
+8 WRITE !!,$PIECE(ABMZ(ABM("ANS")),U)," has Already been Billed!"
+9 WRITE !
+10 KILL DIR
+11 SET DIR(0)="YO"
+12 SET DIR("A")="Do you wish to bill "_$PIECE(ABMZ(ABM("ANS")),U,1)_" Again"
+13 DO ^DIR
+14 KILL DIR
+15 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)!(Y'=1)
QUIT
+16 ;
PA ;
+1 IF $PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8)]""
Begin DoDot:1
+2 WRITE !!,$PIECE(^AUTNINS($PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8),0),U)
+3 WRITE " is Currently the Billing Source!"
End DoDot:1
+4 WRITE !
+5 KILL DIR
+6 SET DIR(0)="YO"
+7 SET DIR("A")="Do you wish to bill "_$PIECE(ABMZ(ABM("ANS")),U,1)
+8 DO ^DIR
+9 KILL DIR
+10 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)!(Y'=1)
QUIT
+11 ;
P3 ;
+1 NEW ABMVIST,ABMMODE
+2 SET ABMP("INS")=$PIECE(ABMZ(ABM("ANS")),U,2)
+3 SET DA=ABMP("CDFN")
+4 SET DIE="^ABMDCLM(DUZ(2),"
+5 SET ABMVIST=$PIECE(^ABMDCLM(DUZ(2),DA,0),U,7)
+6 SET ABMMODE=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMVIST,0)),U,4)
+7 SET DR=".08////"_ABMP("INS")_$SELECT(ABMMODE:";.14///"_ABMMODE,1:"")
+8 SET ABMP("BTYP")=$SELECT($PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0)),U,11)'="":$PIECE($GET(^ABMDCODE($PIECE(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),0),U,11),0)),U),1:ABMP("VTYP"))
+9 SET DR=DR_";.12////"_ABMP("BTYP")
+10 DO ^DIE
+11 KILL DR
+12 KILL ^ABMDCLM(DUZ(2),DA,13,"C")
+13 SET ABMP("C0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),0)
+14 SET ABMX("INS")=$PIECE(ABMZ(ABM("ANS")),"^",3)
+15 DO COV^ABMDE2X5
+16 KILL ABMX
+17 SET Y=""
SET ABM("T")=""
+18 IF ABMZ("UNBILL")
Begin DoDot:1
+19 FOR ABM("I")=1:1
SET ABM("T")=$ORDER(ABMZ("UNBILL",ABM("T")))
IF 'ABM("T")
QUIT
Begin DoDot:2
+20 IF ABM("T")'=ABM("ANS")
Begin DoDot:3
+21 SET Y=$SELECT(Y]"":Y_","_ABM("T"),1:ABM("T"))
End DoDot:3
End DoDot:2
End DoDot:1
+22 SET Y=$SELECT(Y]"":Y_","_ABM("ANS"),1:ABM("ANS"))
+23 FOR ABM("I")=1:1
SET ABM("T")=$ORDER(ABMZ(ABM("T")))
IF 'ABM("T")
QUIT
Begin DoDot:1
+24 IF ABM("T")'=ABM("ANS")
Begin DoDot:2
+25 IF '$DATA(ABMZ("UNBILL",ABM("T")))
Begin DoDot:3
+26 SET Y=Y_","_ABM("T")
End DoDot:3
End DoDot:2
End DoDot:1
+27 SET DA(1)=ABMP("CDFN")
+28 SET DIE="^ABMDCLM(DUZ(2),"_DA(1)_","_ABMZ("SUB")_","
+29 IF ABM("I")'=1
Begin DoDot:1
+30 KILL ABMX
+31 FOR ABMX=1:1
SET ABMX("Y")=$PIECE(Y,",",ABMX)
IF ABMX("Y")=""
QUIT
IF +ABMX("Y")'>0!(ABMX("Y")'<(ABMZ("NUM")+1))
QUIT
Begin DoDot:2
+32 IF '$DATA(ABMX(ABMX("Y")))
SET ABMX(ABMX("Y"))=ABMX
End DoDot:2
End DoDot:1
+33 IF ABM("I")'=1
Begin DoDot:1
+34 FOR ABMX=1:1:ABMZ("NUM")
Begin DoDot:2
+35 SET DA=$PIECE(ABMZ(ABMX),U,3)
+36 SET DR=".02////"_$SELECT($DATA(ABMX(ABMX)):ABMX(ABMX),1:ABMX)
+37 DO ^DIE
End DoDot:2
End DoDot:1
+38 SET DA(1)=ABMP("CDFN")
+39 SET DA=$PIECE(ABMZ(ABM("ANS")),U,3)
+40 SET DIE="^ABMDCLM(DUZ(2),"_DA(1)_","_ABMZ("SUB")_","
+41 SET DR=".03///I"
+42 DO ^DIE
+43 KILL DR
+44 SET DA(1)=ABMP("CDFN")
+45 SET DIE="^ABMDCLM(DUZ(2),"_DA(1)_",13,"
+46 SET DR=".03///P"
+47 SET DA=0
+48 FOR
SET DA=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,DA))
IF 'DA
QUIT
Begin DoDot:1
+49 IF "CU"'[$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,DA,0),U,3)
Begin DoDot:2
+50 IF DA'=$PIECE(ABMZ(ABM("ANS")),U,3)
DO ^DIE
End DoDot:2
End DoDot:1
+51 ;abm*2.6*24 IHS/SD/SDR CR9823
SET ABMPS("FEE")=ABMP("FEE")
+52 DO TPICHECK^ABMDE1
+53 ;start new abm*2.6*24 IHS/SD/SDR CR9823
NEWFETBL ;
+1 ;if a fee table is setup for the insurer/visit type and it's not the one already defined
+2 SET ABMFTST=0
+3 IF +$PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),0)),U,5)'=0&(+$GET(ABMPS("FEE"))'=+$PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),0)),U,5))
SET ABMFTST=1
+4 IF ABMFTST=0&(+$PIECE($GET(^ABMDPARM(DUZ(2),1,0)),U,9)'=0)&(+$GET(ABMPS("FEE"))'=+$PIECE($GET(^ABMDPARM(DUZ(2),1,0)),U,9))
SET ABMFTST=1
+5 IF ABMFTST=1
Begin DoDot:1
+6 WRITE !!,$$EN^ABMVDF("HIN"),"**Note**",$$EN^ABMVDF("HIF")
+7 WRITE " A different fee schedule (#"_ABMP("FEE")_") has been identified for this"
+8 WRITE !,"visit type ("_ABMP("VTYP")_").",!
+9 DO ^XBFMK
+10 SET DIR(0)="Y"
+11 SET DIR("A")="Do you wish to import those fees into this claim"
+12 SET DIR("B")="Yes"
+13 DO ^DIR
+14 KILL DIR
+15 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
QUIT
+16 ;don't want to import; leave fees as is
IF Y=0
WRITE !!,"Fees will be left as is then.."
HANG 1
QUIT
+17 ;skip everything prior to 21 (starting at 19)
SET ABMI=19
+18 FOR
SET ABMI=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMI))
IF 'ABMI!(ABMI>47)
QUIT
Begin DoDot:2
+19 ;skip provider multiple
IF ABMI=41
QUIT
+20 SET ABMTT=0
+21 FOR
SET ABMTT=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMI,ABMTT))
IF 'ABMTT
QUIT
Begin DoDot:3
+22 ;skip any entry that are from the V Trans Code file; these are from charge master and should be left alone
IF $PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMI,ABMTT,0)),U,17)["|TC"
QUIT
+23 KILL ABMT
+24 DO ^XBFMK
+25 SET DA(1)=ABMP("CDFN")
+26 SET DA=ABMTT
+27 SET DIE="^ABMDCLM("_DUZ(2)_","_DA(1)_","_ABMI_","
+28 ;S ABMT("CD")=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMI,ABMTT,0)),U) ;abm*2.6*27 IHS/SD/SDR CR8894
+29 ;abm*2.6*27 IHS/SD/SDR CR8894
SET ABMT("CD")=$PIECE($$CPT^ABMCVAPI($PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),ABMI,ABMTT,0)),U),ABMP("VDT")),U,2)
+30 SET ABMMLT=$SELECT(ABMI=21:11,ABMI=23:25,ABMI=25:31,ABMI=27:19,ABMI=33:21,ABMI=35:15,ABMI=37:17,ABMI=39:23,ABMI=43:13,ABMI=45:32,ABMI=47:13,1:13)
+31 IF ABMI=33
SET ABMR("CODE")=$$GET1^DIQ(9999999.31,ABMT("CD"),".01","E")
SET ABMT("CD")="1"_ABMR("CODE")
+32 SET ABMT("FEE")=+$$ONE^ABMFEAPI(ABMP("FEE"),ABMMLT,ABMT("CD"),ABMP("VDT"))
+33 IF ABMI=21
SET DR=".07"
+34 IF "^23^27^35^37^39^43^47^"[("^"_ABMI_"^")
SET DR=".04"
+35 IF ABMI=25
SET DR=".03"
+36 IF ABMI=33
SET DR=".08"
+37 SET DR=DR_"////"_+ABMT("FEE")
+38 DO ^DIE
End DoDot:3
End DoDot:2
+39 WRITE !!,"Updates complete"
HANG 1
End DoDot:1
+40 ;end new abm*2.6*24 IHS/SD/SDR CR9823
+41 QUIT
+42 ;
PAZ ;
+1 KILL DIR
+2 SET DIR(0)="E"
+3 DO ^DIR
+4 KILL DIRUT,DUOUT
+5 QUIT
