IBCEFG ;ALB/TMP - OUTPUT FORMATTER EXTRACT ;17-JAN-96
;;2.0;INTEGRATED BILLING;**52,51,718**;21-MAR-94;Build 73
;
;EXTRACT(IBXFORM,IBXIEN,IBXREC,IBXPARM) ; Extract entry into global by rec #/pg/ln/col ; WCJ;IB718v22
; IBXFORM (required) Form id pointer to file #353
; IBXIEN (required) entry # in form's base file to output
; IBXREC (optional) record # in extract file - if not defined - 1 used
; IBXPARM (optional) array used to pass in specific search variables
; that can be used to customize the determination
; of the form field definition to use for each
; form field to be extracted
; IBXPARM(1) should contain a code to identify the
; type of form being processed (see $$ELE^IBCEFG0 function)
; IBXPOSTWA (optional) = 1 if the post processing of workarounds should be executed ; WCJ;IB718v22
; Returns total # of bytes of data extracted if extract successful
; or 0 if extract not successful
;
N IBXPG,IBXLN,IBXCOL,IBXERR,IBXF,IBXFILE,IBX2,IBXSIZE
S IBXERR="" S:$G(IBXREC)="" IBXREC=1
I $G(IBXFORM)=""!($G(IBXIEN)="") S IBXERR="Missing Parameters" G EXTQ
K ^TMP("IBXDATA",$J,IBXREC),^TMP("DIERR",$J,1),^TMP("IBXEDIT",$J)
;
S IBX2=$G(^IBE(353,IBXFORM,2)),IBXFILE=+IBX2
I 'IBXFILE S IBXERR="No base file found for form "_IBXFORM G EXTQ
S IBXF=$S($P(IBX2,U,5):$P(IBX2,U,5),1:IBXFORM)
;
I $G(^IBE(353,IBXFORM,"PRE"))'="" X ^("PRE") ;Entry pre-proc
I $G(^IBE(353,IBXFORM,"PRE"))="",$G(^IBE(353,IBXF,"PRE"))'="" X ^("PRE") ;Entry pre-proc - parent
G:$G(IBXERR)'="" EXTQ
;
S IBXPG=""
F S IBXPG=$O(^IBA(364.6,"ASEQ",IBXF,IBXPG)) Q:IBXPG="" S IBXLN="" F S IBXLN=$O(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN)) Q:IBXLN="" S IBXCOL="" D G:$G(IBXERR)'="" EXTQ
.F S IBXCOL=$O(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN,IBXCOL)) Q:IBXCOL="" D Q:$G(IBXERR)'=""
..S IBXDA=$O(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN,IBXCOL,""))
..Q:'IBXDA
..D DATA(IBXPG,IBXLN,IBXCOL,IBXIEN,IBXFORM,IBXDA,.IBXPARM,.IBXERR)
.. I $G(IBXERR)'="" S IBXERR=IBXERR_" Field: "_$P($G(^IBA(364.6,IBXDA,0)),U,10)
;
EXTQ ;
I $G(^IBE(353,IBXFORM,"POST"))'="" X ^("POST") ;Entry post-proc - assoc form or parent if not associated
I $G(^IBE(353,IBXFORM,"POST"))="",$G(^IBE(353,IBXF,"POST"))'="" X ^("POST") ;Entry post-proc - parent of associated form
;
K IBXMAX,IBX0,IBX00,IBXARRAY,IBXDA,IBXDATA,IBXFF,IBZ,IBZ0,IBZ1
S:$G(IBXERR)'="" IBXSIZE=0
Q +$G(IBXSIZE)
;
DATA(IBXPG,IBXLN,IBXCOL,IBXIEN,IBXFORM,IBXDA,IBXPARM,IBXERR) ; Extract/Format Data Element
;IBXPG,IBXLN,IBXCOL = page,line,column to extract
;IBXIEN = internal entry # of entity to extract
;IBXFORM = internal entry # of FORM (file 353) to use to extract data
;IBXDA = ien of IB FORM SKELETON file entry to use (file 364.6)
; to use to extract the data
;IBXPARM = passed by reference. Array that optionally contains the
; parameters to use to screen
;IBXERR = passed by reference. Returned = error message if error
; condition found
;
; If associated form fld - get 'local' fld override
S:'$D(IBXREC) IBXREC=1
S:'$D(IBXFILE) IBXFILE=+$G(^IBE(353,IBXFORM,2))
N IBXFF,IBX0,IBXELE,IBXARRAY,IBXZ,IBXMAX,IBXLEN,IBZ,IBZ0,IBZ1,IBX00,IBXDA0
S IBXFF=$$ELE^IBCEFG0(IBXDA,.IBXPARM,IBXFORM) ;Form field entry to use
Q:'IBXFF ;no form field definition found
S IBX0=$G(^IBA(364.7,IBXFF,0)) ;Form field 0-node
;
S IBXELE=$P(IBX0,U,3) ;data element def entry to use
Q:'$D(^IBA(364.5,+IBXELE,0)) S IBX00=$G(^(0))
;
S IBXARRAY=$S($G(^IBA(364.5,IBXELE,2))="":"IBXDATA",1:^(2))
K:IBXARRAY?1A.E!(IBXARRAY?1"^"1A.E) @IBXARRAY
S @IBXARRAY=$$DATA^IBCEFG0(IBXELE,IBX00,IBXFILE,IBXIEN,IBXARRAY,.IBXERR)
Q:$G(IBXERR)'=""
;
I $G(^IBA(364.7,IBXFF,1))'="" S IBXZ=^(1) D Q:$G(IBXERR)'=""
. N IBXFF,IBXLOOP,Z
. F Z="IBXDA","IBXPG","IBXLN","IBXCOL","IBX0" S IBXLOOP(Z)=@Z ;Protect loop variables
. X IBXZ
. F Z="IBXDA","IBXPG","IBXLN","IBXCOL","IBX0" K @Z S @Z=IBXLOOP(Z)
S IBXDA0=$G(^IBA(364.6,IBXDA,0))
; Check for required field
I $P(IBXDA0,U,13),'$G(IBXNOREQ) D Q:$G(IBXERR)'=""
. I $G(@IBXARRAY)="" N Z S Z=0 F S Z=$O(@IBXARRAY@(Z)) S:'Z IBXERR="No data found for required field " Q:$S('Z:1,1:$G(@IBXARRAY@(Z))'="")
D:'$G(IBXNOREQ) NULLCHEK
K IBXNOREQ
Q:$P(IBXDA0,U,11)!($P(IBXDA0,U,8)[".")!('$D(@IBXARRAY)) ;data no longer exists or fld not an output fld
;
S IBXMAX=$O(@IBXARRAY@(""),-1),IBXLEN=$P(IBXDA0,U,9)
I IBXMAX,$P(IBXDA0,U,6),IBXMAX>$P(IBXDA0,U,6) S IBXERR="Max # lines or occurrences exceeded ("_IBXMAX_" > "_$P(IBXDA0,U,6)_") - "_$P(IBXDA0,U,10) Q:$G(IBXERR)'=""
I 'IBXMAX D Q
. D SETGBL(IBXPG,IBXLN,IBXCOL,$$FORMAT($G(@IBXARRAY),IBXLEN,$P(^IBA(364.7,IBXFF,0),U,7),IBX0),.IBXSIZE)
. D:$P($G(^IBE(353,IBXFORM,2)),U,2)="S" SETEDIT(IBXFORM,IBX0)
;
S IBZ=IBXARRAY,IBZ0=$E(IBZ,1,$L(IBZ)-$S($E(IBZ,$L(IBZ))=")":1,1:0))
S:IBZ0["("&($P(IBZ0,"(",2)'="") IBZ0=IBZ0_"," S:IBZ0'["(" IBZ0=IBZ0_"("
F S IBZ=$Q(@IBZ) Q:IBZ'[IBZ0 I $QS(IBZ,$QL(IBZ)) D
. S IBZ1=IBXLN+$P(IBZ,IBZ0,2)-1
. D SETGBL(IBXPG,IBZ1,IBXCOL,$$FORMAT(@IBZ,IBXLEN,$P(^IBA(364.7,IBXFF,0),U,7),IBX0,+$P(IBZ,"(",2)),.IBXSIZE)
. D:$P($G(^IBE(353,IBXFORM,2)),U,2)="S" SETEDIT(IBXFORM,IBX0)
Q
;
FORMAT(DATA,IBXLEN,IBXPAD,IBX0,MULTI) ; Adjust length on data for field def,add prompt
; DATA = the data to be output
; IBXLEN = the max length of the data
; IBXPAD = code for pad character
; IBX0 = the 0-node of the entry in file 364.7 being formatted
; MULTI = (optional)
; 0 or null if a single occurrence of the data
; > 0 if multiple ocurrences of the data being processed (group data)
;
N Z
S Z="",$P(Z,$S($E(IBXPAD)="Z":"0",1:" "),IBXLEN+1)=""
S Z=$S($E(IBXPAD)="N":$E(DATA,1,IBXLEN),$E(IBXPAD,2)="L":$E(Z,1,IBXLEN-$L(DATA))_DATA,1:$E(DATA_Z,1,IBXLEN))
I $P(IBX0,U,4)'="" D
.I $S('$G(MULTI):1,1:MULTI=1) S Z=$P(IBX0,U,4)_Z Q ;Add prompt to data
.S Z=$J("",$L($P(IBX0,U,4)))_Z
I $P(IBX0,U,10),$P(IBX0,U,9)="E" S Z="["_$P(IBX0,U,10)_"] "_Z
Q Z
;
SETGBL(IBXPG,IBXLN,IBXCOL,VAL,IBXSIZE) ; Sets the output global
;IBXPG = Form page IBXLN = Form line IBXCOL = form column
;VAL = value to place at PG/LINE/COL IBXSIZE = size counter (optional)
;
S ^TMP("IBXDATA",$J,IBXREC,IBXPG,IBXLN,IBXCOL)=VAL,IBXSIZE=$G(IBXSIZE)+$L(VAL)
Q
;
SETEDIT(IBFORM,IBX0) ;
N Z,Z0
Q:$P(IBX0,U,9)="D"!'$P(IBX0,U,10)
S Z0=$P($G(^IBA(364.5,+$P(IBX0,U,3),0)),U,6)
Q:Z0="" S Z0=$O(^DD(+$G(^IBE(353,IBXFORM,2)),"B",Z0,""))
Q:Z0=""
S Z=$O(^TMP("IBXEDIT",$J,$P(IBX0,U,10),""),-1)+1
S ^TMP("IBXEDIT",$J,$P(IBX0,U,10),Z)=Z0
Q
;
NULLCHEK ; Checks for no output if null, deletes variable if appropriate
; Check for no output if transmit and null
I $P($G(^IBA(364.6,+IBXDA,0)),U,12),$P($G(^IBE(353,IBXFORM,2)),U,2)="T" D
. I $D(@IBXARRAY)=1 K:$G(@IBXARRAY)="" @IBXARRAY Q
. I $D(@IBXARRAY)>9 D
.. N Z
.. S Z=0 F S Z=$O(@IBXARRAY@(Z)) Q:'Z I $G(@IBXARRAY@(Z))="" K @IBXARRAY@(Z)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEFG 7078 printed Oct 16, 2024@18:11:07 Page 2
IBCEFG ;ALB/TMP - OUTPUT FORMATTER EXTRACT ;17-JAN-96
+1 ;;2.0;INTEGRATED BILLING;**52,51,718**;21-MAR-94;Build 73
+2 ;
+3 ;EXTRACT(IBXFORM,IBXIEN,IBXREC,IBXPARM) ; Extract entry into global by rec #/pg/ln/col ; WCJ;IB718v22
+1 ; IBXFORM (required) Form id pointer to file #353
+2 ; IBXIEN (required) entry # in form's base file to output
+3 ; IBXREC (optional) record # in extract file - if not defined - 1 used
+4 ; IBXPARM (optional) array used to pass in specific search variables
+5 ; that can be used to customize the determination
+6 ; of the form field definition to use for each
+7 ; form field to be extracted
+8 ; IBXPARM(1) should contain a code to identify the
+9 ; type of form being processed (see $$ELE^IBCEFG0 function)
+10 ; IBXPOSTWA (optional) = 1 if the post processing of workarounds should be executed ; WCJ;IB718v22
+11 ; Returns total # of bytes of data extracted if extract successful
+12 ; or 0 if extract not successful
+13 ;
+14 NEW IBXPG,IBXLN,IBXCOL,IBXERR,IBXF,IBXFILE,IBX2,IBXSIZE
+15 SET IBXERR=""
if $GET(IBXREC)=""
SET IBXREC=1
+16 IF $GET(IBXFORM)=""!($GET(IBXIEN)="")
SET IBXERR="Missing Parameters"
GOTO EXTQ
+17 KILL ^TMP("IBXDATA",$JOB,IBXREC),^TMP("DIERR",$JOB,1),^TMP("IBXEDIT",$JOB)
+18 ;
+19 SET IBX2=$GET(^IBE(353,IBXFORM,2))
SET IBXFILE=+IBX2
+20 IF 'IBXFILE
SET IBXERR="No base file found for form "_IBXFORM
GOTO EXTQ
+21 SET IBXF=$SELECT($PIECE(IBX2,U,5):$PIECE(IBX2,U,5),1:IBXFORM)
+22 ;
+23 ;Entry pre-proc
IF $GET(^IBE(353,IBXFORM,"PRE"))'=""
XECUTE ^("PRE")
+24 ;Entry pre-proc - parent
IF $GET(^IBE(353,IBXFORM,"PRE"))=""
IF $GET(^IBE(353,IBXF,"PRE"))'=""
XECUTE ^("PRE")
+25 if $GET(IBXERR)'=""
GOTO EXTQ
+26 ;
+27 SET IBXPG=""
+28 FOR
SET IBXPG=$ORDER(^IBA(364.6,"ASEQ",IBXF,IBXPG))
if IBXPG=""
QUIT
SET IBXLN=""
FOR
SET IBXLN=$ORDER(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN))
if IBXLN=""
QUIT
SET IBXCOL=""
Begin DoDot:1
+29 FOR
SET IBXCOL=$ORDER(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN,IBXCOL))
if IBXCOL=""
QUIT
Begin DoDot:2
+30 SET IBXDA=$ORDER(^IBA(364.6,"ASEQ",IBXF,IBXPG,IBXLN,IBXCOL,""))
+31 if 'IBXDA
QUIT
+32 DO DATA(IBXPG,IBXLN,IBXCOL,IBXIEN,IBXFORM,IBXDA,.IBXPARM,.IBXERR)
+33 IF $GET(IBXERR)'=""
SET IBXERR=IBXERR_" Field: "_$PIECE($GET(^IBA(364.6,IBXDA,0)),U,10)
End DoDot:2
if $GET(IBXERR)'=""
QUIT
End DoDot:1
if $GET(IBXERR)'=""
GOTO EXTQ
+34 ;
EXTQ ;
+1 ;Entry post-proc - assoc form or parent if not associated
IF $GET(^IBE(353,IBXFORM,"POST"))'=""
XECUTE ^("POST")
+2 ;Entry post-proc - parent of associated form
IF $GET(^IBE(353,IBXFORM,"POST"))=""
IF $GET(^IBE(353,IBXF,"POST"))'=""
XECUTE ^("POST")
+3 ;
+4 KILL IBXMAX,IBX0,IBX00,IBXARRAY,IBXDA,IBXDATA,IBXFF,IBZ,IBZ0,IBZ1
+5 if $GET(IBXERR)'=""
SET IBXSIZE=0
+6 QUIT +$GET(IBXSIZE)
+7 ;
DATA(IBXPG,IBXLN,IBXCOL,IBXIEN,IBXFORM,IBXDA,IBXPARM,IBXERR) ; Extract/Format Data Element
+1 ;IBXPG,IBXLN,IBXCOL = page,line,column to extract
+2 ;IBXIEN = internal entry # of entity to extract
+3 ;IBXFORM = internal entry # of FORM (file 353) to use to extract data
+4 ;IBXDA = ien of IB FORM SKELETON file entry to use (file 364.6)
+5 ; to use to extract the data
+6 ;IBXPARM = passed by reference. Array that optionally contains the
+7 ; parameters to use to screen
+8 ;IBXERR = passed by reference. Returned = error message if error
+9 ; condition found
+10 ;
+11 ; If associated form fld - get 'local' fld override
+12 if '$DATA(IBXREC)
SET IBXREC=1
+13 if '$DATA(IBXFILE)
SET IBXFILE=+$GET(^IBE(353,IBXFORM,2))
+14 NEW IBXFF,IBX0,IBXELE,IBXARRAY,IBXZ,IBXMAX,IBXLEN,IBZ,IBZ0,IBZ1,IBX00,IBXDA0
+15 ;Form field entry to use
SET IBXFF=$$ELE^IBCEFG0(IBXDA,.IBXPARM,IBXFORM)
+16 ;no form field definition found
if 'IBXFF
QUIT
+17 ;Form field 0-node
SET IBX0=$GET(^IBA(364.7,IBXFF,0))
+18 ;
+19 ;data element def entry to use
SET IBXELE=$PIECE(IBX0,U,3)
+20 if '$DATA(^IBA(364.5,+IBXELE,0))
QUIT
SET IBX00=$GET(^(0))
+21 ;
+22 SET IBXARRAY=$SELECT($GET(^IBA(364.5,IBXELE,2))="":"IBXDATA",1:^(2))
+23 if IBXARRAY?1A.E!(IBXARRAY?1"^"1A.E)
KILL @IBXARRAY
+24 SET @IBXARRAY=$$DATA^IBCEFG0(IBXELE,IBX00,IBXFILE,IBXIEN,IBXARRAY,.IBXERR)
+25 if $GET(IBXERR)'=""
QUIT
+26 ;
+27 IF $GET(^IBA(364.7,IBXFF,1))'=""
SET IBXZ=^(1)
Begin DoDot:1
+28 NEW IBXFF,IBXLOOP,Z
+29 ;Protect loop variables
FOR Z="IBXDA","IBXPG","IBXLN","IBXCOL","IBX0"
SET IBXLOOP(Z)=@Z
+30 XECUTE IBXZ
+31 FOR Z="IBXDA","IBXPG","IBXLN","IBXCOL","IBX0"
KILL @Z
SET @Z=IBXLOOP(Z)
End DoDot:1
if $GET(IBXERR)'=""
QUIT
+32 SET IBXDA0=$GET(^IBA(364.6,IBXDA,0))
+33 ; Check for required field
+34 IF $PIECE(IBXDA0,U,13)
IF '$GET(IBXNOREQ)
Begin DoDot:1
+35 IF $GET(@IBXARRAY)=""
NEW Z
SET Z=0
FOR
SET Z=$ORDER(@IBXARRAY@(Z))
if 'Z
SET IBXERR="No data found for required field "
if $SELECT('Z
QUIT
End DoDot:1
if $GET(IBXERR)'=""
QUIT
+36 if '$GET(IBXNOREQ)
DO NULLCHEK
+37 KILL IBXNOREQ
+38 ;data no longer exists or fld not an output fld
if $PIECE(IBXDA0,U,11)!($PIECE(IBXDA0,U,8)[".")!('$DATA(@IBXARRAY))
QUIT
+39 ;
+40 SET IBXMAX=$ORDER(@IBXARRAY@(""),-1)
SET IBXLEN=$PIECE(IBXDA0,U,9)
+41 IF IBXMAX
IF $PIECE(IBXDA0,U,6)
IF IBXMAX>$PIECE(IBXDA0,U,6)
SET IBXERR="Max # lines or occurrences exceeded ("_IBXMAX_" > "_$PIECE(IBXDA0,U,6)_") - "_$PIECE(IBXDA0,U,10)
if $GET(IBXERR)'=""
QUIT
+42 IF 'IBXMAX
Begin DoDot:1
+43 DO SETGBL(IBXPG,IBXLN,IBXCOL,$$FORMAT($GET(@IBXARRAY),IBXLEN,$PIECE(^IBA(364.7,IBXFF,0),U,7),IBX0),.IBXSIZE)
+44 if $PIECE($GET(^IBE(353,IBXFORM,2)),U,2)="S"
DO SETEDIT(IBXFORM,IBX0)
End DoDot:1
QUIT
+45 ;
+46 SET IBZ=IBXARRAY
SET IBZ0=$EXTRACT(IBZ,1,$LENGTH(IBZ)-$SELECT($EXTRACT(IBZ,$LENGTH(IBZ))=")":1,1:0))
+47 if IBZ0["("&($PIECE(IBZ0,"(",2)'="")
SET IBZ0=IBZ0_","
if IBZ0'["("
SET IBZ0=IBZ0_"("
+48 FOR
SET IBZ=$QUERY(@IBZ)
if IBZ'[IBZ0
QUIT
IF $QSUBSCRIPT(IBZ,$QLENGTH(IBZ))
Begin DoDot:1
+49 SET IBZ1=IBXLN+$PIECE(IBZ,IBZ0,2)-1
+50 DO SETGBL(IBXPG,IBZ1,IBXCOL,$$FORMAT(@IBZ,IBXLEN,$PIECE(^IBA(364.7,IBXFF,0),U,7),IBX0,+$PIECE(IBZ,"(",2)),.IBXSIZE)
+51 if $PIECE($GET(^IBE(353,IBXFORM,2)),U,2)="S"
DO SETEDIT(IBXFORM,IBX0)
End DoDot:1
+52 QUIT
+53 ;
FORMAT(DATA,IBXLEN,IBXPAD,IBX0,MULTI) ; Adjust length on data for field def,add prompt
+1 ; DATA = the data to be output
+2 ; IBXLEN = the max length of the data
+3 ; IBXPAD = code for pad character
+4 ; IBX0 = the 0-node of the entry in file 364.7 being formatted
+5 ; MULTI = (optional)
+6 ; 0 or null if a single occurrence of the data
+7 ; > 0 if multiple ocurrences of the data being processed (group data)
+8 ;
+9 NEW Z
+10 SET Z=""
SET $PIECE(Z,$SELECT($EXTRACT(IBXPAD)="Z":"0",1:" "),IBXLEN+1)=""
+11 SET Z=$SELECT($EXTRACT(IBXPAD)="N":$EXTRACT(DATA,1,IBXLEN),$EXTRACT(IBXPAD,2)="L":$EXTRACT(Z,1,IBXLEN-$LENGTH(DATA))_DATA,1:$EXTRACT(DATA_Z,1,IBXLEN))
+12 IF $PIECE(IBX0,U,4)'=""
Begin DoDot:1
+13 ;Add prompt to data
IF $SELECT('$GET(MULTI):1,1:MULTI=1)
SET Z=$PIECE(IBX0,U,4)_Z
QUIT
+14 SET Z=$JUSTIFY("",$LENGTH($PIECE(IBX0,U,4)))_Z
End DoDot:1
+15 IF $PIECE(IBX0,U,10)
IF $PIECE(IBX0,U,9)="E"
SET Z="["_$PIECE(IBX0,U,10)_"] "_Z
+16 QUIT Z
+17 ;
SETGBL(IBXPG,IBXLN,IBXCOL,VAL,IBXSIZE) ; Sets the output global
+1 ;IBXPG = Form page IBXLN = Form line IBXCOL = form column
+2 ;VAL = value to place at PG/LINE/COL IBXSIZE = size counter (optional)
+3 ;
+4 SET ^TMP("IBXDATA",$JOB,IBXREC,IBXPG,IBXLN,IBXCOL)=VAL
SET IBXSIZE=$GET(IBXSIZE)+$LENGTH(VAL)
+5 QUIT
+6 ;
SETEDIT(IBFORM,IBX0) ;
+1 NEW Z,Z0
+2 if $PIECE(IBX0,U,9)="D"!'$PIECE(IBX0,U,10)
QUIT
+3 SET Z0=$PIECE($GET(^IBA(364.5,+$PIECE(IBX0,U,3),0)),U,6)
+4 if Z0=""
QUIT
SET Z0=$ORDER(^DD(+$GET(^IBE(353,IBXFORM,2)),"B",Z0,""))
+5 if Z0=""
QUIT
+6 SET Z=$ORDER(^TMP("IBXEDIT",$JOB,$PIECE(IBX0,U,10),""),-1)+1
+7 SET ^TMP("IBXEDIT",$JOB,$PIECE(IBX0,U,10),Z)=Z0
+8 QUIT
+9 ;
NULLCHEK ; Checks for no output if null, deletes variable if appropriate
+1 ; Check for no output if transmit and null
+2 IF $PIECE($GET(^IBA(364.6,+IBXDA,0)),U,12)
IF $PIECE($GET(^IBE(353,IBXFORM,2)),U,2)="T"
Begin DoDot:1
+3 IF $DATA(@IBXARRAY)=1
if $GET(@IBXARRAY)=""
KILL @IBXARRAY
QUIT
+4 IF $DATA(@IBXARRAY)>9
Begin DoDot:2
+5 NEW Z
+6 SET Z=0
FOR
SET Z=$ORDER(@IBXARRAY@(Z))
if 'Z
QUIT
IF $GET(@IBXARRAY@(Z))=""
KILL @IBXARRAY@(Z)
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
