RCTCSWL1 ;ALB/PAW-Cross Servicing Worklist ;30-SEP-2015
;;4.5;ACCOUNTS RECEIVABLE;**315,339**;Mar 20, 1995;Build 2
;;Per VA Directive 6402, this routine should not be modified.
;
GETRPT(RCRPT) ; Create patient report based upon report selection
; required input RCRPT (see comments below for number/report correlation)
; output ^TMP("RCTCSWL",$J), containing auths for group queue
N RCBILLEX,RCDATE,RCDEBTOR,RCDFN,RCBILL,RCDBTRN,RCDFN,RCFND1,RCTRAN,RCRTCD,RCRTCDX,RCUNC,RCPIF,RCSPA,RCDIV,RCDIVX
; Loop through ACCOUNTS RECEIVABLE File (#430) Cross-Servicing Index
S RCDATE="" F S RCDATE=$O(^PRCA(430,"AN",RCDATE)) Q:RCDATE="" D
.S RCBILL="" F S RCBILL=$O(^PRCA(430,"AN",RCDATE,RCBILL)) Q:RCBILL="" D
..I +$P($G(^PRCA(430,RCBILL,30)),U,9) Q ;Bill has been removed from CS Reconciliation Worklist
..S RCDEBTOR=$P($G(^PRCA(430,RCBILL,0)),U,9) ;Debtor in File 340
..I $P($G(^RCD(340,RCDEBTOR,0)),U,1)["DPT" S RCDFN=+$P($G(^RCD(340,RCDEBTOR,0)),U,1)
..S RCRTCD=$P($G(^PRCA(430,RCBILL,30)),U,2)
..I RCRTCD="" Q
..S RCRTCDX=$P(^PRCA(430.5,RCRTCD,0),U)
..S RCBILLEX=$P(^PRCA(430,RCBILL,0),U)
..; Check if running for specific Division - MEDICAL CENTER DIVISION File #40.8
..S RCDIV=$P(RCBILLEX,"-")
..S RCDIVX="" I VAUTD=0 I '$D(VAUTD(RCDIV)) Q
..; Check if running for specific Patient
..I $P(FILTERS(0),U,3)=1 I '$D(RCDFN) Q
..I $P(FILTERS(0),U,3)=1 I '$D(FILTERS(2,RCDFN)) Q
..; Specific checks for each type of report
..I RCRPT=1 I RCRTCDX'="B" Q ;Bankruptcy Return Reason code B
..I RCRPT=2 I RCRTCDX'="D" Q ;Death Return Reason Code D
..I RCRPT=3 I RCRTCDX'="Z" Q ;Uncollectable Return Reason Code Z
..I RCRPT=4 I RCRTCDX'="F" Q ;Payment in Full - Return Reason Code = F
..I RCRPT=5 I RCRTCDX'="P" Q ;Satisfied PA - Return Reason Code = P, but nothing in Compromise Field
..I RCRPT=6 I RCRTCDX'="S" Q ;Compromise Field set to Y
..I RCRPT=7 I RCRTCDX="" Q ;Any Return Reason Code
..D BLDTMP
Q
;
BLDTMP ; Build ^TMP("RCTCSWL",$J) for the main list screen
N A1,A2,PRCA3,DFN,RCBAL,RCBILLEX,RCNAME,RCPTID,RCRTRSN,RCLINE,VA,VADM,VAERR,TRTYP,RCBIND
I $D(RCDFN) D
. S DFN=RCDFN
. D DEM^VADPT
. I VAERR K VADM
. S RCNAME=VADM(1)
. S RCPTID=$E(RCNAME,1)_VA("BID")
S A1=$P(^RCD(340,RCDEBTOR,0),";",1),A2=$P($P(^(0),U,1),";",2),PRCA3=U_A2_A1_",0)",RCNAME=$S($D(@PRCA3):$P(^(0),U,1),1:"")
S RCBAL=$$GET1^DIQ(430,RCBILL_",",11)
S RCBILLEX=$P($G(^PRCA(430,RCBILL,0)),U,1) ;External Bill Number
; Set historical indicator "y" when returned from Treasury
I $D(^PRCA(430,"AN",RCDATE,RCBILL)) S RCBIND="y"
S RCLINE=$G(RCNAME)_U_$G(RCPTID)_U_$G(RCBAL)_U_$G(DFN)_U_$G(RCBIND)_$G(RCBILLEX)_U_RCDEBTOR_U_RCBILL_U_RCDATE_U_RCRTCDX
; Sort by Patient Name
I SORTBY=1 S ^TMP("RCTCSWL",$J,RCNAME,RCBILLEX)=RCLINE
; Sort by Bill Number
I SORTBY=2 S ^TMP("RCTCSWL",$J,RCBILLEX,RCNAME)=RCLINE
; Sort by Return Reason Code
I SORTBY=3 S ^TMP("RCTCSWL",$J,RCRTCDX,RCBILLEX)=RCLINE
;
BLDWL ; Format main list screen data lines
; build display lines
K ^TMP("RCTCSWLX",$J)
N RCBILL,RCBILLEX,RCDATE,RCDEBTOR,RCDFN,RCNAME,RCPATNAM,RCPTID,RCRRSN,RCXX,RCY,RCYY,FIRST,LINE,VCNT
S (VALMCNT,FIRST,VCNT)=0
S RCY="" F S RCY=$O(^TMP("RCTCSWL",$J,RCY)) Q:RCY="" D
.S RCYY="" F S RCYY=$O(^TMP("RCTCSWL",$J,RCY,RCYY)) Q:RCYY="" D
..S VCNT=VCNT+1
..S LINE=$$LJ^XLFSTR(VCNT,6) ;line #
..S RCXX=^TMP("RCTCSWL",$J,RCY,RCYY)
..S RCPATNAM=$P(RCXX,U)
..S RCPTID=$P(RCXX,U,2)
..S RCDFN=$P(RCXX,U,4)
..S RCBILLEX=$P(RCXX,U,5)
..S RCDEBTOR=$P(RCXX,U,6)
..S RCBILL=$P(RCXX,U,7)
..S RCDATE=$P(RCXX,U,8)
..S RCRRSN=$P(RCXX,U,9)
..I SORTBY=1 D
...;Patient^Patient ID^Bill No.^Balance^Ret Rsn
...S LINE=$$SETL(LINE,$P(RCXX,U),"",4,27)
...S LINE=$$SETL(LINE,$P(RCXX,U,2),"",32,5)
...S LINE=$$SETL(LINE,$P(RCXX,U,5),"",40,12)
...S LINE=$$SETL(LINE,$J($P(RCXX,U,3),10,2),"",55,12)
...S LINE=$$SETL(LINE,$P(RCXX,U,9),"",67,3)
..I SORTBY=2 D
...;Bill No.^Patient ID^Patient^Balance^Ret Rsn
...S LINE=$$SETL(LINE,$P(RCXX,U,5),"",4,12)
...S LINE=$$SETL(LINE,$P(RCXX,U,2),"",17,5)
...S LINE=$$SETL(LINE,$P(RCXX,U),"",24,27)
...S LINE=$$SETL(LINE,$J($P(RCXX,U,3),10,2),"",55,12)
...S LINE=$$SETL(LINE,$P(RCXX,U,9),"",67,3)
..I SORTBY=3 D
...;Ret Rsn^Bill No.^Pt ID^Patient^Balance
...S LINE=$$SETL(LINE,$P(RCXX,U,9),"",4,7)
...S LINE=$$SETL(LINE,$P(RCXX,U,5),"",12,12)
...S LINE=$$SETL(LINE,$P(RCXX,U,2),"",25,5)
...S LINE=$$SETL(LINE,$P(RCXX,U),"",32,27)
...S LINE=$$SETL(LINE,$J($P(RCXX,U,2),10,2),"",64,12)
..S VALMCNT=VALMCNT+1
..D SET^VALM10(VALMCNT,LINE,VCNT)
..S ^TMP("RCTCSWLX",$J,VCNT)=RCDFN_U_RCPATNAM_U_RCPTID_U_RCDEBTOR_U_RCBILL_U_RCBILLEX_U_RCDATE_U_RCRRSN ;This is set for ACTIONS
Q
;
SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
; of the worklist
; Input: LINE - Current line being created
; DATA - Information to be added to the end of the current line
; LABEL - Label to describe the information being added
; COL - Column position in line to add information add
; LNG - Maximum length of data information to include on the line
; Returns: Line updated with added information
S LINE=LINE_$J("",(COL-$L(LABEL)-$L(LINE)))_LABEL_$E(DATA,1,LNG)
Q LINE
;
EXCEL ;Format and Print EXCEL file
W @IOF
N RCX,RCXX,RCY,RCYY,RCZ,RCAMT
S RCX=$P(FILTERS(0),U,1)
S RCXX=$S(RCX=1:"Bankruptcy",RCX=2:"Deaths",RCX=3:"Uncollectible",RCX=4:"Payment in Full",1:"")
I $G(RCXX)="" S RCXX=$S(RCX=5:"Satisfied PA",RCX=6:"Compromise",RCX=7:"All Returns",1:"")
W !,RCXX_" Report"
I SORTBY=1 W !,"Patient Name^Patient ID^Bill Number^Current Amount^Rt Rsn Code"
I SORTBY=2 W !,"Bill Number^Patient ID^Patient Name^Current Amount^Rt Rsn Code"
I SORTBY=3 W !,"Rt Rsn Code^Bill Number^Patient ID^Patient Name^Current Amount"
S RCY="" F S RCY=$O(^TMP("RCTCSWL",$J,RCY)) Q:RCY="" D
.S RCYY="" F S RCYY=$O(^TMP("RCTCSWL",$J,RCY,RCYY)) Q:RCYY="" D
..S RCZ=^TMP("RCTCSWL",$J,RCY,RCYY)
..;Reformat Excel line, based upon sort
..;Input from RCZ: PtName_U_PtID_U_CurBal_U_DFN_U_Bill No_U_Debtor_U_InternalBill_U_Date_U_ReturnReasonCode
..S RCAMT=$P(RCZ,U,3)
..I RCAMT="" S RCAMT=0
..S RCAMT=$J(RCAMT,10,2)
..I SORTBY=1 W !,$P(RCZ,U)_"^",$P(RCZ,U,2)_"^"_$P(RCZ,U,5)_"^"_RCAMT_"^"_$P(RCZ,U,9)
..I SORTBY=2 W !,$P(RCZ,U,5)_"^",$P(RCZ,U,2)_"^"_$P(RCZ,U)_"^"_RCAMT_"^"_$P(RCZ,U,9)
..I SORTBY=3 W !,$P(RCZ,U,9)_"^",$P(RCZ,U,5)_"^"_$P(RCZ,U,2)_"^"_$P(RCZ,U)_"^"_RCAMT
I $E(IOST,1,2)="C-",'EXCEL R !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME W @IOF
D ^%ZISC
S:$D(ZTQUEUED) ZTREQ="@"
K IOP,%ZIS,ZTQUEUED
Q
;
;RCDIV() N DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y
;
;Reset RCDIV array
K RCDIV
;
;First see if they want to enter individual divisions or ALL
S DIR(0)="S^D:DIVISION;A:ALL"
S DIR("A")="Select Certain (D)ivisions or (A)LL"
S DIR("L",1)="Select one of the following:"
S DIR("L",2)=""
S DIR("L",3)=" D DIVISION"
S DIR("L",4)=" A ALL"
D ^DIR K DIR
;
;Check for "^" or timeout, otherwise define BPPHARM
I ($G(DUOUT)=1)!($G(DTOUT)=1) S Y="^"
E S RCDIV=$S(Y="A":0,1:1)
;
;If division selected, ask prompt
I $G(RCDIV)=1 F D Q:Y="^"!(Y="")
.;
.;Prompt for entry
.K X S DIC(0)="QEAM",DIC=40.8,DIC("A")="Select Division(s): "
.W ! D ^DIC
.;
.;Check for "^" or timeout
.I ($G(DUOUT)=1)!($G(DTOUT)=1) K RCDIV S Y="^" Q
.;
.;Check for blank entry, quit if no previous selections
.I $G(X)="" S Y=$S($D(RCDIV)>9:"",1:"^") K:Y="^" RCDIV Q
.;
.;Handle Deletes
.I $D(RCDIV(+Y)) D Q:Y="^" I 1
..N P
..S P=Y ;Save Original Value
..S DIR(0)="S^Y:YES;N:NO",DIR("A")="Delete "_$P(P,U,2)_" from your list?"
..S DIR("B")="NO" D ^DIR
..I ($G(DUOUT)=1)!($G(DTOUT)=1) K RCDIV S Y="^" Q
..I Y="Y" K RCDIV(+P),RCDIV("B",$P(P,U,2),+P)
..S Y=P ;Restore Original Value
..K P
.E D
..;Define new entries in RCDIV array
..S VAUTD(+Y)=Y
..S RCDIV("B",$P(Y,U,2),+Y)=""
.;
.;Display a list of selected divisions
.I $D(RCDIV)>9 D
..N X
..W !,?2,"Selected:"
..S X="" F S X=$O(RCDIV("B",X)) Q:X="" W !,?10,X
..K X
.Q
;
K RCDIV("B")
Q Y
;
CSTOP(BILL) ;
; Input:
; BILL - Bill number from #430 - External Value (.01), not IEN
; Output:
; CSTOP - Cross-serviced status (blank = not found, 0 = not stopped, 1 = stopped)
;
N CSTOP,IEN
I BILL="" Q "" ;no bill #
I '$D(^PRCA(430,"TCSP",BILL)) Q ""
S CSTOP=$$GET1^DIQ(430,BILL,"157,","IE")
Q CSTOP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCTCSWL1 8497 printed Oct 16, 2024@17:49:51 Page 2
RCTCSWL1 ;ALB/PAW-Cross Servicing Worklist ;30-SEP-2015
+1 ;;4.5;ACCOUNTS RECEIVABLE;**315,339**;Mar 20, 1995;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
GETRPT(RCRPT) ; Create patient report based upon report selection
+1 ; required input RCRPT (see comments below for number/report correlation)
+2 ; output ^TMP("RCTCSWL",$J), containing auths for group queue
+3 NEW RCBILLEX,RCDATE,RCDEBTOR,RCDFN,RCBILL,RCDBTRN,RCDFN,RCFND1,RCTRAN,RCRTCD,RCRTCDX,RCUNC,RCPIF,RCSPA,RCDIV,RCDIVX
+4 ; Loop through ACCOUNTS RECEIVABLE File (#430) Cross-Servicing Index
+5 SET RCDATE=""
FOR
SET RCDATE=$ORDER(^PRCA(430,"AN",RCDATE))
if RCDATE=""
QUIT
Begin DoDot:1
+6 SET RCBILL=""
FOR
SET RCBILL=$ORDER(^PRCA(430,"AN",RCDATE,RCBILL))
if RCBILL=""
QUIT
Begin DoDot:2
+7 ;Bill has been removed from CS Reconciliation Worklist
IF +$PIECE($GET(^PRCA(430,RCBILL,30)),U,9)
QUIT
+8 ;Debtor in File 340
SET RCDEBTOR=$PIECE($GET(^PRCA(430,RCBILL,0)),U,9)
+9 IF $PIECE($GET(^RCD(340,RCDEBTOR,0)),U,1)["DPT"
SET RCDFN=+$PIECE($GET(^RCD(340,RCDEBTOR,0)),U,1)
+10 SET RCRTCD=$PIECE($GET(^PRCA(430,RCBILL,30)),U,2)
+11 IF RCRTCD=""
QUIT
+12 SET RCRTCDX=$PIECE(^PRCA(430.5,RCRTCD,0),U)
+13 SET RCBILLEX=$PIECE(^PRCA(430,RCBILL,0),U)
+14 ; Check if running for specific Division - MEDICAL CENTER DIVISION File #40.8
+15 SET RCDIV=$PIECE(RCBILLEX,"-")
+16 SET RCDIVX=""
IF VAUTD=0
IF '$DATA(VAUTD(RCDIV))
QUIT
+17 ; Check if running for specific Patient
+18 IF $PIECE(FILTERS(0),U,3)=1
IF '$DATA(RCDFN)
QUIT
+19 IF $PIECE(FILTERS(0),U,3)=1
IF '$DATA(FILTERS(2,RCDFN))
QUIT
+20 ; Specific checks for each type of report
+21 ;Bankruptcy Return Reason code B
IF RCRPT=1
IF RCRTCDX'="B"
QUIT
+22 ;Death Return Reason Code D
IF RCRPT=2
IF RCRTCDX'="D"
QUIT
+23 ;Uncollectable Return Reason Code Z
IF RCRPT=3
IF RCRTCDX'="Z"
QUIT
+24 ;Payment in Full - Return Reason Code = F
IF RCRPT=4
IF RCRTCDX'="F"
QUIT
+25 ;Satisfied PA - Return Reason Code = P, but nothing in Compromise Field
IF RCRPT=5
IF RCRTCDX'="P"
QUIT
+26 ;Compromise Field set to Y
IF RCRPT=6
IF RCRTCDX'="S"
QUIT
+27 ;Any Return Reason Code
IF RCRPT=7
IF RCRTCDX=""
QUIT
+28 DO BLDTMP
End DoDot:2
End DoDot:1
+29 QUIT
+30 ;
BLDTMP ; Build ^TMP("RCTCSWL",$J) for the main list screen
+1 NEW A1,A2,PRCA3,DFN,RCBAL,RCBILLEX,RCNAME,RCPTID,RCRTRSN,RCLINE,VA,VADM,VAERR,TRTYP,RCBIND
+2 IF $DATA(RCDFN)
Begin DoDot:1
+3 SET DFN=RCDFN
+4 DO DEM^VADPT
+5 IF VAERR
KILL VADM
+6 SET RCNAME=VADM(1)
+7 SET RCPTID=$EXTRACT(RCNAME,1)_VA("BID")
End DoDot:1
+8 SET A1=$PIECE(^RCD(340,RCDEBTOR,0),";",1)
SET A2=$PIECE($PIECE(^(0),U,1),";",2)
SET PRCA3=U_A2_A1_",0)"
SET RCNAME=$SELECT($DATA(@PRCA3):$PIECE(^(0),U,1),1:"")
+9 SET RCBAL=$$GET1^DIQ(430,RCBILL_",",11)
+10 ;External Bill Number
SET RCBILLEX=$PIECE($GET(^PRCA(430,RCBILL,0)),U,1)
+11 ; Set historical indicator "y" when returned from Treasury
+12 IF $DATA(^PRCA(430,"AN",RCDATE,RCBILL))
SET RCBIND="y"
+13 SET RCLINE=$GET(RCNAME)_U_$GET(RCPTID)_U_$GET(RCBAL)_U_$GET(DFN)_U_$GET(RCBIND)_$GET(RCBILLEX)_U_RCDEBTOR_U_RCBILL_U_RCDATE_U_RCRTCDX
+14 ; Sort by Patient Name
+15 IF SORTBY=1
SET ^TMP("RCTCSWL",$JOB,RCNAME,RCBILLEX)=RCLINE
+16 ; Sort by Bill Number
+17 IF SORTBY=2
SET ^TMP("RCTCSWL",$JOB,RCBILLEX,RCNAME)=RCLINE
+18 ; Sort by Return Reason Code
+19 IF SORTBY=3
SET ^TMP("RCTCSWL",$JOB,RCRTCDX,RCBILLEX)=RCLINE
+20 ;
BLDWL ; Format main list screen data lines
+1 ; build display lines
+2 KILL ^TMP("RCTCSWLX",$JOB)
+3 NEW RCBILL,RCBILLEX,RCDATE,RCDEBTOR,RCDFN,RCNAME,RCPATNAM,RCPTID,RCRRSN,RCXX,RCY,RCYY,FIRST,LINE,VCNT
+4 SET (VALMCNT,FIRST,VCNT)=0
+5 SET RCY=""
FOR
SET RCY=$ORDER(^TMP("RCTCSWL",$JOB,RCY))
if RCY=""
QUIT
Begin DoDot:1
+6 SET RCYY=""
FOR
SET RCYY=$ORDER(^TMP("RCTCSWL",$JOB,RCY,RCYY))
if RCYY=""
QUIT
Begin DoDot:2
+7 SET VCNT=VCNT+1
+8 ;line #
SET LINE=$$LJ^XLFSTR(VCNT,6)
+9 SET RCXX=^TMP("RCTCSWL",$JOB,RCY,RCYY)
+10 SET RCPATNAM=$PIECE(RCXX,U)
+11 SET RCPTID=$PIECE(RCXX,U,2)
+12 SET RCDFN=$PIECE(RCXX,U,4)
+13 SET RCBILLEX=$PIECE(RCXX,U,5)
+14 SET RCDEBTOR=$PIECE(RCXX,U,6)
+15 SET RCBILL=$PIECE(RCXX,U,7)
+16 SET RCDATE=$PIECE(RCXX,U,8)
+17 SET RCRRSN=$PIECE(RCXX,U,9)
+18 IF SORTBY=1
Begin DoDot:3
+19 ;Patient^Patient ID^Bill No.^Balance^Ret Rsn
+20 SET LINE=$$SETL(LINE,$PIECE(RCXX,U),"",4,27)
+21 SET LINE=$$SETL(LINE,$PIECE(RCXX,U,2),"",32,5)
+22 SET LINE=$$SETL(LINE,$PIECE(RCXX,U,5),"",40,12)
+23 SET LINE=$$SETL(LINE,$JUSTIFY($PIECE(RCXX,U,3),10,2),"",55,12)
+24 SET LINE=$$SETL(LINE,$PIECE(RCXX,U,9),"",67,3)
End DoDot:3
+25 IF SORTBY=2
Begin DoDot:3
+26 ;Bill No.^Patient ID^Patient^Balance^Ret Rsn
+27 SET LINE=$$SETL(LINE,$PIECE(RCXX,U,5),"",4,12)
+28 SET LINE=$$SETL(LINE,$PIECE(RCXX,U,2),"",17,5)
+29 SET LINE=$$SETL(LINE,$PIECE(RCXX,U),"",24,27)
+30 SET LINE=$$SETL(LINE,$JUSTIFY($PIECE(RCXX,U,3),10,2),"",55,12)
+31 SET LINE=$$SETL(LINE,$PIECE(RCXX,U,9),"",67,3)
End DoDot:3
+32 IF SORTBY=3
Begin DoDot:3
+33 ;Ret Rsn^Bill No.^Pt ID^Patient^Balance
+34 SET LINE=$$SETL(LINE,$PIECE(RCXX,U,9),"",4,7)
+35 SET LINE=$$SETL(LINE,$PIECE(RCXX,U,5),"",12,12)
+36 SET LINE=$$SETL(LINE,$PIECE(RCXX,U,2),"",25,5)
+37 SET LINE=$$SETL(LINE,$PIECE(RCXX,U),"",32,27)
+38 SET LINE=$$SETL(LINE,$JUSTIFY($PIECE(RCXX,U,2),10,2),"",64,12)
End DoDot:3
+39 SET VALMCNT=VALMCNT+1
+40 DO SET^VALM10(VALMCNT,LINE,VCNT)
+41 ;This is set for ACTIONS
SET ^TMP("RCTCSWLX",$JOB,VCNT)=RCDFN_U_RCPATNAM_U_RCPTID_U_RCDEBTOR_U_RCBILL_U_RCBILLEX_U_RCDATE_U_RCRRSN
End DoDot:2
End DoDot:1
+42 QUIT
+43 ;
SETL(LINE,DATA,LABEL,COL,LNG) ; Creates a line of data to be set into the body
+1 ; of the worklist
+2 ; Input: LINE - Current line being created
+3 ; DATA - Information to be added to the end of the current line
+4 ; LABEL - Label to describe the information being added
+5 ; COL - Column position in line to add information add
+6 ; LNG - Maximum length of data information to include on the line
+7 ; Returns: Line updated with added information
+8 SET LINE=LINE_$JUSTIFY("",(COL-$LENGTH(LABEL)-$LENGTH(LINE)))_LABEL_$EXTRACT(DATA,1,LNG)
+9 QUIT LINE
+10 ;
EXCEL ;Format and Print EXCEL file
+1 WRITE @IOF
+2 NEW RCX,RCXX,RCY,RCYY,RCZ,RCAMT
+3 SET RCX=$PIECE(FILTERS(0),U,1)
+4 SET RCXX=$SELECT(RCX=1:"Bankruptcy",RCX=2:"Deaths",RCX=3:"Uncollectible",RCX=4:"Payment in Full",1:"")
+5 IF $GET(RCXX)=""
SET RCXX=$SELECT(RCX=5:"Satisfied PA",RCX=6:"Compromise",RCX=7:"All Returns",1:"")
+6 WRITE !,RCXX_" Report"
+7 IF SORTBY=1
WRITE !,"Patient Name^Patient ID^Bill Number^Current Amount^Rt Rsn Code"
+8 IF SORTBY=2
WRITE !,"Bill Number^Patient ID^Patient Name^Current Amount^Rt Rsn Code"
+9 IF SORTBY=3
WRITE !,"Rt Rsn Code^Bill Number^Patient ID^Patient Name^Current Amount"
+10 SET RCY=""
FOR
SET RCY=$ORDER(^TMP("RCTCSWL",$JOB,RCY))
if RCY=""
QUIT
Begin DoDot:1
+11 SET RCYY=""
FOR
SET RCYY=$ORDER(^TMP("RCTCSWL",$JOB,RCY,RCYY))
if RCYY=""
QUIT
Begin DoDot:2
+12 SET RCZ=^TMP("RCTCSWL",$JOB,RCY,RCYY)
+13 ;Reformat Excel line, based upon sort
+14 ;Input from RCZ: PtName_U_PtID_U_CurBal_U_DFN_U_Bill No_U_Debtor_U_InternalBill_U_Date_U_ReturnReasonCode
+15 SET RCAMT=$PIECE(RCZ,U,3)
+16 IF RCAMT=""
SET RCAMT=0
+17 SET RCAMT=$JUSTIFY(RCAMT,10,2)
+18 IF SORTBY=1
WRITE !,$PIECE(RCZ,U)_"^",$PIECE(RCZ,U,2)_"^"_$PIECE(RCZ,U,5)_"^"_RCAMT_"^"_$PIECE(RCZ,U,9)
+19 IF SORTBY=2
WRITE !,$PIECE(RCZ,U,5)_"^",$PIECE(RCZ,U,2)_"^"_$PIECE(RCZ,U)_"^"_RCAMT_"^"_$PIECE(RCZ,U,9)
+20 IF SORTBY=3
WRITE !,$PIECE(RCZ,U,9)_"^",$PIECE(RCZ,U,5)_"^"_$PIECE(RCZ,U,2)_"^"_$PIECE(RCZ,U)_"^"_RCAMT
End DoDot:2
End DoDot:1
+21 IF $EXTRACT(IOST,1,2)="C-"
IF 'EXCEL
READ !!,"END OF REPORT...PRESS RETURN TO CONTINUE",X:DTIME
WRITE @IOF
+22 DO ^%ZISC
+23 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+24 KILL IOP,%ZIS,ZTQUEUED
+25 QUIT
+26 ;
+27 ;RCDIV() N DIC,DIR,DIRUT,DTOUT,DUOUT,X,Y
+28 ;
+29 ;Reset RCDIV array
+30 KILL RCDIV
+31 ;
+32 ;First see if they want to enter individual divisions or ALL
+33 SET DIR(0)="S^D:DIVISION;A:ALL"
+34 SET DIR("A")="Select Certain (D)ivisions or (A)LL"
+35 SET DIR("L",1)="Select one of the following:"
+36 SET DIR("L",2)=""
+37 SET DIR("L",3)=" D DIVISION"
+38 SET DIR("L",4)=" A ALL"
+39 DO ^DIR
KILL DIR
+40 ;
+41 ;Check for "^" or timeout, otherwise define BPPHARM
+42 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
SET Y="^"
+43 IF '$TEST
SET RCDIV=$SELECT(Y="A":0,1:1)
+44 ;
+45 ;If division selected, ask prompt
+46 IF $GET(RCDIV)=1
FOR
Begin DoDot:1
+47 ;
+48 ;Prompt for entry
+49 KILL X
SET DIC(0)="QEAM"
SET DIC=40.8
SET DIC("A")="Select Division(s): "
+50 WRITE !
DO ^DIC
+51 ;
+52 ;Check for "^" or timeout
+53 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
KILL RCDIV
SET Y="^"
QUIT
+54 ;
+55 ;Check for blank entry, quit if no previous selections
+56 IF $GET(X)=""
SET Y=$SELECT($DATA(RCDIV)>9:"",1:"^")
if Y="^"
KILL RCDIV
QUIT
+57 ;
+58 ;Handle Deletes
+59 IF $DATA(RCDIV(+Y))
Begin DoDot:2
+60 NEW P
+61 ;Save Original Value
SET P=Y
+62 SET DIR(0)="S^Y:YES;N:NO"
SET DIR("A")="Delete "_$PIECE(P,U,2)_" from your list?"
+63 SET DIR("B")="NO"
DO ^DIR
+64 IF ($GET(DUOUT)=1)!($GET(DTOUT)=1)
KILL RCDIV
SET Y="^"
QUIT
+65 IF Y="Y"
KILL RCDIV(+P),RCDIV("B",$PIECE(P,U,2),+P)
+66 ;Restore Original Value
SET Y=P
+67 KILL P
End DoDot:2
if Y="^"
QUIT
IF 1
+68 IF '$TEST
Begin DoDot:2
+69 ;Define new entries in RCDIV array
+70 SET VAUTD(+Y)=Y
+71 SET RCDIV("B",$PIECE(Y,U,2),+Y)=""
End DoDot:2
+72 ;
+73 ;Display a list of selected divisions
+74 IF $DATA(RCDIV)>9
Begin DoDot:2
+75 NEW X
+76 WRITE !,?2,"Selected:"
+77 SET X=""
FOR
SET X=$ORDER(RCDIV("B",X))
if X=""
QUIT
WRITE !,?10,X
+78 KILL X
End DoDot:2
+79 QUIT
End DoDot:1
if Y="^"!(Y="")
QUIT
+80 ;
+81 KILL RCDIV("B")
+82 QUIT Y
+83 ;
CSTOP(BILL) ;
+1 ; Input:
+2 ; BILL - Bill number from #430 - External Value (.01), not IEN
+3 ; Output:
+4 ; CSTOP - Cross-serviced status (blank = not found, 0 = not stopped, 1 = stopped)
+5 ;
+6 NEW CSTOP,IEN
+7 ;no bill #
IF BILL=""
QUIT ""
+8 IF '$DATA(^PRCA(430,"TCSP",BILL))
QUIT ""
+9 SET CSTOP=$$GET1^DIQ(430,BILL,"157,","IE")
+10 QUIT CSTOP
