ABMDVST9 ; IHS/ASDST/DMJ - PCC VISIT STUFF IV PHARMACY ;
;;2.6;IHS Third Party Billing System;**2**;NOV 12, 2009
;;Y2K/OK - IHS/ADC/JLG 12-18-97
;Original;TMD;03/26/96 10:50 AM
;
;IHS/DSD/JLG 05/21/98 - NOIS NCA-0598-180077
; Modified to set corresponding diagnosis if only one POV
; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - modified to call ABMFEAPI
;
Q:ABMIDONE
Q:$D(ABMP("RXIVDONE"))
MED ;
N ABMPPDU,ABMQTY
S DA(1)=ABMP("CDFN"),DIC="^ABMDCLM(DUZ(2),"_DA(1)_",23,",DIC(0)="LE"
S ABM=0 F S ABM=$O(^PS(55,ABMP("PDFN"),"IV",ABM)) Q:'ABM I $G(^(ABM,9)) S ABM(9)=^(9) D
.I $D(ABMP("DDT")),$D(ABMP("ADMITDT")),+ABM(9)\1>ABMP("DDT")!((+ABM(9)\1)<ABMP("ADMITDT")) Q
.I '$D(ABMP("DDT")),+ABM(9)\1'=ABMCHVDT Q
.S ABM("TIME")=+ABMCHV0
.N DOC,OK,DIC,DR,DIQ,DA
.S OK=$D(ABMP("DDT"))
.I 'OK D
..S DOC=$P(^PS(55,ABMP("PDFN"),"IV",ABM,0),U,6)
..S DIC="^DD(55.01,"
..S DR=.3
..S DIQ="ABMDFP"
..S DIQ(0)="I"
..S DA=.06
..D EN^DIQ1
..S DIC="^DD(9000010.06,"
..S DIQ="ABMDFV"
..S DA=.01
..D EN^DIQ1
..I ABMDFP(0,.06,.3,"I")'=ABMDFV(0,.01,.3,"I") D
...S DOC=$G(^DIC(16,DOC,"A3"))
..;It is assumed that if the files point to different files only the
..;pharmacy one needs to converted to a file 200 value
..S D1=0,OK=0
..F S D1=$O(^AUPNVPRV("AD",ABMVDFN,D1)) Q:'D1 D Q:OK
...I $P(^AUPNVPRV(D1,0),U,1)=DOC S OK=1
.Q:'OK
.K X
.S ABM("FEE")=0
.;This is the IV subfile of the Pharmacy Patient File.
.S Y=^PS(55,ABMP("PDFN"),"IV",ABM,0)
.S ABM("ORDER#")=$P(Y,U,1)
.S ABM("TIME")=$P(Y,U,2)
.S ABM("TYPE")=$P(Y,"^",4)
.S ABM("TQTY")=$P(Y,"^",16)
.;ABM("TQTY")=Cumulative doses - not used
.S ABM("A")=0,ABM("T")="A" F S ABM("A")=$O(^PS(55,ABMP("PDFN"),"IV",ABM,"AD",ABM("A"))) Q:'ABM("A") S ABM(0)=^(ABM("A"),0) D
..;ABM(0) - Additive node
..;(#.01) ADDITIVE [1P] ^ (#.02) STRENGTH [2F] ^(#.03) BOTTLE [3F] ^
..;S ABM("QTY")=+$P(ABM(0),U,2)*$P(ABM(9),U,2)
..S ABMQTY=$S("PACSH"[ABM("TYPE"):+$P(ABM(0),U,2),1:1)*$P(ABM(9),U,3)
..;For piggybacks, admixtures, & chemo the strength is multiplied
..;times TOTAL IV'S ADMINISTERED to get ABMQTY. For others we use
..;just TOTAL IV'S ADMINISTERED.
..;The above line has been modified further to measure the quantity
..;the same for all IV's. It has been left in to make it easier
..;to modify.
..;ABM("QTY") - STRENGTH TIMES LAST QTY FILLED - not used
..I +ABM(0),$D(^PS(52.6,+ABM(0))) D
...S Y=^PS(52.6,+ABM(0),0)
...S ABMX=$P(Y,U,2)
...;The price per disp unit is obtained either from 3P fee table or
...;drug file.
...;S ABMPPDU=$S($D(^ABMDFEE(ABMP("FEE"),25,ABMX,0)):$P(^(0),U,2),1:$P($G(^PSDRUG(ABMX,660)),U,6)) ;abm*2.6*2 3PMS10003A
...S ABMPPDU=$S($D(^ABMDFEE(ABMP("FEE"),25,ABMX,0)):$P($$ONE^ABMFEAPI(ABMP("FEE"),25,ABMX,ABMP("VDT")),U),1:$P($G(^PSDRUG(ABMX,660)),U,6)) ;abm*2.6*2 3PMS10003A
...;Fee for each PPDU times ABMQTY (quantity) calculated above
...S ABM("FEE")=ABM("FEE")+(ABMPPDU*ABMQTY)
...;S ABM("FEE")=$G(ABM("FEE"))+($P(Y,U,7)*ABM("QTY"))
...I '$D(X),$D(^PSDRUG(ABMX,0)) S X=ABMX
..;ABMX - Generic Drug
..;7th Piece - average drug cost per unit
.S ABMSRC="PSIV|"_ABM_"|RX-AD"
.I $D(X),$D(^PSDRUG(X,0)) D MEDSET
.K X
.S ABM("FEE")=0
.S ABM("A")=0,ABM("T")="S" F S ABM("A")=$O(^PS(55,ABMP("PDFN"),"IV",ABM,"SOL",ABM("A"))) Q:'ABM("A") S ABM(0)=^(ABM("A"),0) D
..;ABM(0) - solution node
..S ABM("QTY")=+$P(ABM(0),U,2)*$P(ABM(9),U,2)
..;ABM("QTY") - VOLUME TIMES LAST QTY FILLED
..;^PS(52.7 is the IV solutions file.
..I +ABM(0),$D(^PS(52.7,+ABM(0))) D
...S Y=^PS(52.7,+ABM(0),0)
...S ABMX=$P(Y,U,2)
...;S ABMPPDU=$S($D(^ABMDFEE(ABMP("FEE"),25,ABMX,0)):$P(^(0),U,2),1:$P($G(^PSDRUG(ABMX,660)),U,6)) ;abm*2.6*2 3PMS10003A
...S ABMPPDU=$S($D(^ABMDFEE(ABMP("FEE"),25,ABMX,0)):$P($$ONE^ABMFEAPI(ABMP("FEE"),25,ABMX,ABMP("VDT")),U),1:$P($G(^PSDRUG(ABMX,660)),U,6)) ;abm*2.6*2 3PMS10003A
...;For solutions same as additives.
...S ABM("FEE")=ABM("FEE")+(ABMPPDU*$P(ABM(9),U,3))
...;S ABM("FEE")=$G(ABM("FEE"))+($P(Y,U,7)*ABM("QTY"))
...I '$D(X),$D(^PSDRUG(ABMX,0)) S X=ABMX
..;X - Generic drug
..;7th piece - Average drug cost
.S ABMSRC="PSIV|"_ABM_"|RX-SOL"
.I $D(X),$D(^PSDRUG(X,0)) D MEDSET
Q
;
MEDSET ;SET 3P CLAIM RX MULTIPLE
S ABMP("RXIVDONE")=1
S DA(1)=ABMP("CDFN")
S DIC="^ABMDCLM(DUZ(2),"_DA(1)_",23,",DIC(0)="LE"
S DA=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),"ASRC",ABMSRC,0))
I DA,'$D(@(DIC_DA_",0)")) S DA="" ;For duplicates problem
I 'DA D
.S DIC("P")=$P(^DD(9002274.3,23,0),U,2)
.; ENTER CORRECT DEFAULT REV CODE
.S DIC("DR")=".02////260" ;IHS/DSD/JLG 3/31/98
.K DD,DO D FILE^DICN S DA=+Y
.K DIC("DR") ;IHS/DSD/JLG 3/31/98
Q:DA<1 S DIE=DIC
D DFEE
S DR=".03////1;.04////"_+ABM("FEE")_";.05////"_+ABM("DISPFEE")_";.06////"_ABM("ORDER#") ;MODIFIED IHS/DSD/JLG 3/31/98
S DR=DR_";"_$S(ABM("T")="A":.07,1:.08)_"////"_(+ABM(0))_";.09///"_$P(ABM(0),U,2)
;Next line set correspond diagnosis if only 1 POV
I $D(ABMP("CORRSDIAG")) S DR=DR_";.13////1"
S DR=DR_";.15////"_ABM("TYPE")_";.14////"_ABM("TIME")
S DR=DR_";.17////"_ABMSRC
D ^DIE
K DR
Q
DFEE ;DISPENSE FEE
S ABM("DFPARM")=$G(^ABMDPARM(DUZ(2),1,4))
S ABM("DISPFEE")=+$P(ABM("DFPARM"),"^",$F("APHSC",ABM("TYPE")))
Q
ABMDVST9 ; IHS/ASDST/DMJ - PCC VISIT STUFF IV PHARMACY ;
+1 ;;2.6;IHS Third Party Billing System;**2**;NOV 12, 2009
+2 ;;Y2K/OK - IHS/ADC/JLG 12-18-97
+3 ;Original;TMD;03/26/96 10:50 AM
+4 ;
+5 ;IHS/DSD/JLG 05/21/98 - NOIS NCA-0598-180077
+6 ; Modified to set corresponding diagnosis if only one POV
+7 ; IHS/SD/SDR - abm*2.6*2 - 3PMS10003A - modified to call ABMFEAPI
+8 ;
+9 IF ABMIDONE
QUIT
+10 IF $DATA(ABMP("RXIVDONE"))
QUIT
MED ;
+1 NEW ABMPPDU,ABMQTY
+2 SET DA(1)=ABMP("CDFN")
SET DIC="^ABMDCLM(DUZ(2),"_DA(1)_",23,"
SET DIC(0)="LE"
+3 SET ABM=0
FOR
SET ABM=$ORDER(^PS(55,ABMP("PDFN"),"IV",ABM))
IF 'ABM
QUIT
IF $GET(^(ABM,9))
SET ABM(9)=^(9)
Begin DoDot:1
+4 IF $DATA(ABMP("DDT"))
IF $DATA(ABMP("ADMITDT"))
IF +ABM(9)\1>ABMP("DDT")!((+ABM(9)\1)<ABMP("ADMITDT"))
QUIT
+5 IF '$DATA(ABMP("DDT"))
IF +ABM(9)\1'=ABMCHVDT
QUIT
+6 SET ABM("TIME")=+ABMCHV0
+7 NEW DOC,OK,DIC,DR,DIQ,DA
+8 SET OK=$DATA(ABMP("DDT"))
+9 IF 'OK
Begin DoDot:2
+10 SET DOC=$PIECE(^PS(55,ABMP("PDFN"),"IV",ABM,0),U,6)
+11 SET DIC="^DD(55.01,"
+12 SET DR=.3
+13 SET DIQ="ABMDFP"
+14 SET DIQ(0)="I"
+15 SET DA=.06
+16 DO EN^DIQ1
+17 SET DIC="^DD(9000010.06,"
+18 SET DIQ="ABMDFV"
+19 SET DA=.01
+20 DO EN^DIQ1
+21 IF ABMDFP(0,.06,.3,"I")'=ABMDFV(0,.01,.3,"I")
Begin DoDot:3
+22 SET DOC=$GET(^DIC(16,DOC,"A3"))
End DoDot:3
+23 ;It is assumed that if the files point to different files only the
+24 ;pharmacy one needs to converted to a file 200 value
+25 SET D1=0
SET OK=0
+26 FOR
SET D1=$ORDER(^AUPNVPRV("AD",ABMVDFN,D1))
IF 'D1
QUIT
Begin DoDot:3
+27 IF $PIECE(^AUPNVPRV(D1,0),U,1)=DOC
SET OK=1
End DoDot:3
IF OK
QUIT
End DoDot:2
+28 IF 'OK
QUIT
+29 KILL X
+30 SET ABM("FEE")=0
+31 ;This is the IV subfile of the Pharmacy Patient File.
+32 SET Y=^PS(55,ABMP("PDFN"),"IV",ABM,0)
+33 SET ABM("ORDER#")=$PIECE(Y,U,1)
+34 SET ABM("TIME")=$PIECE(Y,U,2)
+35 SET ABM("TYPE")=$PIECE(Y,"^",4)
+36 SET ABM("TQTY")=$PIECE(Y,"^",16)
+37 ;ABM("TQTY")=Cumulative doses - not used
+38 SET ABM("A")=0
SET ABM("T")="A"
FOR
SET ABM("A")=$ORDER(^PS(55,ABMP("PDFN"),"IV",ABM,"AD",ABM("A")))
IF 'ABM("A")
QUIT
SET ABM(0)=^(ABM("A"),0)
Begin DoDot:2
+39 ;ABM(0) - Additive node
+40 ;(#.01) ADDITIVE [1P] ^ (#.02) STRENGTH [2F] ^(#.03) BOTTLE [3F] ^
+41 ;S ABM("QTY")=+$P(ABM(0),U,2)*$P(ABM(9),U,2)
+42 SET ABMQTY=$SELECT("PACSH"[ABM("TYPE"):+$PIECE(ABM(0),U,2),1:1)*$PIECE(ABM(9),U,3)
+43 ;For piggybacks, admixtures, & chemo the strength is multiplied
+44 ;times TOTAL IV'S ADMINISTERED to get ABMQTY. For others we use
+45 ;just TOTAL IV'S ADMINISTERED.
+46 ;The above line has been modified further to measure the quantity
+47 ;the same for all IV's. It has been left in to make it easier
+48 ;to modify.
+49 ;ABM("QTY") - STRENGTH TIMES LAST QTY FILLED - not used
+50 IF +ABM(0)
IF $DATA(^PS(52.6,+ABM(0)))
Begin DoDot:3
+51 SET Y=^PS(52.6,+ABM(0),0)
+52 SET ABMX=$PIECE(Y,U,2)
+53 ;The price per disp unit is obtained either from 3P fee table or
+54 ;drug file.
+55 ;S ABMPPDU=$S($D(^ABMDFEE(ABMP("FEE"),25,ABMX,0)):$P(^(0),U,2),1:$P($G(^PSDRUG(ABMX,660)),U,6)) ;abm*2.6*2 3PMS10003A
+56 ;abm*2.6*2 3PMS10003A
SET ABMPPDU=$SELECT($DATA(^ABMDFEE(ABMP("FEE"),25,ABMX,0)):$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),25,ABMX,ABMP("VDT")),U),1:$PIECE($GET(^PSDRUG(ABMX,660)),U,6))
+57 ;Fee for each PPDU times ABMQTY (quantity) calculated above
+58 SET ABM("FEE")=ABM("FEE")+(ABMPPDU*ABMQTY)
+59 ;S ABM("FEE")=$G(ABM("FEE"))+($P(Y,U,7)*ABM("QTY"))
+60 IF '$DATA(X)
IF $DATA(^PSDRUG(ABMX,0))
SET X=ABMX
End DoDot:3
+61 ;ABMX - Generic Drug
+62 ;7th Piece - average drug cost per unit
End DoDot:2
+63 SET ABMSRC="PSIV|"_ABM_"|RX-AD"
+64 IF $DATA(X)
IF $DATA(^PSDRUG(X,0))
DO MEDSET
+65 KILL X
+66 SET ABM("FEE")=0
+67 SET ABM("A")=0
SET ABM("T")="S"
FOR
SET ABM("A")=$ORDER(^PS(55,ABMP("PDFN"),"IV",ABM,"SOL",ABM("A")))
IF 'ABM("A")
QUIT
SET ABM(0)=^(ABM("A"),0)
Begin DoDot:2
+68 ;ABM(0) - solution node
+69 SET ABM("QTY")=+$PIECE(ABM(0),U,2)*$PIECE(ABM(9),U,2)
+70 ;ABM("QTY") - VOLUME TIMES LAST QTY FILLED
+71 ;^PS(52.7 is the IV solutions file.
+72 IF +ABM(0)
IF $DATA(^PS(52.7,+ABM(0)))
Begin DoDot:3
+73 SET Y=^PS(52.7,+ABM(0),0)
+74 SET ABMX=$PIECE(Y,U,2)
+75 ;S ABMPPDU=$S($D(^ABMDFEE(ABMP("FEE"),25,ABMX,0)):$P(^(0),U,2),1:$P($G(^PSDRUG(ABMX,660)),U,6)) ;abm*2.6*2 3PMS10003A
+76 ;abm*2.6*2 3PMS10003A
SET ABMPPDU=$SELECT($DATA(^ABMDFEE(ABMP("FEE"),25,ABMX,0)):$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),25,ABMX,ABMP("VDT")),U),1:$PIECE($GET(^PSDRUG(ABMX,660)),U,6))
+77 ;For solutions same as additives.
+78 SET ABM("FEE")=ABM("FEE")+(ABMPPDU*$PIECE(ABM(9),U,3))
+79 ;S ABM("FEE")=$G(ABM("FEE"))+($P(Y,U,7)*ABM("QTY"))
+80 IF '$DATA(X)
IF $DATA(^PSDRUG(ABMX,0))
SET X=ABMX
End DoDot:3
+81 ;X - Generic drug
+82 ;7th piece - Average drug cost
End DoDot:2
+83 SET ABMSRC="PSIV|"_ABM_"|RX-SOL"
+84 IF $DATA(X)
IF $DATA(^PSDRUG(X,0))
DO MEDSET
End DoDot:1
+85 QUIT
+86 ;
MEDSET ;SET 3P CLAIM RX MULTIPLE
+1 SET ABMP("RXIVDONE")=1
+2 SET DA(1)=ABMP("CDFN")
+3 SET DIC="^ABMDCLM(DUZ(2),"_DA(1)_",23,"
SET DIC(0)="LE"
+4 SET DA=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),"ASRC",ABMSRC,0))
+5 ;For duplicates problem
IF DA
IF '$DATA(@(DIC_DA_",0)"))
SET DA=""
+6 IF 'DA
Begin DoDot:1
+7 SET DIC("P")=$PIECE(^DD(9002274.3,23,0),U,2)
+8 ; ENTER CORRECT DEFAULT REV CODE
+9 ;IHS/DSD/JLG 3/31/98
SET DIC("DR")=".02////260"
+10 KILL DD,DO
DO FILE^DICN
SET DA=+Y
+11 ;IHS/DSD/JLG 3/31/98
KILL DIC("DR")
End DoDot:1
+12 IF DA<1
QUIT
SET DIE=DIC
+13 DO DFEE
+14 ;MODIFIED IHS/DSD/JLG 3/31/98
SET DR=".03////1;.04////"_+ABM("FEE")_";.05////"_+ABM("DISPFEE")_";.06////"_ABM("ORDER#")
+15 SET DR=DR_";"_$SELECT(ABM("T")="A":.07,1:.08)_"////"_(+ABM(0))_";.09///"_$PIECE(ABM(0),U,2)
+16 ;Next line set correspond diagnosis if only 1 POV
+17 IF $DATA(ABMP("CORRSDIAG"))
SET DR=DR_";.13////1"
+18 SET DR=DR_";.15////"_ABM("TYPE")_";.14////"_ABM("TIME")
+19 SET DR=DR_";.17////"_ABMSRC
+20 DO ^DIE
+21 KILL DR
+22 QUIT
DFEE ;DISPENSE FEE
+1 SET ABM("DFPARM")=$GET(^ABMDPARM(DUZ(2),1,4))
+2 SET ABM("DISPFEE")=+$PIECE(ABM("DFPARM"),"^",$FIND("APHSC",ABM("TYPE")))
+3 QUIT
