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

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

initial load of FOIAVistA 6/30/08 version
File size: 4.0 KB
Line 
1IBCF3P ;ALB/BGA -UB92 HCFA-1450 (print data ) ;7-SEPT-93
2 ;;Version 2.0 ; INTEGRATED BILLING ;**8,52**; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;
6EN ;This routine prints out the bill from the data gathered in
7 ;routines IBCF3,IBCF31, and IBCF32
8 S IBPGS=1,IBRM=$S($G(IOM)>80:1,1:0)
9 ;
100 W IBFL(0,"SR"),?34,IBFL(0,"ZBILL")
111 W !,$E(IBFL(1,"PROVL1"),1,25),?26,IBFL(2,1)
12 W !,$E(IBFL(1,"PROVL2"),1,25),?26,IBFL(2,2),?57,$E(IBFL(3),1,20),?(77+IBRM),IBFL(4)
13 W !,$E(IBFL(1,"PROVL3"),1,25),?(68+IBRM),IBFL(11,1)
14 W !,$E(IBFL(1,"PROVL4"),1,25),?26,$E(IBFL(5),1,10),?37,IBFL(6,"FROM"),?44,IBFL(6,"TO"),?51,IBFL(7),?55,IBFL(8),?(67+IBRM),IBFL(11,2)
15 W !
16 W !,$E(IBFL(12),1,30),?31,$E(IBFL(13),1,49)
17 W !,?(75+IBRM),IBFL(31,1)
18 W !,IBFL(14),?9,IBFL(15),?12,IBFL(16),?14,IBFL(17),?21,IBFL(18),?25,IBFL(19),?28,IBFL(20),?30,IBFL(21),?33,IBFL(22),?36,$E(IBFL(23),1,17)
19CC ;
20 I +IBFL(24) S IBC=54,IBX=$P(IBFL(24),U,2) F IBI=1:1:7 S IBX=$O(IBFL(24,IBX)) Q:'IBX D
21 . W ?IBC,IBFL(24,IBX) S IBC=IBC+3 S $P(IBFL(24),U,1)=$P(IBFL(24),U,1)-1,$P(IBFL(24),U,2)=IBX
22 W ?(74+IBRM),IBFL(31,2)
23 W !,?(57+IBRM),IBFL(37,1)
24 ;W !
25OC ;
26 F IBJ=2,3 S IBC=0 W ! D
27 . F IBI=32,33,34,35 S IBX=+IBFL(IBI) D S IBC=IBC+10
28 .. Q:+IBX'>0 S IBX=$P(IBFL(IBI),U,2)+1,IBY=$G(IBFL(IBI,+IBX)) W ?IBC,$P(IBY,U,1),?(IBC+3),$P(IBY,U,2)
29 .. S $P(IBFL(IBI),U,1)=+IBFL(IBI)-1,$P(IBFL(IBI),U,2)=+IBX
30 . S IBI=36,IBX=+IBFL(IBI) I +IBX>0 D
31 .. S IBX=$P(IBFL(IBI),U,2)+1,IBY=$G(IBFL(IBI,+IBX)) W ?40,$P(IBY,U,1),?43,$P(IBY,U,2),?50,$P(IBY,U,3)
32 .. S $P(IBFL(IBI),U,1)=+IBFL(IBI)-1,$P(IBFL(IBI),U,2)=+IBX
33 . W ?(57+IBRM),$G(IBFL(37,IBJ))
34 ;
35 ;
3638 ;responsible party name/address and value codes
37 S IB38C1=+$P(IBSIGN,U,31),IB38C2=42-IB38C1
38 F IBI=1:1:5 W !,?IB38C1,$E($G(IBFL(38,IBI)),1,IB38C2) I IBI>1,+IBFL(39) D
39 . S IBX=$P(IBFL(39),U,2) F IBJ=1:1:3 S IBX=$O(IBFL(39,IBX)) Q:'IBX D
40 .. S IBVCCOL=8 I +$P(IBFL(39,IBX),U,3) S IBVCCOL=10 I IBJ=3,$G(IOM)'>80 S IBVCCOL=9
41 .. S IBC=(30+(13*IBJ)) W ?IBC,$P(IBFL(39,IBX),U,1),?(IBC+2),$J($P(IBFL(39,IBX),U,2),IBVCCOL)
42 .. S $P(IBFL(39),U,1)=$P(IBFL(39),U,1)-1,$P(IBFL(39),U,2)=IBX
43 W ! K IB38C1,IB38C2,IBVCCOL
44 ;
4542 ;Rev Codes
46 S IBX=$G(^TMP($J,"IBC-RC")) I +IBX S IBX=$P(IBX,U,2) F IBI=1:1:23 S IBX=$O(^TMP($J,"IBC-RC",IBX)) Q:'IBX D
47 . S $P(^TMP($J,"IBC-RC"),U,1)=+$P(^TMP($J,"IBC-RC"),U,1)-1,$P(^TMP($J,"IBC-RC"),U,2)=IBX
48 . S IBY=^TMP($J,"IBC-RC",IBX) I +IBY>1 W !,?($S(+IBY=3:5,1:0)),$E($P(IBY,U,2),1,76) Q
49 . W !,$P(IBY,U,2),?5,$E($P(IBY,U,3),1,24),?30,$P(IBY,U,4)
50 . I +$P(IBY,U,5) W:$P(IBY,U,4)'="" "/"_$J($P(IBY,U,5),0,2) I $P(IBY,U,4)="" W $J($P(IBY,U,5),7,2)
51 . W ?48,$P(IBY,U,6) I $P(IBY,U,7)'="" W ?53,$J($P(IBY,U,7),11,2)
52 . I $P(IBY,U,8) W ?66,$J($P(IBY,U,8),10,2)
53 ;
54 ;Payer
55 W !,?(67+IBRM),IBFL(56,1)
5650 F IBI=1:1:3 D
57 . W !,$E($G(IBFL(50,IBI)),1,25),?26,$E($G(IBFL(51,IBI)),1,13),?40,$G(IBFL(52,IBI)),?43,$G(IBFL(53,IBI)),?45,$S($D(^DGCR(399,IBIFN,"I"_IBI)):$J(IBFL(54,IBI),10,2),1:""),?(66+IBRM),IBFL(56,(IBI+1))
58 W !,?1,IBFL(57),?(66+IBRM),IBFL(56,5)
5958 W ! F IBI=1:1:3 D
60 . W !,$E($G(IBFL(58,IBI)),1,25),?26,$G(IBFL(59,IBI)),?29,$E($G(IBFL(60,IBI)),1,19),?49,$E($G(IBFL(61,IBI)),1,14),?64,$E($G(IBFL(62,IBI)),1,16)
6163 W ! F IBI=1:1:3 D
62 . W !,$E($G(IBFL(63,IBI)),1,18),?19,$G(IBFL(64,IBI)),?21,$E($G(IBFL(65,IBI)),1,24),?46,$E($G(IBFL(66,IBI)),1,34)
63 ;
6467 ;field locators 67-71 and 76,78
65 W !,?(78+IBRM),IBFL(78,1)
66 W ! S IBC=0 F IBI=1:1:9 W ?IBC,$G(IBFL(66+IBI)) S IBC=IBC+7
67 W ?64,$E($G(IBFL(76)),1,6),?(77+IBRM),IBFL(78,2)
68 W !
6979 ;field locators 80-83
70 W !,IBFL(79) S IBC=3 F IBI=1:1:3 W ?IBC,$P($G(IBFL(80,IBI)),U,1),?(IBC+8),$P($G(IBFL(80,IBI)),U,2) S IBC=IBC+15
71 W ?50,$E($G(IBFL(82)),1,30)
72 W !!
73 S IBC=3 F IBI=4:1:6 W ?IBC,$P($G(IBFL(80,IBI)),U,1),?(IBC+8),$P($G(IBFL(80,IBI)),U,2) S IBC=IBC+15
74 W ?50,$E($G(IBFL(83)),1,30)
7584 ;remarks field locator 84
76 W !,?7,$E(IBFL(84,1),1,27),?35,"(PAGE ",IBPGS," OF ",IBPG,")" S IBI=1 F S IBI=$O(IBFL(84,IBI)) Q:'IBI W !,$E($G(IBFL(84,IBI)),1,48)
77 W ?50,$E($G(IBFL(85,1)),1,22),?74,$G(IBFL(86)),!,?50,$E($G(IBFL(85,2)),1,22)
78 I IBPGS<IBPG S IBPGS=IBPGS+1 W @IOF G 0
79 K IBPGS,IBC,IBRM
80 Q
Note: See TracBrowser for help on using the repository browser.