IBACVA.m

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 ---IBACVA   1549     printed  Apr 09, 2024@21:09: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