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

IBATO.m

Go to the documentation of this file.
  1. IBATO ;LL/ELZ - TRANSFER PRICING REPORTS ; 18-DEC-98
  1. ;;2.0;INTEGRATED BILLING;**115**;21-MAR-94
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. ENW ; produces a workload report
  1. N IBHEAD,IBMARG,IBFIELD,IBMUL
  1. S IBHEAD="Transfer Pricing Workload Report "
  1. D DISP^IBATO1
  1. S IBMARG=$$SEL^IBATO1("70,60,61,50,51,53,52") Q:'IBMARG
  1. D START
  1. Q
  1. ENP ; produces a patient detail report
  1. N IBHEAD,IBMARG,IBFIELD,IBMUL
  1. S IBHEAD="Transfer Pricing Patient Report "
  1. D DISP^IBATO1
  1. S IBMARG=$$SEL^IBATO1("1,2,40,41,60,50,52,53") Q:'IBMARG
  1. D START
  1. Q
  1. ENEX ; excel formatted report
  1. N IBHEAD,IBMARG,IBFIELD,IBMUL,IBEX,IBQUIT
  1. S IBEX=1,IBQUIT=0
  1. W !!,"This will produce a report that can be exported into an excel spread sheet."
  1. W !,"If you select any fields with an asterisk (*) then the report will contain"
  1. W !,"fields which are multiples. Multiple fields will cause dollar amounts to"
  1. W !,"repeat for each multiple line!",! Q:$$PAGE
  1. D DISP^IBATO1
  1. S IBMARG=$$SEL^IBATO1() Q:'IBMARG
  1. D START
  1. Q
  1. ENS ; produces a summary report
  1. N IBHEAD
  1. S IBHEAD="Transfer Pricing Summary Report "
  1. START ;
  1. N IBBDT,IBEDT,IBFAC,IBXREF,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
  1. ;
  1. ; status for sorting
  1. W !,"Select how you want this report to sort by for a date range."
  1. S DIR(0)="S^E:EVENT DATE;P:PRICED DATE"
  1. S DIR("A")="Select Sort"
  1. D ^DIR Q:$D(DIRUT) S IBXREF=$S(Y="E":"AG",1:"AE")
  1. S IBHEAD=$S(Y="E":"Event ",1:"Priced ")_$G(IBHEAD)
  1. ;
  1. Q:$$FAC^IBATUTL Q:$$SLDR^IBATUTL
  1. Q:$$DEV("Transfer Pricing Report","DQ")
  1. ;
  1. DQ ; queued entry point
  1. N IBPAGE,IBDT,IBVISN,IBIEN,IBLOC,IBTYPE,IBTMP,IBCOPAY,IBCOUNT,IBQUIT
  1. N IBSAVE,IBX,IBLINE,IBLAST
  1. U IO K ^TMP("IBATO",$J)
  1. S (IBQUIT,IBPAGE,IBSAVE,IBLAST)=0,IBDT=$$FMADD^XLFDT(IBBDT,-1)_.99999
  1. S IBLINE="" F IBX=1:1:80 S IBLINE=IBLINE_"-"
  1. F S IBDT=$O(^IBAT(351.61,IBXREF,IBDT)) Q:IBDT<1!(IBDT>IBEDT) S IBIEN=0 F S IBIEN=$O(^IBAT(351.61,IBXREF,IBDT,IBIEN)) Q:IBIEN<1 D
  1. . S IBIEN(0)=$G(^IBAT(351.61,IBIEN,0))
  1. . Q:$P(IBIEN(0),"^",5)="X"!('$P(IBIEN(0),"^",11))
  1. . S IBVISN=+$$VISN^IBATUTL($P(IBIEN(0),"^",11))
  1. . S IBLOC=$P(IBIEN(0),"^",11)
  1. . S IBTYPE=$P($P(IBIEN(0),"^",12),";",2)
  1. . I $D(IBFAC)'=0,$D(IBFAC(IBVISN,"C",$P(IBIEN(0),"^",11)))=0 Q
  1. . S ^TMP("IBATO",$J,IBVISN,IBLOC,IBTYPE,IBIEN)=IBIEN(0)
  1. ;
  1. ;use excel format for printing
  1. I $G(IBEX) D K ^TMP("IBATO",$J) D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" Q
  1. . N A,B,C,D
  1. . ;
  1. . ;first print header
  1. . S A=0 F S A=$O(IBFIELD(A)) Q:A<1 S B=0 F S B=$O(IBFIELD(A,B)) Q:B<1 W $P(IBFIELD(A,B),"^"),"|"
  1. . S A=0 F S A=$O(IBMUL(A)) Q:A<1 S B=0 F S B=$O(IBMUL(A,B)) Q:B<1 W $P(IBMUL(A,B),"^"),"|"
  1. . W !
  1. . ;
  1. . ;now onto printing excel
  1. . S A=0 F S A=$O(^TMP("IBATO",$J,A)) Q:A<1 S B=0 F S B=$O(^TMP("IBATO",$J,A,B)) Q:B<1 S C=0 F S C=$O(^TMP("IBATO",$J,A,B,C)) Q:C="" S D=0 F S D=$O(^TMP("IBATO",$J,A,B,C,D)) Q:D<1 D EXPRT^IBATO1(D)
  1. ;
  1. ; start all other printing
  1. S IBVISN=0
  1. F S IBVISN=$O(^TMP("IBATO",$J,IBVISN)) Q:IBVISN<1!IBQUIT D
  1. . D ZERO(.IBVISN)
  1. . S IBLOC=0
  1. . F S IBLOC=$O(^TMP("IBATO",$J,IBVISN,IBLOC)) Q:IBLOC<1!IBQUIT D
  1. .. D ZERO(.IBLOC)
  1. .. S IBTYPE=""
  1. .. F S IBTYPE=$O(^TMP("IBATO",$J,IBVISN,IBLOC,IBTYPE)) Q:IBTYPE=""!IBQUIT D
  1. ... S IBIEN=0
  1. ... F S IBIEN=$O(^TMP("IBATO",$J,IBVISN,IBLOC,IBTYPE,IBIEN)) Q:IBIEN<1!IBQUIT D
  1. .... S IBIEN(0)=^TMP("IBATO",$J,IBVISN,IBLOC,IBTYPE,IBIEN)
  1. .... S IBIEN(6)=$G(^IBAT(351.61,IBIEN,6))
  1. .... S IBCOPAY=$$COPAY^IBATUTL($P(IBIEN(0),"^",2),$P(IBIEN(0),"^",12),$P($P(IBIEN(0),"^",9),"."),$P($P(IBIEN(0),"^",10),"."))
  1. .... I IBCOPAY,IBTYPE="SCE(" S (IBCOUNT,IBTMP)=0 F S IBTMP=$O(^IBAT(351.61,"AH",$P(IBIEN(0),"^",2),$P(IBIEN(0),"^",4),IBTMP)) Q:IBTMP<1 I $P(^IBAT(351.61,IBTMP,0),"^",12)["SCE(" S IBCOUNT=IBCOUNT+1
  1. .... I S IBCOPAY=IBCOPAY/IBCOUNT
  1. .... S IBIEN(6)="1^"_$P(IBIEN(6),"^",1,2)_"^"_IBCOPAY_"^"_($P(IBIEN(6),"^",2)-IBCOPAY)
  1. .... D:$D(IBMARG) PRT^IBATO1(IBIEN)
  1. .... D SUM(.IBLOC,.IBTYPE,IBIEN(6)),SUM(.IBVISN,.IBTYPE,IBIEN(6))
  1. .. D:'IBQUIT TOTAL(.IBLOC)
  1. .. D:'IBQUIT PRINT(.IBLOC)
  1. . D:'IBQUIT TOTAL(.IBVISN)
  1. . D:'IBQUIT PRINT(.IBVISN):$D(IBFAC)=0!($D(IBFAC(IBVISN))=11)
  1. I $E(IOST,1,2)="C-" I $$PAGE
  1. K ^TMP("IBATO",$J)
  1. D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
  1. Q
  1. TOTAL(X) ; totals up types in subscripted X
  1. N IBP,IBX
  1. F IBX="DGPM(","SCE(","PSRX(","RMPR(660," F IBP=1:1:5 S $P(X("TOTAL"),"^",IBP)=$P(X("TOTAL"),"^",IBP)+$P(X(IBX),"^",IBP)
  1. Q
  1. SUM(X,Z,Y) ; adds up amounts for type in X
  1. N IBP
  1. F IBP=1:1:5 S $P(X(Z),"^",IBP)=$P(X(Z),"^",IBP)+$P(Y,"^",IBP)
  1. Q
  1. ZERO(X) ; zeros out variables
  1. N IBP
  1. F IBP="DGPM(","PSRX(","SCE(","RMPR(660,","TOTAL" S X(IBP)=0
  1. Q
  1. PRINT(IBPRT) ; prints out report sum from what is passed
  1. N IBP
  1. D HEAD(IBPRT)
  1. F IBP="DGPM(","SCE(","PSRX(","RMPR(660,","TOTAL" Q:IBQUIT D
  1. . W !!,$S(IBP="DGPM(":"INPATIENT",IBP="SCE(":"OUTPATIENT",IBP="PSRX(":"PHARMACY",IBP="RMPR(660,":"PROSTHETICS",1:"TOTAL")
  1. . W ":",?27,"COUNT: ",$$NUM($P(IBPRT(IBP),"^"),0)
  1. . W:IBP="DGPM(" !,?20,"OUTLIER DAYS: ",$$NUM($P(IBPRT(IBP),"^",2),0)
  1. . W !,?20,"TOTAL AMOUNT: ",$$NUM($P(IBPRT(IBP),"^",3))
  1. Q
  1. DEV(ZTDESC,ZTRTN) ; device handler for reports
  1. ; needs task description and entry point returns 1 if queued or pop
  1. N %ZIS,ZTSAVE,POP,ZTSK
  1. I $D(IBMARG) W !,?5,"*** Requires a margin of at least ",IBMARG," ***"
  1. S %ZIS="MQ" D ^%ZIS Q:POP 1
  1. I $D(IO("Q")) D Q 1
  1. . S ZTRTN=ZTRTN_"^IBATO",ZTSAVE("IB*")=""
  1. . D ^%ZTLOAD,HOME^%ZIS K IO("Q") W !,"Task# ",ZTSK
  1. Q 0
  1. N Z
  1. I IBPAGE,$E(IOST,1,2)="C-" I $$PAGE S IBQUIT=1 Q
  1. S IBPAGE=IBPAGE+1
  1. W @IOF,!,IBHEAD,$$FMTE^XLFDT(IBBDT,"5D")," to ",$$FMTE^XLFDT(IBEDT,"5D"),?IOM-10,"Page: ",IBPAGE
  1. W ! F Z=1:1:IOM W "-"
  1. W !,"LOCATION: "_$P($$INST^IBATUTL(X),"^")
  1. Q
  1. PAGE() ; performs page reads and returns 1 if quitting is needed
  1. Q:IBQUIT 1
  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 X