RCVCR2 ;SLC/LLB/JC - First Party Veterans Charge Report ; NOV 30,2020@13:36
;;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 #
;------------------- ---------- -----
; GETS^DIQ Supported 2056
; EN^DIQ1 Supported 10015
; RX^PSO52API Supported 4820
; $$FMTE^XLFDT Supported 10103
; $$STRIP^XLFSTR Supported 10104
;
;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) ;jmc
; 1992 Contr. Sub. File (#399), access to field (#17)
; 418 Contr. Sub. File (#45), access to discharge Date field (#70), Admission Date Field (#2) ;jmc
; 6033 Contr. Sub. File (#362.4) access to "C" cross reference and access for fields (#.01), (#.03), (#.04), (#.05), (#.1)
;
GET399 ; 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
S IBUNITS=1,(ARSTAT,ARAPPR,ARRSC)=""
; 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 ;jmc
. ; 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;42*","IE","IBFLDS","IBERR")
. D GETS^DIQ(399,IBIEN_",",".01;.03;.05;.07;.08;.11;.13;.17;17;18;19;151;42*","IE","IBFLDS","IBERR") ;jmc
. 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,IBPTF,IBXDRG,IENS,IBRXFLG,FLAG399,IBADMDT
N XTEMP,IBDISDT,DATEINFO,IBBCNUM,IBXDRG,IENS,IBRXFLG,FLAG399 ;jmc
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=""
. ;S IBPTF=$G(IBFLDS(399,IBIEN_",",.08,"I")) ; Read PTF file
. ;jmc
. 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 IBPTF'="" S IENS=IBPTF_"," S IBDISDT=$$GET1^DIQ(45,IENS,70,"I",,"45ERR")\1
. ;I IBDISDT'="" S TRIGDT=IBDISDT ;jmc
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 infor 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 infor 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
. 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
. . 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,RCTPR399
S (CNT,RCTPR399)=0
S IBBEDST=$G(IBBEDST)
I $D(^TMP($J,"RCVCR",BILLNUM,SVCDT)) S CNT="" S CNT=$O(^TMP($J,"RCVCR",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 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
. I $G(LETTER)'=1 Q ;JMC If LETTER'=1 Q (Do not display letters)
. 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"
I $G(LETTER)=2 D ;user wants to display Total Payments Received on Bill Number
. S RCTPR399=+$P($G(^PRCA(430,RC430IEN,7)),"^",7)
. S XTEMP=XTEMP_U_RCTPR399
S ^TMP($J,"RCVCR",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
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
I IBRXFILL>0 S RXDATE=$P($G(^TMP($J,"RXRDT",DFN,RXIEN,"RF",IBRXFILL,17)),U,1)
E S RXDATE=$P($G(^TMP($J,"RXRDT",DFN,RXIEN,31)),U,1)
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)
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[HRCVCR2 12874 printed Dec 13, 2024@01:49:12 Page 2
RCVCR2 ;SLC/LLB/JC - First Party Veterans Charge Report ; NOV 30,2020@13:36
+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 ; 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 ;ICR# TYPE DESCRIPTION
+13 ;----- ---------- ---------------------
+14 ; 7217 Private File (#399), access to "C" cross-reference and fields (#.08),(#.17),(#18),(#19)
+15 ; 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) ;jmc
+16 ; 1992 Contr. Sub. File (#399), access to field (#17)
+17 ; 418 Contr. Sub. File (#45), access to discharge Date field (#70), Admission Date Field (#2) ;jmc
+18 ; 6033 Contr. Sub. File (#362.4) access to "C" cross reference and access for fields (#.01), (#.03), (#.04), (#.05), (#.1)
+19 ;
GET399 ; 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
+3 SET IBUNITS=1
SET (ARSTAT,ARAPPR,ARRSC)=""
+4 ; Start by using the patient index "C" to get all records for patient
+5 ;No file 399 records for patient
IF '$DATA(^DGCR(399,"C",DFN))
QUIT
+6 SET IBIEN=0
+7 FOR
SET IBIEN=$ORDER(^DGCR(399,"C",DFN,IBIEN))
if IBIEN=""
QUIT
Begin DoDot:1
+8 KILL IBFLDS,IBERR,IBBEDST
+9 ; Fields captured
+10 ; .01 BILL NUMBER [BILLNUM]
+11 ; .03 Event Date [EVNTDT]
+12 ; .05 Bill Classification [BILLCLAS]
+13 ; .07 Rate Type
+14 ; .08 PTF Entry Number
+15 ; .11 Who's Responsible for Bill?
+16 ; .13 Status [STAT]
+17 ; .17 Primary Bill [PBILL]
+18 ; 151 Statement Covers From ;jmc
+19 ; 42 Revenue Code ([Multiple] capture all fields of all multiples)
+20 ; 17 Date Bill Cancelled
+21 ; 18 Bill Cancelled By
+22 ; 19 Reason Cancelled
+23 KILL DIC,DR,DA,DIQ
+24 ;D GETS^DIQ(399,IBIEN_",",".01;.03;.05;.07;.08;.11;.13;.17;17;18;19;42*","IE","IBFLDS","IBERR")
+25 ;jmc
DO GETS^DIQ(399,IBIEN_",",".01;.03;.05;.07;.08;.11;.13;.17;17;18;19;151;42*","IE","IBFLDS","IBERR")
+26 if $DATA(IBERR)
QUIT
+27 SET BILLTYP="/"_IBFLDS(399,IBIEN_",",.07,"E")_"/"
+28 ;Exclude all but specific Bill Type
IF "/HUMANITARIAN/INELIGIBLE/MEANS TEST/DENTAL/"'[BILLTYP
QUIT
+29 ; All of these are patient responsibility
+30 ;exclude all but patient responsibility
IF IBFLDS(399,IBIEN_",",.11,"I")'="p"
QUIT
+31 ; Skip all that don't fall into the required rate types
+32 ; Determine STATUS and skip any that are not 3 AUTHORIZED,4 PRNT/TX,7 CANCELLED
+33 IF "/3/4/7/"'[IBFLDS(399,IBIEN_",",.13,"I")
QUIT
+34 SET BILLCLAS=IBFLDS(399,IBIEN_",",.05,"I")
+35 DO PROC399
End DoDot:1
+36 KILL XTEMP
+37 QUIT
+38 ;
PROC399 ; Process one 399 record
+1 ;N XTEMP,IBDISDT,DATEINFO,IBBCNUM,IBPTF,IBXDRG,IENS,IBRXFLG,FLAG399,IBADMDT
+2 ;jmc
NEW XTEMP,IBDISDT,DATEINFO,IBBCNUM,IBXDRG,IENS,IBRXFLG,FLAG399
+3 NEW IBCANCLD,IBCANCLR,IBCANCLB,ARFLDS
+4 SET FLAG399=0
+5 SET IBSTATNM=IBFLDS(399,IBIEN_",",.13,"E")
+6 SET BILLNUM=IBFLDS(399,IBIEN_",",.01,"E")
+7 SET EVNTDT=IBFLDS(399,IBIEN_",",.03,"I")\1
+8 SET SVCDT=EVNTDT
+9 SET TRIGDT=EVNTDT
+10 ; If there are more than one RC multiple split them into separate lines
+11 ; if prescription get info from File 52 especially Release Date
+12 ; if inpatient get discharge use Event date as Admission date
+13 ; Inpatient
IF BILLCLAS=1!(BILLCLAS=2)
Begin DoDot:1
+14 SET IBDISDT=""
+15 ;S IBPTF=$G(IBFLDS(399,IBIEN_",",.08,"I")) ; Read PTF file
+16 ;jmc
+17 NEW IBFROMDT
+18 ;^DGCR(399,D0,U)= (#151) STATEMENT COVERS FROM [1D]
SET IBFROMDT=$GET(IBFLDS(399,IBIEN_",",151,"I"))
+19 IF IBFROMDT'=""
SET TRIGDT=IBFROMDT
SET IBDISDT=IBFROMDT
SET EVNTDT=IBFROMDT
+20 ;I IBPTF'="" S IENS=IBPTF_"," S IBDISDT=$$GET1^DIQ(45,IENS,70,"I",,"45ERR")\1
+21 ;I IBDISDT'="" S TRIGDT=IBDISDT ;jmc
End DoDot:1
+22 ; Inpatient not billed until discharged
IF (BILLCLAS=1!BILLCLAS=2)
IF (IBDISDT="")
QUIT
+23 ; Get information from file #430
+24 ;Get IEN to 430 based on bill number
IF BILLNUM'=""
SET ARIEN=$ORDER(^PRCA(430,"D",BILLNUM,""))
+25 IF BILLNUM'=""
IF $GET(ARIEN)'=""
Begin DoDot:1
+26 SET DIC=430
SET DR="3;8;203;255.1"
SET DA=ARIEN
SET DIQ="ARFLDS"
SET DIQ(0)="IE"
DO EN^DIQ1
+27 SET (ARSTAT,ARAPPR,ARRSC)=""
+28 ; AR Status
SET ARSTAT=$EXTRACT($GET(ARFLDS(430,ARIEN,8,"E")),1,21)
+29 ; APPR
SET ARAPPR=$GET(ARFLDS(430,ARIEN,203,"E"))
+30 IF ARAPPR=""
SET ARAPPR="RVW"
+31 ; RSC
SET ARRSC=$GET(ARFLDS(430,ARIEN,255.1,"E"))
+32 IF ARRSC=""
SET ARRSC="RVW"
End DoDot:1
+33 ; Get Cancellation Info
+34 SET IBCANCLD=$GET(IBFLDS(399,IBIEN_",",17,"I"))
+35 SET IBCANCLR=$GET(IBFLDS(399,IBIEN_",",19,"E"))
+36 SET IBCANCLB=$GET(IBFLDS(399,IBIEN_",",18,"E"))
+37 ;
+38 ;Handle no revenue codes
IF '$DATA(IBFLDS(399.042))
Begin DoDot:1
+39 ;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
+40 ; ORIGINAL AMOUNT from #430
IF '$TEST
SET IBCHRG=$GET(ARFLDS(430,ARIEN,3,"E"))
+41 IF IBCHRG=""
SET IBCHRG=0
+42 SET IBBCNUM=0
+43 ; Get RX infor if any
+44 ;Flag if RX information
SET IBRXFLG=0
+45 ;trigger to display the RX infor 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
+46 SET TRIGDT=EVNTDT
IF TRIGDT<FRMDTINT!(TRIGDT>TODTINT)
QUIT
+47 ;display the Medical Care only
IF 'IBRXFLG
IF '$DATA(^IBA(362.4,"C",IBIEN))
if IBSVCTYP=2
QUIT
DO ST399TMP
End DoDot:1
QUIT
+48 IF $DATA(IBFLDS(399.042))
DO RCNODE
SET FLAG399=1
+49 QUIT
+50 ;
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 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 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,RCTPR399
+2 SET (CNT,RCTPR399)=0
+3 SET IBBEDST=$GET(IBBEDST)
+4 IF $DATA(^TMP($JOB,"RCVCR",BILLNUM,SVCDT))
SET CNT=""
SET CNT=$ORDER(^TMP($JOB,"RCVCR",BILLNUM,SVCDT,CNT),-1)+1
+5 ; Pos 1-3 FILE^IBIEN^IB Ref #
SET XTEMP=399_U_IBIEN_U
+6 ;Pos 4 Parent Charge
SET XTEMP=XTEMP_U
+7 ;Pos 5 Parent Event
SET XTEMP=XTEMP_U
+8 ;Pos 6 IB STATUS Pos 7 Units
SET XTEMP=XTEMP_U_"*"_IBSTATNM_U_IBUNITS
+9 ;Pos 8 Total Charge
SET XTEMP=XTEMP_U_IBCHRG
+10 ;Pos 9 AR Bill #
SET XTEMP=XTEMP_U_BILLNUM
+11 ;Pos 10 Category
SET XTEMP=XTEMP_U_$PIECE(BILLTYP,"/",2)
+12 ;Pos 11 Medical DOS Pos 12-14 blank
IF IBBEDST'="PRESCRIPTION"
SET XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")_U_U_U
+13 IF IBBEDST="PRESCRIPTION"
Begin DoDot:1
+14 ; Medical DOS if RX info missing
IF $PIECE(DATEINFO,"/",5)=""
SET XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")_U_U
+15 IF $PIECE(DATEINFO,"/",5)'=""
Begin DoDot:2
+16 ;Pos 11 blank Pos 12 Release RX Date
SET XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")
+17 ;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
+18 ;Pos 15 AR Status ;Pos 15 AR Status
SET XTEMP=XTEMP_U_$EXTRACT($GET(ARSTAT),1,21)
+19 ;Pos 16 Cancel Dt
SET XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT($GET(IBCANCLD),"8D")," ")
+20 ;Pos 17 Cancel Reason
SET XTEMP=XTEMP_U_$EXTRACT($GET(IBCANCLR),1,14)
+21 ;Pos 18 Cancel By
SET XTEMP=XTEMP_U_$EXTRACT($GET(IBCANCLB),1,16)
+22 ;Pos 19 APPR
SET XTEMP=XTEMP_U_$GET(ARAPPR)
+23 ;Pos 20 RSC
SET XTEMP=XTEMP_U_$GET(ARRSC)
+24 ;Get Letter dates if they exist
+25 IF BILLNUM'=""
SET RC430IEN=$ORDER(^PRCA(430,"D",BILLNUM,""))
+26 KILL ARFLDS
+27 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
+28 SET LCNT=0
+29 FOR LTRFLD=61,62,63,68
Begin DoDot:1
+30 IF $GET(RC430IEN)=""
QUIT
+31 ;JMC If LETTER'=1 Q (Do not display letters)
IF $GET(LETTER)'=1
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 ;user wants to display Total Payments Received on Bill Number
IF $GET(LETTER)=2
Begin DoDot:1
+38 SET RCTPR399=+$PIECE($GET(^PRCA(430,RC430IEN,7)),"^",7)
+39 SET XTEMP=XTEMP_U_RCTPR399
End DoDot:1
+40 SET ^TMP($JOB,"RCVCR",BILLNUM,SVCDT,CNT)=XTEMP
+41 KILL XTEMP
+42 QUIT
+43 ; Determine type of bill and the appropriate date falls within the desired date range
+44 ; What date do we use for selection / display?
+45 ; Use event date except for RX (Release DT) and
+46 ; Inpatient (Discharge DT)for selection and Event Dt for (Admission DT) for display
+47 ; For Inpatient
+48 ; #399 Field .08 Pointer to PTF (Patient Transfer File #45) to get Admission and discharge DT
+49 ; For RX
+50 ; Check RC Multiples for BEDSECTION=Prescription & TYPE=RX then ITEM is an IEN to file #362.4
+51 ; #362.4 will have an RX# to lookup in file #52 and a FILL NUMBER (0 or null if original RX or a
+52 ; positive refill number) and if a fill number is present check the appropriate refill in #52
+53 ; check status for inclusion
+54 ;
IB399RX(DFN,RXIEN,IBRXFILL) ; Get Prescription information for 399 bills.
+1 NEW RESPONSE,RXNODE,IBRXNAME,IBRXNUM,RXDATE
+2 KILL ^TMP($JOB,"RXRDT")
+3 SET RESPONSE=""
+4 SET RXNODE="0,2"
+5 IF IBRXFILL>0
SET RXNODE="0,2,R^^"_IBRXFILL
+6 DO RX^PSO52API(DFN,"RXRDT",RXIEN,,RXNODE,,)
+7 IF +$GET(^TMP($JOB,"RXRDT",DFN,0))=-1
SET RESPONSE="RX/"_"399#/"_$PIECE(^TMP($JOB,"RXRDT",DFN,0),U,2)
QUIT RESPONSE
+8 IF IBRXFILL>0
SET RXDATE=$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,"RF",IBRXFILL,17)),U,1)
+9 IF '$TEST
SET RXDATE=$PIECE($GET(^TMP($JOB,"RXRDT",DFN,RXIEN,31)),U,1)
+10 SET RXDATE=RXDATE\1
+11 IF 'RXDATE
SET RXDATE=$GET(IBRXDT)\1
+12 SET IBRXNUM=$SELECT(+RXIEN<1:RXFLDS(362.4,RXITEM_",",.01,"E"),1:^TMP($JOB,"RXRDT",DFN,RXIEN,.01))
+13 SET IBRXNAME=$SELECT(+RXIEN<1:RXFLDS(362.4,RXITEM_",",.04,"E"),1:$PIECE(^TMP($JOB,"RXRDT",DFN,RXIEN,6),U,2))
+14 SET RESPONSE="RX/"_"399/"_RXDATE_"/"_RXDATE_"/"_IBRXNUM_"/"_$EXTRACT(IBRXNAME,1,16)
+15 SET TRIGDT=$PIECE(RESPONSE,"/",3)
+16 IF TRIGDT<FRMDTINT!(TRIGDT>TODTINT)
SET RESPONSE="RX/"_"399#"_"/DATE NOT IN RANGE"
QUIT RESPONSE
+17 QUIT RESPONSE
+18 ;
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 ;
