RCHRFS1 ;SLC/SS - High Risk for Suicide Patients Report ; JAN 22,2021@14:32
;;4.5;Accounts Receivable;**379**;Mar 20, 1995;Build 16
;;Per VA Directive 6402, this routine should not be modified.
;
;External References Type ICR #
;------------------- ---------- -----
; EN^DIQ1 Supported 10015
; ^DIR Supported 10026
; RX^PSO52API Supported 4820
; $$FMTE^XLFDT Supported 10103
; $$RJ^XLFSTR Supported 10104
; $$STRIP^XLFSTR Supported 10104
;
;Access to files
;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)
;
;Global References Supported by
;----------------- --------------
; ^TMP($J SACC 2.3.2.5.1
;
;
;Run the report:
; RCDFN - DFN of the patient
; FRMDTINT - from date
; TODTINT - to date
; IBSTAT - IB status :
; 1-BILLED,
; 2- ON HOLD,
; 3- CANCELLED,
; 4- BILLED and ON HOLD,
; 5- ALL
; IBSVCTYP - type of care
; 1 Medical Care
; 2 Outpatient Medication
; 3 Both (Medical Care and Outpatient Medication)
;
RUNRPT(RCDFN,FRMDTINT,TODTINT,IBSTAT,IBSVCTYP) ;Gather data for Report
D GET350(RCDFN,FRMDTINT,TODTINT,IBSTAT,IBSVCTYP)
I IBSTAT=5 D GET399^RCHRFS2(RCDFN,FRMDTINT,TODTINT,IBSVCTYP) ; Only pull file #399 data if user selected All as the desired IB Status
Q
;
;
;Get data from #350
GET350(DFN,FRMDTINT,TODTINT,IBSTAT,IBSVCTYP) ; 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
N RXADTNL,NORELDT,RXFILDT,RCHRFSST,STAT350,PTNINFO
S (RXADTNL,NORELDT,RXFILDT)=""
S (IBIEN,IBCANCLR,ICANCLD,IBCANCLB)="",CNT=0
; STATUS=1-BILLED,2- ON HOLD,3- CANCELLED,4- BILLED and ON HOLD, 5- ALL
S STATLST=$S(IBSTAT=1:"/3/",IBSTAT=2:"/8/",IBSTAT=3:"/10/",IBSTAT=4:"/3/8/",1:"/3/8/10/")
S PTNINFO=$$PATINFO^RCHRFSUT(DFN)
I '$L(PTNINFO) Q ;something wrong with the patient data
K ^TMP($J,"RCHRFS",PTNINFO)
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 STAT350="/"_IBFLDS(350,IBIEN,.05,"I")_"/"
. S RXADTNL="" ;used only for RX copays in #350 to store additional information to get refill date and indicate whether we have the released date or not
. S NORELDT=0 ;by default there IS the released date, if there is no released date then =1
. S RXFILDT=0 ;to store refill date
. S DATEINFO=$$GETDTS
. S RXADTNL=$P(DATEINFO,":",2) ;applies only to RX copays in #350 to store additional information to get refill dates and indicate whether we have the released date or not
. S DATEINFO=$P(DATEINFO,":") ;the main data
. 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) ;the date that used to compare against the date range and
. S SVCDT=$P(DATEINFO,"/",4) ; DOS
. I DATEINFO["RX/350/" D
. . S NORELDT=+RXADTNL ;if 1 then there is not release date, so don't display it
. . S RXFILDT=$P(RXADTNL,U,2) ;fill/ refill date to display
. I TRIGDT'<FRMDTINT,TRIGDT'>TODTINT,(STATLST[STAT350) 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,"RCHRFS",PTNINFO,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,"RCHRFS",PTNINFO,BILLNUM,SVCDT)) S CNT="" S CNT=$O(^TMP($J,"RCHRFS",PTNINFO,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 D
. . . S XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ") ;Pos 11 blank Pos 12 Release RX Date Col 7&8
. . . 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,""))
. . . 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
. . ;add HRfS information
. . S RCHRFSST=$$HRFSDTS^RCHRFSUT(DFN,SVCDT)
. . S $P(XTEMP,U,27)=$P(RCHRFSST,U,2) ;HRfS Activation Date 16
. . S $P(XTEMP,U,28)=$P(RCHRFSST,U,3) ;HRfS Inactivation Date 18
. . S $P(XTEMP,U,29)=$P(RCHRFSST,U,1) ;HRfS Active On DOS 11
. . I SVCTYP=52 D
. . . I NORELDT>0 S $P(XTEMP,U,12)=""
. . . I RXFILDT>0 S $P(XTEMP,U,30)=RXFILDT
. . S ^TMP($J,"RCHRFS",PTNINFO,BILLNUM,SVCDT,CNT)=XTEMP
. . K XTEMP
Q
;
;Loop through ^TMP to write report lines.
OUTPRPT ; Loop through ^TMP to write report lines.
N LINE,BILLNUM,CNT,JUNK,PTNINFO
S CNT=0,POP=0,LINE="",BILLNUM="",JUNK=0
I '$D(^TMP($J,"RCHRFS")) S POP=1 W !,"NO DATA FOUND" Q
S PTNINFO=""
F S PTNINFO=$O(^TMP($J,"RCHRFS",PTNINFO)) Q:PTNINFO=""!POP D Q:IBQUIT
.F S BILLNUM=$O(^TMP($J,"RCHRFS",PTNINFO,BILLNUM)) Q:BILLNUM=""!POP D Q:IBQUIT
.. S SVCDT="" F S SVCDT=$O(^TMP($J,"RCHRFS",PTNINFO,BILLNUM,SVCDT)) Q:SVCDT=""!POP D Q:IBQUIT
... S CNT="" F S CNT=$O(^TMP($J,"RCHRFS",PTNINFO,BILLNUM,SVCDT,CNT)) Q:CNT="" D Q:IBQUIT
.... I $Y>(IOSL-4) W ! D PAUSE(.IBQUIT) Q:IBQUIT W @IOF D COLHEAD^RCHRFS
.... S LINE=^TMP($J,"RCHRFS",PTNINFO,BILLNUM,SVCDT,CNT)
.... I $P(LINE,U,9)=0 S $P(LINE,U,9)=""
.... I '$P(LINE,U,4) D WRITEREC(PTNINFO,LINE)
.... I $P(LINE,U,4)=$P(LINE,U,3),($P(LINE,U,3)'="") D WRITEREC(PTNINFO,LINE)
K ^TMP($J,"RCHRFS")
Q
;
;Write one line of the report
WRITEREC(PTNINFO,LINE) ; Write one line of report
N PATNM,RCSSN
S PATNM=$P(PTNINFO,U,1)
S RCSSN=$P(PTNINFO,U,2)
W !,$E(PATNM,1,26) ;Veteran Name, length: 26
W ?26,U,RCSSN ;SSN 9
W ?36,U,$P(LINE,U,27) ;HRfS Activation Date 16
W ?53,U,$P(LINE,U,28) ;HRfS Inactivation Date 18
W ?72,U,$P(LINE,U,29) ;HRfS Active On DOS 11
W ?84,U,$P(LINE,U,9) ;Bill Number 11
W ?96,U,$P(LINE,U,10) ;Category 26
W ?123,U,$P(LINE,U,11) ;Medical DOS 11
W ?135,U,$$STRIP^XLFSTR($$FMTE^XLFDT($P(LINE,U,30),"8D")," ") ;Rx Fill Date 12
W ?148,U,$P(LINE,U,12) ;Rx Release Date 15
W ?164,U,$P(LINE,U,13) ;Rx Number 12
W ?177,U,$E($P(LINE,U,14),1,16) ;Rx Name 16
W ?194,U,$$RJ^XLFSTR($J($P(LINE,U,8),8,2),11) ;Charge Amount 11
W ?206,U,$P(LINE,U,7) ;Unit 4
W ?211,U,$P(LINE,U,6) ;IB STATUS 13
W ?225,U,$P(LINE,U,15) ;AR STATUS 21
Q
;
;Get dates for #350 entries
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,NORELDT
S RESPONSE="",RXRFILL="",IBCAT="",IBDTFRM="",IBDTENT="",NORELDT=0
;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
. ;get refill # if available and store it in RXRFILL
. 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 if this is a refill (RXRFILL'="")
. I RXRFILL'="" S RXDATE=$P($G(^TMP($J,"RXRDT",DFN,RXIEN,"RF",RXRFILL,17)),U,1)
. ;and if it is the original fill
. E S RXDATE=$P($G(^TMP($J,"RXRDT",DFN,RXIEN,31)),U,1)
. ;get the fill date if this is a refill (RXRFILL'="")
. I RXRFILL'="" S RXFILDT=$P($G(^TMP($J,"RXRDT",DFN,RXIEN,"RF",RXRFILL,0.01)),U,1)
. ;and if it is the original fill
. 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,NORELDT=1 ;NORELDT=1 indicates that release date does not exist. Note: we set RXDATE=RXFILDT only for the inclusion logic, that compares release date with the selected date range
. 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)_":"_NORELDT_U_RXFILDT
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
I IBCAT["INPT"!(IBCAT["ADMISSION") D
. ;INP/350/(#.14) DATE BILLED FROM - used as trigger date to compare against the date range/(#.14) DATE BILLED FROM - used as DOS
. S RESPONSE="INP/"_"350/"_IBFLDS(350,IBIEN,.14,"I")_"/"_IBFLDS(350,IBIEN,.14,"I")
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(RCPAGE)>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[HRCHRFS1 13184 printed Sep 23, 2025@19:23:09 Page 2
RCHRFS1 ;SLC/SS - High Risk for Suicide Patients Report ; JAN 22,2021@14:32
+1 ;;4.5;Accounts Receivable;**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 ; EN^DIQ1 Supported 10015
+7 ; ^DIR Supported 10026
+8 ; RX^PSO52API Supported 4820
+9 ; $$FMTE^XLFDT Supported 10103
+10 ; $$RJ^XLFSTR Supported 10104
+11 ; $$STRIP^XLFSTR Supported 10104
+12 ;
+13 ;Access to files
+14 ;ICR# TYPE DESCRIPTION
+15 ;----- ---------- ---------------------------------------------------------------------------------------------------------------------------------------------
+16 ; 7218 Private File (#350), access to fields (#.08),(#.09),(#.1),(#.12),(#.18),(#.19),(#.2),(#12),(#13),(#14)
+17 ; 4541 Private File (#350), access to the "C" cross-reference and fields (#.01),(#.02),(#.03),(#.04),(#.05),(#.06),(#.07),(#.11),(#.14),(#.15),(#.16),(#.17)
+18 ;
+19 ;Global References Supported by
+20 ;----------------- --------------
+21 ; ^TMP($J SACC 2.3.2.5.1
+22 ;
+23 ;
+24 ;Run the report:
+25 ; RCDFN - DFN of the patient
+26 ; FRMDTINT - from date
+27 ; TODTINT - to date
+28 ; IBSTAT - IB status :
+29 ; 1-BILLED,
+30 ; 2- ON HOLD,
+31 ; 3- CANCELLED,
+32 ; 4- BILLED and ON HOLD,
+33 ; 5- ALL
+34 ; IBSVCTYP - type of care
+35 ; 1 Medical Care
+36 ; 2 Outpatient Medication
+37 ; 3 Both (Medical Care and Outpatient Medication)
+38 ;
RUNRPT(RCDFN,FRMDTINT,TODTINT,IBSTAT,IBSVCTYP) ;Gather data for Report
+1 DO GET350(RCDFN,FRMDTINT,TODTINT,IBSTAT,IBSVCTYP)
+2 ; Only pull file #399 data if user selected All as the desired IB Status
IF IBSTAT=5
DO GET399^RCHRFS2(RCDFN,FRMDTINT,TODTINT,IBSVCTYP)
+3 QUIT
+4 ;
+5 ;
+6 ;Get data from #350
GET350(DFN,FRMDTINT,TODTINT,IBSTAT,IBSVCTYP) ; Collect data originating from the INTEGRATED BILLING ACTION file (#350)
+1 NEW IBIEN,IB0,STATLST,CNT,STATLST,LINE,RESULT,IBSTATNM,POP,SVCTYP,BILLNUM
+2 NEW DATEINFO,TRIGDT,SVCDT,XTEMP,DIC,DR,DA,DIQ,FBILLNUM,LCNT,LTRFLD,RC430IEN
+3 NEW TLTR,IBCANCLR,IBCANCLD,IBCANCLB,ARSTAT,ARAPPR,ARRSC,ARIEN,ARFLDS
+4 NEW RXADTNL,NORELDT,RXFILDT,RCHRFSST,STAT350,PTNINFO
+5 SET (RXADTNL,NORELDT,RXFILDT)=""
+6 SET (IBIEN,IBCANCLR,ICANCLD,IBCANCLB)=""
SET CNT=0
+7 ; STATUS=1-BILLED,2- ON HOLD,3- CANCELLED,4- BILLED and ON HOLD, 5- ALL
+8 SET STATLST=$SELECT(IBSTAT=1:"/3/",IBSTAT=2:"/8/",IBSTAT=3:"/10/",IBSTAT=4:"/3/8/",1:"/3/8/10/")
+9 SET PTNINFO=$$PATINFO^RCHRFSUT(DFN)
+10 ;something wrong with the patient data
IF '$LENGTH(PTNINFO)
QUIT
+11 KILL ^TMP($JOB,"RCHRFS",PTNINFO)
+12 FOR
SET IBIEN=$ORDER(^IB("C",DFN,IBIEN))
if IBIEN=""
QUIT
Begin DoDot:1
+13 KILL IBFLDS
+14 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
+15 SET STAT350="/"_IBFLDS(350,IBIEN,.05,"I")_"/"
+16 ;used only for RX copays in #350 to store additional information to get refill date and indicate whether we have the released date or not
SET RXADTNL=""
+17 ;by default there IS the released date, if there is no released date then =1
SET NORELDT=0
+18 ;to store refill date
SET RXFILDT=0
+19 SET DATEINFO=$$GETDTS
+20 ;applies only to RX copays in #350 to store additional information to get refill dates and indicate whether we have the released date or not
SET RXADTNL=$PIECE(DATEINFO,":",2)
+21 ;the main data
SET DATEINFO=$PIECE(DATEINFO,":")
+22 IF DATEINFO["#"
Begin DoDot:2
+23 SET RXDATE=IBFLDS(350,IBIEN,12,"I")
+24 SET RXNUM=$EXTRACT(IBFLDS(350,IBIEN,.08,"E"),1,12)
+25 SET RXNAME=""
+26 SET DATEINFO="RX/"_"350/"_RXDATE_"/"_RXDATE_"/"_RXNUM_"/"_$EXTRACT(RXNAME,1,16)
End DoDot:2
+27 ;the date that used to compare against the date range and
SET TRIGDT=$PIECE(DATEINFO,"/",3)
+28 ; DOS
SET SVCDT=$PIECE(DATEINFO,"/",4)
+29 IF DATEINFO["RX/350/"
Begin DoDot:2
+30 ;if 1 then there is not release date, so don't display it
SET NORELDT=+RXADTNL
+31 ;fill/ refill date to display
SET RXFILDT=$PIECE(RXADTNL,U,2)
End DoDot:2
+32 IF TRIGDT'<FRMDTINT
IF TRIGDT'>TODTINT
IF (STATLST[STAT350)
Begin DoDot:2
+33 ;Check Service Type
+34 SET RESULT=IBFLDS(350,IBIEN,.04,"I")
SET SVCTYP=$PIECE(RESULT,":",1)
+35 ;Only include Medical
IF IBSVCTYP=1
IF (SVCTYP=52!(IBFLDS(350,IBIEN,.03,"E")["RX"))
QUIT
+36 ;Only include RX
IF IBSVCTYP=2
IF (SVCTYP'=52)
IF (IBFLDS(350,IBIEN,.03,"E")'["RX")
QUIT
+37 ;Get Cancellation information if it exists
+38 SET IBCANCLR=IBFLDS(350,IBIEN,.1,"E")
+39 SET IBCANCLD=IBFLDS(350,IBIEN,14,"I")
+40 SET IBCANCLB=IBFLDS(350,IBIEN,13,"E")
+41 ;Get data & Set into scratch global ^TMP($J,"RCHRFS",PTNINFO,BILLNUM,DATE,CNT)=
+42 ;FILE#^IBIEN^REF#^PARENT CHARGE^PARENT EVENT^STATUS^UNITS^TOTAL CHARG^AR BILL NUMBER^CATEGORY
+43 ;MEDICAL DOS^Release RX DT^RX #^RX Name^
+44 ;CNT is used to distinguish entries with the same Bill Number
+45 SET (CNT,ARIEN)=0
+46 SET FBILLNUM=IBFLDS(350,IBIEN,.11,"I")
IF FBILLNUM=""
SET BILLNUM=0
+47 IF FBILLNUM["-"
SET BILLNUM=$PIECE(FBILLNUM,"-",2)
+48 ;Get IEN to 430 based on bill number
IF BILLNUM'=""
SET ARIEN=$ORDER(^PRCA(430,"D",BILLNUM,""))
+49 SET (ARSTAT,ARAPPR,ARRSC)=""
+50 IF BILLNUM'=""
IF $GET(ARIEN)'=""
Begin DoDot:3
+51 SET DIC=430
SET DR="8;203;255.1"
SET DA=ARIEN
SET DIQ="ARFLDS"
SET DIQ(0)="IE"
DO EN^DIQ1
+52 ; AR Status
SET ARSTAT=$GET(ARFLDS(430,ARIEN,8,"E"))
+53 ; APPR
SET ARAPPR=$GET(ARFLDS(430,ARIEN,203,"E"))
+54 IF ARAPPR=""
SET ARAPPR="RVW"
+55 ; RSC
SET ARRSC=$GET(ARFLDS(430,ARIEN,255.1,"I"))
+56 IF ARRSC=""
SET ARRSC="RVW"
End DoDot:3
+57 SET IBSTATNM=IBFLDS(350,IBIEN,.05,"E")
+58 IF $DATA(^TMP($JOB,"RCHRFS",PTNINFO,BILLNUM,SVCDT))
SET CNT=""
SET CNT=$ORDER(^TMP($JOB,"RCHRFS",PTNINFO,BILLNUM,SVCDT,CNT),-1)+1
+59 ; Pos 1-3 FILE^IBIEN^IB Ref #
SET XTEMP=350_U_IBIEN_U_IBFLDS(350,IBIEN,.01,"E")
+60 ;Pos 4 Parent Charge
SET XTEMP=XTEMP_U_IBFLDS(350,IBIEN,.09,"E")
+61 ;Pos 5 Parent Event
SET XTEMP=XTEMP_U_IBFLDS(350,IBIEN,.16,"E")
+62 ;Pos 6 IB STATUS Pos 7 Units Col 11&6
SET XTEMP=XTEMP_U_IBSTATNM_U_IBFLDS(350,IBIEN,.06,"E")
+63 ;Pos 8 Total Charge Col 5
SET XTEMP=XTEMP_U_IBFLDS(350,IBIEN,.07,"E")
+64 ;Pos 9 AR Bill # Col 3
SET XTEMP=XTEMP_U_$EXTRACT(BILLNUM,1,21)
+65 ;Pos 10 Category Col 4
SET XTEMP=XTEMP_U_$EXTRACT(IBFLDS(350,IBIEN,.03,"E"),1,26)
+66 IF SVCTYP'=52
Begin DoDot:3
+67 ;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
+68 ;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
+69 IF SVCTYP=52
Begin DoDot:3
+70 ;Pos 11 blank Pos 12 Release RX Date Col 7&8
SET XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")
+71 ;Pos 13 RX Number, Pos 14 RX Name Col 9&10
SET XTEMP=XTEMP_U_$PIECE(DATEINFO,"/",5)_U_$PIECE(DATEINFO,"/",6)
End DoDot:3
+72 ;Pos 15 AR Status Col 12
SET XTEMP=XTEMP_U_$EXTRACT($GET(ARSTAT),1,21)
+73 ;Pos 16 Cancel Dt
SET XTEMP=XTEMP_U
IF $GET(IBCANCLR)'=""
SET XTEMP=XTEMP_$$STRIP^XLFSTR($$FMTE^XLFDT($GET(IBCANCLD),"8D")," ")
+74 ;Pos 17 Cancel Reason
SET XTEMP=XTEMP_U
IF $GET(IBCANCLR)'=""
SET XTEMP=XTEMP_$EXTRACT($GET(IBCANCLR),1,14)
+75 ;Pos 18 Cancel By
SET XTEMP=XTEMP_U
IF $GET(IBCANCLR)'=""
SET XTEMP=XTEMP_$EXTRACT(IBCANCLB,1,16)
+76 ;Pos 19 APPR
SET XTEMP=XTEMP_U_$GET(ARAPPR)
+77 ;Pos 20 RSC
SET XTEMP=XTEMP_U_$GET(ARRSC)
+78 ;Get Letter dates if they exist
+79 IF FBILLNUM
Begin DoDot:3
+80 IF '$DATA(^PRCA(430,"B",FBILLNUM))
QUIT
+81 SET RC430IEN=$ORDER(^PRCA(430,"B",FBILLNUM,""))
+82 KILL ARFLDS
+83 SET DIC=430
SET DR="61:63;68"
SET DA=RC430IEN
SET DIQ="ARFLDS"
SET DIQ(0)="I"
DO EN^DIQ1
+84 SET LCNT=0
+85 FOR LTRFLD=61,62,63,68
Begin DoDot:4
+86 SET LCNT=LCNT+1
SET TLTR="LTR"_LCNT
+87 SET @TLTR=ARFLDS(430,RC430IEN,LTRFLD,"I")
+88 ; Pos 21-24 Letter 1-4
IF @TLTR'=""
SET XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT(@TLTR,"8D")," ")
+89 ; Pos 21-24 Letter 1-4
IF @TLTR=""
SET XTEMP=XTEMP_U_"NO DATE"
End DoDot:4
End DoDot:3
+90 ;add HRfS information
+91 SET RCHRFSST=$$HRFSDTS^RCHRFSUT(DFN,SVCDT)
+92 ;HRfS Activation Date 16
SET $PIECE(XTEMP,U,27)=$PIECE(RCHRFSST,U,2)
+93 ;HRfS Inactivation Date 18
SET $PIECE(XTEMP,U,28)=$PIECE(RCHRFSST,U,3)
+94 ;HRfS Active On DOS 11
SET $PIECE(XTEMP,U,29)=$PIECE(RCHRFSST,U,1)
+95 IF SVCTYP=52
Begin DoDot:3
+96 IF NORELDT>0
SET $PIECE(XTEMP,U,12)=""
+97 IF RXFILDT>0
SET $PIECE(XTEMP,U,30)=RXFILDT
End DoDot:3
+98 SET ^TMP($JOB,"RCHRFS",PTNINFO,BILLNUM,SVCDT,CNT)=XTEMP
+99 KILL XTEMP
End DoDot:2
End DoDot:1
+100 QUIT
+101 ;
+102 ;Loop through ^TMP to write report lines.
OUTPRPT ; Loop through ^TMP to write report lines.
+1 NEW LINE,BILLNUM,CNT,JUNK,PTNINFO
+2 SET CNT=0
SET POP=0
SET LINE=""
SET BILLNUM=""
SET JUNK=0
+3 IF '$DATA(^TMP($JOB,"RCHRFS"))
SET POP=1
WRITE !,"NO DATA FOUND"
QUIT
+4 SET PTNINFO=""
+5 FOR
SET PTNINFO=$ORDER(^TMP($JOB,"RCHRFS",PTNINFO))
if PTNINFO=""!POP
QUIT
Begin DoDot:1
+6 FOR
SET BILLNUM=$ORDER(^TMP($JOB,"RCHRFS",PTNINFO,BILLNUM))
if BILLNUM=""!POP
QUIT
Begin DoDot:2
+7 SET SVCDT=""
FOR
SET SVCDT=$ORDER(^TMP($JOB,"RCHRFS",PTNINFO,BILLNUM,SVCDT))
if SVCDT=""!POP
QUIT
Begin DoDot:3
+8 SET CNT=""
FOR
SET CNT=$ORDER(^TMP($JOB,"RCHRFS",PTNINFO,BILLNUM,SVCDT,CNT))
if CNT=""
QUIT
Begin DoDot:4
+9 IF $Y>(IOSL-4)
WRITE !
DO PAUSE(.IBQUIT)
if IBQUIT
QUIT
WRITE @IOF
DO COLHEAD^RCHRFS
+10 SET LINE=^TMP($JOB,"RCHRFS",PTNINFO,BILLNUM,SVCDT,CNT)
+11 IF $PIECE(LINE,U,9)=0
SET $PIECE(LINE,U,9)=""
+12 IF '$PIECE(LINE,U,4)
DO WRITEREC(PTNINFO,LINE)
+13 IF $PIECE(LINE,U,4)=$PIECE(LINE,U,3)
IF ($PIECE(LINE,U,3)'="")
DO WRITEREC(PTNINFO,LINE)
End DoDot:4
if IBQUIT
QUIT
End DoDot:3
if IBQUIT
QUIT
End DoDot:2
if IBQUIT
QUIT
End DoDot:1
if IBQUIT
QUIT
+14 KILL ^TMP($JOB,"RCHRFS")
+15 QUIT
+16 ;
+17 ;Write one line of the report
WRITEREC(PTNINFO,LINE) ; Write one line of report
+1 NEW PATNM,RCSSN
+2 SET PATNM=$PIECE(PTNINFO,U,1)
+3 SET RCSSN=$PIECE(PTNINFO,U,2)
+4 ;Veteran Name, length: 26
WRITE !,$EXTRACT(PATNM,1,26)
+5 ;SSN 9
WRITE ?26,U,RCSSN
+6 ;HRfS Activation Date 16
WRITE ?36,U,$PIECE(LINE,U,27)
+7 ;HRfS Inactivation Date 18
WRITE ?53,U,$PIECE(LINE,U,28)
+8 ;HRfS Active On DOS 11
WRITE ?72,U,$PIECE(LINE,U,29)
+9 ;Bill Number 11
WRITE ?84,U,$PIECE(LINE,U,9)
+10 ;Category 26
WRITE ?96,U,$PIECE(LINE,U,10)
+11 ;Medical DOS 11
WRITE ?123,U,$PIECE(LINE,U,11)
+12 ;Rx Fill Date 12
WRITE ?135,U,$$STRIP^XLFSTR($$FMTE^XLFDT($PIECE(LINE,U,30),"8D")," ")
+13 ;Rx Release Date 15
WRITE ?148,U,$PIECE(LINE,U,12)
+14 ;Rx Number 12
WRITE ?164,U,$PIECE(LINE,U,13)
+15 ;Rx Name 16
WRITE ?177,U,$EXTRACT($PIECE(LINE,U,14),1,16)
+16 ;Charge Amount 11
WRITE ?194,U,$$RJ^XLFSTR($JUSTIFY($PIECE(LINE,U,8),8,2),11)
+17 ;Unit 4
WRITE ?206,U,$PIECE(LINE,U,7)
+18 ;IB STATUS 13
WRITE ?211,U,$PIECE(LINE,U,6)
+19 ;AR STATUS 21
WRITE ?225,U,$PIECE(LINE,U,15)
+20 QUIT
+21 ;
+22 ;Get dates for #350 entries
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,NORELDT
+8 SET RESPONSE=""
SET RXRFILL=""
SET IBCAT=""
SET IBDTFRM=""
SET IBDTENT=""
SET NORELDT=0
+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 ;get refill # if available and store it in RXRFILL
+14 IF $PIECE(IBTYPE,";",2)'=""
SET RXRFILL=$PIECE(IBTYPE,":",3)
+15 KILL ^TMP($JOB,"RXRDT")
+16 SET RXIEN=+$PIECE(IBTYPE,":",2)
+17 SET RXNODE="0,2"
+18 IF RXRFILL'=""
SET RXNODE="0,2,R^^"_RXRFILL
+19 DO RX^PSO52API(DFN,"RXRDT",RXIEN,,RXNODE,,)
+20 IF +$GET(^TMP($JOB,"RXRDT",RXIEN,0))=-1
SET RESPONSE="RX/"_"350#"_$PIECE(^TMP($JOB,"RXRDT",RXIEN,0),U,2)
QUIT
+21 IF RESPONSE'=""
QUIT
+22 ;No data for refill
IF RXRFILL'=""
IF $PIECE(^TMP($JOB,"RXRDT",DFN,RXIEN,"RF",0),U,1)=-1
QUIT
+23 ;get the release date if this is a refill (RXRFILL'="")
+24 IF RXRFILL'=""
SET RXDATE=$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,"RF",RXRFILL,17)),U,1)
+25 ;and if it is the original fill
+26 IF '$TEST
SET RXDATE=$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,31)),U,1)
+27 ;get the fill date if this is a refill (RXRFILL'="")
+28 IF RXRFILL'=""
SET RXFILDT=$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,"RF",RXRFILL,0.01)),U,1)
+29 ;and if it is the original fill
+30 IF '$TEST
SET RXFILDT=+$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,22)),U,1)
+31 ;
+32 ;if no release date then use the refill date instead
+33 ;NORELDT=1 indicates that release date does not exist. Note: we set RXDATE=RXFILDT only for the inclusion logic, that compares release date with the selected date range
IF 'RXDATE
IF RXFILDT
SET RXDATE=RXFILDT
SET NORELDT=1
+34 SET RXDATE=RXDATE\1
+35 SET RXNUM=^TMP($JOB,"RXRDT",DFN,RXIEN,.01)
+36 SET RXNAME=$PIECE(^TMP($JOB,"RXRDT",DFN,RXIEN,6),U,2)
+37 SET RESPONSE="RX/"_"350/"_RXDATE_"/"_RXDATE_"/"_RXNUM_"/"_$EXTRACT(RXNAME,1,16)_":"_NORELDT_U_RXFILDT
End DoDot:1
+38 IF RESPONSE'=""
QUIT RESPONSE
+39 ;Manually entered RX
+40 IF SVCTYP=350
Begin DoDot:1
+41 ; Medical Charge
IF IBCAT'["RX"
QUIT
+42 SET IBDTENT=IBFLDS(350,IBIEN,.15,"I")
+43 IF IBDTENT=""
SET IBDTENT=IBFLDS(350,IBIEN,12,"I")
+44 SET IBDTFRM=IBFLDS(350,IBIEN,.14,"I")
+45 IF IBDTFRM=""
SET IBDTFRM=IBDTENT
+46 SET RESPONSE="RXM/"_"350/"_IBDTENT_"/"_IBDTFRM
End DoDot:1
+47 IF RESPONSE'=""
QUIT RESPONSE
+48 ;Inpatient or LTC Inpatient
+49 IF IBCAT["INPT"!(IBCAT["ADMISSION")
Begin DoDot:1
+50 ;INP/350/(#.14) DATE BILLED FROM - used as trigger date to compare against the date range/(#.14) DATE BILLED FROM - used as DOS
+51 SET RESPONSE="INP/"_"350/"_IBFLDS(350,IBIEN,.14,"I")_"/"_IBFLDS(350,IBIEN,.14,"I")
End DoDot:1
+52 IF RESPONSE'=""
QUIT RESPONSE
+53 ;All Outpatient except for LTC
+54 SET RESPONSE="OPT/350/"_IBFLDS(350,IBIEN,.14,"I")_"/"_IBFLDS(350,IBIEN,.14,"I")
+55 QUIT RESPONSE
+56 ;
PAUSE(IBQUIT) ;
+1 IF $GET(RCPAGE)>0
IF TRM
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if +Y=0
SET IBQUIT=1
+2 QUIT
+3 ;
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 ;
