ABMDTASC.m

ABMDTASC ; IHS/ASDST/DMJ - UPDATE ASC FEE TABLE ; 

 ;;2.6;IHS Third Party Billing System;**2**;NOV 12, 2009

 ; IHS/SD/SDR - v2.5 p9 - IM12137 - Added code to put group 9 prompts in

 ; IHS/SD/SDR - v2.6 CSV

 ; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - modified to populated effective dates

 ;

START ;START

 W !!,$$EN^ABMVDF("RVN"),"NOTE:",$$EN^ABMVDF("RVF")

 W " We recommend doing a global save of global ^ABMDFEE before proceeding.",!!

 S DIC="^ABMDFEE(",DIC(0)="AEMNQ"

 S DIC("A")="Enter the Number of your ASC Fee Schedule: "

 S DIC("B")=2

 D ^DIC K DIC

 Q:+Y<0  S ABMJ=+Y

 D CURRATE

 D RATE

 Q:$D(DUOUT)!$D(DTOUT)

 S $P(ABMEQ,"=",80)=""

 W !!,ABMEQ,!

 F ABMI=1:1:9 W !,"Rate for ASC Payment Group ",ABMI,": $",ABM(ABMI)

 S DIR(0)="Y"

 S DIR("A")="Continue"

 S DIR("B")="NO"

 D ^DIR K DIR

 Q:Y'=1

 ;start new code abm*2.6*2 3PMS10003A

 D ^XBFMK

 S DIR(0)="D"

 S DIR("A")="What is the effective date? "

 S DIR("B")="TODAY"

 D ^DIR K DIR

 Q:$D(DIRUT)

 S ABMEDT=Y

 ;end new code 3PMS10003A

 D LOOP

 K ABMPG,ABMEQ

 ;start new code abm*2.6*2 3PMS10003A

 D ^XBFMK

 S DA(1)=ABMJ

 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_";.06////Y"

 D ^DIC

 ;end new code 3PMS10003A

 W !!,"Finished.",!!

 S DIR(0)="E" D ^DIR K DIR

 Q

CURRATE ;

 S ABMI=9999

 F  S ABMI=$O(^ICPT(ABMI)) Q:ABMI>69999  D

 .S ABMPG=$P($$IHSCPT^ABMCVAPI(ABMI,""),U,6)  ;CSV-c

 .Q:'ABMPG

 .Q:ABMPG>9

 .Q:'$D(^ABMDFEE(ABMJ,11,ABMI,0))

 .S ABMRATE(+ABMPG)=$P($G(^ABMDFEE(ABMJ,11,ABMI,0)),U,2)

 W !!,"CURRENT RATES"

 F ABMI=1:1:9 W !,?3,"Rate for ASC Payment Group ",ABMI,":$",+$G(ABMRATE(ABMI))

 W !

 K ABMRATE

 Q

RATE ;ENTER RATES FOR THE ASC PAYMENT GROUPS

 K DUOUT,DTOUT

 S DIR(0)="N"

 W !,"NEW RATES"

 F ABMI=1:1:9 D  Q:$D(DUOUT)!$D(DTOUT)

 .S DIR("A")="Enter Rate for ASC Payment Group #"_ABMI

 .D ^DIR

 .Q:$D(DUOUT)!$D(DTOUT)

 .S ABM(ABMI)=Y

 K DIR

 Q

LOOP ;LOOP THROUGH CPT SURGERY

 S ABMI=9999

 F  S ABMI=$O(^ICPT(ABMI)) Q:ABMI>69999  D

 .S ABMPG=$P($$IHSCPT^ABMCVAPI(ABMI,""),U,6)  ;CSV-c

 .Q:'ABMPG

 .Q:ABMPG>9

 .;I '$D(^ABMDFEE(ABMJ,11,ABMI,0)) D NEW Q:+Y<0  ;abm*2.6*2 3PMS10003A

 .I '$D(^ABMDFEE(ABMJ,11,ABMI,0)) D NEW  ;abm*2.6*2 3PMS10003A

 .S $P(^ABMDFEE(ABMJ,11,ABMI,0),U,2)=ABM(+ABMPG)

 .D EFFDT  ;abm*2.6*2 3PMS10003A

 .W "."

 Q

NEW ;NEW ENTRY IN FEE TABLE

 S ^ABMDFEE(ABMJ,11,ABMI,0)=ABMI

 S ^ABMDFEE(ABMJ,11,"B",ABMI,ABMI)=""

 Q

 ;start new code abm*2.6*2 3PMS10003A

EFFDT ;

 D ^XBFMK

 S DA(2)=ABMJ

 S DA(1)=ABMI

 S DIC="^ABMDFEE("_DA(2)_",11,"_DA(1)_",1,"

 S DIC(0)="L"

 S DIC("P")=$P(^DD(9002274.0111,1,0),U,2)

 S X=ABMEDT

 D ^DIC

 S ABMENTRY=+Y

 D ^XBFMK

 S DA(2)=ABMJ

 S DA(1)=ABMI

 S DIE="^ABMDFEE("_DA(2)_",11,"_DA(1)_",1,"

 S DA=ABMENTRY

 S DR=".02////"_ABM(+ABMPG)

 S DR=DR_";.05////"_DT_";.06////"_DUZ

 D ^DIE

 Q

 ;end new code 3PMS10003A

ABMDTASC  ; IHS/ASDST/DMJ - UPDATE ASC FEE TABLE ; 

 +1       ;;2.6;IHS Third Party Billing System;**2**;NOV 12, 2009

 +2       ; IHS/SD/SDR - v2.5 p9 - IM12137 - Added code to put group 9 prompts in

 +3       ; IHS/SD/SDR - v2.6 CSV

 +4       ; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - modified to populated effective dates

 +5       ;

START     ;START

 +1        WRITE !!,$$EN^ABMVDF("RVN"),"NOTE:",$$EN^ABMVDF("RVF")

 +2        WRITE " We recommend doing a global save of global ^ABMDFEE before proceeding.",!!

 +3        SET DIC="^ABMDFEE("

           SET DIC(0)="AEMNQ"

 +4        SET DIC("A")="Enter the Number of your ASC Fee Schedule: "

 +5        SET DIC("B")=2

 +6        DO ^DIC

           KILL DIC

 +7        IF +Y<0

               QUIT 

           SET ABMJ=+Y

 +8        DO CURRATE

 +9        DO RATE

 +10       IF $DATA(DUOUT)!$DATA(DTOUT)

               QUIT 

 +11       SET $PIECE(ABMEQ,"=",80)=""

 +12       WRITE !!,ABMEQ,!

 +13       FOR ABMI=1:1:9

               WRITE !,"Rate for ASC Payment Group ",ABMI,": $",ABM(ABMI)

 +14       SET DIR(0)="Y"

 +15       SET DIR("A")="Continue"

 +16       SET DIR("B")="NO"

 +17       DO ^DIR

           KILL DIR

 +18       IF Y'=1

               QUIT 

 +19      ;start new code abm*2.6*2 3PMS10003A

 +20       DO ^XBFMK

 +21       SET DIR(0)="D"

 +22       SET DIR("A")="What is the effective date? "

 +23       SET DIR("B")="TODAY"

 +24       DO ^DIR

           KILL DIR

 +25       IF $DATA(DIRUT)

               QUIT 

 +26       SET ABMEDT=Y

 +27      ;end new code 3PMS10003A

 +28       DO LOOP

 +29       KILL ABMPG,ABMEQ

 +30      ;start new code abm*2.6*2 3PMS10003A

 +31       DO ^XBFMK

 +32       SET DA(1)=ABMJ

 +33       SET DIC="^ABMDFEE("_DA(1)_",1,"

 +34       SET DIC(0)="MQL"

 +35       SET DIC("P")=$PIECE(^DD(9002274.01,1,0),U,2)

 +36       DO NOW^%DTC

 +37       SET X=%

 +38       SET DIC("DR")=".02////"_DUZ_";.06////Y"

 +39       DO ^DIC

 +40      ;end new code 3PMS10003A

 +41       WRITE !!,"Finished.",!!

 +42       SET DIR(0)="E"

           DO ^DIR

           KILL DIR

 +43       QUIT 

CURRATE   ;

 +1        SET ABMI=9999

 +2        FOR 

               SET ABMI=$ORDER(^ICPT(ABMI))

               IF ABMI>69999

                   QUIT 

               Begin DoDot:1

 +3       ;CSV-c

                   SET ABMPG=$PIECE($$IHSCPT^ABMCVAPI(ABMI,""),U,6)

 +4                IF 'ABMPG

                       QUIT 

 +5                IF ABMPG>9

                       QUIT 

 +6                IF '$DATA(^ABMDFEE(ABMJ,11,ABMI,0))

                       QUIT 

 +7                SET ABMRATE(+ABMPG)=$PIECE($GET(^ABMDFEE(ABMJ,11,ABMI,0)),U,2)

               End DoDot:1

 +8        WRITE !!,"CURRENT RATES"

 +9        FOR ABMI=1:1:9

               WRITE !,?3,"Rate for ASC Payment Group ",ABMI,":$",+$GET(ABMRATE(ABMI))

 +10       WRITE !

 +11       KILL ABMRATE

 +12       QUIT 

RATE      ;ENTER RATES FOR THE ASC PAYMENT GROUPS

 +1        KILL DUOUT,DTOUT

 +2        SET DIR(0)="N"

 +3        WRITE !,"NEW RATES"

 +4        FOR ABMI=1:1:9

               Begin DoDot:1

 +5                SET DIR("A")="Enter Rate for ASC Payment Group #"_ABMI

 +6                DO ^DIR

 +7                IF $DATA(DUOUT)!$DATA(DTOUT)

                       QUIT 

 +8                SET ABM(ABMI)=Y

               End DoDot:1

               IF $DATA(DUOUT)!$DATA(DTOUT)

                   QUIT 

 +9        KILL DIR

 +10       QUIT 

LOOP      ;LOOP THROUGH CPT SURGERY

 +1        SET ABMI=9999

 +2        FOR 

               SET ABMI=$ORDER(^ICPT(ABMI))

               IF ABMI>69999

                   QUIT 

               Begin DoDot:1

 +3       ;CSV-c

                   SET ABMPG=$PIECE($$IHSCPT^ABMCVAPI(ABMI,""),U,6)

 +4                IF 'ABMPG

                       QUIT 

 +5                IF ABMPG>9

                       QUIT 

 +6       ;I '$D(^ABMDFEE(ABMJ,11,ABMI,0)) D NEW Q:+Y<0  ;abm*2.6*2 3PMS10003A

 +7       ;abm*2.6*2 3PMS10003A

                   IF '$DATA(^ABMDFEE(ABMJ,11,ABMI,0))

                       DO NEW

 +8                SET $PIECE(^ABMDFEE(ABMJ,11,ABMI,0),U,2)=ABM(+ABMPG)

 +9       ;abm*2.6*2 3PMS10003A

                   DO EFFDT

 +10               WRITE "."

               End DoDot:1

 +11       QUIT 

NEW       ;NEW ENTRY IN FEE TABLE

 +1        SET ^ABMDFEE(ABMJ,11,ABMI,0)=ABMI

 +2        SET ^ABMDFEE(ABMJ,11,"B",ABMI,ABMI)=""

 +3        QUIT 

 +4       ;start new code abm*2.6*2 3PMS10003A

EFFDT     ;

 +1        DO ^XBFMK

 +2        SET DA(2)=ABMJ

 +3        SET DA(1)=ABMI

 +4        SET DIC="^ABMDFEE("_DA(2)_",11,"_DA(1)_",1,"

 +5        SET DIC(0)="L"

 +6        SET DIC("P")=$PIECE(^DD(9002274.0111,1,0),U,2)

 +7        SET X=ABMEDT

 +8        DO ^DIC

 +9        SET ABMENTRY=+Y

 +10       DO ^XBFMK

 +11       SET DA(2)=ABMJ

 +12       SET DA(1)=ABMI

 +13       SET DIE="^ABMDFEE("_DA(2)_",11,"_DA(1)_",1,"

 +14       SET DA=ABMENTRY

 +15       SET DR=".02////"_ABM(+ABMPG)

 +16       SET DR=DR_";.05////"_DT_";.06////"_DUZ

 +17       DO ^DIE

 +18       QUIT 

 +19      ;end new code 3PMS10003A