IBECEA ;ALB/RLW - Cancel/Edit/Add Patient Charges ;12-JUN-92
;;2.0;INTEGRATED BILLING ;**199,135,568**;21-MAR-94;Build 40
;;Per VA Directive 6402, this routine should not be modified.
;
EN ; Cancel/Edit/Add Patient Charges -- invoke the List Manager.
K XQORS,VALMEVL
EN1 ; Entrypoint to avoid killing XQORS
I '$$CHECK^IBECEAU(1) G ENQ
D EN^VALM("IB CHARGES")
ENQ K IBSITE,IBFAC,IBSERV
Q
;
EN1AR ; AR entry for charge maintenance
N DIR,X,Y
D EN1
S DIR(0)="EA",DIR("A")="PRESS RETURN TO CONTINUE. "
W ! D ^DIR K DIR
Q
;
INIT ; List Manager (IB CHARGES) main entry point.
S IBJOB=4,IBWHER="IBECEA",IBDUZ=DUZ
S IBACMAR="^TMP(""IBACM"",$J)",IBACMIDX="^TMP(""IBACMIDX"",$J)",VALMIDX="^TMP(""IBCMLIDX"",$J)"
I '$$SLPT S VALMQUIT="" D FNL G INITQ
I $$SLDT S VALMQUIT="" D FNL G INITQ
I $$SLRX S VALMQUIT="" D FNL G INITQ
D ARRAY^IBECEA0
INITQ Q
;
PAT ; 'Change Patient' protocol entry action.
I $D(REC) S (GOTPAT,DFN)=0 ;IB*2.0*568
N IBDFN S IBDFN=DFN
I '$$SLPT D MSG S DFN=IBDFN K REC,GOTPAT G PATQ ;IB*2.0*568
DATE ; 'Change Date' protocol entry action.
N IBDT1,IBDT2,IBRXXX S IBDT1=IBABEG,IBDT2=IBAEND,IBRXXX=IBRX
I $$SLDT D MSG S IBABEG=IBDT1,IBAEND=IBDT2 S:$D(IBDFN) DFN=IBDFN G PATQ
I $$SLRX D MSG S IBABEG=IBDT1,IBAEND=IBDT2,IBRX=IBRXXX S:$D(IBDFN) DFN=IBDFN G PATQ
D ARRAY^IBECEA0,HDR S VALMBCK="R"
PATQ Q
;
MSG ; Quick message display.
N DIR,DIRUT,DUOUT,DTOUT,X,Y
W !!,*7,"No changes were made!",!
S DIR(0)="E" D ^DIR S VALMBCK=""
Q
;
HDR ; Build screen header.
S IBNAM=$$PT^IBEFUNC(DFN)
S VALMHDR(1)=$$SETSTR^VALM1($$FDATE^VALM1(IBABEG)_" THRU "_$$FDATE^VALM1(IBAEND),"Cancel/Edit/Add Charges",59,22)
S VALMHDR(2)=$E("Patient: "_$P(IBNAM,"^"),1,25)_" "_$E(IBNAM)_$P(IBNAM,"^",3)
Q
;
SLPT() ; Select a patient.
N DIC,X,Y
I $G(GOTPAT) Q DFN ;IB*2.0*568
N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC S DFN=+Y
Q Y>0
;
SLDT() ; Select Charge dates.
N DIR,DIRUT,DUOUT,DTOUT,X,Y
S DIR(0)="DA^2860101:NOW:EX",DIR("A")="Search for CHARGES from: ",DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(DT,-365)) D ^DIR S IBABEG=+Y G:'Y SLDTQ
S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")=" to: ",DIR("B")=$$DAT2^IBOUTL(DT) D ^DIR S IBAEND=+Y+.999999
SLDTQ Q $D(DIRUT)!($D(DUOUT))
;
SLRX() ; Include Rx copay charges?
N DIR,DIRUT,DUOUT,DTOUT,X,Y
S DIR(0)="Y",DIR("A")="Include RX COPAY charges",DIR("B")="NO" D ^DIR S IBRX=Y
Q $D(DIRUT)!($D(DUOUT))
;
RCFNL ;
K:$D(IBACMAR) @IBACMAR,IBACMAR K:$D(IBACMIDX) @IBACMIDX,IBACMIDX K:$D(VALMIDX) @VALMIDX,VALMIDX
K IBABEG,IBAEND,DFN,IBAT,IBAX,IBY,VA,IBRX,IBWHER,X,^TMP("IBECEA",$J),^TMP("IBCMLIDX",$J),IBSAVY,IBARTYP,IBPRNT,IBDUZ,IBJOB,IBXA,IBNOW,IBLDT,IBL,IBIL,IBNAM
Q
;
FNL ; List Manager (IB CHARGES) exit action.
K:$D(IBACMAR) @IBACMAR,IBACMAR K:$D(IBACMIDX) @IBACMIDX,IBACMIDX K:$D(VALMIDX) @VALMIDX,VALMIDX
K IBABEG,IBAEND,DFN,IBAT,IBAX,IBY,VA,IBRX,IBWHER,X,^TMP("IBECEA",$J),^TMP("IBCMLIDX",$J),DFN,IBSAVY,IBARTYP,IBPRNT,IBDUZ,IBJOB,IBXA,IBNOW,IBLDT,IBL,IBIL,IBNAM
Q
;
EXIT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBECEA 3103 printed Oct 16, 2024@18:21:49 Page 2
IBECEA ;ALB/RLW - Cancel/Edit/Add Patient Charges ;12-JUN-92
+1 ;;2.0;INTEGRATED BILLING ;**199,135,568**;21-MAR-94;Build 40
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ; Cancel/Edit/Add Patient Charges -- invoke the List Manager.
+1 KILL XQORS,VALMEVL
EN1 ; Entrypoint to avoid killing XQORS
+1 IF '$$CHECK^IBECEAU(1)
GOTO ENQ
+2 DO EN^VALM("IB CHARGES")
ENQ KILL IBSITE,IBFAC,IBSERV
+1 QUIT
+2 ;
EN1AR ; AR entry for charge maintenance
+1 NEW DIR,X,Y
+2 DO EN1
+3 SET DIR(0)="EA"
SET DIR("A")="PRESS RETURN TO CONTINUE. "
+4 WRITE !
DO ^DIR
KILL DIR
+5 QUIT
+6 ;
INIT ; List Manager (IB CHARGES) main entry point.
+1 SET IBJOB=4
SET IBWHER="IBECEA"
SET IBDUZ=DUZ
+2 SET IBACMAR="^TMP(""IBACM"",$J)"
SET IBACMIDX="^TMP(""IBACMIDX"",$J)"
SET VALMIDX="^TMP(""IBCMLIDX"",$J)"
+3 IF '$$SLPT
SET VALMQUIT=""
DO FNL
GOTO INITQ
+4 IF $$SLDT
SET VALMQUIT=""
DO FNL
GOTO INITQ
+5 IF $$SLRX
SET VALMQUIT=""
DO FNL
GOTO INITQ
+6 DO ARRAY^IBECEA0
INITQ QUIT
+1 ;
PAT ; 'Change Patient' protocol entry action.
+1 ;IB*2.0*568
IF $DATA(REC)
SET (GOTPAT,DFN)=0
+2 NEW IBDFN
SET IBDFN=DFN
+3 ;IB*2.0*568
IF '$$SLPT
DO MSG
SET DFN=IBDFN
KILL REC,GOTPAT
GOTO PATQ
DATE ; 'Change Date' protocol entry action.
+1 NEW IBDT1,IBDT2,IBRXXX
SET IBDT1=IBABEG
SET IBDT2=IBAEND
SET IBRXXX=IBRX
+2 IF $$SLDT
DO MSG
SET IBABEG=IBDT1
SET IBAEND=IBDT2
if $DATA(IBDFN)
SET DFN=IBDFN
GOTO PATQ
+3 IF $$SLRX
DO MSG
SET IBABEG=IBDT1
SET IBAEND=IBDT2
SET IBRX=IBRXXX
if $DATA(IBDFN)
SET DFN=IBDFN
GOTO PATQ
+4 DO ARRAY^IBECEA0
DO HDR
SET VALMBCK="R"
PATQ QUIT
+1 ;
MSG ; Quick message display.
+1 NEW DIR,DIRUT,DUOUT,DTOUT,X,Y
+2 WRITE !!,*7,"No changes were made!",!
+3 SET DIR(0)="E"
DO ^DIR
SET VALMBCK=""
+4 QUIT
+5 ;
HDR ; Build screen header.
+1 SET IBNAM=$$PT^IBEFUNC(DFN)
+2 SET VALMHDR(1)=$$SETSTR^VALM1($$FDATE^VALM1(IBABEG)_" THRU "_$$FDATE^VALM1(IBAEND),"Cancel/Edit/Add Charges",59,22)
+3 SET VALMHDR(2)=$EXTRACT("Patient: "_$PIECE(IBNAM,"^"),1,25)_" "_$EXTRACT(IBNAM)_$PIECE(IBNAM,"^",3)
+4 QUIT
+5 ;
SLPT() ; Select a patient.
+1 NEW DIC,X,Y
+2 ;IB*2.0*568
IF $GET(GOTPAT)
QUIT DFN
+3 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+4 SET DIC="^DPT("
SET DIC(0)="AEMQ"
DO ^DIC
SET DFN=+Y
+5 QUIT Y>0
+6 ;
SLDT() ; Select Charge dates.
+1 NEW DIR,DIRUT,DUOUT,DTOUT,X,Y
+2 SET DIR(0)="DA^2860101:NOW:EX"
SET DIR("A")="Search for CHARGES from: "
SET DIR("B")=$$DAT2^IBOUTL($$FMADD^XLFDT(DT,-365))
DO ^DIR
SET IBABEG=+Y
if 'Y
GOTO SLDTQ
+3 SET DIR(0)="DA^"_+Y_":NOW:EX"
SET DIR("A")=" to: "
SET DIR("B")=$$DAT2^IBOUTL(DT)
DO ^DIR
SET IBAEND=+Y+.999999
SLDTQ QUIT $DATA(DIRUT)!($DATA(DUOUT))
+1 ;
SLRX() ; Include Rx copay charges?
+1 NEW DIR,DIRUT,DUOUT,DTOUT,X,Y
+2 SET DIR(0)="Y"
SET DIR("A")="Include RX COPAY charges"
SET DIR("B")="NO"
DO ^DIR
SET IBRX=Y
+3 QUIT $DATA(DIRUT)!($DATA(DUOUT))
+4 ;
RCFNL ;
+1 if $DATA(IBACMAR)
KILL @IBACMAR,IBACMAR
if $DATA(IBACMIDX)
KILL @IBACMIDX,IBACMIDX
if $DATA(VALMIDX)
KILL @VALMIDX,VALMIDX
+2 KILL IBABEG,IBAEND,DFN,IBAT,IBAX,IBY,VA,IBRX,IBWHER,X,^TMP("IBECEA",$JOB),^TMP("IBCMLIDX",$JOB),IBSAVY,IBARTYP,IBPRNT,IBDUZ,IBJOB,IBXA,IBNOW,IBLDT,IBL,IBIL,IBNAM
+3 QUIT
+4 ;
FNL ; List Manager (IB CHARGES) exit action.
+1 if $DATA(IBACMAR)
KILL @IBACMAR,IBACMAR
if $DATA(IBACMIDX)
KILL @IBACMIDX,IBACMIDX
if $DATA(VALMIDX)
KILL @VALMIDX,VALMIDX
+2 KILL IBABEG,IBAEND,DFN,IBAT,IBAX,IBY,VA,IBRX,IBWHER,X,^TMP("IBECEA",$JOB),^TMP("IBCMLIDX",$JOB),DFN,IBSAVY,IBARTYP,IBPRNT,IBDUZ,IBJOB,IBXA,IBNOW,IBLDT,IBL,IBIL,IBNAM
+3 QUIT
+4 ;
EXIT QUIT
