- 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 Feb 18, 2025@23:34:22 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