RCVCR1 ;SLC/LLB/JC - First Party Veterans Charge Report ; SEP 9,2020@16:17
;;4.5;Accounts Receivable;**373,379**;Mar 20, 1995;Build 16
;;Per VA Directive 6402, this routine should not be modified.
;
;External References Type ICR #
;------------------- --------- -----
; HOME^%ZIS Supported 10086
; ^DIC Supported 10006
; ^DIQ Supported 10004
; EN^DIQ1 Supported 10015
; ^DIR Supported 10026
; RX^PSO52API Supported 4820
; DEM^VADPT Supported 10061
; $$FMTE^XLFDT Supported 10103
; $$NOW^XLFDT Supported 10103
; $$CJ^XLFSTR Supported 10104
; $$STRIP^XLFSTR Supported 10104
; EN^XUTMDEVQ Supported 1519
;
;ICR# TYPE DESCRIPTION
;----- ---------- ---------------------
; 7218 Private File (#350), access to fields (#.08),(#.09),(#.1),(#.12),(#.18),(#.19),(#.2),(#12),(#13),(#14)
; 4541 Private File (#350), access to the "C" cross-reference and fields (#.01),(#.02),(#.03),(#.04),(#.05),(#.06),(#.07),(#.11),(#.14),(#.15),(#.16),(#.17)
;
START ;
N DFN,VETNM,FRMDT,FRMDTINT,TODT,TODTINT,IBSVCTYP,IBSVCNM,IBQUIT,DGPAGE
N IBSTAT,IBSTATNM,POP,%ZIS,X,ZTSAVE,Y,LETTER,STAT,SSN,DIRUT,IBRXNAM
S (POP,DIRUT,IBQUIT,DGPAGE)=0
D INIT
I POP Q
W !!,"The number of characters per row should be set to 256."
W !,"Please use the following path to modify the display settings:"
W !,"In Reflections. File >>> Settings >>> Terminal Configuration"
W !," >>> Set Up Display Settings >>> Number of characters per row",!
W !,"To capture as a spreadsheet format, at the DEVICE prompt, please accept the"
W !,"default value of 0;256;99999. This should help avoid wrapping problems.",!
W !,"For pagination, please use "";256;"" for the device value instead of the default.",!
S %ZIS=""
S %ZIS("B")="0;256;99999"
S ZTSAVE("FRMDTINT")=""
S ZTSAVE("LETTER")=""
S X="FIRST PARTY VETERAN CHARGE REPORT"
D EN^XUTMDEVQ("DISPHEAD^RCVCR1",X,.ZTSAVE,.%ZIS)
D HOME^%ZIS
D CLEAN
Q
;
INIT ;
;
W @IOF
W !,"*** Print the First Party Veteran Charge Report ***",!
W !,"This report captures detailed 1st party bill information for a specific "
W !,"Veteran, within a user specified range of dates of service."
W !,"This report output requires screen size of 256 characters wide.",!
; Get Veteran Name
S DIC="^DPT(",DIC(0)="AQEZMV",DIC("A")="Enter Veteran Name: "
D ^DIC
K DIC
I +Y<1 K DIC S POP=1 Q
S DFN=$P(Y,U)
S VETNM=$P(Y,U,2)
D DEM^VADPT
S SSN=$P(VADM(2),U,1)
;Get From date
W !
N DIR
S DIR(0)="DO^:DT:EX"
S DIR("A")="Enter From Date "
D ^DIR
I +Y<1 K DIR S POP=1 Q
K DIR
S FRMDT=X,FRMDTINT=Y
;Get To date
S DIR(0)="DA^"_FRMDTINT_":"_DT_":EX"
S Y=DT D D^DIQ S DIR("B")="TODAY"
S DIR("A")="Enter To Date: "
D ^DIR
I +Y<1 K DIR S POP=1 Q
K DIR
S TODT=X,TODTINT=Y
; Get Service Type
S DIR(0)="SO^1:Medical Care;2:Outpatient Medication;3:Both (Medical Care and Outpatient Medication)"
S DIR("L",1)="Which type of copayment do you wish to see?"
S DIR("L",2)=" 1. Medical Care"
S DIR("L",3)=" 2. Outpatient Medication"
S DIR("L")=" 3. Both (Medical Care and Outpatient Medication)"
S DIR("B")="3"
S DIR("A")="Enter selection (1,2 or 3) "
D ^DIR
K DIR
I +Y<1!(+Y>3) K DIR S POP=1 Q
S IBSVCTYP=Y,IBSVCNM=Y(0)
; Get IB Status
S DIR(0)="SO^1:Billed;2:On Hold;3:Cancelled;4:All (Billed, On Hold, Cancelled)"
S DIR("L",1)="Which IB status for the selected copayment(s) do you wish to see?"
S DIR("L",2)=" 1. Billed"
S DIR("L",3)=" 2. On Hold"
S DIR("L",4)=" 3. Cancelled"
S DIR("L")=" 4. All (Billed, On Hold, Cancelled)"
S DIR("B")="4"
S DIR("A")="Enter Status selection (1,2,3 or 4) "
D ^DIR
K DIR
I +Y<1!(+Y>4) K DIR S POP=1 Q
S IBSTAT=Y,IBSTATNM=Y(0)
;Ask if Letters should print
W !
S DIR("A")="Enter Selection (1,2,or 3) "
S DIR(0)="SO^1:Letter Dates;2:Total Payments Received on Bill Number;3:Neither"
S DIR("L",1)="Do you want to see: "
S DIR("L",2)=" 1. Letter Dates"
S DIR("L",3)=" 2. Total Payments Received on Bill Number"
S DIR("L")=" 3. Neither"
S DIR("B")="3"
D ^DIR
I $G(DIRUT) S POP=1 Q
K DIR
I +Y<1!(+Y>3) K DIR S POP=1 Q
S LETTER=Y
Q
;
DISPHEAD ; Write report header
;
W @IOF
W !,"First Party Veteran Charge Report",!
W !,"Run date: ",$$FMTE^XLFDT($$NOW^XLFDT,"MP")
W !,"Service Dates From ",$$FMTE^XLFDT(FRMDTINT,"5D")," To ",$$FMTE^XLFDT(TODTINT,"5D")
W !,"Copayment Type Selected: ",IBSVCNM
W !,"IB Status Selected: ",IBSTATNM
N TRM S TRM=($E(IOST)="C")
W !!
D PRTCOLHD
D RUNRPT
D OUTPRPT
Q:IBQUIT
D ASKCONT(0)
Q
;
ASKCONT(FLAG) ; display "press <Enter> to continue" prompt
N Z
W !!,$$CJ^XLFSTR("Press <Enter> to "_$S(FLAG=1:"continue.",1:"exit."),20)
R !,Z:DTIME
Q
;
PRTCOLHD ;
;
N COL,CNT,CNAME,LENGTH,END,SCOL,LOC
S END=255,SCOL=21,COL=0
;I $G(LETTER)="NO" S END=220,SCOL=17
I $G(LETTER)'=1 S END=220,SCOL=17 ;JMC If Total Payment or Neither selected
S DGPAGE=$G(DGPAGE)+1
F CNT=1:1:SCOL D
. S CNAME=$P($T(COLHD+CNT),U,2)
. S LENGTH=$P($T(COLHD+CNT),U,4)
. S LOC=COL+((LENGTH-$L(CNAME))\2)
. I CNT>1 S LOC=LOC+1
. W ?LOC,CNAME
. S COL=COL+LENGTH
. I CNT>1 S COL=COL+1
. I CNT<SCOL W ?COL,"^"
I $G(LETTER)=2 W ?223,"^Total Principal"
W !
S COL=0
F CNT=1:1:SCOL D
. S CNAME=$P($T(COLHD+CNT),U,3)
. S LENGTH=$P($T(COLHD+CNT),U,4)
. S LOC=COL+((LENGTH-$L(CNAME))\2)
. I CNT>1 S LOC=LOC+1
. S COL=COL+LENGTH
. W ?LOC,CNAME
. I CNT>1 S COL=COL+1
. I CNT<SCOL W ?COL,"^"
I $G(LETTER)=2 W ?223,"^Paid on Bill Number"
Q
COLHD ; $T target. Format: Column #^1st row data^2nd row data^Field Width
;;1^^Veteran Name^26
;;2^^SSN^9
;;3^^Bill Number^11
;;4^^Category^26
;;5^Charge^Amount^8
;;6^Unit^Day^4
;;7^Medical^DOS^7
;;8^Release^RX DT^7
;;9^^RX Number^12
;;10^^RX Name^16
;;11^^IB Status^13
;;12^^AR Status^21
;;13^Cancel^Date^7
;;14^Cancellation^Reason^14
;;15^^Cancelled By^16
;;16^^APPR^6
;;17^^RSC^4
;;18^^Letter1^7
;;19^^Letter2^7
;;20^^Letter3^7
;;21^^Letter4^7
Q
;
RUNRPT ;Gather data for Report
D GET350
I IBSTAT=4 D GET399^RCVCR2 ; Only pull file #399 data if user selected All as the desired IB Status
Q
;
GET350 ; Collect data originating from the INTEGRATED BILLING ACTION file (#350)
;
N IBIEN,IB0,STATLST,CNT,STATLST,LINE,RESULT,IBSTATNM,POP,SVCTYP,BILLNUM
N DATEINFO,TRIGDT,SVCDT,XTEMP,DIC,DR,DA,DIQ,FBILLNUM,LCNT,LTRFLD,RC430IEN
N TLTR,IBCANCLR,IBCANCLD,IBCANCLB,ARSTAT,ARAPPR,ARRSC,ARIEN,ARFLDS,RC430TPR
S (IBIEN,IBCANCLR,ICANCLD,IBCANCLB)="",(CNT,RC430TPR)=0
; STATUS=BILLED,ON HOLD,CANCELLED, or ALL
S STATLST=$S(IBSTAT=1:"/3/",IBSTAT=2:"/8/",IBSTAT=3:"/10/",1:"/3/8/10/")
K ^TMP($J,"RCVCR")
F S IBIEN=$O(^IB("C",DFN,IBIEN)) Q:IBIEN="" D
. K IBFLDS
. S DIC=350,DR=".01:.07;.08;.09:.12;.14:.2;12:14",DA=IBIEN,DIQ="IBFLDS",DIQ(0)="IE" D EN^DIQ1
. S STAT="/"_IBFLDS(350,IBIEN,.05,"I")_"/"
. S DATEINFO=$$GETDTS
. I DATEINFO["#" D
. . S RXDATE=IBFLDS(350,IBIEN,12,"I")
. . S RXNUM=$E(IBFLDS(350,IBIEN,.08,"E"),1,12)
. . S RXNAME=""
. . S DATEINFO="RX/"_"350/"_RXDATE_"/"_RXDATE_"/"_RXNUM_"/"_$E(RXNAME,1,16)
. S TRIGDT=$P(DATEINFO,"/",3)
. S SVCDT=$P(DATEINFO,"/",4)
. I TRIGDT'<FRMDTINT,TRIGDT'>TODTINT,(STATLST[STAT) D
. . ;Check Service Type
. . S RESULT=IBFLDS(350,IBIEN,.04,"I"),SVCTYP=$P(RESULT,":",1)
. . I IBSVCTYP=1,(SVCTYP=52!(IBFLDS(350,IBIEN,.03,"E")["RX")) Q ;Only include Medical
. . I IBSVCTYP=2,(SVCTYP'=52),(IBFLDS(350,IBIEN,.03,"E")'["RX") Q ;Only include RX
. . ;Get Cancellation information if it exists
. . S IBCANCLR=IBFLDS(350,IBIEN,.1,"E")
. . S IBCANCLD=IBFLDS(350,IBIEN,14,"I")
. . S IBCANCLB=IBFLDS(350,IBIEN,13,"E")
. . ;Get data & Set into scratch global ^TMP($J,"RCVCR",BILLNUM,DATE,CNT)=
. . ;FILE#^IBIEN^REF#^PARENT CHARGE^PARENT EVENT^STATUS^UNITS^TOTAL CHARG^AR BILL NUMBER^CATEGORY
. . ;MEDICAL DOS^Release RX DT^RX #^RX Name^
. . ;CNT is used to distinguish entries with the same Bill Number
. . S (CNT,ARIEN)=0
. . S FBILLNUM=IBFLDS(350,IBIEN,.11,"I") I FBILLNUM="" S BILLNUM=0
. . I FBILLNUM["-" S BILLNUM=$P(FBILLNUM,"-",2)
. . I BILLNUM'="" S ARIEN=$O(^PRCA(430,"D",BILLNUM,"")) ;Get IEN to 430 based on bill number
. . S (ARSTAT,ARAPPR,ARRSC)=""
. . I BILLNUM'="",$G(ARIEN)'="" D
. . . S DIC=430,DR="8;203;255.1",DA=ARIEN,DIQ="ARFLDS",DIQ(0)="IE" D EN^DIQ1
. . . S ARSTAT=$G(ARFLDS(430,ARIEN,8,"E")) ; AR Status
. . . S ARAPPR=$G(ARFLDS(430,ARIEN,203,"E")) ; APPR
. . . I ARAPPR="" S ARAPPR="RVW"
. . . S ARRSC=$G(ARFLDS(430,ARIEN,255.1,"I")) ; RSC
. . . I ARRSC="" S ARRSC="RVW"
. . S IBSTATNM=IBFLDS(350,IBIEN,.05,"E")
. . I $D(^TMP($J,"RCVCR",BILLNUM,SVCDT)) S CNT="" S CNT=$O(^TMP($J,"RCVCR",BILLNUM,SVCDT,CNT),-1)+1
. . S XTEMP=350_U_IBIEN_U_IBFLDS(350,IBIEN,.01,"E") ; Pos 1-3 FILE^IBIEN^IB Ref #
. . S XTEMP=XTEMP_U_IBFLDS(350,IBIEN,.09,"E") ;Pos 4 Parent Charge
. . S XTEMP=XTEMP_U_IBFLDS(350,IBIEN,.16,"E") ;Pos 5 Parent Event
. . S XTEMP=XTEMP_U_IBSTATNM_U_IBFLDS(350,IBIEN,.06,"E") ;Pos 6 IB STATUS Pos 7 Units Col 11&6
. . S XTEMP=XTEMP_U_IBFLDS(350,IBIEN,.07,"E") ;Pos 8 Total Charge Col 5
. . S XTEMP=XTEMP_U_$E(BILLNUM,1,21) ;Pos 9 AR Bill # Col 3
. . S XTEMP=XTEMP_U_$E(IBFLDS(350,IBIEN,.03,"E"),1,26) ;Pos 10 Category Col 4
. . I SVCTYP'=52 D
. . . I IBFLDS(350,IBIEN,.03,"E")["RX" S XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")_U_U ;Pos 11 blank Pos 12 Release RX Date Col 7&8
. . . I IBFLDS(350,IBIEN,.03,"E")'["RX" S XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")_U_U_U ;Pos 11 Medical DOS Pos 12-14 blank Col 7,8,9,10
. . I SVCTYP=52 S XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ") ;Pos 11 blank Pos 12 Release RX Date Col 7&8
. . I SVCTYP=52 S XTEMP=XTEMP_U_$P(DATEINFO,"/",5)_U_$P(DATEINFO,"/",6) ;Pos 13 RX Number, Pos 14 RX Name Col 9&10
. . S XTEMP=XTEMP_U_$E($G(ARSTAT),1,21) ;Pos 15 AR Status Col 12
. . S XTEMP=XTEMP_U I $G(IBCANCLR)'="" S XTEMP=XTEMP_$$STRIP^XLFSTR($$FMTE^XLFDT($G(IBCANCLD),"8D")," ") ;Pos 16 Cancel Dt
. . S XTEMP=XTEMP_U I $G(IBCANCLR)'="" S XTEMP=XTEMP_$E($G(IBCANCLR),1,14) ;Pos 17 Cancel Reason
. . S XTEMP=XTEMP_U I $G(IBCANCLR)'="" S XTEMP=XTEMP_$E(IBCANCLB,1,16) ;Pos 18 Cancel By
. . S XTEMP=XTEMP_U_$G(ARAPPR) ;Pos 19 APPR
. . S XTEMP=XTEMP_U_$G(ARRSC) ;Pos 20 RSC
. . ;Get Letter dates if they exist
. . I FBILLNUM D
. . . I '$D(^PRCA(430,"B",FBILLNUM)) Q
. . . S RC430IEN=$O(^PRCA(430,"B",FBILLNUM,""))
. . . I $G(LETTER)=1 D ;JMC display letters if Letter Dates selected
. . . . K ARFLDS
. . . . S DIC=430,DR="61:63;68",DA=RC430IEN,DIQ="ARFLDS",DIQ(0)="I" D EN^DIQ1
. . . . S LCNT=0
. . . . F LTRFLD=61,62,63,68 D
. . . . . S LCNT=LCNT+1 S TLTR="LTR"_LCNT
. . . . . S @TLTR=ARFLDS(430,RC430IEN,LTRFLD,"I")
. . . . . I @TLTR'="" S XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT(@TLTR,"8D")," ") ; Pos 21-24 Letter 1-4
. . . . . I @TLTR="" S XTEMP=XTEMP_U_"NO DATE" ; Pos 21-24 Letter 1-4
. . . I $G(LETTER)=2 D ;user wants to display Total Payments Received on Bill Number
. . . . S RC430TPR=+$P($G(^PRCA(430,RC430IEN,7)),"^",7)
. . . . S XTEMP=XTEMP_U_RC430TPR
. . S ^TMP($J,"RCVCR",BILLNUM,SVCDT,CNT)=XTEMP
. . K XTEMP
Q
;
OUTPRPT ; Loop through ^TMP to write report lines.
N LINE,BILLNUM,CNT,JUNK,RCTPRARY
S CNT=0,POP=0,LINE="",BILLNUM="",JUNK=0
I '$D(^TMP($J,"RCVCR")) S POP=1 W !,"NO DATA FOUND" Q
F S BILLNUM=$O(^TMP($J,"RCVCR",BILLNUM)) Q:BILLNUM=""!POP D Q:IBQUIT
. S SVCDT="" F S SVCDT=$O(^TMP($J,"RCVCR",BILLNUM,SVCDT)) Q:SVCDT=""!POP D Q:IBQUIT
. . S CNT="" F S CNT=$O(^TMP($J,"RCVCR",BILLNUM,SVCDT,CNT)) Q:CNT="" D Q:IBQUIT
. . . I $Y>(IOSL-4) W ! D PAUSE(.IBQUIT) Q:IBQUIT W @IOF D PRTCOLHD
. . . S LINE=^TMP($J,"RCVCR",BILLNUM,SVCDT,CNT)
. . . I $P(LINE,U,9)=0 S $P(LINE,U,9)=""
. . . I '$P(LINE,U,4) D WRITEREC(LINE)
. . . I $P(LINE,U,4)=$P(LINE,U,3),($P(LINE,U,3)'="") D WRITEREC(LINE)
K ^TMP($J,"RCVCR"),RCTPRARY
Q
;
WRITEREC(LINE) ; Write one line of report
; display date as DDmmmYY $$STRIP^XLFSTR($$FMTE^XLFDT(3070308,"8D")," ")
W !,$E(VETNM,1,26),?26,U,SSN,?36,U,$P(LINE,U,9),?48,U,$P(LINE,U,10),?75,U,$J($P(LINE,U,8),8,2)
W ?84,U,$P(LINE,U,7),?89,U,$P(LINE,U,11),?97,U,$P(LINE,U,12),?105,U,$P(LINE,U,13),?118,U,$P(LINE,U,14)
W ?135,U,$P(LINE,U,6),?149,U,$P(LINE,U,15),?171,U,$P(LINE,U,16),?179,U,$P(LINE,U,17),?194,U,$P(LINE,U,18)
W ?211,U,$P(LINE,U,19),?218,U,$P(LINE,U,20)
I $G(LETTER)=1 W ?223,U,$P(LINE,U,21),?231,U,$P(LINE,U,22),?239,U,$P(LINE,U,23),?247,U,$P(LINE,U,24) ;JMC Only print if 1 selected
I $G(LETTER)=2 D
. W ?223,U
. I $P(LINE,U,9)="" Q
. I '$D(RCTPRARY($P(LINE,U,9))) W $J($P(LINE,U,21),11,2) ;display the Total Principal Paid on Bill Number only once
. S RCTPRARY($P(LINE,U,9))=""
Q
;
GETDTS() ; Get appropriate selection trigger dates by type of service
;Determine transaction type 52, RX Manual RX Out pat, inpatient, LTC inpatient, LTC Outpatient
;based on transaction type get date used for selection and determine if it falls within the
;date range for the report.
; Return: Transaction type/File derived from/SELDT (Selection date)/DISPDT (display date).
; in the case of RX the following is appended to the return /RX #/Drug Name
N IBTYPINT,IBTYPE,IBTYPE,IBBG,DATES,RESPONSE,SVCTYP,RXFLDS,RXRFILL,RXNUM,RXNAME,IBCAT,IBDTENT
N RXDATE,RXIEN,RXNODE,IBDTFRM,RXFILDT
S RESPONSE="",RXRFILL="",IBCAT="",IBDTFRM="",IBDTENT=""
;RX via pharmacy system
S IBCAT=IBFLDS(350,IBIEN,.03,"E")
S IBTYPE=IBFLDS(350,IBIEN,.04,"E") S SVCTYP=+IBTYPE
I SVCTYP=52 D ;RX
. I $P(IBTYPE,";",2)'="" S RXRFILL=$P(IBTYPE,":",3)
. K ^TMP($J,"RXRDT")
. S RXIEN=+$P(IBTYPE,":",2)
. S RXNODE="0,2"
. I RXRFILL'="" S RXNODE="0,2,R^^"_RXRFILL
. D RX^PSO52API(DFN,"RXRDT",RXIEN,,RXNODE,,)
. I +$G(^TMP($J,"RXRDT",RXIEN,0))=-1 S RESPONSE="RX/"_"350#"_$P(^TMP($J,"RXRDT",RXIEN,0),U,2) Q
. I RESPONSE'="" Q
. I RXRFILL'="",$P(^TMP($J,"RXRDT",DFN,RXIEN,"RF",0),U,1)=-1 Q ;No data for refill
. ;get the release date
. I RXRFILL'="" S RXDATE=$P($G(^TMP($J,"RXRDT",DFN,RXIEN,"RF",RXRFILL,17)),U,1)
. E S RXDATE=$P($G(^TMP($J,"RXRDT",DFN,RXIEN,31)),U,1)
. ;get the fill date
. I RXRFILL'="" S RXFILDT=$P($G(^TMP($J,"RXRDT",DFN,RXIEN,"RF",RXRFILL,0.01)),U,1)
. E S RXFILDT=+$P($G(^TMP($J,"RXRDT",DFN,RXIEN,22)),U,1)
. ;if no release date then use the refill date instead
. I 'RXDATE,RXFILDT S RXDATE=RXFILDT
. S RXDATE=RXDATE\1
. S RXNUM=^TMP($J,"RXRDT",DFN,RXIEN,.01)
. S RXNAME=$P(^TMP($J,"RXRDT",DFN,RXIEN,6),U,2)
. S RESPONSE="RX/"_"350/"_RXDATE_"/"_RXDATE_"/"_RXNUM_"/"_$E(RXNAME,1,16)
I RESPONSE'="" Q RESPONSE
;Manually entered RX
I SVCTYP=350 D
. I IBCAT'["RX" Q ; Medical Charge
. S IBDTENT=IBFLDS(350,IBIEN,.15,"I")
. I IBDTENT="" S IBDTENT=IBFLDS(350,IBIEN,12,"I")
. S IBDTFRM=IBFLDS(350,IBIEN,.14,"I")
. I IBDTFRM="" S IBDTFRM=IBDTENT
. S RESPONSE="RXM/"_"350/"_IBDTENT_"/"_IBDTFRM
I RESPONSE'="" Q RESPONSE
;Inpatient or LTC Inpatient
;INP/350/(#.14) DATE BILLED FROM - used as trigger date to compare against the date range/(#.14) DATE BILLED FROM - used as DOS
I IBCAT["INPT"!(IBCAT["ADMISSION") D
. ;S RESPONSE="INP/"_"350/"_IBFLDS(350,IBIEN,.15,"I")_"/"_IBFLDS(350,IBIEN,.14,"I")
. S RESPONSE="INP/"_"350/"_IBFLDS(350,IBIEN,.14,"I")_"/"_IBFLDS(350,IBIEN,.14,"I") ;jmc
I RESPONSE'="" Q RESPONSE
;All Outpatient except for LTC
S RESPONSE="OPT/350/"_IBFLDS(350,IBIEN,.14,"I")_"/"_IBFLDS(350,IBIEN,.14,"I")
Q RESPONSE
;
PAUSE(IBQUIT) ;
I $G(DGPAGE)>0,TRM K DIR S DIR(0)="E" D ^DIR K DIR S:+Y=0 IBQUIT=1
Q
CLEAN ; KILL ALL REMAINING VARIABLES BEFORE EXIT
K ^TMP($J,"RXRDT")
K RXFLDS,IBFLDS,TRIGDT,DPTDFN,IBRXFILL,IBRXNAM,IBRXNUM,ICANCLD,LTR1,LTR2,LTR3,LTR4,VADM
K ARSTAT,ARAPPR,ARRSC
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCVCR1 15975 printed Sep 23, 2025@19:25:20 Page 2
RCVCR1 ;SLC/LLB/JC - First Party Veterans Charge Report ; SEP 9,2020@16:17
+1 ;;4.5;Accounts Receivable;**373,379**;Mar 20, 1995;Build 16
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;External References Type ICR #
+5 ;------------------- --------- -----
+6 ; HOME^%ZIS Supported 10086
+7 ; ^DIC Supported 10006
+8 ; ^DIQ Supported 10004
+9 ; EN^DIQ1 Supported 10015
+10 ; ^DIR Supported 10026
+11 ; RX^PSO52API Supported 4820
+12 ; DEM^VADPT Supported 10061
+13 ; $$FMTE^XLFDT Supported 10103
+14 ; $$NOW^XLFDT Supported 10103
+15 ; $$CJ^XLFSTR Supported 10104
+16 ; $$STRIP^XLFSTR Supported 10104
+17 ; EN^XUTMDEVQ Supported 1519
+18 ;
+19 ;ICR# TYPE DESCRIPTION
+20 ;----- ---------- ---------------------
+21 ; 7218 Private File (#350), access to fields (#.08),(#.09),(#.1),(#.12),(#.18),(#.19),(#.2),(#12),(#13),(#14)
+22 ; 4541 Private File (#350), access to the "C" cross-reference and fields (#.01),(#.02),(#.03),(#.04),(#.05),(#.06),(#.07),(#.11),(#.14),(#.15),(#.16),(#.17)
+23 ;
START ;
+1 NEW DFN,VETNM,FRMDT,FRMDTINT,TODT,TODTINT,IBSVCTYP,IBSVCNM,IBQUIT,DGPAGE
+2 NEW IBSTAT,IBSTATNM,POP,%ZIS,X,ZTSAVE,Y,LETTER,STAT,SSN,DIRUT,IBRXNAM
+3 SET (POP,DIRUT,IBQUIT,DGPAGE)=0
+4 DO INIT
+5 IF POP
QUIT
+6 WRITE !!,"The number of characters per row should be set to 256."
+7 WRITE !,"Please use the following path to modify the display settings:"
+8 WRITE !,"In Reflections. File >>> Settings >>> Terminal Configuration"
+9 WRITE !," >>> Set Up Display Settings >>> Number of characters per row",!
+10 WRITE !,"To capture as a spreadsheet format, at the DEVICE prompt, please accept the"
+11 WRITE !,"default value of 0;256;99999. This should help avoid wrapping problems.",!
+12 WRITE !,"For pagination, please use "";256;"" for the device value instead of the default.",!
+13 SET %ZIS=""
+14 SET %ZIS("B")="0;256;99999"
+15 SET ZTSAVE("FRMDTINT")=""
+16 SET ZTSAVE("LETTER")=""
+17 SET X="FIRST PARTY VETERAN CHARGE REPORT"
+18 DO EN^XUTMDEVQ("DISPHEAD^RCVCR1",X,.ZTSAVE,.%ZIS)
+19 DO HOME^%ZIS
+20 DO CLEAN
+21 QUIT
+22 ;
INIT ;
+1 ;
+2 WRITE @IOF
+3 WRITE !,"*** Print the First Party Veteran Charge Report ***",!
+4 WRITE !,"This report captures detailed 1st party bill information for a specific "
+5 WRITE !,"Veteran, within a user specified range of dates of service."
+6 WRITE !,"This report output requires screen size of 256 characters wide.",!
+7 ; Get Veteran Name
+8 SET DIC="^DPT("
SET DIC(0)="AQEZMV"
SET DIC("A")="Enter Veteran Name: "
+9 DO ^DIC
+10 KILL DIC
+11 IF +Y<1
KILL DIC
SET POP=1
QUIT
+12 SET DFN=$PIECE(Y,U)
+13 SET VETNM=$PIECE(Y,U,2)
+14 DO DEM^VADPT
+15 SET SSN=$PIECE(VADM(2),U,1)
+16 ;Get From date
+17 WRITE !
+18 NEW DIR
+19 SET DIR(0)="DO^:DT:EX"
+20 SET DIR("A")="Enter From Date "
+21 DO ^DIR
+22 IF +Y<1
KILL DIR
SET POP=1
QUIT
+23 KILL DIR
+24 SET FRMDT=X
SET FRMDTINT=Y
+25 ;Get To date
+26 SET DIR(0)="DA^"_FRMDTINT_":"_DT_":EX"
+27 SET Y=DT
DO D^DIQ
SET DIR("B")="TODAY"
+28 SET DIR("A")="Enter To Date: "
+29 DO ^DIR
+30 IF +Y<1
KILL DIR
SET POP=1
QUIT
+31 KILL DIR
+32 SET TODT=X
SET TODTINT=Y
+33 ; Get Service Type
+34 SET DIR(0)="SO^1:Medical Care;2:Outpatient Medication;3:Both (Medical Care and Outpatient Medication)"
+35 SET DIR("L",1)="Which type of copayment do you wish to see?"
+36 SET DIR("L",2)=" 1. Medical Care"
+37 SET DIR("L",3)=" 2. Outpatient Medication"
+38 SET DIR("L")=" 3. Both (Medical Care and Outpatient Medication)"
+39 SET DIR("B")="3"
+40 SET DIR("A")="Enter selection (1,2 or 3) "
+41 DO ^DIR
+42 KILL DIR
+43 IF +Y<1!(+Y>3)
KILL DIR
SET POP=1
QUIT
+44 SET IBSVCTYP=Y
SET IBSVCNM=Y(0)
+45 ; Get IB Status
+46 SET DIR(0)="SO^1:Billed;2:On Hold;3:Cancelled;4:All (Billed, On Hold, Cancelled)"
+47 SET DIR("L",1)="Which IB status for the selected copayment(s) do you wish to see?"
+48 SET DIR("L",2)=" 1. Billed"
+49 SET DIR("L",3)=" 2. On Hold"
+50 SET DIR("L",4)=" 3. Cancelled"
+51 SET DIR("L")=" 4. All (Billed, On Hold, Cancelled)"
+52 SET DIR("B")="4"
+53 SET DIR("A")="Enter Status selection (1,2,3 or 4) "
+54 DO ^DIR
+55 KILL DIR
+56 IF +Y<1!(+Y>4)
KILL DIR
SET POP=1
QUIT
+57 SET IBSTAT=Y
SET IBSTATNM=Y(0)
+58 ;Ask if Letters should print
+59 WRITE !
+60 SET DIR("A")="Enter Selection (1,2,or 3) "
+61 SET DIR(0)="SO^1:Letter Dates;2:Total Payments Received on Bill Number;3:Neither"
+62 SET DIR("L",1)="Do you want to see: "
+63 SET DIR("L",2)=" 1. Letter Dates"
+64 SET DIR("L",3)=" 2. Total Payments Received on Bill Number"
+65 SET DIR("L")=" 3. Neither"
+66 SET DIR("B")="3"
+67 DO ^DIR
+68 IF $GET(DIRUT)
SET POP=1
QUIT
+69 KILL DIR
+70 IF +Y<1!(+Y>3)
KILL DIR
SET POP=1
QUIT
+71 SET LETTER=Y
+72 QUIT
+73 ;
DISPHEAD ; Write report header
+1 ;
+2 WRITE @IOF
+3 WRITE !,"First Party Veteran Charge Report",!
+4 WRITE !,"Run date: ",$$FMTE^XLFDT($$NOW^XLFDT,"MP")
+5 WRITE !,"Service Dates From ",$$FMTE^XLFDT(FRMDTINT,"5D")," To ",$$FMTE^XLFDT(TODTINT,"5D")
+6 WRITE !,"Copayment Type Selected: ",IBSVCNM
+7 WRITE !,"IB Status Selected: ",IBSTATNM
+8 NEW TRM
SET TRM=($EXTRACT(IOST)="C")
+9 WRITE !!
+10 DO PRTCOLHD
+11 DO RUNRPT
+12 DO OUTPRPT
+13 if IBQUIT
QUIT
+14 DO ASKCONT(0)
+15 QUIT
+16 ;
ASKCONT(FLAG) ; display "press <Enter> to continue" prompt
+1 NEW Z
+2 WRITE !!,$$CJ^XLFSTR("Press <Enter> to "_$SELECT(FLAG=1:"continue.",1:"exit."),20)
+3 READ !,Z:DTIME
+4 QUIT
+5 ;
PRTCOLHD ;
+1 ;
+2 NEW COL,CNT,CNAME,LENGTH,END,SCOL,LOC
+3 SET END=255
SET SCOL=21
SET COL=0
+4 ;I $G(LETTER)="NO" S END=220,SCOL=17
+5 ;JMC If Total Payment or Neither selected
IF $GET(LETTER)'=1
SET END=220
SET SCOL=17
+6 SET DGPAGE=$GET(DGPAGE)+1
+7 FOR CNT=1:1:SCOL
Begin DoDot:1
+8 SET CNAME=$PIECE($TEXT(COLHD+CNT),U,2)
+9 SET LENGTH=$PIECE($TEXT(COLHD+CNT),U,4)
+10 SET LOC=COL+((LENGTH-$LENGTH(CNAME))\2)
+11 IF CNT>1
SET LOC=LOC+1
+12 WRITE ?LOC,CNAME
+13 SET COL=COL+LENGTH
+14 IF CNT>1
SET COL=COL+1
+15 IF CNT<SCOL
WRITE ?COL,"^"
End DoDot:1
+16 IF $GET(LETTER)=2
WRITE ?223,"^Total Principal"
+17 WRITE !
+18 SET COL=0
+19 FOR CNT=1:1:SCOL
Begin DoDot:1
+20 SET CNAME=$PIECE($TEXT(COLHD+CNT),U,3)
+21 SET LENGTH=$PIECE($TEXT(COLHD+CNT),U,4)
+22 SET LOC=COL+((LENGTH-$LENGTH(CNAME))\2)
+23 IF CNT>1
SET LOC=LOC+1
+24 SET COL=COL+LENGTH
+25 WRITE ?LOC,CNAME
+26 IF CNT>1
SET COL=COL+1
+27 IF CNT<SCOL
WRITE ?COL,"^"
End DoDot:1
+28 IF $GET(LETTER)=2
WRITE ?223,"^Paid on Bill Number"
+29 QUIT
COLHD ; $T target. Format: Column #^1st row data^2nd row data^Field Width
+1 ;;1^^Veteran Name^26
+2 ;;2^^SSN^9
+3 ;;3^^Bill Number^11
+4 ;;4^^Category^26
+5 ;;5^Charge^Amount^8
+6 ;;6^Unit^Day^4
+7 ;;7^Medical^DOS^7
+8 ;;8^Release^RX DT^7
+9 ;;9^^RX Number^12
+10 ;;10^^RX Name^16
+11 ;;11^^IB Status^13
+12 ;;12^^AR Status^21
+13 ;;13^Cancel^Date^7
+14 ;;14^Cancellation^Reason^14
+15 ;;15^^Cancelled By^16
+16 ;;16^^APPR^6
+17 ;;17^^RSC^4
+18 ;;18^^Letter1^7
+19 ;;19^^Letter2^7
+20 ;;20^^Letter3^7
+21 ;;21^^Letter4^7
+22 QUIT
+23 ;
RUNRPT ;Gather data for Report
+1 DO GET350
+2 ; Only pull file #399 data if user selected All as the desired IB Status
IF IBSTAT=4
DO GET399^RCVCR2
+3 QUIT
+4 ;
GET350 ; Collect data originating from the INTEGRATED BILLING ACTION file (#350)
+1 ;
+2 NEW IBIEN,IB0,STATLST,CNT,STATLST,LINE,RESULT,IBSTATNM,POP,SVCTYP,BILLNUM
+3 NEW DATEINFO,TRIGDT,SVCDT,XTEMP,DIC,DR,DA,DIQ,FBILLNUM,LCNT,LTRFLD,RC430IEN
+4 NEW TLTR,IBCANCLR,IBCANCLD,IBCANCLB,ARSTAT,ARAPPR,ARRSC,ARIEN,ARFLDS,RC430TPR
+5 SET (IBIEN,IBCANCLR,ICANCLD,IBCANCLB)=""
SET (CNT,RC430TPR)=0
+6 ; STATUS=BILLED,ON HOLD,CANCELLED, or ALL
+7 SET STATLST=$SELECT(IBSTAT=1:"/3/",IBSTAT=2:"/8/",IBSTAT=3:"/10/",1:"/3/8/10/")
+8 KILL ^TMP($JOB,"RCVCR")
+9 FOR
SET IBIEN=$ORDER(^IB("C",DFN,IBIEN))
if IBIEN=""
QUIT
Begin DoDot:1
+10 KILL IBFLDS
+11 SET DIC=350
SET DR=".01:.07;.08;.09:.12;.14:.2;12:14"
SET DA=IBIEN
SET DIQ="IBFLDS"
SET DIQ(0)="IE"
DO EN^DIQ1
+12 SET STAT="/"_IBFLDS(350,IBIEN,.05,"I")_"/"
+13 SET DATEINFO=$$GETDTS
+14 IF DATEINFO["#"
Begin DoDot:2
+15 SET RXDATE=IBFLDS(350,IBIEN,12,"I")
+16 SET RXNUM=$EXTRACT(IBFLDS(350,IBIEN,.08,"E"),1,12)
+17 SET RXNAME=""
+18 SET DATEINFO="RX/"_"350/"_RXDATE_"/"_RXDATE_"/"_RXNUM_"/"_$EXTRACT(RXNAME,1,16)
End DoDot:2
+19 SET TRIGDT=$PIECE(DATEINFO,"/",3)
+20 SET SVCDT=$PIECE(DATEINFO,"/",4)
+21 IF TRIGDT'<FRMDTINT
IF TRIGDT'>TODTINT
IF (STATLST[STAT)
Begin DoDot:2
+22 ;Check Service Type
+23 SET RESULT=IBFLDS(350,IBIEN,.04,"I")
SET SVCTYP=$PIECE(RESULT,":",1)
+24 ;Only include Medical
IF IBSVCTYP=1
IF (SVCTYP=52!(IBFLDS(350,IBIEN,.03,"E")["RX"))
QUIT
+25 ;Only include RX
IF IBSVCTYP=2
IF (SVCTYP'=52)
IF (IBFLDS(350,IBIEN,.03,"E")'["RX")
QUIT
+26 ;Get Cancellation information if it exists
+27 SET IBCANCLR=IBFLDS(350,IBIEN,.1,"E")
+28 SET IBCANCLD=IBFLDS(350,IBIEN,14,"I")
+29 SET IBCANCLB=IBFLDS(350,IBIEN,13,"E")
+30 ;Get data & Set into scratch global ^TMP($J,"RCVCR",BILLNUM,DATE,CNT)=
+31 ;FILE#^IBIEN^REF#^PARENT CHARGE^PARENT EVENT^STATUS^UNITS^TOTAL CHARG^AR BILL NUMBER^CATEGORY
+32 ;MEDICAL DOS^Release RX DT^RX #^RX Name^
+33 ;CNT is used to distinguish entries with the same Bill Number
+34 SET (CNT,ARIEN)=0
+35 SET FBILLNUM=IBFLDS(350,IBIEN,.11,"I")
IF FBILLNUM=""
SET BILLNUM=0
+36 IF FBILLNUM["-"
SET BILLNUM=$PIECE(FBILLNUM,"-",2)
+37 ;Get IEN to 430 based on bill number
IF BILLNUM'=""
SET ARIEN=$ORDER(^PRCA(430,"D",BILLNUM,""))
+38 SET (ARSTAT,ARAPPR,ARRSC)=""
+39 IF BILLNUM'=""
IF $GET(ARIEN)'=""
Begin DoDot:3
+40 SET DIC=430
SET DR="8;203;255.1"
SET DA=ARIEN
SET DIQ="ARFLDS"
SET DIQ(0)="IE"
DO EN^DIQ1
+41 ; AR Status
SET ARSTAT=$GET(ARFLDS(430,ARIEN,8,"E"))
+42 ; APPR
SET ARAPPR=$GET(ARFLDS(430,ARIEN,203,"E"))
+43 IF ARAPPR=""
SET ARAPPR="RVW"
+44 ; RSC
SET ARRSC=$GET(ARFLDS(430,ARIEN,255.1,"I"))
+45 IF ARRSC=""
SET ARRSC="RVW"
End DoDot:3
+46 SET IBSTATNM=IBFLDS(350,IBIEN,.05,"E")
+47 IF $DATA(^TMP($JOB,"RCVCR",BILLNUM,SVCDT))
SET CNT=""
SET CNT=$ORDER(^TMP($JOB,"RCVCR",BILLNUM,SVCDT,CNT),-1)+1
+48 ; Pos 1-3 FILE^IBIEN^IB Ref #
SET XTEMP=350_U_IBIEN_U_IBFLDS(350,IBIEN,.01,"E")
+49 ;Pos 4 Parent Charge
SET XTEMP=XTEMP_U_IBFLDS(350,IBIEN,.09,"E")
+50 ;Pos 5 Parent Event
SET XTEMP=XTEMP_U_IBFLDS(350,IBIEN,.16,"E")
+51 ;Pos 6 IB STATUS Pos 7 Units Col 11&6
SET XTEMP=XTEMP_U_IBSTATNM_U_IBFLDS(350,IBIEN,.06,"E")
+52 ;Pos 8 Total Charge Col 5
SET XTEMP=XTEMP_U_IBFLDS(350,IBIEN,.07,"E")
+53 ;Pos 9 AR Bill # Col 3
SET XTEMP=XTEMP_U_$EXTRACT(BILLNUM,1,21)
+54 ;Pos 10 Category Col 4
SET XTEMP=XTEMP_U_$EXTRACT(IBFLDS(350,IBIEN,.03,"E"),1,26)
+55 IF SVCTYP'=52
Begin DoDot:3
+56 ;Pos 11 blank Pos 12 Release RX Date Col 7&8
IF IBFLDS(350,IBIEN,.03,"E")["RX"
SET XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")_U_U
+57 ;Pos 11 Medical DOS Pos 12-14 blank Col 7,8,9,10
IF IBFLDS(350,IBIEN,.03,"E")'["RX"
SET XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")_U_U_U
End DoDot:3
+58 ;Pos 11 blank Pos 12 Release RX Date Col 7&8
IF SVCTYP=52
SET XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")
+59 ;Pos 13 RX Number, Pos 14 RX Name Col 9&10
IF SVCTYP=52
SET XTEMP=XTEMP_U_$PIECE(DATEINFO,"/",5)_U_$PIECE(DATEINFO,"/",6)
+60 ;Pos 15 AR Status Col 12
SET XTEMP=XTEMP_U_$EXTRACT($GET(ARSTAT),1,21)
+61 ;Pos 16 Cancel Dt
SET XTEMP=XTEMP_U
IF $GET(IBCANCLR)'=""
SET XTEMP=XTEMP_$$STRIP^XLFSTR($$FMTE^XLFDT($GET(IBCANCLD),"8D")," ")
+62 ;Pos 17 Cancel Reason
SET XTEMP=XTEMP_U
IF $GET(IBCANCLR)'=""
SET XTEMP=XTEMP_$EXTRACT($GET(IBCANCLR),1,14)
+63 ;Pos 18 Cancel By
SET XTEMP=XTEMP_U
IF $GET(IBCANCLR)'=""
SET XTEMP=XTEMP_$EXTRACT(IBCANCLB,1,16)
+64 ;Pos 19 APPR
SET XTEMP=XTEMP_U_$GET(ARAPPR)
+65 ;Pos 20 RSC
SET XTEMP=XTEMP_U_$GET(ARRSC)
+66 ;Get Letter dates if they exist
+67 IF FBILLNUM
Begin DoDot:3
+68 IF '$DATA(^PRCA(430,"B",FBILLNUM))
QUIT
+69 SET RC430IEN=$ORDER(^PRCA(430,"B",FBILLNUM,""))
+70 ;JMC display letters if Letter Dates selected
IF $GET(LETTER)=1
Begin DoDot:4
+71 KILL ARFLDS
+72 SET DIC=430
SET DR="61:63;68"
SET DA=RC430IEN
SET DIQ="ARFLDS"
SET DIQ(0)="I"
DO EN^DIQ1
+73 SET LCNT=0
+74 FOR LTRFLD=61,62,63,68
Begin DoDot:5
+75 SET LCNT=LCNT+1
SET TLTR="LTR"_LCNT
+76 SET @TLTR=ARFLDS(430,RC430IEN,LTRFLD,"I")
+77 ; Pos 21-24 Letter 1-4
IF @TLTR'=""
SET XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT(@TLTR,"8D")," ")
+78 ; Pos 21-24 Letter 1-4
IF @TLTR=""
SET XTEMP=XTEMP_U_"NO DATE"
End DoDot:5
End DoDot:4
+79 ;user wants to display Total Payments Received on Bill Number
IF $GET(LETTER)=2
Begin DoDot:4
+80 SET RC430TPR=+$PIECE($GET(^PRCA(430,RC430IEN,7)),"^",7)
+81 SET XTEMP=XTEMP_U_RC430TPR
End DoDot:4
End DoDot:3
+82 SET ^TMP($JOB,"RCVCR",BILLNUM,SVCDT,CNT)=XTEMP
+83 KILL XTEMP
End DoDot:2
End DoDot:1
+84 QUIT
+85 ;
OUTPRPT ; Loop through ^TMP to write report lines.
+1 NEW LINE,BILLNUM,CNT,JUNK,RCTPRARY
+2 SET CNT=0
SET POP=0
SET LINE=""
SET BILLNUM=""
SET JUNK=0
+3 IF '$DATA(^TMP($JOB,"RCVCR"))
SET POP=1
WRITE !,"NO DATA FOUND"
QUIT
+4 FOR
SET BILLNUM=$ORDER(^TMP($JOB,"RCVCR",BILLNUM))
if BILLNUM=""!POP
QUIT
Begin DoDot:1
+5 SET SVCDT=""
FOR
SET SVCDT=$ORDER(^TMP($JOB,"RCVCR",BILLNUM,SVCDT))
if SVCDT=""!POP
QUIT
Begin DoDot:2
+6 SET CNT=""
FOR
SET CNT=$ORDER(^TMP($JOB,"RCVCR",BILLNUM,SVCDT,CNT))
if CNT=""
QUIT
Begin DoDot:3
+7 IF $Y>(IOSL-4)
WRITE !
DO PAUSE(.IBQUIT)
if IBQUIT
QUIT
WRITE @IOF
DO PRTCOLHD
+8 SET LINE=^TMP($JOB,"RCVCR",BILLNUM,SVCDT,CNT)
+9 IF $PIECE(LINE,U,9)=0
SET $PIECE(LINE,U,9)=""
+10 IF '$PIECE(LINE,U,4)
DO WRITEREC(LINE)
+11 IF $PIECE(LINE,U,4)=$PIECE(LINE,U,3)
IF ($PIECE(LINE,U,3)'="")
DO WRITEREC(LINE)
End DoDot:3
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+12 KILL ^TMP($JOB,"RCVCR"),RCTPRARY
+13 QUIT
+14 ;
WRITEREC(LINE) ; Write one line of report
+1 ; display date as DDmmmYY $$STRIP^XLFSTR($$FMTE^XLFDT(3070308,"8D")," ")
+2 WRITE !,$EXTRACT(VETNM,1,26),?26,U,SSN,?36,U,$PIECE(LINE,U,9),?48,U,$PIECE(LINE,U,10),?75,U,$JUSTIFY($PIECE(LINE,U,8),8,2)
+3 WRITE ?84,U,$PIECE(LINE,U,7),?89,U,$PIECE(LINE,U,11),?97,U,$PIECE(LINE,U,12),?105,U,$PIECE(LINE,U,13),?118,U,$PIECE(LINE,U,14)
+4 WRITE ?135,U,$PIECE(LINE,U,6),?149,U,$PIECE(LINE,U,15),?171,U,$PIECE(LINE,U,16),?179,U,$PIECE(LINE,U,17),?194,U,$PIECE(LINE,U,18)
+5 WRITE ?211,U,$PIECE(LINE,U,19),?218,U,$PIECE(LINE,U,20)
+6 ;JMC Only print if 1 selected
IF $GET(LETTER)=1
WRITE ?223,U,$PIECE(LINE,U,21),?231,U,$PIECE(LINE,U,22),?239,U,$PIECE(LINE,U,23),?247,U,$PIECE(LINE,U,24)
+7 IF $GET(LETTER)=2
Begin DoDot:1
+8 WRITE ?223,U
+9 IF $PIECE(LINE,U,9)=""
QUIT
+10 ;display the Total Principal Paid on Bill Number only once
IF '$DATA(RCTPRARY($PIECE(LINE,U,9)))
WRITE $JUSTIFY($PIECE(LINE,U,21),11,2)
+11 SET RCTPRARY($PIECE(LINE,U,9))=""
End DoDot:1
+12 QUIT
+13 ;
GETDTS() ; Get appropriate selection trigger dates by type of service
+1 ;Determine transaction type 52, RX Manual RX Out pat, inpatient, LTC inpatient, LTC Outpatient
+2 ;based on transaction type get date used for selection and determine if it falls within the
+3 ;date range for the report.
+4 ; Return: Transaction type/File derived from/SELDT (Selection date)/DISPDT (display date).
+5 ; in the case of RX the following is appended to the return /RX #/Drug Name
+6 NEW IBTYPINT,IBTYPE,IBTYPE,IBBG,DATES,RESPONSE,SVCTYP,RXFLDS,RXRFILL,RXNUM,RXNAME,IBCAT,IBDTENT
+7 NEW RXDATE,RXIEN,RXNODE,IBDTFRM,RXFILDT
+8 SET RESPONSE=""
SET RXRFILL=""
SET IBCAT=""
SET IBDTFRM=""
SET IBDTENT=""
+9 ;RX via pharmacy system
+10 SET IBCAT=IBFLDS(350,IBIEN,.03,"E")
+11 SET IBTYPE=IBFLDS(350,IBIEN,.04,"E")
SET SVCTYP=+IBTYPE
+12 ;RX
IF SVCTYP=52
Begin DoDot:1
+13 IF $PIECE(IBTYPE,";",2)'=""
SET RXRFILL=$PIECE(IBTYPE,":",3)
+14 KILL ^TMP($JOB,"RXRDT")
+15 SET RXIEN=+$PIECE(IBTYPE,":",2)
+16 SET RXNODE="0,2"
+17 IF RXRFILL'=""
SET RXNODE="0,2,R^^"_RXRFILL
+18 DO RX^PSO52API(DFN,"RXRDT",RXIEN,,RXNODE,,)
+19 IF +$GET(^TMP($JOB,"RXRDT",RXIEN,0))=-1
SET RESPONSE="RX/"_"350#"_$PIECE(^TMP($JOB,"RXRDT",RXIEN,0),U,2)
QUIT
+20 IF RESPONSE'=""
QUIT
+21 ;No data for refill
IF RXRFILL'=""
IF $PIECE(^TMP($JOB,"RXRDT",DFN,RXIEN,"RF",0),U,1)=-1
QUIT
+22 ;get the release date
+23 IF RXRFILL'=""
SET RXDATE=$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,"RF",RXRFILL,17)),U,1)
+24 IF '$TEST
SET RXDATE=$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,31)),U,1)
+25 ;get the fill date
+26 IF RXRFILL'=""
SET RXFILDT=$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,"RF",RXRFILL,0.01)),U,1)
+27 IF '$TEST
SET RXFILDT=+$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,22)),U,1)
+28 ;if no release date then use the refill date instead
+29 IF 'RXDATE
IF RXFILDT
SET RXDATE=RXFILDT
+30 SET RXDATE=RXDATE\1
+31 SET RXNUM=^TMP($JOB,"RXRDT",DFN,RXIEN,.01)
+32 SET RXNAME=$PIECE(^TMP($JOB,"RXRDT",DFN,RXIEN,6),U,2)
+33 SET RESPONSE="RX/"_"350/"_RXDATE_"/"_RXDATE_"/"_RXNUM_"/"_$EXTRACT(RXNAME,1,16)
End DoDot:1
+34 IF RESPONSE'=""
QUIT RESPONSE
+35 ;Manually entered RX
+36 IF SVCTYP=350
Begin DoDot:1
+37 ; Medical Charge
IF IBCAT'["RX"
QUIT
+38 SET IBDTENT=IBFLDS(350,IBIEN,.15,"I")
+39 IF IBDTENT=""
SET IBDTENT=IBFLDS(350,IBIEN,12,"I")
+40 SET IBDTFRM=IBFLDS(350,IBIEN,.14,"I")
+41 IF IBDTFRM=""
SET IBDTFRM=IBDTENT
+42 SET RESPONSE="RXM/"_"350/"_IBDTENT_"/"_IBDTFRM
End DoDot:1
+43 IF RESPONSE'=""
QUIT RESPONSE
+44 ;Inpatient or LTC Inpatient
+45 ;INP/350/(#.14) DATE BILLED FROM - used as trigger date to compare against the date range/(#.14) DATE BILLED FROM - used as DOS
+46 IF IBCAT["INPT"!(IBCAT["ADMISSION")
Begin DoDot:1
+47 ;S RESPONSE="INP/"_"350/"_IBFLDS(350,IBIEN,.15,"I")_"/"_IBFLDS(350,IBIEN,.14,"I")
+48 ;jmc
SET RESPONSE="INP/"_"350/"_IBFLDS(350,IBIEN,.14,"I")_"/"_IBFLDS(350,IBIEN,.14,"I")
End DoDot:1
+49 IF RESPONSE'=""
QUIT RESPONSE
+50 ;All Outpatient except for LTC
+51 SET RESPONSE="OPT/350/"_IBFLDS(350,IBIEN,.14,"I")_"/"_IBFLDS(350,IBIEN,.14,"I")
+52 QUIT RESPONSE
+53 ;
PAUSE(IBQUIT) ;
+1 IF $GET(DGPAGE)>0
IF TRM
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET IBQUIT=1
+2 QUIT
CLEAN ; KILL ALL REMAINING VARIABLES BEFORE EXIT
+1 KILL ^TMP($JOB,"RXRDT")
+2 KILL RXFLDS,IBFLDS,TRIGDT,DPTDFN,IBRXFILL,IBRXNAM,IBRXNUM,ICANCLD,LTR1,LTR2,LTR3,LTR4,VADM
+3 KILL ARSTAT,ARAPPR,ARRSC
+4 QUIT
+5 ;
