IBARXMO ;LL/ELZ - PHARMACY COPAY CAP REPORTS ;21-JAN-2001
;;2.0;INTEGRATED BILLING;**156,261**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
CAP ; cap report entry point
; this report will produce a summary of patient's who have met or exceed their cap for the period selected. They may select either a mo/year or just a year.
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="D^::AEMP",DIR("A")="Select a Month/Year or just a Year" D ^DIR
Q:$D(DIRUT) S IBD=+Y
D DEV("CAPDQ^IBARXMO","Medication Co-Pay Cap Report")
Q
;
CAPDQ ; cap report processing entry
N IBP,IBT,IBS,IBDT,IBST,IBM,IBNAM,DFN,IBAB,IBAT,IBDATA,IBTOT K ^TMP("IBARXMO",$J)
;
U IO
S (IBP,IBAT,IBAB,IBTOT)=0,IBT="Patient/SSN Non-Billed Total Above Cap Patient Priority",IBS=$$SITE^IBARXMU,IBN=IBN_" for ("_$P(IBS,"^",3)_") "_$P(IBS,"^",2)_" - "_$$FMTE^XLFDT(IBD),IBDT=IBD-1
D HEAD(IBN,IBT)
;
; build tmp for output
; format ^tmp("ibarxmo",$j,name (last 4),dfn)=total not billed ^ at or above cap
;
F S IBDT=$O(^IBAM(354.7,"AC",IBDT)) Q:IBDT<1!($S($E(IBD,4,5)="00"&($E(IBD,1,3)'=$E(IBDT,1,3)):1,$E(IBD,4,5)'="00"&($E(IBDT,1,5)'=$E(IBD,1,5)):1,1:0)) S IBST=0 F S IBST=$O(^IBAM(354.7,"AC",IBDT,IBST)) Q:IBST<1 D
. S DFN=0 F S DFN=$O(^IBAM(354.7,"AC",IBDT,IBST,DFN)) Q:DFN<1 D DEM^VADPT S IBM=0 F S IBM=$O(^IBAM(354.7,"AC",IBDT,IBST,DFN,IBM)) Q:IBM<1 D
.. S IBNAM=$E(VADM(1),1,25)_" ("_VA("BID")_")",^TMP("IBARXMO",$J,IBNAM,DFN)=$G(^TMP("IBARXMO",$J,IBNAM,DFN))+$P(^IBAM(354.7,DFN,1,IBM,0),"^",4)_"^"_IBST
;
; now lets do some printing
S IBNAM=0 F S IBNAM=$O(^TMP("IBARXMO",$J,IBNAM)) Q:IBNAM=""!($D(DIRUT)) S DFN=0 F S DFN=$O(^TMP("IBARXMO",$J,IBNAM,DFN)) Q:DFN<1!($D(DIRUT)) D
. S IBDATA=^TMP("IBARXMO",$J,IBNAM,DFN)
. W !,IBNAM,?37,$J($FN(+IBDATA,",",2),12),?53,$S($P(IBDATA,"^",2)=1:"At Cap",1:"Above Cap"),?71,$$PRIORITY^IBARXMU(DFN)
. S @$S($P(IBDATA,"^",2)=1:"IBAT",1:"IBAB")=@$S($P(IBDATA,"^",2)=1:"IBAT",1:"IBAB")+1,IBTOT=IBTOT+IBDATA
. D:$Y+3>IOSL HEAD(IBN,IBT)
;
W !!,?12,"Patient Count At Cap: ",$J($FN(IBAT,",",0),12)
W !,?9,"Patient Count Above Cap: ",$J($FN(IBAB,",",0),12)
W !,?18,"Total Unbilled: ",?37,$J($FN(IBTOT,",",2),12)
;
I $E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR
;
K IBR,IBN,IBD,^TMP("IBARXMO",$J)
;
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
;
Q
NOBILL ; non-billable report entry point
; this report will produce a list of copay transaction which could not be billed (fully or partly) for the Month/Year selected.
;
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="D^::AEMPX",DIR("A")="Select a Month/Year" D ^DIR
Q:$D(DIRUT) S IBD=+Y
D DEV("NOBILLDQ^IBARXMO","Non-Billable Copayments Report")
Q
NOBILLDQ ; entry point to produce the non-billable report
N IBDT,IBP,IBT,IBX,IBZ,DFN,IBS
U IO
;
S IBP=0,IBS=+$P($$SITE^IBARXMU,"^",3),IBN=IBN_" - "_$$FMTE^XLFDT(IBD),IBT="Patient/SSN Rx # Date Drug Amount" D HEAD(IBN,IBT)
;
S IBDT=IBD F S IBDT=$O(^IBAM(354.71,"AE",IBDT)) Q:IBDT<1!($D(DIRUT))!($E(IBDT,1,5)'=$E(IBD,1,5)) S IBX=0 F S IBX=$O(^IBAM(354.71,"AE",IBDT,IBX)) Q:IBX<1 D
. S IBZ=^IBAM(354.71,IBX,0),$P(IBZ,"^",12)=$P($$NET^IBARXMC(IBX),"^",2)
. Q:$P(IBZ,"^",12)'>0!($P(IBZ,"^",10)'=IBX)!($E(IBZ,1,3)'=IBS)
. S DFN=$P(IBZ,"^",2) D DEM^VADPT
. W !,$E(VADM(1),1,25)_" ("_VA("BID")_")",?32,$P($P(IBZ,"^",9),"-"),?43,$$FMTE^XLFDT(IBDT),?58,$E($P($P(IBZ,"^",9),"-",2),1,13),?72,$J($FN($P(IBZ,"^",12),",",2),8)
. D:$Y+3>IOSL HEAD(IBN,IBT)
;
I $E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR
;
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
;
Q
DEV(IBR,IBN) ; device selection
; IBR=routine, IBN=task name (only used of tasked)
N %ZIS,ZTSK,ZTSAVE,POP,ZTRTN,ZTDESC
S %ZIS="MQ" D ^%ZIS Q:POP
I $D(IO("Q")) D Q
. S ZTRTN=IBR,ZTDESC=IBN,ZTSAVE("IB*")=""
. D ^%ZTLOAD,HOME^%ZIS K IO("Q") W !,"QUEUED TASK #",ZTSK
D @IBR
;
Q
HEAD(IBX,IBY) ; print header
; IBX=report name, IBY=data description for second line
; IBP is assumed for page #
N DIR,X,Y
I $E(IOST,1,2)="C-",IBP S DIR(0)="E" D ^DIR
S IBP=IBP+1
W @IOF,!,IBX,?IOM-10,"Page: ",IBP,!,IBY,! F X=1:1:IOM W "-"
W !
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXMO 4216 printed Apr 09, 2024@21:21:18 Page 2
IBARXMO ;LL/ELZ - PHARMACY COPAY CAP REPORTS ;21-JAN-2001
+1 ;;2.0;INTEGRATED BILLING;**156,261**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
CAP ; cap report entry point
+1 ; this report will produce a summary of patient's who have met or exceed their cap for the period selected. They may select either a mo/year or just a year.
+2 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+3 SET DIR(0)="D^::AEMP"
SET DIR("A")="Select a Month/Year or just a Year"
DO ^DIR
+4 if $DATA(DIRUT)
QUIT
SET IBD=+Y
+5 DO DEV("CAPDQ^IBARXMO","Medication Co-Pay Cap Report")
+6 QUIT
+7 ;
CAPDQ ; cap report processing entry
+1 NEW IBP,IBT,IBS,IBDT,IBST,IBM,IBNAM,DFN,IBAB,IBAT,IBDATA,IBTOT
KILL ^TMP("IBARXMO",$JOB)
+2 ;
+3 USE IO
+4 SET (IBP,IBAT,IBAB,IBTOT)=0
SET IBT="Patient/SSN Non-Billed Total Above Cap Patient Priority"
SET IBS=$$SITE^IBARXMU
SET IBN=IBN_" for ("_$PIECE(IBS,"^",3)_") "_$PIECE(IBS,"^",2)_" - "_$$FMTE^XLFDT(IBD)
SET IBDT=IBD-1
+5 DO HEAD(IBN,IBT)
+6 ;
+7 ; build tmp for output
+8 ; format ^tmp("ibarxmo",$j,name (last 4),dfn)=total not billed ^ at or above cap
+9 ;
+10 FOR
SET IBDT=$ORDER(^IBAM(354.7,"AC",IBDT))
if IBDT<1!($SELECT($EXTRACT(IBD,4,5)="00"&($EXTRACT(IBD,1,3)'=$EXTRACT(IBDT,1,3))
QUIT
SET IBST=0
FOR
SET IBST=$ORDER(^IBAM(354.7,"AC",IBDT,IBST))
if IBST<1
QUIT
Begin DoDot:1
+11 SET DFN=0
FOR
SET DFN=$ORDER(^IBAM(354.7,"AC",IBDT,IBST,DFN))
if DFN<1
QUIT
DO DEM^VADPT
SET IBM=0
FOR
SET IBM=$ORDER(^IBAM(354.7,"AC",IBDT,IBST,DFN,IBM))
if IBM<1
QUIT
Begin DoDot:2
+12 SET IBNAM=$EXTRACT(VADM(1),1,25)_" ("_VA("BID")_")"
SET ^TMP("IBARXMO",$JOB,IBNAM,DFN)=$GET(^TMP("IBARXMO",$JOB,IBNAM,DFN))+$PIECE(^IBAM(354.7,DFN,1,IBM,0),"^",4)_"^"_IBST
End DoDot:2
End DoDot:1
+13 ;
+14 ; now lets do some printing
+15 SET IBNAM=0
FOR
SET IBNAM=$ORDER(^TMP("IBARXMO",$JOB,IBNAM))
if IBNAM=""!($DATA(DIRUT))
QUIT
SET DFN=0
FOR
SET DFN=$ORDER(^TMP("IBARXMO",$JOB,IBNAM,DFN))
if DFN<1!($DATA(DIRUT))
QUIT
Begin DoDot:1
+16 SET IBDATA=^TMP("IBARXMO",$JOB,IBNAM,DFN)
+17 WRITE !,IBNAM,?37,$JUSTIFY($FNUMBER(+IBDATA,",",2),12),?53,$SELECT($PIECE(IBDATA,"^",2)=1:"At Cap",1:"Above Cap"),?71,$$PRIORITY^IBARXMU(DFN)
+18 SET @$SELECT($PIECE(IBDATA,"^",2)=1:"IBAT",1:"IBAB")=@$SELECT($PIECE(IBDATA,"^",2)=1:"IBAT",1:"IBAB")+1
SET IBTOT=IBTOT+IBDATA
+19 if $Y+3>IOSL
DO HEAD(IBN,IBT)
End DoDot:1
+20 ;
+21 WRITE !!,?12,"Patient Count At Cap: ",$JUSTIFY($FNUMBER(IBAT,",",0),12)
+22 WRITE !,?9,"Patient Count Above Cap: ",$JUSTIFY($FNUMBER(IBAB,",",0),12)
+23 WRITE !,?18,"Total Unbilled: ",?37,$JUSTIFY($FNUMBER(IBTOT,",",2),12)
+24 ;
+25 IF $EXTRACT(IOST,1,2)="C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
+26 ;
+27 KILL IBR,IBN,IBD,^TMP("IBARXMO",$JOB)
+28 ;
+29 DO ^%ZISC
+30 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+31 ;
+32 QUIT
NOBILL ; non-billable report entry point
+1 ; this report will produce a list of copay transaction which could not be billed (fully or partly) for the Month/Year selected.
+2 ;
+3 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+4 SET DIR(0)="D^::AEMPX"
SET DIR("A")="Select a Month/Year"
DO ^DIR
+5 if $DATA(DIRUT)
QUIT
SET IBD=+Y
+6 DO DEV("NOBILLDQ^IBARXMO","Non-Billable Copayments Report")
+7 QUIT
NOBILLDQ ; entry point to produce the non-billable report
+1 NEW IBDT,IBP,IBT,IBX,IBZ,DFN,IBS
+2 USE IO
+3 ;
+4 SET IBP=0
SET IBS=+$PIECE($$SITE^IBARXMU,"^",3)
SET IBN=IBN_" - "_$$FMTE^XLFDT(IBD)
SET IBT="Patient/SSN Rx # Date Drug Amount"
DO HEAD(IBN,IBT)
+5 ;
+6 SET IBDT=IBD
FOR
SET IBDT=$ORDER(^IBAM(354.71,"AE",IBDT))
if IBDT<1!($DATA(DIRUT))!($EXTRACT(IBDT,1,5)'=$EXTRACT(IBD,1,5))
QUIT
SET IBX=0
FOR
SET IBX=$ORDER(^IBAM(354.71,"AE",IBDT,IBX))
if IBX<1
QUIT
Begin DoDot:1
+7 SET IBZ=^IBAM(354.71,IBX,0)
SET $PIECE(IBZ,"^",12)=$PIECE($$NET^IBARXMC(IBX),"^",2)
+8 if $PIECE(IBZ,"^",12)'>0!($PIECE(IBZ,"^",10)'=IBX)!($EXTRACT(IBZ,1,3)'=IBS)
QUIT
+9 SET DFN=$PIECE(IBZ,"^",2)
DO DEM^VADPT
+10 WRITE !,$EXTRACT(VADM(1),1,25)_" ("_VA("BID")_")",?32,$PIECE($PIECE(IBZ,"^",9),"-"),?43,$$FMTE^XLFDT(IBDT),?58,$EXTRACT($PIECE($PIECE(IBZ,"^",9),"-",2),1,13),?72,$JUSTIFY($FNUMBER($PIECE(IBZ,"^",12),",",2),8)
+11 if $Y+3>IOSL
DO HEAD(IBN,IBT)
End DoDot:1
+12 ;
+13 IF $EXTRACT(IOST,1,2)="C-"
KILL DIR
SET DIR(0)="E"
DO ^DIR
+14 ;
+15 DO ^%ZISC
+16 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+17 ;
+18 QUIT
DEV(IBR,IBN) ; device selection
+1 ; IBR=routine, IBN=task name (only used of tasked)
+2 NEW %ZIS,ZTSK,ZTSAVE,POP,ZTRTN,ZTDESC
+3 SET %ZIS="MQ"
DO ^%ZIS
if POP
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET ZTRTN=IBR
SET ZTDESC=IBN
SET ZTSAVE("IB*")=""
+6 DO ^%ZTLOAD
DO HOME^%ZIS
KILL IO("Q")
WRITE !,"QUEUED TASK #",ZTSK
End DoDot:1
QUIT
+7 DO @IBR
+8 ;
+9 QUIT
HEAD(IBX,IBY) ; print header
+1 ; IBX=report name, IBY=data description for second line
+2 ; IBP is assumed for page #
+3 NEW DIR,X,Y
+4 IF $EXTRACT(IOST,1,2)="C-"
IF IBP
SET DIR(0)="E"
DO ^DIR
+5 SET IBP=IBP+1
+6 WRITE @IOF,!,IBX,?IOM-10,"Page: ",IBP,!,IBY,!
FOR X=1:1:IOM
WRITE "-"
+7 WRITE !
+8 QUIT
