Routine: IB20P389

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.

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

 ; 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

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

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

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)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIB20P389   3371     printed  Apr 23, 2025@18:17:02                                                                                                                                                                                                    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

IB20P389.m