ABMDTFEF.m

ABMDTFEF ; IHS/ASDST/DMJ - ADJUST FEE SCHED BY FACTOR ;

 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009

 ;

FEE ;G XIT:$P(^AUTTLOC(ABM("SITE"),0),U,10)'=30,XIT:$D(^ABMDPARM(DUZ(2),1,0))

 W !!?5,"This utility will adjust the IHS Standard Fee Schedule by the factor",!?5,"specified (if entered) in the following prompt."

 S ABM("OLD")=$S($P(^ABMDFEE(1,0),U,3):$P(^(0),U,3),1:1)

 W !!?10,"The Current Adjustment Factor = ",ABM("OLD"),!

 K DIR S DIR(0)="NO^.25:10:2",DIR("A")="Enter the Desired ADJUSTMENT FACTOR" D ^DIR

 G XIT:$D(DIRUT)!$D(DIROUT)

 S ABM("FAC")=+Y

 S ABM("FAC")=ABM("FAC")/ABM("OLD") G XIT:ABM("FAC")=1

 ;

ENT ;EP - for updating the fee schedule

 W !!,"Updating FEE SCHEDULE."

 S DA(1)=1 F ABM("S")=11,15,17,19,21,23,31 D  Q:$D(ABM("DIE-FAIL"))

 .S DA=0 F ABM("I")=1:1 S DA=$O(^ABMDFEE(1,ABM("S"),DA)) Q:'DA  D  Q:$D(ABM("DIE-FAIL"))

 ..S DIE="^ABMDFEE(1,"_ABM("S")_",",DR=".02////"_$FN($P(^ABMDFEE(1,ABM("S"),DA,0),U,2)*ABM("FAC"),"T",2) D ^ABMDDIE W:'(ABM("I")#20) "."

 S $P(^ABMDFEE(1,0),U,3)=ABM("FAC")

 ;

XIT K ABM

 Q

ABMDTFEF  ; IHS/ASDST/DMJ - ADJUST FEE SCHED BY FACTOR ;

 +1       ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009

 +2       ;

FEE       ;G XIT:$P(^AUTTLOC(ABM("SITE"),0),U,10)'=30,XIT:$D(^ABMDPARM(DUZ(2),1,0))

 +1        WRITE !!?5,"This utility will adjust the IHS Standard Fee Schedule by the factor",!?5,"specified (if entered) in the following prompt."

 +2        SET ABM("OLD")=$SELECT($PIECE(^ABMDFEE(1,0),U,3):$PIECE(^(0),U,3),1:1)

 +3        WRITE !!?10,"The Current Adjustment Factor = ",ABM("OLD"),!

 +4        KILL DIR

           SET DIR(0)="NO^.25:10:2"

           SET DIR("A")="Enter the Desired ADJUSTMENT FACTOR"

           DO ^DIR

 +5        IF $DATA(DIRUT)!$DATA(DIROUT)

               GOTO XIT

 +6        SET ABM("FAC")=+Y

 +7        SET ABM("FAC")=ABM("FAC")/ABM("OLD")

           IF ABM("FAC")=1

               GOTO XIT

 +8       ;

ENT       ;EP - for updating the fee schedule

 +1        WRITE !!,"Updating FEE SCHEDULE."

 +2        SET DA(1)=1

           FOR ABM("S")=11,15,17,19,21,23,31

               Begin DoDot:1

 +3                SET DA=0

                   FOR ABM("I")=1:1

                       SET DA=$ORDER(^ABMDFEE(1,ABM("S"),DA))

                       IF 'DA

                           QUIT 

                       Begin DoDot:2

 +4                        SET DIE="^ABMDFEE(1,"_ABM("S")_","

                           SET DR=".02////"_$FNUMBER($PIECE(^ABMDFEE(1,ABM("S"),DA,0),U,2)*ABM("FAC"),"T",2)

                           DO ^ABMDDIE

                           IF '(ABM("I")#20)

                               WRITE "."

                       End DoDot:2

                       IF $DATA(ABM("DIE-FAIL"))

                           QUIT 

               End DoDot:1

               IF $DATA(ABM("DIE-FAIL"))

                   QUIT 

 +5        SET $PIECE(^ABMDFEE(1,0),U,3)=ABM("FAC")

 +6       ;

XIT        KILL ABM

 +1        QUIT