IBCSC4A ;ALB/MJB - MCCR PTF SCREEN ;24 FEB 89 9:49
;;2.0;INTEGRATED BILLING;**106,228,339,479,522,714**;21-MAR-94;Build 8
;;Per VA Directive 6402, this routine should not be modified.
;
DX ;
PRO ; Get PTF Procedures for a bill in ^UTILITY($J,"IB")
; includes ICD Surgeries (401) and ICD Procedures (601) or CPT Professional Services (801) based on PCM
N IB0,IBU,IBPTF,IBFDT,IBTDT,IBPCM,IBINDTS K ^UTILITY($J) Q:'$G(IBIFN)
S IB0=$G(^DGCR(399,+$G(IBIFN),0)),IBPTF=$P(IB0,U,8),IBPCM=+$P(IB0,U,9),IBINDTS=$P(IB0,U,28) Q:'IBPTF ; IB*2.0*714
S IBU=$G(^DGCR(399,+IBIFN,"U")),IBFDT=+IBU,IBTDT=$P(IBU,U,2) Q:$P(IB0,U,5)>2
;
D PTFPRDT(IBPTF,$S(IBINDTS>0:IBINDTS,1:IBFDT),IBTDT,IBPCM,IBIFN) ; IB*2.0*714
Q
;
;
PTFPRDT(PTF,IBDT1,IBDT2,PCM,IBIFN) ; collect PTF Procedures within a date range
; includes ICD Surgeries (401) and ICD Procedures (601) or CPT Professional Services (801)
; the procedure coding method (PCM) determines if ICD (401/601) or CPT (801) procedures returned
N DFN K ^UTILITY($J,"IB") Q:'$G(PTF)
S IBDT1=+$G(IBDT1),IBDT2=+$G(IBDT2),DFN=+$G(^DGPT(PTF,0)) Q:'DFN
I '$G(PCM) S PCM=9
;
I +PCM'=9 D PTFPS(DFN,PTF,IBDT1,IBDT2) Q ; get CPT Procedures (601)
;
D PTFPR(PTF,IBDT1,IBDT2,$G(IBIFN)) ; get ICD Procedures (401/601)
;
Q
;
;
PTFPR(IBPTF,IBDT1,IBDT2,IBIFN) ; collect PTF ICD Procedures, Surgeries (401) and Procedures (601), for a date range
; Output: UTILITY($J,"IB",X,1) = ICD IEN ^ Date ^ Seq Group Letter ^ Type (401="", 601="*")
; UTILITY($J,"IB",X,Y) = ICD IEN
; UTILITY($J,"IB","B", Seq Group Letter_Y ) = X ^ Y ^ on bill (Y/N)
; where X is 1:1 of the number of events found, order by: Surgeries first, then Procedures, then by reverse date
N IBXRF,IBPI,IBPDT,IBECNT,IBCNT,IBTYPE,IBSGRP,IBFIRST,IBPRC,IBPB,IBI,IBJ,IBARR,PTFCOD,BPARR K ^UTILITY($J,"IB")
S IBDT1=$S(+$G(IBDT1):IBDT1\1,1:0),IBDT2=$S(+$G(IBDT2):IBDT2\1,1:9999999)+.999999 Q:'$G(IBPTF)
I +$G(IBIFN) D BILLPRC(IBIFN,.BPARR)
;
; get list of Procedure and Surgery Events and order by reverse date
F IBXRF="S","P" S IBPI=0 F S IBPI=$O(^DGPT(IBPTF,IBXRF,IBPI)) Q:'IBPI D
. S IBPDT=+$G(^DGPT(IBPTF,IBXRF,IBPI,0))\1 I IBPDT'<IBDT1,IBPDT'>IBDT2 S IBARR(IBXRF,-IBPDT,IBPI)=IBPDT
;
; collect PTF Procedure (601) and Surgeries (401) associated ICD codes, by type and reverse date
S IBECNT=0 F IBXRF="S","P" S IBJ="" F S IBJ=$O(IBARR(IBXRF,IBJ)) Q:IBJ="" D
. S IBPI="" F S IBPI=$O(IBARR(IBXRF,IBJ,IBPI)) Q:IBPI="" S IBPDT=IBARR(IBXRF,IBJ,IBPI),IBECNT=IBECNT+1 D
.. ;
.. S IBTYPE=$S(IBXRF="S":401,IBXRF="P":601,1:0),IBSGRP=$$SEQGRP(IBECNT)
.. S IBFIRST=IBPDT\1_U_IBSGRP_U_$S(IBTYPE=601:"*",1:"")
.. S ^UTILITY($J,"IB",IBECNT,1)="UNSPECIFIED CODE"_U_IBFIRST
.. ;
.. D PTFCDS^IBCSC4F(IBPTF,IBTYPE,IBPI,.PTFCOD) D K PTFCOD ; get surgery/procedure codes
... S IBCNT=0,IBI="" F S IBI=$O(PTFCOD(IBI)) Q:IBI="" S IBPRC=PTFCOD(IBI) I +IBPRC S IBCNT=IBCNT+1 D
.... S IBPB=+$O(BPARR(+IBPRC,+IBPDT,0)) S BPARR=$S('$G(IBIFN):"",+IBPB:"Y",1:"N") K BPARR(+IBPRC,+IBPDT,+IBPB)
.... S ^UTILITY($J,"IB",IBECNT,IBCNT)=+IBPRC_U_IBFIRST S IBFIRST=""
.... I IBSGRP'="" S ^UTILITY($J,"IB","B",IBSGRP_IBCNT)=IBECNT_U_IBCNT_U_BPARR
Q
;
;
SEQGRP(ECNT) ; return sequence group alpha character (A-Z, a-z, 52 max)
N IBX S IBX="" I +$G(ECNT) S ECNT=$S(ECNT>52:0,ECNT>26:ECNT+6,1:ECNT) I +ECNT S IBX=$C(64+ECNT)
Q IBX
;
;
BILLPRC(IBIFN,ARRAY) ; return array of ICD procedures on bill, ARRAY(PRC,DATE,X)="" pass by reference
N IBPI,IBP0 K ARRAY
S IBPI=0 F S IBPI=$O(^DGCR(399,+$G(IBIFN),"CP",IBPI)) Q:'IBPI D
. S IBP0=$G(^DGCR(399,IBIFN,"CP",IBPI,0)) Q:IBP0'[";ICD0" S ARRAY(+IBP0,+$P(IBP0,U,2),IBPI)=""
Q
;
;
PTFPS(DFN,IBPTF,IBFDT,IBTDT) ; this will return a list of professional
; services from the ptf records. If no date range specified, then
; it will return all services for that ptf entry.
; return: ^utility($j,"IB",count for event,count for procedures) =
; pices: 1 = procedure
; 2 = date (only if new date)
; 3 = sequentual grouping letter (only if new date)
; 4 = "+" to flag as CPT 4 procedure
; 5 = if exemption applicable, info for that
; 6-9 = assoc dx in order
; 10 = quantity
; 11-12 = modifiers
; 13 = provider
; 14 = location
;
; the exemption information returned will be first evaluated at the
; dx level and if nothing there to exempt, it will be at the procedure
; level.
;
N IBX,IBY,IBDT,IBXX,IBP,IBC,IBD,IBSGRP,IBRMARK,IBDX,IBDXX,IBPP,IB46
K ^TMP("PTF",$J),^TMP("IBPTFPS",$J)
S IBFDT=$S(+$G(IBFDT):IBFDT\1,1:0),IBTDT=$S(+$G(IBTDT):IBTDT\1,1:9999999)+.999999
;
; get starting place for ^utility global
S IBC=+$O(^UTILITY($J,"IB",":"),-1)
;
D PTFINFOR^DGAPI(DFN,IBPTF) I '$D(^TMP("PTF",$J)) G PTFPSQ
;
S IBX=0 F S IBX=$O(^TMP("PTF",$J,IBX)) Q:IBX<1 S IBY=^TMP("PTF",$J,IBX) I $S(IBFDT<+IBY&(IBTDT>+IBY):1,1:0) S ^TMP("IBPTFPS",$J,+IBY)=""
I '$D(^TMP("IBPTFPS",$J)) G PTFPSQ
;
K ^TMP("PTF",$J)
D ICDINFO^DGAPI(DFN,IBPTF) ;get the dx's for the ptf
;
S IBDT=0 F S:'IBC!($D(^UTILITY($J,"IB",IBC))) IBC=IBC+1 S IBDT=$O(^TMP("IBPTFPS",$J,IBDT)) Q:IBDT<1 D
. ;
. S IBD=0,IBSGRP=$$SEQGRP(IBC)
. D CPTINFO^DGAPI(DFN,,IBDT) I '$D(^TMP("PTF",$J,46)) Q
. S IB46=$P($G(^TMP("PTF",$J,46,0)),"^",2)_"^"_$P($G(^(0)),"^",4)
. ;
. S IBX=0 F S IBX=$O(^TMP("PTF",$J,46,IBX)) Q:IBX<1 S IBY=^TMP("PTF",$J,46,IBX) D
.. S IBRMARK=""
.. F IBP=5:1:8,16:1:19 S IBDX=$P(IBY,"^",IBP),IBDXX=0 F S IBDXX=$O(^TMP("PTF",$J,46.1,IBDXX)) Q:IBDXX<1!(IBRMARK) I $P(^TMP("PTF",$J,46.1,IBDXX),"^",2)=IBDX D
... F IBPP=3:1:10 I $P(^TMP("PTF",$J,46.1,IBDXX),"^",IBPP) S IBRMARK=IBPP Q
.. S IBD=IBD+1,^UTILITY($J,"IB",IBC,IBD)=$P(IBY,"^",2)_"^"_$S(IBD=1:$P(IBDT,".")_"^"_IBSGRP_"^+^",1:"^^^")_$S(IBRMARK:$P($T(EXEMPT+(IBRMARK-2)),";",3),1:"")_"^"_$P(IBY,"^",5,8)_"^"_$P(IBY,"^",15)_"^"_$P(IBY,"^",3,4)_"^"_IB46
.. I IBSGRP'="" S ^UTILITY($J,"IB","B",IBSGRP_IBD)=IBC_"^"_IBD
. S IBD=0
. K ^TMP("PTF",$J,46)
;
PTFPSQ K ^TMP("PTF",$J),^TMP("IBPTFPS",$J),^TMP("CPT",$J)
Q
;
EXEMPT ; exemption reasons
;;SC
;;AO
;;IR
;;SW
;;MT
;;HC
;;CV
;;SH
;
;
;
P Q
;S M=($A($E(X,1))-64),S=$E(X,2),IB5=$S($D(^UTILITY($J,"IB",M,S)):^(S),1:"") I IB5]"" Q:$P(^UTILITY($J,"IB",M,1),U,3)=$E(X,1)
;F J=M:1:26 Q:'$D(^UTILITY($J,"IB",J)) I $P(^UTILITY($J,"IB",J,1),U,3)=$E(X,1) S M=J,IBA=1 Q
;S:'$D(IBA) M=0 K IBA Q
D Q
;S M=($A($E(X,1))-64),S=$E(X,2),IB4=$S($D(^UTILITY($J,"IBDX",M,S)):^(S),1:"") I IB4]"" Q:$P(^UTILITY($J,"IBDX",M,1),U,3)=$E(X,1)
;F J=M:1:26 Q:'$D(^UTILITY($J,"IBDX",J)) I $P(^UTILITY($J,"IBDX",J,1),U,3)=$E(X,1) S M=J,IBA=1 Q
;S:'$D(IBA) M=0 K IBA Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC4A 6836 printed Sep 23, 2025@19:56:28 Page 2
IBCSC4A ;ALB/MJB - MCCR PTF SCREEN ;24 FEB 89 9:49
+1 ;;2.0;INTEGRATED BILLING;**106,228,339,479,522,714**;21-MAR-94;Build 8
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
DX ;
PRO ; Get PTF Procedures for a bill in ^UTILITY($J,"IB")
+1 ; includes ICD Surgeries (401) and ICD Procedures (601) or CPT Professional Services (801) based on PCM
+2 NEW IB0,IBU,IBPTF,IBFDT,IBTDT,IBPCM,IBINDTS
KILL ^UTILITY($JOB)
if '$GET(IBIFN)
QUIT
+3 ; IB*2.0*714
SET IB0=$GET(^DGCR(399,+$GET(IBIFN),0))
SET IBPTF=$PIECE(IB0,U,8)
SET IBPCM=+$PIECE(IB0,U,9)
SET IBINDTS=$PIECE(IB0,U,28)
if 'IBPTF
QUIT
+4 SET IBU=$GET(^DGCR(399,+IBIFN,"U"))
SET IBFDT=+IBU
SET IBTDT=$PIECE(IBU,U,2)
if $PIECE(IB0,U,5)>2
QUIT
+5 ;
+6 ; IB*2.0*714
DO PTFPRDT(IBPTF,$SELECT(IBINDTS>0:IBINDTS,1:IBFDT),IBTDT,IBPCM,IBIFN)
+7 QUIT
+8 ;
+9 ;
PTFPRDT(PTF,IBDT1,IBDT2,PCM,IBIFN) ; collect PTF Procedures within a date range
+1 ; includes ICD Surgeries (401) and ICD Procedures (601) or CPT Professional Services (801)
+2 ; the procedure coding method (PCM) determines if ICD (401/601) or CPT (801) procedures returned
+3 NEW DFN
KILL ^UTILITY($JOB,"IB")
if '$GET(PTF)
QUIT
+4 SET IBDT1=+$GET(IBDT1)
SET IBDT2=+$GET(IBDT2)
SET DFN=+$GET(^DGPT(PTF,0))
if 'DFN
QUIT
+5 IF '$GET(PCM)
SET PCM=9
+6 ;
+7 ; get CPT Procedures (601)
IF +PCM'=9
DO PTFPS(DFN,PTF,IBDT1,IBDT2)
QUIT
+8 ;
+9 ; get ICD Procedures (401/601)
DO PTFPR(PTF,IBDT1,IBDT2,$GET(IBIFN))
+10 ;
+11 QUIT
+12 ;
+13 ;
PTFPR(IBPTF,IBDT1,IBDT2,IBIFN) ; collect PTF ICD Procedures, Surgeries (401) and Procedures (601), for a date range
+1 ; Output: UTILITY($J,"IB",X,1) = ICD IEN ^ Date ^ Seq Group Letter ^ Type (401="", 601="*")
+2 ; UTILITY($J,"IB",X,Y) = ICD IEN
+3 ; UTILITY($J,"IB","B", Seq Group Letter_Y ) = X ^ Y ^ on bill (Y/N)
+4 ; where X is 1:1 of the number of events found, order by: Surgeries first, then Procedures, then by reverse date
+5 NEW IBXRF,IBPI,IBPDT,IBECNT,IBCNT,IBTYPE,IBSGRP,IBFIRST,IBPRC,IBPB,IBI,IBJ,IBARR,PTFCOD,BPARR
KILL ^UTILITY($JOB,"IB")
+6 SET IBDT1=$SELECT(+$GET(IBDT1):IBDT1\1,1:0)
SET IBDT2=$SELECT(+$GET(IBDT2):IBDT2\1,1:9999999)+.999999
if '$GET(IBPTF)
QUIT
+7 IF +$GET(IBIFN)
DO BILLPRC(IBIFN,.BPARR)
+8 ;
+9 ; get list of Procedure and Surgery Events and order by reverse date
+10 FOR IBXRF="S","P"
SET IBPI=0
FOR
SET IBPI=$ORDER(^DGPT(IBPTF,IBXRF,IBPI))
if 'IBPI
QUIT
Begin DoDot:1
+11 SET IBPDT=+$GET(^DGPT(IBPTF,IBXRF,IBPI,0))\1
IF IBPDT'<IBDT1
IF IBPDT'>IBDT2
SET IBARR(IBXRF,-IBPDT,IBPI)=IBPDT
End DoDot:1
+12 ;
+13 ; collect PTF Procedure (601) and Surgeries (401) associated ICD codes, by type and reverse date
+14 SET IBECNT=0
FOR IBXRF="S","P"
SET IBJ=""
FOR
SET IBJ=$ORDER(IBARR(IBXRF,IBJ))
if IBJ=""
QUIT
Begin DoDot:1
+15 SET IBPI=""
FOR
SET IBPI=$ORDER(IBARR(IBXRF,IBJ,IBPI))
if IBPI=""
QUIT
SET IBPDT=IBARR(IBXRF,IBJ,IBPI)
SET IBECNT=IBECNT+1
Begin DoDot:2
+16 ;
+17 SET IBTYPE=$SELECT(IBXRF="S":401,IBXRF="P":601,1:0)
SET IBSGRP=$$SEQGRP(IBECNT)
+18 SET IBFIRST=IBPDT\1_U_IBSGRP_U_$SELECT(IBTYPE=601:"*",1:"")
+19 SET ^UTILITY($JOB,"IB",IBECNT,1)="UNSPECIFIED CODE"_U_IBFIRST
+20 ;
+21 ; get surgery/procedure codes
DO PTFCDS^IBCSC4F(IBPTF,IBTYPE,IBPI,.PTFCOD)
Begin DoDot:3
+22 SET IBCNT=0
SET IBI=""
FOR
SET IBI=$ORDER(PTFCOD(IBI))
if IBI=""
QUIT
SET IBPRC=PTFCOD(IBI)
IF +IBPRC
SET IBCNT=IBCNT+1
Begin DoDot:4
+23 SET IBPB=+$ORDER(BPARR(+IBPRC,+IBPDT,0))
SET BPARR=$SELECT('$GET(IBIFN):"",+IBPB:"Y",1:"N")
KILL BPARR(+IBPRC,+IBPDT,+IBPB)
+24 SET ^UTILITY($JOB,"IB",IBECNT,IBCNT)=+IBPRC_U_IBFIRST
SET IBFIRST=""
+25 IF IBSGRP'=""
SET ^UTILITY($JOB,"IB","B",IBSGRP_IBCNT)=IBECNT_U_IBCNT_U_BPARR
End DoDot:4
End DoDot:3
KILL PTFCOD
End DoDot:2
End DoDot:1
+26 QUIT
+27 ;
+28 ;
SEQGRP(ECNT) ; return sequence group alpha character (A-Z, a-z, 52 max)
+1 NEW IBX
SET IBX=""
IF +$GET(ECNT)
SET ECNT=$SELECT(ECNT>52:0,ECNT>26:ECNT+6,1:ECNT)
IF +ECNT
SET IBX=$CHAR(64+ECNT)
+2 QUIT IBX
+3 ;
+4 ;
BILLPRC(IBIFN,ARRAY) ; return array of ICD procedures on bill, ARRAY(PRC,DATE,X)="" pass by reference
+1 NEW IBPI,IBP0
KILL ARRAY
+2 SET IBPI=0
FOR
SET IBPI=$ORDER(^DGCR(399,+$GET(IBIFN),"CP",IBPI))
if 'IBPI
QUIT
Begin DoDot:1
+3 SET IBP0=$GET(^DGCR(399,IBIFN,"CP",IBPI,0))
if IBP0'[";ICD0"
QUIT
SET ARRAY(+IBP0,+$PIECE(IBP0,U,2),IBPI)=""
End DoDot:1
+4 QUIT
+5 ;
+6 ;
PTFPS(DFN,IBPTF,IBFDT,IBTDT) ; this will return a list of professional
+1 ; services from the ptf records. If no date range specified, then
+2 ; it will return all services for that ptf entry.
+3 ; return: ^utility($j,"IB",count for event,count for procedures) =
+4 ; pices: 1 = procedure
+5 ; 2 = date (only if new date)
+6 ; 3 = sequentual grouping letter (only if new date)
+7 ; 4 = "+" to flag as CPT 4 procedure
+8 ; 5 = if exemption applicable, info for that
+9 ; 6-9 = assoc dx in order
+10 ; 10 = quantity
+11 ; 11-12 = modifiers
+12 ; 13 = provider
+13 ; 14 = location
+14 ;
+15 ; the exemption information returned will be first evaluated at the
+16 ; dx level and if nothing there to exempt, it will be at the procedure
+17 ; level.
+18 ;
+19 NEW IBX,IBY,IBDT,IBXX,IBP,IBC,IBD,IBSGRP,IBRMARK,IBDX,IBDXX,IBPP,IB46
+20 KILL ^TMP("PTF",$JOB),^TMP("IBPTFPS",$JOB)
+21 SET IBFDT=$SELECT(+$GET(IBFDT):IBFDT\1,1:0)
SET IBTDT=$SELECT(+$GET(IBTDT):IBTDT\1,1:9999999)+.999999
+22 ;
+23 ; get starting place for ^utility global
+24 SET IBC=+$ORDER(^UTILITY($JOB,"IB",":"),-1)
+25 ;
+26 DO PTFINFOR^DGAPI(DFN,IBPTF)
IF '$DATA(^TMP("PTF",$JOB))
GOTO PTFPSQ
+27 ;
+28 SET IBX=0
FOR
SET IBX=$ORDER(^TMP("PTF",$JOB,IBX))
if IBX<1
QUIT
SET IBY=^TMP("PTF",$JOB,IBX)
IF $SELECT(IBFDT<+IBY&(IBTDT>+IBY):1,1:0)
SET ^TMP("IBPTFPS",$JOB,+IBY)=""
+29 IF '$DATA(^TMP("IBPTFPS",$JOB))
GOTO PTFPSQ
+30 ;
+31 KILL ^TMP("PTF",$JOB)
+32 ;get the dx's for the ptf
DO ICDINFO^DGAPI(DFN,IBPTF)
+33 ;
+34 SET IBDT=0
FOR
if 'IBC!($DATA(^UTILITY($JOB,"IB",IBC)))
SET IBC=IBC+1
SET IBDT=$ORDER(^TMP("IBPTFPS",$JOB,IBDT))
if IBDT<1
QUIT
Begin DoDot:1
+35 ;
+36 SET IBD=0
SET IBSGRP=$$SEQGRP(IBC)
+37 DO CPTINFO^DGAPI(DFN,,IBDT)
IF '$DATA(^TMP("PTF",$JOB,46))
QUIT
+38 SET IB46=$PIECE($GET(^TMP("PTF",$JOB,46,0)),"^",2)_"^"_$PIECE($GET(^(0)),"^",4)
+39 ;
+40 SET IBX=0
FOR
SET IBX=$ORDER(^TMP("PTF",$JOB,46,IBX))
if IBX<1
QUIT
SET IBY=^TMP("PTF",$JOB,46,IBX)
Begin DoDot:2
+41 SET IBRMARK=""
+42 FOR IBP=5:1:8,16:1:19
SET IBDX=$PIECE(IBY,"^",IBP)
SET IBDXX=0
FOR
SET IBDXX=$ORDER(^TMP("PTF",$JOB,46.1,IBDXX))
if IBDXX<1!(IBRMARK)
QUIT
IF $PIECE(^TMP("PTF",$JOB,46.1,IBDXX),"^",2)=IBDX
Begin DoDot:3
+43 FOR IBPP=3:1:10
IF $PIECE(^TMP("PTF",$JOB,46.1,IBDXX),"^",IBPP)
SET IBRMARK=IBPP
QUIT
End DoDot:3
+44 SET IBD=IBD+1
SET ^UTILITY($JOB,"IB",IBC,IBD)=$PIECE(IBY,"^",2)_"^"_$SELECT(IBD=1:$PIECE(IBDT,".")_"^"_IBSGRP_"^+^",1:"^^^")_$SELECT(IBRMARK:$PIECE($TEXT(EXEMPT+(IBRMARK-2)),";",3),1:"")_"^"_$PIECE(IBY,"^",5,8)_"^"_$PIECE(IBY,"^",15)_"^"_$PIE
CE(IBY,"^",3,4)_"^"_IB46
+45 IF IBSGRP'=""
SET ^UTILITY($JOB,"IB","B",IBSGRP_IBD)=IBC_"^"_IBD
End DoDot:2
+46 SET IBD=0
+47 KILL ^TMP("PTF",$JOB,46)
End DoDot:1
+48 ;
PTFPSQ KILL ^TMP("PTF",$JOB),^TMP("IBPTFPS",$JOB),^TMP("CPT",$JOB)
+1 QUIT
+2 ;
EXEMPT ; exemption reasons
+1 ;;SC
+2 ;;AO
+3 ;;IR
+4 ;;SW
+5 ;;MT
+6 ;;HC
+7 ;;CV
+8 ;;SH
+9 ;
+10 ;
+11 ;
P QUIT
+1 ;S M=($A($E(X,1))-64),S=$E(X,2),IB5=$S($D(^UTILITY($J,"IB",M,S)):^(S),1:"") I IB5]"" Q:$P(^UTILITY($J,"IB",M,1),U,3)=$E(X,1)
+2 ;F J=M:1:26 Q:'$D(^UTILITY($J,"IB",J)) I $P(^UTILITY($J,"IB",J,1),U,3)=$E(X,1) S M=J,IBA=1 Q
+3 ;S:'$D(IBA) M=0 K IBA Q
D QUIT
+1 ;S M=($A($E(X,1))-64),S=$E(X,2),IB4=$S($D(^UTILITY($J,"IBDX",M,S)):^(S),1:"") I IB4]"" Q:$P(^UTILITY($J,"IBDX",M,1),U,3)=$E(X,1)
+2 ;F J=M:1:26 Q:'$D(^UTILITY($J,"IBDX",J)) I $P(^UTILITY($J,"IBDX",J,1),U,3)=$E(X,1) S M=J,IBA=1 Q
+3 ;S:'$D(IBA) M=0 K IBA Q
