ABMDE8D ; IHS/SD/SDR - Page 8 - MEDICATIONS ; APR 05, 2002
;;2.6;IHS Third Party Billing System;**2,7,9,19,21**;NOV 12, 2009;Build 379
;
;IHS/SD/SDR - V2.5 P8 - Rewrote routine - Request to completely change display
;IHS/SD/SDR - v2.5 p9 - IM16660 - 4-digit revenue codes
;IHS/SD/SDR - v2.5 p9 - task 1 - Use service line provider multiple
;IHS/SD/SDR - v2.5 p11 - NPI
;
;IHS/SD/SDR - 2.6*2 - 3PMS10003A - Modified to call ABMFEAPI
;IHS/SD/SDR - 2.6*19 - HEAT173117 - Added code to prompt for CPT Narrative if necessary for med.
;IHS/SD/SDR - 2.6*21 - HEAT168435 - Added code to display/add/edit pharmacy modifiers
;IHS/SD/SDR - 2.6*21 - HEAT207995 - Gave user ability to edit NDC even when a prescription from the
; prescription file is selected. They want ability to remove dashes in NDC.
;
DISP K ABMZ,DIC
S ABMZ("TITL")="MEDICATIONS",ABMZ("PG")="8D"
I $D(ABMP("DDL")),$Y>(IOSL-9) D PAUSE^ABMDE1 G:$D(DUOUT)!$D(DTOUT)!$D(DIROUT) XIT I 1
E D SUM^ABMDE1
;
D D^ABMDE8X
S $P(ABMZ("="),"=",81)=""
S ABMZ("SUB")=23,ABMZ("DIAG")=";.13"
S ABMZ("ITEM")="Medication",ABMZ("DIC")="^PSDRUG("
S ABMZ("X")="X",(ABM("FEE"),ABMZ("TOTL"))=0
D HD G LOOP
HD W !?5,"REVN",?11,"CHARGE",?60,"DAYS",?74,"TOTAL"
W !?5,"CODE",?11,"DATE",?30,"MEDICATION",?60,"SUPPLY",?68,"QTY",?74,"CHARGE"
W !,ABMZ("=")
Q
LOOP S (ABMZ("LNUM"),ABMZ("NUM"),ABMZ(1),ABM)=0 F ABM("I")=1:1 S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM)) Q:'ABM S ABM("X")=ABM,ABMZ("NUM")=ABM("I") D PC1
I ABMZ("NUM")>0 W !,?72,"========",!?5,"TOTAL",?71,$J("$"_($FN(ABMZ("TOTL"),",",2)),9)
I +$O(ABME(0)) S ABME("CONT")="" D ^ABMDERR K ABME("CONT")
G XIT
;
PC1 S ABM("X0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),0)
S ABM("X2")=$G(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),2)) ;abm*2.6*21 IHS/SD/SDR HEAT168435
S ABMZ("UNIT")=$P(ABM("X0"),U,3)
S:'+ABMZ("UNIT") ABMZ("UNIT")=1
Q:'$D(^PSDRUG(+ABM("X0"),0)) S ABMZ(ABM("I"))=$P(^(0),U)_U_ABM("X")_U_$P(ABM("X0"),U,2)
EOP I $Y>(IOSL-8) D PAUSE^ABMDE1,HD
W !,"[",ABM("I"),"]"
I $P(ABM("X0"),U,14) D
.W ?5,$$GETREV^ABMDUTL($P(ABM("X0"),U,2)) ;rev code
.W ?11,$$CDT^ABMDUTL($P(ABM("X0"),U,14)) ;charge date
.I $P(ABM("X0"),U,28)'="",($P(ABM("X0"),U,14)'=$P(ABM("X0"),U,28)) W "-",$$CDT^ABMDUTL($P(ABM("X0"),U,28))
I $P(ABM("X0"),U,26)'="" W " (+)" ;date disc
I $P(ABM("X0"),U,27)'="" W " (*)" ;RTS
W ?30,$S($P(ABM("X0"),U,22)]"":" Rx:"_$P($G(^PSRX($P(ABM("X0"),U,22),0)),U)_" ",$P($G(ABM("X0")),U,6)'="":" Rx: "_$P(ABM("X0"),U,6)_" ",1:"<No Rx>") ;Rx number
I $P(ABM("X0"),U,29)'="" W ?40,"CPT: ",$P($$CPT^ABMCVAPI(+$P(ABM("X0"),U,29),ABMP("VDT")),U,2) ;abm*2.6*7 HEAT30524
S ABMZ("MOD")="" ;abm*2.6*21 IHS/SD/SDR HEAT168435
F ABM("M")=3,4,5 S:$P(ABM("X2"),U,ABM("M"))]"" ABMZ("MOD")=ABMZ("MOD")_"-"_$P(ABM("X2"),U,ABM("M")) ;abm*2.6*21 IHS/SD/SDR HEAT168435
W:ABMZ("MOD")]"" ABMZ("MOD")_" " ;abm*2.6*21 IHS/SD/SDR HEAT168435
S ABMRPRV=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P","C","D",0))
S:ABMRPRV="" ABMRPRV=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P","C","R",0))
I ABMRPRV'="" D ;rendering provider on line item
.;W " ("_$P($G(^VA(200,$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P",ABMRPRV,0),U),0)),U)_"-"_$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P",ABMRPRV,0),U,2)_")" ;abm*2.6*7 HEAT30524
.;W !?51," ("_$E($P($G(^VA(200,$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P",ABMRPRV,0),U),0)),U),1,23)_"-"_$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P",ABMRPRV,0),U,2)_")" ;abm*2.6*7 HEAT30524 ;abm*2.6*21 IHS/SD/SDR HEAT168435
.W !?40," ("_$E($P($G(^VA(200,$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P",ABMRPRV,0),U),0)),U),1,23)_"-"_$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P",ABMRPRV,0),U,2)_")" ;abm*2.6*7 HEAT30524 ;abm*2.6*21 IHS/SD/SDR HEAT168435
W !
W ?4,$S($P($G(ABM("X0")),U,24)]"":$P(ABM("X0"),U,24)_" ",1:"<NO NDC> ") ;NDC number
S ABMU("TXT")=$P(ABMZ(ABM("I")),U) ;Medication
N M7,M8,M9
S M7=$P(ABM("X0"),U,7) ;additive
S M8=$P(ABM("X0"),U,8) ;solution
S M9=" "_$P(ABM("X0"),U,9) ;narrative
S ABMU("TXT")=ABMU("TXT")_" "_$S(M7&($D(^PS(52.6,+M7,0))):$P(^PS(52.6,M7,0),U)_M9,M8&($D(^PS(52.7,+M8,0))):$P(^(0),U)_M9,1:"")
S ABMU("RM")=57
S ABMU("LM")=22
D ^ABMDWRAP
W ?60,$J($P(ABM("X0"),U,20),3) ;days supply
W ?68,$J(ABMZ("UNIT"),3) ;quantity
W ?72,$J($FN(($P(ABM("X0"),U,4)*ABMZ("UNIT"))+$P(ABM("X0"),U,5),",",2),8) ;total charge
I $P(ABM("X0"),U,6)]"" D
.N DA S DA=$O(^PSRX("B",$P(ABM("X0"),"^",6),0)) Q:'DA
.S DIC="^PSRX(",DR=12,DIQ="ABM(",DIQ(0)="E" D EN^DIQ1 K DIQ
.Q:ABM(52,DA,12,"E")=""
.S ABMU("TXT")=$G(ABMU("TXT"))_" Comments: "_ABM(52,DA,12,"E")
S ABM("FEE")=ABM("FEE")+$P(ABM("X0"),U,5)
S ABMZ("CHARGE")=+$P(ABM("X0"),U,4) ;abm*2.6*21 IHS/SD/SDR HEAT168435
;S ABMZ("TOTL")=(ABMZ("UNIT")*$P(ABM("X0"),U,4))+ABMZ("TOTL")+$P(ABM("X0"),U,5) ;abm*2.6*21 IHS/SD/SDR HEAT168435
S ABMZ("TOTL")=(ABMZ("UNIT")*ABMZ("CHARGE"))+ABMZ("TOTL")+$P(ABM("X0"),U,5) ;abm*2.6*21 IHS/SD/SDR HEAT168435
Q
XIT K ABM,ABMMODE
Q
A ;EP ADD ENTRY
K DIC
S DIC="^PSDRUG("
S DIC(0)="AEMQ"
S DIC("P")=$P(^DD(9002274.3,23,0),U,2)
D ^DIC
Q:+Y<0 S ABMZ("DRUG")=+Y
S DA(1)=ABMP("CDFN")
S DIC="^ABMDCLM(DUZ(2),DA(1),23,",X=+Y
S ABMX("Y")=X,$P(ABMZ(ABMX("Y")),U,2)=X ;abm*2.6*21 IHS/SD/SDR HEAT168435
K DD,DO
D FILE^DICN
Q:Y<0 S DA=+Y
I '$G(ABMZ("NUM")) S ABMZ("NUM")=1
E ;EDIT EXISTING ENTRY
I +$G(ABMZ("NUM"))=0 W *7,!!,"There are no entries to edit, you must first ADD an entry.",! K DIR S DIR(0)="E" D ^DIR K DIR Q
I '$G(ABMZ("DRUG")) D Q:'Y
.S DA(1)=ABMP("CDFN")
.I ABMZ("NUM")=1 S Y=1
.E S DIR(0)="NO^1:"_ABMZ("NUM") D ^DIR K DIR Q:'Y
.S DA=$P(ABMZ(Y),U,2)
.S ABMZ("DRUG")=$P(^ABMDCLM(DUZ(2),DA(1),23,DA,0),U)
D MODE^ABMDE8X
S DIE="^ABMDCLM(DUZ(2),DA(1),23,"
;start new abm*2.6*21 IHS/SD/SDR HEAT168435
S ABMX("Y")=DA,$P(ABMZ(ABMX("Y")),U,2)=DA
S ABMZ("MOD")=.31_U_3_U_.32_U_.33
D MOD3^ABMDEMLC
;end new abm*2.6*21 IHS/SD/SDR HEAT168435
D PPDU Q:$D(DIRUT)
S DR=DR_".22Prescription"
S ABMSCRIP=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,22)
D ^DIE
I ABMSCRIP'="",$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,22)="" D Q ;the Prescription was removed
.K DIR,DIE,DIC
.S DA(1)=ABMP("CDFN")
.S DIK="^ABMDCLM(DUZ(2),"_DA(1)_",23,"
.D ^DIK
;if prescription, get data from there and just ask about Dxs
I $P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,22)'="" D
.S ABMIEN=$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,22)
.K DR
.S DR=".06////@" ;remove other Prescription#
.S DR=DR_";.03Units (at $"_ABMZ("PPDU")_" per unit)//"_$P($G(^PSRX(ABMIEN,0)),U,7)_";.04///"_ABMZ("PPDU") D ^DIE
.D DFEE S DR=".16Times Dispensed (at $"_ABMZ("DISPFEE")_" per each time dispensed) //1"
.D ^DIE Q:$D(Y)
.S DR=".05///"_(ABMZ("DISPFEE")*X) D ^DIE
.S DR=".25////"_$P($G(^PSRX(ABMIEN,0)),U,13) ;date written
.S DR=DR_";.2////"_$P($G(^PSRX(ABMIEN,0)),U,8) ;days supply
.;S DR=DR_";.24////"_$P($G(^PSRX(ABMIEN,2)),U,7) ;NDC ;abm*2.6*21 IHS/SD/SDR HEAT207995
.S DR=DR_";.24//"_$P($G(^PSRX(ABMIEN,2)),U,7) ;NDC ;abm*2.6*21 IHS/SD/SDR HEAT207995
.S DR=DR_";.29//" ;CPT code ;abm*2.6*7 HEAT30524
.D ^DIE
.D NARR ;abm*2.6*19 IHS/SD/SDR HEAT173117
.D PROV
;
;no prescription, prompt for all fields
;E D ;abm*2.6*19 IHS/SD/SDR HEAT173117
I $P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,22)="" D ;abm*2.6*19 IHS/SD/SDR HEAT173117
.S DR=".14//"_$S($P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,14)'="":$$SDT^ABMDUTL($P(^(0),U,14)),$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),7),U,1)'=$P(^(7),U,2):$$SDT^ABMDUTL($P(^(7),U)),1:"/"_$$SDT^ABMDUTL($P(^(7),U)))
.S DR=DR_";.28//"_$$SDT^ABMDUTL($P(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0),U,14))
.S DR=DR_";.03Units (at $"_ABMZ("PPDU")_" per unit);.04///"_ABMZ("PPDU")
.D ^DIE Q:$D(Y)
.S DR=".17///M" D ^DIE
.S ABM("X0")=^ABMDCLM(DUZ(2),DA(1),23,DA,0)
.D DFEE S DR=".16Times Dispensed (at $"_ABMZ("DISPFEE")_" per each time dispensed) //1"
.D ^DIE Q:$D(Y)
.S DR=".05///"_(ABMZ("DISPFEE")*X) D ^DIE
.S DR=".2;.06;.22////@;.19Refill"
.S DR=DR_";.24//"_$S($P($G(^PSDRUG(+ABM("X0"),2)),U,4)]"":$P(^(2),U,4),1:"")
.S DR=DR_";.25"
.S DR=DR_";.29//" ;CPT code ;abm*2.6*7 HEAT30524
.D ^DIE
.D NARR ;abm*2.6*19 IHS/SD/SDR HEAT173117
.D PROV
.;
I (^ABMDEXP(ABMMODE(4),0)["HCFA")!(^ABMDEXP(ABMMODE(4),0)["CMS") D
.D DX^ABMDEMLC S DR=".13////"_$G(Y(0)) D ^DIE
.S DIR(0)="E",DIR("A")="Enter RETURN to Continue" D ^DIR K DIR
Q
;
;start new abm*2.6*19 IHS/SD/SDR HEAT173117 NARR
NARR ;
I (+$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,29)'=0) D
.I $D(^ABMNINS(ABMP("LDFN"),ABMP("INS"),5,"B",$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,29))) D
..Q:$P($G(^ABMDEXP(ABMP("EXP"),0)),U)'["5010" ;only 5010 formats
..S ABMCNCK=$O(^ABMNINS(ABMP("LDFN"),ABMP("INS"),5,"B",$P($G(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,29),0))
..I ABMCNCK,$P($G(^ABMNINS(ABMP("LDFN"),ABMP("INS"),5,ABMCNCK,0)),U,2)="Y" S DR="22Narrative" D ^DIE
Q
;end new abm*2.6*19 IHS/SD/SDR HEAT173117 NARR
;
PPDU ;PRICE PER DISPENSE UNIT
S DR=""
S:^ABMDEXP(ABMMODE(4),0)["UB" DR=".02//250;"
;S ABMZ("PPDU")=+$P($G(^ABMDFEE(ABMP("FEE"),25,ABMZ("DRUG"),0)),U,2) ;abm*2.6*2 3PMS10003A
S ABMZ("PPDU")=+$P($$ONE^ABMFEAPI(ABMP("FEE"),25,ABMZ("DRUG"),ABMP("VDT")),U) ;abm*2.6*2 3PMS10003A
S:'ABMZ("PPDU") ABMZ("PPDU")=+$P($G(^PSDRUG(ABMZ("DRUG"),660)),U,6)
S DIR(0)="Y",DIR("A")="Is this entry an IV"
S DIR("B")=$S($P(^ABMDCLM(DUZ(2),DA(1),23,DA,0),"^",15)'="":"YES",1:"NO")
D ^DIR K DIR S ABMZ("IV")=Y I Y=1 D
.S DIR(0)="N^0:9999:3",DIR("B")=ABMZ("PPDU"),DIR("A")="IV Price per Unit"
.I $P(^ABMDCLM(DUZ(2),DA(1),23,DA,0),U,4) S DIR("B")=$P(^(0),U,4)
.D ^DIR K DIR S ABMZ("PPDU")=Y
.S DR=".02//IV;.15;.07;.08;.09;"
Q
DFEE ;GET DISPENSE FEE
S ABMZ("DISPFEE")=0
I ABMP("VTYP")'=111,ABMP("VTYP")'=831 S ABMZ("DISPFEE")=$P($G(^ABMDPARM(DUZ(2),1,0)),U,3) Q
I $P($G(ABM("X0")),U,15)="" S ABMZ("DISPFEE")=$P($G(^ABMDPARM(DUZ(2),1,4)),U,6) Q
S ABMZ("DISPFEE")=$P($G(^ABMDPARM(DUZ(2),1,4)),U,$F("APHSC",$P(ABM("X0"),U,15))-1)
Q
PROV ;
N DIC,DR,DIE
S DA(2)=ABMP("CDFN")
S (DA(1),ABMSIEN)=DA
S DIC="^ABMDCLM(DUZ(2),"_DA(2)_","_ABMZ("SUB")_","_DA(1)_",""P"","
S DIC(0)="AELMQ"
S ABMFLNM="9002274.30"_$G(ABMZ("SUB"))
S DIC("P")=$P(^DD(ABMFLNM,.18,0),U,2)
S DIC("DR")=".01;.02//R"
D ^DIC
K DIC,DR,DIE
I +Y>0,(+$P(Y,U,3)=0) D
.K DIE,DA,DR
.S DA(2)=ABMP("CDFN")
.S DA(1)=ABMSIEN
.S DIE="^ABMDCLM(DUZ(2),"_DA(2)_","_ABMZ("SUB")_","_DA(1)_",""P"","
.S DA=+Y
.S DR=".01//;.02"
.D ^DIE
S DA=+$G(DA(1))
S DA(1)=ABMP("CDFN")
Q
ABMDE8D ; IHS/SD/SDR - Page 8 - MEDICATIONS ; APR 05, 2002
+1 ;;2.6;IHS Third Party Billing System;**2,7,9,19,21**;NOV 12, 2009;Build 379
+2 ;
+3 ;IHS/SD/SDR - V2.5 P8 - Rewrote routine - Request to completely change display
+4 ;IHS/SD/SDR - v2.5 p9 - IM16660 - 4-digit revenue codes
+5 ;IHS/SD/SDR - v2.5 p9 - task 1 - Use service line provider multiple
+6 ;IHS/SD/SDR - v2.5 p11 - NPI
+7 ;
+8 ;IHS/SD/SDR - 2.6*2 - 3PMS10003A - Modified to call ABMFEAPI
+9 ;IHS/SD/SDR - 2.6*19 - HEAT173117 - Added code to prompt for CPT Narrative if necessary for med.
+10 ;IHS/SD/SDR - 2.6*21 - HEAT168435 - Added code to display/add/edit pharmacy modifiers
+11 ;IHS/SD/SDR - 2.6*21 - HEAT207995 - Gave user ability to edit NDC even when a prescription from the
+12 ; prescription file is selected. They want ability to remove dashes in NDC.
+13 ;
DISP KILL ABMZ,DIC
+1 SET ABMZ("TITL")="MEDICATIONS"
SET ABMZ("PG")="8D"
+2 IF $DATA(ABMP("DDL"))
IF $Y>(IOSL-9)
DO PAUSE^ABMDE1
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DIROUT)
GOTO XIT
IF 1
+3 IF '$TEST
DO SUM^ABMDE1
+4 ;
+5 DO D^ABMDE8X
+6 SET $PIECE(ABMZ("="),"=",81)=""
+7 SET ABMZ("SUB")=23
SET ABMZ("DIAG")=";.13"
+8 SET ABMZ("ITEM")="Medication"
SET ABMZ("DIC")="^PSDRUG("
+9 SET ABMZ("X")="X"
SET (ABM("FEE"),ABMZ("TOTL"))=0
+10 DO HD
GOTO LOOP
HD WRITE !?5,"REVN",?11,"CHARGE",?60,"DAYS",?74,"TOTAL"
+1 WRITE !?5,"CODE",?11,"DATE",?30,"MEDICATION",?60,"SUPPLY",?68,"QTY",?74,"CHARGE"
+2 WRITE !,ABMZ("=")
+3 QUIT
LOOP SET (ABMZ("LNUM"),ABMZ("NUM"),ABMZ(1),ABM)=0
FOR ABM("I")=1:1
SET ABM=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM))
IF 'ABM
QUIT
SET ABM("X")=ABM
SET ABMZ("NUM")=ABM("I")
DO PC1
+1 IF ABMZ("NUM")>0
WRITE !,?72,"========",!?5,"TOTAL",?71,$JUSTIFY("$"_($FNUMBER(ABMZ("TOTL"),",",2)),9)
+2 IF +$ORDER(ABME(0))
SET ABME("CONT")=""
DO ^ABMDERR
KILL ABME("CONT")
+3 GOTO XIT
+4 ;
PC1 SET ABM("X0")=^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),0)
+1 ;abm*2.6*21 IHS/SD/SDR HEAT168435
SET ABM("X2")=$GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),2))
+2 SET ABMZ("UNIT")=$PIECE(ABM("X0"),U,3)
+3 IF '+ABMZ("UNIT")
SET ABMZ("UNIT")=1
+4 IF '$DATA(^PSDRUG(+ABM("X0"),0))
QUIT
SET ABMZ(ABM("I"))=$PIECE(^(0),U)_U_ABM("X")_U_$PIECE(ABM("X0"),U,2)
EOP IF $Y>(IOSL-8)
DO PAUSE^ABMDE1
DO HD
+1 WRITE !,"[",ABM("I"),"]"
+2 IF $PIECE(ABM("X0"),U,14)
Begin DoDot:1
+3 ;rev code
WRITE ?5,$$GETREV^ABMDUTL($PIECE(ABM("X0"),U,2))
+4 ;charge date
WRITE ?11,$$CDT^ABMDUTL($PIECE(ABM("X0"),U,14))
+5 IF $PIECE(ABM("X0"),U,28)'=""
IF ($PIECE(ABM("X0"),U,14)'=$PIECE(ABM("X0"),U,28))
WRITE "-",$$CDT^ABMDUTL($PIECE(ABM("X0"),U,28))
End DoDot:1
+6 ;date disc
IF $PIECE(ABM("X0"),U,26)'=""
WRITE " (+)"
+7 ;RTS
IF $PIECE(ABM("X0"),U,27)'=""
WRITE " (*)"
+8 ;Rx number
WRITE ?30,$SELECT($PIECE(ABM("X0"),U,22)]"":" Rx:"_$PIECE($GET(^PSRX($PIECE(ABM("X0"),U,22),0)),U)_" ",$PIECE($GET(ABM("X0")),U,6)'="":" Rx: "_$PIECE(ABM("X0"),U,6)_" ",1:"<No Rx>")
+9 ;abm*2.6*7 HEAT30524
IF $PIECE(ABM("X0"),U,29)'=""
WRITE ?40,"CPT: ",$PIECE($$CPT^ABMCVAPI(+$PIECE(ABM("X0"),U,29),ABMP("VDT")),U,2)
+10 ;abm*2.6*21 IHS/SD/SDR HEAT168435
SET ABMZ("MOD")=""
+11 ;abm*2.6*21 IHS/SD/SDR HEAT168435
FOR ABM("M")=3,4,5
IF $PIECE(ABM("X2"),U,ABM("M"))]""
SET ABMZ("MOD")=ABMZ("MOD")_"-"_$PIECE(ABM("X2"),U,ABM("M"))
+12 ;abm*2.6*21 IHS/SD/SDR HEAT168435
IF ABMZ("MOD")]""
WRITE ABMZ("MOD")_" "
+13 SET ABMRPRV=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P","C","D",0))
+14 IF ABMRPRV=""
SET ABMRPRV=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P","C","R",0))
+15 ;rendering provider on line item
IF ABMRPRV'=""
Begin DoDot:1
+16 ;W " ("_$P($G(^VA(200,$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P",ABMRPRV,0),U),0)),U)_"-"_$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P",ABMRPRV,0),U,2)_")" ;abm*2.6*7 HEAT30524
+17 ;W !?51," ("_$E($P($G(^VA(200,$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P",ABMRPRV,0),U),0)),U),1,23)_"-"_$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P",ABMRPRV,0),U,2)_")" ;abm*2.6*7 HEAT30524 ;abm*2.6*21 IHS/SD/SDR HEAT168435
+18 ;abm*2.6*7 HEAT30524 ;abm*2.6*21 IHS/SD/SDR HEAT168435
WRITE !?40," ("_$EXTRACT($PIECE($GET(^VA(200,$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P",ABMRPRV,0),U),0)),U),1,23)_"-"_$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,ABM("X"),"P",ABMRPRV,0),U,2)_")"
End DoDot:1
+19 WRITE !
+20 ;NDC number
WRITE ?4,$SELECT($PIECE($GET(ABM("X0")),U,24)]"":$PIECE(ABM("X0"),U,24)_" ",1:"<NO NDC> ")
+21 ;Medication
SET ABMU("TXT")=$PIECE(ABMZ(ABM("I")),U)
+22 NEW M7,M8,M9
+23 ;additive
SET M7=$PIECE(ABM("X0"),U,7)
+24 ;solution
SET M8=$PIECE(ABM("X0"),U,8)
+25 ;narrative
SET M9=" "_$PIECE(ABM("X0"),U,9)
+26 SET ABMU("TXT")=ABMU("TXT")_" "_$SELECT(M7&($DATA(^PS(52.6,+M7,0))):$PIECE(^PS(52.6,M7,0),U)_M9,M8&($DATA(^PS(52.7,+M8,0))):$PIECE(^(0),U)_M9,1:"")
+27 SET ABMU("RM")=57
+28 SET ABMU("LM")=22
+29 DO ^ABMDWRAP
+30 ;days supply
WRITE ?60,$JUSTIFY($PIECE(ABM("X0"),U,20),3)
+31 ;quantity
WRITE ?68,$JUSTIFY(ABMZ("UNIT"),3)
+32 ;total charge
WRITE ?72,$JUSTIFY($FNUMBER(($PIECE(ABM("X0"),U,4)*ABMZ("UNIT"))+$PIECE(ABM("X0"),U,5),",",2),8)
+33 IF $PIECE(ABM("X0"),U,6)]""
Begin DoDot:1
+34 NEW DA
SET DA=$ORDER(^PSRX("B",$PIECE(ABM("X0"),"^",6),0))
IF 'DA
QUIT
+35 SET DIC="^PSRX("
SET DR=12
SET DIQ="ABM("
SET DIQ(0)="E"
DO EN^DIQ1
KILL DIQ
+36 IF ABM(52,DA,12,"E")=""
QUIT
+37 SET ABMU("TXT")=$GET(ABMU("TXT"))_" Comments: "_ABM(52,DA,12,"E")
End DoDot:1
+38 SET ABM("FEE")=ABM("FEE")+$PIECE(ABM("X0"),U,5)
+39 ;abm*2.6*21 IHS/SD/SDR HEAT168435
SET ABMZ("CHARGE")=+$PIECE(ABM("X0"),U,4)
+40 ;S ABMZ("TOTL")=(ABMZ("UNIT")*$P(ABM("X0"),U,4))+ABMZ("TOTL")+$P(ABM("X0"),U,5) ;abm*2.6*21 IHS/SD/SDR HEAT168435
+41 ;abm*2.6*21 IHS/SD/SDR HEAT168435
SET ABMZ("TOTL")=(ABMZ("UNIT")*ABMZ("CHARGE"))+ABMZ("TOTL")+$PIECE(ABM("X0"),U,5)
+42 QUIT
XIT KILL ABM,ABMMODE
+1 QUIT
A ;EP ADD ENTRY
+1 KILL DIC
+2 SET DIC="^PSDRUG("
+3 SET DIC(0)="AEMQ"
+4 SET DIC("P")=$PIECE(^DD(9002274.3,23,0),U,2)
+5 DO ^DIC
+6 IF +Y<0
QUIT
SET ABMZ("DRUG")=+Y
+7 SET DA(1)=ABMP("CDFN")
+8 SET DIC="^ABMDCLM(DUZ(2),DA(1),23,"
SET X=+Y
+9 ;abm*2.6*21 IHS/SD/SDR HEAT168435
SET ABMX("Y")=X
SET $PIECE(ABMZ(ABMX("Y")),U,2)=X
+10 KILL DD,DO
+11 DO FILE^DICN
+12 IF Y<0
QUIT
SET DA=+Y
+13 IF '$GET(ABMZ("NUM"))
SET ABMZ("NUM")=1
E ;EDIT EXISTING ENTRY
+1 IF +$GET(ABMZ("NUM"))=0
WRITE *7,!!,"There are no entries to edit, you must first ADD an entry.",!
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
QUIT
+2 IF '$GET(ABMZ("DRUG"))
Begin DoDot:1
+3 SET DA(1)=ABMP("CDFN")
+4 IF ABMZ("NUM")=1
SET Y=1
+5 IF '$TEST
SET DIR(0)="NO^1:"_ABMZ("NUM")
DO ^DIR
KILL DIR
IF 'Y
QUIT
+6 SET DA=$PIECE(ABMZ(Y),U,2)
+7 SET ABMZ("DRUG")=$PIECE(^ABMDCLM(DUZ(2),DA(1),23,DA,0),U)
End DoDot:1
IF 'Y
QUIT
+8 DO MODE^ABMDE8X
+9 SET DIE="^ABMDCLM(DUZ(2),DA(1),23,"
+10 ;start new abm*2.6*21 IHS/SD/SDR HEAT168435
+11 SET ABMX("Y")=DA
SET $PIECE(ABMZ(ABMX("Y")),U,2)=DA
+12 SET ABMZ("MOD")=.31_U_3_U_.32_U_.33
+13 DO MOD3^ABMDEMLC
+14 ;end new abm*2.6*21 IHS/SD/SDR HEAT168435
+15 DO PPDU
IF $DATA(DIRUT)
QUIT
+16 SET DR=DR_".22Prescription"
+17 SET ABMSCRIP=$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,22)
+18 DO ^DIE
+19 ;the Prescription was removed
IF ABMSCRIP'=""
IF $PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,22)=""
Begin DoDot:1
+20 KILL DIR,DIE,DIC
+21 SET DA(1)=ABMP("CDFN")
+22 SET DIK="^ABMDCLM(DUZ(2),"_DA(1)_",23,"
+23 DO ^DIK
End DoDot:1
QUIT
+24 ;if prescription, get data from there and just ask about Dxs
+25 IF $PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,22)'=""
Begin DoDot:1
+26 SET ABMIEN=$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,22)
+27 KILL DR
+28 ;remove other Prescription#
SET DR=".06////@"
+29 SET DR=DR_";.03Units (at $"_ABMZ("PPDU")_" per unit)//"_$PIECE($GET(^PSRX(ABMIEN,0)),U,7)_";.04///"_ABMZ("PPDU")
DO ^DIE
+30 DO DFEE
SET DR=".16Times Dispensed (at $"_ABMZ("DISPFEE")_" per each time dispensed) //1"
+31 DO ^DIE
IF $DATA(Y)
QUIT
+32 SET DR=".05///"_(ABMZ("DISPFEE")*X)
DO ^DIE
+33 ;date written
SET DR=".25////"_$PIECE($GET(^PSRX(ABMIEN,0)),U,13)
+34 ;days supply
SET DR=DR_";.2////"_$PIECE($GET(^PSRX(ABMIEN,0)),U,8)
+35 ;S DR=DR_";.24////"_$P($G(^PSRX(ABMIEN,2)),U,7) ;NDC ;abm*2.6*21 IHS/SD/SDR HEAT207995
+36 ;NDC ;abm*2.6*21 IHS/SD/SDR HEAT207995
SET DR=DR_";.24//"_$PIECE($GET(^PSRX(ABMIEN,2)),U,7)
+37 ;CPT code ;abm*2.6*7 HEAT30524
SET DR=DR_";.29//"
+38 DO ^DIE
+39 ;abm*2.6*19 IHS/SD/SDR HEAT173117
DO NARR
+40 DO PROV
End DoDot:1
+41 ;
+42 ;no prescription, prompt for all fields
+43 ;E D ;abm*2.6*19 IHS/SD/SDR HEAT173117
+44 ;abm*2.6*19 IHS/SD/SDR HEAT173117
IF $PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,22)=""
Begin DoDot:1
+45 SET DR=".14//"_$SELECT($PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,14)'="":$$SDT^ABMDUTL($PIECE(^(0),U,14)),$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),7),U,1)'=$PIECE(^(7),U,2):$$SDT^ABMDUTL($PIECE(^(7),U)),1:"/"_$$SDT^ABMDUTL($PIECE(
^(7),U)))
+46 SET DR=DR_";.28//"_$$SDT^ABMDUTL($PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0),U,14))
+47 SET DR=DR_";.03Units (at $"_ABMZ("PPDU")_" per unit);.04///"_ABMZ("PPDU")
+48 DO ^DIE
IF $DATA(Y)
QUIT
+49 SET DR=".17///M"
DO ^DIE
+50 SET ABM("X0")=^ABMDCLM(DUZ(2),DA(1),23,DA,0)
+51 DO DFEE
SET DR=".16Times Dispensed (at $"_ABMZ("DISPFEE")_" per each time dispensed) //1"
+52 DO ^DIE
IF $DATA(Y)
QUIT
+53 SET DR=".05///"_(ABMZ("DISPFEE")*X)
DO ^DIE
+54 SET DR=".2;.06;.22////@;.19Refill"
+55 SET DR=DR_";.24//"_$SELECT($PIECE($GET(^PSDRUG(+ABM("X0"),2)),U,4)]"":$PIECE(^(2),U,4),1:"")
+56 SET DR=DR_";.25"
+57 ;CPT code ;abm*2.6*7 HEAT30524
SET DR=DR_";.29//"
+58 DO ^DIE
+59 ;abm*2.6*19 IHS/SD/SDR HEAT173117
DO NARR
+60 DO PROV
+61 ;
End DoDot:1
+62 IF (^ABMDEXP(ABMMODE(4),0)["HCFA")!(^ABMDEXP(ABMMODE(4),0)["CMS")
Begin DoDot:1
+63 DO DX^ABMDEMLC
SET DR=".13////"_$GET(Y(0))
DO ^DIE
+64 SET DIR(0)="E"
SET DIR("A")="Enter RETURN to Continue"
DO ^DIR
KILL DIR
End DoDot:1
+65 QUIT
+66 ;
+67 ;start new abm*2.6*19 IHS/SD/SDR HEAT173117 NARR
NARR ;
+1 IF (+$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,29)'=0)
Begin DoDot:1
+2 IF $DATA(^ABMNINS(ABMP("LDFN"),ABMP("INS"),5,"B",$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,29)))
Begin DoDot:2
+3 ;only 5010 formats
IF $PIECE($GET(^ABMDEXP(ABMP("EXP"),0)),U)'["5010"
QUIT
+4 SET ABMCNCK=$ORDER(^ABMNINS(ABMP("LDFN"),ABMP("INS"),5,"B",$PIECE($GET(^ABMDCLM(DUZ(2),ABMP("CDFN"),23,DA,0)),U,29),0))
+5 IF ABMCNCK
IF $PIECE($GET(^ABMNINS(ABMP("LDFN"),ABMP("INS"),5,ABMCNCK,0)),U,2)="Y"
SET DR="22Narrative"
DO ^DIE
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;end new abm*2.6*19 IHS/SD/SDR HEAT173117 NARR
+8 ;
PPDU ;PRICE PER DISPENSE UNIT
+1 SET DR=""
+2 IF ^ABMDEXP(ABMMODE(4),0)["UB"
SET DR=".02//250;"
+3 ;S ABMZ("PPDU")=+$P($G(^ABMDFEE(ABMP("FEE"),25,ABMZ("DRUG"),0)),U,2) ;abm*2.6*2 3PMS10003A
+4 ;abm*2.6*2 3PMS10003A
SET ABMZ("PPDU")=+$PIECE($$ONE^ABMFEAPI(ABMP("FEE"),25,ABMZ("DRUG"),ABMP("VDT")),U)
+5 IF 'ABMZ("PPDU")
SET ABMZ("PPDU")=+$PIECE($GET(^PSDRUG(ABMZ("DRUG"),660)),U,6)
+6 SET DIR(0)="Y"
SET DIR("A")="Is this entry an IV"
+7 SET DIR("B")=$SELECT($PIECE(^ABMDCLM(DUZ(2),DA(1),23,DA,0),"^",15)'="":"YES",1:"NO")
+8 DO ^DIR
KILL DIR
SET ABMZ("IV")=Y
IF Y=1
Begin DoDot:1
+9 SET DIR(0)="N^0:9999:3"
SET DIR("B")=ABMZ("PPDU")
SET DIR("A")="IV Price per Unit"
+10 IF $PIECE(^ABMDCLM(DUZ(2),DA(1),23,DA,0),U,4)
SET DIR("B")=$PIECE(^(0),U,4)
+11 DO ^DIR
KILL DIR
SET ABMZ("PPDU")=Y
+12 SET DR=".02//IV;.15;.07;.08;.09;"
End DoDot:1
+13 QUIT
DFEE ;GET DISPENSE FEE
+1 SET ABMZ("DISPFEE")=0
+2 IF ABMP("VTYP")'=111
IF ABMP("VTYP")'=831
SET ABMZ("DISPFEE")=$PIECE($GET(^ABMDPARM(DUZ(2),1,0)),U,3)
QUIT
+3 IF $PIECE($GET(ABM("X0")),U,15)=""
SET ABMZ("DISPFEE")=$PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,6)
QUIT
+4 SET ABMZ("DISPFEE")=$PIECE($GET(^ABMDPARM(DUZ(2),1,4)),U,$FIND("APHSC",$PIECE(ABM("X0"),U,15))-1)
+5 QUIT
PROV ;
+1 NEW DIC,DR,DIE
+2 SET DA(2)=ABMP("CDFN")
+3 SET (DA(1),ABMSIEN)=DA
+4 SET DIC="^ABMDCLM(DUZ(2),"_DA(2)_","_ABMZ("SUB")_","_DA(1)_",""P"","
+5 SET DIC(0)="AELMQ"
+6 SET ABMFLNM="9002274.30"_$GET(ABMZ("SUB"))
+7 SET DIC("P")=$PIECE(^DD(ABMFLNM,.18,0),U,2)
+8 SET DIC("DR")=".01;.02//R"
+9 DO ^DIC
+10 KILL DIC,DR,DIE
+11 IF +Y>0
IF (+$PIECE(Y,U,3)=0)
Begin DoDot:1
+12 KILL DIE,DA,DR
+13 SET DA(2)=ABMP("CDFN")
+14 SET DA(1)=ABMSIEN
+15 SET DIE="^ABMDCLM(DUZ(2),"_DA(2)_","_ABMZ("SUB")_","_DA(1)_",""P"","
+16 SET DA=+Y
+17 SET DR=".01//;.02"
+18 DO ^DIE
End DoDot:1
+19 SET DA=+$GET(DA(1))
+20 SET DA(1)=ABMP("CDFN")
+21 QUIT
