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

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

initial load of WorldVistAEHR

File size: 4.4 KB
Line 
1IBR ;ALB/AAS - INTEGRATED BILLING - A/R INTERFACE ;25-FEB-91
2V ;;2.0;INTEGRATED BILLING;**52,70,93,113,132,51**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; - handles calls to AR
6 ; - input IBSEQNO = 1,2, or 3
7 ; - IBDUZ = user causing entry
8 ; - IBNOS = IBnumber^Ibnumber... to process
9 ; - DFN = patient number
10 ; - output Y = 1 if successful
11 ; - =-1^error code if unsuccessful
12 S IBERR=""
13 I '$D(IBSEQNO) S IBERR="IB017;"_IBERR G END
14 D @IBSEQNO
15 G END
16 ;
171 ; -pass new entries to a/r
18 S IBTOTL=0 N IBNOW
19 F I=1:1 S IBN=$P(IBNOS,"^",I) Q:'IBN S X=$S($D(^IB(IBN,0)):^(0),1:"") S:X="" IBERR="IB018;"_IBERR D TRCHK S IBTOTL=IBTOTL+$P(X,"^",7)
20 Q:IBNOS=""!(IBTOTL<1)
21 S IBSERV="",IBATYP=$P(X,"^",3) I $D(^IBE(350.1,+IBATYP,0)) S IBSERV=$P(^(0),"^",4)
22 D ARPARM^IBAUTL
23 S IBWHER=3
24 D BILLNO^IBAUTL I +Y<1 G ERR
25 S IBWHER=4
26 ;
27 F I=1:1 S IBN=$P(IBNOS,"^",I) Q:'IBN D UP1,UP3:IBSEQNO=3
28 Q
29UP1 ; -update IB data and reindex
30 N DIERR
31 S FDA(350,IBN_",",.05)=$S(IBERR="":3,1:9)
32 S FDA(350,IBN_",",.11)=IBIL
33 S FDA(350,IBN_",",.12)=IBTRAN
34 D FILE^DIE("K","FDA")
35 I $G(DIERR) S IBERR="IB020;"_IBERR
36 ;S DIE="^IB(",DA=IBN,DR=".05////"_$S(IBERR="":3,1:9)_";.11////"_IBIL_";.12////"_IBTRAN
37 ;D ^DIE K DIE,DR,DA
38 ;I $D(Y) S IBERR="IB020;"_IBERR
39 ;S DA=IBN,DIK="^IB(" D IX^DIK
40 ;K DIK,DA
41 Q
422 S IBTOTL=0 N IBNOW
43 F I=1:1 S IBN=$P(IBNOS,"^",I) Q:'IBN S X=$S($D(^IB(IBN,0)):^(0),1:"") S:X="" IBERR="IB018;"_IBERR S:$P($G(^IB(+$P(X,"^",9),0)),"^",5)'=8 IBTOTL=IBTOTL+$P(X,"^",7)
44 S IBIL=$P(X,"^",11)
45 ;
46 S IBSERV="",IBATYP=$P(X,"^",3) I $D(^IBE(350.1,+IBATYP,0)) S IBSERV=$P(^(0),"^",4)
47 D ARPARM^IBAUTL
48 S IBWHER=3
49 ; - piece 1 of X (21) denotes the AR Trans. Type of Decrease Adjustment
50 I IBTOTL>0 S X="21^"_IBTOTL_"^"_IBIL_"^"_IBDUZ_"^"_$P(IBNOW,".")_"^"_$S($D(^IBE(350.3,+$P(^IB(IBNOS,0),"^",10),0)):$P(^(0),"^",1),1:"") D ^PRCASER1 I +Y<0 G ERR
51 ;
52 S IBWHER=4
53 F I=1:1 S IBN=$P(IBNOS,"^",I) Q:'IBN D UP2
54 Q
55UP2 ; -update IB data and reindex
56 S DIE="^IB(",DA=IBN,DR=".05////"_$S(IBERR="":3,1:9)
57 D ^DIE K DIE,DR,DA
58 I $D(Y) S IBERR="IB020;"_IBERR
59 S DA=IBN,DIK="^IB(" D IX^DIK
60 ;W "FILING UPDATED ENTRY IN IB",!
61 K DIK,DA
62 ; -update parent to cancelled
63 S IBPARNT=$P(^IB(IBN,0),"^",9),IBCRES=$P(^IB(IBN,0),"^",10)
64 S DIE="^IB(",DA=IBPARNT,DR=".05////10;.1////"_IBCRES D ^DIE K DIE,DA,DR
65 Q
66 ;
673 D 1
68 Q
69UP3 ; -update status of all previous bills to updated
70 ;
71 N IBI,IBJ
72 S IBJ="" F IBI=0:0 S IBJ=$O(^IB("AD",$P(^IB(IBN,0),"^",9),IBJ)) Q:'IBJ I $D(^IB(IBJ,0)),$P(^(0),"^",5)=3,IBN'=IBJ S DIE="^IB(",DA=IBJ,DR=".05////4" D ^DIE
73 Q
74 ;
75ERR D ^IBAERR:$D(ZTQUEUED) Q
76END ;
77 S Y=$S(IBERR="":1,1:"-1^"_IBERR)
78 K IBERR Q
79 ;
80TRCHK ; - if entry has an ar transaction number take out of list
81 I $P(X,"^",12)!($$HOLD^IBRUTL(X,IBN,IBDUZ,IBSEQNO)) D
82 . I I=1 S IBNOS=$P(IBNOS,"^",2,99)
83 . E S IBNOS=$P(IBNOS,"^",1,I-1)_"^"_$P(IBNOS,"^",I+1,99)
84 . S $P(X,"^",7)=0,I=I-1
85 Q
86 ;
87 ;
88AR ; Pass charges which need separate bills to Accounts Receivable.
89 ; Variable input: DFN -- Pointer to the patient in file #2
90 ; IBSITE -- Facility number
91 ; IBATYP -- Pointer to the action type in file #350.1
92 ; IBFR -- 'Bill From' Date
93 ; IBCHG -- Charge amount
94 ; IBN -- Pointer to the charge in file #350
95 ; IBY -- Set to 1 to denote potential success
96 ; IBSERV -- Pointer to the service in file #49
97 ;
98 ; Variable output: IBY -- Set <0 if there is an error
99 ;
100 D SET,REL:IBY>0
101 Q
102 ;
103 ;
104SET ; Set up stub receivable in AR.
105 S PRCASV("SITE")=IBSITE
106 S PRCASV("SER")=IBSERV
107 D SETUP^PRCASVC3
108 S:PRCASV("ARREC")<0 IBY=PRCASV("ARREC")
109 S:PRCASV("ARBIL")<0 IBY=PRCASV("ARBIL")
110 Q
111 ;
112REL ; Release the charge to AR.
113 S PRCASV("APR")=DUZ
114 S PRCASV("BDT")=DT
115 S PRCASV("CAT")=+$P($G(^IBE(350.1,IBATYP,0)),"^",3)
116 S PRCASV("DEBTOR")=DFN_";DPT("
117 S PRCASV("FY")=$$FY^IBOUTL(IBFR)_"^"_IBCHG
118 ;
119 D ^PRCASVC6
120 I PRCASV("OKAY") D
121 .S (IBTRAN,IBERR)="",IBIL=PRCASV("ARBIL")
122 .D UP1
123 .;
124 .D REL^PRCASVC
125 ;
126 I 'PRCASV("OKAY") D G RELQ
127 .W:$G(IBJOB)=4 !," >> Unable to establish this receivable in AR! Please investigate before",!," trying to re-bill this patient."
128 .S IBY="-1^^Unable to establish receivable in AR."
129 ;
130 ; - update the receivable status to Active
131 S PRCASV("STATUS")=16
132 D STATUS^PRCASVC1
133 ;
134 ; - update charge status
135 ;S (IBTRAN,IBERR)="",IBIL=PRCASV("ARBIL")
136 ;D UP1
137 ;
138RELQ K PRCASV,IBTRAN,IBIL,IBERR
139 Q
140 ;
Note: See TracBrowser for help on using the repository browser.