ABMDFRA ; IHS/ASDST/DMJ - FLAT RATE ADJUSTMENT ;
;;2.6;IHS 3P BILLING SYSTEM;**9**;NOV 12, 2009
;
; IHS/SD/SDR - v2.5 p12 - UFMS
; If user isn't logged into cashiering session they can't do
; this option
;
START ;START
;start new code abm*2.6*9 NOHEAT - ensure UFMS is setup
I $P($G(^ABMDPARM(DUZ(2),1,4)),U,15)="" D Q
.W !!,"* * UFMS SETUP MUST BE DONE BEFORE ANY BILLING FUNCTIONS CAN BE USED! * *",!
.S DIR(0)="E",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR
;end new code
I $P($G(^ABMDPARM(DUZ(2),1,4)),U,15)=1 D Q:+$G(ABMUOPNS)=0
.S ABMUOPNS=$$FINDOPEN^ABMUCUTL(DUZ)
.I +$G(ABMUOPNS)=0 D Q
..W !!,"* * YOU MUST SIGN IN TO BE ABLE TO PERFORM BILLING FUNCTIONS! * *",!
..S DIR(0)="E",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR
W !!,"This option will adjust the amount billed field for all claims"
W !,"for the insurer and visit type you select beginning with the date"
W !,"you select to reflect a new flat rate.",!
W !,"An adjustment will then be passed to the A/R system.",!
S DIC="^ABMNINS(DUZ(2),",DIC(0)="AEMQ" D ^DIC Q:+Y<0 S ABMINS=+Y
S DIC="^ABMNINS(DUZ(2),ABMINS,1,",DIC(0)="AEMQ" D ^DIC Q:+Y<0 S ABMVTYP=+Y
S DIR(0)="D" D ^DIR K DIR Q:'Y S ABMDATE=Y
S DIR(0)="N",DIR("A")="Enter Old Rate " D ^DIR K DIR S ABMORAT=Y
W !!,"I am going to adjust the amount billed field for all bills with visit date ",!,$$MDT^ABMDUTL(ABMDATE)
W "or later for insurer ",$P(^AUTNINS(ABMINS,0),U),", visit type ",ABMVTYP,", billed at"
W !,"the old rate of ",ABMORAT,"."
S ABMFLAT=$$FLAT^ABMDUTL(ABMINS,ABMVTYP,ABMDATE)
W !!,"NOTE: The flat rate for this insurer, visit type, and date is $",ABMFLAT,".",!
D PRO Q:Y'=1
S ABMCOUNT=0
S ABMI=ABMDATE-.5 F S ABMI=$O(^ABMDBILL(DUZ(2),"AD",ABMI)) Q:'ABMI D
.S ABMJ=0 F S ABMJ=$O(^ABMDBILL(DUZ(2),"AD",ABMI,ABMJ)) Q:'ABMJ D
..D ONE
W !!,"Finished - ",ABMCOUNT," bills changed.",!!
S DIR(0)="E" D ^DIR K DIR
K ABMFLAT,ABMVTYP,ABMDATE,ABMINS,ABMZERO,ABMCOUNT,ABMOLD,ABMI,ABMJ,ABMAO
Q
ONE ;EP - one bill
S DA=ABMJ
S ABMZERO=^ABMDBILL(DUZ(2),DA,0)
Q:$P(ABMZERO,"^",7)'=ABMVTYP
Q:$P(ABMZERO,"^",8)'=ABMINS
S ABMDAYS=$P($G(^ABMDBILL(DUZ(2),DA,7)),"^",3)
S:+ABMDAYS<2 ABMDAYS=1
S ABMOLD=$P(^ABMDBILL(DUZ(2),DA,2),U)
S ABMOTOT=ABMORAT*ABMDAYS
Q:ABMOLD'=ABMOTOT
S ABMNEW=ABMFLAT*ABMDAYS
Q:ABMOLD=ABMNEW
S $P(^ABMDBILL(DUZ(2),DA,2),U)=ABMNEW
S:$P(^ABMDBILL(DUZ(2),DA,2),"^",3)=ABMOLD $P(^(2),"^",3)=ABMNEW
S ^ABMDBILL(DUZ(2),DA,"AF",$H,.21)=DUZ_"^"_ABMOLD
W "."
S ABMCOUNT=ABMCOUNT+1
S ABMFR("ADJ AMT")=ABMNEW-ABMOLD
S ABMFR("USER")=DUZ
S ABMFR("ARLOC")=$P(^ABMDBILL(DUZ(2),DA,2),"^",6)
I ABMFR("ARLOC")="" D
.S ABMFR("ARLOC")=$$FIND(DA)
.I ABMFR("ARLOC")="" Q
.S DIE="^ABMDBILL(DUZ(2),",DR=".26///"_ABMFR("ARLOC")
.D ^DIE
S ABMFR("TRAN TYPE")=503
S ABMTEST=$$EN^BARFRAPI(.ABMFR)
Q
PRO ;PROCEED
W !
S DIR(0)="Y",DIR("A")="Proceed",DIR("B")="NO" D ^DIR K DIR
Q
FIND(DA) ;find bill in A/R
S ABMARLOC=""
S ABMNAME=$P(^ABMDBILL(DUZ(2),DA,0),U),ABMLOC=$P(^(0),"^",3)
N I
S I=0
F S I=$O(^BARBL(I)) Q:'I D
.Q:ABMARLOC'=""
.S ABMNXT=$O(^BARBL(I,"B",ABMNAME))
.Q:ABMNXT'[ABMNAME
.S ABMIEN=$O(^BARBL(I,"B",ABMNXT,0))
.I $P(^BARBL(I,ABMIEN,0),"^",17)=DA S ABMARLOC=I_","_ABMIEN
Q ABMARLOC
ABMDFRA ; IHS/ASDST/DMJ - FLAT RATE ADJUSTMENT ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**9**;NOV 12, 2009
+2 ;
+3 ; IHS/SD/SDR - v2.5 p12 - UFMS
+4 ; If user isn't logged into cashiering session they can't do
+5 ; this option
+6 ;
START ;START
+1 ;start new code abm*2.6*9 NOHEAT - ensure UFMS is setup
+2 IF $PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,15)=""
Begin DoDot:1
+3 WRITE !!,"* * UFMS SETUP MUST BE DONE BEFORE ANY BILLING FUNCTIONS CAN BE USED! * *",!
+4 SET DIR(0)="E"
SET DIR("A")="Enter RETURN to Continue"
DO ^DIR
KILL DIR
End DoDot:1
QUIT
+5 ;end new code
+6 IF $PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,15)=1
Begin DoDot:1
+7 SET ABMUOPNS=$$FINDOPEN^ABMUCUTL(DUZ)
+8 IF +$GET(ABMUOPNS)=0
Begin DoDot:2
+9 WRITE !!,"* * YOU MUST SIGN IN TO BE ABLE TO PERFORM BILLING FUNCTIONS! * *",!
+10 SET DIR(0)="E"
SET DIR("A")="Enter RETURN to Continue"
DO ^DIR
KILL DIR
End DoDot:2
QUIT
End DoDot:1
IF +$GET(ABMUOPNS)=0
QUIT
+11 WRITE !!,"This option will adjust the amount billed field for all claims"
+12 WRITE !,"for the insurer and visit type you select beginning with the date"
+13 WRITE !,"you select to reflect a new flat rate.",!
+14 WRITE !,"An adjustment will then be passed to the A/R system.",!
+15 SET DIC="^ABMNINS(DUZ(2),"
SET DIC(0)="AEMQ"
DO ^DIC
IF +Y<0
QUIT
SET ABMINS=+Y
+16 SET DIC="^ABMNINS(DUZ(2),ABMINS,1,"
SET DIC(0)="AEMQ"
DO ^DIC
IF +Y<0
QUIT
SET ABMVTYP=+Y
+17 SET DIR(0)="D"
DO ^DIR
KILL DIR
IF 'Y
QUIT
SET ABMDATE=Y
+18 SET DIR(0)="N"
SET DIR("A")="Enter Old Rate "
DO ^DIR
KILL DIR
SET ABMORAT=Y
+19 WRITE !!,"I am going to adjust the amount billed field for all bills with visit date ",!,$$MDT^ABMDUTL(ABMDATE)
+20 WRITE "or later for insurer ",$PIECE(^AUTNINS(ABMINS,0),U),", visit type ",ABMVTYP,", billed at"
+21 WRITE !,"the old rate of ",ABMORAT,"."
+22 SET ABMFLAT=$$FLAT^ABMDUTL(ABMINS,ABMVTYP,ABMDATE)
+23 WRITE !!,"NOTE: The flat rate for this insurer, visit type, and date is $",ABMFLAT,".",!
+24 DO PRO
IF Y'=1
QUIT
+25 SET ABMCOUNT=0
+26 SET ABMI=ABMDATE-.5
FOR
SET ABMI=$ORDER(^ABMDBILL(DUZ(2),"AD",ABMI))
IF 'ABMI
QUIT
Begin DoDot:1
+27 SET ABMJ=0
FOR
SET ABMJ=$ORDER(^ABMDBILL(DUZ(2),"AD",ABMI,ABMJ))
IF 'ABMJ
QUIT
Begin DoDot:2
+28 DO ONE
End DoDot:2
End DoDot:1
+29 WRITE !!,"Finished - ",ABMCOUNT," bills changed.",!!
+30 SET DIR(0)="E"
DO ^DIR
KILL DIR
+31 KILL ABMFLAT,ABMVTYP,ABMDATE,ABMINS,ABMZERO,ABMCOUNT,ABMOLD,ABMI,ABMJ,ABMAO
+32 QUIT
ONE ;EP - one bill
+1 SET DA=ABMJ
+2 SET ABMZERO=^ABMDBILL(DUZ(2),DA,0)
+3 IF $PIECE(ABMZERO,"^",7)'=ABMVTYP
QUIT
+4 IF $PIECE(ABMZERO,"^",8)'=ABMINS
QUIT
+5 SET ABMDAYS=$PIECE($GET(^ABMDBILL(DUZ(2),DA,7)),"^",3)
+6 IF +ABMDAYS<2
SET ABMDAYS=1
+7 SET ABMOLD=$PIECE(^ABMDBILL(DUZ(2),DA,2),U)
+8 SET ABMOTOT=ABMORAT*ABMDAYS
+9 IF ABMOLD'=ABMOTOT
QUIT
+10 SET ABMNEW=ABMFLAT*ABMDAYS
+11 IF ABMOLD=ABMNEW
QUIT
+12 SET $PIECE(^ABMDBILL(DUZ(2),DA,2),U)=ABMNEW
+13 IF $PIECE(^ABMDBILL(DUZ(2),DA,2),"^",3)=ABMOLD
SET $PIECE(^(2),"^",3)=ABMNEW
+14 SET ^ABMDBILL(DUZ(2),DA,"AF",$HOROLOG,.21)=DUZ_"^"_ABMOLD
+15 WRITE "."
+16 SET ABMCOUNT=ABMCOUNT+1
+17 SET ABMFR("ADJ AMT")=ABMNEW-ABMOLD
+18 SET ABMFR("USER")=DUZ
+19 SET ABMFR("ARLOC")=$PIECE(^ABMDBILL(DUZ(2),DA,2),"^",6)
+20 IF ABMFR("ARLOC")=""
Begin DoDot:1
+21 SET ABMFR("ARLOC")=$$FIND(DA)
+22 IF ABMFR("ARLOC")=""
QUIT
+23 SET DIE="^ABMDBILL(DUZ(2),"
SET DR=".26///"_ABMFR("ARLOC")
+24 DO ^DIE
End DoDot:1
+25 SET ABMFR("TRAN TYPE")=503
+26 SET ABMTEST=$$EN^BARFRAPI(.ABMFR)
+27 QUIT
PRO ;PROCEED
+1 WRITE !
+2 SET DIR(0)="Y"
SET DIR("A")="Proceed"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+3 QUIT
FIND(DA) ;find bill in A/R
+1 SET ABMARLOC=""
+2 SET ABMNAME=$PIECE(^ABMDBILL(DUZ(2),DA,0),U)
SET ABMLOC=$PIECE(^(0),"^",3)
+3 NEW I
+4 SET I=0
+5 FOR
SET I=$ORDER(^BARBL(I))
IF 'I
QUIT
Begin DoDot:1
+6 IF ABMARLOC'=""
QUIT
+7 SET ABMNXT=$ORDER(^BARBL(I,"B",ABMNAME))
+8 IF ABMNXT'[ABMNAME
QUIT
+9 SET ABMIEN=$ORDER(^BARBL(I,"B",ABMNXT,0))
+10 IF $PIECE(^BARBL(I,ABMIEN,0),"^",17)=DA
SET ABMARLOC=I_","_ABMIEN
End DoDot:1
+11 QUIT ABMARLOC
