RCHRFS2 ;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 #
;------------------- ---------- -----
; GETS^DIQ Supported 2056
; EN^DIQ1 Supported 10015
; RX^PSO52API Supported 4820
; $$FMTE^XLFDT Supported 10103
; $$STRIP^XLFSTR Supported 10104
;
;Access to files
;ICR# TYPE DESCRIPTION
;----- ---------- -----------------------------------------------------------------------------------------------------------------------------------------------------------
; 7217 Private File (#399), access to "C" cross-reference and fields (#.08),(#.17),(#18),(#19)
; 3820 Private File (#399), access to fields (#.01),(#.03),(#.05),(#.07),(#.11),(#.13),(#151) and access to (#42) multiple fields: (#.01), (#.03), (#.04), (#.05), (#.1), (#.11)
; 1992 Contr. Sub. File (#399), access to field (#17)
; 418 Contr. Sub. File (#45), access to discharge Date field (#70), Admission date field (#2)
; 6033 Contr. Sub. File (#362.4) access to "C" cross reference and access for fields (#.01), (#.03), (#.04), (#.05), (#.1)
;
;Global References Supported by
;----------------- --------------
; ^TMP($J SACC 2.3.2.5.1
;
;Get data for #399 entries
GET399(DFN,FRMDTINT,TODTINT,IBSVCTYP) ; Insert code to loop through 399 here
N IBIEN,IBFLDS,BILLCLAS,BILLTYP,BILLNUM,EVNTDT,MULT,X,RCNODE,D1,IBRSC,IBCHRG,IBRXNAM
N IBUNITS,IBBEDST,IBTYPE,SVCDT,IBSTATNM,CNT,DIC,DR,DA,DIQ,IBBCPR,ARAPPR,ARRSC,ARSTAT,ARIEN,PTNINFO
S IBUNITS=1,(ARSTAT,ARAPPR,ARRSC)=""
S PTNINFO=$$PATINFO^RCHRFSUT(DFN)
I '$L(PTNINFO) Q ;something wrong with the patient data
; Start by using the patient index "C" to get all records for patient
I '$D(^DGCR(399,"C",DFN)) Q ;No file 399 records for patient
S IBIEN=0
F S IBIEN=$O(^DGCR(399,"C",DFN,IBIEN)) Q:IBIEN="" D
. K IBFLDS,IBERR,IBBEDST
. ; Fields captured
. ; .01 BILL NUMBER [BILLNUM]
. ; .03 Event Date [EVNTDT]
. ; .05 Bill Classification [BILLCLAS]
. ; .07 Rate Type
. ; .08 PTF Entry Number
. ; .11 Who's Responsible for Bill?
. ; .13 Status [STAT]
. ; .17 Primary Bill [PBILL]
. ; 151 Statement covers from
. ; 42 Revenue Code ([Multiple] capture all fields of all multiples)
. ; 17 Date Bill Cancelled
. ; 18 Bill Cancelled By
. ; 19 Reason Cancelled
. K DIC,DR,DA,DIQ
. D GETS^DIQ(399,IBIEN_",",".01;.03;.05;.07;.08;.11;.13;.17;17;18;19;151;42*","IE","IBFLDS","IBERR")
. Q:$D(IBERR)
. S BILLTYP="/"_IBFLDS(399,IBIEN_",",.07,"E")_"/"
. I "/HUMANITARIAN/INELIGIBLE/MEANS TEST/DENTAL/"'[BILLTYP Q ;Exclude all but specific Bill Type
. ; All of these are patient responsibility
. I IBFLDS(399,IBIEN_",",.11,"I")'="p" Q ;exclude all but patient responsibility
. ; Skip all that don't fall into the required rate types
. ; Determine STATUS and skip any that are not 3 AUTHORIZED,4 PRNT/TX,7 CANCELLED
. I "/3/4/7/"'[IBFLDS(399,IBIEN_",",.13,"I") Q
. S BILLCLAS=IBFLDS(399,IBIEN_",",.05,"I")
. D PROC399
K XTEMP
Q
;
PROC399 ; Process one 399 record
N XTEMP,IBDISDT,DATEINFO,IBBCNUM,IBXDRG,IENS,IBRXFLG,FLAG399
N IBCANCLD,IBCANCLR,IBCANCLB,ARFLDS
S FLAG399=0
S IBSTATNM=IBFLDS(399,IBIEN_",",.13,"E")
S BILLNUM=IBFLDS(399,IBIEN_",",.01,"E")
S EVNTDT=IBFLDS(399,IBIEN_",",.03,"I")\1
S SVCDT=EVNTDT
S TRIGDT=EVNTDT
; If there are more than one RC multiple split them into separate lines
; if prescription get info from File 52 especially Release Date
; if inpatient get discharge use Event date as Admission date
I BILLCLAS=1!(BILLCLAS=2) D ; Inpatient
. S IBDISDT=""
. N IBFROMDT
. S IBFROMDT=$G(IBFLDS(399,IBIEN_",",151,"I")) ;^DGCR(399,D0,U)= (#151) STATEMENT COVERS FROM [1D]
. I IBFROMDT'="" S TRIGDT=IBFROMDT,IBDISDT=IBFROMDT,EVNTDT=IBFROMDT
I (BILLCLAS=1!BILLCLAS=2),(IBDISDT="") Q ; Inpatient not billed until discharged
; Get information from file #430
I BILLNUM'="" S ARIEN=$O(^PRCA(430,"D",BILLNUM,"")) ;Get IEN to 430 based on bill number
I BILLNUM'="",$G(ARIEN)'="" D
. S DIC=430,DR="3;8;203;255.1",DA=ARIEN,DIQ="ARFLDS",DIQ(0)="IE" D EN^DIQ1
. S (ARSTAT,ARAPPR,ARRSC)=""
. S ARSTAT=$E($G(ARFLDS(430,ARIEN,8,"E")),1,21) ; AR Status
. S ARAPPR=$G(ARFLDS(430,ARIEN,203,"E")) ; APPR
. I ARAPPR="" S ARAPPR="RVW"
. S ARRSC=$G(ARFLDS(430,ARIEN,255.1,"E")) ; RSC
. I ARRSC="" S ARRSC="RVW"
; Get Cancellation Info
S IBCANCLD=$G(IBFLDS(399,IBIEN_",",17,"I"))
S IBCANCLR=$G(IBFLDS(399,IBIEN_",",19,"E"))
S IBCANCLB=$G(IBFLDS(399,IBIEN_",",18,"E"))
;
I '$D(IBFLDS(399.042)) D Q ;Handle no revenue codes
. I $O(ARFLDS(430,""))="" S IBCHRG=0 ;this is to prevent if ARIEN does not exist or is null and will allow the program to exit gracefully
. E S IBCHRG=$G(ARFLDS(430,ARIEN,3,"E")) ; ORIGINAL AMOUNT from #430
. I IBCHRG="" S IBCHRG=0
. S IBBCNUM=0
. ; Get RX info if any
. S IBRXFLG=0 ;Flag if RX information
. I (IBSVCTYP=2!(IBSVCTYP=3)),$D(^IBA(362.4,"C",IBIEN)) S TRIGDT=0 D CHKBCRX Q ;trigger to display the RX info if user select Outpatient Medication or Both
. S TRIGDT=EVNTDT I TRIGDT<FRMDTINT!(TRIGDT>TODTINT) Q
. I 'IBRXFLG,'$D(^IBA(362.4,"C",IBIEN)) Q:IBSVCTYP=2 D ST399TMP ;display the Medical Care only
I $D(IBFLDS(399.042)) D RCNODE S FLAG399=1
Q
;
RCNODE ; Capture Revenue Code Node information
N IBITEM,RCCNT,IBRXDT,RXFLDS
S IBRXFLG=0,IBRXDT=""
S X="",MULT=0 F S X=$O(IBFLDS(399.042,X),-1) Q:X="" S MULT=MULT+1
S (IBRSC,IBCHRG,IBUNITS,IBBEDST,IBTYPE,IBITEM,IBBCPR,IBRXFILL,IBRXNUM,RXIEN,RCNODE)=""
F RCCNT=1:1:MULT D ; Build a separate line in the report
. S RCNODE=$O(IBFLDS(399.042,RCNODE))
. S D1=+RCNODE ; May not be needed
. S IBRSC=IBFLDS(399.042,RCNODE,.01,"E") ;Revenue Source Code
. I IBRSC="" S IBRSC="RVW"
. S IBCHRG=IBFLDS(399.042,RCNODE,.04,"E") ; Total Charge
. S IBUNITS=IBFLDS(399.042,RCNODE,.03,"E") ; Units of service
. S IBBEDST=IBFLDS(399.042,RCNODE,.05,"E") ; Bed Section
. S IBTYPE=IBFLDS(399.042,RCNODE,.1,"E") ; IB Type
. S IBITEM=IBFLDS(399.042,RCNODE,.11,"I") ; ITEM number (For RX pointer to file #362.4)
. S SVCDT=EVNTDT
. I IBSVCTYP=2,$G(IBBEDST)'="PRESCRIPTION" Q ; Only include 399 RX charges
. I IBSVCTYP=1,$G(IBBEDST)="PRESCRIPTION" Q ; Only include 399 non RX charges
. I $G(IBBEDST)="PRESCRIPTION" D
. . S DATEINFO="RX/"_"399/"_SVCDT_"/"_SVCDT_"//"
. . I IBITEM="" D CHKBCRX ; add check of "C" index if IBITEM=""
. . I IBITEM="" Q
. . S IBBCPR=IBITEM ;S IBBCPR=$P(^IBA(362.4,IBITEM,0),U,11)
. . K DIC,DR,DA,DIQ,IBERR,RXFLDS
. . D GETS^DIQ(362.4,IBITEM_",",".01;.03;.04;.1","IE","RXFLDS","IBERR")
. . Q:$D(IBERR)
. . S IBRXNUM=RXFLDS(362.4,IBITEM_",",.01,"E") ;RX Number
. . S IBRXFILL=RXFLDS(362.4,IBITEM_",",.1,"E") ;Fill Number
. . S IBRXNAM=RXFLDS(362.4,IBITEM_",",.04,"E") ;Drug from file #50
. . S IBRXDT=RXFLDS(362.4,IBITEM_",",.03,"I") ;IB 362.4 date
. . I IBRXNUM="" Q
. . I +IBRXNUM>0 D
. . . S RXIEN=0 S RXIEN=$$GETIEN52(DFN,IBRXNUM)
. . . I +RXIEN<1 D ;If RXIEN is equal to zero, then get all the RX info from file #362.4
. . . . S RXIEN=+$G(RXFLDS(362.4,IBITEM_",",.01,"I")) ;this RXIEN comes from file 362.4
. . . . S DATEINFO="RX/"_"399/"_IBRXDT_"/"_IBRXDT_"/"_IBRXNUM_"/"_$E(IBRXNAM,1,16)
. . . E S DATEINFO=$$IB399RX(DFN,RXIEN,+IBRXFILL)
. . I +IBRXNUM'>0 D
. . . S DATEINFO="RX/"_"399/"_EVNTDT_"/"_EVNTDT_"/"_IBRXNUM_"/"_$E(IBRXNAM,1,16)
. . S SVCDT=$P(DATEINFO,"/",3)
. . S TRIGDT=$P(DATEINFO,"/",3)
. I TRIGDT<FRMDTINT!(TRIGDT>TODTINT) Q
. I 'IBRXFLG D ST399TMP
Q
;
ST399TMP ; Write one 399 record into TMP file
N LCNT,LTRFLD,RC430IEN,TLTR,RCHRFSST,RCMISSRX
S CNT=0
S RCMISSRX=0
S IBBEDST=$G(IBBEDST)
I $D(^TMP($J,"RCHRFS",PTNINFO,BILLNUM,SVCDT)) S CNT="" S CNT=$O(^TMP($J,"RCHRFS",PTNINFO,BILLNUM,SVCDT,CNT),-1)+1
S XTEMP=399_U_IBIEN_U ; Pos 1-3 FILE^IBIEN^IB Ref #
S XTEMP=XTEMP_U ;Pos 4 Parent Charge
S XTEMP=XTEMP_U ;Pos 5 Parent Event
S XTEMP=XTEMP_U_"*"_IBSTATNM_U_IBUNITS ;Pos 6 IB STATUS Pos 7 Units
S XTEMP=XTEMP_U_IBCHRG ;Pos 8 Total Charge
S XTEMP=XTEMP_U_BILLNUM ;Pos 9 AR Bill #
S XTEMP=XTEMP_U_$P(BILLTYP,"/",2) ;Pos 10 Category
I IBBEDST'="PRESCRIPTION" S XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")_U_U_U ;Pos 11 Medical DOS Pos 12-14 blank
I IBBEDST="PRESCRIPTION" D
. I $P(DATEINFO,"/",5)="" S RCMISSRX=1,XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")_U_U ; Medical DOS if RX info missing
. I $P(DATEINFO,"/",5)'="" D
. . S XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ") ;Pos 11 blank Pos 12 Release RX Date
. . S XTEMP=XTEMP_U_$P(DATEINFO,"/",5)_U_$P(DATEINFO,"/",6) ;Pos 13 RX Number, Pos 14 RX Name
S XTEMP=XTEMP_U_$E($G(ARSTAT),1,21) ;Pos 15 AR Status ;Pos 15 AR Status
S XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT($G(IBCANCLD),"8D")," ") ;Pos 16 Cancel Dt
S XTEMP=XTEMP_U_$E($G(IBCANCLR),1,14) ;Pos 17 Cancel Reason
S XTEMP=XTEMP_U_$E($G(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 BILLNUM'="" S RC430IEN=$O(^PRCA(430,"D",BILLNUM,""))
K ARFLDS
S DIC=430,DR="61:63;68",DA=$S($G(RC430IEN)'="":RC430IEN,1:$G(BILLNUM)),DIQ="ARFLDS",DIQ(0)="I" D EN^DIQ1
S LCNT=0
F LTRFLD=61,62,63,68 D
. I $G(RC430IEN)="" Q
. 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 +XTEMP=399,$P(XTEMP,U,12)'="",$P(XTEMP,U,13)="" S $P(XTEMP,U,13)="PHARMACY"
;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 IBBEDST="PRESCRIPTION",RCMISSRX=0 D
. N NORELDT,RXFILDT
. S NORELDT=+$P(DATEINFO,":",2) ;0 if we have a release date
. S RXFILDT=+$P($P(DATEINFO,":",2),U,2) ;refill date
. 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
; Determine type of bill and the appropriate date falls within the desired date range
; What date do we use for selection / display?
; Use event date except for RX (Release DT) and
; Inpatient (Discharge DT)for selection and Event Dt for (Admission DT) for display
; For Inpatient
; #399 Field .08 Pointer to PTF (Patient Transfer File #45) to get Admission and discharge DT
; For RX
; Check RC Multiples for BEDSECTION=Prescription & TYPE=RX then ITEM is an IEN to file #362.4
; #362.4 will have an RX# to lookup in file #52 and a FILL NUMBER (0 or null if original RX or a
; positive refill number) and if a fill number is present check the appropriate refill in #52
; check status for inclusion
;
IB399RX(DFN,RXIEN,IBRXFILL) ; Get Prescription information for 399 bills.
N RESPONSE,RXNODE,IBRXNAME,IBRXNUM,RXDATE,RXFILDT,NORELDT
S NORELDT=0 ;by default there IS the released date, if there is no released date then =1
K ^TMP($J,"RXRDT")
S RESPONSE=""
S RXNODE="0,2"
I IBRXFILL>0 S RXNODE="0,2,R^^"_IBRXFILL
D RX^PSO52API(DFN,"RXRDT",RXIEN,,RXNODE,,)
I +$G(^TMP($J,"RXRDT",DFN,0))=-1 S RESPONSE="RX/"_"399#/"_$P(^TMP($J,"RXRDT",DFN,0),U,2) Q RESPONSE
;get the release date if this is a refill (RXRFILL'="")
I IBRXFILL>0 S RXDATE=$P($G(^TMP($J,"RXRDT",DFN,RXIEN,"RF",IBRXFILL,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 IBRXFILL>0 S RXFILDT=$P($G(^TMP($J,"RXRDT",DFN,RXIEN,"RF",IBRXFILL,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
I 'RXDATE S RXDATE=$G(IBRXDT)\1
S IBRXNUM=$S(+RXIEN<1:RXFLDS(362.4,RXITEM_",",.01,"E"),1:^TMP($J,"RXRDT",DFN,RXIEN,.01))
S IBRXNAME=$S(+RXIEN<1:RXFLDS(362.4,RXITEM_",",.04,"E"),1:$P(^TMP($J,"RXRDT",DFN,RXIEN,6),U,2))
S RESPONSE="RX/"_"399/"_RXDATE_"/"_RXDATE_"/"_IBRXNUM_"/"_$E(IBRXNAME,1,16)_":"_NORELDT_U_RXFILDT
S TRIGDT=$P(RESPONSE,"/",3)
I TRIGDT<FRMDTINT!(TRIGDT>TODTINT) S RESPONSE="RX/"_"399#"_"/DATE NOT IN RANGE" Q RESPONSE
Q RESPONSE
;
CHKBCRX ;
N RXITEM
S IBBCNUM=0
F S IBBCNUM=$O(^IBA(362.4,"C",IBIEN,IBBCNUM)) Q:IBBCNUM="" D
. S IBRXFLG=1,RXITEM=IBBCNUM
. S DATEINFO=""
. S IBERR=""
. K RXFLDS D GETS^DIQ(362.4,RXITEM_",",".01;.03;.04;.05;.1","IE","RXFLDS","IBERR")
. I IBERR Q
. S IBRXNUM=RXFLDS(362.4,RXITEM_",",.01,"E") ;RX Number
. S IBRXFILL=RXFLDS(362.4,RXITEM_",",.1,"E") ;Fill Number
. S IBRXDT=RXFLDS(362.4,RXITEM_",",.03,"I") ;IB 362.4 date
. S IBRXNAM=RXFLDS(362.4,RXITEM_",",.04,"E") ;Drug from file #50
. S RXIEN=RXFLDS(362.4,RXITEM_",",.05,"I") ;IEN into file 52
. S DATEINFO=$$IB399RX(DFN,RXIEN,IBRXFILL)
. S TRIGDT=$P(DATEINFO,"/",3)
. I TRIGDT<FRMDTINT!(TRIGDT>TODTINT) Q
. S SVCDT=$P(DATEINFO,"/",3)
. I $G(IBBEDST)="" S IBBEDST="PRESCRIPTION" ;this will prevent for the RX's data to be displayed if user select service type of Medical Care
. D ST399TMP
Q
;
GETIEN52(RCDFN,RCRX) ;return IEN for #52 by RX# and DFN
N RCRET
K ^TMP($J,"RCPRRX")
D RX^PSO52API(RCDFN,"RCPRRX",,RCRX,"0")
I +$G(^TMP($J,"RCPRRX",RCDFN,0))=-1 Q 0
S RCRET=+$O(^TMP($J,"RCPRRX",RCDFN,0))
K ^TMP($J,"RCPRRX")
Q RCRET
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCHRFS2 14015 printed Oct 16, 2024@17:47:53 Page 2
RCHRFS2 ;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 ; GETS^DIQ Supported 2056
+7 ; EN^DIQ1 Supported 10015
+8 ; RX^PSO52API Supported 4820
+9 ; $$FMTE^XLFDT Supported 10103
+10 ; $$STRIP^XLFSTR Supported 10104
+11 ;
+12 ;Access to files
+13 ;ICR# TYPE DESCRIPTION
+14 ;----- ---------- -----------------------------------------------------------------------------------------------------------------------------------------------------------
+15 ; 7217 Private File (#399), access to "C" cross-reference and fields (#.08),(#.17),(#18),(#19)
+16 ; 3820 Private File (#399), access to fields (#.01),(#.03),(#.05),(#.07),(#.11),(#.13),(#151) and access to (#42) multiple fields: (#.01), (#.03), (#.04), (#.05), (#.1), (#.11)
+17 ; 1992 Contr. Sub. File (#399), access to field (#17)
+18 ; 418 Contr. Sub. File (#45), access to discharge Date field (#70), Admission date field (#2)
+19 ; 6033 Contr. Sub. File (#362.4) access to "C" cross reference and access for fields (#.01), (#.03), (#.04), (#.05), (#.1)
+20 ;
+21 ;Global References Supported by
+22 ;----------------- --------------
+23 ; ^TMP($J SACC 2.3.2.5.1
+24 ;
+25 ;Get data for #399 entries
GET399(DFN,FRMDTINT,TODTINT,IBSVCTYP) ; Insert code to loop through 399 here
+1 NEW IBIEN,IBFLDS,BILLCLAS,BILLTYP,BILLNUM,EVNTDT,MULT,X,RCNODE,D1,IBRSC,IBCHRG,IBRXNAM
+2 NEW IBUNITS,IBBEDST,IBTYPE,SVCDT,IBSTATNM,CNT,DIC,DR,DA,DIQ,IBBCPR,ARAPPR,ARRSC,ARSTAT,ARIEN,PTNINFO
+3 SET IBUNITS=1
SET (ARSTAT,ARAPPR,ARRSC)=""
+4 SET PTNINFO=$$PATINFO^RCHRFSUT(DFN)
+5 ;something wrong with the patient data
IF '$LENGTH(PTNINFO)
QUIT
+6 ; Start by using the patient index "C" to get all records for patient
+7 ;No file 399 records for patient
IF '$DATA(^DGCR(399,"C",DFN))
QUIT
+8 SET IBIEN=0
+9 FOR
SET IBIEN=$ORDER(^DGCR(399,"C",DFN,IBIEN))
if IBIEN=""
QUIT
Begin DoDot:1
+10 KILL IBFLDS,IBERR,IBBEDST
+11 ; Fields captured
+12 ; .01 BILL NUMBER [BILLNUM]
+13 ; .03 Event Date [EVNTDT]
+14 ; .05 Bill Classification [BILLCLAS]
+15 ; .07 Rate Type
+16 ; .08 PTF Entry Number
+17 ; .11 Who's Responsible for Bill?
+18 ; .13 Status [STAT]
+19 ; .17 Primary Bill [PBILL]
+20 ; 151 Statement covers from
+21 ; 42 Revenue Code ([Multiple] capture all fields of all multiples)
+22 ; 17 Date Bill Cancelled
+23 ; 18 Bill Cancelled By
+24 ; 19 Reason Cancelled
+25 KILL DIC,DR,DA,DIQ
+26 DO GETS^DIQ(399,IBIEN_",",".01;.03;.05;.07;.08;.11;.13;.17;17;18;19;151;42*","IE","IBFLDS","IBERR")
+27 if $DATA(IBERR)
QUIT
+28 SET BILLTYP="/"_IBFLDS(399,IBIEN_",",.07,"E")_"/"
+29 ;Exclude all but specific Bill Type
IF "/HUMANITARIAN/INELIGIBLE/MEANS TEST/DENTAL/"'[BILLTYP
QUIT
+30 ; All of these are patient responsibility
+31 ;exclude all but patient responsibility
IF IBFLDS(399,IBIEN_",",.11,"I")'="p"
QUIT
+32 ; Skip all that don't fall into the required rate types
+33 ; Determine STATUS and skip any that are not 3 AUTHORIZED,4 PRNT/TX,7 CANCELLED
+34 IF "/3/4/7/"'[IBFLDS(399,IBIEN_",",.13,"I")
QUIT
+35 SET BILLCLAS=IBFLDS(399,IBIEN_",",.05,"I")
+36 DO PROC399
End DoDot:1
+37 KILL XTEMP
+38 QUIT
+39 ;
PROC399 ; Process one 399 record
+1 NEW XTEMP,IBDISDT,DATEINFO,IBBCNUM,IBXDRG,IENS,IBRXFLG,FLAG399
+2 NEW IBCANCLD,IBCANCLR,IBCANCLB,ARFLDS
+3 SET FLAG399=0
+4 SET IBSTATNM=IBFLDS(399,IBIEN_",",.13,"E")
+5 SET BILLNUM=IBFLDS(399,IBIEN_",",.01,"E")
+6 SET EVNTDT=IBFLDS(399,IBIEN_",",.03,"I")\1
+7 SET SVCDT=EVNTDT
+8 SET TRIGDT=EVNTDT
+9 ; If there are more than one RC multiple split them into separate lines
+10 ; if prescription get info from File 52 especially Release Date
+11 ; if inpatient get discharge use Event date as Admission date
+12 ; Inpatient
IF BILLCLAS=1!(BILLCLAS=2)
Begin DoDot:1
+13 SET IBDISDT=""
+14 NEW IBFROMDT
+15 ;^DGCR(399,D0,U)= (#151) STATEMENT COVERS FROM [1D]
SET IBFROMDT=$GET(IBFLDS(399,IBIEN_",",151,"I"))
+16 IF IBFROMDT'=""
SET TRIGDT=IBFROMDT
SET IBDISDT=IBFROMDT
SET EVNTDT=IBFROMDT
End DoDot:1
+17 ; Inpatient not billed until discharged
IF (BILLCLAS=1!BILLCLAS=2)
IF (IBDISDT="")
QUIT
+18 ; Get information from file #430
+19 ;Get IEN to 430 based on bill number
IF BILLNUM'=""
SET ARIEN=$ORDER(^PRCA(430,"D",BILLNUM,""))
+20 IF BILLNUM'=""
IF $GET(ARIEN)'=""
Begin DoDot:1
+21 SET DIC=430
SET DR="3;8;203;255.1"
SET DA=ARIEN
SET DIQ="ARFLDS"
SET DIQ(0)="IE"
DO EN^DIQ1
+22 SET (ARSTAT,ARAPPR,ARRSC)=""
+23 ; AR Status
SET ARSTAT=$EXTRACT($GET(ARFLDS(430,ARIEN,8,"E")),1,21)
+24 ; APPR
SET ARAPPR=$GET(ARFLDS(430,ARIEN,203,"E"))
+25 IF ARAPPR=""
SET ARAPPR="RVW"
+26 ; RSC
SET ARRSC=$GET(ARFLDS(430,ARIEN,255.1,"E"))
+27 IF ARRSC=""
SET ARRSC="RVW"
End DoDot:1
+28 ; Get Cancellation Info
+29 SET IBCANCLD=$GET(IBFLDS(399,IBIEN_",",17,"I"))
+30 SET IBCANCLR=$GET(IBFLDS(399,IBIEN_",",19,"E"))
+31 SET IBCANCLB=$GET(IBFLDS(399,IBIEN_",",18,"E"))
+32 ;
+33 ;Handle no revenue codes
IF '$DATA(IBFLDS(399.042))
Begin DoDot:1
+34 ;this is to prevent if ARIEN does not exist or is null and will allow the program to exit gracefully
IF $ORDER(ARFLDS(430,""))=""
SET IBCHRG=0
+35 ; ORIGINAL AMOUNT from #430
IF '$TEST
SET IBCHRG=$GET(ARFLDS(430,ARIEN,3,"E"))
+36 IF IBCHRG=""
SET IBCHRG=0
+37 SET IBBCNUM=0
+38 ; Get RX info if any
+39 ;Flag if RX information
SET IBRXFLG=0
+40 ;trigger to display the RX info if user select Outpatient Medication or Both
IF (IBSVCTYP=2!(IBSVCTYP=3))
IF $DATA(^IBA(362.4,"C",IBIEN))
SET TRIGDT=0
DO CHKBCRX
QUIT
+41 SET TRIGDT=EVNTDT
IF TRIGDT<FRMDTINT!(TRIGDT>TODTINT)
QUIT
+42 ;display the Medical Care only
IF 'IBRXFLG
IF '$DATA(^IBA(362.4,"C",IBIEN))
if IBSVCTYP=2
QUIT
DO ST399TMP
End DoDot:1
QUIT
+43 IF $DATA(IBFLDS(399.042))
DO RCNODE
SET FLAG399=1
+44 QUIT
+45 ;
RCNODE ; Capture Revenue Code Node information
+1 NEW IBITEM,RCCNT,IBRXDT,RXFLDS
+2 SET IBRXFLG=0
SET IBRXDT=""
+3 SET X=""
SET MULT=0
FOR
SET X=$ORDER(IBFLDS(399.042,X),-1)
if X=""
QUIT
SET MULT=MULT+1
+4 SET (IBRSC,IBCHRG,IBUNITS,IBBEDST,IBTYPE,IBITEM,IBBCPR,IBRXFILL,IBRXNUM,RXIEN,RCNODE)=""
+5 ; Build a separate line in the report
FOR RCCNT=1:1:MULT
Begin DoDot:1
+6 SET RCNODE=$ORDER(IBFLDS(399.042,RCNODE))
+7 ; May not be needed
SET D1=+RCNODE
+8 ;Revenue Source Code
SET IBRSC=IBFLDS(399.042,RCNODE,.01,"E")
+9 IF IBRSC=""
SET IBRSC="RVW"
+10 ; Total Charge
SET IBCHRG=IBFLDS(399.042,RCNODE,.04,"E")
+11 ; Units of service
SET IBUNITS=IBFLDS(399.042,RCNODE,.03,"E")
+12 ; Bed Section
SET IBBEDST=IBFLDS(399.042,RCNODE,.05,"E")
+13 ; IB Type
SET IBTYPE=IBFLDS(399.042,RCNODE,.1,"E")
+14 ; ITEM number (For RX pointer to file #362.4)
SET IBITEM=IBFLDS(399.042,RCNODE,.11,"I")
+15 SET SVCDT=EVNTDT
+16 ; Only include 399 RX charges
IF IBSVCTYP=2
IF $GET(IBBEDST)'="PRESCRIPTION"
QUIT
+17 ; Only include 399 non RX charges
IF IBSVCTYP=1
IF $GET(IBBEDST)="PRESCRIPTION"
QUIT
+18 IF $GET(IBBEDST)="PRESCRIPTION"
Begin DoDot:2
+19 SET DATEINFO="RX/"_"399/"_SVCDT_"/"_SVCDT_"//"
+20 ; add check of "C" index if IBITEM=""
IF IBITEM=""
DO CHKBCRX
+21 IF IBITEM=""
QUIT
+22 ;S IBBCPR=$P(^IBA(362.4,IBITEM,0),U,11)
SET IBBCPR=IBITEM
+23 KILL DIC,DR,DA,DIQ,IBERR,RXFLDS
+24 DO GETS^DIQ(362.4,IBITEM_",",".01;.03;.04;.1","IE","RXFLDS","IBERR")
+25 if $DATA(IBERR)
QUIT
+26 ;RX Number
SET IBRXNUM=RXFLDS(362.4,IBITEM_",",.01,"E")
+27 ;Fill Number
SET IBRXFILL=RXFLDS(362.4,IBITEM_",",.1,"E")
+28 ;Drug from file #50
SET IBRXNAM=RXFLDS(362.4,IBITEM_",",.04,"E")
+29 ;IB 362.4 date
SET IBRXDT=RXFLDS(362.4,IBITEM_",",.03,"I")
+30 IF IBRXNUM=""
QUIT
+31 IF +IBRXNUM>0
Begin DoDot:3
+32 SET RXIEN=0
SET RXIEN=$$GETIEN52(DFN,IBRXNUM)
+33 ;If RXIEN is equal to zero, then get all the RX info from file #362.4
IF +RXIEN<1
Begin DoDot:4
+34 ;this RXIEN comes from file 362.4
SET RXIEN=+$GET(RXFLDS(362.4,IBITEM_",",.01,"I"))
+35 SET DATEINFO="RX/"_"399/"_IBRXDT_"/"_IBRXDT_"/"_IBRXNUM_"/"_$EXTRACT(IBRXNAM,1,16)
End DoDot:4
+36 IF '$TEST
SET DATEINFO=$$IB399RX(DFN,RXIEN,+IBRXFILL)
End DoDot:3
+37 IF +IBRXNUM'>0
Begin DoDot:3
+38 SET DATEINFO="RX/"_"399/"_EVNTDT_"/"_EVNTDT_"/"_IBRXNUM_"/"_$EXTRACT(IBRXNAM,1,16)
End DoDot:3
+39 SET SVCDT=$PIECE(DATEINFO,"/",3)
+40 SET TRIGDT=$PIECE(DATEINFO,"/",3)
End DoDot:2
+41 IF TRIGDT<FRMDTINT!(TRIGDT>TODTINT)
QUIT
+42 IF 'IBRXFLG
DO ST399TMP
End DoDot:1
+43 QUIT
+44 ;
ST399TMP ; Write one 399 record into TMP file
+1 NEW LCNT,LTRFLD,RC430IEN,TLTR,RCHRFSST,RCMISSRX
+2 SET CNT=0
+3 SET RCMISSRX=0
+4 SET IBBEDST=$GET(IBBEDST)
+5 IF $DATA(^TMP($JOB,"RCHRFS",PTNINFO,BILLNUM,SVCDT))
SET CNT=""
SET CNT=$ORDER(^TMP($JOB,"RCHRFS",PTNINFO,BILLNUM,SVCDT,CNT),-1)+1
+6 ; Pos 1-3 FILE^IBIEN^IB Ref #
SET XTEMP=399_U_IBIEN_U
+7 ;Pos 4 Parent Charge
SET XTEMP=XTEMP_U
+8 ;Pos 5 Parent Event
SET XTEMP=XTEMP_U
+9 ;Pos 6 IB STATUS Pos 7 Units
SET XTEMP=XTEMP_U_"*"_IBSTATNM_U_IBUNITS
+10 ;Pos 8 Total Charge
SET XTEMP=XTEMP_U_IBCHRG
+11 ;Pos 9 AR Bill #
SET XTEMP=XTEMP_U_BILLNUM
+12 ;Pos 10 Category
SET XTEMP=XTEMP_U_$PIECE(BILLTYP,"/",2)
+13 ;Pos 11 Medical DOS Pos 12-14 blank
IF IBBEDST'="PRESCRIPTION"
SET XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")_U_U_U
+14 IF IBBEDST="PRESCRIPTION"
Begin DoDot:1
+15 ; Medical DOS if RX info missing
IF $PIECE(DATEINFO,"/",5)=""
SET RCMISSRX=1
SET XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")_U_U
+16 IF $PIECE(DATEINFO,"/",5)'=""
Begin DoDot:2
+17 ;Pos 11 blank Pos 12 Release RX Date
SET XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")
+18 ;Pos 13 RX Number, Pos 14 RX Name
SET XTEMP=XTEMP_U_$PIECE(DATEINFO,"/",5)_U_$PIECE(DATEINFO,"/",6)
End DoDot:2
End DoDot:1
+19 ;Pos 15 AR Status ;Pos 15 AR Status
SET XTEMP=XTEMP_U_$EXTRACT($GET(ARSTAT),1,21)
+20 ;Pos 16 Cancel Dt
SET XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT($GET(IBCANCLD),"8D")," ")
+21 ;Pos 17 Cancel Reason
SET XTEMP=XTEMP_U_$EXTRACT($GET(IBCANCLR),1,14)
+22 ;Pos 18 Cancel By
SET XTEMP=XTEMP_U_$EXTRACT($GET(IBCANCLB),1,16)
+23 ;Pos 19 APPR
SET XTEMP=XTEMP_U_$GET(ARAPPR)
+24 ;Pos 20 RSC
SET XTEMP=XTEMP_U_$GET(ARRSC)
+25 ;Get Letter dates if they exist
+26 IF BILLNUM'=""
SET RC430IEN=$ORDER(^PRCA(430,"D",BILLNUM,""))
+27 KILL ARFLDS
+28 SET DIC=430
SET DR="61:63;68"
SET DA=$SELECT($GET(RC430IEN)'="":RC430IEN,1:$GET(BILLNUM))
SET DIQ="ARFLDS"
SET DIQ(0)="I"
DO EN^DIQ1
+29 SET LCNT=0
+30 FOR LTRFLD=61,62,63,68
Begin DoDot:1
+31 IF $GET(RC430IEN)=""
QUIT
+32 SET LCNT=LCNT+1
SET TLTR="LTR"_LCNT
+33 SET @TLTR=ARFLDS(430,RC430IEN,LTRFLD,"I")
+34 ; Pos 21-24 Letter 1-4
IF @TLTR'=""
SET XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT(@TLTR,"8D")," ")
+35 ; Pos 21-24 Letter 1-4
IF @TLTR=""
SET XTEMP=XTEMP_U_"NO DATE"
End DoDot:1
+36 IF +XTEMP=399
IF $PIECE(XTEMP,U,12)'=""
IF $PIECE(XTEMP,U,13)=""
SET $PIECE(XTEMP,U,13)="PHARMACY"
+37 ;add HRfS information
+38 SET RCHRFSST=$$HRFSDTS^RCHRFSUT(DFN,SVCDT)
+39 ;HRfS Activation Date 16
SET $PIECE(XTEMP,U,27)=$PIECE(RCHRFSST,U,2)
+40 ;HRfS Inactivation Date 18
SET $PIECE(XTEMP,U,28)=$PIECE(RCHRFSST,U,3)
+41 ;HRfS Active On DOS 11
SET $PIECE(XTEMP,U,29)=$PIECE(RCHRFSST,U,1)
+42 IF IBBEDST="PRESCRIPTION"
IF RCMISSRX=0
Begin DoDot:1
+43 NEW NORELDT,RXFILDT
+44 ;0 if we have a release date
SET NORELDT=+$PIECE(DATEINFO,":",2)
+45 ;refill date
SET RXFILDT=+$PIECE($PIECE(DATEINFO,":",2),U,2)
+46 IF NORELDT>0
SET $PIECE(XTEMP,U,12)=""
+47 IF RXFILDT>0
SET $PIECE(XTEMP,U,30)=RXFILDT
End DoDot:1
+48 SET ^TMP($JOB,"RCHRFS",PTNINFO,BILLNUM,SVCDT,CNT)=XTEMP
+49 KILL XTEMP
+50 QUIT
+51 ; Determine type of bill and the appropriate date falls within the desired date range
+52 ; What date do we use for selection / display?
+53 ; Use event date except for RX (Release DT) and
+54 ; Inpatient (Discharge DT)for selection and Event Dt for (Admission DT) for display
+55 ; For Inpatient
+56 ; #399 Field .08 Pointer to PTF (Patient Transfer File #45) to get Admission and discharge DT
+57 ; For RX
+58 ; Check RC Multiples for BEDSECTION=Prescription & TYPE=RX then ITEM is an IEN to file #362.4
+59 ; #362.4 will have an RX# to lookup in file #52 and a FILL NUMBER (0 or null if original RX or a
+60 ; positive refill number) and if a fill number is present check the appropriate refill in #52
+61 ; check status for inclusion
+62 ;
IB399RX(DFN,RXIEN,IBRXFILL) ; Get Prescription information for 399 bills.
+1 NEW RESPONSE,RXNODE,IBRXNAME,IBRXNUM,RXDATE,RXFILDT,NORELDT
+2 ;by default there IS the released date, if there is no released date then =1
SET NORELDT=0
+3 KILL ^TMP($JOB,"RXRDT")
+4 SET RESPONSE=""
+5 SET RXNODE="0,2"
+6 IF IBRXFILL>0
SET RXNODE="0,2,R^^"_IBRXFILL
+7 DO RX^PSO52API(DFN,"RXRDT",RXIEN,,RXNODE,,)
+8 IF +$GET(^TMP($JOB,"RXRDT",DFN,0))=-1
SET RESPONSE="RX/"_"399#/"_$PIECE(^TMP($JOB,"RXRDT",DFN,0),U,2)
QUIT RESPONSE
+9 ;get the release date if this is a refill (RXRFILL'="")
+10 IF IBRXFILL>0
SET RXDATE=$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,"RF",IBRXFILL,17)),U,1)
+11 ;and if it is the original fill
+12 IF '$TEST
SET RXDATE=$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,31)),U,1)
+13 ;get the fill date if this is a refill (RXRFILL'="")
+14 IF IBRXFILL>0
SET RXFILDT=$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,"RF",IBRXFILL,0.01)),U,1)
+15 ;and if it is the original fill
+16 IF '$TEST
SET RXFILDT=+$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,22)),U,1)
+17 ;if no release date then use the refill date instead
+18 ;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
+19 ;
+20 SET RXDATE=RXDATE\1
+21 IF 'RXDATE
SET RXDATE=$GET(IBRXDT)\1
+22 SET IBRXNUM=$SELECT(+RXIEN<1:RXFLDS(362.4,RXITEM_",",.01,"E"),1:^TMP($JOB,"RXRDT",DFN,RXIEN,.01))
+23 SET IBRXNAME=$SELECT(+RXIEN<1:RXFLDS(362.4,RXITEM_",",.04,"E"),1:$PIECE(^TMP($JOB,"RXRDT",DFN,RXIEN,6),U,2))
+24 SET RESPONSE="RX/"_"399/"_RXDATE_"/"_RXDATE_"/"_IBRXNUM_"/"_$EXTRACT(IBRXNAME,1,16)_":"_NORELDT_U_RXFILDT
+25 SET TRIGDT=$PIECE(RESPONSE,"/",3)
+26 IF TRIGDT<FRMDTINT!(TRIGDT>TODTINT)
SET RESPONSE="RX/"_"399#"_"/DATE NOT IN RANGE"
QUIT RESPONSE
+27 QUIT RESPONSE
+28 ;
CHKBCRX ;
+1 NEW RXITEM
+2 SET IBBCNUM=0
+3 FOR
SET IBBCNUM=$ORDER(^IBA(362.4,"C",IBIEN,IBBCNUM))
if IBBCNUM=""
QUIT
Begin DoDot:1
+4 SET IBRXFLG=1
SET RXITEM=IBBCNUM
+5 SET DATEINFO=""
+6 SET IBERR=""
+7 KILL RXFLDS
DO GETS^DIQ(362.4,RXITEM_",",".01;.03;.04;.05;.1","IE","RXFLDS","IBERR")
+8 IF IBERR
QUIT
+9 ;RX Number
SET IBRXNUM=RXFLDS(362.4,RXITEM_",",.01,"E")
+10 ;Fill Number
SET IBRXFILL=RXFLDS(362.4,RXITEM_",",.1,"E")
+11 ;IB 362.4 date
SET IBRXDT=RXFLDS(362.4,RXITEM_",",.03,"I")
+12 ;Drug from file #50
SET IBRXNAM=RXFLDS(362.4,RXITEM_",",.04,"E")
+13 ;IEN into file 52
SET RXIEN=RXFLDS(362.4,RXITEM_",",.05,"I")
+14 SET DATEINFO=$$IB399RX(DFN,RXIEN,IBRXFILL)
+15 SET TRIGDT=$PIECE(DATEINFO,"/",3)
+16 IF TRIGDT<FRMDTINT!(TRIGDT>TODTINT)
QUIT
+17 SET SVCDT=$PIECE(DATEINFO,"/",3)
+18 ;this will prevent for the RX's data to be displayed if user select service type of Medical Care
IF $GET(IBBEDST)=""
SET IBBEDST="PRESCRIPTION"
+19 DO ST399TMP
End DoDot:1
+20 QUIT
+21 ;
GETIEN52(RCDFN,RCRX) ;return IEN for #52 by RX# and DFN
+1 NEW RCRET
+2 KILL ^TMP($JOB,"RCPRRX")
+3 DO RX^PSO52API(RCDFN,"RCPRRX",,RCRX,"0")
+4 IF +$GET(^TMP($JOB,"RCPRRX",RCDFN,0))=-1
QUIT 0
+5 SET RCRET=+$ORDER(^TMP($JOB,"RCPRRX",RCDFN,0))
+6 KILL ^TMP($JOB,"RCPRRX")
+7 QUIT RCRET
+8 ;
