Index: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATFILE.m
===================================================================
--- WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATFILE.m	(revision 613)
+++ WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATFILE.m	(revision 623)
@@ -1,197 +1,197 @@
-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
+IBATFILE ;LL/ELZ - TRANSFER PRICING FILLING  ; 22-JAN-1999
+ ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
+ ;;Per VHA Directive 10-93-142, 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
+ ; IBCOST=item cost
+ I '$G(DFN)!('$G(IBEDT))!('$G(IBPREF))!($G(IBSOURCE)="")!('$G(IBPROS)) 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.04////"_+IBPROS_";.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
