Routine: ABMDTFPC

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

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

 ;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)

 ;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

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

 ;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

ABMDTFPC.m