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