Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBATO1

IBATO1.m

Go to the documentation of this file. 
  1. IBATO1 ;LL/ELZ - TRANSFER PRICING REPORTS CONT. ; 18-DEC-98
  1.  ;;2.0;INTEGRATED BILLING;**115,266,389**;21-MAR-94;Build 6
  1.  ;;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1. PAGE() ; performs page reads and returns 1 if quiting is needed
  1.  N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
  1.  S DIR(0)="E" D ^DIR
  1.  Q $D(DIRUT)
  1. NUM(X,X2,X3) ; calls to format numbers
  1.  D COMMA^%DTC
  1.  Q $E(X,1,$L(X)-1)
  1. UNIT(IBA,IBD,IBO) ; sets IBD subscripted with units for IBA
  1.  N IBX,IBB S IBB="UNIT"
  1.  I $P(IBA(0),"^",12)["DGPM" D  Q
  1.  . S IBD(1,IBO,IBB)=$$EX^IBATUTL(351.61,1.01,+IBA(1))
  1.  I $P(IBA(0),"^",12)["PSRX(" D  Q
  1.  . S IBD(1,IBO,IBB)=$$EX^IBATUTL(52,.01,+$P(IBA(0),"^",12))
  1.  I $P(IBA(0),"^",12)["RMPR" D  Q
  1.  . S IBD(1,IBO,IBB)="PROSTHETIC"
  1.  S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D
  1.  . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
  1.  . S IBD(IBX,IBO,IBB)="CPT"_$P($$PROC^IBATUTL(+IBX(0)),U)
  1.  Q
  1. TYPE(IBA,IBO) ; sets IBO with descriptive trans type for IBA
  1.  N IBB,IBC,IBD
  1.  S:'$D(IBA(0)) IBA(0)=^IBAT(351.61,IBA,0)
  1.  S IBB=$P(IBA(0),"^",12)
  1.  I IBB["DGPM(" S IBO="INPATIENT" Q
  1.  I IBB["PSRX(" S IBO="PHARMACY" Q
  1.  I IBB["RMPR(660," S IBO="PROSTHETICS" Q
  1.  D GETGEN^SDOE(+$P(IBA(0),"^",12),"IBC")
  1.  D:$P($G(IBC(0)),"^",3) PARSE^SDOE(.IBC,"EXTERNAL","IBD")
  1.  S IBO=$S($G(IBD(.03))="":"OUTPATINET",1:$E("OUT "_IBD(.03),1,10))
  1.  Q
  1. DES(IBA,IBD,IBO) ; sets IBD subscripted with description for IBA
  1.  N IBX,IBB,IBDATE S IBB="UNIT DESCRIPTION"
  1.  I $P(IBA(0),"^",12)["DGPM" D  Q
  1.  . S IBD(1,IBO,IBB)=$E($$DRGTD^IBACSV(+IBA(1),$P(IBA(0),U,4)),1,18)
  1.  I $P(IBA(0),"^",12)["PSRX(" D  Q
  1.  . S IBD(1,IBO,IBB)=$E($$EX^IBATUTL(351.61,4.01,+IBA(4)),1,18)
  1.  I $P(IBA(0),"^",12)["RMPR(660," D  Q
  1.  . S IBD(1,IBO,IBB)=$E($P($$PIN^IBATUTL(+$P(IBA(0),"^",12)),U,2),1,18)
  1.  S IBDATE=$P($G(^IBAT(351.61,IBIEN,0)),U,4) ; Event Date
  1.  S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D
  1.  . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
  1.  . S IBD(IBX,IBO,IBB)=$E($P($$PROC^IBATUTL(+IBX(0),IBDATE),U,2),1,18)
  1.  Q
  1. PRICE(IBA,IBD,IBO) ; sets IBD subscripted with price for IBA
  1.  N IBX,IBB S IBB="UNIT PRICE"
  1.  I $P(IBA(0),"^",12)["DGPM" D  Q
  1.  . S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",2),2,9)
  1.  I $P(IBA(0),"^",12)["PSRX(" D  Q
  1.  . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",3),3,10)
  1.  I $P(IBA(0),"^",12)["RMPR(660," D  Q
  1.  . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",5),3,10)
  1.  S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D
  1.  . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
  1.  . S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",3),2,9)
  1.  Q
  1. QTY(IBA,IBD,IBO) ; sets IBD subscripted with quantity for IBA
  1.  N IBX,IBB S IBB="QTY"
  1.  I $P(IBA(0),"^",12)["DGPM" D  Q
  1.  . S IBD(1,IBO,IBB)=$$NUM($P(IBA(1),"^",5),0,3)
  1.  I $P(IBA(0),"^",12)["PSRX(" D  Q
  1.  . S IBD(1,IBO,IBB)=$$NUM($P(IBA(4),"^",2),0,3)
  1.  I $P(IBA(0),"^",12)["RMPR(660," D  Q
  1.  . S IBD(1,IBO,IBB)=$$NUM(1,0,3)
  1.  S IBX=0 F  S IBX=$O(^IBAT(351.61,IBA,3,IBX)) Q:IBX<1  D
  1.  . S IBX(0)=^IBAT(351.61,IBIEN,3,IBX,0)
  1.  . S IBD(IBX,IBO,IBB)=$$NUM($P(IBX(0),"^",2),0,3)
  1.  Q
  1. COPAY(IBA) ; compute copay for iba and return
  1.  N IBC,IBT,IBCOPAY
  1.  S IBCOPAY=$$COPAY^IBATUTL($P(IBA(0),"^",2),$P(IBA(0),"^",12),$P($P(IBA(0),"^",9),"."),$P($P(IBA(0),"^",10),"."))
  1.  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
  1.  I  S IBCOPAY=IBCOPAY/IBC
  1.  Q $$NUM(IBCOPAY,2,7)
  1.  ;
  1. VAR(IBA) ; set up required variables
  1.  N IBX
  1.  F IBX=0,1,4 S IBA(IBX)=$G(^IBAT(351.61,IBA,IBX))
  1.  Q
  1. PRT(IBIEN) ; main entry for report printing
  1.  ;
  1.  N DFN,IBXDATA,IBC,IBF,IBF1,IBF2,IBO,VA,VAERR,IBM
  1.  ;
  1.  D VAR(.IBIEN)
  1.  S DFN=$P(IBIEN(0),"^",2)
  1.  I IBPAGE=0!($Y+5>IOSL)!(IBLAST'=$P(IBIEN(0),"^",11)) S IBLAST=$P(IBIEN(0),"^",11) D PRTH Q:IBQUIT
  1.  W ! S IBC=0
  1.  ;
  1.  ; print single valued data first
  1.  S IBF=0 F  S IBF=$O(IBFIELD(IBF)) Q:IBF<1  D
  1.  . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
  1.  . X ^IBAT(351.62,IBF1,1)
  1.  . W IBXDATA,?IBC
  1.  ;
  1.  ; compute multiple valued data
  1.  S IBM=IBC
  1.  S IBF=0 F  S IBF=$O(IBMUL(IBF)) Q:IBF<1  D
  1.  . S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1))
  1.  . X ^IBAT(351.62,IBF1,1)
  1.  ;
  1.  ; print multiple valued data
  1.  S IBF=0 F  S IBF=$O(IBXDATA(IBF)) Q:IBF=""  W:IBC'=IBM ! W ?IBM S IBC=IBM D
  1.  . 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
  1.  .. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2))
  1.  .. S IBF2=^IBAT(351.62,IBF2,0)
  1.  .. S IBC=IBC+$P(IBF2,"^",2)+1
  1.  .. I IBC>IOM W !?5 S IBC=$P(IBF2,"^",2)+6
  1.  .. W IBXDATA(IBF,IBO,IBF1),?IBC
  1.  ;
  1.  ; clean up
  1.  X ^IBAT(351.62,999,1)
  1.  ;
  1.  Q
  1. EXPRT(IBIEN) ; main entry for excel printing
  1.  ;
  1.  N DFN,IBXDATA,IBF,IBF1,IBF2,IBO,VA,VAERR
  1.  ;
  1.  D VAR(.IBIEN)
  1.  S DFN=$P(IBIEN(0),"^",2)
  1.  ;
  1.  ; do single if no multiple
  1.  I '$D(IBMUL) D EXSING() W ! X ^IBAT(351.62,999,1) Q
  1.  ;
  1.  ; compute multiple valued data
  1.  S IBF=0 F  S IBF=$O(IBMUL(IBF)) Q:IBF<1  D
  1.  . S IBF1=0,IBF1=$O(IBMUL(IBF,IBF1))
  1.  . X ^IBAT(351.62,IBF1,1)
  1.  ;
  1.  ; print multiple valued data
  1.  S IBF=0 F  S IBF=$O(IBXDATA(IBF)) Q:IBF=""  D EXSING(IBF) D
  1.  . 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
  1.  .. S IBF2=0,IBF2=$O(^IBAT(351.62,"B",IBF1,IBF2))
  1.  .. S IBF2=^IBAT(351.62,IBF2,0)
  1.  .. W $$STRIP(IBXDATA(IBF,IBO,IBF1),IBF2),"|"
  1.  . W !
  1.  ;
  1.  ; clean up
  1.  X ^IBAT(351.62,999,1)
  1.  ;
  1.  Q
  1. STRIP(A,B) ; strips off junk from numbers
  1.  Q $S($P(B,"^",5):+$TR(A,", "),1:A)
  1.  ;
  1. EXSING(IBF) ; print single valued data first
  1.  S IBF=0 F  S IBF=$O(IBFIELD(IBF)) Q:IBF<1  D
  1.  . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
  1.  . X ^IBAT(351.62,IBF1,1)
  1.  . W $$STRIP(IBXDATA,IBF1(0)),"|"
  1.  Q
  1.  ;
  1. PRTH ; header
  1.  S IBC=0
  1.  D HEAD^IBATO($P(IBIEN(0),"^",11)) Q:IBQUIT
  1.  W !
  1.  S IBF=0 F  S IBF=$O(IBFIELD(IBF)) Q:IBF<1  D
  1.  . D PRTG(.IBFIELD,.IBF,.IBF1,.IBC)
  1.  . W $P(IBF1(0),"^"),?IBC
  1.  ;
  1.  ; multiple part of header
  1.  S IBF=0 F  S IBF=$O(IBMUL(IBF)) Q:IBF<1  D
  1.  . D PRTG(.IBMUL,.IBF,.IBF1,.IBC)
  1.  . W $P(IBF1(0),"^"),?IBC
  1.  ;
  1.  W ! F IBC=1:1:IOM W "-"
  1.  Q
  1. PRTG(X,Y,Z,C) ; general printing stuff
  1.  S Z=0,Z=$O(X(Y,Z))
  1.  S Z(0)=X(Y,Z)
  1.  I $D(C) S C=C+$P(Z(0),"^",2)+1 I C>IOM W !?5 S C=$P(Z(0),"^",2)+6
  1.  Q
  1. SEL(B) ; selection of which fields B = default
  1.  ; sets up variables IBFIELD and IBMUL
  1.  ; returns max length of output
  1.  ;
  1.  N DTOUT,DUOUT,DIRUT,DIROUT,DIR,W,X,Y,Z,IBR,IBM
  1.  S (IBR,IBM)=0
  1.  ;
  1. AGAIN S DIR(0)="LAO^1:98",DIR("A")="Which fields: "_$S($D(B):B_"//",1:"")
  1.  S DIR("?")="Select what fields you want printed. Ranges must start with a valid number."
  1.  D ^DIR Q:$D(DTOUT)!($D(DUOUT))!($D(DIROUT)) 0
  1.  ;
  1.  ; if default selected set Y
  1.  S:Y="" Y=$G(B)
  1.  ;
  1.  ; validate input
  1.  I '$D(^IBAT(351.62,"AC",+Y)) W *7,"??" G AGAIN
  1.  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
  1.  ;
  1.  ; setup variables for output
  1.  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
  1.  ;
  1.  Q $G(IBFIELD)+$G(IBMUL)
  1.  ;
  1. DISP ; displays fields for selection
  1.  ;
  1.  N IBX,IBL,IBI
  1.  ;
  1.  ; set up lines
  1.  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)
  1.  ;
  1.  ; display lines
  1.  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.",!
  1.  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),"^")
  1.  ;
  1.  W !
  1.  ;
  1.  Q