Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCVCR2

RCVCR2.m

Go to the documentation of this file. 
  1. 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
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1.  ;External References  Type       ICR #
  1.  ;-------------------  ---------- -----
  1.  ; GETS^DIQ            Supported  2056
  1.  ; EN^DIQ1             Supported  10015
  1.  ; RX^PSO52API         Supported  4820
  1.  ; $$FMTE^XLFDT        Supported  10103
  1.  ; $$STRIP^XLFSTR      Supported  10104
  1.  ;
  1.  ;ICR#  TYPE          DESCRIPTION
  1.  ;----- ----------    ---------------------
  1.  ; 7217 Private       File (#399), access to "C" cross-reference and fields (#.08),(#.17),(#18),(#19)
  1.  ; 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
  1.  ; 1992 Contr. Sub.   File (#399), access to field (#17)
  1.  ; 418  Contr. Sub.   File (#45),  access to discharge Date field (#70), Admission Date Field (#2)  ;jmc
  1.  ; 6033 Contr. Sub.   File (#362.4) access to "C" cross reference and access for fields (#.01), (#.03), (#.04), (#.05), (#.1)
  1.  ;
  1. GET399 ; Insert code to loop through 399 here
  1.  N IBIEN,IBFLDS,BILLCLAS,BILLTYP,BILLNUM,EVNTDT,MULT,X,RCNODE,D1,IBRSC,IBCHRG,IBRXNAM
  1.  N IBUNITS,IBBEDST,IBTYPE,SVCDT,IBSTATNM,CNT,DIC,DR,DA,DIQ,IBBCPR,ARAPPR,ARRSC,ARSTAT,ARIEN
  1.  S IBUNITS=1,(ARSTAT,ARAPPR,ARRSC)=""
  1.  ; Start by using the patient index "C" to get all records for patient
  1.  I '$D(^DGCR(399,"C",DFN)) Q  ;No file 399 records for patient
  1.  S IBIEN=0
  1.  F  S IBIEN=$O(^DGCR(399,"C",DFN,IBIEN)) Q:IBIEN=""  D
  1.  . K IBFLDS,IBERR,IBBEDST
  1.  . ; Fields captured
  1.  . ;    .01 BILL NUMBER [BILLNUM]
  1.  . ;    .03 Event Date  [EVNTDT]
  1.  . ;    .05 Bill Classification  [BILLCLAS]
  1.  . ;    .07 Rate Type
  1.  . ;    .08 PTF Entry Number
  1.  . ;    .11 Who's Responsible for Bill?
  1.  . ;    .13 Status [STAT]
  1.  . ;    .17 Primary Bill [PBILL]
  1.  . ;    151 Statement Covers From  ;jmc
  1.  . ;     42 Revenue Code ([Multiple] capture all fields of all multiples)
  1.  . ;     17 Date Bill Cancelled
  1.  . ;     18 Bill Cancelled By
  1.  . ;     19 Reason Cancelled
  1.  . K DIC,DR,DA,DIQ
  1.  . ;D GETS^DIQ(399,IBIEN_",",".01;.03;.05;.07;.08;.11;.13;.17;17;18;19;42*","IE","IBFLDS","IBERR")
  1.  . D GETS^DIQ(399,IBIEN_",",".01;.03;.05;.07;.08;.11;.13;.17;17;18;19;151;42*","IE","IBFLDS","IBERR")  ;jmc
  1.  . Q:$D(IBERR)
  1.  . S BILLTYP="/"_IBFLDS(399,IBIEN_",",.07,"E")_"/"
  1.  . I "/HUMANITARIAN/INELIGIBLE/MEANS TEST/DENTAL/"'[BILLTYP Q  ;Exclude all but specific Bill Type
  1.  . ; All of these are patient responsibility
  1.  . I IBFLDS(399,IBIEN_",",.11,"I")'="p" Q  ;exclude all but patient responsibility
  1.  . ; Skip all that don't fall into the required rate types
  1.  . ; Determine STATUS and skip any that are not 3 AUTHORIZED,4 PRNT/TX,7 CANCELLED
  1.  . I "/3/4/7/"'[IBFLDS(399,IBIEN_",",.13,"I") Q
  1.  . S BILLCLAS=IBFLDS(399,IBIEN_",",.05,"I")
  1.  . D PROC399
  1.  K XTEMP
  1.  Q
  1.  ;
  1. PROC399 ; Process one 399 record
  1.  ;N XTEMP,IBDISDT,DATEINFO,IBBCNUM,IBPTF,IBXDRG,IENS,IBRXFLG,FLAG399,IBADMDT
  1.  N XTEMP,IBDISDT,DATEINFO,IBBCNUM,IBXDRG,IENS,IBRXFLG,FLAG399  ;jmc
  1.  N IBCANCLD,IBCANCLR,IBCANCLB,ARFLDS
  1.  S FLAG399=0
  1.  S IBSTATNM=IBFLDS(399,IBIEN_",",.13,"E")
  1.  S BILLNUM=IBFLDS(399,IBIEN_",",.01,"E")
  1.  S EVNTDT=IBFLDS(399,IBIEN_",",.03,"I")\1
  1.  S SVCDT=EVNTDT
  1.  S TRIGDT=EVNTDT
  1.  ; If there are more than one RC multiple split them into separate lines
  1.  ; if prescription get info from File 52 especially Release Date
  1.  ; if inpatient get discharge use Event date as Admission date
  1.  I BILLCLAS=1!(BILLCLAS=2) D  ; Inpatient
  1.  . S IBDISDT=""
  1.  . ;S IBPTF=$G(IBFLDS(399,IBIEN_",",.08,"I")) ; Read PTF file
  1.  . ;jmc
  1.  . N IBFROMDT
  1.  . S IBFROMDT=$G(IBFLDS(399,IBIEN_",",151,"I")) ;^DGCR(399,D0,U)= (#151) STATEMENT COVERS FROM [1D] 
  1.  . I IBFROMDT'="" S TRIGDT=IBFROMDT,IBDISDT=IBFROMDT,EVNTDT=IBFROMDT
  1.  . ;I IBPTF'="" S IENS=IBPTF_"," S IBDISDT=$$GET1^DIQ(45,IENS,70,"I",,"45ERR")\1
  1.  . ;I IBDISDT'="" S TRIGDT=IBDISDT  ;jmc
  1.  I (BILLCLAS=1!BILLCLAS=2),(IBDISDT="") Q  ; Inpatient not billed until discharged
  1.  ; Get information from file #430
  1.  I BILLNUM'="" S ARIEN=$O(^PRCA(430,"D",BILLNUM,"")) ;Get IEN to 430 based on bill number
  1.  I BILLNUM'="",$G(ARIEN)'="" D
  1.  . S DIC=430,DR="3;8;203;255.1",DA=ARIEN,DIQ="ARFLDS",DIQ(0)="IE" D EN^DIQ1
  1.  . S (ARSTAT,ARAPPR,ARRSC)=""
  1.  . S ARSTAT=$E($G(ARFLDS(430,ARIEN,8,"E")),1,21) ; AR Status
  1.  . S ARAPPR=$G(ARFLDS(430,ARIEN,203,"E")) ; APPR
  1.  . I ARAPPR="" S ARAPPR="RVW"
  1.  . S ARRSC=$G(ARFLDS(430,ARIEN,255.1,"E")) ; RSC
  1.  . I ARRSC="" S ARRSC="RVW"
  1.  ; Get Cancellation Info
  1.  S IBCANCLD=$G(IBFLDS(399,IBIEN_",",17,"I"))
  1.  S IBCANCLR=$G(IBFLDS(399,IBIEN_",",19,"E"))
  1.  S IBCANCLB=$G(IBFLDS(399,IBIEN_",",18,"E"))
  1.  ;
  1.  I '$D(IBFLDS(399.042)) D  Q  ;Handle no revenue codes
  1.  . 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
  1.  . E  S IBCHRG=$G(ARFLDS(430,ARIEN,3,"E")) ; ORIGINAL AMOUNT from #430
  1.  . I IBCHRG="" S IBCHRG=0
  1.  . S IBBCNUM=0
  1.  . ; Get RX infor if any
  1.  . S IBRXFLG=0 ;Flag if RX information
  1.  . 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
  1.  . S TRIGDT=EVNTDT I TRIGDT<FRMDTINT!(TRIGDT>TODTINT) Q
  1.  . I 'IBRXFLG,'$D(^IBA(362.4,"C",IBIEN)) Q:IBSVCTYP=2  D ST399TMP ;display the Medical Care only
  1.  I $D(IBFLDS(399.042)) D RCNODE S FLAG399=1
  1.  Q
  1.  ;
  1. RCNODE ; Capture Revenue Code Node information
  1.  N IBITEM,RCCNT,IBRXDT,RXFLDS
  1.  S IBRXFLG=0,IBRXDT=""
  1.  S X="",MULT=0 F  S X=$O(IBFLDS(399.042,X),-1) Q:X=""  S MULT=MULT+1
  1.  S (IBRSC,IBCHRG,IBUNITS,IBBEDST,IBTYPE,IBITEM,IBBCPR,IBRXFILL,IBRXNUM,RXIEN,RCNODE)=""
  1.  F RCCNT=1:1:MULT D  ; Build a separate line in the report
  1.  . S RCNODE=$O(IBFLDS(399.042,RCNODE))
  1.  . S D1=+RCNODE
  1.  . S IBRSC=IBFLDS(399.042,RCNODE,.01,"E") ;Revenue Source Code
  1.  . I IBRSC="" S IBRSC="RVW"
  1.  . S IBCHRG=IBFLDS(399.042,RCNODE,.04,"E") ; Total Charge
  1.  . S IBUNITS=IBFLDS(399.042,RCNODE,.03,"E") ; Units of service
  1.  . S IBBEDST=IBFLDS(399.042,RCNODE,.05,"E") ; Bed Section 
  1.  . S IBTYPE=IBFLDS(399.042,RCNODE,.1,"E") ; IB Type
  1.  . S IBITEM=IBFLDS(399.042,RCNODE,.11,"I") ; ITEM number (For RX pointer to file #362.4)
  1.  . S SVCDT=EVNTDT
  1.  . I IBSVCTYP=2,$G(IBBEDST)'="PRESCRIPTION" Q  ; Only include 399 RX charges
  1.  . I IBSVCTYP=1,$G(IBBEDST)="PRESCRIPTION" Q  ; Only include 399 non RX charges
  1.  . I $G(IBBEDST)="PRESCRIPTION" D
  1.  . . S DATEINFO="RX/"_"399/"_SVCDT_"/"_SVCDT_"//"
  1.  . . I IBITEM="" D CHKBCRX ; add check of "C" index if IBITEM=""
  1.  . . I IBITEM="" Q
  1.  . . S IBBCPR=IBITEM
  1.  . . K DIC,DR,DA,DIQ,IBERR,RXFLDS
  1.  . . D GETS^DIQ(362.4,IBITEM_",",".01;.03;.04;.1","IE","RXFLDS","IBERR")
  1.  . . Q:$D(IBERR)
  1.  . . S IBRXNUM=RXFLDS(362.4,IBITEM_",",.01,"E") ;RX Number
  1.  . . S IBRXFILL=RXFLDS(362.4,IBITEM_",",.1,"E") ;Fill Number
  1.  . . S IBRXNAM=RXFLDS(362.4,IBITEM_",",.04,"E") ;Drug from file #50
  1.  . . S IBRXDT=RXFLDS(362.4,IBITEM_",",.03,"I") ;IB 362.4 date
  1.  . . I IBRXNUM="" Q
  1.  . . I +IBRXNUM>0 D
  1.  . . . S RXIEN=0 S RXIEN=$$GETIEN52(DFN,IBRXNUM)
  1.  . . . I +RXIEN<1 D  ;If RXIEN is equal to zero, then get all the RX info from file #362.4
  1.  . . . . S RXIEN=+$G(RXFLDS(362.4,IBITEM_",",.01,"I")) ;this RXIEN comes from file 362.4
  1.  . . . . S DATEINFO="RX/"_"399/"_IBRXDT_"/"_IBRXDT_"/"_IBRXNUM_"/"_$E(IBRXNAM,1,16)
  1.  . . . E  S DATEINFO=$$IB399RX(DFN,RXIEN,+IBRXFILL)
  1.  . . I +IBRXNUM'>0 D
  1.  . . . S DATEINFO="RX/"_"399/"_EVNTDT_"/"_EVNTDT_"/"_IBRXNUM_"/"_$E(IBRXNAM,1,16)
  1.  . . S SVCDT=$P(DATEINFO,"/",3)
  1.  . . S TRIGDT=$P(DATEINFO,"/",3)
  1.  . I TRIGDT<FRMDTINT!(TRIGDT>TODTINT) Q
  1.  . I 'IBRXFLG D ST399TMP
  1.  Q
  1.  ;
  1. ST399TMP ; Write one 399 record into TMP file
  1.  N LCNT,LTRFLD,RC430IEN,TLTR,RCTPR399
  1.  S (CNT,RCTPR399)=0
  1.  S IBBEDST=$G(IBBEDST)
  1.  I $D(^TMP($J,"RCVCR",BILLNUM,SVCDT)) S CNT="" S CNT=$O(^TMP($J,"RCVCR",BILLNUM,SVCDT,CNT),-1)+1
  1.  S XTEMP=399_U_IBIEN_U ; Pos 1-3 FILE^IBIEN^IB Ref #
  1.  S XTEMP=XTEMP_U ;Pos 4 Parent Charge 
  1.  S XTEMP=XTEMP_U ;Pos 5 Parent Event
  1.  S XTEMP=XTEMP_U_"*"_IBSTATNM_U_IBUNITS ;Pos 6 IB STATUS Pos 7 Units
  1.  S XTEMP=XTEMP_U_IBCHRG ;Pos 8 Total Charge
  1.  S XTEMP=XTEMP_U_BILLNUM ;Pos 9 AR Bill #
  1.  S XTEMP=XTEMP_U_$P(BILLTYP,"/",2) ;Pos 10 Category
  1.  I IBBEDST'="PRESCRIPTION" S XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")_U_U_U ;Pos 11  Medical DOS Pos 12-14 blank
  1.  I IBBEDST="PRESCRIPTION" D
  1.  . I $P(DATEINFO,"/",5)="" S XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ")_U_U ; Medical DOS if RX info missing
  1.  . I $P(DATEINFO,"/",5)'="" D
  1.  . . S XTEMP=XTEMP_U_U_$$STRIP^XLFSTR($$FMTE^XLFDT(SVCDT,"8D")," ") ;Pos 11 blank Pos 12 Release RX Date
  1.  . . S XTEMP=XTEMP_U_$P(DATEINFO,"/",5)_U_$P(DATEINFO,"/",6) ;Pos 13 RX Number, Pos 14 RX Name
  1.  S XTEMP=XTEMP_U_$E($G(ARSTAT),1,21) ;Pos 15 AR Status ;Pos 15 AR Status
  1.  S XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT($G(IBCANCLD),"8D")," ") ;Pos 16 Cancel Dt
  1.  S XTEMP=XTEMP_U_$E($G(IBCANCLR),1,14) ;Pos 17 Cancel Reason
  1.  S XTEMP=XTEMP_U_$E($G(IBCANCLB),1,16) ;Pos 18 Cancel By
  1.  S XTEMP=XTEMP_U_$G(ARAPPR) ;Pos 19 APPR
  1.  S XTEMP=XTEMP_U_$G(ARRSC)  ;Pos 20 RSC
  1.  ;Get Letter dates if they exist
  1.  I BILLNUM'="" S RC430IEN=$O(^PRCA(430,"D",BILLNUM,""))
  1.  K ARFLDS
  1.  S DIC=430,DR="61:63;68",DA=$S($G(RC430IEN)'="":RC430IEN,1:$G(BILLNUM)),DIQ="ARFLDS",DIQ(0)="I" D EN^DIQ1
  1.  S LCNT=0
  1.  F LTRFLD=61,62,63,68 D
  1.  . I $G(RC430IEN)="" Q
  1.  . I $G(LETTER)'=1 Q  ;JMC If LETTER'=1 Q (Do not display letters)
  1.  . S LCNT=LCNT+1 S TLTR="LTR"_LCNT
  1.  . S @TLTR=ARFLDS(430,RC430IEN,LTRFLD,"I")
  1.  . I @TLTR'="" S XTEMP=XTEMP_U_$$STRIP^XLFSTR($$FMTE^XLFDT(@TLTR,"8D")," ") ; Pos 21-24 Letter 1-4
  1.  . I @TLTR="" S XTEMP=XTEMP_U_"NO DATE" ; Pos 21-24 Letter 1-4
  1.  I +XTEMP=399,$P(XTEMP,U,12)'="",$P(XTEMP,U,13)="" S $P(XTEMP,U,13)="PHARMACY"
  1.  I $G(LETTER)=2 D  ;user wants to display Total Payments Received on Bill Number
  1.  . S RCTPR399=+$P($G(^PRCA(430,RC430IEN,7)),"^",7)
  1.  . S XTEMP=XTEMP_U_RCTPR399
  1.  S ^TMP($J,"RCVCR",BILLNUM,SVCDT,CNT)=XTEMP
  1.  K XTEMP
  1.  Q
  1.  ; Determine type of bill and the appropriate date falls within the desired date range
  1.  ; What date do we use for selection / display?
  1.  ;   Use event date except for RX (Release DT) and 
  1.  ;      Inpatient (Discharge DT)for selection and Event Dt for (Admission DT) for display
  1.  ; For Inpatient
  1.  ; #399 Field .08 Pointer to PTF (Patient Transfer File #45) to get Admission and discharge DT 
  1.  ; For RX
  1.  ; Check RC Multiples for BEDSECTION=Prescription  & TYPE=RX then ITEM is an IEN to file #362.4
  1.  ; #362.4 will have an RX# to lookup in file #52 and a FILL NUMBER (0 or null if original RX or a
  1.  ; positive refill number) and if a fill number is present check the appropriate refill in #52
  1.  ; check status for inclusion
  1.  ;
  1. IB399RX(DFN,RXIEN,IBRXFILL) ; Get Prescription information for 399 bills.
  1.  N RESPONSE,RXNODE,IBRXNAME,IBRXNUM,RXDATE
  1.  K ^TMP($J,"RXRDT")
  1.  S RESPONSE=""
  1.  S RXNODE="0,2"
  1.  I IBRXFILL>0 S RXNODE="0,2,R^^"_IBRXFILL
  1.  D RX^PSO52API(DFN,"RXRDT",RXIEN,,RXNODE,,)
  1.  I +$G(^TMP($J,"RXRDT",DFN,0))=-1 S RESPONSE="RX/"_"399#/"_$P(^TMP($J,"RXRDT",DFN,0),U,2) Q RESPONSE
  1.  I IBRXFILL>0 S RXDATE=$P($G(^TMP($J,"RXRDT",DFN,RXIEN,"RF",IBRXFILL,17)),U,1)
  1.  E  S RXDATE=$P($G(^TMP($J,"RXRDT",DFN,RXIEN,31)),U,1)
  1.  S RXDATE=RXDATE\1
  1.  I 'RXDATE S RXDATE=$G(IBRXDT)\1
  1.  S IBRXNUM=$S(+RXIEN<1:RXFLDS(362.4,RXITEM_",",.01,"E"),1:^TMP($J,"RXRDT",DFN,RXIEN,.01))
  1.  S IBRXNAME=$S(+RXIEN<1:RXFLDS(362.4,RXITEM_",",.04,"E"),1:$P(^TMP($J,"RXRDT",DFN,RXIEN,6),U,2))
  1.  S RESPONSE="RX/"_"399/"_RXDATE_"/"_RXDATE_"/"_IBRXNUM_"/"_$E(IBRXNAME,1,16)
  1.  S TRIGDT=$P(RESPONSE,"/",3)
  1.  I TRIGDT<FRMDTINT!(TRIGDT>TODTINT) S RESPONSE="RX/"_"399#"_"/DATE NOT IN RANGE" Q RESPONSE
  1.  Q RESPONSE
  1.  ;
  1. CHKBCRX ;
  1.  N RXITEM
  1.  S IBBCNUM=0
  1.  F  S IBBCNUM=$O(^IBA(362.4,"C",IBIEN,IBBCNUM)) Q:IBBCNUM=""  D
  1.  . S IBRXFLG=1,RXITEM=IBBCNUM
  1.  . S DATEINFO=""
  1.  . S IBERR=""
  1.  . K RXFLDS D GETS^DIQ(362.4,RXITEM_",",".01;.03;.04;.05;.1","IE","RXFLDS","IBERR")
  1.  . I IBERR Q
  1.  . S IBRXNUM=RXFLDS(362.4,RXITEM_",",.01,"E") ;RX Number
  1.  . S IBRXFILL=RXFLDS(362.4,RXITEM_",",.1,"E") ;Fill Number
  1.  . S IBRXDT=RXFLDS(362.4,RXITEM_",",.03,"I") ;IB 362.4 date
  1.  . S IBRXNAM=RXFLDS(362.4,RXITEM_",",.04,"E") ;Drug from file #50 
  1.  . S RXIEN=RXFLDS(362.4,RXITEM_",",.05,"I") ;IEN into file 52
  1.  . S DATEINFO=$$IB399RX(DFN,RXIEN,IBRXFILL)
  1.  . S TRIGDT=$P(DATEINFO,"/",3)
  1.  . I TRIGDT<FRMDTINT!(TRIGDT>TODTINT) Q
  1.  . S SVCDT=$P(DATEINFO,"/",3)
  1.  . 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
  1.  . D ST399TMP
  1.  Q
  1.  ;
  1. GETIEN52(RCDFN,RCRX) ;return IEN for #52 by RX# and DFN
  1.  N RCRET
  1.  K ^TMP($J,"RCPRRX")
  1.  D RX^PSO52API(RCDFN,"RCPRRX",,RCRX,"0")
  1.  I +$G(^TMP($J,"RCPRRX",RCDFN,0))=-1 Q 0
  1.  S RCRET=+$O(^TMP($J,"RCPRRX",RCDFN,0))
  1.  K ^TMP($J,"RCPRRX")
  1.  Q RCRET
  1.  ;