source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATO1.m@ 724

IBATO1 ;LL/ELZ - TRANSFER PRICING REPORTS CONT. ; 18-DEC-98
 ;;2.0;INTEGRATED BILLING;**115,266**;21-MAR-94
 ;;Per VHA Directive 10-93-142, 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($$EX^IBATUTL(351.61,4.04,$P(IBA(4),"^",4)),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