IBATO1 ;LL/ELZ - TRANSFER PRICING REPORTS CONT. ; 18-DEC-98
;;2.0;INTEGRATED BILLING;**115,266,389**;21-MAR-94;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified.
;
PAGE() ; performs page reads and returns 1 if quiting is needed
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="E" D ^DIR
Q $D(DIRUT)
NUM(X,X2,X3) ; calls to format numbers
D COMMA^%DTC
Q $E(X,1,$L(X)-1)
UNIT(IBA,IBD,IBO) ; sets IBD subscripted with units for IBA
N IBX,IBB S IBB="UNIT"
I $P(IBA(0),"^",12)["DGPM" D Q
. S IBD(1,IBO,IBB)=$$EX^IBATUTL(351.61,1.01,+IBA(1))
I $P(IBA(0),"^",12)["PSRX(" D Q
. S IBD(1,IBO,IBB)=$$EX^IBATUTL(52,.01,+$P(IBA(0),"^",12))
I $P(IBA(0),"^",12)["RMPR" D Q
. S IBD(1,IBO,IBB)="PROSTHETIC"
S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D
. S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
. S IBD(IBX,IBO,IBB)="CPT"_$P($$PROC^IBATUTL(+IBX(0)),U)
Q
TYPE(IBA,IBO) ; sets IBO with descriptive trans type for IBA
N IBB,IBC,IBD
S:'$D(IBA(0)) IBA(0)=^IBAT(351.61,IBA,0)
S IBB=$P(IBA(0),"^",12)
I IBB["DGPM(" S IBO="INPATIENT" Q
I IBB["PSRX(" S IBO="PHARMACY" Q
I IBB["RMPR(660," S IBO="PROSTHETICS" Q
D GETGEN^SDOE(+$P(IBA(0),"^",12),"IBC")
D:$P($G(IBC(0)),"^",3) PARSE^SDOE(.IBC,"EXTERNAL","IBD")
S IBO=$S($G(IBD(.03))="":"OUTPATINET",1:$E("OUT "_IBD(.03),1,10))
Q
DES(IBA,IBD,IBO) ; sets IBD subscripted with description for IBA
N IBX,IBB,IBDATE S IBB="UNIT DESCRIPTION"
I $P(IBA(0),"^",12)["DGPM" D Q
. S IBD(1,IBO,IBB)=$E($$DRGTD^IBACSV(+IBA(1),$P(IBA(0),U,4)),1,18)
I $P(IBA(0),"^",12)["PSRX(" D Q
. S IBD(1,IBO,IBB)=$E($$EX^IBATUTL(351.61,4.01,+IBA(4)),1,18)
I $P(IBA(0),"^",12)["RMPR(660," D Q
. S IBD(1,IBO,IBB)=$E($P($$PIN^IBATUTL(+$P(IBA(0),"^",12)),U,2),1,18)
S IBDATE=$P($G(^IBAT(351.61,IBIEN,0)),U,4) ; Event Date
S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D
. S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
. S IBD(IBX,IBO,IBB)=$E($P($$PROC^IBATUTL(+IBX(0),IBDATE),U,2),1,18)
Q
PRICE(IBA,IBD,IBO) ; sets IBD subscripted with price for IBA
N IBX,IBB S IBB="UNIT PRICE"
I $P(IBA(0),"^",12)["DGPM" D Q
. S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",2),2,9)
I $P(IBA(0),"^",12)["PSRX(" D Q
. S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",3),3,10)
I $P(IBA(0),"^",12)["RMPR(660," D Q
. S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",5),3,10)
S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D
. S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
. S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",3),2,9)
Q
QTY(IBA,IBD,IBO) ; sets IBD subscripted with quantity for IBA
N IBX,IBB S IBB="QTY"
I $P(IBA(0),"^",12)["DGPM" D Q
. S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",5),0,3)
I $P(IBA(0),"^",12)["PSRX(" D Q
. S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",2),0,3)
I $P(IBA(0),"^",12)["RMPR(660," D Q
. S IBD(1,IBO,IBB)=$$NUM(1,0,3)
S IBX=0 F S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1 D
. S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
. S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",2),0,3)
Q
COPAY(IBA) ; compute copay for iba and return
N IBC,IBT,IBCOPAY
S IBCOPAY=$$COPAY^IBATUTL($P(IBA(0),"^",2),$P(IBA(0),"^",12),$P($P(IBA(0),"^",9),"."),$P($P(IBA(0),"^",10),"."))
I IBCOPAY,$P(IBA(0),"^",12)["SCE(" S (IBC,IBT)=0 F S IBT=$O(^IBAT(351.61,"AH",$P(IBA(0),"^",2),$P(IBA(0),"^",4),IBT)) Q:IBT<1 I $P(^IBAT(351.61,IBT,0),"^",12)["SCE(" S IBC=IBC+1
I S IBCOPAY=IBCOPAY/IBC
Q $$NUM(IBCOPAY,2,7)
;
VAR(IBA) ; set up required variables
N IBX
F IBX=0,1,4 S IBA(IBX)=$G(^IBAT(351.61,IBA,IBX))
Q
PRT(IBIEN) ; main entry for report printing
;
N DFN,IBXDATA,IBC,IBF,IBF1,IBF2,IBO,VA,VAERR,IBM
;
D VAR(.IBIEN)
S DFN=$P(IBIEN(0),"^",2)
I IBPAGE=0!($Y+5>IOSL)!(IBLAST'=$P(IBIEN(0),"^",11)) S IBLAST=$P(IBIEN(0),"^",11) D PRTH Q:IBQUIT
W ! S IBC=0
;
; print single valued data first
S IBF=0 F S IBF=$O(IBFIELD(IBF)) Q:IBF<1 D
. D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
. X ^IBAT(351.62,IBF1,1)
. W IBXDATA,?IBC
;
; compute multiple valued data
S IBM=IBC
S IBF=0 F S IBF=$O(IBMUL(IBF)) Q:IBF<1 D
. S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1))
. X ^IBAT(351.62,IBF1,1)
;
; print multiple valued data
S IBF=0 F S IBF=$O(IBXDATA(IBF)) Q:IBF="" W:IBC'=IBM ! W ?IBM S IBC=IBM D
. S IBO=0 F S IBO=$O(IBXDATA(IBF,IBO)) Q:IBO<1 S IBF1=0 F S IBF1=$O(IBXDATA(IBF,IBO,IBF1)) Q:IBF1="" D
.. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2))
.. S IBF2=^IBAT(351.62,IBF2,0)
.. S IBC=IBC+$P(IBF2,"^",2)+1
.. I IBC>IOM W !?5 S IBC=$P(IBF2,"^",2)+6
.. W IBXDATA(IBF,IBO,IBF1),?IBC
;
; clean up
X ^IBAT(351.62,999,1)
;
Q
EXPRT(IBIEN) ; main entry for excel printing
;
N DFN,IBXDATA,IBF,IBF1,IBF2,IBO,VA,VAERR
;
D VAR(.IBIEN)
S DFN=$P(IBIEN(0),"^",2)
;
; do single if no multiple
I '$D(IBMUL) D EXSING() W ! X ^IBAT(351.62,999,1) Q
;
; compute multiple valued data
S IBF=0 F S IBF=$O(IBMUL(IBF)) Q:IBF<1 D
. S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1))
. X ^IBAT(351.62,IBF1,1)
;
; print multiple valued data
S IBF=0 F S IBF=$O(IBXDATA(IBF)) Q:IBF="" D EXSING(IBF) D
. S IBO=0 F S IBO=$O(IBXDATA(IBF,IBO)) Q:IBO<1 S IBF1=0 F S IBF1=$O(IBXDATA(IBF,IBO,IBF1)) Q:IBF1="" D
.. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2))
.. S IBF2=^IBAT(351.62,IBF2,0)
.. W $$STRIP(IBXDATA(IBF,IBO,IBF1),IBF2),"|"
. W !
;
; clean up
X ^IBAT(351.62,999,1)
;
Q
STRIP(A,B) ; strips off junk from numbers
Q $S($P(B,"^",5):+$TR(A,", "),1:A)
;
EXSING(IBF) ; print single valued data first
S IBF=0 F S IBF=$O(IBFIELD(IBF)) Q:IBF<1 D
. D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
. X ^IBAT(351.62,IBF1,1)
. W $$STRIP(IBXDATA,IBF1(0)),"|"
Q
;
PRTH ; header
S IBC=0
D HEAD^IBATO($P(IBIEN(0),"^",11)) Q:IBQUIT
W !
S IBF=0 F S IBF=$O(IBFIELD(IBF)) Q:IBF<1 D
. D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
. W $P(IBF1(0),"^"),?IBC
;
; multiple part of header
S IBF=0 F S IBF=$O(IBMUL(IBF)) Q:IBF<1 D
. D PRTG(.IBMUL,.IBF,.IBF1,.IBC)
. W $P(IBF1(0),"^"),?IBC
;
W ! F IBC=1:1:IOM W "-"
Q
PRTG(X,Y,Z,C) ; general printing stuff
S Z=0,Z=$O(X(Y,Z))
S Z(0)=X(Y,Z)
I $D(C) S C=C+$P(Z(0),"^",2)+1 I C>IOM W !?5 S C=$P(Z(0),"^",2)+6
Q
SEL(B) ; selection of which fields B = default
; sets up variables IBFIELD and IBMUL
; returns max length of output
;
N DTOUT,DUOUT,DIRUT,DIROUT,DIR,W,X,Y,Z,IBR,IBM
S (IBR,IBM)=0
;
AGAIN S DIR(0)="LAO^1:98",DIR("A")="Which fields: "_$S($D(B):B_"//",1:"")
S DIR("?")="Select what fields you want printed. Ranges must start with a valid number."
D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT)) 0
;
; if default selected set Y
S:Y="" Y=$G(B)
;
; validate input
I '$D(^IBAT(351.62,"AC",+Y)) W *7,"??" G AGAIN
F X=1:1 Q:$P(Y,",",X)="" S:'$D(^IBAT(351.62,"AC",$P(Y,",",X))) Y=$P(Y,",",1,X-1)_","_$P(Y,",",X+1,98),X=X-1
;
; setup variables for output
F X=1:1 Q:'$P(Y,",",X) S W=+$P($Q(^IBAT(351.62,"AC",$P(Y,",",X))),",",4),Z=^IBAT(351.62,W,0),IBR=$S($P(Z,"^",3):"IBMUL",1:"IBFIELD"),@(IBR_"("_X_","_W_")")=Z,@IBR=$G(@IBR)+$P(Z,"^",2)+1
;
Q $G(IBFIELD)+$G(IBMUL)
;
DISP ; displays fields for selection
;
N IBX,IBL,IBI
;
; set up lines
S (IBX,IBL)=0 F S IBX=$O(^IBAT(351.62,"AC",IBX)),IBL=IBL+1 Q:IBX<1 S:IBX=40 IBL=1 S IBI=+$P($Q(^IBAT(351.62,"AC",IBX)),",",4),IBL(IBL,$S(IBX<40:0,1:40))=^IBAT(351.62,IBI,0)
;
; display lines
W @IOF,!,"Select the fields you would like printed on this report, in the order you",!,"want them printed. Fields with an asterisk (*) are fields that are multiples.",!
S IBX="" F S IBX=$O(IBL(IBX)) Q:IBX="" W ! S IBI="" F S IBI=$O(IBL(IBX,IBI)) Q:IBI="" W ?IBI,$P(IBL(IBX,IBI),"^",4),?IBI+4,$S($P(IBL(IBX,IBI),"^",3):"*",1:""),$P(IBL(IBX,IBI),"^")
;
W !
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBATO1 7670 printed Dec 13, 2024@02:07:58 Page 2
IBATO1 ;LL/ELZ - TRANSFER PRICING REPORTS CONT. ; 18-DEC-98
+1 ;;2.0;INTEGRATED BILLING;**115,266,389**;21-MAR-94;Build 6
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
PAGE() ; performs page reads and returns 1 if quiting is needed
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIR(0)="E"
DO ^DIR
+3 QUIT $DATA(DIRUT)
NUM(X,X2,X3) ; calls to format numbers
+1 DO COMMA^%DTC
+2 QUIT $EXTRACT(X,1,$LENGTH(X)-1)
UNIT(IBA,IBD,IBO) ; sets IBD subscripted with units for IBA
+1 NEW IBX,IBB
SET IBB="UNIT"
+2 IF $PIECE(IBA(0),"^",12)["DGPM"
Begin DoDot:1
+3 SET IBD(1,IBO,IBB)=$$EX^IBATUTL(351.61,1.01,+IBA(1))
End DoDot:1
QUIT
+4 IF $PIECE(IBA(0),"^",12)["PSRX("
Begin DoDot:1
+5 SET IBD(1,IBO,IBB)=$$EX^IBATUTL(52,.01,+$PIECE(IBA(0),"^",12))
End DoDot:1
QUIT
+6 IF $PIECE(IBA(0),"^",12)["RMPR"
Begin DoDot:1
+7 SET IBD(1,IBO,IBB)="PROSTHETIC"
End DoDot:1
QUIT
+8 SET IBX=0
FOR
SET IBX=$ORDER(^IBAT(351.61,IBA,3,IBX))
if IBX<1
QUIT
Begin DoDot:1
+9 SET IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
+10 SET IBD(IBX,IBO,IBB)="CPT"_$PIECE($$PROC^IBATUTL(+IBX(0)),U)
End DoDot:1
+11 QUIT
TYPE(IBA,IBO) ; sets IBO with descriptive trans type for IBA
+1 NEW IBB,IBC,IBD
+2 if '$DATA(IBA(0))
SET IBA(0)=^IBAT(351.61,IBA,0)
+3 SET IBB=$PIECE(IBA(0),"^",12)
+4 IF IBB["DGPM("
SET IBO="INPATIENT"
QUIT
+5 IF IBB["PSRX("
SET IBO="PHARMACY"
QUIT
+6 IF IBB["RMPR(660,"
SET IBO="PROSTHETICS"
QUIT
+7 DO GETGEN^SDOE(+$PIECE(IBA(0),"^",12),"IBC")
+8 if $PIECE($GET(IBC(0)),"^",3)
DO PARSE^SDOE(.IBC,"EXTERNAL","IBD")
+9 SET IBO=$SELECT($GET(IBD(.03))="":"OUTPATINET",1:$EXTRACT("OUT "_IBD(.03),1,10))
+10 QUIT
DES(IBA,IBD,IBO) ; sets IBD subscripted with description for IBA
+1 NEW IBX,IBB,IBDATE
SET IBB="UNIT DESCRIPTION"
+2 IF $PIECE(IBA(0),"^",12)["DGPM"
Begin DoDot:1
+3 SET IBD(1,IBO,IBB)=$EXTRACT($$DRGTD^IBACSV(+IBA(1),$PIECE(IBA(0),U,4)),1,18)
End DoDot:1
QUIT
+4 IF $PIECE(IBA(0),"^",12)["PSRX("
Begin DoDot:1
+5 SET IBD(1,IBO,IBB)=$EXTRACT($$EX^IBATUTL(351.61,4.01,+IBA(4)),1,18)
End DoDot:1
QUIT
+6 IF $PIECE(IBA(0),"^",12)["RMPR(660,"
Begin DoDot:1
+7 SET IBD(1,IBO,IBB)=$EXTRACT($PIECE($$PIN^IBATUTL(+$PIECE(IBA(0),"^",12)),U,2),1,18)
End DoDot:1
QUIT
+8 ; Event Date
SET IBDATE=$PIECE($GET(^IBAT(351.61,IBIEN,0)),U,4)
+9 SET IBX=0
FOR
SET IBX=$ORDER(^IBAT(351.61,IBA,3,IBX))
if IBX<1
QUIT
Begin DoDot:1
+10 SET IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
+11 SET IBD(IBX,IBO,IBB)=$EXTRACT($PIECE($$PROC^IBATUTL(+IBX(0),IBDATE),U,2),1,18)
End DoDot:1
+12 QUIT
PRICE(IBA,IBD,IBO) ; sets IBD subscripted with price for IBA
+1 NEW IBX,IBB
SET IBB="UNIT PRICE"
+2 IF $PIECE(IBA(0),"^",12)["DGPM"
Begin DoDot:1
+3 SET IBD(1,IBO,IBB)=$$NUM($PIECE(IBA(1),"^",2),2,9)
End DoDot:1
QUIT
+4 IF $PIECE(IBA(0),"^",12)["PSRX("
Begin DoDot:1
+5 SET IBD(1,IBO,IBB)=$$NUM($PIECE(IBA(4),"^",3),3,10)
End DoDot:1
QUIT
+6 IF $PIECE(IBA(0),"^",12)["RMPR(660,"
Begin DoDot:1
+7 SET IBD(1,IBO,IBB)=$$NUM($PIECE(IBA(4),"^",5),3,10)
End DoDot:1
QUIT
+8 SET IBX=0
FOR
SET IBX=$ORDER(^IBAT(351.61,IBA,3,IBX))
if IBX<1
QUIT
Begin DoDot:1
+9 SET IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
+10 SET IBD(IBX,IBO,IBB)=$$NUM($PIECE(IBX(0),"^",3),2,9)
End DoDot:1
+11 QUIT
QTY(IBA,IBD,IBO) ; sets IBD subscripted with quantity for IBA
+1 NEW IBX,IBB
SET IBB="QTY"
+2 IF $PIECE(IBA(0),"^",12)["DGPM"
Begin DoDot:1
+3 SET IBD(1,IBO,IBB)=$$NUM($PIECE(IBA(1),"^",5),0,3)
End DoDot:1
QUIT
+4 IF $PIECE(IBA(0),"^",12)["PSRX("
Begin DoDot:1
+5 SET IBD(1,IBO,IBB)=$$NUM($PIECE(IBA(4),"^",2),0,3)
End DoDot:1
QUIT
+6 IF $PIECE(IBA(0),"^",12)["RMPR(660,"
Begin DoDot:1
+7 SET IBD(1,IBO,IBB)=$$NUM(1,0,3)
End DoDot:1
QUIT
+8 SET IBX=0
FOR
SET IBX=$ORDER(^IBAT(351.61,IBA,3,IBX))
if IBX<1
QUIT
Begin DoDot:1
+9 SET IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
+10 SET IBD(IBX,IBO,IBB)=$$NUM($PIECE(IBX(0),"^",2),0,3)
End DoDot:1
+11 QUIT
COPAY(IBA) ; compute copay for iba and return
+1 NEW IBC,IBT,IBCOPAY
+2 SET IBCOPAY=$$COPAY^IBATUTL($PIECE(IBA(0),"^",2),$PIECE(IBA(0),"^",12),$PIECE($PIECE(IBA(0),"^",9),"."),$PIECE($PIECE(IBA(0),"^",10),"."))
+3 IF IBCOPAY
IF $PIECE(IBA(0),"^",12)["SCE("
SET (IBC,IBT)=0
FOR
SET IBT=$ORDER(^IBAT(351.61,"AH",$PIECE(IBA(0),"^",2),$PIECE(IBA(0),"^",4),IBT))
if IBT<1
QUIT
IF $PIECE(^IBAT(351.61,IBT,0),"^",12)["SCE("
SET IBC=IBC+1
+4 IF $TEST
SET IBCOPAY=IBCOPAY/IBC
+5 QUIT $$NUM(IBCOPAY,2,7)
+6 ;
VAR(IBA) ; set up required variables
+1 NEW IBX
+2 FOR IBX=0,1,4
SET IBA(IBX)=$GET(^IBAT(351.61,IBA,IBX))
+3 QUIT
PRT(IBIEN) ; main entry for report printing
+1 ;
+2 NEW DFN,IBXDATA,IBC,IBF,IBF1,IBF2,IBO,VA,VAERR,IBM
+3 ;
+4 DO VAR(.IBIEN)
+5 SET DFN=$PIECE(IBIEN(0),"^",2)
+6 IF IBPAGE=0!($Y+5>IOSL)!(IBLAST'=$PIECE(IBIEN(0),"^",11))
SET IBLAST=$PIECE(IBIEN(0),"^",11)
DO PRTH
if IBQUIT
QUIT
+7 WRITE !
SET IBC=0
+8 ;
+9 ; print single valued data first
+10 SET IBF=0
FOR
SET IBF=$ORDER(IBFIELD(IBF))
if IBF<1
QUIT
Begin DoDot:1
+11 DO PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
+12 XECUTE ^IBAT(351.62,IBF1,1)
+13 WRITE IBXDATA,?IBC
End DoDot:1
+14 ;
+15 ; compute multiple valued data
+16 SET IBM=IBC
+17 SET IBF=0
FOR
SET IBF=$ORDER(IBMUL(IBF))
if IBF<1
QUIT
Begin DoDot:1
+18 SET IBF1=0
SET IBF1=$ORDER(IBMUL(IBF,IBF1))
+19 XECUTE ^IBAT(351.62,IBF1,1)
End DoDot:1
+20 ;
+21 ; print multiple valued data
+22 SET IBF=0
FOR
SET IBF=$ORDER(IBXDATA(IBF))
if IBF=""
QUIT
if IBC'=IBM
WRITE !
WRITE ?IBM
SET IBC=IBM
Begin DoDot:1
+23 SET IBO=0
FOR
SET IBO=$ORDER(IBXDATA(IBF,IBO))
if IBO<1
QUIT
SET IBF1=0
FOR
SET IBF1=$ORDER(IBXDATA(IBF,IBO,IBF1))
if IBF1=""
QUIT
Begin DoDot:2
+24 SET IBF2=0
SET IBF2=$ORDER(^IBAT(351.62,"B",IBF1,IBF2))
+25 SET IBF2=^IBAT(351.62,IBF2,0)
+26 SET IBC=IBC+$PIECE(IBF2,"^",2)+1
+27 IF IBC>IOM
WRITE !?5
SET IBC=$PIECE(IBF2,"^",2)+6
+28 WRITE IBXDATA(IBF,IBO,IBF1),?IBC
End DoDot:2
End DoDot:1
+29 ;
+30 ; clean up
+31 XECUTE ^IBAT(351.62,999,1)
+32 ;
+33 QUIT
EXPRT(IBIEN) ; main entry for excel printing
+1 ;
+2 NEW DFN,IBXDATA,IBF,IBF1,IBF2,IBO,VA,VAERR
+3 ;
+4 DO VAR(.IBIEN)
+5 SET DFN=$PIECE(IBIEN(0),"^",2)
+6 ;
+7 ; do single if no multiple
+8 IF '$DATA(IBMUL)
DO EXSING()
WRITE !
XECUTE ^IBAT(351.62,999,1)
QUIT
+9 ;
+10 ; compute multiple valued data
+11 SET IBF=0
FOR
SET IBF=$ORDER(IBMUL(IBF))
if IBF<1
QUIT
Begin DoDot:1
+12 SET IBF1=0
SET IBF1=$ORDER(IBMUL(IBF,IBF1))
+13 XECUTE ^IBAT(351.62,IBF1,1)
End DoDot:1
+14 ;
+15 ; print multiple valued data
+16 SET IBF=0
FOR
SET IBF=$ORDER(IBXDATA(IBF))
if IBF=""
QUIT
DO EXSING(IBF)
Begin DoDot:1
+17 SET IBO=0
FOR
SET IBO=$ORDER(IBXDATA(IBF,IBO))
if IBO<1
QUIT
SET IBF1=0
FOR
SET IBF1=$ORDER(IBXDATA(IBF,IBO,IBF1))
if IBF1=""
QUIT
Begin DoDot:2
+18 SET IBF2=0
SET IBF2=$ORDER(^IBAT(351.62,"B",IBF1,IBF2))
+19 SET IBF2=^IBAT(351.62,IBF2,0)
+20 WRITE $$STRIP(IBXDATA(IBF,IBO,IBF1),IBF2),"|"
End DoDot:2
+21 WRITE !
End DoDot:1
+22 ;
+23 ; clean up
+24 XECUTE ^IBAT(351.62,999,1)
+25 ;
+26 QUIT
STRIP(A,B) ; strips off junk from numbers
+1 QUIT $SELECT($PIECE(B,"^",5):+$TRANSLATE(A,", "),1:A)
+2 ;
EXSING(IBF) ; print single valued data first
+1 SET IBF=0
FOR
SET IBF=$ORDER(IBFIELD(IBF))
if IBF<1
QUIT
Begin DoDot:1
+2 DO PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
+3 XECUTE ^IBAT(351.62,IBF1,1)
+4 WRITE $$STRIP(IBXDATA,IBF1(0)),"|"
End DoDot:1
+5 QUIT
+6 ;
PRTH ; header
+1 SET IBC=0
+2 DO HEAD^IBATO($PIECE(IBIEN(0),"^",11))
if IBQUIT
QUIT
+3 WRITE !
+4 SET IBF=0
FOR
SET IBF=$ORDER(IBFIELD(IBF))
if IBF<1
QUIT
Begin DoDot:1
+5 DO PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
+6 WRITE $PIECE(IBF1(0),"^"),?IBC
End DoDot:1
+7 ;
+8 ; multiple part of header
+9 SET IBF=0
FOR
SET IBF=$ORDER(IBMUL(IBF))
if IBF<1
QUIT
Begin DoDot:1
+10 DO PRTG(.IBMUL,.IBF,.IBF1,.IBC)
+11 WRITE $PIECE(IBF1(0),"^"),?IBC
End DoDot:1
+12 ;
+13 WRITE !
FOR IBC=1:1:IOM
WRITE "-"
+14 QUIT
PRTG(X,Y,Z,C) ; general printing stuff
+1 SET Z=0
SET Z=$ORDER(X(Y,Z))
+2 SET Z(0)=X(Y,Z)
+3 IF $DATA(C)
SET C=C+$PIECE(Z(0),"^",2)+1
IF C>IOM
WRITE !?5
SET C=$PIECE(Z(0),"^",2)+6
+4 QUIT
SEL(B) ; selection of which fields B = default
+1 ; sets up variables IBFIELD and IBMUL
+2 ; returns max length of output
+3 ;
+4 NEW DTOUT,DUOUT,DIRUT,DIROUT,DIR,W,X,Y,Z,IBR,IBM
+5 SET (IBR,IBM)=0
+6 ;
AGAIN SET DIR(0)="LAO^1:98"
SET DIR("A")="Which fields: "_$SELECT($DATA(B):B_"//",1:"")
+1 SET DIR("?")="Select what fields you want printed. Ranges must start with a valid number."
+2 DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))!($DATA(DIROUT))
QUIT 0
+3 ;
+4 ; if default selected set Y
+5 if Y=""
SET Y=$GET(B)
+6 ;
+7 ; validate input
+8 IF '$DATA(^IBAT(351.62,"AC",+Y))
WRITE *7,"??"
GOTO AGAIN
+9 FOR X=1:1
if $PIECE(Y,",",X)=""
QUIT
if '$DATA(^IBAT(351.62,"AC",$PIECE(Y,",",X)))
SET Y=$PIECE(Y,",",1,X-1)_","_$PIECE(Y,",",X+1,98)
SET X=X-1
+10 ;
+11 ; setup variables for output
+12 FOR X=1:1
if '$PIECE(Y,",",X)
QUIT
SET W=+$PIECE($QUERY(^IBAT(351.62,"AC",$PIECE(Y,",",X))),",",4)
SET Z=^IBAT(351.62,W,0)
SET IBR=$SELECT($PIECE(Z,"^",3):"IBMUL",1:"IBFIELD")
SET @(IBR_"("_X_","_W_")")=Z
SET @IBR=$GET(@IBR)+$PIECE(Z,"^",2)+1
+13 ;
+14 QUIT $GET(IBFIELD)+$GET(IBMUL)
+15 ;
DISP ; displays fields for selection
+1 ;
+2 NEW IBX,IBL,IBI
+3 ;
+4 ; set up lines
+5 SET (IBX,IBL)=0
FOR
SET IBX=$ORDER(^IBAT(351.62,"AC",IBX))
SET IBL=IBL+1
if IBX<1
QUIT
if IBX=40
SET IBL=1
SET IBI=+$PIECE($QUERY(^IBAT(351.62,"AC",IBX)),",",4)
SET IBL(IBL,$SELECT(IBX<40:0,1:40))=^IBAT(351.62,IBI,0)
+6 ;
+7 ; display lines
+8 WRITE @IOF,!,"Select the fields you would like printed on this report, in the order you",!,"want them printed. Fields with an asterisk (*) are fields that are multiples.",!
+9 SET IBX=""
FOR
SET IBX=$ORDER(IBL(IBX))
if IBX=""
QUIT
WRITE !
SET IBI=""
FOR
SET IBI=$ORDER(IBL(IBX,IBI))
if IBI=""
QUIT
WRITE ?IBI,$PIECE(IBL(IBX,IBI),"^",4),?IBI+4,$SELECT($PIECE(IBL(IBX,IBI),"^",3):"*",1:""),$PIECE(IBL(IBX,IBI),"^")
+10 ;
+11 WRITE !
+12 ;
+13 QUIT
