ABMDTFPC ; IHS/SD/SDR - Apply per cent change to fee sched ;
;;2.6;IHS Third Party Billing System;**2,14,21,27**;NOV 12, 2009;Build 486
;IHS/SD/SDR 2.6*2 3PMS10003A modified to track changes in effective date multiples and who updated
;IHS/SD/SDR 2.6*21 HEAT112857 Fixed increase fee even when old data structure is incomplete.
;IHS/SD/SDR 2.6*27 CR8894 Fixed how it calculates fees; it was rounding everything off to a whole number which doesn't work for the Drugs section
;
START ;START
W !!,"This routine will apply a percentage increase or decrease to"
W !,"a selected segment or the entire fee schedule."
S DIR(0)="Y",DIR("A")="Continue",DIR("B")="NO" D ^DIR K DIR Q:Y'=1
S DIC="^ABMDFEE(",DIC(0)="AEMQ" D ^DIC Q:Y<0 S ABMFEE=+Y
ID ;INCREASE OR DECREASE
S DIR(0)="S^1:INCREASE;2:DECREASE",DIR("B")=1 D ^DIR K DIR Q:'Y S ABMID=Y,ABMIDNM=Y(0)
S DIR(0)="N^0.01:100:2",DIR("A")="Enter PERCENTAGE" D ^DIR K DIR Q:'Y S ABMPCT=+Y
S ABMMULT=$S(ABMID=1:1+(ABMPCT/100),1:(100-ABMPCT)/100)
;S DIR(0)="S^1:ALL;11:SURGERY;13:HCPCS;15:RADIOLOGY;17:LABORATORY;19:MEDICINE;21:DENTAL;23:ANESTHESIA;25:DRUG;31:ROOM & BOARD" ;abm*2.6*2 3PMS10003A
S DIR(0)="S^1:ALL;11:SURGERY;13:HCPCS;15:RADIOLOGY;17:LABORATORY;19:MEDICAL;21:DENTAL;23:ANESTHESIA;25:DRUG;31:REVENUE CODE (ROOM & BOARD)" ;abm*2.6*2 3PMS10003A
S DIR("A")="Select FEE SCHEDULE CATEGORY"
D ^DIR K DIR Q:'Y S ABMCAT=Y,ABMCNAME=Y(0)
;start new code abm*2.6*2 3PMS10003A
D ^XBFMK
S DIR(0)="D"
S DIR("A")="Effective Date of "_ABMIDNM
S DIR("B")="TODAY"
D ^DIR K DIR
Q:$D(DIRUT)
S ABMEDT=Y
;end new code 3PMS10003A
W !!,"I am going to apply a ",ABMPCT," percent ",ABMIDNM," to category ",ABMCNAME
;W !," for fee schedule #",ABMFEE,"." ;abm*2.6*2 3PMS10003A
W !," for fee schedule #",ABMFEE,", with an effective date of "_$$SDT^ABMDUTL(ABMEDT)_"." ;abm*2.6*2 3PMS10003A
S DIR(0)="Y",DIR("A")="ARE YOU SURE",DIR("B")="NO" D ^DIR K DIR Q:Y'=1
I ABMCAT'=1 D CAT1
I ABMCAT=1 D
.F ABMCAT=11,13,15,17,19,21,23,25,31 D CAT1
;start new code abm*2.6*2 3PMS10003A
D ^XBFMK
S DA(1)=ABMFEE
S DIC="^ABMDFEE("_DA(1)_",1,"
S DIC(0)="MQL"
S DIC("P")=$P(^DD(9002274.01,1,0),U,2)
D NOW^%DTC
S X=%
S DIC("DR")=".02////"_DUZ_";.04////"_$E(ABMIDNM,1)_";.05////"_ABMPCT
D ^DIC
;end new code 3PMS10003A
;start new abm*2.6*27 IHS/SD/SDR CR8894
;reindex all entries for look up
S DIK="^ABMDFEE("
S DA=ABMFEE
D IX^DIK
;end new abm*2.6*27 IHS/SD/SDR CR8894
W !!,"Finished.",!!
K ABMCAT,ABMFEE,ABMID,ABMMULT,ABMPCT,ABMCTR,ABMCNAME,ABMIDNM
S DIR(0)="E" D ^DIR K DIR
Q
CAT1 ;CHANGE FEES ONE CATEGORY
S ABMI=0
F S ABMI=$O(^ABMDFEE(ABMFEE,ABMCAT,ABMI)) Q:'ABMI D
.S ABMCTR=+$G(ABMCTR)+1 W:'(ABMCTR#10) "."
.;start old abm*2.6*21 HEAT112857
.;S ABMOFE=$P(^ABMDFEE(ABMFEE,ABMCAT,ABMI,0),U,2)
.;S ABMNFE=ABMOFE*ABMMULT
.;S ABMNFE=ABMNFE+.5
.;S ABMNFE=ABMNFE\1
.;S $P(^ABMDFEE(ABMFEE,ABMCAT,ABMI,0),U,2)=ABMNFE
.;end old start new abm*2.6*21 IHS/SD/SDR HEAT112857
.S ABMOFE=+$P($G(^ABMDFEE(ABMFEE,ABMCAT,ABMI,0)),U,2)
.I ABMOFE'=0 D
..;start old abm*2.6*27 IHS/SD/SDR CR8894
..;S ABMNFE=ABMOFE*ABMMULT
..;S ABMNFE=ABMNFE+.5
..;S ABMNFE=ABMNFE\1
..;end old start abm*2.6*27 IHS/SD/SDR CR8894
..D ROUND ;abm*2.6*27 IHS/SD/SDR CR8894
..S $P(^ABMDFEE(ABMFEE,ABMCAT,ABMI,0),U,2)=ABMNFE
.;end new abm*2.6*21 IHS/SD/SDR HEAT112857
.D EFFDT
Q
;start new code abm*2.6*2 3PMS10003A
;
;start new abm*2.6*27 IHS/SD/SDR CR8894
ROUND ;EP
I ABMCAT'=25 D
.S ABMNFE=ABMOFE*ABMMULT
.S ABMNFE=ABMNFE+.5
.S ABMNFE=ABMNFE\1
I ABMCAT=25 D
.S ABMNFE=ABMOFE*ABMMULT
.S ABMDEC=$L($P(ABMOFE,".",2))
.S ABMNFE=$J(ABMNFE,0,ABMDEC)
Q
;end new abm*2.6*27 IHS/SD/SDR CR8894
;
EFFDT ;
D GETFEES
;
S ABMTFE=ABMTFE*ABMMULT
S ABMTFE=ABMTFE+.5
S ABMTFE=ABMTFE\1
;
S ABMPFE=ABMPFE*ABMMULT
S ABMPFE=ABMPFE+.5
S ABMPFE=ABMPFE\1
;
D ^XBFMK
S DA(2)=ABMFEE
S DA(1)=ABMI
S DIC="^ABMDFEE("_DA(2)_","_ABMCAT_","_DA(1)_",1,"
S DIC(0)="L"
S DIC("P")=$P(^DD(9002274.01_ABMCAT,1,0),U,2)
S X=ABMEDT
D ^DIC
S ABMENTRY=+Y
D ^XBFMK
S DA(2)=ABMFEE
S DA(1)=ABMI
S DIE="^ABMDFEE("_DA(2)_","_ABMCAT_","_DA(1)_",1,"
S DA=ABMENTRY
S DR=".02////"_ABMNFE
S DR=DR_";.03////"_ABMTFE
S DR=DR_";.04////"_ABMPFE
S DR=DR_";.05////"_DT_";.06////"_DUZ
D ^DIE
Q
GETFEES ;
S ABMDT=0
F S ABMDT=$O(^ABMDFEE(ABMFEE,ABMCAT,ABMI,1,"B",ABMDT)) Q:(+$G(ABMDT)=0) D
.S ABMDIEN=0
.F S ABMDIEN=$O(^ABMDFEE(ABMFEE,ABMCAT,ABMI,1,"B",ABMDT,ABMDIEN)) Q:(+$G(ABMDIEN)=0) D
..;start new abm*2.6*21 IHS/SD/SDR HEAT112857
..I ABMOFE=0 D
...S ABMOFE=+$P($G(^ABMDFEE(ABMFEE,ABMCAT,ABMI,1,ABMDIEN,0)),U,2)
...;start old abm*2.6*27 IHS/SD/SDR CR8894
...;S ABMNFE=ABMOFE*ABMMULT
...;S ABMNFE=ABMNFE+.5
...;S ABMNFE=ABMNFE\1
...;end old abm*2.6*27 IHS/SD/SDR CR8894
...D ROUND ;abm*2.6*27 IHS/SD/SDR CR8894
...;S ^ABMDFEE(ABMFEE,ABMCAT,ABMI,0)=ABMI_U_ABMNFE_U_ABMEDT ;abm*2.6*27 IHS/SD/SDR CR8894
...S $P(^ABMDFEE(ABMFEE,ABMCAT,ABMI,0),U,2)=ABMNFE ;abm*2.6*27 IHS/SD/SDR CR8894
...S $P(^ABMDFEE(ABMFEE,ABMCAT,ABMI,0),U,3)=ABMEDT ;abm*2.6*27 IHS/SD/SDR CR8894
..;end new abm*2.6*21 IHS/SD/SDR HEAT112857
..S ABMTFE=+$P($G(^ABMDFEE(ABMFEE,ABMCAT,ABMI,1,ABMDIEN,0)),U,3) ;technical charge
..S ABMPFE=+$P($G(^ABMDFEE(ABMFEE,ABMCAT,ABMI,1,ABMDIEN,0)),U,4) ;professional charge
Q
;end new code 3PMS10003A
ABMDTFPC ; IHS/SD/SDR - Apply per cent change to fee sched ;
+1 ;;2.6;IHS Third Party Billing System;**2,14,21,27**;NOV 12, 2009;Build 486
+2 ;IHS/SD/SDR 2.6*2 3PMS10003A modified to track changes in effective date multiples and who updated
+3 ;IHS/SD/SDR 2.6*21 HEAT112857 Fixed increase fee even when old data structure is incomplete.
+4 ;IHS/SD/SDR 2.6*27 CR8894 Fixed how it calculates fees; it was rounding everything off to a whole number which doesn't work for the Drugs section
+5 ;
START ;START
+1 WRITE !!,"This routine will apply a percentage increase or decrease to"
+2 WRITE !,"a selected segment or the entire fee schedule."
+3 SET DIR(0)="Y"
SET DIR("A")="Continue"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF Y'=1
QUIT
+4 SET DIC="^ABMDFEE("
SET DIC(0)="AEMQ"
DO ^DIC
IF Y<0
QUIT
SET ABMFEE=+Y
ID ;INCREASE OR DECREASE
+1 SET DIR(0)="S^1:INCREASE;2:DECREASE"
SET DIR("B")=1
DO ^DIR
KILL DIR
IF 'Y
QUIT
SET ABMID=Y
SET ABMIDNM=Y(0)
+2 SET DIR(0)="N^0.01:100:2"
SET DIR("A")="Enter PERCENTAGE"
DO ^DIR
KILL DIR
IF 'Y
QUIT
SET ABMPCT=+Y
+3 SET ABMMULT=$SELECT(ABMID=1:1+(ABMPCT/100),1:(100-ABMPCT)/100)
+4 ;S DIR(0)="S^1:ALL;11:SURGERY;13:HCPCS;15:RADIOLOGY;17:LABORATORY;19:MEDICINE;21:DENTAL;23:ANESTHESIA;25:DRUG;31:ROOM & BOARD" ;abm*2.6*2 3PMS10003A
+5 ;abm*2.6*2 3PMS10003A
SET DIR(0)="S^1:ALL;11:SURGERY;13:HCPCS;15:RADIOLOGY;17:LABORATORY;19:MEDICAL;21:DENTAL;23:ANESTHESIA;25:DRUG;31:REVENUE CODE (ROOM & BOARD)"
+6 SET DIR("A")="Select FEE SCHEDULE CATEGORY"
+7 DO ^DIR
KILL DIR
IF 'Y
QUIT
SET ABMCAT=Y
SET ABMCNAME=Y(0)
+8 ;start new code abm*2.6*2 3PMS10003A
+9 DO ^XBFMK
+10 SET DIR(0)="D"
+11 SET DIR("A")="Effective Date of "_ABMIDNM
+12 SET DIR("B")="TODAY"
+13 DO ^DIR
KILL DIR
+14 IF $DATA(DIRUT)
QUIT
+15 SET ABMEDT=Y
+16 ;end new code 3PMS10003A
+17 WRITE !!,"I am going to apply a ",ABMPCT," percent ",ABMIDNM," to category ",ABMCNAME
+18 ;W !," for fee schedule #",ABMFEE,"." ;abm*2.6*2 3PMS10003A
+19 ;abm*2.6*2 3PMS10003A
WRITE !," for fee schedule #",ABMFEE,", with an effective date of "_$$SDT^ABMDUTL(ABMEDT)_"."
+20 SET DIR(0)="Y"
SET DIR("A")="ARE YOU SURE"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF Y'=1
QUIT
+21 IF ABMCAT'=1
DO CAT1
+22 IF ABMCAT=1
Begin DoDot:1
+23 FOR ABMCAT=11,13,15,17,19,21,23,25,31
DO CAT1
End DoDot:1
+24 ;start new code abm*2.6*2 3PMS10003A
+25 DO ^XBFMK
+26 SET DA(1)=ABMFEE
+27 SET DIC="^ABMDFEE("_DA(1)_",1,"
+28 SET DIC(0)="MQL"
+29 SET DIC("P")=$PIECE(^DD(9002274.01,1,0),U,2)
+30 DO NOW^%DTC
+31 SET X=%
+32 SET DIC("DR")=".02////"_DUZ_";.04////"_$EXTRACT(ABMIDNM,1)_";.05////"_ABMPCT
+33 DO ^DIC
+34 ;end new code 3PMS10003A
+35 ;start new abm*2.6*27 IHS/SD/SDR CR8894
+36 ;reindex all entries for look up
+37 SET DIK="^ABMDFEE("
+38 SET DA=ABMFEE
+39 DO IX^DIK
+40 ;end new abm*2.6*27 IHS/SD/SDR CR8894
+41 WRITE !!,"Finished.",!!
+42 KILL ABMCAT,ABMFEE,ABMID,ABMMULT,ABMPCT,ABMCTR,ABMCNAME,ABMIDNM
+43 SET DIR(0)="E"
DO ^DIR
KILL DIR
+44 QUIT
CAT1 ;CHANGE FEES ONE CATEGORY
+1 SET ABMI=0
+2 FOR
SET ABMI=$ORDER(^ABMDFEE(ABMFEE,ABMCAT,ABMI))
IF 'ABMI
QUIT
Begin DoDot:1
+3 SET ABMCTR=+$GET(ABMCTR)+1
IF '(ABMCTR#10)
WRITE "."
+4 ;start old abm*2.6*21 HEAT112857
+5 ;S ABMOFE=$P(^ABMDFEE(ABMFEE,ABMCAT,ABMI,0),U,2)
+6 ;S ABMNFE=ABMOFE*ABMMULT
+7 ;S ABMNFE=ABMNFE+.5
+8 ;S ABMNFE=ABMNFE\1
+9 ;S $P(^ABMDFEE(ABMFEE,ABMCAT,ABMI,0),U,2)=ABMNFE
+10 ;end old start new abm*2.6*21 IHS/SD/SDR HEAT112857
+11 SET ABMOFE=+$PIECE($GET(^ABMDFEE(ABMFEE,ABMCAT,ABMI,0)),U,2)
+12 IF ABMOFE'=0
Begin DoDot:2
+13 ;start old abm*2.6*27 IHS/SD/SDR CR8894
+14 ;S ABMNFE=ABMOFE*ABMMULT
+15 ;S ABMNFE=ABMNFE+.5
+16 ;S ABMNFE=ABMNFE\1
+17 ;end old start abm*2.6*27 IHS/SD/SDR CR8894
+18 ;abm*2.6*27 IHS/SD/SDR CR8894
DO ROUND
+19 SET $PIECE(^ABMDFEE(ABMFEE,ABMCAT,ABMI,0),U,2)=ABMNFE
End DoDot:2
+20 ;end new abm*2.6*21 IHS/SD/SDR HEAT112857
+21 DO EFFDT
End DoDot:1
+22 QUIT
+23 ;start new code abm*2.6*2 3PMS10003A
+24 ;
+25 ;start new abm*2.6*27 IHS/SD/SDR CR8894
ROUND ;EP
+1 IF ABMCAT'=25
Begin DoDot:1
+2 SET ABMNFE=ABMOFE*ABMMULT
+3 SET ABMNFE=ABMNFE+.5
+4 SET ABMNFE=ABMNFE\1
End DoDot:1
+5 IF ABMCAT=25
Begin DoDot:1
+6 SET ABMNFE=ABMOFE*ABMMULT
+7 SET ABMDEC=$LENGTH($PIECE(ABMOFE,".",2))
+8 SET ABMNFE=$JUSTIFY(ABMNFE,0,ABMDEC)
End DoDot:1
+9 QUIT
+10 ;end new abm*2.6*27 IHS/SD/SDR CR8894
+11 ;
EFFDT ;
+1 DO GETFEES
+2 ;
+3 SET ABMTFE=ABMTFE*ABMMULT
+4 SET ABMTFE=ABMTFE+.5
+5 SET ABMTFE=ABMTFE\1
+6 ;
+7 SET ABMPFE=ABMPFE*ABMMULT
+8 SET ABMPFE=ABMPFE+.5
+9 SET ABMPFE=ABMPFE\1
+10 ;
+11 DO ^XBFMK
+12 SET DA(2)=ABMFEE
+13 SET DA(1)=ABMI
+14 SET DIC="^ABMDFEE("_DA(2)_","_ABMCAT_","_DA(1)_",1,"
+15 SET DIC(0)="L"
+16 SET DIC("P")=$PIECE(^DD(9002274.01_ABMCAT,1,0),U,2)
+17 SET X=ABMEDT
+18 DO ^DIC
+19 SET ABMENTRY=+Y
+20 DO ^XBFMK
+21 SET DA(2)=ABMFEE
+22 SET DA(1)=ABMI
+23 SET DIE="^ABMDFEE("_DA(2)_","_ABMCAT_","_DA(1)_",1,"
+24 SET DA=ABMENTRY
+25 SET DR=".02////"_ABMNFE
+26 SET DR=DR_";.03////"_ABMTFE
+27 SET DR=DR_";.04////"_ABMPFE
+28 SET DR=DR_";.05////"_DT_";.06////"_DUZ
+29 DO ^DIE
+30 QUIT
GETFEES ;
+1 SET ABMDT=0
+2 FOR
SET ABMDT=$ORDER(^ABMDFEE(ABMFEE,ABMCAT,ABMI,1,"B",ABMDT))
IF (+$GET(ABMDT)=0)
QUIT
Begin DoDot:1
+3 SET ABMDIEN=0
+4 FOR
SET ABMDIEN=$ORDER(^ABMDFEE(ABMFEE,ABMCAT,ABMI,1,"B",ABMDT,ABMDIEN))
IF (+$GET(ABMDIEN)=0)
QUIT
Begin DoDot:2
+5 ;start new abm*2.6*21 IHS/SD/SDR HEAT112857
+6 IF ABMOFE=0
Begin DoDot:3
+7 SET ABMOFE=+$PIECE($GET(^ABMDFEE(ABMFEE,ABMCAT,ABMI,1,ABMDIEN,0)),U,2)
+8 ;start old abm*2.6*27 IHS/SD/SDR CR8894
+9 ;S ABMNFE=ABMOFE*ABMMULT
+10 ;S ABMNFE=ABMNFE+.5
+11 ;S ABMNFE=ABMNFE\1
+12 ;end old abm*2.6*27 IHS/SD/SDR CR8894
+13 ;abm*2.6*27 IHS/SD/SDR CR8894
DO ROUND
+14 ;S ^ABMDFEE(ABMFEE,ABMCAT,ABMI,0)=ABMI_U_ABMNFE_U_ABMEDT ;abm*2.6*27 IHS/SD/SDR CR8894
+15 ;abm*2.6*27 IHS/SD/SDR CR8894
SET $PIECE(^ABMDFEE(ABMFEE,ABMCAT,ABMI,0),U,2)=ABMNFE
+16 ;abm*2.6*27 IHS/SD/SDR CR8894
SET $PIECE(^ABMDFEE(ABMFEE,ABMCAT,ABMI,0),U,3)=ABMEDT
End DoDot:3
+17 ;end new abm*2.6*21 IHS/SD/SDR HEAT112857
+18 ;technical charge
SET ABMTFE=+$PIECE($GET(^ABMDFEE(ABMFEE,ABMCAT,ABMI,1,ABMDIEN,0)),U,3)
+19 ;professional charge
SET ABMPFE=+$PIECE($GET(^ABMDFEE(ABMFEE,ABMCAT,ABMI,1,ABMDIEN,0)),U,4)
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;end new code 3PMS10003A
