- 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 Apr 23, 2025@18:21:04 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
