IBJDB21 ;ALB/RB - REASONS NOT BILLABLE REPORT (COMPILE) ;19-JUN-00
;;2.0;INTEGRATED BILLING;**123,159,185,399,437,458,568**;21-MAR-94;Build 40
;;Per VA Directive 6402, this routine should not be modified.
;;
EN ; - Entry point from IBJDB2.
K ^TMP("IBJDB2",$J),IB,IBE,ENCTYP,EPIEN,IBADMDT,RELBILL
I '$G(IBXTRACT) D
. F X=1:1:4 I IBSEL[X S IBE(X)=IBEPS(X) ; Set episodes for report.
;
; - Print the header line for the Excel spreadsheet
I $G(IBEXCEL) D PHDL
;
; - Compile reason not billable (RNB) data for episode.
S IBRNB=0 F S IBRNB=$S(IBSRNB'="A":$O(IBSRNB(IBRNB)),1:$O(^IBE(356.8,IBRNB))) Q:'IBRNB D
.S IB0=0 F S IB0=$O(^IBT(356,"AR",IBRNB,IB0)) Q:'IB0 D
..S IBN0=$G(^IBT(356,IB0,0)),IBN1=$G(^IBT(356,IB0,1)) Q:'IBN0!('IBN1)
..S IBEP=+$P(IBN0,U,18) I IBSEL'[IBEP Q ; Get episode.
..S (IBRNB1,IBSORT1)=$P($G(^IBE(356.8,IBRNB,0)),U)
..;
..; - Get valid date entered/episode date and amount for report.
..S IBEPD=+$P(IBN0,U,6)\1,IBDEN=+IBN1\1
..S IBDT=$S($E(IBD)="D":IBDEN,1:IBEPD)
..Q:IBDT<IBBDT!(IBDT>IBEDT)
..S IBAMT=$$AMOUNT(IBEP,IB0)
..I IBAMT<0 Q ;Quit if amount is -1 *568
..;
..; - Get division, if necessary.
..I IBSD D Q:'VAUTD&('$D(VAUTD(IBDIV)))
...S IBDIV=$$DIV^IBJD1(IB0)
..E S IBDIV=$S($G(IBEXCEL):+$$PRIM^VASITE(),1:0)
..;
..; - Provider & Specialty
..S (IBPRV,IBSPC)="",IBQT=0
..I IBEP=1!(IBEP=2) D I IBQT Q
...S IBPRSP=$$PRVSPC(IBEP,IB0)
...I IBSPRV'="A",'$D(IBSPRV(+IBPRSP)) S IBQT=1 Q
...I IBEP=1,IBSISP'="A",'$D(IBSISP(+$P(IBPRSP,U,3))) S IBQT=1 Q
...I IBEP=2,IBSOSP'="A",'$D(IBSOSP(+$P(IBPRSP,U,3))) S IBQT=1 Q
...S IBPRV=$S($P(IBPRSP,U,2)'="":$P(IBPRSP,U,2),1:"** UNKNOWN **")
...S IBSPC=$S($P(IBPRSP,U,4)'="":$P(IBPRSP,U,4),1:"** UNKNOWN **")
..;
..; - Get remaining data for detailed report.
..S DFN=+$P(IBN0,U,2)
..D DEM^VADPT S IBPT=$E(VADM(1),1,25),IBSSN=$P(VADM(2),U)
..S DIC="^VA(200,",DA=+$P(IBN1,U,4),DR=".01",DIQ="IBCLK" D EN^DIQ1
..S IBCLK=$E($G(IBCLK(200,DA,.01)),1,20)
..I ($P(IBN0,U,18)=2)&($$EXTERNAL^DILFD(356,.19,"",$P(IBN0,U,19))["72 HOUR RULE") D
...S IBADMDT=$$ADMDT^IBTUTL5(DFN,$P(IBN0,U,6))
..E S IBADMDT=""
..S ENCTYP=$P(^IBE(356.6,$P(IBN0,U,18),0),U,3) S EPDT=$E($P(IBN0,U,6),1,7)
..S EPIEN=$S(ENCTYP=3:$P(IBN0,U,8),ENCTYP=4:$P(IBN0,U,9),1:"")
..S RELBILL=$$RELBIL^IBTUTL5(EPIEN,EPDT,DFN,ENCTYP)
..;
..; - Get totals for summary.
..I '$D(IB(IBDIV,IBEP,IBRNB)) S IB(IBDIV,IBEP,IBRNB)="0^0"
..S $P(IB(IBDIV,IBEP,IBRNB),U)=$P(IB(IBDIV,IBEP,IBRNB),U)+1
..S $P(IB(IBDIV,IBEP,IBRNB),U,2)=$P(IB(IBDIV,IBEP,IBRNB),U,2)+IBAMT
..I IBRPT="S" Q
..;
..S IBSORT1=$S(IBSORT="P":IBPRV,IBSORT="S":IBSPC,1:IBSORT1)
..S:IBSORT1="" IBSORT1=" "
..;
..I $G(IBEXCEL) D Q
...W !,$E($P($G(^DG(40.8,IBDIV,0)),U),1,25),U
...W $S(IBEP<4:$E(IBE(IBEP)),1:"H"),U,IBPT,U,$E(IBSSN,6,10),U
...W $E($$INS^IBJD1(+$P(IBN0,U,2),IBEPD),1,25),U
...W $$DT^IBJD(IBEPD,1),U,$$DT^IBJD(IBDEN,1),U
...W $$DT^IBJD($P(IBN1,U,3),1),U,IBCLK,U,IBADMDT,U,$E(IBRNB1,1,25),U
...W $E(IBPRV,1,25),U,$E(IBSPC,1,25),U,IBAMT,U
...I RELBILL>0 F X=2:1:$P(RELBILL,";",1)+1 W $P(RELBILL,";",X)_" "
...I RELBILL<0 W ""
...W U,$P(IBN1,U,8)
..;
..S X=IBEPD_U_IBDEN_U_$P(IBN1,U,3)_U_IBCLK_U_IBRNB1
..S X=X_U_IBPRV_U_IBSPC_U_IBAMT_U_$E($P(IBN1,U,8),1,50)_U_IBADMDT_U_RELBILL
..S ^TMP("IBJDB2",$J,IBDIV,IBEP,IBSORT1,IBPT_"@@"_$E(IBSSN,6,10))=$$INS^IBJD1(+$P(IBN0,U,2),IBEPD)
..S ^TMP("IBJDB2",$J,IBDIV,IBEP,IBSORT1,IBPT_"@@"_$E(IBSSN,6,10),+IBN0)=X
;
I '$G(IBEXCEL) D EN^IBJDB22 ; Print report(s).
;
ENQ K ^TMP("IBJDB2")
K DA,DIC,DIQ,DR,IB,IB0,IBAMT,IBCLK,IBDEN,IBDIV,IBDT,IBE,IBEP,IBEPD,IBI
K IBN0,IBN1,IBN2,IBPRSP,IBPRV,IBPT,IBQT,IBRNB,IBRNB1,IBSORT1,IBSPC
K IBSSN,VADM,X1,X2
Q
;
AMOUNT(EPS,CLM) ; Return the Amount not billed
; Input: EPS - Episode(1=Inpatient,2=Outpatient,3=Prosthet.,4=Prescr.)
; CLM - Pointer to Claim Tracking File (#356)
;Output: AMOUNT not billed
;
N ADM,ADMDT,AMOUNT,BLBS,BLDT,CPT,CPTLST,DA,DR,DCHD,DFN,DIC,DIQ,DIV,DRG,SPCLTY
N IBRX,ENC,ENCDT,EPDT,PFT,PRST,PTF,RIMB,VCPT,TTCST,X
;
S AMOUNT=0,X=$G(^IBT(356,CLM,0))
S ENC=+$P(X,U,4) ; Encounter (Pointer to #409.68)
S ADM=+$P(X,U,5) ; Admission (Pointer to #405)
S PRST=+$P(X,U,9) ; Prothetics (Pointer to #660)
S EPDT=$P(X,U,6) ; Episode Date (FM format)
S IBRX=+$P(X,U,8)
;
; - Assumes REIMBURSABLE INS. as the RATE TYPE
S RIMB=$O(^DGCR(399.3,"B","REIMBURSABLE INS.",0)) I 'RIMB S RIMB=8
;
G @("AMT"_EPS)
;
AMT1 ; - Inpatient Charges
I 'ADM S AMOUNT=-1 G QAMT
S X=$G(^DGPM(ADM,0)) I X="" S AMOUNT=-1 G QAMT
S PTF=$P(X,U,16) I 'PTF S AMOUNT=-1 G QAMT
S ADMDT=$P(X,U)\1,DFN=+$P(X,U,3)
I $P(X,U,17) S DCHD=$P($G(^DGPM(+$P(X,U,17),0)),U)\1
I '$G(DCHD) S DCHD=$$DT^XLFDT()
;
K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV"),^TMP($J,"IBCRC-INDT")
D PTF^IBCRBG(PTF) I '$D(^TMP($J,"IBCRC-PTF")) S AMOUNT=-1 G QAMT ;*568
D PTFDV^IBCRBG(PTF) I '$D(^TMP($J,"IBCRC-DIV")) S AMOUNT=-1 G QAMT ;*568
D BSLOS^IBCRBG(ADMDT,DCHD,1,ADM,0) I '$D(^TMP($J,"IBCRC-INDT")) S AMOUNT=-1 G QAMT ;*568
;
S BLDT=""
F S BLDT=$O(^TMP($J,"IBCRC-INDT",BLDT)) Q:BLDT="" D
.S X=^TMP($J,"IBCRC-INDT",BLDT)
.S BLBS=$P(X,U,2),DRG=$P(X,U,4),DIV=$P(X,U,5),SPCLTY=$P(X,U,6)
.;
.; - Tort Liable Charge (prior to 09/01/99)
.I BLDT<2990901 D Q
..S AMOUNT=AMOUNT+$$BICOST^IBCRCI(RIMB,1,BLDT,"INPATIENT BEDSECTION STAY",BLBS)
.;
.; - Reasonable Charges (on 09/01/99 or later)
.I $$NODRG^IBCRBG2(SPCLTY)["Observation" Q
.I $$NODRG^IBCRBG2(SPCLTY)["Nursing Home Care" D Q
..S BLBS=$$MCCRUTL^IBCRU1("SKILLED NURSING CARE",25)
..S AMOUNT=AMOUNT+$$BICOST^IBCRCI(RIMB,1,BLDT,"INPATIENT BEDSECTION STAY",BLBS,"",DIV,"",1)
.;
.S BLBS=$$BSUPD^IBCRBG2(+SPCLTY,BLDT,1)
.S AMOUNT=AMOUNT+$$BICOST^IBCRCI(RIMB,1,BLDT,"INPATIENT DRG",DRG,"",DIV,"",1,BLBS)
;
; - Add the Professional Average Amount per Episode (Reason.Chg only)
I EPDT'<2990901 S AMOUNT=AMOUNT+$$AVG(EPDT)
;
; - Subtract the amount billed for this Episode
S AMOUNT=AMOUNT-$$CLAMT(DFN,EPDT,1) I AMOUNT=0 S AMOUNT=-1 ;*568
;
K ^TMP($J,"IBCRC-PTF"),^TMP($J,"IBCRC-DIV"),^TMP($J,"IBCRC-INDT")
;
G QAMT
;
AMT2 ; - Outpatient Charges
S X=$$GETOE^SDOE(ENC),ENCDT=+$P(X,U),DFN=+$P(X,U,2),DIV=$P(X,U,11)
;
; - Tort Liable Charge (prior to 09/01/99)
I ENCDT<2990901 D G QAMT
. S AMOUNT=+$$BICOST^IBCRCI(RIMB,3,ENCDT,"OUTPATIENT VISIT DATE")
;
S AMOUNT=$$OPT(ENC,EPDT) ;*568
G QAMT ;*568
;
AMT3 ; Prosthetic Charges
N NTBLD
S NTBLD=$$PRSAMT^IBTUTL5(EPDT,PRST) I NTBLD=0 S AMOUNT=-1 G QAMT ;*568
S DIC="^RMPR(660,",DA=PRST,DR="14",DIQ="TTCST" D EN^DIQ1
S AMOUNT=+$G(TTCST(660,DA,14))
G QAMT
;
AMT4 ; - Prescription Charges
;
; Protect Rx internal entry # before RXAMT call switches to RX number
N IBRXIEN,NTBLD S IBRXIEN=IBRX
;
; - Tort Liable Charge & Reasonable Charge (same source)
S NTBLD=$$RXAMT^IBTUTL5(EPDT,IBRX) I NTBLD=0 S AMOUNT=-1 G QAMT ;*568
;
; Patch 437 update to call charge master with enough information
; to lookup actual cost of prescription
;
N IBBI,IBRSNEW
;
; check charge master for the type of billing--VA Cost or not
S IBBI=$$EVNTITM^IBCRU3(+RIMB,3,"PRESCRIPTION FILL",EPDT,.IBRSNEW)
;
S DFN=$$FILE^IBRXUTL(IBRXIEN,2)
I $G(DFN)>0&(IBBI["VA COST") D
. N IBQTY,IBCOST,IBRFNUM,IBSUBND,IBFEE,IBRXNODE
.; if this is a refill look up the refill info for cost and quantity
. S IBRFNUM=$$RFLNUM^IBRXUTL(IBRXIEN,EPDT,"")
. I IBRFNUM>0 D
.. S IBSUBND=$$ZEROSUB^IBRXUTL(DFN,IBRXIEN,IBRFNUM)
.. S IBQTY=$P($G(IBSUBND),U,4)
.. S IBCOST=$P($G(IBSUBND),U,11)
.;
.; if this was an original fill look up zero node for Rx info
. E D
.. S IBRXNODE=$$RXZERO^IBRXUTL(DFN,IBRXIEN)
.. S IBQTY=$P($G(IBRXNODE),U,7)
.. S IBCOST=$P($G(IBRXNODE),U,17)
.;
. S IBRSNEW=+$O(IBRSNEW($P(IBBI,";"),0))
. S AMOUNT=$J(+$$RATECHG^IBCRCC(+IBRSNEW,IBQTY*IBCOST,EPDT,.IBFEE),0,2)
E D
. S AMOUNT=+$$BICOST^IBCRCI(RIMB,3,EPDT,"PRESCRIPTION FILL")
;
;
QAMT I AMOUNT=0 S AMOUNT=-1 ;*568
Q AMOUNT
;
CLAMT(DFN,EPDT,PT) ; Returns the Total Amount of Claims for Patient/Episode
;
; Input: DFN - Pointer to the Patient File #2
; EPDT - Episode Date
; PT - 0=Outpatient, 1=Inpatient
;
N CLAMT,CLM,DAY,IBD,X
S CLAMT=0,DAY=EPDT-1,CLM=""
F S CLM=$O(^DGCR(399,"C",DFN,CLM)) Q:'CLM D
.S X=$G(^DGCR(399,CLM,0))
.I $P($P(X,U,3),".")=$P(EPDT,".") D
..S IBD=$$CKBIL^IBTUBOU(CLM,PT) Q:IBD=""
..I '$P(IBD,U,3) Q ; Not authorized
..S CLAMT=CLAMT+$G(^DGCR(399,CLM,"U1"))
;
QCLAMT Q CLAMT
;
OPT(IBOE,IBDT) ; - Has the outpatient encounter been billed?
; Input: IBOE=pointer to outpatient encounter in file #409.68
; IBDT=event date CLAIMS TRACKING(#356)
;
; ; *Pre-set variables: DFN=patient IEN, RIMB=bill rate
;
;
I '$G(DFN)!('$G(IBDT))!('$G(RIMB))!('$G(IBOE)) S IBRTN=0 G OPTQ
N IBCN,IBCPT,IBCT,IBDATA,IBDAY,IBDIV,IBXX,IBYD,IBYY,IBZ,IBMRA,IBCPTSUM,IBTCHRG,IBRTN,IBAUTH
; - Check to be sure the encounter is billable.
I $$INPT^IBAMTS1(DFN,IBDT\1_.2359) S IBRTN=-1 G OPTQ ; Became inpatient same day.
I $$ENCL^IBAMTS2(IBOE)["1" S IBRTN=-1 G OPTQ ; "ao^ir^sc^swa^mst^hnc^cv^shad" encounter.
;
;
; - Gather all procedures associated with the encounter.
D GETCPT^SDOE(IBOE,"IBYY") I '$G(IBYY) S IBRTN=-1 G OPTQ ; Check CPT qty.
;
; - Determine the encounter division.
S IBDIV=+$P($$GETOE^SDOE(IBOE),U,11) S:'IBDIV IBDIV=+$$PRIM^VASITE()
;
; - Build array of all billable encounter procedures.
S IBXX=0 F S IBXX=$O(IBYY(IBXX)) Q:'IBXX D
. ;
. ; - Get procedure pointer and code.
. S IBZ=+IBYY(IBXX),IBCN=$P($$CPT^ICPTCOD(IBZ),"^",2)
. ;
. ; - Ignore LAB services for vets with Medicare Supplemental coverage.
. I IBCN>79999,IBCN<90000 Q
. ;
. ; - Get the institutional/professional charge components.
. S IBCPT(IBZ,1)=+$$BICOST^IBCRCI(RIMB,3,IBDT,"PROCEDURE",IBZ,"",IBDIV,"",1)
. S IBCPT(IBZ,2)=+$$BICOST^IBCRCI(RIMB,3,IBDT,"PROCEDURE",IBZ,"",IBDIV,"",2)
. ;
. ; - Eliminate components without a charge.
. S IBCPTSUM(IBZ)=+$G(IBCPT(IBZ,1))+$G(IBCPT(IBZ,2))
. I 'IBCPT(IBZ,1) K IBCPT(IBZ,1)
. I 'IBCPT(IBZ,2) K IBCPT(IBZ,2)
;
I '$D(IBCPT) S IBRTN=-1 G OPTQ ; Quit if no billable procedures remain.
;
; - Look at all of the vet's bills for the day and eliminate
; from the array those procedures that have been billed.
S IBXX=0 S IBDAY=$E(IBDT,1,7)
F S IBXX=$O(^DGCR(399,"AOPV",DFN,IBDAY,IBXX)) Q:'IBXX D
. ;
. ; - Perform general checks on the claim.
. S IBDATA=$$CKBIL^IBTUBOU(IBXX) Q:IBDATA=""
. S IBAUTH=$P($G(IBDATA),U,2)
. I $G(IBAUTH)<2&($G(IBAUTH)>5) Q
. ; - The episode has been billed. Check the revenue code multiple for
. ; all procedures billed on the claim.
. S IBYY=0
. F S IBYY=$O(^DGCR(399,IBXX,"RC",IBYY)) Q:'IBYY S IBYD=^(IBYY,0) D
. . ;
. . ; - Get the procedure code,charge type and total charges for the revenue code.
. . S IBZ=$P(IBYD,U,6)
. . S IBCT=$S($P(IBYD,U,12):$P(IBYD,U,12),1:$P(IBDATA,U,4))
. . S IBTCHRG=$P(IBYD,U,4)
. . I 'IBZ!('IBCT) Q ; Can't determine code/charge type for procedure.
. . ; Delete procedure from unbilled procedures array.
. . I $G(IBTCHRG)'<$G(IBCPTSUM(IBZ)) K IBCPT(IBZ)
. . I $D(IBCPT(IBZ,IBCT)) K IBCPT(IBZ,IBCT)
;
; - Again, quit if no billable procedures remain.
I '$D(IBCPT) S IBRTN=-1 G OPTQ
; - If there are billable procedures return TOTAL AMOUNT
I $D(IBCPT) S (IBZ,IBCT,IBRTN)=0
F S IBZ=$O(IBCPT(IBZ)) Q:'IBZ D
.F S IBCT=$O(IBCPT(IBZ,IBCT)) Q:'IBCT D
..S IBRTN=IBRTN+IBCPT(IBZ,IBCT)
I IBRTN=0 S IBRTN=-1
;
OPTQ K IBCPT Q IBRTN
;
AVG(EPDT) ; Returns the Average Amount of Inpatient Professional per
; Number of Episodes for the previous 12 months
N AVG,M,Z
S AVG=0,M=EPDT\100*100
I '$D(^IBE(356.19,M,1)) S M=$O(^IBE(356.19,M),-1) I 'M G QAVG
S Z=$G(^IBE(356.19,M,1)) I $P(Z,U,12) S AVG=$P(Z,U,11)/$P(Z,U,12)
QAVG Q $J(AVG,0,2)
;
PRVSPC(EPS,CLM) ; Return the Provider and the Specialty
; Input: EPS - Episode(1 = Inpatient OR 2 = Outpatient)
; CLM - Pointer to Claim Tracking File (#356)
; Output: Provider Code (Pointer to #200) ^ Provider Name ^
; Specialty Code (Pointer to #40.7 or #45.7) ^ Specialty Name
;
N ADM,DFN,ENC,PRI,PRS,PRV,PRVLST,SPC,STP,X,VAIN,VAINDT
;
S X=$G(^IBT(356,CLM,0))
S DFN=$P(X,U,2),ENC=$P(X,U,4),ADM=$P(X,U,5),PRS=$P(X,U,8)
;
S (PRV,SPC)="^"
I EPS=1,ADM D G QPS ; Inpatient
.S X=$G(^DGPM(ADM,0)),VAINDT=$P(X,U)\1 I 'VAINDT Q
.D INP^VADPT S PRV=$G(VAIN(11)),SPC=$G(VAIN(3))
.S:PRV="" PRV="^" S:SPC="" SPC="^"
;
I EPS=2,ENC D G QPS ; Outpatient
.D GETPRV^SDOE(ENC,"PRVLST")
.S (X,PRI)=""
.F S X=$O(PRVLST(X),-1) Q:X=""!PRI D
..N IBX S PRV=+PRVLST(X)
..I $P(PRVLST(X),U,4)="P" S PRI=1 ; Primary provider
..I PRV S PRV=PRV_U_$P($G(^VA(200,+PRV,0)),U)
..S IBX=$$GETOE^SDOE(ENC),STP=$P(IBX,U,3)
..I STP'="" S SPC=STP_U_$P($G(^DIC(40.7,STP,0)),U)
;
QPS Q (PRV_U_SPC)
;
PHDL ; - Print the header line for the Excel spreadsheet
N X
S X="Division^Svc^Patient^SSN^Insurance^Episode Dt^Dt Entered^Dt Lst Edit^"
S X=X_"Lst Edited By^Next Admission^RNB Cat^Provider^Specialty^Entry Amt^Related Bills^Comments"
W !,X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDB21 13355 printed Apr 09, 2024@21:27:37 Page 2
IBJDB21 ;ALB/RB - REASONS NOT BILLABLE REPORT (COMPILE) ;19-JUN-00
+1 ;;2.0;INTEGRATED BILLING;**123,159,185,399,437,458,568**;21-MAR-94;Build 40
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;
EN ; - Entry point from IBJDB2.
+1 KILL ^TMP("IBJDB2",$JOB),IB,IBE,ENCTYP,EPIEN,IBADMDT,RELBILL
+2 IF '$GET(IBXTRACT)
Begin DoDot:1
+3 ; Set episodes for report.
FOR X=1:1:4
IF IBSEL[X
SET IBE(X)=IBEPS(X)
End DoDot:1
+4 ;
+5 ; - Print the header line for the Excel spreadsheet
+6 IF $GET(IBEXCEL)
DO PHDL
+7 ;
+8 ; - Compile reason not billable (RNB) data for episode.
+9 SET IBRNB=0
FOR
SET IBRNB=$SELECT(IBSRNB'="A":$ORDER(IBSRNB(IBRNB)),1:$ORDER(^IBE(356.8,IBRNB)))
if 'IBRNB
QUIT
Begin DoDot:1
+10 SET IB0=0
FOR
SET IB0=$ORDER(^IBT(356,"AR",IBRNB,IB0))
if 'IB0
QUIT
Begin DoDot:2
+11 SET IBN0=$GET(^IBT(356,IB0,0))
SET IBN1=$GET(^IBT(356,IB0,1))
if 'IBN0!('IBN1)
QUIT
+12 ; Get episode.
SET IBEP=+$PIECE(IBN0,U,18)
IF IBSEL'[IBEP
QUIT
+13 SET (IBRNB1,IBSORT1)=$PIECE($GET(^IBE(356.8,IBRNB,0)),U)
+14 ;
+15 ; - Get valid date entered/episode date and amount for report.
+16 SET IBEPD=+$PIECE(IBN0,U,6)\1
SET IBDEN=+IBN1\1
+17 SET IBDT=$SELECT($EXTRACT(IBD)="D":IBDEN,1:IBEPD)
+18 if IBDT<IBBDT!(IBDT>IBEDT)
QUIT
+19 SET IBAMT=$$AMOUNT(IBEP,IB0)
+20 ;Quit if amount is -1 *568
IF IBAMT<0
QUIT
+21 ;
+22 ; - Get division, if necessary.
+23 IF IBSD
Begin DoDot:3
+24 SET IBDIV=$$DIV^IBJD1(IB0)
End DoDot:3
if 'VAUTD&('$DATA(VAUTD(IBDIV)))
QUIT
+25 IF '$TEST
SET IBDIV=$SELECT($GET(IBEXCEL):+$$PRIM^VASITE(),1:0)
+26 ;
+27 ; - Provider & Specialty
+28 SET (IBPRV,IBSPC)=""
SET IBQT=0
+29 IF IBEP=1!(IBEP=2)
Begin DoDot:3
+30 SET IBPRSP=$$PRVSPC(IBEP,IB0)
+31 IF IBSPRV'="A"
IF '$DATA(IBSPRV(+IBPRSP))
SET IBQT=1
QUIT
+32 IF IBEP=1
IF IBSISP'="A"
IF '$DATA(IBSISP(+$PIECE(IBPRSP,U,3)))
SET IBQT=1
QUIT
+33 IF IBEP=2
IF IBSOSP'="A"
IF '$DATA(IBSOSP(+$PIECE(IBPRSP,U,3)))
SET IBQT=1
QUIT
+34 SET IBPRV=$SELECT($PIECE(IBPRSP,U,2)'="":$PIECE(IBPRSP,U,2),1:"** UNKNOWN **")
+35 SET IBSPC=$SELECT($PIECE(IBPRSP,U,4)'="":$PIECE(IBPRSP,U,4),1:"** UNKNOWN **")
End DoDot:3
IF IBQT
QUIT
+36 ;
+37 ; - Get remaining data for detailed report.
+38 SET DFN=+$PIECE(IBN0,U,2)
+39 DO DEM^VADPT
SET IBPT=$EXTRACT(VADM(1),1,25)
SET IBSSN=$PIECE(VADM(2),U)
+40 SET DIC="^VA(200,"
SET DA=+$PIECE(IBN1,U,4)
SET DR=".01"
SET DIQ="IBCLK"
DO EN^DIQ1
+41 SET IBCLK=$EXTRACT($GET(IBCLK(200,DA,.01)),1,20)
+42 IF ($PIECE(IBN0,U,18)=2)&($$EXTERNAL^DILFD(356,.19,"",$PIECE(IBN0,U,19))["72 HOUR RULE")
Begin DoDot:3
+43 SET IBADMDT=$$ADMDT^IBTUTL5(DFN,$PIECE(IBN0,U,6))
End DoDot:3
+44 IF '$TEST
SET IBADMDT=""
+45 SET ENCTYP=$PIECE(^IBE(356.6,$PIECE(IBN0,U,18),0),U,3)
SET EPDT=$EXTRACT($PIECE(IBN0,U,6),1,7)
+46 SET EPIEN=$SELECT(ENCTYP=3:$PIECE(IBN0,U,8),ENCTYP=4:$PIECE(IBN0,U,9),1:"")
+47 SET RELBILL=$$RELBIL^IBTUTL5(EPIEN,EPDT,DFN,ENCTYP)
+48 ;
+49 ; - Get totals for summary.
+50 IF '$DATA(IB(IBDIV,IBEP,IBRNB))
SET IB(IBDIV,IBEP,IBRNB)="0^0"
+51 SET $PIECE(IB(IBDIV,IBEP,IBRNB),U)=$PIECE(IB(IBDIV,IBEP,IBRNB),U)+1
+52 SET $PIECE(IB(IBDIV,IBEP,IBRNB),U,2)=$PIECE(IB(IBDIV,IBEP,IBRNB),U,2)+IBAMT
+53 IF IBRPT="S"
QUIT
+54 ;
+55 SET IBSORT1=$SELECT(IBSORT="P":IBPRV,IBSORT="S":IBSPC,1:IBSORT1)
+56 if IBSORT1=""
SET IBSORT1=" "
+57 ;
+58 IF $GET(IBEXCEL)
Begin DoDot:3
+59 WRITE !,$EXTRACT($PIECE($GET(^DG(40.8,IBDIV,0)),U),1,25),U
+60 WRITE $SELECT(IBEP<4:$EXTRACT(IBE(IBEP)),1:"H"),U,IBPT,U,$EXTRACT(IBSSN,6,10),U
+61 WRITE $EXTRACT($$INS^IBJD1(+$PIECE(IBN0,U,2),IBEPD),1,25),U
+62 WRITE $$DT^IBJD(IBEPD,1),U,$$DT^IBJD(IBDEN,1),U
+63 WRITE $$DT^IBJD($PIECE(IBN1,U,3),1),U,IBCLK,U,IBADMDT,U,$EXTRACT(IBRNB1,1,25),U
+64 WRITE $EXTRACT(IBPRV,1,25),U,$EXTRACT(IBSPC,1,25),U,IBAMT,U
+65 IF RELBILL>0
FOR X=2:1:$PIECE(RELBILL,";",1)+1
WRITE $PIECE(RELBILL,";",X)_" "
+66 IF RELBILL<0
WRITE ""
+67 WRITE U,$PIECE(IBN1,U,8)
End DoDot:3
QUIT
+68 ;
+69 SET X=IBEPD_U_IBDEN_U_$PIECE(IBN1,U,3)_U_IBCLK_U_IBRNB1
+70 SET X=X_U_IBPRV_U_IBSPC_U_IBAMT_U_$EXTRACT($PIECE(IBN1,U,8),1,50)_U_IBADMDT_U_RELBILL
+71 SET ^TMP("IBJDB2",$JOB,IBDIV,IBEP,IBSORT1,IBPT_"@@"_$EXTRACT(IBSSN,6,10))=$$INS^IBJD1(+$PIECE(IBN0,U,2),IBEPD)
+72 SET ^TMP("IBJDB2",$JOB,IBDIV,IBEP,IBSORT1,IBPT_"@@"_$EXTRACT(IBSSN,6,10),+IBN0)=X
End DoDot:2
End DoDot:1
+73 ;
+74 ; Print report(s).
IF '$GET(IBEXCEL)
DO EN^IBJDB22
+75 ;
ENQ KILL ^TMP("IBJDB2")
+1 KILL DA,DIC,DIQ,DR,IB,IB0,IBAMT,IBCLK,IBDEN,IBDIV,IBDT,IBE,IBEP,IBEPD,IBI
+2 KILL IBN0,IBN1,IBN2,IBPRSP,IBPRV,IBPT,IBQT,IBRNB,IBRNB1,IBSORT1,IBSPC
+3 KILL IBSSN,VADM,X1,X2
+4 QUIT
+5 ;
AMOUNT(EPS,CLM) ; Return the Amount not billed
+1 ; Input: EPS - Episode(1=Inpatient,2=Outpatient,3=Prosthet.,4=Prescr.)
+2 ; CLM - Pointer to Claim Tracking File (#356)
+3 ;Output: AMOUNT not billed
+4 ;
+5 NEW ADM,ADMDT,AMOUNT,BLBS,BLDT,CPT,CPTLST,DA,DR,DCHD,DFN,DIC,DIQ,DIV,DRG,SPCLTY
+6 NEW IBRX,ENC,ENCDT,EPDT,PFT,PRST,PTF,RIMB,VCPT,TTCST,X
+7 ;
+8 SET AMOUNT=0
SET X=$GET(^IBT(356,CLM,0))
+9 ; Encounter (Pointer to #409.68)
SET ENC=+$PIECE(X,U,4)
+10 ; Admission (Pointer to #405)
SET ADM=+$PIECE(X,U,5)
+11 ; Prothetics (Pointer to #660)
SET PRST=+$PIECE(X,U,9)
+12 ; Episode Date (FM format)
SET EPDT=$PIECE(X,U,6)
+13 SET IBRX=+$PIECE(X,U,8)
+14 ;
+15 ; - Assumes REIMBURSABLE INS. as the RATE TYPE
+16 SET RIMB=$ORDER(^DGCR(399.3,"B","REIMBURSABLE INS.",0))
IF 'RIMB
SET RIMB=8
+17 ;
+18 GOTO @("AMT"_EPS)
+19 ;
AMT1 ; - Inpatient Charges
+1 IF 'ADM
SET AMOUNT=-1
GOTO QAMT
+2 SET X=$GET(^DGPM(ADM,0))
IF X=""
SET AMOUNT=-1
GOTO QAMT
+3 SET PTF=$PIECE(X,U,16)
IF 'PTF
SET AMOUNT=-1
GOTO QAMT
+4 SET ADMDT=$PIECE(X,U)\1
SET DFN=+$PIECE(X,U,3)
+5 IF $PIECE(X,U,17)
SET DCHD=$PIECE($GET(^DGPM(+$PIECE(X,U,17),0)),U)\1
+6 IF '$GET(DCHD)
SET DCHD=$$DT^XLFDT()
+7 ;
+8 KILL ^TMP($JOB,"IBCRC-PTF"),^TMP($JOB,"IBCRC-DIV"),^TMP($JOB,"IBCRC-INDT")
+9 ;*568
DO PTF^IBCRBG(PTF)
IF '$DATA(^TMP($JOB,"IBCRC-PTF"))
SET AMOUNT=-1
GOTO QAMT
+10 ;*568
DO PTFDV^IBCRBG(PTF)
IF '$DATA(^TMP($JOB,"IBCRC-DIV"))
SET AMOUNT=-1
GOTO QAMT
+11 ;*568
DO BSLOS^IBCRBG(ADMDT,DCHD,1,ADM,0)
IF '$DATA(^TMP($JOB,"IBCRC-INDT"))
SET AMOUNT=-1
GOTO QAMT
+12 ;
+13 SET BLDT=""
+14 FOR
SET BLDT=$ORDER(^TMP($JOB,"IBCRC-INDT",BLDT))
if BLDT=""
QUIT
Begin DoDot:1
+15 SET X=^TMP($JOB,"IBCRC-INDT",BLDT)
+16 SET BLBS=$PIECE(X,U,2)
SET DRG=$PIECE(X,U,4)
SET DIV=$PIECE(X,U,5)
SET SPCLTY=$PIECE(X,U,6)
+17 ;
+18 ; - Tort Liable Charge (prior to 09/01/99)
+19 IF BLDT<2990901
Begin DoDot:2
+20 SET AMOUNT=AMOUNT+$$BICOST^IBCRCI(RIMB,1,BLDT,"INPATIENT BEDSECTION STAY",BLBS)
End DoDot:2
QUIT
+21 ;
+22 ; - Reasonable Charges (on 09/01/99 or later)
+23 IF $$NODRG^IBCRBG2(SPCLTY)["Observation"
QUIT
+24 IF $$NODRG^IBCRBG2(SPCLTY)["Nursing Home Care"
Begin DoDot:2
+25 SET BLBS=$$MCCRUTL^IBCRU1("SKILLED NURSING CARE",25)
+26 SET AMOUNT=AMOUNT+$$BICOST^IBCRCI(RIMB,1,BLDT,"INPATIENT BEDSECTION STAY",BLBS,"",DIV,"",1)
End DoDot:2
QUIT
+27 ;
+28 SET BLBS=$$BSUPD^IBCRBG2(+SPCLTY,BLDT,1)
+29 SET AMOUNT=AMOUNT+$$BICOST^IBCRCI(RIMB,1,BLDT,"INPATIENT DRG",DRG,"",DIV,"",1,BLBS)
End DoDot:1
+30 ;
+31 ; - Add the Professional Average Amount per Episode (Reason.Chg only)
+32 IF EPDT'<2990901
SET AMOUNT=AMOUNT+$$AVG(EPDT)
+33 ;
+34 ; - Subtract the amount billed for this Episode
+35 ;*568
SET AMOUNT=AMOUNT-$$CLAMT(DFN,EPDT,1)
IF AMOUNT=0
SET AMOUNT=-1
+36 ;
+37 KILL ^TMP($JOB,"IBCRC-PTF"),^TMP($JOB,"IBCRC-DIV"),^TMP($JOB,"IBCRC-INDT")
+38 ;
+39 GOTO QAMT
+40 ;
AMT2 ; - Outpatient Charges
+1 SET X=$$GETOE^SDOE(ENC)
SET ENCDT=+$PIECE(X,U)
SET DFN=+$PIECE(X,U,2)
SET DIV=$PIECE(X,U,11)
+2 ;
+3 ; - Tort Liable Charge (prior to 09/01/99)
+4 IF ENCDT<2990901
Begin DoDot:1
+5 SET AMOUNT=+$$BICOST^IBCRCI(RIMB,3,ENCDT,"OUTPATIENT VISIT DATE")
End DoDot:1
GOTO QAMT
+6 ;
+7 ;*568
SET AMOUNT=$$OPT(ENC,EPDT)
+8 ;*568
GOTO QAMT
+9 ;
AMT3 ; Prosthetic Charges
+1 NEW NTBLD
+2 ;*568
SET NTBLD=$$PRSAMT^IBTUTL5(EPDT,PRST)
IF NTBLD=0
SET AMOUNT=-1
GOTO QAMT
+3 SET DIC="^RMPR(660,"
SET DA=PRST
SET DR="14"
SET DIQ="TTCST"
DO EN^DIQ1
+4 SET AMOUNT=+$GET(TTCST(660,DA,14))
+5 GOTO QAMT
+6 ;
AMT4 ; - Prescription Charges
+1 ;
+2 ; Protect Rx internal entry # before RXAMT call switches to RX number
+3 NEW IBRXIEN,NTBLD
SET IBRXIEN=IBRX
+4 ;
+5 ; - Tort Liable Charge & Reasonable Charge (same source)
+6 ;*568
SET NTBLD=$$RXAMT^IBTUTL5(EPDT,IBRX)
IF NTBLD=0
SET AMOUNT=-1
GOTO QAMT
+7 ;
+8 ; Patch 437 update to call charge master with enough information
+9 ; to lookup actual cost of prescription
+10 ;
+11 NEW IBBI,IBRSNEW
+12 ;
+13 ; check charge master for the type of billing--VA Cost or not
+14 SET IBBI=$$EVNTITM^IBCRU3(+RIMB,3,"PRESCRIPTION FILL",EPDT,.IBRSNEW)
+15 ;
+16 SET DFN=$$FILE^IBRXUTL(IBRXIEN,2)
+17 IF $GET(DFN)>0&(IBBI["VA COST")
Begin DoDot:1
+18 NEW IBQTY,IBCOST,IBRFNUM,IBSUBND,IBFEE,IBRXNODE
+19 ; if this is a refill look up the refill info for cost and quantity
+20 SET IBRFNUM=$$RFLNUM^IBRXUTL(IBRXIEN,EPDT,"")
+21 IF IBRFNUM>0
Begin DoDot:2
+22 SET IBSUBND=$$ZEROSUB^IBRXUTL(DFN,IBRXIEN,IBRFNUM)
+23 SET IBQTY=$PIECE($GET(IBSUBND),U,4)
+24 SET IBCOST=$PIECE($GET(IBSUBND),U,11)
End DoDot:2
+25 ;
+26 ; if this was an original fill look up zero node for Rx info
+27 IF '$TEST
Begin DoDot:2
+28 SET IBRXNODE=$$RXZERO^IBRXUTL(DFN,IBRXIEN)
+29 SET IBQTY=$PIECE($GET(IBRXNODE),U,7)
+30 SET IBCOST=$PIECE($GET(IBRXNODE),U,17)
End DoDot:2
+31 ;
+32 SET IBRSNEW=+$ORDER(IBRSNEW($PIECE(IBBI,";"),0))
+33 SET AMOUNT=$JUSTIFY(+$$RATECHG^IBCRCC(+IBRSNEW,IBQTY*IBCOST,EPDT,.IBFEE),0,2)
End DoDot:1
+34 IF '$TEST
Begin DoDot:1
+35 SET AMOUNT=+$$BICOST^IBCRCI(RIMB,3,EPDT,"PRESCRIPTION FILL")
End DoDot:1
+36 ;
+37 ;
QAMT ;*568
IF AMOUNT=0
SET AMOUNT=-1
+1 QUIT AMOUNT
+2 ;
CLAMT(DFN,EPDT,PT) ; Returns the Total Amount of Claims for Patient/Episode
+1 ;
+2 ; Input: DFN - Pointer to the Patient File #2
+3 ; EPDT - Episode Date
+4 ; PT - 0=Outpatient, 1=Inpatient
+5 ;
+6 NEW CLAMT,CLM,DAY,IBD,X
+7 SET CLAMT=0
SET DAY=EPDT-1
SET CLM=""
+8 FOR
SET CLM=$ORDER(^DGCR(399,"C",DFN,CLM))
if 'CLM
QUIT
Begin DoDot:1
+9 SET X=$GET(^DGCR(399,CLM,0))
+10 IF $PIECE($PIECE(X,U,3),".")=$PIECE(EPDT,".")
Begin DoDot:2
+11 SET IBD=$$CKBIL^IBTUBOU(CLM,PT)
if IBD=""
QUIT
+12 ; Not authorized
IF '$PIECE(IBD,U,3)
QUIT
+13 SET CLAMT=CLAMT+$GET(^DGCR(399,CLM,"U1"))
End DoDot:2
End DoDot:1
+14 ;
QCLAMT QUIT CLAMT
+1 ;
OPT(IBOE,IBDT) ; - Has the outpatient encounter been billed?
+1 ; Input: IBOE=pointer to outpatient encounter in file #409.68
+2 ; IBDT=event date CLAIMS TRACKING(#356)
+3 ;
+4 ; ; *Pre-set variables: DFN=patient IEN, RIMB=bill rate
+5 ;
+6 ;
+7 IF '$GET(DFN)!('$GET(IBDT))!('$GET(RIMB))!('$GET(IBOE))
SET IBRTN=0
GOTO OPTQ
+8 NEW IBCN,IBCPT,IBCT,IBDATA,IBDAY,IBDIV,IBXX,IBYD,IBYY,IBZ,IBMRA,IBCPTSUM,IBTCHRG,IBRTN,IBAUTH
+9 ; - Check to be sure the encounter is billable.
+10 ; Became inpatient same day.
IF $$INPT^IBAMTS1(DFN,IBDT\1_.2359)
SET IBRTN=-1
GOTO OPTQ
+11 ; "ao^ir^sc^swa^mst^hnc^cv^shad" encounter.
IF $$ENCL^IBAMTS2(IBOE)["1"
SET IBRTN=-1
GOTO OPTQ
+12 ;
+13 ;
+14 ; - Gather all procedures associated with the encounter.
+15 ; Check CPT qty.
DO GETCPT^SDOE(IBOE,"IBYY")
IF '$GET(IBYY)
SET IBRTN=-1
GOTO OPTQ
+16 ;
+17 ; - Determine the encounter division.
+18 SET IBDIV=+$PIECE($$GETOE^SDOE(IBOE),U,11)
if 'IBDIV
SET IBDIV=+$$PRIM^VASITE()
+19 ;
+20 ; - Build array of all billable encounter procedures.
+21 SET IBXX=0
FOR
SET IBXX=$ORDER(IBYY(IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+22 ;
+23 ; - Get procedure pointer and code.
+24 SET IBZ=+IBYY(IBXX)
SET IBCN=$PIECE($$CPT^ICPTCOD(IBZ),"^",2)
+25 ;
+26 ; - Ignore LAB services for vets with Medicare Supplemental coverage.
+27 IF IBCN>79999
IF IBCN<90000
QUIT
+28 ;
+29 ; - Get the institutional/professional charge components.
+30 SET IBCPT(IBZ,1)=+$$BICOST^IBCRCI(RIMB,3,IBDT,"PROCEDURE",IBZ,"",IBDIV,"",1)
+31 SET IBCPT(IBZ,2)=+$$BICOST^IBCRCI(RIMB,3,IBDT,"PROCEDURE",IBZ,"",IBDIV,"",2)
+32 ;
+33 ; - Eliminate components without a charge.
+34 SET IBCPTSUM(IBZ)=+$GET(IBCPT(IBZ,1))+$GET(IBCPT(IBZ,2))
+35 IF 'IBCPT(IBZ,1)
KILL IBCPT(IBZ,1)
+36 IF 'IBCPT(IBZ,2)
KILL IBCPT(IBZ,2)
End DoDot:1
+37 ;
+38 ; Quit if no billable procedures remain.
IF '$DATA(IBCPT)
SET IBRTN=-1
GOTO OPTQ
+39 ;
+40 ; - Look at all of the vet's bills for the day and eliminate
+41 ; from the array those procedures that have been billed.
+42 SET IBXX=0
SET IBDAY=$EXTRACT(IBDT,1,7)
+43 FOR
SET IBXX=$ORDER(^DGCR(399,"AOPV",DFN,IBDAY,IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+44 ;
+45 ; - Perform general checks on the claim.
+46 SET IBDATA=$$CKBIL^IBTUBOU(IBXX)
if IBDATA=""
QUIT
+47 SET IBAUTH=$PIECE($GET(IBDATA),U,2)
+48 IF $GET(IBAUTH)<2&($GET(IBAUTH)>5)
QUIT
+49 ; - The episode has been billed. Check the revenue code multiple for
+50 ; all procedures billed on the claim.
+51 SET IBYY=0
+52 FOR
SET IBYY=$ORDER(^DGCR(399,IBXX,"RC",IBYY))
if 'IBYY
QUIT
SET IBYD=^(IBYY,0)
Begin DoDot:2
+53 ;
+54 ; - Get the procedure code,charge type and total charges for the revenue code.
+55 SET IBZ=$PIECE(IBYD,U,6)
+56 SET IBCT=$SELECT($PIECE(IBYD,U,12):$PIECE(IBYD,U,12),1:$PIECE(IBDATA,U,4))
+57 SET IBTCHRG=$PIECE(IBYD,U,4)
+58 ; Can't determine code/charge type for procedure.
IF 'IBZ!('IBCT)
QUIT
+59 ; Delete procedure from unbilled procedures array.
+60 IF $GET(IBTCHRG)'<$GET(IBCPTSUM(IBZ))
KILL IBCPT(IBZ)
+61 IF $DATA(IBCPT(IBZ,IBCT))
KILL IBCPT(IBZ,IBCT)
End DoDot:2
End DoDot:1
+62 ;
+63 ; - Again, quit if no billable procedures remain.
+64 IF '$DATA(IBCPT)
SET IBRTN=-1
GOTO OPTQ
+65 ; - If there are billable procedures return TOTAL AMOUNT
+66 IF $DATA(IBCPT)
SET (IBZ,IBCT,IBRTN)=0
+67 FOR
SET IBZ=$ORDER(IBCPT(IBZ))
if 'IBZ
QUIT
Begin DoDot:1
+68 FOR
SET IBCT=$ORDER(IBCPT(IBZ,IBCT))
if 'IBCT
QUIT
Begin DoDot:2
+69 SET IBRTN=IBRTN+IBCPT(IBZ,IBCT)
End DoDot:2
End DoDot:1
+70 IF IBRTN=0
SET IBRTN=-1
+71 ;
OPTQ KILL IBCPT
QUIT IBRTN
+1 ;
AVG(EPDT) ; Returns the Average Amount of Inpatient Professional per
+1 ; Number of Episodes for the previous 12 months
+2 NEW AVG,M,Z
+3 SET AVG=0
SET M=EPDT\100*100
+4 IF '$DATA(^IBE(356.19,M,1))
SET M=$ORDER(^IBE(356.19,M),-1)
IF 'M
GOTO QAVG
+5 SET Z=$GET(^IBE(356.19,M,1))
IF $PIECE(Z,U,12)
SET AVG=$PIECE(Z,U,11)/$PIECE(Z,U,12)
QAVG QUIT $JUSTIFY(AVG,0,2)
+1 ;
PRVSPC(EPS,CLM) ; Return the Provider and the Specialty
+1 ; Input: EPS - Episode(1 = Inpatient OR 2 = Outpatient)
+2 ; CLM - Pointer to Claim Tracking File (#356)
+3 ; Output: Provider Code (Pointer to #200) ^ Provider Name ^
+4 ; Specialty Code (Pointer to #40.7 or #45.7) ^ Specialty Name
+5 ;
+6 NEW ADM,DFN,ENC,PRI,PRS,PRV,PRVLST,SPC,STP,X,VAIN,VAINDT
+7 ;
+8 SET X=$GET(^IBT(356,CLM,0))
+9 SET DFN=$PIECE(X,U,2)
SET ENC=$PIECE(X,U,4)
SET ADM=$PIECE(X,U,5)
SET PRS=$PIECE(X,U,8)
+10 ;
+11 SET (PRV,SPC)="^"
+12 ; Inpatient
IF EPS=1
IF ADM
Begin DoDot:1
+13 SET X=$GET(^DGPM(ADM,0))
SET VAINDT=$PIECE(X,U)\1
IF 'VAINDT
QUIT
+14 DO INP^VADPT
SET PRV=$GET(VAIN(11))
SET SPC=$GET(VAIN(3))
+15 if PRV=""
SET PRV="^"
if SPC=""
SET SPC="^"
End DoDot:1
GOTO QPS
+16 ;
+17 ; Outpatient
IF EPS=2
IF ENC
Begin DoDot:1
+18 DO GETPRV^SDOE(ENC,"PRVLST")
+19 SET (X,PRI)=""
+20 FOR
SET X=$ORDER(PRVLST(X),-1)
if X=""!PRI
QUIT
Begin DoDot:2
+21 NEW IBX
SET PRV=+PRVLST(X)
+22 ; Primary provider
IF $PIECE(PRVLST(X),U,4)="P"
SET PRI=1
+23 IF PRV
SET PRV=PRV_U_$PIECE($GET(^VA(200,+PRV,0)),U)
+24 SET IBX=$$GETOE^SDOE(ENC)
SET STP=$PIECE(IBX,U,3)
+25 IF STP'=""
SET SPC=STP_U_$PIECE($GET(^DIC(40.7,STP,0)),U)
End DoDot:2
End DoDot:1
GOTO QPS
+26 ;
QPS QUIT (PRV_U_SPC)
+1 ;
PHDL ; - Print the header line for the Excel spreadsheet
+1 NEW X
+2 SET X="Division^Svc^Patient^SSN^Insurance^Episode Dt^Dt Entered^Dt Lst Edit^"
+3 SET X=X_"Lst Edited By^Next Admission^RNB Cat^Provider^Specialty^Entry Amt^Related Bills^Comments"
+4 WRITE !,X
+5 QUIT
