- IBTRR1 ;ALB/ARH - CLAIMS TRACKING - ROI SPECIAL CONSENT ACTIONS ; 08-JAN-2013
- ;;2.0;INTEGRATED BILLING;**458**;21-MAR-94;Build 4
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- AA ; Protocol Action: Add an ROI Special Consent
- I '$D(^XUSEC("IB ROI EDIT",DUZ)) W !!,"IB ROI EDIT Key Required to Add an ROI" H 2 S VALMBCK="R" Q
- D FULL^VALM1
- ;
- D ADD I +$G(IBRFN) D EDIT
- ;
- D BLD^IBTRR
- S VALMBCK="R"
- Q
- ;
- EA ; Protocol Action: Edit an ROI Special Consent
- I '$D(^XUSEC("IB ROI EDIT",DUZ)) W !!,"IB ROI EDIT Key Required to Edit an ROI" H 2 S VALMBCK="R" Q
- D FULL^VALM1
- ;
- N VALMY,I,J,IBXXR,IBRFN
- D EN^VALM2($G(XQORNOD(0)))
- I $D(VALMY) S IBXXR=0 F S IBXXR=$O(VALMY(IBXXR)) Q:'IBXXR D
- . S IBRFN=$P($G(^TMP("IBTRRX",$J,+$O(^TMP("IBTRR",$J,"IDX",IBXXR,0)))),U,2)
- . D ROIDSP(IBRFN)
- . D EDIT
- ;
- D BLD^IBTRR
- S VALMBCK="R"
- Q
- ;
- RA ; Protocol Action: Revoke an ROI Special Consent
- I '$D(^XUSEC("IB ROI EDIT",DUZ)) W !!,"IB ROI EDIT Key Required to Revoke an ROI" H 2 S VALMBCK="R" Q
- D FULL^VALM1
- ;
- N VALMY,I,J,IBXXR,IBRFN
- D EN^VALM2($G(XQORNOD(0)))
- I $D(VALMY) S IBXXR=0 F S IBXXR=$O(VALMY(IBXXR)) Q:'IBXXR D
- . S IBRFN=$P($G(^TMP("IBTRRX",$J,+$O(^TMP("IBTRR",$J,"IDX",IBXXR,0)))),U,2)
- . D ROIDSP(IBRFN)
- . D REVOKE
- ;
- D BLD^IBTRR
- S VALMBCK="R"
- Q
- ;
- DA ; Protocol Action: Delete an ROI Special Consent
- I '$D(^XUSEC("IB ROI EDIT",DUZ)) W !!,"IB ROI EDIT Key Required to Delete an ROI" H 2 S VALMBCK="R" Q
- D FULL^VALM1
- ;
- N VALMY,I,J,IBXXR,IBRFN
- D EN^VALM2($G(XQORNOD(0)))
- I $D(VALMY) S IBXXR=0 F S IBXXR=$O(VALMY(IBXXR)) Q:'IBXXR D
- . S IBRFN=$P($G(^TMP("IBTRRX",$J,+$O(^TMP("IBTRR",$J,"IDX",IBXXR,0)))),U,2)
- . D ROIDSP(IBRFN)
- . D DELETE
- ;
- D BLD^IBTRR
- S VALMBCK="R"
- Q
- ;
- OP ; Protocol Action: Open ROI Screen - called from CT Editor IBTRE ROI CONSENT
- D EN^IBTRR D HDR^IBTRE,BLD^IBTRE S VALMBCK="R"
- Q
- ;
- ;
- ADD ; add a new ROI Special Consent entry, IBRFN set on exit (record incomplete)
- N DD,DO,DA,DR,D0,DIR,DIC,DIE,DLAYGO,X,Y,VALMQUIT S IBRFN=0 W !
- ;
- I '$G(DFN) D PAT^IBCNSM W !! I '$D(DFN) Q
- ;
- S DIR(0)="Y",DIR("B")="NO",DIR("A")="Add a New ROI Special Consent" D ^DIR I Y'=1 Q
- ;
- W !!,"A New ROI Special Consent has been added for: ",$P($G(^DPT(+DFN,0)),U,1),!
- ;
- S X=$P(^IBT(356.26,0),U,3)+1
- S DIC="^IBT(356.26,",DIC(0)="L",DLAYGO=356.26
- S DIC("DR")=".02////"_DFN_";1.01///NOW;1.02////"_DUZ_";1.03///NOW;1.04////"_DUZ
- D FILE^DICN K DIC,DIE,DLAYGO I Y>0 S IBRFN=+Y
- ;
- Q
- ;
- EDIT ; edit an ROI Special Consent entry, IBRFN must be set on entry
- N DIC,DIE,DR,DA,D0,IBROIBG,IBDIFF,X,Y
- ;
- I '$D(^IBT(356.26,+$G(IBRFN),0)) Q
- D SAVE
- ;
- S DIE="^IBT(356.26,",DA=+IBRFN,DIE("NO^")="BACK"
- S DR=".03;@1;.04;S IBROIBG=X;.05;I X<IBROIBG W !!,""Expiraton date must not be before the Effective Date!"",! S Y=""@1"";2.01"
- D ^DIE
- ;
- D COMP I IBDIFF D UPDATE
- K ^TMP($J,"IBTRRS",356.26)
- Q
- ;
- REVOKE ; revoke an ROI entry, IBRFN must be defined
- N DIC,DIE,DR,DA,D0,IBDIFF,X,Y
- ;
- I '$D(^IBT(356.26,+$G(IBRFN),0)) Q
- D SAVE
- ;
- S DIE="^IBT(356.26,",DA=+IBRFN,DIE("NO^")="BACK"
- S DR=".06;I X'=1 S Y=""@1"";W !!,""Update the Expiration Date with the Date the revocation becomes effective."",!;.05;@1"
- D ^DIE
- ;
- D COMP I IBDIFF D UPDATE
- K ^TMP($J,"IBTRRS",356.26)
- Q
- ;
- DELETE ; delete and ROI entry, IBRFN must be defined
- N DIR,DIK,DA,DIRUT,X,Y
- ;
- I '$D(^IBT(356.26,+$G(IBRFN),0)) Q
- ;
- S DIR(0)="Y",DIR("B")="NO",DIR("A")="Delete this ROI Special Consent" D ^DIR I Y'=1 W " Not Deleted!" Q
- ;
- I Y=1 S DA=IBRFN,DIK="^IBT(356.26," D ^DIK W " Entry Deleted!"
- ;
- Q
- ;
- ;
- SAVE ; save entry before editing
- K ^TMP($J,"IBTRRS",356.26)
- S ^TMP($J,"IBTRRS",356.26,IBRFN,0)=$G(^IBT(356.26,+IBRFN,0))
- S ^TMP($J,"IBTRRS",356.26,IBRFN,1)=$G(^IBT(356.26,+IBRFN,1))
- S ^TMP($J,"IBTRRS",356.26,IBRFN,2)=$G(^IBT(356.26,+IBRFN,2))
- Q
- ;
- COMP ; compare before editing global with current global entry
- S IBDIFF=0
- I $G(^IBT(356.26,+IBRFN,0))'=$G(^TMP($J,"IBTRRS",356.26,IBRFN,0)) S IBDIFF=1
- I $G(^IBT(356.26,+IBRFN,1))'=$G(^TMP($J,"IBTRRS",356.26,IBRFN,1)) S IBDIFF=1
- I $G(^IBT(356.26,+IBRFN,2))'=$G(^TMP($J,"IBTRRS",356.26,IBRFN,2)) S IBDIFF=1
- Q
- ;
- UPDATE ; update last edited fields for entry
- N DIC,DIE,DR,DA,D0,X,Y
- S DIE="^IBT(356.26,",DA=+IBRFN,DR="1.03///NOW;1.04////"_DUZ D ^DIE
- Q
- ;
- ;
- ROIDSP(IBRFN) ; display an ROI entry
- N IBR0,IBR1,IBR2,IBDS S IBDS="",$P(IBDS,"-",IOM+1)=""
- S IBR0=$G(^IBT(356.26,+$G(IBRFN),0)) Q:IBR0=""
- S IBR1=$G(^IBT(356.26,IBRFN,1)),IBR2=$G(^IBT(356.26,IBRFN,2))
- ;
- W !!,IBDS,!,"ROI Special Consent for ",$P($G(^DPT(+$P(IBR0,U,2),0)),U,1),":"
- W !!,$$EXPAND^IBTRE(356.26,.03,$P(IBR0,U,3)),?37,$$DATE^IBTRR($P(IBR0,U,4))," - ",$$DATE^IBTRR($P(IBR0,U,5))
- W ?60,$S(+$$ACTIVE^IBTRR(IBRFN,DT):"ACTIVE",1:"INACTIVE"),?70,$S(+$P(IBR0,U,6):"REVOKED",1:"")
- W !!,"Comment: ",IBR2
- W !!,"Entered by: ",$E($$EXPAND^IBTRE(356.26,1.02,$P(IBR1,U,2)),1,21),?37,"Last Edited By: ",$E($$EXPAND^IBTRE(356.26,1.04,$P(IBR1,U,4)),1,21)
- W !,"Date Entered: ",$$FMTE^XLFDT($P(IBR1,U,1)),?37,"Date Last Edited: ",$$FMTE^XLFDT($P(IBR1,U,3)),!,IBDS,!
- Q
- ;
- ;
- ROIPAT(DFN,DATE) ; return Indicators of Conditions Active for Patient on Date (LM Patient List header)
- ; outputs alpha characters of sensitive conditions with active ROI
- N IBX,IBY,IBZ,IBRFN,IBR0 S (IBX,IBY,IBZ)="" S DFN=+$G(DFN) S DATE=$G(DATE)\1 I DATE'?7N S DATE=DT
- ;
- S IBRFN=0 F S IBRFN=$O(^IBT(356.26,"C",DFN,IBRFN)) Q:'IBRFN D
- . S IBR0=$G(^IBT(356.26,IBRFN,0))
- . I IBR0'="",DATE'<$P(IBR0,U,4),DATE'>$P(IBR0,U,5) S IBY(+$P(IBR0,U,3))=""
- S IBZ="" F IBY=1:1:4 I $D(IBY(IBY)) S IBZ=IBZ_IBY
- S IBX=$TR(IBZ,"1234","DAHS")
- Q IBX
- ;
- ROIEVT(IBTRN,SHRT) ; return ROI Consent and Indicators for a specific CT Event and Date (LM Event Detail)
- ; outputs CT entries ROI Consent and alpha characters of sensitive conditions with active ROI
- ;
- N IBX,IBY,IBTRN0,IBRSC S IBX="" S IBTRN0=$G(^IBT(356,+$G(IBTRN),0)),IBRSC=$P(IBTRN0,U,31)
- I +IBRSC S IBX=$$EXPAND^IBTRE(356,.31,IBRSC)_" "
- I +IBRSC=2 S IBY=$$ROIPAT(+$P(IBTRN0,U,2),+$P(IBTRN0,U,6)) I IBY'="" S:$G(SHRT) IBX=$E(IBX,1,6) S IBX=IBX_"("_IBY_")"
- Q IBX
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBTRR1 6214 printed Jan 18, 2025@03:30:05 Page 2
- IBTRR1 ;ALB/ARH - CLAIMS TRACKING - ROI SPECIAL CONSENT ACTIONS ; 08-JAN-2013
- +1 ;;2.0;INTEGRATED BILLING;**458**;21-MAR-94;Build 4
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- AA ; Protocol Action: Add an ROI Special Consent
- +1 IF '$DATA(^XUSEC("IB ROI EDIT",DUZ))
- WRITE !!,"IB ROI EDIT Key Required to Add an ROI"
- HANG 2
- SET VALMBCK="R"
- QUIT
- +2 DO FULL^VALM1
- +3 ;
- +4 DO ADD
- IF +$GET(IBRFN)
- DO EDIT
- +5 ;
- +6 DO BLD^IBTRR
- +7 SET VALMBCK="R"
- +8 QUIT
- +9 ;
- EA ; Protocol Action: Edit an ROI Special Consent
- +1 IF '$DATA(^XUSEC("IB ROI EDIT",DUZ))
- WRITE !!,"IB ROI EDIT Key Required to Edit an ROI"
- HANG 2
- SET VALMBCK="R"
- QUIT
- +2 DO FULL^VALM1
- +3 ;
- +4 NEW VALMY,I,J,IBXXR,IBRFN
- +5 DO EN^VALM2($GET(XQORNOD(0)))
- +6 IF $DATA(VALMY)
- SET IBXXR=0
- FOR
- SET IBXXR=$ORDER(VALMY(IBXXR))
- if 'IBXXR
- QUIT
- Begin DoDot:1
- +7 SET IBRFN=$PIECE($GET(^TMP("IBTRRX",$JOB,+$ORDER(^TMP("IBTRR",$JOB,"IDX",IBXXR,0)))),U,2)
- +8 DO ROIDSP(IBRFN)
- +9 DO EDIT
- End DoDot:1
- +10 ;
- +11 DO BLD^IBTRR
- +12 SET VALMBCK="R"
- +13 QUIT
- +14 ;
- RA ; Protocol Action: Revoke an ROI Special Consent
- +1 IF '$DATA(^XUSEC("IB ROI EDIT",DUZ))
- WRITE !!,"IB ROI EDIT Key Required to Revoke an ROI"
- HANG 2
- SET VALMBCK="R"
- QUIT
- +2 DO FULL^VALM1
- +3 ;
- +4 NEW VALMY,I,J,IBXXR,IBRFN
- +5 DO EN^VALM2($GET(XQORNOD(0)))
- +6 IF $DATA(VALMY)
- SET IBXXR=0
- FOR
- SET IBXXR=$ORDER(VALMY(IBXXR))
- if 'IBXXR
- QUIT
- Begin DoDot:1
- +7 SET IBRFN=$PIECE($GET(^TMP("IBTRRX",$JOB,+$ORDER(^TMP("IBTRR",$JOB,"IDX",IBXXR,0)))),U,2)
- +8 DO ROIDSP(IBRFN)
- +9 DO REVOKE
- End DoDot:1
- +10 ;
- +11 DO BLD^IBTRR
- +12 SET VALMBCK="R"
- +13 QUIT
- +14 ;
- DA ; Protocol Action: Delete an ROI Special Consent
- +1 IF '$DATA(^XUSEC("IB ROI EDIT",DUZ))
- WRITE !!,"IB ROI EDIT Key Required to Delete an ROI"
- HANG 2
- SET VALMBCK="R"
- QUIT
- +2 DO FULL^VALM1
- +3 ;
- +4 NEW VALMY,I,J,IBXXR,IBRFN
- +5 DO EN^VALM2($GET(XQORNOD(0)))
- +6 IF $DATA(VALMY)
- SET IBXXR=0
- FOR
- SET IBXXR=$ORDER(VALMY(IBXXR))
- if 'IBXXR
- QUIT
- Begin DoDot:1
- +7 SET IBRFN=$PIECE($GET(^TMP("IBTRRX",$JOB,+$ORDER(^TMP("IBTRR",$JOB,"IDX",IBXXR,0)))),U,2)
- +8 DO ROIDSP(IBRFN)
- +9 DO DELETE
- End DoDot:1
- +10 ;
- +11 DO BLD^IBTRR
- +12 SET VALMBCK="R"
- +13 QUIT
- +14 ;
- OP ; Protocol Action: Open ROI Screen - called from CT Editor IBTRE ROI CONSENT
- +1 DO EN^IBTRR
- DO HDR^IBTRE
- DO BLD^IBTRE
- SET VALMBCK="R"
- +2 QUIT
- +3 ;
- +4 ;
- ADD ; add a new ROI Special Consent entry, IBRFN set on exit (record incomplete)
- +1 NEW DD,DO,DA,DR,D0,DIR,DIC,DIE,DLAYGO,X,Y,VALMQUIT
- SET IBRFN=0
- WRITE !
- +2 ;
- +3 IF '$GET(DFN)
- DO PAT^IBCNSM
- WRITE !!
- IF '$DATA(DFN)
- QUIT
- +4 ;
- +5 SET DIR(0)="Y"
- SET DIR("B")="NO"
- SET DIR("A")="Add a New ROI Special Consent"
- DO ^DIR
- IF Y'=1
- QUIT
- +6 ;
- +7 WRITE !!,"A New ROI Special Consent has been added for: ",$PIECE($GET(^DPT(+DFN,0)),U,1),!
- +8 ;
- +9 SET X=$PIECE(^IBT(356.26,0),U,3)+1
- +10 SET DIC="^IBT(356.26,"
- SET DIC(0)="L"
- SET DLAYGO=356.26
- +11 SET DIC("DR")=".02////"_DFN_";1.01///NOW;1.02////"_DUZ_";1.03///NOW;1.04////"_DUZ
- +12 DO FILE^DICN
- KILL DIC,DIE,DLAYGO
- IF Y>0
- SET IBRFN=+Y
- +13 ;
- +14 QUIT
- +15 ;
- EDIT ; edit an ROI Special Consent entry, IBRFN must be set on entry
- +1 NEW DIC,DIE,DR,DA,D0,IBROIBG,IBDIFF,X,Y
- +2 ;
- +3 IF '$DATA(^IBT(356.26,+$GET(IBRFN),0))
- QUIT
- +4 DO SAVE
- +5 ;
- +6 SET DIE="^IBT(356.26,"
- SET DA=+IBRFN
- SET DIE("NO^")="BACK"
- +7 SET DR=".03;@1;.04;S IBROIBG=X;.05;I X<IBROIBG W !!,""Expiraton date must not be before the Effective Date!"",! S Y=""@1"";2.01"
- +8 DO ^DIE
- +9 ;
- +10 DO COMP
- IF IBDIFF
- DO UPDATE
- +11 KILL ^TMP($JOB,"IBTRRS",356.26)
- +12 QUIT
- +13 ;
- REVOKE ; revoke an ROI entry, IBRFN must be defined
- +1 NEW DIC,DIE,DR,DA,D0,IBDIFF,X,Y
- +2 ;
- +3 IF '$DATA(^IBT(356.26,+$GET(IBRFN),0))
- QUIT
- +4 DO SAVE
- +5 ;
- +6 SET DIE="^IBT(356.26,"
- SET DA=+IBRFN
- SET DIE("NO^")="BACK"
- +7 SET DR=".06;I X'=1 S Y=""@1"";W !!,""Update the Expiration Date with the Date the revocation becomes effective."",!;.05;@1"
- +8 DO ^DIE
- +9 ;
- +10 DO COMP
- IF IBDIFF
- DO UPDATE
- +11 KILL ^TMP($JOB,"IBTRRS",356.26)
- +12 QUIT
- +13 ;
- DELETE ; delete and ROI entry, IBRFN must be defined
- +1 NEW DIR,DIK,DA,DIRUT,X,Y
- +2 ;
- +3 IF '$DATA(^IBT(356.26,+$GET(IBRFN),0))
- QUIT
- +4 ;
- +5 SET DIR(0)="Y"
- SET DIR("B")="NO"
- SET DIR("A")="Delete this ROI Special Consent"
- DO ^DIR
- IF Y'=1
- WRITE " Not Deleted!"
- QUIT
- +6 ;
- +7 IF Y=1
- SET DA=IBRFN
- SET DIK="^IBT(356.26,"
- DO ^DIK
- WRITE " Entry Deleted!"
- +8 ;
- +9 QUIT
- +10 ;
- +11 ;
- SAVE ; save entry before editing
- +1 KILL ^TMP($JOB,"IBTRRS",356.26)
- +2 SET ^TMP($JOB,"IBTRRS",356.26,IBRFN,0)=$GET(^IBT(356.26,+IBRFN,0))
- +3 SET ^TMP($JOB,"IBTRRS",356.26,IBRFN,1)=$GET(^IBT(356.26,+IBRFN,1))
- +4 SET ^TMP($JOB,"IBTRRS",356.26,IBRFN,2)=$GET(^IBT(356.26,+IBRFN,2))
- +5 QUIT
- +6 ;
- COMP ; compare before editing global with current global entry
- +1 SET IBDIFF=0
- +2 IF $GET(^IBT(356.26,+IBRFN,0))'=$GET(^TMP($JOB,"IBTRRS",356.26,IBRFN,0))
- SET IBDIFF=1
- +3 IF $GET(^IBT(356.26,+IBRFN,1))'=$GET(^TMP($JOB,"IBTRRS",356.26,IBRFN,1))
- SET IBDIFF=1
- +4 IF $GET(^IBT(356.26,+IBRFN,2))'=$GET(^TMP($JOB,"IBTRRS",356.26,IBRFN,2))
- SET IBDIFF=1
- +5 QUIT
- +6 ;
- UPDATE ; update last edited fields for entry
- +1 NEW DIC,DIE,DR,DA,D0,X,Y
- +2 SET DIE="^IBT(356.26,"
- SET DA=+IBRFN
- SET DR="1.03///NOW;1.04////"_DUZ
- DO ^DIE
- +3 QUIT
- +4 ;
- +5 ;
- ROIDSP(IBRFN) ; display an ROI entry
- +1 NEW IBR0,IBR1,IBR2,IBDS
- SET IBDS=""
- SET $PIECE(IBDS,"-",IOM+1)=""
- +2 SET IBR0=$GET(^IBT(356.26,+$GET(IBRFN),0))
- if IBR0=""
- QUIT
- +3 SET IBR1=$GET(^IBT(356.26,IBRFN,1))
- SET IBR2=$GET(^IBT(356.26,IBRFN,2))
- +4 ;
- +5 WRITE !!,IBDS,!,"ROI Special Consent for ",$PIECE($GET(^DPT(+$PIECE(IBR0,U,2),0)),U,1),":"
- +6 WRITE !!,$$EXPAND^IBTRE(356.26,.03,$PIECE(IBR0,U,3)),?37,$$DATE^IBTRR($PIECE(IBR0,U,4))," - ",$$DATE^IBTRR($PIECE(IBR0,U,5))
- +7 WRITE ?60,$SELECT(+$$ACTIVE^IBTRR(IBRFN,DT):"ACTIVE",1:"INACTIVE"),?70,$SELECT(+$PIECE(IBR0,U,6):"REVOKED",1:"")
- +8 WRITE !!,"Comment: ",IBR2
- +9 WRITE !!,"Entered by: ",$EXTRACT($$EXPAND^IBTRE(356.26,1.02,$PIECE(IBR1,U,2)),1,21),?37,"Last Edited By: ",$EXTRACT($$EXPAND^IBTRE(356.26,1.04,$PIECE(IBR1,U,4)),1,21)
- +10 WRITE !,"Date Entered: ",$$FMTE^XLFDT($PIECE(IBR1,U,1)),?37,"Date Last Edited: ",$$FMTE^XLFDT($PIECE(IBR1,U,3)),!,IBDS,!
- +11 QUIT
- +12 ;
- +13 ;
- ROIPAT(DFN,DATE) ; return Indicators of Conditions Active for Patient on Date (LM Patient List header)
- +1 ; outputs alpha characters of sensitive conditions with active ROI
- +2 NEW IBX,IBY,IBZ,IBRFN,IBR0
- SET (IBX,IBY,IBZ)=""
- SET DFN=+$GET(DFN)
- SET DATE=$GET(DATE)\1
- IF DATE'?7N
- SET DATE=DT
- +3 ;
- +4 SET IBRFN=0
- FOR
- SET IBRFN=$ORDER(^IBT(356.26,"C",DFN,IBRFN))
- if 'IBRFN
- QUIT
- Begin DoDot:1
- +5 SET IBR0=$GET(^IBT(356.26,IBRFN,0))
- +6 IF IBR0'=""
- IF DATE'<$PIECE(IBR0,U,4)
- IF DATE'>$PIECE(IBR0,U,5)
- SET IBY(+$PIECE(IBR0,U,3))=""
- End DoDot:1
- +7 SET IBZ=""
- FOR IBY=1:1:4
- IF $DATA(IBY(IBY))
- SET IBZ=IBZ_IBY
- +8 SET IBX=$TRANSLATE(IBZ,"1234","DAHS")
- +9 QUIT IBX
- +10 ;
- ROIEVT(IBTRN,SHRT) ; return ROI Consent and Indicators for a specific CT Event and Date (LM Event Detail)
- +1 ; outputs CT entries ROI Consent and alpha characters of sensitive conditions with active ROI
- +2 ;
- +3 NEW IBX,IBY,IBTRN0,IBRSC
- SET IBX=""
- SET IBTRN0=$GET(^IBT(356,+$GET(IBTRN),0))
- SET IBRSC=$PIECE(IBTRN0,U,31)
- +4 IF +IBRSC
- SET IBX=$$EXPAND^IBTRE(356,.31,IBRSC)_" "
- +5 IF +IBRSC=2
- SET IBY=$$ROIPAT(+$PIECE(IBTRN0,U,2),+$PIECE(IBTRN0,U,6))
- IF IBY'=""
- if $GET(SHRT)
- SET IBX=$EXTRACT(IBX,1,6)
- SET IBX=IBX_"("_IBY_")"
- +6 QUIT IBX