Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBJDB21

IBJDB21.m

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