Routine: IBARXMO

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")

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="@"

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")

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="@"

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

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 !

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXMO   4216     printed  Feb 18, 2025@23:34                                                                                                                                                                                                        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

IBARXMO.m