- 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 Mar 13, 2025@21:10:43 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
