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

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

initial load of WorldVistAEHR

File size: 2.3 KB
Line 
1IBAMTC2 ;ALB/CJM - INTEGRATED BILLING, CLEANUP OF UNCLOSED EVENTS, UNPASSED CHARGES ; 04-APRIL-1992
2 ;;2.0;INTEGRATED BILLING;**132,176**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5MAIN ;
6 N IBAGE,IBFREQ,IBCHG,DFN,IBN,IBND,IBSL,IBDISC,DIE,DR,DA,IBQUIT,IBPASS,IBOLD,IBDATE,IBDUZ S IBDUZ=$G(DUZ)
7 D NOW^%DTC S IBDATE=X
8 S IBAGE=44,IBFREQ=15 ; age of unpassed charges to report, frequency
9 ; loop through all incomplete entries in file 350
10 N IBFLLTC
11 S IBN="" F S IBN=$O(^IB("AC",1,IBN)) Q:'IBN S IBND=$G(^IB(IBN,0)) D
12 .Q:($P(IBND,"^",5)'=1)!($P(IBND,"^",16)']"")
13 .I $P(IBND,"^",16)=IBN S IBFLLTC="" D Q:IBFLLTC="L"
14 ..;
15 ..N IBDISC,IBSL,VAIN,VAINDT,IBLDT D DISC Q:+IBDISC=0
16 ..S DFN=$P(IBND,"^",2),VAINDT=IBDISC D INP^VADPT S IBFLLTC=$P($$TREATSP^IBAECU2($P($G(^DIC(45.7,+VAIN(3),0)),U,2)),"^",1)
17 ..S IBLDT=$$LASTMJ^IBAECU() I IBLDT>0,$E(IBDISC,1,5)<$E(IBLDT,1,5),IBFLLTC="L" D CLOSE
18 .I $P(IBND,"^",16)=IBN D
19 ..D EVENT
20 .E D CHARGE
21 Q
22EVENT ; closes events if the patient was discharged
23 S (IBPASS,IBQUIT)=0
24 D DISC I IBDISC D CLOSE D:'IBQUIT FNDCHGS,PASS:IBCHG,BULLET1^IBAMTC3
25 Q
26DISC ; gets the discharge date
27 S IBDISC="",IBSL=$P(IBND,"^",4)
28 I $P(IBSL,":")=405 S IBDISC=$P(IBSL,":",2) S:IBDISC]"" IBDISC=$P($G(^DGPM(IBDISC,0)),"^",17)
29 S:IBDISC IBDISC=($P($G(^DGPM(IBDISC,0)),"^")\1)
30 Q
31CLOSE ;
32 S IBQUIT=1
33 L +^IB(IBN):3 I $T D
34 .S IBQUIT=0
35 .S DIE="^IB(",DA=IBN,DR=".05////2"
36 .D ^DIE L -^IB(IBN)
37 Q
38FNDCHGS ;
39 N I S IBCHG="" F I=1:1 S IBCHG=$O(^IB("ACT",IBN,IBCHG)) Q:'IBCHG S IBCHG(I)=IBCHG
40 S IBCHG=(I-1)
41 Q
42PASS ; pass the charges if they appear correct, complete, and can be locked
43 S IBPASS=0
44 N IBI,IBNOS,IBADMIT S DFN=$P(IBND,"^",2),IBADMIT=($P(IBND,"^",17)\1)
45 Q:+$$MVT^DGPMOBS($P(IBSL,":",2))
46 I IBDISC=$P(IBND,"^",17) Q:$P(IBND,"^",18)'=IBDISC
47 E S X1=$P(IBND,"^",18),X2=1 D C^%DTC Q:X'=IBDISC
48 S IBPASS=1 F IBI=1:1:IBCHG L +^IB(IBCHG(IBI)):1 S IBPASS=$T Q:'IBPASS I ($P($G(^IB(IBCHG(IBI),0)),"^",15)>IBDISC)!($P($G(^IB(IBCHG(IBI),0)),"^",14)<IBADMIT) S IBPASS=0 Q
49 I IBPASS N IBN F IBI=1:1:IBCHG S IBNOS=IBCHG(IBI),IBY=1 D FILER^IBAUTL5 D:IBY<1 ^IBAERR1
50 F IBI=1:1:IBCHG L -^IB(IBCHG(IBI))
51 Q
52 ;
53CHARGE ; if the charge is old send a bulletin
54 N IBWHEN S IBWHEN=$P($G(^IB(IBN,1)),"^",2)
55 S X2=IBWHEN,X1=IBDATE D ^%DTC
56 S IBOLD=(+$FN(X,"T")) I IBOLD>IBAGE,X#IBFREQ=0 D BULLET2^IBAMTC3
57 Q
Note: See TracBrowser for help on using the repository browser.