source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBARXMO1.m@ 1766

Last change on this file since 1766 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.3 KB
Line 
1IBARXMO1 ;LEX/WRC - PHARMACY CO-PAY CAP ;10/23/03
2 ;;2.0;INTEGRATED BILLING;**259**;21-MAR-94
3 ;
4CALDT ;
5 ;set dates min/max and calendar year
6 S IBMIN=3011231
7 D NOW^%DTC S IBCENYR=$E(X,1,3),IBCENYR=IBCENYR-1,IBMAX=IBCENYR_1231
8 S DIR(0)="DOA^"_IBMIN_":"_IBMAX_":AEP^K:X'?2.4N X",DIR("A")="Enter the Two or Four Digit Calendar Year: "
9 D ^DIR K DIR
10 I Y<1 D KIL Q
11 S IBCENYR=$E(Y,1,3),IBSMYR=IBCENYR_"0100",IBEMYR=IBCENYR_1231
12 ;
13ZIS S %IS="Q" D ^%ZIS
14 K %H,%T I POP=1 D KIL Q
15 I '$D(IO("Q")) U IO D STRT Q
16 S ZTRTN="STRT^IBARXMO1",ZTIO=ION,ZTSAVE("IBSMYR")="",ZTSAVE("IBEMYR")=""
17 D ^%ZTLOAD
18 W:$D(ZTSK) !,"Request Queued!",!,"Task Number: "_ZTSK,!
19 D KIL Q
20 ;
21STRT ;
22 ;-set the annual billing cap in variable IBY
23 S IBD=IBEMYR,IBP=2 D CAP^IBARXMC(IBD,IBP,.IBM,.IBY,.IBF,.IBT)
24 S IBSITE=$P($$SITE^VASITE,"^",3) ;get the site's station number
25 S (IBTNBOC,IBTV,IBTVC,IBAB,IBANB,IBA5,IBB5,IBA3)=0
26 S IBDFN=0
27 F S IBDFN=$O(^IBAM(354.71,"AD",IBDFN)) Q:'IBDFN D
28 . S IBP=$$PRIORITY^IBARXMU(IBDFN)
29 . I IBP<2!(IBP>6) Q
30 . D IB350R
31 . S IBTRDT=IBSMYR-1,IBTIEN=""
32 . F S IBTRDT=$O(^IBAM(354.71,"AD",IBDFN,IBTRDT)) Q:IBTRDT=""!(IBTRDT>IBEMYR)!($D(IBSLESS)) D
33 .. F S IBTIEN=$O(^IBAM(354.71,"AD",IBDFN,IBTRDT,IBTIEN)) Q:IBTIEN="" D
34 ... S IBTREC=$G(^IBAM(354.71,IBTIEN,0))
35 ... I $P(IBTREC,"^",4)'="",($D(^TMP("IBARXMO1",$J,$P(IBTREC,"^",4)))) Q ;ignore charge because "co-pay" cancellation (status=11) not in 354.71
36 ... S IBTSTA=$E($P(IBTREC,"^",1),1,3) ;get the orginating station
37 ... I IBTSTA<+IBSITE S IBSLESS=1 Q ;if the vet was billed at a 'lesser site', don't count him here
38 ... I IBTSTA=+IBSITE S IBSSITE=1 ;vet was billed at this site, so vet can be counted at this site
39 ... S IBAB=IBAB+$P(IBTREC,"^",11) ;increment the total amount billed to the vet
40 ... 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
41 ... S IBANB=IBANB+$P(IBTREC,"^",12) ;increment the total amount not billed
42 . I $D(IBSLESS) D RESET Q ;vet to be counted at the 'lesser site'
43 . I '$D(IBSSITE) D RESET Q ;vet wasn't billed here at least once in the timeframe
44 . I IBAB<.01 D RESET Q ;vet wasn't billed
45 . S IBTNBOC=IBTNBOC+IBANB ;increment 'Amount Above Cap'
46 . S IBTV=IBTV+1 ;increment 'Veterans Billed the Co-payment'
47 . I IBAB<IBY D D RESET Q ;if vet didn't reach the cap
48 .. S IBA5=IBA5+IBAB ;increment the amounts billed to vets not reaching cap
49 .. S IBB5=IBB5+1 ;increment # vets not reaching cap
50 . 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
51 . S IBTVC=IBTVC+1 ;increment 'Veterans Reaching the Cap'
52 . D RESET
53 S IBAVGD=$S('IBTVC:0,1:IBA3/IBTVC) ;calculate 'Average Days Reaching Cap'
54 S IBAVGBUC=$S('IBB5:0,1:IBA5/IBB5) ;calculate 'Average Billed to Those Not Reaching Cap'
55 D PRINT
56 ;
57KIL I $D(ZTQUEUED) S ZTREQ="@"
58 E D ^%ZISC
59 ;
60 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
61 K DIR,POP,IBF,IBMIN,IBMAX,IBCENYR,IB350STD,IB350IEN,IB350R,X1,X2,X3,ZTIO,ZTQUEUED,ZTRTN,ZTSAVE,ZTSK
62 K ^TMP("IBARXMO1",$J)
63 Q
64 ;
65RESET ;
66 S (IBAB,IBANB)=0
67 K IBMRK,IBSLESS,IBSSITE
68 Q
69 ;
70PRINT ;
71 I $E(IOST,1,2)="C-" W @IOF,*13
72 S IBSMYR=$E(IBSMYR,1,5)_"01"
73 S Y=IBSMYR D DD^%DT S IBPSMYR=Y
74 S Y=IBEMYR D DD^%DT S IBPEMYR=Y
75 W !,?26,"FACILITY PHARMACY CO-PAY CAP"
76 W !,?32,"SUMMARY REPORT"
77 W !,?23,IBPSMYR," THROUGH ",IBPEMYR
78 D NOW^%DTC S Y=X D DD^%DT W !,?29,"RUN DATE: ",Y,!!
79 W !,"Total Vets Billed:" S X=IBTV,X2=0,X3=20 D COMMA^%DTC W ?50,X
80 W !,"Total Vets At or Above the Cap:" S X=IBTVC,X2=0,X3=20 D COMMA^%DTC W ?50,X
81 W !,"Average Number of Days to Reach Cap:" S X=IBAVGD,X2=0,X3=20 D COMMA^%DTC W ?50,X
82 W !,"Average Amount Charged to Those Not Reaching Cap:" S X=IBAVGBUC,X2="2$",X3=20 D COMMA^%DTC W ?50,X
83 W !,"Potential Billable Amount:" S X=IBTNBOC,X2="2$",X3=20 D COMMA^%DTC W ?50,X
84 I $E(IOST,1,2)="C-" W !! S DIR(0)="E" D ^DIR
85 Q
86IB350R ;
87 ;build array of "co-pay" cancellations (status=11) not in 354.71
88 ;
89 K ^TMP("IBARXMO1",$J)
90 S IB350STD=IBSMYR
91 F S IB350STD=$O(^IB("APTDT",IBDFN,IB350STD)) Q:IB350STD=""!(IB350STD>IBEMYR) D
92 . S IB350IEN=""
93 . F S IB350IEN=$O(^IB("APTDT",IBDFN,IB350STD,IB350IEN)) Q:'IB350IEN D
94 .. S IB350R=$G(^IB(IB350IEN,0))
95 .. I $P(IB350R,"^",5)'=11 Q
96 .. I $P(IB350R,"^",9)'="" S ^TMP("IBARXMO1",$J,$P(IB350R,"^",9))=""
97 Q
Note: See TracBrowser for help on using the repository browser.