Routine: IBARXMO1

IBARXMO1 ;LEX/WRC - PHARMACY CO-PAY CAP ;10/23/03

 ;;2.0;INTEGRATED BILLING;**259**;21-MAR-94

CALDT ;

 ;set dates min/max and calendar year

 S IBMIN=3011231

 D NOW^%DTC S IBCENYR=$E(X,1,3),IBCENYR=IBCENYR-1,IBMAX=IBCENYR_1231

 S DIR(0)="DOA^"_IBMIN_":"_IBMAX_":AEP^K:X'?2.4N X",DIR("A")="Enter the Two or Four Digit Calendar Year: "

 D ^DIR K DIR

 I Y<1 D KIL Q

 S IBCENYR=$E(Y,1,3),IBSMYR=IBCENYR_"0100",IBEMYR=IBCENYR_1231

ZIS S %IS="Q" D ^%ZIS

 K %H,%T I POP=1 D KIL Q

 I '$D(IO("Q")) U IO D STRT Q

 S ZTRTN="STRT^IBARXMO1",ZTIO=ION,ZTSAVE("IBSMYR")="",ZTSAVE("IBEMYR")=""

 D ^%ZTLOAD

 W:$D(ZTSK) !,"Request Queued!",!,"Task Number: "_ZTSK,!

 D KIL Q

STRT ;

 ;-set the annual billing cap in variable IBY

 S IBD=IBEMYR,IBP=2 D CAP^IBARXMC(IBD,IBP,.IBM,.IBY,.IBF,.IBT)

 S IBSITE=$P($$SITE^VASITE,"^",3) ;get the site's station number

 S (IBTNBOC,IBTV,IBTVC,IBAB,IBANB,IBA5,IBB5,IBA3)=0

 S IBDFN=0

 F  S IBDFN=$O(^IBAM(354.71,"AD",IBDFN)) Q:'IBDFN  D

 . S IBP=$$PRIORITY^IBARXMU(IBDFN)

 . I IBP<2!(IBP>6) Q

 . D IB350R

 . S IBTRDT=IBSMYR-1,IBTIEN=""

 . F  S IBTRDT=$O(^IBAM(354.71,"AD",IBDFN,IBTRDT)) Q:IBTRDT=""!(IBTRDT>IBEMYR)!($D(IBSLESS))  D

 .. F  S IBTIEN=$O(^IBAM(354.71,"AD",IBDFN,IBTRDT,IBTIEN)) Q:IBTIEN=""  D

 ... S IBTREC=$G(^IBAM(354.71,IBTIEN,0))

 ... I $P(IBTREC,"^",4)'="",($D(^TMP("IBARXMO1",$J,$P(IBTREC,"^",4)))) Q  ;ignore charge because "co-pay" cancellation (status=11) not in 354.71

 ... S IBTSTA=$E($P(IBTREC,"^",1),1,3) ;get the orginating station

 ... I IBTSTA<+IBSITE S IBSLESS=1 Q  ;if the vet was billed at a 'lesser site', don't count him here

 ... I IBTSTA=+IBSITE S IBSSITE=1 ;vet was billed at this site, so vet can be counted at this site

 ... S IBAB=IBAB+$P(IBTREC,"^",11) ;increment the total amount billed to the vet

 ... I IBAB=IBY!(IBAB>IBY),('$D(IBMRK)) S IBMRK=$P(IBTREC,"^",3) ;if the vet hit or exceeded the cap for the first time, set the date that occurred

 ... S IBANB=IBANB+$P(IBTREC,"^",12) ;increment the total amount not billed

 . I $D(IBSLESS) D RESET Q  ;vet to be counted at the 'lesser site'

 . I '$D(IBSSITE) D RESET Q  ;vet wasn't billed here at least once in the timeframe

 . I IBAB<.01 D RESET Q  ;vet wasn't billed

 . S IBTNBOC=IBTNBOC+IBANB ;increment 'Amount Above Cap'

 . S IBTV=IBTV+1 ;increment 'Veterans Billed the Co-payment'

 . I IBAB<IBY D  D RESET Q  ;if vet didn't reach the cap

 .. S IBA5=IBA5+IBAB ;increment the amounts billed to vets not reaching cap

 .. S IBB5=IBB5+1 ;increment # vets not reaching cap

 . I $D(IBMRK) S X1=IBMRK,X2=IBSMYR D ^%DTC S IBA3=IBA3+X ;calculate running total of time rquired by vet to reach the cap

 . S IBTVC=IBTVC+1 ;increment 'Veterans Reaching the Cap'

 . D RESET

 S IBAVGD=$S('IBTVC:0,1:IBA3/IBTVC) ;calculate 'Average Days Reaching Cap'

 S IBAVGBUC=$S('IBB5:0,1:IBA5/IBB5) ;calculate 'Average Billed to Those Not Reaching Cap'

 D PRINT

KIL I $D(ZTQUEUED) S ZTREQ="@"

 E  D ^%ZISC

 K %DT,IBSMYR,Y,IBEMYR,%IS,IBD,IBP,IBM,IBY,IBT,IBSITE,IBTNBOC,IBTV,IBTVC,IBAB,IBANB,IBA5,IBB5,IBA3,IBDFN,IBMRK,IBAVGD,IBAVGBUC,IBTRDT,IBTIEN,IBTREC,IBTSTA,X,IBPSMYR,IBPEMYR

 K DIR,POP,IBF,IBMIN,IBMAX,IBCENYR,IB350STD,IB350IEN,IB350R,X1,X2,X3,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE,ZTSK

 K ^TMP("IBARXMO1",$J)

RESET ;

 S (IBAB,IBANB)=0

 K IBMRK,IBSLESS,IBSSITE

PRINT ;

 I $E(IOST,1,2)="C-" W @IOF,*13

 S IBSMYR=$E(IBSMYR,1,5)_"01"

 S Y=IBSMYR D DD^%DT S IBPSMYR=Y

 S Y=IBEMYR D DD^%DT S IBPEMYR=Y

 W !,?26,"FACILITY PHARMACY CO-PAY CAP"

 W !,?32,"SUMMARY REPORT"

 W !,?23,IBPSMYR," THROUGH ",IBPEMYR

 D NOW^%DTC S Y=X D DD^%DT W !,?29,"RUN DATE: ",Y,!!

 W !,"Total Vets Billed:" S X=IBTV,X2=0,X3=20 D COMMA^%DTC W ?50,X

 W !,"Total Vets At or Above the Cap:" S X=IBTVC,X2=0,X3=20 D COMMA^%DTC W ?50,X

 W !,"Average Number of Days to Reach Cap:" S X=IBAVGD,X2=0,X3=20 D COMMA^%DTC W ?50,X

 W !,"Average Amount Charged to Those Not Reaching Cap:" S X=IBAVGBUC,X2="2$",X3=20 D COMMA^%DTC W ?50,X

 W !,"Potential Billable Amount:" S X=IBTNBOC,X2="2$",X3=20 D COMMA^%DTC W ?50,X

 I $E(IOST,1,2)="C-" W !! S DIR(0)="E" D ^DIR

IB350R ;

 ;build array of "co-pay" cancellations (status=11) not in 354.71

 K ^TMP("IBARXMO1",$J)

 S IB350STD=IBSMYR

 F  S IB350STD=$O(^IB("APTDT",IBDFN,IB350STD)) Q:IB350STD=""!(IB350STD>IBEMYR)  D

 . S IB350IEN=""

 . F  S IB350IEN=$O(^IB("APTDT",IBDFN,IB350STD,IB350IEN)) Q:'IB350IEN  D

 .. S IB350R=$G(^IB(IB350IEN,0))

 .. I $P(IB350R,"^",5)'=11 Q

 .. I $P(IB350R,"^",9)'="" S ^TMP("IBARXMO1",$J,$P(IB350R,"^",9))=""

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXMO1   4548     printed  Feb 18, 2025@23:34:01                                                                                                                                                                                                    Page 2

IBARXMO1  ;LEX/WRC - PHARMACY CO-PAY CAP ;10/23/03

 +1       ;;2.0;INTEGRATED BILLING;**259**;21-MAR-94

 +2       ;

CALDT     ;

 +1       ;set dates min/max and calendar year

 +2        SET IBMIN=3011231

 +3        DO NOW^%DTC

           SET IBCENYR=$EXTRACT(X,1,3)

           SET IBCENYR=IBCENYR-1

           SET IBMAX=IBCENYR_1231

 +4        SET DIR(0)="DOA^"_IBMIN_":"_IBMAX_":AEP^K:X'?2.4N X"

           SET DIR("A")="Enter the Two or Four Digit Calendar Year: "

 +5        DO ^DIR

           KILL DIR

 +6        IF Y<1

               DO KIL

               QUIT

 +7        SET IBCENYR=$EXTRACT(Y,1,3)

           SET IBSMYR=IBCENYR_"0100"

           SET IBEMYR=IBCENYR_1231

 +8       ;

ZIS        SET %IS="Q"

           DO ^%ZIS

 +1        KILL %H,%T

           IF POP=1

               DO KIL

               QUIT

 +2        IF '$DATA(IO("Q"))

               USE IO

               DO STRT

               QUIT

 +3        SET ZTRTN="STRT^IBARXMO1"

           SET ZTIO=ION

           SET ZTSAVE("IBSMYR")=""

           SET ZTSAVE("IBEMYR")=""

 +4        DO ^%ZTLOAD

 +5        if $DATA(ZTSK)

               WRITE !,"Request Queued!",!,"Task Number: "_ZTSK,!

 +6        DO KIL

           QUIT

 +7       ;

STRT      ;

 +1       ;-set the annual billing cap in variable IBY

 +2        SET IBD=IBEMYR

           SET IBP=2

           DO CAP^IBARXMC(IBD,IBP,.IBM,.IBY,.IBF,.IBT)

 +3       ;get the site's station number

           SET IBSITE=$PIECE($$SITE^VASITE,"^",3)

 +4        SET (IBTNBOC,IBTV,IBTVC,IBAB,IBANB,IBA5,IBB5,IBA3)=0

 +5        SET IBDFN=0

 +6        FOR

               SET IBDFN=$ORDER(^IBAM(354.71,"AD",IBDFN))

               if 'IBDFN

                   QUIT

               Begin DoDot:1

 +7                SET IBP=$$PRIORITY^IBARXMU(IBDFN)

 +8                IF IBP<2!(IBP>6)

                       QUIT

 +9                DO IB350R

 +10               SET IBTRDT=IBSMYR-1

                   SET IBTIEN=""

 +11               FOR

                       SET IBTRDT=$ORDER(^IBAM(354.71,"AD",IBDFN,IBTRDT))

                       if IBTRDT=""!(IBTRDT>IBEMYR)!($DATA(IBSLESS))

                           QUIT

                       Begin DoDot:2

 +12                       FOR

                               SET IBTIEN=$ORDER(^IBAM(354.71,"AD",IBDFN,IBTRDT,IBTIEN))

                               if IBTIEN=""

                                   QUIT

                               Begin DoDot:3

 +13                               SET IBTREC=$GET(^IBAM(354.71,IBTIEN,0))

 +14      ;ignore charge because "co-pay" cancellation (status=11) not in 354.71

                                   IF $PIECE(IBTREC,"^",4)'=""

                                       IF ($DATA(^TMP("IBARXMO1",$JOB,$PIECE(IBTREC,"^",4))))

                                           QUIT

 +15      ;get the orginating station

                                   SET IBTSTA=$EXTRACT($PIECE(IBTREC,"^",1),1,3)

 +16      ;if the vet was billed at a 'lesser site', don't count him here

                                   IF IBTSTA<+IBSITE

                                       SET IBSLESS=1

                                       QUIT

 +17      ;vet was billed at this site, so vet can be counted at this site

                                   IF IBTSTA=+IBSITE

                                       SET IBSSITE=1

 +18      ;increment the total amount billed to the vet

                                   SET IBAB=IBAB+$PIECE(IBTREC,"^",11)

 +19      ;if the vet hit or exceeded the cap for the first time, set the date that occurred

                                   IF IBAB=IBY!(IBAB>IBY)

                                       IF ('$DATA(IBMRK))

                                           SET IBMRK=$PIECE(IBTREC,"^",3)

 +20      ;increment the total amount not billed

                                   SET IBANB=IBANB+$PIECE(IBTREC,"^",12)

                               End DoDot:3

                       End DoDot:2

 +21      ;vet to be counted at the 'lesser site'

                   IF $DATA(IBSLESS)

                       DO RESET

                       QUIT

 +22      ;vet wasn't billed here at least once in the timeframe

                   IF '$DATA(IBSSITE)

                       DO RESET

                       QUIT

 +23      ;vet wasn't billed

                   IF IBAB<.01

                       DO RESET

                       QUIT

 +24      ;increment 'Amount Above Cap'

                   SET IBTNBOC=IBTNBOC+IBANB

 +25      ;increment 'Veterans Billed the Co-payment'

                   SET IBTV=IBTV+1

 +26      ;if vet didn't reach the cap

                   IF IBAB<IBY

                       Begin DoDot:2

 +27      ;increment the amounts billed to vets not reaching cap

                           SET IBA5=IBA5+IBAB

 +28      ;increment # vets not reaching cap

                           SET IBB5=IBB5+1

                       End DoDot:2

                       DO RESET

                       QUIT

 +29      ;calculate running total of time rquired by vet to reach the cap

                   IF $DATA(IBMRK)

                       SET X1=IBMRK

                       SET X2=IBSMYR

                       DO ^%DTC

                       SET IBA3=IBA3+X

 +30      ;increment 'Veterans Reaching the Cap'

                   SET IBTVC=IBTVC+1

 +31               DO RESET

               End DoDot:1

 +32      ;calculate 'Average Days Reaching Cap'

           SET IBAVGD=$SELECT('IBTVC:0,1:IBA3/IBTVC)

 +33      ;calculate 'Average Billed to Those Not Reaching Cap'

           SET IBAVGBUC=$SELECT('IBB5:0,1:IBA5/IBB5)

 +34       DO PRINT

 +35      ;

KIL        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +1       IF '$TEST

               DO ^%ZISC

 +2       ;

 +3        KILL %DT,IBSMYR,Y,IBEMYR,%IS,IBD,IBP,IBM,IBY,IBT,IBSITE,IBTNBOC,IBTV,IBTVC,IBAB,IBANB,IBA5,IBB5,IBA3,IBDFN,IBMRK,IBAVGD,IBAVGBUC,IBTRDT,IBTIEN,IBTREC,IBTSTA,X,IBPSMYR,IBPEMYR

 +4        KILL DIR,POP,IBF,IBMIN,IBMAX,IBCENYR,IB350STD,IB350IEN,IB350R,X1,X2,X3,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE,ZTSK

 +5        KILL ^TMP("IBARXMO1",$JOB)

 +6        QUIT

 +7       ;

RESET     ;

 +1        SET (IBAB,IBANB)=0

 +2        KILL IBMRK,IBSLESS,IBSSITE

 +3        QUIT

 +4       ;

PRINT     ;

 +1        IF $EXTRACT(IOST,1,2)="C-"

               WRITE @IOF,*13

 +2        SET IBSMYR=$EXTRACT(IBSMYR,1,5)_"01"

 +3        SET Y=IBSMYR

           DO DD^%DT

           SET IBPSMYR=Y

 +4        SET Y=IBEMYR

           DO DD^%DT

           SET IBPEMYR=Y

 +5        WRITE !,?26,"FACILITY PHARMACY CO-PAY CAP"

 +6        WRITE !,?32,"SUMMARY REPORT"

 +7        WRITE !,?23,IBPSMYR," THROUGH ",IBPEMYR

 +8        DO NOW^%DTC

           SET Y=X

           DO DD^%DT

           WRITE !,?29,"RUN DATE: ",Y,!!

 +9        WRITE !,"Total Vets Billed:"

           SET X=IBTV

           SET X2=0

           SET X3=20

           DO COMMA^%DTC

           WRITE ?50,X

 +10       WRITE !,"Total Vets At or Above the Cap:"

           SET X=IBTVC

           SET X2=0

           SET X3=20

           DO COMMA^%DTC

           WRITE ?50,X

 +11       WRITE !,"Average Number of Days to Reach Cap:"

           SET X=IBAVGD

           SET X2=0

           SET X3=20

           DO COMMA^%DTC

           WRITE ?50,X

 +12       WRITE !,"Average Amount Charged to Those Not Reaching Cap:"

           SET X=IBAVGBUC

           SET X2="2$"

           SET X3=20

           DO COMMA^%DTC

           WRITE ?50,X

 +13       WRITE !,"Potential Billable Amount:"

           SET X=IBTNBOC

           SET X2="2$"

           SET X3=20

           DO COMMA^%DTC

           WRITE ?50,X

 +14       IF $EXTRACT(IOST,1,2)="C-"

               WRITE !!

               SET DIR(0)="E"

               DO ^DIR

 +15       QUIT

IB350R    ;

 +1       ;build array of "co-pay" cancellations (status=11) not in 354.71

 +2       ;

 +3        KILL ^TMP("IBARXMO1",$JOB)

 +4        SET IB350STD=IBSMYR

 +5        FOR

               SET IB350STD=$ORDER(^IB("APTDT",IBDFN,IB350STD))

               if IB350STD=""!(IB350STD>IBEMYR)

                   QUIT

               Begin DoDot:1

 +6                SET IB350IEN=""

 +7                FOR

                       SET IB350IEN=$ORDER(^IB("APTDT",IBDFN,IB350STD,IB350IEN))

                       if 'IB350IEN

                           QUIT

                       Begin DoDot:2

 +8                        SET IB350R=$GET(^IB(IB350IEN,0))

 +9                        IF $PIECE(IB350R,"^",5)'=11

                               QUIT

 +10                       IF $PIECE(IB350R,"^",9)'=""

                               SET ^TMP("IBARXMO1",$JOB,$PIECE(IB350R,"^",9))=""

                       End DoDot:2

               End DoDot:1

 +11       QUIT

IBARXMO1.m