ABMDFAWP ; IHS/ASDST/DMJ - IMPORT AWP FROM DRUG FILE ;
;;2.6;IHS Third Party Billing System;**2**;NOV 09, 2009
; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - put data in new effective date multiple
START ;START
K ABMID
W !!,"This option will transfer the AWP price per dispense unit"
W !,"or the cost per dispense unit from the drug file to the Third"
W !,"Party Billing Fee Table, and will apply an optional user specified"
W !,"percentage increase or decrease.",!!
W $$EN^ABMVDF("RVN"),"NOTE:",$$EN^ABMVDF("RVF")," We advise saving global ABMDFEE before continuing.",!
S DIR(0)="Y"
S DIR("A")="Continue"
S DIR("B")="NO"
D ^DIR K DIR Q:Y'=1
W !
S DIC="^ABMDFEE("
S DIC(0)="AEMQ"
S DIC("A")="Update which Fee Table Entry? "
S DIC("B")=1
D ^DIC
Q:Y<0
S ABMTABLE=+Y
S DIR(0)="S^1:Average Wholesale Price (AWP) per Dispense Unit (field# 9999999.32);2:Price (cost) per Dispense Unit (field# 16)"
S DIR("A")="Select Field from Drug File to Transfer"
S DIR("B")=1
D ^DIR K DIR
Q:'Y
S ABMFIELD=+Y
;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
W !
S DIR(0)="Y"
S DIR("A")="Apply percentage increase or decrease"
S DIR("B")="NO"
D ^DIR K DIR
I Y D
.S DIR(0)="S^1:INCREASE;2:DECREASE" D ^DIR K DIR Q:'Y
.S ABMID=Y
.S DIR(0)="N^0:"_$S(ABMID=1:99999,1:100)
.S DIR("A")="Enter percent"
.S DIR("B")=10
.D ^DIR K DIR
.S ABMPCT=+Y
.S ABMOPCT=ABMPCT ;store what user entered ;abm*2.6*2 3PMS10003A
W !!,"I will move the ",$P("Average Wholesale Price per Dispense Unit^Price (cost) per Dispense Unit","^",ABMFIELD)," field from the "
;W !,"Drug File to the 3P Fee Table.",! ;abm*2.6*2 3PMS10003A
W !,"Drug File to the 3P Fee Table with an effective date of "_$$SDT^ABMDUTL(ABMEDT)_".",! ;abm*2.6*2 3PMS10003A
I $G(ABMID) D
.W !,"I will apply a ",ABMPCT," percent ",$P("increase^decrease","^",ABMID),".",!
S DIR(0)="Y"
S DIR("A")="Continue",DIR("B")="NO"
D ^DIR K DIR
Q:Y'=1
S ABMSUB=$S(ABMFIELD=1:999999931,1:660)
S ABMPCE=$S(ABMFIELD=1:2,1:6)
I $G(ABMID)=2 D
.S ABMPCT=100-ABMPCT
.S ABMPCT=ABMPCT/100
I $G(ABMID)=1 D
.S ABMPCT=ABMPCT/100
.S ABMPCT=1+ABMPCT
LOOP ;LOOP THROUGH DRUG FILE
;S DA(1)=ABMTABLE ;abm*2.6*2 3PMS10003A
;S DIE="^ABMDFEE(DA(1),25," ;abm*2.6*2 3PMS10003A
I '$D(^ABMDFEE(ABMTABLE,25,0)) S ^ABMDFEE(ABMTABLE,25,0)="^9002274.0125P" ;abm*2.6*2 3PMS10003A
S ABMI=0
F S ABMI=$O(^PSDRUG(ABMI)) Q:'ABMI D
.S ABMPRICE=$P($G(^PSDRUG(ABMI,ABMSUB)),U,ABMPCE)
.I $G(ABMID) D
..S ABMPRICE=ABMPRICE*ABMPCT
..S ABMPRICE=$J(ABMPRICE,1,3)
.S:+ABMPRICE<0 ABMPRICE=0
.Q:'ABMPRICE
.I '$D(^ABMDFEE(ABMTABLE,25,ABMI)) D
..S ^ABMDFEE(ABMTABLE,25,ABMI,0)=ABMI
..S ^ABMDFEE(ABMTABLE,25,"B",ABMI,ABMI)=""
.D ^XBFMK ;abm*2.6*2 3PMS10003A
.S DA(1)=ABMTABLE ;abm*2.6*2 3PMS10003A
.S DIE="^ABMDFEE("_DA(1)_",25," ;abm*2.6*2 3PMS10003A
.S DR=".02///"_ABMPRICE
.S DA=ABMI
.D ^DIE
.D EFFDT
.W "."
;start new code abm*2.6*2 3PMS10003A
D ^XBFMK
S DA(1)=ABMTABLE
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
I +$G(ABMPCT)'=0 S DIC("DR")=DIC("DR")_";.04////"_$S(ABMID=1:"I",1:"D")_";.05////"_ABMOPCT
D ^DIC
;end new code 3PMS10003A
K DIC,ABMPRICE,ABMPCT,ABMID,ABMSUB,ABMI,ABMPCE
W !!,"Finished.",!
S DIR(0)="E" D ^DIR K DIR
Q
;start new code abm*2.6*2 3PMS10003A
EFFDT ;
D ^XBFMK
S DA(2)=ABMTABLE
S DA(1)=ABMI
S DIC="^ABMDFEE("_DA(2)_",25,"_DA(1)_",1,"
S DIC(0)="L"
S DIC("P")=$P(^DD(9002274.0125,1,0),U,2)
S X=ABMEDT
D ^DIC
S ABMENTRY=+Y
D ^XBFMK
S DA(2)=ABMTABLE
S DA(1)=ABMI
S DIE="^ABMDFEE("_DA(2)_",25,"_DA(1)_",1,"
S DA=ABMENTRY
S DR=".02////"_ABMPRICE
S DR=DR_";.05////"_DT_";.06////"_DUZ
D ^DIE
Q
;end new code 3PMS10003A
ABMDFAWP ; IHS/ASDST/DMJ - IMPORT AWP FROM DRUG FILE ;
+1 ;;2.6;IHS Third Party Billing System;**2**;NOV 09, 2009
+2 ; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - put data in new effective date multiple
START ;START
+1 KILL ABMID
+2 WRITE !!,"This option will transfer the AWP price per dispense unit"
+3 WRITE !,"or the cost per dispense unit from the drug file to the Third"
+4 WRITE !,"Party Billing Fee Table, and will apply an optional user specified"
+5 WRITE !,"percentage increase or decrease.",!!
+6 WRITE $$EN^ABMVDF("RVN"),"NOTE:",$$EN^ABMVDF("RVF")," We advise saving global ABMDFEE before continuing.",!
+7 SET DIR(0)="Y"
+8 SET DIR("A")="Continue"
+9 SET DIR("B")="NO"
+10 DO ^DIR
KILL DIR
IF Y'=1
QUIT
+11 WRITE !
+12 SET DIC="^ABMDFEE("
+13 SET DIC(0)="AEMQ"
+14 SET DIC("A")="Update which Fee Table Entry? "
+15 SET DIC("B")=1
+16 DO ^DIC
+17 IF Y<0
QUIT
+18 SET ABMTABLE=+Y
+19 SET DIR(0)="S^1:Average Wholesale Price (AWP) per Dispense Unit (field# 9999999.32);2:Price (cost) per Dispense Unit (field# 16)"
+20 SET DIR("A")="Select Field from Drug File to Transfer"
+21 SET DIR("B")=1
+22 DO ^DIR
KILL DIR
+23 IF 'Y
QUIT
+24 SET ABMFIELD=+Y
+25 ;start new code abm*2.6*2 3PMS10003A
+26 DO ^XBFMK
+27 SET DIR(0)="D"
+28 SET DIR("A")="What is the effective date? "
+29 SET DIR("B")="TODAY"
+30 DO ^DIR
KILL DIR
+31 IF $DATA(DIRUT)
QUIT
+32 SET ABMEDT=Y
+33 ;end new code 3PMS10003A
+34 WRITE !
+35 SET DIR(0)="Y"
+36 SET DIR("A")="Apply percentage increase or decrease"
+37 SET DIR("B")="NO"
+38 DO ^DIR
KILL DIR
+39 IF Y
Begin DoDot:1
+40 SET DIR(0)="S^1:INCREASE;2:DECREASE"
DO ^DIR
KILL DIR
IF 'Y
QUIT
+41 SET ABMID=Y
+42 SET DIR(0)="N^0:"_$SELECT(ABMID=1:99999,1:100)
+43 SET DIR("A")="Enter percent"
+44 SET DIR("B")=10
+45 DO ^DIR
KILL DIR
+46 SET ABMPCT=+Y
+47 ;store what user entered ;abm*2.6*2 3PMS10003A
SET ABMOPCT=ABMPCT
End DoDot:1
+48 WRITE !!,"I will move the ",$PIECE("Average Wholesale Price per Dispense Unit^Price (cost) per Dispense Unit","^",ABMFIELD)," field from the "
+49 ;W !,"Drug File to the 3P Fee Table.",! ;abm*2.6*2 3PMS10003A
+50 ;abm*2.6*2 3PMS10003A
WRITE !,"Drug File to the 3P Fee Table with an effective date of "_$$SDT^ABMDUTL(ABMEDT)_".",!
+51 IF $GET(ABMID)
Begin DoDot:1
+52 WRITE !,"I will apply a ",ABMPCT," percent ",$PIECE("increase^decrease","^",ABMID),".",!
End DoDot:1
+53 SET DIR(0)="Y"
+54 SET DIR("A")="Continue"
SET DIR("B")="NO"
+55 DO ^DIR
KILL DIR
+56 IF Y'=1
QUIT
+57 SET ABMSUB=$SELECT(ABMFIELD=1:999999931,1:660)
+58 SET ABMPCE=$SELECT(ABMFIELD=1:2,1:6)
+59 IF $GET(ABMID)=2
Begin DoDot:1
+60 SET ABMPCT=100-ABMPCT
+61 SET ABMPCT=ABMPCT/100
End DoDot:1
+62 IF $GET(ABMID)=1
Begin DoDot:1
+63 SET ABMPCT=ABMPCT/100
+64 SET ABMPCT=1+ABMPCT
End DoDot:1
LOOP ;LOOP THROUGH DRUG FILE
+1 ;S DA(1)=ABMTABLE ;abm*2.6*2 3PMS10003A
+2 ;S DIE="^ABMDFEE(DA(1),25," ;abm*2.6*2 3PMS10003A
+3 ;abm*2.6*2 3PMS10003A
IF '$DATA(^ABMDFEE(ABMTABLE,25,0))
SET ^ABMDFEE(ABMTABLE,25,0)="^9002274.0125P"
+4 SET ABMI=0
+5 FOR
SET ABMI=$ORDER(^PSDRUG(ABMI))
IF 'ABMI
QUIT
Begin DoDot:1
+6 SET ABMPRICE=$PIECE($GET(^PSDRUG(ABMI,ABMSUB)),U,ABMPCE)
+7 IF $GET(ABMID)
Begin DoDot:2
+8 SET ABMPRICE=ABMPRICE*ABMPCT
+9 SET ABMPRICE=$JUSTIFY(ABMPRICE,1,3)
End DoDot:2
+10 IF +ABMPRICE<0
SET ABMPRICE=0
+11 IF 'ABMPRICE
QUIT
+12 IF '$DATA(^ABMDFEE(ABMTABLE,25,ABMI))
Begin DoDot:2
+13 SET ^ABMDFEE(ABMTABLE,25,ABMI,0)=ABMI
+14 SET ^ABMDFEE(ABMTABLE,25,"B",ABMI,ABMI)=""
End DoDot:2
+15 ;abm*2.6*2 3PMS10003A
DO ^XBFMK
+16 ;abm*2.6*2 3PMS10003A
SET DA(1)=ABMTABLE
+17 ;abm*2.6*2 3PMS10003A
SET DIE="^ABMDFEE("_DA(1)_",25,"
+18 SET DR=".02///"_ABMPRICE
+19 SET DA=ABMI
+20 DO ^DIE
+21 DO EFFDT
+22 WRITE "."
End DoDot:1
+23 ;start new code abm*2.6*2 3PMS10003A
+24 DO ^XBFMK
+25 SET DA(1)=ABMTABLE
+26 SET DIC="^ABMDFEE("_DA(1)_",1,"
+27 SET DIC(0)="MQL"
+28 SET DIC("P")=$PIECE(^DD(9002274.01,1,0),U,2)
+29 DO NOW^%DTC
+30 SET X=%
+31 SET DIC("DR")=".02////"_DUZ
+32 IF +$GET(ABMPCT)'=0
SET DIC("DR")=DIC("DR")_";.04////"_$SELECT(ABMID=1:"I",1:"D")_";.05////"_ABMOPCT
+33 DO ^DIC
+34 ;end new code 3PMS10003A
+35 KILL DIC,ABMPRICE,ABMPCT,ABMID,ABMSUB,ABMI,ABMPCE
+36 WRITE !!,"Finished.",!
+37 SET DIR(0)="E"
DO ^DIR
KILL DIR
+38 QUIT
+39 ;start new code abm*2.6*2 3PMS10003A
EFFDT ;
+1 DO ^XBFMK
+2 SET DA(2)=ABMTABLE
+3 SET DA(1)=ABMI
+4 SET DIC="^ABMDFEE("_DA(2)_",25,"_DA(1)_",1,"
+5 SET DIC(0)="L"
+6 SET DIC("P")=$PIECE(^DD(9002274.0125,1,0),U,2)
+7 SET X=ABMEDT
+8 DO ^DIC
+9 SET ABMENTRY=+Y
+10 DO ^XBFMK
+11 SET DA(2)=ABMTABLE
+12 SET DA(1)=ABMI
+13 SET DIE="^ABMDFEE("_DA(2)_",25,"_DA(1)_",1,"
+14 SET DA=ABMENTRY
+15 SET DR=".02////"_ABMPRICE
+16 SET DR=DR_";.05////"_DT_";.06////"_DUZ
+17 DO ^DIE
+18 QUIT
+19 ;end new code 3PMS10003A
