| 1 | IBAMTD2 ;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 | ;
|
|---|
| 5 | APM() ; 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 | ;
|
|---|
| 29 | APMQ Q IBY
|
|---|
| 30 | ;
|
|---|
| 31 | ;
|
|---|
| 32 | CHG(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 | ;
|
|---|
| 43 | SET ; 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 | ;
|
|---|
| 50 | CHK ; 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
|
|---|
