IB20P389	;ALB/ARH - IB*2.0*389 POST INIT: PROSTHETICS ITEM REPLACEMENT ; 20-FEB-2008
	;;2.0;INTEGRATED BILLING;**389**;21-MAR-94;Build 6
	;;Per VHA Directive 2004-038, this routine should not be modified.
	;
	Q
	;
PRE	; Clean up DD, remove fields exported so installs clean
	; TRANSFER PRICING INPT PROSTHETIC ITEMS (#351.67), ITEM (.01) Output Transform not deleted by install
	S DIK="^DD(351.61,",DA(1)=351.61,DA=4.04 D ^DIK K DIK,DA
	S DIK="^DD(351.67,",DA(1)=351.67,DA=.01 D ^DIK K DIK,DA
	S DIK="^DD(362.5,",DA(1)=362.5,DA=.03 D ^DIK K DIK,DA
	Q
	;
	;
	; Add Prosthetics Item Name to IB BILL/CLAIMS PROSTHETICS (#362.5, .05)
	; This free text Item Name (#362.5, .05) replaces the ITEM pointer (#362.5, .03) to PROS ITEM MASTER (#661)
	; The free Text Item Name will be based on the RECORD (#352.5, .04) if defined, otherwise ITEM (#362.5, .03):
	; - Prosthetics HISTORICAL ITEM (660,89) if patient item (#362.5, .04) defined/set
	; - Item Master PRE_NIF SHORT DESCRIPTION (#441,52) if defined and Delivery Date before last edit date
	; - Item Master SHORT DESCRIPTION (#441,.05) if Delivery Date is after last edit date
	;
	; Delete all entries in TRANSFER PRICING INPT PROSTHETIC ITEMS (#351.67) file
	; List of Prosthetics Item to not bill, changed Item pointer from #661 to #661.1
	;
POST	;
	N IBA
	S IBA(1)="",IBA(2)="    IB*2*389 Prosthetics Item Replacement Post-Install .....",IBA(3)="" D MESG K IBA
	;
	D PIDEL ; delete all TP Inpt Prosthetics Item (#352.67)
	D RBILL ; add prosthetic item name to bill record (#362.5)
	;
	S IBA(1)="",IBA(2)="    IB*2*389 Prosthetics Item Replacement Post-Install Complete",IBA(3)="" D MESG K IBA
	;
	Q
	;
PIDEL	; Delete all entries from TRANSFER PRICING INPT PROSTHETIC ITEMS (#361.67)
	N IBPIFN,IBCNT,DIK,DIC,DIE,DA,X,Y S IBCNT=0
	;
	S IBPIFN=0 F  S IBPIFN=$O(^IBAT(351.67,IBPIFN)) Q:'IBPIFN  D
	. ;
	. S DA=IBPIFN,DIK="^IBAT(351.67," D ^DIK K DIK,DA S IBCNT=IBCNT+1
	;
	S IBA(1)="      >> "_IBCNT_" TRANSFER PRICING INPT PROSTHETIC ITEMS deleted (#351.67)" D MESG K IBA
	Q
	;
RBILL	; Replace Bill Prosthetics Item pointer with name (#362.5)
	N IBPIN,IBPI0,IBDDT,IB661,IB660,IBNAME,IBCNT,DIE,DR,DA,DIC,DA,DO,X,Y S IBCNT=0
	;
	S IBPIN=0 F  S IBPIN=$O(^IBA(362.5,IBPIN)) Q:'IBPIN  D
	. S IBPI0=$G(^IBA(362.5,IBPIN,0)) S IBDDT=+IBPI0 Q:$P(IBPI0,U,5)'=""
	. S IB661=+$P(IBPI0,U,3),IB660=+$P(IBPI0,U,4)
	. ;
	. S IBNAME=$$NAME(IB661,IB660,IBDDT) Q:IBNAME=""
	. ;
	. S DIE="^IBA(362.5,",DA=IBPIN,DR=".05////^S X=IBNAME" D ^DIE K DIE,DR,DA,DIC,DA,DO S IBCNT=IBCNT+1
	;
	S IBA(1)="      >> "_IBCNT_" IB BILL/CLAIMS PROSTHETICS Records converted (#362.5)" D MESG K IBA
	Q
	;
NAME(IP661,IP660,IDDT)	; Return free text name description for item
	N IBNAME,IB441,IBOLD,IBNEW,IBDATE S IDDT=+$G(IDDT),IBNAME=""
	;
	I +$G(IP660) S IBNAME=$P($G(^RMPR(660,IP660,"HST")),U,1)
	;
	I IBNAME="",+$G(IP661) D
	. S IB441=+$G(^RMPR(661,+IP661,0)) Q:'IB441
	. S IBOLD=$P($G(^PRC(441,+IB441,9)),U,1) ; pre_nif short description
	. S IBNEW=$P($G(^PRC(441,+IB441,0)),U,2) ; short description
	. S IBDATE=$P($G(^PRC(441,+IB441,0)),U,9) ; date item created (last updated)
	. ;
	. S IBNAME=IBNEW I IBOLD'="",IDDT<IBDATE S IBNAME=IBOLD
	;
	I $E(IBNAME,1,2)="**" S IBNAME=$P(IBNAME,"**",2)
	I IBNAME="" S IBNAME="PROSTHETIC ITEM"
	;
	Q IBNAME
	;
MESG	;
	D MES^XPDUTL(.IBA)
	Q