- IBACVA ;ALB/CPM - PROCESS CHAMPVA PATIENT MOVEMENTS ; 27-JUL-93
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- PROC ; Process patient movements for CHAMPVA inpatients.
- ;
- ; - quit if the software is not fully installed
- I '$$ON^IBACVA2() G PROCQ
- ;
- ; - send bulletin for CHAMPVA admissions
- I DGPMP="",$P(DGPMA,"^",2)=1 D ADM^IBACVA2 G PROCQ
- ;
- ; - determine if admission has been billed
- S IBCVAPM=$P($S(DGPMA:DGPMA,1:DGPMP),"^",14)
- S IBCVA=$P(+$G(^DGPM(IBCVAPM,0)),".")
- S IBBILLED=$$PREV^IBACVA1(DFN,IBCVA,IBCVAPM)
- ;
- ; - if admission was deleted, cancel the charge (if billed)
- I DGPMA="",$P(DGPMP,"^",2)=1 G:'IBBILLED PROCQ D G PROCQ
- .S IBCRES=$O(^IBE(350.3,"B","CHAMPVA ADMISSION DELETED",0))
- .S:'IBCRES IBCRES=24
- .D CANCH^IBECEAU4(IBBILLED,IBCRES,0,1)
- ;
- ; - if delete a discharge -> bulletin
- I DGPMA="",$P(DGPMP,"^",2)=3 D WARN^IBACVA2 G PROCQ
- ;
- ; - if edit a discharge, change date -> bulletin
- I DGPMA,DGPMP,$P(DGPMA,"^",2)=3,$P(+DGPMA,".")'=$P(+DGPMP,".") D WARN^IBACVA2(+DGPMP,+DGPMA) G PROCQ
- ;
- ; - if discharged, bill the subsistence charge
- I DGPMP="",$P(DGPMA,"^",2)=3,'IBBILLED D
- .S IBSL=IBCVAPM,IBBDT=$$FMTH^XLFDT(IBCVA,1),IBEDT=$$FMTH^XLFDT(+DGPMA\1,1)
- .D BILL^IBACVA1
- ;
- PROCQ K IBY,IBFAC,IBSITE,IBSERV,IBSL,IBCHGT,IBBILLED,IBBDT,IBEDT,IBD,IBDT
- K IBCHG,IBFR,IBTO,IBATYP,IBLIM,IBN,IBUNIT,IBCVA,IBBILLED,IBCVAPM
- K %H,VA,VAIP,VAERR,X
- Q
- IBACVA ;ALB/CPM - PROCESS CHAMPVA PATIENT MOVEMENTS ; 27-JUL-93
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- PROC ; Process patient movements for CHAMPVA inpatients.
- +1 ;
- +2 ; - quit if the software is not fully installed
- +3 IF '$$ON^IBACVA2()
- GOTO PROCQ
- +4 ;
- +5 ; - send bulletin for CHAMPVA admissions
- +6 IF DGPMP=""
- IF $PIECE(DGPMA,"^",2)=1
- DO ADM^IBACVA2
- GOTO PROCQ
- +7 ;
- +8 ; - determine if admission has been billed
- +9 SET IBCVAPM=$PIECE($SELECT(DGPMA:DGPMA,1:DGPMP),"^",14)
- +10 SET IBCVA=$PIECE(+$GET(^DGPM(IBCVAPM,0)),".")
- +11 SET IBBILLED=$$PREV^IBACVA1(DFN,IBCVA,IBCVAPM)
- +12 ;
- +13 ; - if admission was deleted, cancel the charge (if billed)
- +14 IF DGPMA=""
- IF $PIECE(DGPMP,"^",2)=1
- IF 'IBBILLED
- GOTO PROCQ
- Begin DoDot:1
- +15 SET IBCRES=$ORDER(^IBE(350.3,"B","CHAMPVA ADMISSION DELETED",0))
- +16 IF 'IBCRES
- SET IBCRES=24
- +17 DO CANCH^IBECEAU4(IBBILLED,IBCRES,0,1)
- End DoDot:1
- GOTO PROCQ
- +18 ;
- +19 ; - if delete a discharge -> bulletin
- +20 IF DGPMA=""
- IF $PIECE(DGPMP,"^",2)=3
- DO WARN^IBACVA2
- GOTO PROCQ
- +21 ;
- +22 ; - if edit a discharge, change date -> bulletin
- +23 IF DGPMA
- IF DGPMP
- IF $PIECE(DGPMA,"^",2)=3
- IF $PIECE(+DGPMA,".")'=$PIECE(+DGPMP,".")
- DO WARN^IBACVA2(+DGPMP,+DGPMA)
- GOTO PROCQ
- +24 ;
- +25 ; - if discharged, bill the subsistence charge
- +26 IF DGPMP=""
- IF $PIECE(DGPMA,"^",2)=3
- IF 'IBBILLED
- Begin DoDot:1
- +27 SET IBSL=IBCVAPM
- SET IBBDT=$$FMTH^XLFDT(IBCVA,1)
- SET IBEDT=$$FMTH^XLFDT(+DGPMA\1,1)
- +28 DO BILL^IBACVA1
- End DoDot:1
- +29 ;
- PROCQ KILL IBY,IBFAC,IBSITE,IBSERV,IBSL,IBCHGT,IBBILLED,IBBDT,IBEDT,IBD,IBDT
- +1 KILL IBCHG,IBFR,IBTO,IBATYP,IBLIM,IBN,IBUNIT,IBCVA,IBBILLED,IBCVAPM
- +2 KILL %H,VA,VAIP,VAERR,X
- +3 QUIT