IBAMTD2 ;ALB/CPM - MOVEMENT BULLETIN PROCESSING ; 03-MAY-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
APM() ; Analyze patient movement to see if Means Test charges were effected.
; Input: DFN -- Pointer to patient in file #2
; DGPMP -- Oth node in file #405 prior to change
; DGPMA -- Oth node in file #405 after the change
; Output: 0 -- No effect on Means Test charges (no bulletin)
; 1 -- Means Test charges were effected (send bulletin)
;
N IBADM,IBCHG,IBMVTA,IBMVTP,IBMTYP,IBPM,IBY
S IBMTYP=$P(DGPMA,"^",2) S:'IBMTYP IBMTYP=$P(DGPMP,"^",2)
I IBMTYP=4!(IBMTYP=5) S IBY=0 G APMQ
S IBY=$$CHG(DFN) G:'IBY APMQ
;
; - process admissions
I IBMTYP=1 D:DGPMA]"" SET,CHK G APMQ
;
; - process specialty transfers
I IBMTYP=6 D G APMQ
.Q:IBJOB=6!(DGPMA="") D SET,CHK
;
; - process discharges and transfers
I IBMTYP=2!(IBMTYP=3) D:DGPMA]"" G APMQ
.I $P(+DGPMA,".")=$P(+DGPMP,".") S IBY=0 Q
.S IBVAL(2)=+DGPMP_"^"_+DGPMA
;
APMQ Q IBY
;
;
CHG(DFN) ; Were any Means Test Charges Billed for this Admission?
; Input: DFN -- Pointer to patient in file #2
; Output: 1 -- Charges have been billed for the admission
; 0 -- Charges have not been billed for the admission
;
N IBD,IBN,IBND,IBCHG,IBNL,IBLAST,IBQ,IBX,PM
S (IBX,IBQ)="",PM=$P(DGPMP,"^",14) S:'PM PM=+$P(DGPMA,"^",14)
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
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
Q +$G(IBCHG)
;
SET ; Set Before/Afters for the mvmt date and treating specialty
N X S IBMVTP=+DGPMP,IBMVTA=+DGPMA
I IBMTYP=6 S IBFTSP=$P(DGPMP,"^",9),IBFTSA=$P(DGPMA,"^",9)
I IBMTYP=1 S X=+$O(^UTILITY("DGPM",$J,6,0)),IBFTSP=$P($G(^(X,"P")),"^",9),IBFTSA=$P($G(^("A")),"^",9)
S IBFTSPBS=$$SECT^IBAUTL5(IBFTSP),IBFTSABS=$$SECT^IBAUTL5(IBFTSA)
Q
;
CHK ; Check for changes in the movement date or treating specialty.
I $P(IBMVTP,".")=$P(IBMVTA,"."),(IBFTSP=IBFTSA!(IBFTSPBS=IBFTSABS)) S IBY=0 Q
I IBFTSPBS'=IBFTSABS S IBVAL(1)=IBFTSP_"^"_IBFTSPBS_"^"_IBFTSA_"^"_IBFTSABS
I $P(IBMVTP,".")'=$P(IBMVTA,".") S IBVAL(2)=IBMVTP_"^"_IBMVTA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBAMTD2 2578 printed Nov 22, 2024@17:16:38 Page 2
IBAMTD2 ;ALB/CPM - MOVEMENT BULLETIN PROCESSING ; 03-MAY-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
APM() ; Analyze patient movement to see if Means Test charges were effected.
+1 ; Input: DFN -- Pointer to patient in file #2
+2 ; DGPMP -- Oth node in file #405 prior to change
+3 ; DGPMA -- Oth node in file #405 after the change
+4 ; Output: 0 -- No effect on Means Test charges (no bulletin)
+5 ; 1 -- Means Test charges were effected (send bulletin)
+6 ;
+7 NEW IBADM,IBCHG,IBMVTA,IBMVTP,IBMTYP,IBPM,IBY
+8 SET IBMTYP=$PIECE(DGPMA,"^",2)
if 'IBMTYP
SET IBMTYP=$PIECE(DGPMP,"^",2)
+9 IF IBMTYP=4!(IBMTYP=5)
SET IBY=0
GOTO APMQ
+10 SET IBY=$$CHG(DFN)
if 'IBY
GOTO APMQ
+11 ;
+12 ; - process admissions
+13 IF IBMTYP=1
if DGPMA]""
DO SET
DO CHK
GOTO APMQ
+14 ;
+15 ; - process specialty transfers
+16 IF IBMTYP=6
Begin DoDot:1
+17 if IBJOB=6!(DGPMA="")
QUIT
DO SET
DO CHK
End DoDot:1
GOTO APMQ
+18 ;
+19 ; - process discharges and transfers
+20 IF IBMTYP=2!(IBMTYP=3)
if DGPMA]""
Begin DoDot:1
+21 IF $PIECE(+DGPMA,".")=$PIECE(+DGPMP,".")
SET IBY=0
QUIT
+22 SET IBVAL(2)=+DGPMP_"^"_+DGPMA
End DoDot:1
GOTO APMQ
+23 ;
APMQ QUIT IBY
+1 ;
+2 ;
CHG(DFN) ; Were any Means Test Charges Billed for this Admission?
+1 ; Input: DFN -- Pointer to patient in file #2
+2 ; Output: 1 -- Charges have been billed for the admission
+3 ; 0 -- Charges have not been billed for the admission
+4 ;
+5 NEW IBD,IBN,IBND,IBCHG,IBNL,IBLAST,IBQ,IBX,PM
+6 SET (IBX,IBQ)=""
SET PM=$PIECE(DGPMP,"^",14)
if 'PM
SET PM=+$PIECE(DGPMA,"^",14)
+7 FOR
SET IBX=$ORDER(^IB("AFDT",DFN,IBX))
if 'IBX!IBQ
QUIT
SET IBD=0
FOR
SET IBD=$ORDER(^IB("AFDT",DFN,IBX,IBD))
if 'IBD
QUIT
SET IBND=$GET(^IB(IBD,0))
IF $PIECE(IBND,"^",8)["ADMISSION"
IF $PIECE(IBND,"^",4)[("405:"_PM)
SET IBQ=1
QUIT
+8 IF $GET(IBD)
SET IBN=IBD
FOR
SET IBN=$ORDER(^IB("AF",IBD,IBN))
if 'IBN
QUIT
SET IBLAST=$$LAST^IBECEAU(+$PIECE($GET(^IB(IBN,0)),"^",9))
SET IBNL=$GET(^IB(+IBLAST,0))
IF $PIECE($GET(^IBE(350.1,+$PIECE(IBNL,"^",3),0)),"^",5)'=2
IF "^1^2^3^4^8^"[("^"_$PIECE(IBNL,"^",5)_"^")
SET IBCHG=1
QUIT
+9 QUIT +$GET(IBCHG)
+10 ;
SET ; Set Before/Afters for the mvmt date and treating specialty
+1 NEW X
SET IBMVTP=+DGPMP
SET IBMVTA=+DGPMA
+2 IF IBMTYP=6
SET IBFTSP=$PIECE(DGPMP,"^",9)
SET IBFTSA=$PIECE(DGPMA,"^",9)
+3 IF IBMTYP=1
SET X=+$ORDER(^UTILITY("DGPM",$JOB,6,0))
SET IBFTSP=$PIECE($GET(^(X,"P")),"^",9)
SET IBFTSA=$PIECE($GET(^("A")),"^",9)
+4 SET IBFTSPBS=$$SECT^IBAUTL5(IBFTSP)
SET IBFTSABS=$$SECT^IBAUTL5(IBFTSA)
+5 QUIT
+6 ;
CHK ; Check for changes in the movement date or treating specialty.
+1 IF $PIECE(IBMVTP,".")=$PIECE(IBMVTA,".")
IF (IBFTSP=IBFTSA!(IBFTSPBS=IBFTSABS))
SET IBY=0
QUIT
+2 IF IBFTSPBS'=IBFTSABS
SET IBVAL(1)=IBFTSP_"^"_IBFTSPBS_"^"_IBFTSA_"^"_IBFTSABS
+3 IF $PIECE(IBMVTP,".")'=$PIECE(IBMVTA,".")
SET IBVAL(2)=IBMVTP_"^"_IBMVTA
+4 QUIT
