ABMDVST9.m

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