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

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

initial load of FOIAVistA 6/30/08 version

File size: 4.0 KB
Line 
1IBARXMB ;LL/ELZ - PHARMCAY COPAY CAP BILLING FUNCTIONS ;26-APR-2001
2 ;;2.0;INTEGRATED BILLING;**156**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5BILL(IBX,IBB) ; receives information to bill for amounts not previously billed
6 ; to create bills for them on the local system, DFN is assumed
7 ; IBX = the parent transaction number to bill, IBB = the amount to bill
8 ;
9 N IBY,IBZ,IB350,IBUPDATE,IBER,Y,IBL
10 ;
11 ; find bill number
12 S IBY=+$O(^IBAM(354.71,"B",IBX,0)) Q:'IBY
13 ;
14 ; find last 354.71 entry for IBX
15 S IBL=$O(^IBAM(354.71,"AF",IBY,":"),-1) I IBL S IBY=+IBL
16 ;
17 ; get info
18 S IBZ=^IBAM(354.71,IBY,0),IB350=$G(^IB(+$P(IBZ,"^",4),0))
19 ;
20 ; is this already totally billed?
21 Q:$P($$NET^IBARXMC(IBY),"^",2)'>0
22 ;
23 ; cancel old 354.71 entry
24 S IBUPDATE=1 S IBER=$$CANCEL^IBARXMN(DFN,IBY,.IBER)
25 ;
26 ; cancel old 350 entry
27 D:IB350 CAN(DFN,+$P(IBZ,"^",4))
28 ;
29 ; create updated one
30 D ADDUP(IBY,IBB)
31 ;
32 Q
33SEND(IBX,IBB) ; receives information to bill remotely for amounts not already
34 ; billed. Makes a call to the remote system to tell them to bill
35 ; IBX = the parent transaction number to bill, IBB = the amount to bill
36 ; ia #3144
37 N IBICN,Y,DA,HLDOM,HLECH,HLFS,HLINSTN,HLNEXT,HLNODE,HLPARAM,HLQ,HLQUIT,PHONE,RPCIEN,IO,IOBS,IOCPU,IOF,IOHG,IOM,ION,IOPAR,IOUPAR,IOS,IOSL,IOST,IOT,IOXY,POP,IBD
38 D
39 . S IBICN=$$ICN^IBARXMU(DFN) Q:'IBICN
40 . D DIRECT^XWB2HL7(.IBD,+IBX,"IBARXM TRANS BILL","",IBICN,IBX,IBB)
41 Q
42CAN(DFN,IBX,IBCRES) ; cancels charge to be updated
43 ; IBX = ien from 350, IBCRES = charge cancel reason (optional)
44 ;
45 N IBZ,IBSERV,IBDUZ,IBSITE,IBFAC,IBLAST,IBPARNT,IBTYP,IBSEQNO,IBIL,IBLASTZ,IBUNIT,IBCHRG,IBNOS,IBTOTL,IBN,IBND
46 ;
47 S (IBND,IBZ)=$G(^IB(IBX,0)) Q:'IBZ
48 ;
49 S IBSERV=$$SERVICE(IBZ)
50 D ARPARM^IBAUTL
51 S:'$D(IBCRES) IBCRES=16
52 ;
53 D LAST^IBARX1 I IBLAST'=IBPARNT,$D(^IB(IBLAST,0)),$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2 Q ; already cancelled
54 ;
55 ; cancel a charge with a status of HOLD
56 I $P(IBZ,"^",5)=8 N DIE,DA,DR S DIE="^IB(",DA=IBX,DR=".05///10;.1///"_IBCRES D ^DIE Q
57 ;
58 S IBDUZ=DUZ
59 S IBPARNT=$P(IBZ,"^",9) Q:'$D(^IB(IBPARNT,0))
60 S IBATYP=$P(^IBE(350.1,$P(IBZ,"^",3),0),"^",6) ;cancellation action type
61 S IBSEQNO=$P($G(^IBE(350.1,+IBATYP,0)),"^",5) Q:'IBSEQNO
62 S IBIL=$P(IBZ,"^",11) Q:'IBIL ; no bill exists
63 S IBLASTZ=$G(^IB(+IBLAST,0))
64 S IBUNIT=$S($P(IBLASTZ,"^",6):$P(IBLASTZ,"^",6),1:$P(IBZ,"^",6))
65 S IBCHRG=$S($P(IBLASTZ,"^",7):$P(IBLASTZ,"^",7),1:$P(IBZ,"^",7))
66 S IBTOTL=IBCHRG,IBWHER=2
67 D ADD^IBAUTL I +Y<1 Q
68 ;
69 S $P(^IB(IBN,1),"^",1)=IBDUZ,$P(^IB(IBN,0),"^",2,13)=DFN_"^"_IBATYP_"^"_$P(IBND,"^",4)_"^2^"_IBUNIT_"^"_IBCHRG_"^"_$P(IBND,"^",8)_"^"_IBPARNT_"^"_IBCRES_"^"_IBIL_"^^"_IBFAC
70 K ^IB("AC",1,IBN)
71 D INDEX^IBARX1
72 S IBNOS=IBN
73 D ^IBAFIL
74 Q
75 ;
76ADDUP(IBX,IBB) ; add updated transaction, assumes DFN
77 ; IBX = example ien from 354.71 to bill, IBB = amount to bill
78 ;
79 N IBZ,IBSEQNO,IBDESC,IBCHRG,IBNOCH,IBAM,IBATYP,IBPARNT,IBN,IBDUZ,IBFAC,IBNOS,Y
80 ;
81 S IBZ=^IBAM(354.71,IBX,0),IBDUZ=$P(IBZ,"^",14)
82 D ARPARM^IBAUTL
83 ;
84 ; check exemption status
85 I +$$RXEXMT^IBARXEU0(DFN,$P(IBZ,"^",3)) Q
86 ;
87 S IBATYP=$P(IBZ,"^",18),IBATYP=$P($G(^IBE(350.1,+IBATYP,0)),"^",7)
88 S IBSEQNO=$P($G(^IBE(350.1,+IBATYP,0)),"^",5) Q:'IBSEQNO
89 S IBDESC=$P(IBZ,"^",9)
90 ;
91 S IBCHRG=IBB+$P(IBZ,"^",11),IBNOCH=$P(IBZ,"^",8)-IBCHRG
92 ;
93 S IBAM=$$ADD^IBARXMN(DFN,"^^"_$P(IBZ,"^",3)_"^^P^"_$P(IBZ,"^",6,9)_"^"_$P(IBZ,"^")_"^"_IBCHRG_"^"_IBNOCH_"^"_(+$P($$SITE^IBARXMU,"^",3)),IBATYP) I IBAM<1 Q
94 ;
95 D ADD^IBAUTL
96 S IBPARNT=$S($P(IBZ,"^",4):$P(IBZ,"^",4),1:IBN)
97 S $P(^IB(IBN,1),"^",1)=IBDUZ,$P(^IB(IBN,0),"^",2,13)=DFN_"^"_IBATYP_"^"_$P(IBZ,"^",6)_"^2^"_$P(IBZ,"^",7)_"^"_IBCHRG_"^"_IBDESC_"^"_IBPARNT_"^^^^"_IBFAC,$P(^(0),"^",19)=IBAM
98 K IBPARNT,^IB("AC",1,IBN)
99 D INDEX^IBARX1
100 S IBNOS=IBN_"^"_$G(IBNOS)
101 D ^IBAFIL
102 ;
103 ; call pso to let them know I have billed
104 ; check for pso part not installed
105 ; ia #3462
106 I $L($T(^PSOCPIB)) S Y(1)=$$NOW^XLFDT_"^"_DUZ_"^"_(+$P($P(IBZ,"^",6),":",2))_"^"_(+$P($P(IBZ,"^",6),":",3))_"^"_$S(IBNOCH:"P",1:"F")_"^"_IBN D ^PSOCPIB
107 ;
108 ;
109 Q
110 ;
111SERVICE(IBZ) ; returns service pointer
112 ; IBZ = zero node from 350
113 Q $P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^",4)
114 ;
Note: See TracBrowser for help on using the repository browser.