source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBOLK.m@ 1442

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

initial load of FOIAVistA 6/30/08 version
File size: 4.2 KB
Line 
1IBOLK ;ALB/AAS - INTEGRATED BILLING - DISPLAY BY BILL NUMBER ; 6-MAR-91
2 ;;2.0; INTEGRATED BILLING ;**199**; 21-MAR-94
3 ;
4% ;
5 ;***
6 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock
7 ;S XRTL=$ZU(0),XRTN="IBOLK-1" D T0^%ZOSV ;start rt clock
8 N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
9 S DIC("A")="Select CHARGE ID or PATIENT NAME: ",DIC="^PRCA(430,",DIC(0)="AEQM" D ^DIC K DIC G END1:+Y<1 S IBIL=$P(Y,"^",2)
10 S IBIFN=$O(^DGCR(399,"B",$P(IBIL,"-",2),0))
11 I '$D(^IB("ABIL",IBIL)),'IBIFN W !!,"Billing has no Record of this Charge ID.",! G %
12 ;
13BRIEF R !,"(B)rief or (F)ull Inquiry: B// ",X:DTIME G:X="^"!('$T) END1 S:X="" X="B" S X=$E(X)
14 I "BFbf"'[X D G BRIEF
15 . W !!?5,"Enter: '<CR>' - To select the Brief Inquiry."
16 . W !?12,"'F' - To select the Full Inquiry. This option will"
17 . W !?23,"include the Address Inquiry, and more detailed"
18 . W !?23,"information for Pharmacy Co-Pay bills."
19 . W !?12,"'^' - To quit this option.",!
20 W $S("Bb"[X:" BRIEF",1:" FULL") S IBFULL="Ff"[X
21 I IBIFN S IBAC=8,IBQUIT=0
22 ;
23DEV W ! S %ZIS="QM",%ZIS("A")="Output Device: " D ^%ZIS G:POP END
24 I $D(IO("Q")) D D ^%ZTLOAD K IO("Q") D HOME^%ZIS W ! G %
25 . S ZTDESC="IB Print Actions by Bill Number"
26 . S ZTRTN=$S(IBIFN:"VIEW^IBCNQ",1:"EN^IBOLK")
27 . S ZTSAVE("IBFULL")="",ZTSAVE("IBIL")="",ZTSAVE("IBIFN")=""
28 . I IBIFN F I="IBAC","IBQUIT" S ZTSAVE(I)=""
29 ;
30 U IO
31 ;***
32 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock
33 I 'IBIFN D EN G %
34 D VIEW^IBCNQ,Q^IBCNQ,END1 G %
35 ;
36EN ; -Entry to display IB Action data for an AR Bill number
37 ; -Input IBIL = external form of bill number, ie 500-K10001
38 ; IBFULL = 1 for full profile logic, 0 for brief description
39 ;***
40 ;S XRTL=$ZU(0),XRTN="IBOLK-2" D T0^%ZOSV ;start rt clock
41 S IBN=$O(^IB("ABIL",IBIL,"")) G:'$D(^IB(IBN,0)) ENQ
42 S IBTOTL=0,IBQUIT="",IBPAG=0 D NOW^%DTC S IBHDT=$$DAT2^IBOUTL($E(%,1,12)) D HDR
43 ;
44 S IBN="" F IBI=0:0 S IBN=$O(^IB("ABIL",IBIL,IBN)) Q:'IBN I $D(^IB(IBN,0)) D LINE Q:IBQUIT
45 I 'IBQUIT D TOTAL,PAUSE,^IBOLK1:IBFULL&('IBQUIT)
46ENQ D END Q
47 ;
48LINE ; -find data for one line, write line, accumulate totals
49 I '$D(IBTRAN),$Y>(IOSL-5) D PAUSE Q:IBQUIT D HDR1
50 S IBND=^IB(IBN,0),IBND1=$G(^(1))
51 I IBFULL,$D(^IBE(350.1,+$P(IBND,"^",3),30)) W ! S X1=$P($P($P(IBND,"^",4),";",1),":",2),X2=$P($P($P(IBND,"^",4),";",2),":",2),X=X1_"^"_$S(X2:X2,1:0) X ^(30)
52 S IBTYP=$G(^IBE(350.1,+$P(IBND,"^",3),0)),IBSEQNO=$P(IBTYP,"^",5)
53 W ! S Y=$P($P(IBND1,"^",2),".",1) D DT^DIQ
54 W ?15,$E($P($P(IBTYP,"^")," ",2,99),1,20),?37,$E($P(IBND,"^",8),1,20),?60,$J($P(IBND,"^",6),5)
55 S IBCHRG=$P(IBND,"^",7) I IBSEQNO=2 S IBCHRG=(-IBCHRG) ;cancel types are decrease adjustments
56 S X=IBCHRG,X2="2$",X3=10 D COMMA^%DTC W ?69,X
57 S IBTOTL=IBTOTL+IBCHRG
58 I $P(IBND,"^",10),IBSEQNO=2 W !,?5,"Charge Removal Reason: ",$S($D(^IBE(350.3,$P(IBND,"^",10),0)):$P(^(0),"^"),1:"UNKNOWN")
59 Q
60 ;
61HDR S IBND=^IB(IBN,0),DFN=+$P(IBND,"^",2),IBNAME=$$PT^IBEFUNC(DFN)
62HDR1 S IBPAG=IBPAG+1 I $E(IOST,1,2)["C-"!(IBPAG>1) W @IOF,*13
63 W $E($P(IBNAME,"^"),1,20)," ",$P(IBNAME,"^",2),?38,IBIL,?51,IBHDT,?72,"PAGE: ",IBPAG
64 D DISP^IBARXEU(DFN,DT,2) W !
65 W:'IBFULL !,"DATE",?15,"CHARGE TYPE",?37,"BRIEF DESCRIPTION",?62,"UNITS",?73,"CHARGE"
66 S IBLINE="",$P(IBLINE,"=",IOM)="" W !,IBLINE K IBLINE
67 Q
68 ;
69TOTAL W !?67,"------------" S X=IBTOTL,X2="2$",X3=12 D COMMA^%DTC
70 W !,?67,X
71 Q
72 ;
73PAUSE Q:$E(IOST,1,2)'["C-"
74 F IBJ=$Y:1:(IOSL-4) W !
75 S DIR(0)="E" D ^DIR K DIR I $D(DIRUT)!($D(DUOUT)) S IBQUIT=1 K DIRUT,DTOUT,DUOUT
76 Q
77 ;
78END1 K IBFULL
79END W !
80 ;***
81 ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOLK" D T1^%ZOSV ;stop rt clock
82 I $D(ZTQUEUED) S ZTREQ="@" Q
83 K X,X2,X3,Y,DFN,IBIFN,IBAC,I,IB,IBIL,IBI,IBJ,IBNAME,IBLINE,IBN,IBND,IBND1,IBCHRG,IBSEQNO,IBTYP,IBTOTL,ZTSK,IBHDT,IBPAG,IBQUIT,DN,D0,DUOUT,DTOUT,VA,VADM,VAERR
84 D ^%ZISC
85 Q
86 ;
87ENF ; -entry point for AR to print full profile for IB actions for
88 ; an ar transaction number.
89 ; -input x = ar transaction number ($p(^ib(ibn,0),u,12)
90 ;
91 S IBFULL=1
92 ;
93ENB ; -entry point for AR to print brief profile for IB actions for
94 ; an ar transaction number.
95 ; -input x = ar transaction number
96 ;
97 S IBTOTL=0,IBPAG=0,IBQUIT="" S:'$D(IBFULL) IBFULL=0
98 S IBTRAN=X
99 S IBN="" F S IBN=$O(^IB("AT",IBTRAN,IBN)) Q:IBN="" D LINE
100 K D0,DN,X,X2,X3,Y,IBFULL,IBTOTL,IBPAG,IBQUIT,IBTRAN,IBN,IBND,IBND1,IBSEQNO,IBTYP,IBCHRG
101 Q
Note: See TracBrowser for help on using the repository browser.