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

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

initial load of WorldVistAEHR

File size: 2.5 KB
Line 
1IBAMTD2 ;ALB/CPM - MOVEMENT BULLETIN PROCESSING ; 03-MAY-93
2 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5APM() ; Analyze patient movement to see if Means Test charges were effected.
6 ; Input: DFN -- Pointer to patient in file #2
7 ; DGPMP -- Oth node in file #405 prior to change
8 ; DGPMA -- Oth node in file #405 after the change
9 ; Output: 0 -- No effect on Means Test charges (no bulletin)
10 ; 1 -- Means Test charges were effected (send bulletin)
11 ;
12 N IBADM,IBCHG,IBMVTA,IBMVTP,IBMTYP,IBPM,IBY
13 S IBMTYP=$P(DGPMA,"^",2) S:'IBMTYP IBMTYP=$P(DGPMP,"^",2)
14 I IBMTYP=4!(IBMTYP=5) S IBY=0 G APMQ
15 S IBY=$$CHG(DFN) G:'IBY APMQ
16 ;
17 ; - process admissions
18 I IBMTYP=1 D:DGPMA]"" SET,CHK G APMQ
19 ;
20 ; - process specialty transfers
21 I IBMTYP=6 D G APMQ
22 .Q:IBJOB=6!(DGPMA="") D SET,CHK
23 ;
24 ; - process discharges and transfers
25 I IBMTYP=2!(IBMTYP=3) D:DGPMA]"" G APMQ
26 .I $P(+DGPMA,".")=$P(+DGPMP,".") S IBY=0 Q
27 .S IBVAL(2)=+DGPMP_"^"_+DGPMA
28 ;
29APMQ Q IBY
30 ;
31 ;
32CHG(DFN) ; Were any Means Test Charges Billed for this Admission?
33 ; Input: DFN -- Pointer to patient in file #2
34 ; Output: 1 -- Charges have been billed for the admission
35 ; 0 -- Charges have not been billed for the admission
36 ;
37 N IBD,IBN,IBND,IBCHG,IBNL,IBLAST,IBQ,IBX,PM
38 S (IBX,IBQ)="",PM=$P(DGPMP,"^",14) S:'PM PM=+$P(DGPMA,"^",14)
39 F S IBX=$O(^IB("AFDT",DFN,IBX)) Q:'IBX!IBQ S IBD=0 F S IBD=$O(^IB("AFDT",DFN,IBX,IBD)) Q:'IBD S IBND=$G(^IB(IBD,0)) I $P(IBND,"^",8)["ADMISSION",$P(IBND,"^",4)[("405:"_PM) S IBQ=1 Q
40 I $G(IBD) S IBN=IBD F S IBN=$O(^IB("AF",IBD,IBN)) Q:'IBN S IBLAST=$$LAST^IBECEAU(+$P($G(^IB(IBN,0)),"^",9)),IBNL=$G(^IB(+IBLAST,0)) I $P($G(^IBE(350.1,+$P(IBNL,"^",3),0)),"^",5)'=2,"^1^2^3^4^8^"[("^"_$P(IBNL,"^",5)_"^") S IBCHG=1 Q
41 Q +$G(IBCHG)
42 ;
43SET ; Set Before/Afters for the mvmt date and treating specialty
44 N X S IBMVTP=+DGPMP,IBMVTA=+DGPMA
45 I IBMTYP=6 S IBFTSP=$P(DGPMP,"^",9),IBFTSA=$P(DGPMA,"^",9)
46 I IBMTYP=1 S X=+$O(^UTILITY("DGPM",$J,6,0)),IBFTSP=$P($G(^(X,"P")),"^",9),IBFTSA=$P($G(^("A")),"^",9)
47 S IBFTSPBS=$$SECT^IBAUTL5(IBFTSP),IBFTSABS=$$SECT^IBAUTL5(IBFTSA)
48 Q
49 ;
50CHK ; Check for changes in the movement date or treating specialty.
51 I $P(IBMVTP,".")=$P(IBMVTA,"."),(IBFTSP=IBFTSA!(IBFTSPBS=IBFTSABS)) S IBY=0 Q
52 I IBFTSPBS'=IBFTSABS S IBVAL(1)=IBFTSP_"^"_IBFTSPBS_"^"_IBFTSA_"^"_IBFTSABS
53 I $P(IBMVTP,".")'=$P(IBMVTA,".") S IBVAL(2)=IBMVTP_"^"_IBMVTA
54 Q
Note: See TracBrowser for help on using the repository browser.