IBACVA ;ALB/CPM - PROCESS CHAMPVA PATIENT MOVEMENTS ; 27-JUL-93
;;Version 2.0 ; INTEGRATED BILLING ;**27**; 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:'IBCVA IBCVA=+DGPMP\1
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 UPSTAT^IBECEAU4(IBBILLED),DEL^IBACVA2(DFN,IBBILLED,+DGPMP)
;
; - if delete a discharge -> bulletin
I DGPMA="",$P(DGPMP,"^",2)=3 D WARN^IBACVA2(+DGPMP,0) 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBACVA 1549 printed Oct 16, 2024@18:06:34 Page 2
IBACVA ;ALB/CPM - PROCESS CHAMPVA PATIENT MOVEMENTS ; 27-JUL-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**27**; 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 if 'IBCVA
SET IBCVA=+DGPMP\1
+12 SET IBBILLED=$$PREV^IBACVA1(DFN,IBCVA,IBCVAPM)
+13 ;
+14 ; - if admission was deleted, cancel the charge (if billed)
+15 IF DGPMA=""
IF $PIECE(DGPMP,"^",2)=1
if 'IBBILLED
GOTO PROCQ
Begin DoDot:1
+16 SET IBCRES=$ORDER(^IBE(350.3,"B","CHAMPVA ADMISSION DELETED",0))
+17 if 'IBCRES
SET IBCRES=24
+18 DO UPSTAT^IBECEAU4(IBBILLED)
DO DEL^IBACVA2(DFN,IBBILLED,+DGPMP)
End DoDot:1
GOTO PROCQ
+19 ;
+20 ; - if delete a discharge -> bulletin
+21 IF DGPMA=""
IF $PIECE(DGPMP,"^",2)=3
DO WARN^IBACVA2(+DGPMP,0)
GOTO PROCQ
+22 ;
+23 ; - if edit a discharge, change date -> bulletin
+24 IF DGPMA
IF DGPMP
IF $PIECE(DGPMA,"^",2)=3
IF $PIECE(+DGPMA,".")'=$PIECE(+DGPMP,".")
DO WARN^IBACVA2(+DGPMP,+DGPMA)
GOTO PROCQ
+25 ;
+26 ; - if discharged, bill the subsistence charge
+27 IF DGPMP=""
IF $PIECE(DGPMA,"^",2)=3
IF 'IBBILLED
Begin DoDot:1
+28 SET IBSL=IBCVAPM
SET IBBDT=$$FMTH^XLFDT(IBCVA,1)
SET IBEDT=$$FMTH^XLFDT(+DGPMA\1,1)
+29 DO BILL^IBACVA1
End DoDot:1
+30 ;
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
