- 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 Feb 18, 2025@23:34:12 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