IBATFILE ;LL/ELZ - TRANSFER PRICING FILLING ; 22-JAN-1999
;;2.0;INTEGRATED BILLING;**115,389**;21-MAR-94;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified.
PAT(DA,IBFAC,IBOVER) ; files patient in transfer pricing returns dfn
Q:'$G(DA) 0
I $D(^IBAT(351.6,DA,0)) Q DA
N DO,DD,DIC,X,DINUM
S DIC="^IBAT(351.6,",DIC(0)="",X=DA,DINUM=DA
S DIC("DR")=".02///"_$$NOW^XLFDT_";.03////"_+$S($G(IBFAC):IBFAC,1:$$PPF^IBATUTL(DA))_";.04///1"_$S($D(IBOVER):";.1////"_+IBOVER,1:"")
D FILE^DICN
Q $S(Y>0:Y,1:0)
UPPPF(DA,PPF) ; updates a patient's enrolled facility
I '$G(DA)!('$G(PPF))!('$D(^IBAT(351.6,DA))) Q
N DIE,DR
S DIE="^IBAT(351.6,",DR=".03////"_+PPF D ^DIE
Q
ADM(DFN,IBADMDT,IBPREF,IBSOURCE) ; - files admissions
; IBADMDT=admission date, IBPREF=enrolled facility
; IBSOURCE=source (movement ien;DGPM(
I '$G(DFN)!('$G(IBADMDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0
Q $$NEW(DFN,IBADMDT,IBPREF,IBSOURCE)
DIS(DA,IBDISDT,IBPTF,IBDISM) ; - files discharges
; DA=transaction ien in 351.61, IBDISDT=discharge date
; IBPTF=ptf pointer, IBDISM=discharge movement pointer
I '$G(DA)!('$G(IBDISDT))!('$G(IBPTF))!('$G(IBDISM)) Q 0
N DIE,DR
S DIE="^IBAT(351.61,"
S DR=".05////C;.1////"_IBDISDT_";1.07////"_IBPTF_";1.08////"_IBDISM
L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked"
D ^DIE L -^IBAT(351.61,DA)
Q DA
DISC(DA) ; - deletes discharge data
; DA=transaction ien in 351.61
N DIE,DR Q:'$G(DA) 0
S DIE="^IBAT(351.61,"
S DR=".05////E;.1///@;1.08///@"
L +^IBAT(351.61,DA):10 I '$T Q "0^Transaction Locked"
D ^DIE L -^IBAT(351.61,DA)
Q DA
INPT(IBIEN,IBDRG,IBDRGA,IBLOS,IBHIGH,IBOUT,IBOUTR) ; - file remaining inpt
; IBIEN=transaction ien in 351.61, IBDRG=DRG pointer
; IBDRGA=DRG amount,IBLOS=inpatient LOS,IBHIGH=high trim days
; IBOUT=outlier days,IBOUTR=outlier rate
I '$G(IBIEN)!('$G(IBLOS))!('$D(IBHIGH))!('$D(IBOUT)) Q 0
N DIE,X,Y,DR
S DIE="^IBAT(351.61,",DA=IBIEN
S DR="1.03////"_IBLOS_";1.04////"_IBHIGH_";1.05////"_IBOUT
S:$G(IBDRG) DR=DR_";1.01///"_IBDRG
S:$G(IBDRGA) DR=DR_";1.02////"_IBDRGA
S:$G(IBOUTR) DR=DR_";1.06////"_IBOUTR
L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
D ^DIE,TOTAL^IBATCM(IBIEN) I $P($G(^IBAT(351.61,IBIEN,6)),"^",2) D
. S DR=";.05////P;.13////"_DT D ^DIE
L -^IBAT(351.61,IBIEN)
Q IBIEN
OUT(DFN,IBEDT,IBPREF,IBSOURCE,IBPROC) ; - files outpatient data
; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
; IBSOURCE=source (outpatient encounter ien;SCE(
; IBPROC=procedures (by ref in array)
I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0
N IBIEN,IBX,Y,IBPRICE
S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures
I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures"
S DIE="^IBAT(351.61,",DA=IBIEN
S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT)
D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN)
Q IBIEN
UPDATE(IBIEN,IBPROC) ; -- updates procedures
; IBIEN=351.61 ien, IBPROC=procedures by ref like above
Q:'$G(IBIEN) 0
N IBX,IBPRICE,DIE,DA,DR,X,Y
S IBIEN(0)=^IBAT(351.61,IBIEN,0),IBEDT=$P(IBIEN(0),"^",4)
; if approved, cancel and create a new one
I $P(IBIEN(0),"^",5)="A" D Q IBIEN
. S IBIEN=$$CANC(IBIEN)
. S IBIEN=$$OUT($P(IBIEN(0),"^",2),IBEDT,$P(IBIEN(0),"^",11),$P(IBIEN(0),"^",12),.IBPROC)
L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
; first clean out procedures there
S IBX=0 F S IBX=$O(^IBAT(351.61,IBIEN,3,IBX)) Q:IBX<1 S DIK="^IBAT(351.61,"_IBIEN_",3,",DA(1)=IBIEN,DA=IBX D ^DIK
S IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE) ; file procedures
I IBIEN<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures"
S DIE="^IBAT(351.61,",DA=IBIEN
S DR=".1////"_IBEDT_";.05////"_$S($G(IBPRICE):"C",1:"P;.13////"_DT)
D ^DIE,TOTAL^IBATCM(IBIEN) L -^IBAT(351.61,IBIEN)
Q IBIEN
RX(DFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST) ; - files pharmacy data
; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
; IBSOURCE=source (prescription ien;PSRX(;refill #
; IBDRUG=ien from drug file
; IBQTY=quantity of drug, IBCOST=drug cost
I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBDRUG))!('$G(IBQTY)) Q 0
N IBIEN
S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
S DIE="^IBAT(351.61,",DA=IBIEN
S DR=".1////"_+IBEDT_";4.01////"_+IBDRUG_";4.02////"_+IBQTY_";.05////"_$S($G(IBCOST):"P;4.03////"_+IBCOST_";.13////"_DT,1:"C")
L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN)
L -^IBAT(351.61,IBIEN)
Q IBIEN
;
RMPR(DFN,IBEDT,IBPREF,IBSOURCE,IBPROS,IBCOST) ; - files prost. data
; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
; IBSOURCE=source (prost ien;RMPR(660,
; IBPROS=ien from file 661 - removed in 389 no longer valid
; IBCOST=item cost
I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="") Q 0
N IBIEN
S IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE) I 'IBIEN Q IBIEN
S DIE="^IBAT(351.61,",DA=IBIEN
S DR=".1////"_+IBEDT_";.05////"_$S($G(IBCOST):"P;4.05////"_+IBCOST_";.13////"_DT,1:"C")
L +^IBAT(351.61,IBIEN):10 I '$T Q "0^Transaction Locked"
D ^DIE D:$G(IBCOST) TOTAL^IBATCM(IBIEN)
L -^IBAT(351.61,IBIEN)
Q IBIEN
;
CANC(DA) ; - used to cancel any transaction
N DIE,DR,X,Y Q:'$G(DA)
S DIE="^IBAT(351.61,",DR=".05///X" D ^DIE
Q
DEL(DA) ; - used to delete a transaction (only valid for inpatients or rx)
N DIK,DR,X,Y,Z Q:'$G(DA)
S Z=$G(^IBAT(351.61,DA,0)) Q:'Z
Q:$P(Z,"^",12)["SCE("
S DIK="^IBAT(351.61," D ^DIK
Q
NEW(DFN,IBEDT,IBPREF,IBSOURCE) ; - creates new transaction and returns ien
N IBIEN,IBSITE,DD,DO,DIC,X,Y,DINUM,DLAYGO,DIE,DA,DR
S IBSITE=$$SITE^IBATUTL
L +^IBAT(351.6,DFN):10 I '$T Q "0^Patient file Locked"
L +^IBAT(351.61,0):10 I '$T Q "0^Transaction File Locked"
S IBIEN=$P(^IBAT(351.61,0),"^",3)+1
F IBIEN=IBIEN:1 Q:'$D(^IBAT(351.61,"B",IBSITE_IBIEN))
S DIC="^IBAT(351.61,",DIC(0)="",X=IBSITE_IBIEN,DINUM=IBIEN,DLAYGO=351.61
S DIC("DR")=".02////"_+DFN_";.03////"_+DT_";.04////"_+IBEDT_";.05////E;.09////"_+IBEDT_";.11////"_+IBPREF_";.12////^S X=IBSOURCE"
D FILE^DICN I +Y<1 L -(^IBAT(351.61,0),^IBAT(351.6,DFN)) Q "0^Unable to add new transaction"
S DIE="^IBAT(351.6,",DA=+DFN
S DR=$S(IBSOURCE["DGPM":".05",IBSOURCE["SCE":".06",IBSOURCE["RMPR":".11",1:".07")_"////"_+IBEDT
I $P(^IBAT(351.6,DFN,0),"^",+(DR*100))<IBEDT D ^DIE
L -(^IBAT(351.61,0),^IBAT(351.6,DFN))
Q IBIEN
PROC(IBIEN,IBPROC,IBPRICE) ; files procedures
N X,Y
S Y=1,IBX=0 F S IBX=$O(IBPROC(IBX)) Q:IBX=""!(+Y<1) D
. N DIC,X,DA,DD,DO
. S DIC="^IBAT(351.61,"_IBIEN_",3,",DIC(0)="L"
. S X=IBX,DA(1)=IBIEN
. ;S DIC("P")=$P(^DD(351.61,3,0),"^",2) ; no longer required with fm22
. S DIC("DR")=".02////"_$P(IBPROC(IBX),"^")
. I $P(IBPROC(IBX),"^",2) S DIC("DR")=DIC("DR")_";.03////"_$P(IBPROC(IBX),"^",2)
. E S IBPRICE=1
. D FILE^DICN
I +Y<1 L -^IBAT(351.61,IBIEN) Q "0^Unable to file procedures"
Q IBIEN
DX(IBIEN,IBPTF) ; - files dx info
Q IBIEN
N IBX,Y S Y=1,IBX="" F S IBX=$O(IBDX(IBX)) Q:IBX=""!(+Y<1) D
. N DD,DO,DIC,DINUM,X
. S DIC="^IBAT(351.61,"_IBIEN_",2,",DIC(0)="",X=$P(IBDX(IBX),"^")
. ;S DA(1)=IBIEN,DIC("P")=$P(^DD(351.61,2,0),"^",2) D FILE^DICN
. ; no longer required with fm22
. S DA(1)=IBIEN D FILE^DICN
Q $S(+Y<1:"0^Unable to file diagnosis's",1:IBIEN)
;
INIT ; called to possibly initialize the 351.6 file if not done
N IBS,ZTRTN,ZTDESC,ZTIO,ZTSK,X,Y
;
Q:$O(^IBAT(351.6,0)) ; already populated
;
; is Transfer Pricing active or not for any
S IBS=$G(^IBE(350.9,1,10))
I '$P(IBS,"^",2),'$P(IBS,"^",3),'$P(IBS,"^",4),'$P(IBS,"^",5) Q
;
; queue off job
W !!,"It appears you have never used Transfer Pricing before. I need to populate",!,"the Transfer Pricing patient file. Please select a date/time to do this.",!
S ZTRTN="ADDTP^IBATFILE",ZTDESC="Initializing Transfer Pricing Patient File",ZTIO="" D ^%ZTLOAD
I $G(ZTSK) W !,"Task Queued #",ZTSK
;
Q
ADDTP ; Add Transfer Pricing patients to file #351.6
;
N DFN,IBADM,IBDFN,IBPREF,IBADMDT,IBX
;
S DFN=0 F S DFN=$O(^DPT(DFN)) Q:'DFN D
.;
.S IBDFN=$$TPP^IBATUTL(DFN)
.Q:'IBDFN
.;
.; - see if they are admitted
.S IBADM=$G(^DPT(DFN,.105))
.I IBADM D
..S IBPREF=+$P($G(^IBAT(351.6,DFN,0)),"^",3)
..S IBADMDT=+$G(^DGPM(IBADM,0))
..S IBX=$$ADM(DFN,IBADMDT,IBPREF,IBADM_";DGPM(")
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBATFILE 8526 printed Dec 13, 2024@02:07:47 Page 2
IBATFILE ;LL/ELZ - TRANSFER PRICING FILLING ; 22-JAN-1999
+1 ;;2.0;INTEGRATED BILLING;**115,389**;21-MAR-94;Build 6
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
PAT(DA,IBFAC,IBOVER) ; files patient in transfer pricing returns dfn
+1 if '$GET(DA)
QUIT 0
+2 IF $DATA(^IBAT(351.6,DA,0))
QUIT DA
+3 NEW DO,DD,DIC,X,DINUM
+4 SET DIC="^IBAT(351.6,"
SET DIC(0)=""
SET X=DA
SET DINUM=DA
+5 SET DIC("DR")=".02///"_$$NOW^XLFDT_";.03////"_+$S($GET(IBFAC):IBFAC,1:$$PPF^IBATUTL(DA))_";.04///1"_$SELECT($DATA(IBOVER):";.1////"_+IBOVER,1:"")
+6 DO FILE^DICN
+7 QUIT $SELECT(Y>0:Y,1:0)
UPPPF(DA,PPF) ; updates a patient's enrolled facility
+1 IF '$GET(DA)!('$GET(PPF))!('$DATA(^IBAT(351.6,DA)))
QUIT
+2 NEW DIE,DR
+3 SET DIE="^IBAT(351.6,"
SET DR=".03////"_+PPF
DO ^DIE
+4 QUIT
ADM(DFN,IBADMDT,IBPREF,IBSOURCE) ; - files admissions
+1 ; IBADMDT=admission date, IBPREF=enrolled facility
+2 ; IBSOURCE=source (movement ien;DGPM(
+3 IF '$GET(DFN)!('$GET(IBADMDT))!('$GET(IBPREF))!($GET(IBSOURCE)="")
QUIT 0
+4 QUIT $$NEW(DFN,IBADMDT,IBPREF,IBSOURCE)
DIS(DA,IBDISDT,IBPTF,IBDISM) ; - files discharges
+1 ; DA=transaction ien in 351.61, IBDISDT=discharge date
+2 ; IBPTF=ptf pointer, IBDISM=discharge movement pointer
+3 IF '$GET(DA)!('$GET(IBDISDT))!('$GET(IBPTF))!('$GET(IBDISM))
QUIT 0
+4 NEW DIE,DR
+5 SET DIE="^IBAT(351.61,"
+6 SET DR=".05////C;.1////"_IBDISDT_";1.07////"_IBPTF_";1.08////"_IBDISM
+7 LOCK +^IBAT(351.61,DA):10
IF '$TEST
QUIT "0^Transaction Locked"
+8 DO ^DIE
LOCK -^IBAT(351.61,DA)
+9 QUIT DA
DISC(DA) ; - deletes discharge data
+1 ; DA=transaction ien in 351.61
+2 NEW DIE,DR
if '$GET(DA)
QUIT 0
+3 SET DIE="^IBAT(351.61,"
+4 SET DR=".05////E;.1///@;1.08///@"
+5 LOCK +^IBAT(351.61,DA):10
IF '$TEST
QUIT "0^Transaction Locked"
+6 DO ^DIE
LOCK -^IBAT(351.61,DA)
+7 QUIT DA
INPT(IBIEN,IBDRG,IBDRGA,IBLOS,IBHIGH,IBOUT,IBOUTR) ; - file remaining inpt
+1 ; IBIEN=transaction ien in 351.61, IBDRG=DRG pointer
+2 ; IBDRGA=DRG amount,IBLOS=inpatient LOS,IBHIGH=high trim days
+3 ; IBOUT=outlier days,IBOUTR=outlier rate
+4 IF '$GET(IBIEN)!('$GET(IBLOS))!('$DATA(IBHIGH))!('$DATA(IBOUT))
QUIT 0
+5 NEW DIE,X,Y,DR
+6 SET DIE="^IBAT(351.61,"
SET DA=IBIEN
+7 SET DR="1.03////"_IBLOS_";1.04////"_IBHIGH_";1.05////"_IBOUT
+8 if $GET(IBDRG)
SET DR=DR_";1.01///"_IBDRG
+9 if $GET(IBDRGA)
SET DR=DR_";1.02////"_IBDRGA
+10 if $GET(IBOUTR)
SET DR=DR_";1.06////"_IBOUTR
+11 LOCK +^IBAT(351.61,IBIEN):10
IF '$TEST
QUIT "0^Transaction Locked"
+12 DO ^DIE
DO TOTAL^IBATCM(IBIEN)
IF $PIECE($GET(^IBAT(351.61,IBIEN,6)),"^",2)
Begin DoDot:1
+13 SET DR=";.05////P;.13////"_DT
DO ^DIE
End DoDot:1
+14 LOCK -^IBAT(351.61,IBIEN)
+15 QUIT IBIEN
OUT(DFN,IBEDT,IBPREF,IBSOURCE,IBPROC) ; - files outpatient data
+1 ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
+2 ; IBSOURCE=source (outpatient encounter ien;SCE(
+3 ; IBPROC=procedures (by ref in array)
+4 IF '$GET(DFN)!('$GET(IBEDT))!('$GET(IBPREF))!($GET(IBSOURCE)="")
QUIT 0
+5 NEW IBIEN,IBX,Y,IBPRICE
+6 SET IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE)
IF 'IBIEN
QUIT IBIEN
+7 LOCK +^IBAT(351.61,IBIEN):10
IF '$TEST
QUIT "0^Transaction Locked"
+8 ; file procedures
SET IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE)
+9 IF IBIEN<1
LOCK -^IBAT(351.61,IBIEN)
QUIT "0^Unable to file procedures"
+10 SET DIE="^IBAT(351.61,"
SET DA=IBIEN
+11 SET DR=".1////"_IBEDT_";.05////"_$SELECT($GET(IBPRICE):"C",1:"P;.13////"_DT)
+12 DO ^DIE
DO TOTAL^IBATCM(IBIEN)
LOCK -^IBAT(351.61,IBIEN)
+13 QUIT IBIEN
UPDATE(IBIEN,IBPROC) ; -- updates procedures
+1 ; IBIEN=351.61 ien, IBPROC=procedures by ref like above
+2 if '$GET(IBIEN)
QUIT 0
+3 NEW IBX,IBPRICE,DIE,DA,DR,X,Y
+4 SET IBIEN(0)=^IBAT(351.61,IBIEN,0)
SET IBEDT=$PIECE(IBIEN(0),"^",4)
+5 ; if approved, cancel and create a new one
+6 IF $PIECE(IBIEN(0),"^",5)="A"
Begin DoDot:1
+7 SET IBIEN=$$CANC(IBIEN)
+8 SET IBIEN=$$OUT($PIECE(IBIEN(0),"^",2),IBEDT,$PIECE(IBIEN(0),"^",11),$PIECE(IBIEN(0),"^",12),.IBPROC)
End DoDot:1
QUIT IBIEN
+9 LOCK +^IBAT(351.61,IBIEN):10
IF '$TEST
QUIT "0^Transaction Locked"
+10 ; first clean out procedures there
+11 SET IBX=0
FOR
SET IBX=$ORDER(^IBAT(351.61,IBIEN,3,IBX))
if IBX<1
QUIT
SET DIK="^IBAT(351.61,"_IBIEN_",3,"
SET DA(1)=IBIEN
SET DA=IBX
DO ^DIK
+12 ; file procedures
SET IBIEN=$$PROC(IBIEN,.IBPROC,.IBPRICE)
+13 IF IBIEN<1
LOCK -^IBAT(351.61,IBIEN)
QUIT "0^Unable to file procedures"
+14 SET DIE="^IBAT(351.61,"
SET DA=IBIEN
+15 SET DR=".1////"_IBEDT_";.05////"_$SELECT($GET(IBPRICE):"C",1:"P;.13////"_DT)
+16 DO ^DIE
DO TOTAL^IBATCM(IBIEN)
LOCK -^IBAT(351.61,IBIEN)
+17 QUIT IBIEN
RX(DFN,IBEDT,IBPREF,IBSOURCE,IBDRUG,IBQTY,IBCOST) ; - files pharmacy data
+1 ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
+2 ; IBSOURCE=source (prescription ien;PSRX(;refill #
+3 ; IBDRUG=ien from drug file
+4 ; IBQTY=quantity of drug, IBCOST=drug cost
+5 IF '$GET(DFN)!('$GET(IBEDT))!('$GET(IBPREF))!($GET(IBSOURCE)="")!('$GET(IBDRUG))!('$GET(IBQTY))
QUIT 0
+6 NEW IBIEN
+7 SET IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE)
IF 'IBIEN
QUIT IBIEN
+8 SET DIE="^IBAT(351.61,"
SET DA=IBIEN
+9 SET DR=".1////"_+IBEDT_";4.01////"_+IBDRUG_";4.02////"_+IBQTY_";.05////"_$SELECT($GET(IBCOST):"P;4.03////"_+IBCOST_";.13////"_DT,1:"C")
+10 LOCK +^IBAT(351.61,IBIEN):10
IF '$TEST
QUIT "0^Transaction Locked"
+11 DO ^DIE
if $GET(IBCOST)
DO TOTAL^IBATCM(IBIEN)
+12 LOCK -^IBAT(351.61,IBIEN)
+13 QUIT IBIEN
+14 ;
RMPR(DFN,IBEDT,IBPREF,IBSOURCE,IBPROS,IBCOST) ; - files prost. data
+1 ; DFN=dfn for patient, IBEDT=event date, IBPREF=enrolled facility
+2 ; IBSOURCE=source (prost ien;RMPR(660,
+3 ; IBPROS=ien from file 661 - removed in 389 no longer valid
+4 ; IBCOST=item cost
+5 IF '$GET(DFN)!('$GET(IBEDT))!('$GET(IBPREF))!($GET(IBSOURCE)="")
QUIT 0
+6 NEW IBIEN
+7 SET IBIEN=$$NEW(DFN,IBEDT,IBPREF,IBSOURCE)
IF 'IBIEN
QUIT IBIEN
+8 SET DIE="^IBAT(351.61,"
SET DA=IBIEN
+9 SET DR=".1////"_+IBEDT_";.05////"_$SELECT($GET(IBCOST):"P;4.05////"_+IBCOST_";.13////"_DT,1:"C")
+10 LOCK +^IBAT(351.61,IBIEN):10
IF '$TEST
QUIT "0^Transaction Locked"
+11 DO ^DIE
if $GET(IBCOST)
DO TOTAL^IBATCM(IBIEN)
+12 LOCK -^IBAT(351.61,IBIEN)
+13 QUIT IBIEN
+14 ;
CANC(DA) ; - used to cancel any transaction
+1 NEW DIE,DR,X,Y
if '$GET(DA)
QUIT
+2 SET DIE="^IBAT(351.61,"
SET DR=".05///X"
DO ^DIE
+3 QUIT
DEL(DA) ; - used to delete a transaction (only valid for inpatients or rx)
+1 NEW DIK,DR,X,Y,Z
if '$GET(DA)
QUIT
+2 SET Z=$GET(^IBAT(351.61,DA,0))
if 'Z
QUIT
+3 if $PIECE(Z,"^",12)["SCE("
QUIT
+4 SET DIK="^IBAT(351.61,"
DO ^DIK
+5 QUIT
NEW(DFN,IBEDT,IBPREF,IBSOURCE) ; - creates new transaction and returns ien
+1 NEW IBIEN,IBSITE,DD,DO,DIC,X,Y,DINUM,DLAYGO,DIE,DA,DR
+2 SET IBSITE=$$SITE^IBATUTL
+3 LOCK +^IBAT(351.6,DFN):10
IF '$TEST
QUIT "0^Patient file Locked"
+4 LOCK +^IBAT(351.61,0):10
IF '$TEST
QUIT "0^Transaction File Locked"
+5 SET IBIEN=$PIECE(^IBAT(351.61,0),"^",3)+1
+6 FOR IBIEN=IBIEN:1
if '$DATA(^IBAT(351.61,"B",IBSITE_IBIEN))
QUIT
+7 SET DIC="^IBAT(351.61,"
SET DIC(0)=""
SET X=IBSITE_IBIEN
SET DINUM=IBIEN
SET DLAYGO=351.61
+8 SET DIC("DR")=".02////"_+DFN_";.03////"_+DT_";.04////"_+IBEDT_";.05////E;.09////"_+IBEDT_";.11////"_+IBPREF_";.12////^S X=IBSOURCE"
+9 DO FILE^DICN
IF +Y<1
LOCK -(^IBAT(351.61,0),^IBAT(351.6,DFN))
QUIT "0^Unable to add new transaction"
+10 SET DIE="^IBAT(351.6,"
SET DA=+DFN
+11 SET DR=$SELECT(IBSOURCE["DGPM":".05",IBSOURCE["SCE":".06",IBSOURCE["RMPR":".11",1:".07")_"////"_+IBEDT
+12 IF $PIECE(^IBAT(351.6,DFN,0),"^",+(DR*100))<IBEDT
DO ^DIE
+13 LOCK -(^IBAT(351.61,0),^IBAT(351.6,DFN))
+14 QUIT IBIEN
PROC(IBIEN,IBPROC,IBPRICE) ; files procedures
+1 NEW X,Y
+2 SET Y=1
SET IBX=0
FOR
SET IBX=$ORDER(IBPROC(IBX))
if IBX=""!(+Y<1)
QUIT
Begin DoDot:1
+3 NEW DIC,X,DA,DD,DO
+4 SET DIC="^IBAT(351.61,"_IBIEN_",3,"
SET DIC(0)="L"
+5 SET X=IBX
SET DA(1)=IBIEN
+6 ;S DIC("P")=$P(^DD(351.61,3,0),"^",2) ; no longer required with fm22
+7 SET DIC("DR")=".02////"_$PIECE(IBPROC(IBX),"^")
+8 IF $PIECE(IBPROC(IBX),"^",2)
SET DIC("DR")=DIC("DR")_";.03////"_$PIECE(IBPROC(IBX),"^",2)
+9 IF '$TEST
SET IBPRICE=1
+10 DO FILE^DICN
End DoDot:1
+11 IF +Y<1
LOCK -^IBAT(351.61,IBIEN)
QUIT "0^Unable to file procedures"
+12 QUIT IBIEN
DX(IBIEN,IBPTF) ; - files dx info
+1 QUIT IBIEN
+2 NEW IBX,Y
SET Y=1
SET IBX=""
FOR
SET IBX=$ORDER(IBDX(IBX))
if IBX=""!(+Y<1)
QUIT
Begin DoDot:1
+3 NEW DD,DO,DIC,DINUM,X
+4 SET DIC="^IBAT(351.61,"_IBIEN_",2,"
SET DIC(0)=""
SET X=$PIECE(IBDX(IBX),"^")
+5 ;S DA(1)=IBIEN,DIC("P")=$P(^DD(351.61,2,0),"^",2) D FILE^DICN
+6 ; no longer required with fm22
+7 SET DA(1)=IBIEN
DO FILE^DICN
End DoDot:1
+8 QUIT $SELECT(+Y<1:"0^Unable to file diagnosis's",1:IBIEN)
+9 ;
INIT ; called to possibly initialize the 351.6 file if not done
+1 NEW IBS,ZTRTN,ZTDESC,ZTIO,ZTSK,X,Y
+2 ;
+3 ; already populated
if $ORDER(^IBAT(351.6,0))
QUIT
+4 ;
+5 ; is Transfer Pricing active or not for any
+6 SET IBS=$GET(^IBE(350.9,1,10))
+7 IF '$PIECE(IBS,"^",2)
IF '$PIECE(IBS,"^",3)
IF '$PIECE(IBS,"^",4)
IF '$PIECE(IBS,"^",5)
QUIT
+8 ;
+9 ; queue off job
+10 WRITE !!,"It appears you have never used Transfer Pricing before. I need to populate",!,"the Transfer Pricing patient file. Please select a date/time to do this.",!
+11 SET ZTRTN="ADDTP^IBATFILE"
SET ZTDESC="Initializing Transfer Pricing Patient File"
SET ZTIO=""
DO ^%ZTLOAD
+12 IF $GET(ZTSK)
WRITE !,"Task Queued #",ZTSK
+13 ;
+14 QUIT
ADDTP ; Add Transfer Pricing patients to file #351.6
+1 ;
+2 NEW DFN,IBADM,IBDFN,IBPREF,IBADMDT,IBX
+3 ;
+4 SET DFN=0
FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
Begin DoDot:1
+5 ;
+6 SET IBDFN=$$TPP^IBATUTL(DFN)
+7 if 'IBDFN
QUIT
+8 ;
+9 ; - see if they are admitted
+10 SET IBADM=$GET(^DPT(DFN,.105))
+11 IF IBADM
Begin DoDot:2
+12 SET IBPREF=+$PIECE($GET(^IBAT(351.6,DFN,0)),"^",3)
+13 SET IBADMDT=+$GET(^DGPM(IBADM,0))
+14 SET IBX=$$ADM(DFN,IBADMDT,IBPREF,IBADM_";DGPM(")
End DoDot:2
End DoDot:1
+15 ;
+16 QUIT
