Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBATFILE

IBATFILE.m

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