Routine: ABMDVST5

ABMDVST5 ; IHS/ASDST/DMJ - PCC VISIT STUFF - PART 6 (PHARMACY) ;

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

 ;Original;TMD;08/19/96 5:01 PM

 ; IHS/SD/SDR - v2.5 p8 - task 57

 ;    Removed check for OTC drugs and no entry in fee schedule.  Also

 ;    added code to populate dt disc. and RTS if flag is set.

 ; IHS/SD/SDR - v2.5 p9 - IM19140 - <SUBSCRIPT>ABMDVST5+29^ABMDVST5

 ; IHS/SD/SDR - v2.5 p10 - IM21500 - Added code to check new V Med field

 ;    POINT OF SALE BILLING STATUS and only bill if blank or rejected

 I $G(ABMP("RXDONE")) Q

 I $G(ABMP("INS"))'="",($P($G(^AUTNINS(ABMP("INS"),2)),U,3)="U") Q

 I $G(ABMP("INS"))'="",($P($G(^AUTNINS(ABMP("INS"),2)),"^",3)="P") Q

 S (ABM("TIME"),ABMR("TIME"))=$P(ABMP("V0"),U)

MED ;

 K DIC

 S DA(1)=ABMP("CDFN"),DIC="^ABMDCLM(DUZ(2),"_DA(1)_",23,",DIC(0)="LE"

 S ABM=0 F  S ABM=$O(^AUPNVMED("AD",ABMVDFN,ABM)) Q:'ABM  D

 .Q:'$D(^AUPNVMED(ABM,0))

 .Q:$P(^AUPNVMED(ABM,0),"^",8)&($G(ABMRXFLG)'=1)

 .S X=$P(^AUPNVMED(ABM,0),U)

 .S ABMSRC="14|"_ABM_"|RX"

 .D MEDCHK

 .Q:ABMR("QTY")=""&($G(ABMRXFLG)'=1)

 .Q:$G(ABMR("RTS"))&($G(ABMRXFLG)'=1)

 .D MEDSET

Q K DIC,ABMR,DR,DIE,X,Y

MEDCHK ;

 S ABMR("X")=$O(^PSRX("APCC",ABM,""))

 I ABMR("X")="" D NORX Q

 S ABMR("RX")=$P($G(^PSRX(ABMR("X"),0)),U)

 I ABMR("RX")="" D NORX Q

 S ABMR("DTWR")=$P(^PSRX(ABMR("X"),0),"^",13)

 S ABMR("REF")=$O(^PSRX("APCC",ABM,ABMR("X"),0))

 I ABMR("REF")="" D

 .S ABMR0=$G(^PSRX(ABMR("X"),0))

 .S ABMR2=$G(^PSRX(ABMR("X"),2))

 .S ABMR("QTY")=$P(ABMR0,"^",7)

 .S ABMR("RTS")=$P(ABMR2,"^",15)

 .S ABMR("DAYS")=$P(ABMR0,"^",8)

 .S ABMR("NDC")=$P(ABMR2,"^",7)

 .S ABMR("PROV")=$P(ABMR0,"^",4)

 I ABMR("REF")'="" D

 .S ABMR0=$G(^PSRX(ABMR("X"),1,ABMR("REF"),0))

 .S ABMR("QTY")=$P(ABMR0,"^",4)

 .S ABMR("RTS")=$P(ABMR0,"^",16)

 .S ABMR("DAYS")=$P(ABMR0,"^",10)

 .S ABMR("NDC")=$$NDCVAL^ABMPFUNC(ABMR("X"),ABMR("REF"))

 .S ABMR("PROV")=$P(ABMR0,"^",17)

NORX ;no entry in prescription file

 S ABMR("QTY")=$P(^AUPNVMED(ABM,0),"^",6)

 S ABMR("RX")=""

MEDSET ;FILE

 S DA=$O(^ABMDCLM(DUZ(2),DA(1),"ASRC",ABMSRC,0))

 I DA,'$D(@(DIC_DA_",0)")) S DA=""          ;For duplicates problem

 S ABMR("PPDU")=+$P($$ONE^ABMFEAPI(ABMP("FEE"),25,X,ABMP("VDT")),U)  ;abm*2.6*2 3PMS10003A  ;abm*2.6*4 NOHEAT

 S:'ABMR("PPDU") ABMR("PPDU")=+$P($G(^PSDRUG(X,660)),U,6)  ;abm*2.6*4 NOHEAT

 I (($P($$ONE^ABMFEAPI(ABMP("FEE"),25,X,ABMP("VDT")),U)=0)&('ABMR("PPDU"))&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y")) Q  ;abm*2.6*4 NOHEAT

 I 'DA D

 .S DIC("P")=$P(^DD(9002274.3,23,0),U,2)

 .; ADD DEFAULT REV CODE

 .S DIC("DR")=".02////250"

 .K DD,DO D FILE^DICN

 .K DIC("DR")

 .S DA=+Y

 Q:DA<0  S DIE=DIC

 S ABMR("SURC")=$S(ABMP("VTYP")'=111:$P(^ABMDPARM(DUZ(2),1,0),U,3),1:$P($G(^ABMDPARM(DUZ(2),1,4)),U,6))

 ;X is the drug ien.  ABMDFEE is dinumed in this mult

 ;Q:($P($G(^ABMDFEE(ABMP("FEE"),25,X,0)),U,2)=0&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A

 ;Q:($P($$ONE^ABMFEAPI(ABMP("FEE"),25,X,ABMP("VDT")),U)=0&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A  ;abm*2.6*4 NOHEAT

 ;S ABMR("PPDU")=+$P($G(^ABMDFEE(ABMP("FEE"),25,X,0)),U,2)  ;abm*2.6*2 3PMS10003A

 ;S ABMR("PPDU")=+$P($$ONE^ABMFEAPI(ABMP("FEE"),25,X,ABMP("VDT")),U)  ;abm*2.6*2 3PMS10003A  ;abm*2.6*4 NOHEAT

 ;S:'ABMR("PPDU") ABMR("PPDU")=+$P($G(^PSDRUG(X,660)),U,6)  ;abm*2.6*4 NOHEAT

 K DR

 S DR=".03////"_ABMR("QTY")_";.04////"_ABMR("PPDU")_";.05////"_ABMR("SURC")_";.06////"_ABMR("RX")_";.14////"_ABMR("TIME")

 ;Next line set correspond diagnosis if only 1 POV

 I $D(ABMP("CORRSDIAG")) S DR=DR_";.13////1"

 S DR=DR_";.17////"_ABMSRC

 D ^DIE

 S DR=".22////"_ABMR("X")

 D ^DIE

 S DR=".23////"_$G(ABMR("PROV"))

 D ^DIE

 S DR=".24////"_$G(ABMR("NDC"))

 D ^DIE

 S DR=".2////"_$G(ABMR("DAYS"))

 D ^DIE

 S DR=".19////"_+$G(ABMR("REF"))

 D ^DIE

 S DR=".25////"_$G(ABMR("DTWR"))

 D ^DIE

 S ABMP("RXDONE")=1

 I $G(ABMRXFLG)=1 D

 .S DR=".26////"_$P($G(^AUPNVMED(ABM,0)),U,8)

 .S DR=DR_";.27////"_$G(ABMR("RTS"))

 .D ^DIE

MED3 ;EP

 ; 4/26/01 - This code is no longer called...  leaving in routine for

 ; version just in case...

 Q:$P($G(^AUTNINS(ABMP("INS"),2)),U,3)="U"

 Q:$D(ABMP("MEDSCHKD"))

 S DA(1)=ABMP("CDFN"),DIC="^ABMDCLM(DUZ(2),"_DA(1)_",23,",DIC(0)="LE"

 S ABM("D")=ABMCHVDT-1

 ;ABM("ED") is the discharge date if it exists

 S ABM("ED")=$S($P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),6)),U,3):$P(^(6),U,3),1:ABMCHVDT)+.24

 F  S ABM("D")=$O(^PSRX("AD",ABM("D"))) Q:'ABM("D")!(ABM("D")>ABM("ED"))  D

 .S ABM("X")=0 F  S ABM("X")=$O(^PSRX("AD",ABM("D"),ABM("X"))) Q:'ABM("X")  I $P($G(^PSRX(ABM("X"),0)),U,2)=ABMP("PDFN") D MED3CK

 K DIC

MED3CK I $D(^PSRX("AD",ABM("D"),ABM("X")))=11 S ABM("REF")=$O(^PSRX("AD",ABM("D"),ABM("X"),""))

 E  S ABM("REF")=""

 S X=$P(^PSRX(ABM("X"),0),U,6),ABM("RX")=$P(^(0),U),ABM("QTY")=$S('+ABM("REF"):$P(^(0),U,7),1:$P($G(^(1,ABM("REF"),0)),U,4))

 S ABMSRC="PSRX|"_ABM("X")_"|RX"

 Q:ABM("QTY")=""

 Q:'$D(^PSDRUG(X,0))

 Q:$P(^PSDRUG(X,0),"^",3)[9   ;OTC DRUG

 S DA=$O(^ABMDCLM(DUZ(2),DA(1),"ASRC",ABMSRC,0))

 I DA,'$D(@(DIC_DA_",0)")) S DA=""          ;For duplicates problem

 I 'DA D

 .S ABMP("MEDSCHKD")=1

 .S DIC("P")=$P(^DD(9002274.3,23,0),U,2)

 .S DIC("DR")=".02////250"

 .K DD,DO D FILE^DICN

 .K DIC("DR")

 .S DA=+Y

 Q:DA<0  S DIE=DIC

 S ABM("SURC")=$S(ABMP("VTYP")'=111:+$P(^ABMDPARM(DUZ(2),1,0),U,3),1:+$P($G(^ABMDPARM(DUZ(2),1,4)),"^",6))

 ;Q:($P($G(^ABMDFEE(ABMP("FEE"),25,X,0)),U,2)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A

 Q:($P($$ONE^ABMFEAPI(ABMP("FEE"),25,X,ABMP("VDT")),U)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A

 ;S ABM("PPDU")=+$P($G(^ABMDFEE(ABMP("FEE"),25,X,0)),"^",2)  ;abm*2.6*2 3PMS10003A

 S ABM("PPDU")=+$P($$ONE^ABMFEAPI(ABMP("FEE"),25,X,ABMP("VDT")),U)  ;abm*2.6*2 3PMS10003A

 S:'ABM("PPDU") ABM("PPDU")=+$P($G(^PSDRUG(X,660)),"^",6)

 K DR

 S DR=".03////"_ABM("QTY")_";.04////"_ABM("PPDU")_";.05////"_ABM("SURC")_";.06////"_ABM("RX")_";.14////"_ABM("TIME")

 ;Next line set correspond diagnosis if only 1 POV

 I $D(ABMP("CORRSDIAG")) S DR=DR_";.13////1"

 S DR=DR_";.17////"_ABMSRC

 D ^DIE

ABMDVST5  ; IHS/ASDST/DMJ - PCC VISIT STUFF - PART 6 (PHARMACY) ;

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

 +2       ;Original;TMD;08/19/96 5:01 PM

 +3       ;

 +4       ; IHS/SD/SDR - v2.5 p8 - task 57

 +5       ;    Removed check for OTC drugs and no entry in fee schedule.  Also

 +6       ;    added code to populate dt disc. and RTS if flag is set.

 +7       ; IHS/SD/SDR - v2.5 p9 - IM19140 - <SUBSCRIPT>ABMDVST5+29^ABMDVST5

 +8       ; IHS/SD/SDR - v2.5 p10 - IM21500 - Added code to check new V Med field

 +9       ;    POINT OF SALE BILLING STATUS and only bill if blank or rejected

 +10      ;

 +11       IF $GET(ABMP("RXDONE"))

               QUIT

 +12       IF $GET(ABMP("INS"))'=""

               IF ($PIECE($GET(^AUTNINS(ABMP("INS"),2)),U,3)="U")

                   QUIT

 +13       IF $GET(ABMP("INS"))'=""

               IF ($PIECE($GET(^AUTNINS(ABMP("INS"),2)),"^",3)="P")

                   QUIT

 +14       SET (ABM("TIME"),ABMR("TIME"))=$PIECE(ABMP("V0"),U)

 +15      ;

MED       ;

 +1        KILL DIC

 +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(^AUPNVMED("AD",ABMVDFN,ABM))

               IF 'ABM

                   QUIT

               Begin DoDot:1

 +4                IF '$DATA(^AUPNVMED(ABM,0))

                       QUIT

 +5                IF $PIECE(^AUPNVMED(ABM,0),"^",8)&($GET(ABMRXFLG)'=1)

                       QUIT

 +6                SET X=$PIECE(^AUPNVMED(ABM,0),U)

 +7                SET ABMSRC="14|"_ABM_"|RX"

 +8                DO MEDCHK

 +9                IF ABMR("QTY")=""&($GET(ABMRXFLG)'=1)

                       QUIT

 +10               IF $GET(ABMR("RTS"))&($GET(ABMRXFLG)'=1)

                       QUIT

 +11               DO MEDSET

               End DoDot:1

Q          KILL DIC,ABMR,DR,DIE,X,Y

 +1        QUIT

 +2       ;

MEDCHK    ;

 +1        SET ABMR("X")=$ORDER(^PSRX("APCC",ABM,""))

 +2        IF ABMR("X")=""

               DO NORX

               QUIT

 +3        SET ABMR("RX")=$PIECE($GET(^PSRX(ABMR("X"),0)),U)

 +4        IF ABMR("RX")=""

               DO NORX

               QUIT

 +5        SET ABMR("DTWR")=$PIECE(^PSRX(ABMR("X"),0),"^",13)

 +6        SET ABMR("REF")=$ORDER(^PSRX("APCC",ABM,ABMR("X"),0))

 +7        IF ABMR("REF")=""

               Begin DoDot:1

 +8                SET ABMR0=$GET(^PSRX(ABMR("X"),0))

 +9                SET ABMR2=$GET(^PSRX(ABMR("X"),2))

 +10               SET ABMR("QTY")=$PIECE(ABMR0,"^",7)

 +11               SET ABMR("RTS")=$PIECE(ABMR2,"^",15)

 +12               SET ABMR("DAYS")=$PIECE(ABMR0,"^",8)

 +13               SET ABMR("NDC")=$PIECE(ABMR2,"^",7)

 +14               SET ABMR("PROV")=$PIECE(ABMR0,"^",4)

               End DoDot:1

 +15       IF ABMR("REF")'=""

               Begin DoDot:1

 +16               SET ABMR0=$GET(^PSRX(ABMR("X"),1,ABMR("REF"),0))

 +17               SET ABMR("QTY")=$PIECE(ABMR0,"^",4)

 +18               SET ABMR("RTS")=$PIECE(ABMR0,"^",16)

 +19               SET ABMR("DAYS")=$PIECE(ABMR0,"^",10)

 +20               SET ABMR("NDC")=$$NDCVAL^ABMPFUNC(ABMR("X"),ABMR("REF"))

 +21               SET ABMR("PROV")=$PIECE(ABMR0,"^",17)

               End DoDot:1

 +22       QUIT

NORX      ;no entry in prescription file

 +1        SET ABMR("QTY")=$PIECE(^AUPNVMED(ABM,0),"^",6)

 +2        SET ABMR("RX")=""

 +3        QUIT

MEDSET    ;FILE

 +1        SET DA=$ORDER(^ABMDCLM(DUZ(2),DA(1),"ASRC",ABMSRC,0))

 +2       ;For duplicates problem

           IF DA

               IF '$DATA(@(DIC_DA_",0)"))

                   SET DA=""

 +3       ;abm*2.6*2 3PMS10003A  ;abm*2.6*4 NOHEAT

           SET ABMR("PPDU")=+$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),25,X,ABMP("VDT")),U)

 +4       ;abm*2.6*4 NOHEAT

           IF 'ABMR("PPDU")

               SET ABMR("PPDU")=+$PIECE($GET(^PSDRUG(X,660)),U,6)

 +5       ;abm*2.6*4 NOHEAT

           IF (($PIECE($$ONE^ABMFEAPI(ABMP("FEE"),25,X,ABMP("VDT")),U)=0)&('ABMR("PPDU"))&($PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))

               QUIT

 +6        IF 'DA

               Begin DoDot:1

 +7                SET DIC("P")=$PIECE(^DD(9002274.3,23,0),U,2)

 +8       ; ADD DEFAULT REV CODE

 +9                SET DIC("DR")=".02////250"

 +10               KILL DD,DO

                   DO FILE^DICN

 +11               KILL DIC("DR")

 +12               SET DA=+Y

               End DoDot:1

 +13       IF DA<0

               QUIT

           SET DIE=DIC

 +14       SET ABMR("SURC")=$SELECT(ABMP("VTYP")'=111:$PIECE(^ABMDPARM(DUZ(2),1,0),U,3),1:$PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,6))

 +15      ;X is the drug ien.  ABMDFEE is dinumed in this mult

 +16      ;Q:($P($G(^ABMDFEE(ABMP("FEE"),25,X,0)),U,2)=0&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A

 +17      ;Q:($P($$ONE^ABMFEAPI(ABMP("FEE"),25,X,ABMP("VDT")),U)=0&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A  ;abm*2.6*4 NOHEAT

 +18      ;S ABMR("PPDU")=+$P($G(^ABMDFEE(ABMP("FEE"),25,X,0)),U,2)  ;abm*2.6*2 3PMS10003A

 +19      ;S ABMR("PPDU")=+$P($$ONE^ABMFEAPI(ABMP("FEE"),25,X,ABMP("VDT")),U)  ;abm*2.6*2 3PMS10003A  ;abm*2.6*4 NOHEAT

 +20      ;S:'ABMR("PPDU") ABMR("PPDU")=+$P($G(^PSDRUG(X,660)),U,6)  ;abm*2.6*4 NOHEAT

 +21       KILL DR

 +22       SET DR=".03////"_ABMR("QTY")_";.04////"_ABMR("PPDU")_";.05////"_ABMR("SURC")_";.06////"_ABMR("RX")_";.14////"_ABMR("TIME")

 +23      ;Next line set correspond diagnosis if only 1 POV

 +24       IF $DATA(ABMP("CORRSDIAG"))

               SET DR=DR_";.13////1"

 +25       SET DR=DR_";.17////"_ABMSRC

 +26       DO ^DIE

 +27       SET DR=".22////"_ABMR("X")

 +28       DO ^DIE

 +29       SET DR=".23////"_$GET(ABMR("PROV"))

 +30       DO ^DIE

 +31       SET DR=".24////"_$GET(ABMR("NDC"))

 +32       DO ^DIE

 +33       SET DR=".2////"_$GET(ABMR("DAYS"))

 +34       DO ^DIE

 +35       SET DR=".19////"_+$GET(ABMR("REF"))

 +36       DO ^DIE

 +37       SET DR=".25////"_$GET(ABMR("DTWR"))

 +38       DO ^DIE

 +39       SET ABMP("RXDONE")=1

 +40       IF $GET(ABMRXFLG)=1

               Begin DoDot:1

 +41               SET DR=".26////"_$PIECE($GET(^AUPNVMED(ABM,0)),U,8)

 +42               SET DR=DR_";.27////"_$GET(ABMR("RTS"))

 +43               DO ^DIE

               End DoDot:1

 +44       QUIT

 +45      ;

MED3      ;EP

 +1       ; 4/26/01 - This code is no longer called...  leaving in routine for

 +2       ; version just in case...

 +3        IF $PIECE($GET(^AUTNINS(ABMP("INS"),2)),U,3)="U"

               QUIT

 +4        IF $DATA(ABMP("MEDSCHKD"))

               QUIT

 +5        SET DA(1)=ABMP("CDFN")

           SET DIC="^ABMDCLM(DUZ(2),"_DA(1)_",23,"

           SET DIC(0)="LE"

 +6        SET ABM("D")=ABMCHVDT-1

 +7       ;ABM("ED") is the discharge date if it exists

 +8        SET ABM("ED")=$SELECT($PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),6)),U,3):$PIECE(^(6),U,3),1:ABMCHVDT)+.24

 +9        FOR

               SET ABM("D")=$ORDER(^PSRX("AD",ABM("D")))

               IF 'ABM("D")!(ABM("D")>ABM("ED"))

                   QUIT

               Begin DoDot:1

 +10               SET ABM("X")=0

FOR

                       SET ABM("X")=$ORDER(^PSRX("AD",ABM("D"),ABM("X")))

                       IF 'ABM("X")

                           QUIT

                       IF $PIECE($GET(^PSRX(ABM("X"),0)),U,2)=ABMP("PDFN")

                           DO MED3CK

               End DoDot:1

 +11       KILL DIC

 +12       QUIT

 +13      ;

MED3CK     IF $DATA(^PSRX("AD",ABM("D"),ABM("X")))=11

               SET ABM("REF")=$ORDER(^PSRX("AD",ABM("D"),ABM("X"),""))

 +1       IF '$TEST

               SET ABM("REF")=""

 +2        SET X=$PIECE(^PSRX(ABM("X"),0),U,6)

           SET ABM("RX")=$PIECE(^(0),U)

           SET ABM("QTY")=$SELECT('+ABM("REF"):$PIECE(^(0),U,7),1:$PIECE($GET(^(1,ABM("REF"),0)),U,4))

 +3        SET ABMSRC="PSRX|"_ABM("X")_"|RX"

 +4        IF ABM("QTY")=""

               QUIT

 +5        IF '$DATA(^PSDRUG(X,0))

               QUIT

 +6       ;OTC DRUG

           IF $PIECE(^PSDRUG(X,0),"^",3)[9

               QUIT

 +7        SET DA=$ORDER(^ABMDCLM(DUZ(2),DA(1),"ASRC",ABMSRC,0))

 +8       ;For duplicates problem

           IF DA

               IF '$DATA(@(DIC_DA_",0)"))

                   SET DA=""

 +9        IF 'DA

               Begin DoDot:1

 +10               SET ABMP("MEDSCHKD")=1

 +11               SET DIC("P")=$PIECE(^DD(9002274.3,23,0),U,2)

 +12               SET DIC("DR")=".02////250"

 +13               KILL DD,DO

                   DO FILE^DICN

 +14               KILL DIC("DR")

 +15               SET DA=+Y

               End DoDot:1

 +16       IF DA<0

               QUIT

           SET DIE=DIC

 +17       SET ABM("SURC")=$SELECT(ABMP("VTYP")'=111:+$PIECE(^ABMDPARM(DUZ(2),1,0),U,3),1:+$PIECE($GET(^ABMDPARM(DUZ(2),1,4)),"^",6))

 +18      ;Q:($P($G(^ABMDFEE(ABMP("FEE"),25,X,0)),U,2)&($P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))  ;abm*2.6*2 3PMS10003A

 +19      ;abm*2.6*2 3PMS10003A

           IF ($PIECE($$ONE^ABMFEAPI(ABMP("FEE"),25,X,ABMP("VDT")),U)&($PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),1,ABMP("VTYP"),1)),U,14)'="Y"))

               QUIT

 +20      ;S ABM("PPDU")=+$P($G(^ABMDFEE(ABMP("FEE"),25,X,0)),"^",2)  ;abm*2.6*2 3PMS10003A

 +21      ;abm*2.6*2 3PMS10003A

           SET ABM("PPDU")=+$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),25,X,ABMP("VDT")),U)

 +22       IF 'ABM("PPDU")

               SET ABM("PPDU")=+$PIECE($GET(^PSDRUG(X,660)),"^",6)

 +23       KILL DR

 +24       SET DR=".03////"_ABM("QTY")_";.04////"_ABM("PPDU")_";.05////"_ABM("SURC")_";.06////"_ABM("RX")_";.14////"_ABM("TIME")

 +25      ;Next line set correspond diagnosis if only 1 POV

 +26       IF $DATA(ABMP("CORRSDIAG"))

               SET DR=DR_";.13////1"

 +27       SET DR=DR_";.17////"_ABMSRC

 +28       DO ^DIE

 +29       QUIT

ABMDVST5.m