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)
Q
;
RESET ;
S (IBAB,IBANB)=0
K IBMRK,IBSLESS,IBSSITE
Q
;
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
Q
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))=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXMO1 4548 printed Oct 16, 2024@18:08:17 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
