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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P389 3371 printed Dec 13, 2024@02:02:33 Page 2
IB20P389 ;ALB/ARH - IB*2.0*389 POST INIT: PROSTHETICS ITEM REPLACEMENT ; 20-FEB-2008
+1 ;;2.0;INTEGRATED BILLING;**389**;21-MAR-94;Build 6
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
PRE ; Clean up DD, remove fields exported so installs clean
+1 ; TRANSFER PRICING INPT PROSTHETIC ITEMS (#351.67), ITEM (.01) Output Transform not deleted by install
+2 SET DIK="^DD(351.61,"
SET DA(1)=351.61
SET DA=4.04
DO ^DIK
KILL DIK,DA
+3 SET DIK="^DD(351.67,"
SET DA(1)=351.67
SET DA=.01
DO ^DIK
KILL DIK,DA
+4 SET DIK="^DD(362.5,"
SET DA(1)=362.5
SET DA=.03
DO ^DIK
KILL DIK,DA
+5 QUIT
+6 ;
+7 ;
+8 ; Add Prosthetics Item Name to IB BILL/CLAIMS PROSTHETICS (#362.5, .05)
+9 ; This free text Item Name (#362.5, .05) replaces the ITEM pointer (#362.5, .03) to PROS ITEM MASTER (#661)
+10 ; The free Text Item Name will be based on the RECORD (#352.5, .04) if defined, otherwise ITEM (#362.5, .03):
+11 ; - Prosthetics HISTORICAL ITEM (660,89) if patient item (#362.5, .04) defined/set
+12 ; - Item Master PRE_NIF SHORT DESCRIPTION (#441,52) if defined and Delivery Date before last edit date
+13 ; - Item Master SHORT DESCRIPTION (#441,.05) if Delivery Date is after last edit date
+14 ;
+15 ; Delete all entries in TRANSFER PRICING INPT PROSTHETIC ITEMS (#351.67) file
+16 ; List of Prosthetics Item to not bill, changed Item pointer from #661 to #661.1
+17 ;
POST ;
+1 NEW IBA
+2 SET IBA(1)=""
SET IBA(2)=" IB*2*389 Prosthetics Item Replacement Post-Install ....."
SET IBA(3)=""
DO MESG
KILL IBA
+3 ;
+4 ; delete all TP Inpt Prosthetics Item (#352.67)
DO PIDEL
+5 ; add prosthetic item name to bill record (#362.5)
DO RBILL
+6 ;
+7 SET IBA(1)=""
SET IBA(2)=" IB*2*389 Prosthetics Item Replacement Post-Install Complete"
SET IBA(3)=""
DO MESG
KILL IBA
+8 ;
+9 QUIT
+10 ;
PIDEL ; Delete all entries from TRANSFER PRICING INPT PROSTHETIC ITEMS (#361.67)
+1 NEW IBPIFN,IBCNT,DIK,DIC,DIE,DA,X,Y
SET IBCNT=0
+2 ;
+3 SET IBPIFN=0
FOR
SET IBPIFN=$ORDER(^IBAT(351.67,IBPIFN))
if 'IBPIFN
QUIT
Begin DoDot:1
+4 ;
+5 SET DA=IBPIFN
SET DIK="^IBAT(351.67,"
DO ^DIK
KILL DIK,DA
SET IBCNT=IBCNT+1
End DoDot:1
+6 ;
+7 SET IBA(1)=" >> "_IBCNT_" TRANSFER PRICING INPT PROSTHETIC ITEMS deleted (#351.67)"
DO MESG
KILL IBA
+8 QUIT
+9 ;
RBILL ; Replace Bill Prosthetics Item pointer with name (#362.5)
+1 NEW IBPIN,IBPI0,IBDDT,IB661,IB660,IBNAME,IBCNT,DIE,DR,DA,DIC,DA,DO,X,Y
SET IBCNT=0
+2 ;
+3 SET IBPIN=0
FOR
SET IBPIN=$ORDER(^IBA(362.5,IBPIN))
if 'IBPIN
QUIT
Begin DoDot:1
+4 SET IBPI0=$GET(^IBA(362.5,IBPIN,0))
SET IBDDT=+IBPI0
if $PIECE(IBPI0,U,5)'=""
QUIT
+5 SET IB661=+$PIECE(IBPI0,U,3)
SET IB660=+$PIECE(IBPI0,U,4)
+6 ;
+7 SET IBNAME=$$NAME(IB661,IB660,IBDDT)
if IBNAME=""
QUIT
+8 ;
+9 SET DIE="^IBA(362.5,"
SET DA=IBPIN
SET DR=".05////^S X=IBNAME"
DO ^DIE
KILL DIE,DR,DA,DIC,DA,DO
SET IBCNT=IBCNT+1
End DoDot:1
+10 ;
+11 SET IBA(1)=" >> "_IBCNT_" IB BILL/CLAIMS PROSTHETICS Records converted (#362.5)"
DO MESG
KILL IBA
+12 QUIT
+13 ;
NAME(IP661,IP660,IDDT) ; Return free text name description for item
+1 NEW IBNAME,IB441,IBOLD,IBNEW,IBDATE
SET IDDT=+$GET(IDDT)
SET IBNAME=""
+2 ;
+3 IF +$GET(IP660)
SET IBNAME=$PIECE($GET(^RMPR(660,IP660,"HST")),U,1)
+4 ;
+5 IF IBNAME=""
IF +$GET(IP661)
Begin DoDot:1
+6 SET IB441=+$GET(^RMPR(661,+IP661,0))
if 'IB441
QUIT
+7 ; pre_nif short description
SET IBOLD=$PIECE($GET(^PRC(441,+IB441,9)),U,1)
+8 ; short description
SET IBNEW=$PIECE($GET(^PRC(441,+IB441,0)),U,2)
+9 ; date item created (last updated)
SET IBDATE=$PIECE($GET(^PRC(441,+IB441,0)),U,9)
+10 ;
+11 SET IBNAME=IBNEW
IF IBOLD'=""
IF IDDT<IBDATE
SET IBNAME=IBOLD
End DoDot:1
+12 ;
+13 IF $EXTRACT(IBNAME,1,2)="**"
SET IBNAME=$PIECE(IBNAME,"**",2)
+14 IF IBNAME=""
SET IBNAME="PROSTHETIC ITEM"
+15 ;
+16 QUIT IBNAME
+17 ;
MESG ;
+1 DO MES^XPDUTL(.IBA)
+2 QUIT
