Routine: ABMDTMS

ABMDTMS ;IHS/ABM/THL - INTERFACE WITH PYXIS/M SYSTEMS;

 ;;2.6;IHS 3P BILLING SYSTEM;**10,21**;NOV 12, 2009;Build 379

;;

 ; IHS/SD/SDR - v2.5 p8 - Link to Omnicell

 ;    Code supplied by Carlene McIntyre to connect TPB to Omnicell

 ; IHS/SD/SDR - v2.6 CSV

 ;IHS/SD/SDR - 2.6*21 - HEAT110091 - Default rev code for Meds to 250

EN F  D EN1 Q:$D(ABMQUIT)!$D(ABMOUT)

EXITOUT K ABM,ABMAR,ABMDA,ABMDTMS,ABMFL,ABMFN,ABMHDR,ABMI,ABMJ,ABMOUT,ABMQUIT,ABMROU,ABMVALM,ABMX,ABMQUIT,ABMOUT,ABMDA,DFN,VALMBCK,VISDATE,PATIENT,ABMDTMS

 K ^TMP("ABMDTMS",$J)

EN1 ;

 D EXITOUT

 D CLAIM

 Q:$D(ABMQUIT)

 D DISPLAY

 I $D(ABMQUIT) K ABMQUIT Q

CLAIM ;SELECT CLAIM

 S DIC="^ABMDCLM("_DUZ(2)_","

 S DIC(0)="AEMQZ"

 S DIC("A")="Select CLAIM Number: "

W !

 D ^DIC K DIC

 I +Y<1 S ABMQUIT="" Q

 S ABMDA=+Y

CL1 ;CLAIM ALREADY IDENTIFIED

 S ABM0=$G(^ABMDCLM(DUZ(2),ABMDA,0))

 S DFN=+ABM0,ABMNUM=ABMDA

DISPLAY ;DISPLAY SULLPY ITEMS

 D DATE

 Q:'$G(ABMBEGIN)!'$G(ABMEND)

 D DISP1

DATE ;SELECT DATE RANGE FOR ITEM CHARGES

 S PATIENT=$P($G(^DPT(DFN,0)),U)

 S FROM=$G(^ABMDCLM(DUZ(2),ABMDA,7))

 S TO=$P(FROM,U,2)

 S FROM=+FROM

 S Y=FROM

 X ^DD("DD")

 S VISDATE=Y

 S Y=TO

 I Y X ^DD("DD") S TO=Y

 W !!,"PATIENT: ",PATIENT,"  VISIT DATE: ",VISDATE

 W:TO]"" "  TO: ",TO

 S DIR("B")=VISDATE

 S DIR(0)="DO"

 S DIR("A")="Beginning Date for Supply/Med Charges"

 S DIR("?")="Enter the earliest date to include for supply/med charges"

W !

 D ^DIR K DIR

 I Y<1 S ABMQUIT="" Q

 S ABMBEGIN=+Y

 S ABMEND=+Y

 S Y=DT

 X ^DD("DD")

 S DIR("B")=Y

 S DIR(0)="DO"

 S DIR("A")="Ending Date for Supply/Med Charges"

 S DIR("?")="Enter the last date to include for supply/med charges"

W !

 D ^DIR K DIR

 I 'Y S ABMEND=ABMBEGIN

 S ABMEND=+Y

DINIT ;EP;LIST ALL SUPPLY ITEMS IN THE DATE RANGE

 K ^TMP("ABMDTMS",$J)

 S ABMCNT=0

 D HEAD

 S ABM=ABMBEGIN-1

 F  S ABM=$O(^AUPNSUP("ASUP",DFN,ABM)) Q:'ABM!(ABM>(ABMEND+.9999))  D

 .S ABMSDA=0

 .F  S ABMSDA=$O(^AUPNSUP("ASUP",DFN,ABM,ABMSDA)) Q:'ABMSDA  D

 ..D SUPPSET

 ..Q:ABM0=""

 ..D FORMAT

 S (VALMCNT,ABMJ)=J

SUPPSET ;SET SUPPLY VARIABLES

 S ABM0=$G(^AUPNSUP(ABMSDA,0))

 S ABM1=$G(^AUPNSUP(ABMSDA,1))

 S ABM2=$G(^AUPNSUP(ABMSDA,2))

HEAD ;

 S J=0

 S X=""

 S $E(X,19)="3P NUM: "_ABMNUM

D J

 S $E(X,18)="PATIENT: "_PATIENT

D J

 S $E(X,9)="ADMIT/VISIT FROM: "_VISDATE_"  TO: "_TO

D J

 S X=""

 S $E(X,51)="TRANCODE/"

 S $E(X,67)="REV/"

D J

 S X="SUPPLY/MED NAME"

 S $E(X,36)="QUAN"

 S $E(X,44)="PRICE"

 S $E(X,51)="NDC"

 S $E(X,61)="HCPC"

 S $E(X,67)="DEPT"

 S $E(X,72)="CLAIM NO."

D J

 S X="--------------------------------------------------------------------------------"

D J

 S JHEAD=J

FORMAT ;FORMAT DATA FOR DISPLAY

 S SUPPLY=$P(ABM0,U)

 S PATIENT=$P($G(^DPT(DFN,0)),U)

 S ADMIT=$G(^ABMDCLM(DUZ(2),ABMDA,6))

 S DISCHARG=$P(ADMIT,U,3)

 S ADMIT=+ADMIT

 S FROM=$G(^ABMDCLM(DUZ(2),ABMDA,7))

 S TO=$P(FROM,U,2)

 S FROM=+FROM

 I ADMIT D

 .S Y=ADMIT

 .X ^DD("DD")

 .S ADMIT=Y

 I DISCHARG D

 .S Y=DISCHARG

 .X ^DD("DD")

 .S DISCHARG=Y

 I FROM D

 .S Y=ADMIT

 .X ^DD("DD")

 .S FROM=Y

 I TO D

 .S Y=TO

 .X ^DD("DD")

 .S TO=Y

 S Y=$P(ABM0,U,3)

 X ^DD("DD")

 S ISSUDATE=Y

 S CLAIM=$P(ABM0,U,6)

 S TRANCODE=$P(ABM1,U)

 S MEDDA=$P(ABM1,U,3)

 S NDC=$P($G(^PSDRUG(+MEDDA,2)),U,4)

 S DEPTCODE=$P(ABM1,U,5)

 S QUANTITY=$P(ABM2,U,3)

 S PRICE=$P(ABM2,U,4)

 S HCPCCODE=$P($$CPT^ABMCVAPI(+$P(ABM2,U,5),FROM),U,2)  ;CSV-c

 S REVCODE=$P($G(^AUTTREVN(+$P(ABM2,U,6),0)),U)

 S ABMCNT=ABMCNT+1

 S X=ABMCNT

 S $E(X,4)=$E(SUPPLY,1,32)

 S $E(X,36)=$J(QUANTITY,4)

 S $E(X,40)=$J($FN(PRICE,"P",2),10)

 S $E(X,51)=$E(TRANCODE,1,10)

 S $E(X,61)=$E(HCPCCODE,1,6)

 S $E(X,67)=$E(REVCODE,1,3)

 S:CLAIM]"" $E(X,71)=$E(CLAIM,1,10)

D J

 S X="   "_ISSUDATE

 S $E(X,51)=$E(NDC,1,12)

 S $E(X,67)=DEPTCODE

D J

 S ^TMP("ABMSUP",$J,ABMCNT)=ABMSDA

ADDITEM ;ADD SUPPLY TO CLAIM

 N ABMJ,ABMX

 F ABMJ=1:1 S ABMX=$P(ABMSET,",",ABMJ) Q:'ABMX  D A1

A1 ;ADD ITEMS TO THE CLAIM

 S DA(1)=ABMDA

 S ABMSDA=$G(^TMP("ABMSUP",$J,ABMX))

 Q:'ABMSDA

 D SUPPSET

 S X=""

 I $P(ABM1,U,3) D  I 1

 .S X=$P(ABM1,U,3)

 .I '$D(^PSDRUG(+X,0)) S X="" Q

 .S DIC="^ABMDCLM("_DUZ(2)_","_ABMDA_",23,"

 .S $P(^ABMDCLM(DUZ(2),DA(1),23,0),U,2)="9002274.3023P"

 .;S DIC("DR")=".02///"_$P(ABM2,U,6)_";.03////"_$P(ABM2,U,3)_";.04////"_$P(ABM2,U,4)_";.05////"_$S($G(DISPFEE):DISPFEE,1:4.5)_";.06////"_$S($P(ABM2,U,7)]"":$P(ABM2,U,7),1:"NOT STATED")_";.14////"_$P(ABM0,U,3)  ;;abm*2.6*21 IHS/SD/SDR HEAT110091

 .;start new abm*2.6*21 IHS/SD/SDR HEAT110091

 .S DIC("DR")=".02///"_$S(+$P(ABM2,U,6)'=0:$P(ABM2,U,6),1:250)_";.03////"_$P(ABM2,U,3)_";.04////"_$P(ABM2,U,4)_";.05////"_$S($G(DISPFEE):DISPFEE,1:4.5)_";.06////"_$S($P(ABM2,U,7)]"":$P(ABM2,U,7),1:"NOT STATED")_";.14////"_$P(ABM0,U,3)

 .;end new abm*2.6*21 IHS/SD/SDR HEAT110091

 .S DIC("DR")=DIC("DR")_";.24////"_$P($G(^PSDRUG($P(ABM1,U,3),2)),U,4)  ;NDC  abm*2.6*10 HEAT74646

 E  I $P(ABM2,U,5) D  I 1

 .S X=+$P(ABM2,U,5)

 .I '$D(^ICPT(+X,0)) S X="" Q

 .S DIC="^ABMDCLM("_DUZ(2)_","_ABMDA_",43,"

 .S $P(^ABMDCLM(DUZ(2),DA(1),43,0),U,2)="9002274.3043P"

 .S DIC("DR")=".02///"_$P(ABM2,U,6)_";.03////"_$P(ABM2,U,3)_";.04////"_$P(ABM2,U,4)_";.06////"_$S($P(ABM2,U,7)]"":$P(ABM2,U,7),1:"NOT STATED")_";.14////"_$P(ABM0,U,3)

 E  I $P(ABM2,U,6) D  I 1

 .S X=+$P(ABM2,U,6)

 .I '$D(^AUTTREVN(+X,0)) S X="" Q

 .S DIC="^ABMDCLM("_DUZ(2)_","_ABMDA_",25,"

 .S $P(^ABMDCLM(DUZ(2),DA(1),25,0),U,2)="9002274.3025P"

 .S DIC("DR")=".02///"_$P(ABM2,U,3)_";.03////"_$P(ABM2,U,4)_";.04////"_$P(ABM2,U,2)

 Q:'X

 S DIC(0)="L"

 D FILE^DICN

 K DIC,DD,DA,DR

 S DA=ABMSDA

 S DIE="^AUPNSUP("

 S DR=".06////"_ABMDA

 D ^DIE

 K DIC,DD,DIE,DA,DR

DISP1 ;DISPLAY ALL RELEVANT ITEMS

 S ABMHDR=""

 S ABMVALM="ABMDTMS HL7 SUPPLY LIST"

 D VALM(ABMVALM)

SELECT ;EP;SELECT ITEMS TO ADD TO CLAIM

 I $G(ABMDTMS)'="E" S ABMDTMS="A"

 S DIR(0)="LO^1:"_ABMCNT

 S DIR("A")="Select Charges to add or edit"

W !

 D ^DIR K DIR

 K ABMQUIT

 I '+Y D BACK Q

 S ABMSET=Y

 I ABMDTMS="A" D ADD I 1

 E  D EDIT

 K ABMDTMS

 D BACK

 D DINIT

ADD D SURE

 I $D(ABMQUIT) K ABMQUIT Q

 D ADDITEM

SURE ;CONFIRM TRANSFER OF SUPPLIES

 W !!,"Are you certain you want to charge these items to the Claim/Bill"

 W !,ABMSET

 S DIR(0)="YO"

 S DIR("A")="Charge these supplies/meds to Claim/Bill "_ABMNUM_" "

 S DIR("B")="NO"

W !

 D ^DIR K DIR

 I 'Y S ABMQUIT="" Q

BACK S VALMBCK="R"

J ;SET TEMP ARRAY

 S J=J+1

 S ^TMP("ABMDTMS",$J,J,0)=X

 S X=""

VALM(ABMVALM) ;EP; -- main entry point for list templates

 S VALMSG="- Previous Screen   Q Quit   ?? for More Actions"

 S VALMCC=1 ;1=screen mode, 0=scrolling mode

 D BACK

 D TERM^VALM0

 D CLEAR^VALM1

 D EN^VALM(ABMVALM)

 D CLEAR^VALM1

OPEN(DFN,ABMDA) ;EP;TO PROCESS WHEN CLAIM ALREAY IDENTIFIED

 I $D(ABMDTMS("OUT")) K ABMDTMS Q

 S ABMDTMS("OUT")=""

 Q:'DFN!'ABMDA

 K ABMQUIT

 S PATIENT=$P($G(^DPT(DFN,0)),U)

 S FROM=$G(^ABMDCLM(DUZ(2),ABMDA,7))

 S TO=DT

 S FROM=+FROM

 N X,Y,Z

 S Z=0

 S X=FROM-1

 F  S X=$O(^AUPNSUP("ASUP",DFN,X)) Q:'X!Z!(X>TO)  D

 .S Y=0

 .F  S Y=$O(^AUPNSUP("ASUP",DFN,X,Y)) Q:'Y  D

 ..S Z=Z+1

 Q:'Z

 W @IOF

 W !!,"There are SUPPLIES/MEDS on file that may need to be added to this claim."

 D CL1

 D DISPLAY

HDR ;EP; -- header code

 S VALMHDR(1)=$G(ABMHDR)

 S VALMSG="- Previous Screen   Q Quit   ?? for More Actions"

HELP ;EP; -- help code

 S X="?"

 D DISP^XQORM1

 W !!

EXIT ;EP; -- exit code

 K ^TMP("ABMLM",$J)

 K ABMAR,ABMDIR,ABMFL,ABMFN,ABMHDR,ABMI,ABMROU,ABMDIR

 I '$G(XQORS) D CLEAR^VALM1

EDIN ;

 S ABMDTMS="E"

 D SELECT

 K ABDMTMS

EDIT ;EDIT SUPPLY ITEMS

 N ABMJ,ABMX

 F ABMJ=1:1 S ABMX=$P(ABMSET,",",ABMJ) Q:'ABMX  D E1

E1 ;EDIT ITEMS

 S DA=$G(^TMP("ABMSUP",$J,ABMX))

 Q:'DA

 S DR="[ABMDTMS SUPPLY EDIT]"

 S (DDSFILE,DIE)="^AUPNSUP("

 D ^DDS

ABMDTMS   ;IHS/ABM/THL - INTERFACE WITH PYXIS/M SYSTEMS;

 +1       ;;2.6;IHS 3P BILLING SYSTEM;**10,21**;NOV 12, 2009;Build 379

 +2       ;;

 +3       ; IHS/SD/SDR - v2.5 p8 - Link to Omnicell

 +4       ;    Code supplied by Carlene McIntyre to connect TPB to Omnicell

 +5       ;

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

 +7       ;IHS/SD/SDR - 2.6*21 - HEAT110091 - Default rev code for Meds to 250

 +8       ;

EN         FOR

               DO EN1

               IF $DATA(ABMQUIT)!$DATA(ABMOUT)

                   QUIT

EXITOUT    KILL ABM,ABMAR,ABMDA,ABMDTMS,ABMFL,ABMFN,ABMHDR,ABMI,ABMJ,ABMOUT,ABMQUIT,ABMROU,ABMVALM,ABMX,ABMQUIT,ABMOUT,ABMDA,DFN,VALMBCK,VISDATE,PATIENT,ABMDTMS

 +1        KILL ^TMP("ABMDTMS",$JOB)

 +2        QUIT

EN1       ;

 +1        DO EXITOUT

 +2        DO CLAIM

 +3        IF $DATA(ABMQUIT)

               QUIT

 +4        DO DISPLAY

 +5        IF $DATA(ABMQUIT)

               KILL ABMQUIT

               QUIT

 +6        QUIT

CLAIM     ;SELECT CLAIM

 +1        SET DIC="^ABMDCLM("_DUZ(2)_","

 +2        SET DIC(0)="AEMQZ"

 +3        SET DIC("A")="Select CLAIM Number: "

 +4        WRITE !

 +5        DO ^DIC

           KILL DIC

 +6        IF +Y<1

               SET ABMQUIT=""

               QUIT

 +7        SET ABMDA=+Y

CL1       ;CLAIM ALREADY IDENTIFIED

 +1        SET ABM0=$GET(^ABMDCLM(DUZ(2),ABMDA,0))

 +2        SET DFN=+ABM0

           SET ABMNUM=ABMDA

 +3        QUIT

DISPLAY   ;DISPLAY SULLPY ITEMS

 +1        DO DATE

 +2        IF '$GET(ABMBEGIN)!'$GET(ABMEND)

               QUIT

 +3        DO DISP1

 +4        QUIT

DATE      ;SELECT DATE RANGE FOR ITEM CHARGES

 +1        SET PATIENT=$PIECE($GET(^DPT(DFN,0)),U)

 +2        SET FROM=$GET(^ABMDCLM(DUZ(2),ABMDA,7))

 +3        SET TO=$PIECE(FROM,U,2)

 +4        SET FROM=+FROM

 +5        SET Y=FROM

 +6        XECUTE ^DD("DD")

 +7        SET VISDATE=Y

 +8        SET Y=TO

 +9        IF Y

               XECUTE ^DD("DD")

               SET TO=Y

 +10       WRITE !!,"PATIENT: ",PATIENT,"  VISIT DATE: ",VISDATE

 +11       IF TO]""

               WRITE "  TO: ",TO

 +12       SET DIR("B")=VISDATE

 +13       SET DIR(0)="DO"

 +14       SET DIR("A")="Beginning Date for Supply/Med Charges"

 +15       SET DIR("?")="Enter the earliest date to include for supply/med charges"

 +16       WRITE !

 +17       DO ^DIR

           KILL DIR

 +18       IF Y<1

               SET ABMQUIT=""

               QUIT

 +19       SET ABMBEGIN=+Y

 +20       SET ABMEND=+Y

 +21       SET Y=DT

 +22       XECUTE ^DD("DD")

 +23       SET DIR("B")=Y

 +24       SET DIR(0)="DO"

 +25       SET DIR("A")="Ending Date for Supply/Med Charges"

 +26       SET DIR("?")="Enter the last date to include for supply/med charges"

 +27       WRITE !

 +28       DO ^DIR

           KILL DIR

 +29       IF 'Y

               SET ABMEND=ABMBEGIN

 +30       SET ABMEND=+Y

 +31       QUIT

DINIT     ;EP;LIST ALL SUPPLY ITEMS IN THE DATE RANGE

 +1        KILL ^TMP("ABMDTMS",$JOB)

 +2        SET ABMCNT=0

 +3        DO HEAD

 +4        SET ABM=ABMBEGIN-1

 +5        FOR

               SET ABM=$ORDER(^AUPNSUP("ASUP",DFN,ABM))

               IF 'ABM!(ABM>(ABMEND+.9999))

                   QUIT

               Begin DoDot:1

 +6                SET ABMSDA=0

 +7                FOR

                       SET ABMSDA=$ORDER(^AUPNSUP("ASUP",DFN,ABM,ABMSDA))

                       IF 'ABMSDA

                           QUIT

                       Begin DoDot:2

 +8                        DO SUPPSET

 +9                        IF ABM0=""

                               QUIT

 +10                       DO FORMAT

                       End DoDot:2

               End DoDot:1

 +11       SET (VALMCNT,ABMJ)=J

 +12       QUIT

SUPPSET   ;SET SUPPLY VARIABLES

 +1        SET ABM0=$GET(^AUPNSUP(ABMSDA,0))

 +2        SET ABM1=$GET(^AUPNSUP(ABMSDA,1))

 +3        SET ABM2=$GET(^AUPNSUP(ABMSDA,2))

 +4        QUIT

HEAD      ;

 +1        SET J=0

 +2        SET X=""

 +3        SET $EXTRACT(X,19)="3P NUM: "_ABMNUM

 +4        DO J

 +5        SET $EXTRACT(X,18)="PATIENT: "_PATIENT

 +6        DO J

 +7        SET $EXTRACT(X,9)="ADMIT/VISIT FROM: "_VISDATE_"  TO: "_TO

 +8        DO J

 +9        SET X=""

 +10       SET $EXTRACT(X,51)="TRANCODE/"

 +11       SET $EXTRACT(X,67)="REV/"

 +12       DO J

 +13       SET X="SUPPLY/MED NAME"

 +14       SET $EXTRACT(X,36)="QUAN"

 +15       SET $EXTRACT(X,44)="PRICE"

 +16       SET $EXTRACT(X,51)="NDC"

 +17       SET $EXTRACT(X,61)="HCPC"

 +18       SET $EXTRACT(X,67)="DEPT"

 +19       SET $EXTRACT(X,72)="CLAIM NO."

 +20       DO J

 +21       SET X="--------------------------------------------------------------------------------"

 +22       DO J

 +23       SET JHEAD=J

 +24       QUIT

FORMAT    ;FORMAT DATA FOR DISPLAY

 +1        SET SUPPLY=$PIECE(ABM0,U)

 +2        SET PATIENT=$PIECE($GET(^DPT(DFN,0)),U)

 +3        SET ADMIT=$GET(^ABMDCLM(DUZ(2),ABMDA,6))

 +4        SET DISCHARG=$PIECE(ADMIT,U,3)

 +5        SET ADMIT=+ADMIT

 +6        SET FROM=$GET(^ABMDCLM(DUZ(2),ABMDA,7))

 +7        SET TO=$PIECE(FROM,U,2)

 +8        SET FROM=+FROM

 +9        IF ADMIT

               Begin DoDot:1

 +10               SET Y=ADMIT

 +11               XECUTE ^DD("DD")

 +12               SET ADMIT=Y

               End DoDot:1

 +13       IF DISCHARG

               Begin DoDot:1

 +14               SET Y=DISCHARG

 +15               XECUTE ^DD("DD")

 +16               SET DISCHARG=Y

               End DoDot:1

 +17       IF FROM

               Begin DoDot:1

 +18               SET Y=ADMIT

 +19               XECUTE ^DD("DD")

 +20               SET FROM=Y

               End DoDot:1

 +21       IF TO

               Begin DoDot:1

 +22               SET Y=TO

 +23               XECUTE ^DD("DD")

 +24               SET TO=Y

               End DoDot:1

 +25       SET Y=$PIECE(ABM0,U,3)

 +26       XECUTE ^DD("DD")

 +27       SET ISSUDATE=Y

 +28       SET CLAIM=$PIECE(ABM0,U,6)

 +29       SET TRANCODE=$PIECE(ABM1,U)

 +30       SET MEDDA=$PIECE(ABM1,U,3)

 +31       SET NDC=$PIECE($GET(^PSDRUG(+MEDDA,2)),U,4)

 +32       SET DEPTCODE=$PIECE(ABM1,U,5)

 +33       SET QUANTITY=$PIECE(ABM2,U,3)

 +34       SET PRICE=$PIECE(ABM2,U,4)

 +35      ;CSV-c

           SET HCPCCODE=$PIECE($$CPT^ABMCVAPI(+$PIECE(ABM2,U,5),FROM),U,2)

 +36       SET REVCODE=$PIECE($GET(^AUTTREVN(+$PIECE(ABM2,U,6),0)),U)

 +37       SET ABMCNT=ABMCNT+1

 +38       SET X=ABMCNT

 +39       SET $EXTRACT(X,4)=$EXTRACT(SUPPLY,1,32)

 +40       SET $EXTRACT(X,36)=$JUSTIFY(QUANTITY,4)

 +41       SET $EXTRACT(X,40)=$JUSTIFY($FNUMBER(PRICE,"P",2),10)

 +42       SET $EXTRACT(X,51)=$EXTRACT(TRANCODE,1,10)

 +43       SET $EXTRACT(X,61)=$EXTRACT(HCPCCODE,1,6)

 +44       SET $EXTRACT(X,67)=$EXTRACT(REVCODE,1,3)

 +45       IF CLAIM]""

               SET $EXTRACT(X,71)=$EXTRACT(CLAIM,1,10)

 +46       DO J

 +47       SET X="   "_ISSUDATE

 +48       SET $EXTRACT(X,51)=$EXTRACT(NDC,1,12)

 +49       SET $EXTRACT(X,67)=DEPTCODE

 +50       DO J

 +51       SET ^TMP("ABMSUP",$JOB,ABMCNT)=ABMSDA

 +52       QUIT

ADDITEM   ;ADD SUPPLY TO CLAIM

 +1        NEW ABMJ,ABMX

 +2        FOR ABMJ=1:1

               SET ABMX=$PIECE(ABMSET,",",ABMJ)

               IF 'ABMX

                   QUIT

               DO A1

 +3        QUIT

A1        ;ADD ITEMS TO THE CLAIM

 +1        SET DA(1)=ABMDA

 +2        SET ABMSDA=$GET(^TMP("ABMSUP",$JOB,ABMX))

 +3        IF 'ABMSDA

               QUIT

 +4        DO SUPPSET

 +5        SET X=""

 +6        IF $PIECE(ABM1,U,3)

               Begin DoDot:1

 +7                SET X=$PIECE(ABM1,U,3)

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

                       SET X=""

                       QUIT

 +9                SET DIC="^ABMDCLM("_DUZ(2)_","_ABMDA_",23,"

 +10               SET $PIECE(^ABMDCLM(DUZ(2),DA(1),23,0),U,2)="9002274.3023P"

 +11      ;S DIC("DR")=".02///"_$P(ABM2,U,6)_";.03////"_$P(ABM2,U,3)_";.04////"_$P(ABM2,U,4)_";.05////"_$S($G(DISPFEE):DISPFEE,1:4.5)_";.06////"_$S($P(ABM2,U,7)]"":$P(ABM2,U,7),1:"NOT STATED")_";.14////"_$P(ABM0,U,3)  ;;abm*2.6*21 IHS/SD/SDR HEAT110091

 +12      ;start new abm*2.6*21 IHS/SD/SDR HEAT110091

 +13              SET DIC("DR")=".02///"_$SELECT(+$PIECE(ABM2,U,6)'=0:$PIECE(ABM2,U,6),1:250)_";.03////"_$PIECE(ABM2,U,3)_";.04////"_...

                   ... $PIECE(ABM2,U,4)_";.05////"_$SELECT">SELECT($GET(DISPFEE):DISPFEE,1:4.5)_";.06////"_$SELECT">SELECT($PIECE(ABM2,U,7)]"":$PIECE(ABM2,U,7),1:"NOT STATED")_";.14////"_$PIECE(ABM0,U,3)

 +14      ;end new abm*2.6*21 IHS/SD/SDR HEAT110091

 +15      ;NDC  abm*2.6*10 HEAT74646

                   SET DIC("DR")=DIC("DR")_";.24////"_$PIECE($GET(^PSDRUG($PIECE(ABM1,U,3),2)),U,4)

               End DoDot:1

               IF 1

 +16      IF '$TEST

               IF $PIECE(ABM2,U,5)

                   Begin DoDot:1

 +17                   SET X=+$PIECE(ABM2,U,5)

 +18                   IF '$DATA(^ICPT(+X,0))

                           SET X=""

                           QUIT

 +19                   SET DIC="^ABMDCLM("_DUZ(2)_","_ABMDA_",43,"

 +20                   SET $PIECE(^ABMDCLM(DUZ(2),DA(1),43,0),U,2)="9002274.3043P"

 +21                   SET DIC("DR")=".02///"_$PIECE(ABM2,U,6)_";.03////"_$PIECE(ABM2,U,3)_";.04////"_$PIECE(ABM2,U,4)_";.06////"_$SELECT($PIECE(ABM2,U,7)]"":$PIECE(ABM2,U,7),1:"NOT STATED")_";.14////"_$PIECE(ABM0,U,3)

                   End DoDot:1

                   IF 1

 +22      IF '$TEST

               IF $PIECE(ABM2,U,6)

                   Begin DoDot:1

 +23                   SET X=+$PIECE(ABM2,U,6)

 +24                   IF '$DATA(^AUTTREVN(+X,0))

                           SET X=""

                           QUIT

 +25                   SET DIC="^ABMDCLM("_DUZ(2)_","_ABMDA_",25,"

 +26                   SET $PIECE(^ABMDCLM(DUZ(2),DA(1),25,0),U,2)="9002274.3025P"

 +27                   SET DIC("DR")=".02///"_$PIECE(ABM2,U,3)_";.03////"_$PIECE(ABM2,U,4)_";.04////"_$PIECE(ABM2,U,2)

                   End DoDot:1

                   IF 1

 +28       IF 'X

               QUIT

 +29       SET DIC(0)="L"

 +30       DO FILE^DICN

 +31       KILL DIC,DD,DA,DR

 +32       SET DA=ABMSDA

 +33       SET DIE="^AUPNSUP("

 +34       SET DR=".06////"_ABMDA

 +35       DO ^DIE

 +36       KILL DIC,DD,DIE,DA,DR

 +37       QUIT

DISP1     ;DISPLAY ALL RELEVANT ITEMS

 +1        SET ABMHDR=""

 +2        SET ABMVALM="ABMDTMS HL7 SUPPLY LIST"

 +3        DO VALM(ABMVALM)

 +4        QUIT

SELECT    ;EP;SELECT ITEMS TO ADD TO CLAIM

 +1        IF $GET(ABMDTMS)'="E"

               SET ABMDTMS="A"

 +2        SET DIR(0)="LO^1:"_ABMCNT

 +3        SET DIR("A")="Select Charges to add or edit"

 +4        WRITE !

 +5        DO ^DIR

           KILL DIR

 +6        KILL ABMQUIT

 +7        IF '+Y

               DO BACK

               QUIT

 +8        SET ABMSET=Y

 +9        IF ABMDTMS="A"

               DO ADD

               IF 1

 +10      IF '$TEST

               DO EDIT

 +11       KILL ABMDTMS

 +12       DO BACK

 +13       DO DINIT

 +14       QUIT

ADD        DO SURE

 +1        IF $DATA(ABMQUIT)

               KILL ABMQUIT

               QUIT

 +2        DO ADDITEM

 +3        QUIT

SURE      ;CONFIRM TRANSFER OF SUPPLIES

 +1        WRITE !!,"Are you certain you want to charge these items to the Claim/Bill"

 +2        WRITE !,ABMSET

 +3        SET DIR(0)="YO"

 +4        SET DIR("A")="Charge these supplies/meds to Claim/Bill "_ABMNUM_" "

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

 +6        WRITE !

 +7        DO ^DIR

           KILL DIR

 +8        IF 'Y

               SET ABMQUIT=""

               QUIT

 +9        QUIT

BACK       SET VALMBCK="R"

 +1        QUIT

J         ;SET TEMP ARRAY

 +1        SET J=J+1

 +2        SET ^TMP("ABMDTMS",$JOB,J,0)=X

 +3        SET X=""

 +4        QUIT

VALM(ABMVALM) ;EP; -- main entry point for list templates

 +1        SET VALMSG="- Previous Screen   Q Quit   ?? for More Actions"

 +2       ;1=screen mode, 0=scrolling mode

           SET VALMCC=1

 +3        DO BACK

 +4        DO TERM^VALM0

 +5        DO CLEAR^VALM1

 +6        DO EN^VALM(ABMVALM)

 +7        DO CLEAR^VALM1

 +8        QUIT

OPEN(DFN,ABMDA) ;EP;TO PROCESS WHEN CLAIM ALREAY IDENTIFIED

 +1        IF $DATA(ABMDTMS("OUT"))

               KILL ABMDTMS

               QUIT

 +2        SET ABMDTMS("OUT")=""

 +3        IF 'DFN!'ABMDA

               QUIT

 +4        KILL ABMQUIT

 +5        SET PATIENT=$PIECE($GET(^DPT(DFN,0)),U)

 +6        SET FROM=$GET(^ABMDCLM(DUZ(2),ABMDA,7))

 +7        SET TO=DT

 +8        SET FROM=+FROM

 +9        NEW X,Y,Z

 +10       SET Z=0

 +11       SET X=FROM-1

 +12       FOR

               SET X=$ORDER(^AUPNSUP("ASUP",DFN,X))

               IF 'X!Z!(X>TO)

                   QUIT

               Begin DoDot:1

 +13               SET Y=0

 +14               FOR

                       SET Y=$ORDER(^AUPNSUP("ASUP",DFN,X,Y))

                       IF 'Y

                           QUIT

                       Begin DoDot:2

 +15                       SET Z=Z+1

                       End DoDot:2

               End DoDot:1

 +16       IF 'Z

               QUIT

 +17       WRITE @IOF

 +18       WRITE !!,"There are SUPPLIES/MEDS on file that may need to be added to this claim."

 +19       DO CL1

 +20       DO DISPLAY

 +21       QUIT

HDR       ;EP; -- header code

 +1        SET VALMHDR(1)=$GET(ABMHDR)

 +2        SET VALMSG="- Previous Screen   Q Quit   ?? for More Actions"

 +3        QUIT

 +4       ;

HELP      ;EP; -- help code

 +1        SET X="?"

 +2        DO DISP^XQORM1

 +3        WRITE !!

 +4        QUIT

 +5       ;

EXIT      ;EP; -- exit code

 +1        KILL ^TMP("ABMLM",$JOB)

 +2        KILL ABMAR,ABMDIR,ABMFL,ABMFN,ABMHDR,ABMI,ABMROU,ABMDIR

 +3        IF '$GET(XQORS)

               DO CLEAR^VALM1

 +4        QUIT

EDIN      ;

 +1        SET ABMDTMS="E"

 +2        DO SELECT

 +3        KILL ABDMTMS

 +4        QUIT

EDIT      ;EDIT SUPPLY ITEMS

 +1        NEW ABMJ,ABMX

 +2        FOR ABMJ=1:1

               SET ABMX=$PIECE(ABMSET,",",ABMJ)

               IF 'ABMX

                   QUIT

               DO E1

 +3        QUIT

E1        ;EDIT ITEMS

 +1        SET DA=$GET(^TMP("ABMSUP",$JOB,ABMX))

 +2        IF 'DA

               QUIT

 +3        SET DR="[ABMDTMS SUPPLY EDIT]"

 +4        SET (DDSFILE,DIE)="^AUPNSUP("

 +5        DO ^DDS

 +6        QUIT

ABMDTMS.m