RCDMCR5B ;HAF/ASF - First Party Charge IB Cancellation Reconciliation Report - Collect Data; Apr 9, 2019@21:06
;;4.5;Accounts Receivable;**347,361**;Mar 20, 1995;Build 6
;;Per VA Directive 6402, this routine should not be modified.
;
; DBIA 4858 - GET1^PSOSI routine calls
; DBIA 4538 - Action Type File (350.1) lookup
; DBIA 4541 - Integrated Billing Action File lookups
; DBIA 5040 - Outpatient event date lookup for file 409.68
; DBIA 4434 - Action Status lookup
;
; See RCDMCR5A for detailed description
;
COLLECT(STOPIT,CANBEGDT,CANENDDT,BILLPAYS) ; Get the report data
;Input
; STOPIT - Passed Variable to determine if process is to be terminated
; CANBEGDT - Cancellation Begin Date
; CANENDDT - Cancellation End Date
;Output
; STOPIT - Passed Variable set to 1 if process is to be terminated
; ^TMP($J,"RCDMCR5B") with report data and summary data
N DFN,IBIEN,IB0,IB1,CTR,ARIEN,ACTTYPE,BILGROUP,RESULT,IBDATA
N SERVDT,RXDT,NAME,SSN,RXDT,CHGAMT,BILLFRDT,PAID,TRIEN
N BILLNO,RXNUM,RXNAM,CANCDT,CANCUSER,CANCREAS,PARENTE
N VAERR,VADM,VAIP
N APPR,RSC
;Quit if passed parameter variables not populated
I $G(CANBEGDT)'>0,$G(CANENDDT)'>0 Q
S CANCDT=CANBEGDT-.000001
F S CANCDT=$O(^IB("D",CANCDT)) Q:CANCDT="" Q:CANCDT>(CANENDDT+1) D Q:$G(STOPIT)>0
. S IBIEN=""
. F S IBIEN=$O(^IB("D",CANCDT,IBIEN)) Q:IBIEN="" D Q:$G(STOPIT)>0
. . S IB0=$G(^IB(IBIEN,0)),IB1=$G(^IB(IBIEN,1))
. . S ACTTYPE=$P(IB0,U,3)
. . I ACTTYPE="" Q
. . ; SEQUENCE NUMBER (file 350.1, field .05) of 2 is CANCEL
. . I $P($G(^IBE(350.1,ACTTYPE,0)),U,5)'=2 Q
. . S DFN=$P(IB0,U,2)
. . S CTR=$G(CTR)+1 ;Counter
. . I CTR#500=0 S STOPIT=$$STOPIT^RCDMCUT2() Q:STOPIT
. . S BILLNO=$P(IB0,U,11)
. . I BILLNO="" Q
. . ; ASF 8/10/19
. . S ARIEN=$O(^PRCA(430,"B",BILLNO,""))
. . I ARIEN'>0 Q
. . ;Grab the existing Fund. If it doesn't exist, calculate it.
. . S APPR=$$GET1^DIQ(430,ARIEN_",",203)
. . I APPR="" S APPR=$$GETFUNDB^RCXFMSUF(ARIEN,1)
. . ;Grab the existing RSC. If it doesn't exist, calculate it.
. . S RSC=$$GET1^DIQ(430,ARIEN_",",255.1) ;Check for accrued RSC
. . S:RSC="" RSC=$$GET1^DIQ(430,ARIEN_",",255) ;if no accrued RSC, check for non-accrued.
. . S:RSC="" RSC=$$CALCRSC^RCXFMSUR(ARIEN) ;if neither present, calculate
. . ; only look at 1st party bills
. . I '$$FIRSTPAR^RCDMCUT1(ARIEN) Q
. . ; BILLPAYS of 1 means only bills with an IB Bill Status of Cancelled and an AR status of Closed/Collected
. . ; Otherwise, show all bills regardless of the payment status (IB Cancelled, and with any AR Status)
. . ; Note: we no longer check Collected/Closed as per customer. Instead, we check if any transactions associated
. . ; with this bill are payments.
. . I BILLPAYS S PAID=0 D Q:'PAID
. . . S TRIEN=""
. . . F S TRIEN=$O(^PRCA(433,"C",ARIEN,TRIEN)) Q:TRIEN="" I $$GET1^DIQ(433,TRIEN_",",12,"E")?1"PAYMENT (".E S PAID=1 Q
. . D DEM^VADPT
. . I $G(VAERR)>0 D KVAR^VADPT Q
. . S NAME=$G(VADM(1))
. . I NAME']"" Q
. . S SSN=$P(VADM(2),U,1)
. . I SSN']"" Q
. . S SERVDT="",RXDT="",RXNUM="",RXNAM="",CANCREAS="",CANCUSER="" K IBDATA
. . S IENS=IBIEN_","
. . D GETS^DIQ(350,IENS,".1;11","E","IBDATA") ;dbia 4541
. . S BILLFRDT=$P(IB0,U,14)
. . S CANCREAS=$G(IBDATA(350,IENS,.1,"E"))
. . S CANCUSER=$G(IBDATA(350,IENS,11,"E"))
. . I CANCUSER="" S CANCUSER="/"_$P(IB1,U)
. . S BILGROUP=$$GET1^DIQ(350.1,+ACTTYPE_",",.11,"I") ;dbia 4538
. . S RESULT=$P(IB0,U,4)
. . S CHGAMT=$$GET1^DIQ(350,$$PARENTC(IBIEN)_",",.07) ;dbia 4541
. . S PARENTE=$$PARENTE(IBIEN),RESULT=$$GET1^DIQ(350,PARENTE_",",.04,"I"),IENS=PARENTE_"," ;dbia 4541
. . S SERVDT=""
. . ;Inpatient Event
. . I $P(RESULT,":",1)=405!($P(RESULT,":",1)=45) D
. . . S VAIP("E")=$P($P(RESULT,";",1),":",2)
. . . ;Call to get Inpatient data
. . . D IN5^VADPT
. . . Q:VAERR>0
. . . S SERVDT=$P($G(VAIP(17,1)),U,1)
. . . D KVAR^VADPT
. . ;Outpatient Event
. . I BILGROUP=4!($P(RESULT,":",1)=44)!($P(RESULT,":",1)=409.68) D
. . . I $P(RESULT,":",1)=44 S SERVDT=$P($P(RESULT,";",2),":",2)
. . . I $P(RESULT,":",1)=409.68 S SERVDT=$$GET1^DIQ(409.68,+$P(RESULT,":",2)_",",.01,"I") ;dbia 5040
. . . I $G(SERVDT)'>0 S SERVDT=BILLFRDT
. . I SERVDT="" S SERVDT=$$GET1^DIQ(350,IENS,.17,"I") ;dbia 4538
. . ;RX Event
. . I $P(RESULT,":",1)=52 D
. . . N IENS
. . . ;Set up for RX Refills
. . . I $P(RESULT,";",2)]"" D
. . . . S IENS=+$P($P(RESULT,";",2),":",2)_","_+$P($P(RESULT,";",1),":",2)_","
. . . . S RXDT=$$GET1^PSODI(52.1,IENS,17,"I") ;dbia 4858
. . . . S:$P(RXDT,U,2)'?7N.E RXDT=$$GET1^PSODI(52.1,IENS,.01,"I") ;dbia 4858
. . . . I 'RXDT S RXDT="^"
. . . . S RXNUM=$$GET1^PSODI(52,$P($P(RESULT,";",1),":",2)_",",.01,"I") ;dbia 4858
. . . . I 'RXNUM S RXNUM="^"
. . . . S RXNAM=$$GET1^PSODI(52,$P($P(RESULT,";",1),":",2)_",",6,"E") ;dbia 4858
. . . . I 'RXNAM S RXNAM="^"
. . . ;Set up for RX Data (No refill)
. . . I $P(RESULT,";",2)']"" D
. . . . S IENS=+$P($P(RESULT,";",1),":",2)_","
. . . . S RXDT=$$GET1^PSODI(52,IENS,31,"I")
. . . . S:$P(RXDT,U,2)'?7N.E RXDT=$$GET1^PSODI(52,IENS,22,"I") ;dbia 4858
. . . . I 'RXDT S RXDT="^"
. . . . S RXNUM=$$GET1^PSODI(52,IENS,.01,"I") ;dbia 4858
. . . . I 'RXNUM S RXNUM="^"
. . . . S RXNAM=$$GET1^PSODI(52,IENS,6,"E") ;dbia 4858
. . . . I 'RXNAM S RXNAM="^"
. . ; ASF 8/10/19
. . S ^TMP($J,"RCDMCR5B","DETAIL",NAME,SSN,BILLNO,IBIEN)=SERVDT_U_$P(RXDT,U,2)_U_CHGAMT_U_$P(RXNUM,U,2)_U_$P(RXNAM,U,2)_U_CANCDT_U_CANCREAS_U_CANCUSER_U_APPR_U_RSC
Q
PARENTE(IBIEN) ; Go up the parenting event chain of IBIEN and return the original "parent"
N NZ
S NZ=$G(^IB(IBIEN,0))
I $P(NZ,U,16)'="" Q $S(IBIEN=$P(NZ,U,16):IBIEN,1:$$PARENTE($P(NZ,U,16)))
I $P(NZ,U,9)'="" Q $S(IBIEN=$P(NZ,U,9):IBIEN,1:$$PARENTE($P(NZ,U,9)))
I $P(NZ,U,4)?1"350:".E Q $S(IBIEN=(+$P($P(NZ,U,4),":",2)):IBIEN,1:$$PARENTE($P($P(NZ,U,4),":",2)+0))
Q IBIEN
PARENTC(IBIEN) ; Go up the parenting charge chain of IBIEN and return the original "parent" charge
N NZ
S NZ=$G(^IB(IBIEN,0))
I $P(NZ,U,9)'="" Q $S(IBIEN=$P(NZ,U,9):IBIEN,1:$$PARENTC($P(NZ,U,9)))
I $P(NZ,U,4)?1"350:".E Q $S(IBIEN=(+$P($P(NZ,U,4),":",2)):IBIEN,1:$$PARENTC($P($P(NZ,U,4),":",2)+0))
Q IBIEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCDMCR5B 6306 printed Apr 09, 2024@20:44:20 Page 2
RCDMCR5B ;HAF/ASF - First Party Charge IB Cancellation Reconciliation Report - Collect Data; Apr 9, 2019@21:06
+1 ;;4.5;Accounts Receivable;**347,361**;Mar 20, 1995;Build 6
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; DBIA 4858 - GET1^PSOSI routine calls
+5 ; DBIA 4538 - Action Type File (350.1) lookup
+6 ; DBIA 4541 - Integrated Billing Action File lookups
+7 ; DBIA 5040 - Outpatient event date lookup for file 409.68
+8 ; DBIA 4434 - Action Status lookup
+9 ;
+10 ; See RCDMCR5A for detailed description
+11 ;
COLLECT(STOPIT,CANBEGDT,CANENDDT,BILLPAYS) ; Get the report data
+1 ;Input
+2 ; STOPIT - Passed Variable to determine if process is to be terminated
+3 ; CANBEGDT - Cancellation Begin Date
+4 ; CANENDDT - Cancellation End Date
+5 ;Output
+6 ; STOPIT - Passed Variable set to 1 if process is to be terminated
+7 ; ^TMP($J,"RCDMCR5B") with report data and summary data
+8 NEW DFN,IBIEN,IB0,IB1,CTR,ARIEN,ACTTYPE,BILGROUP,RESULT,IBDATA
+9 NEW SERVDT,RXDT,NAME,SSN,RXDT,CHGAMT,BILLFRDT,PAID,TRIEN
+10 NEW BILLNO,RXNUM,RXNAM,CANCDT,CANCUSER,CANCREAS,PARENTE
+11 NEW VAERR,VADM,VAIP
+12 NEW APPR,RSC
+13 ;Quit if passed parameter variables not populated
+14 IF $GET(CANBEGDT)'>0
IF $GET(CANENDDT)'>0
QUIT
+15 SET CANCDT=CANBEGDT-.000001
+16 FOR
SET CANCDT=$ORDER(^IB("D",CANCDT))
if CANCDT=""
QUIT
if CANCDT>(CANENDDT+1)
QUIT
Begin DoDot:1
+17 SET IBIEN=""
+18 FOR
SET IBIEN=$ORDER(^IB("D",CANCDT,IBIEN))
if IBIEN=""
QUIT
Begin DoDot:2
+19 SET IB0=$GET(^IB(IBIEN,0))
SET IB1=$GET(^IB(IBIEN,1))
+20 SET ACTTYPE=$PIECE(IB0,U,3)
+21 IF ACTTYPE=""
QUIT
+22 ; SEQUENCE NUMBER (file 350.1, field .05) of 2 is CANCEL
+23 IF $PIECE($GET(^IBE(350.1,ACTTYPE,0)),U,5)'=2
QUIT
+24 SET DFN=$PIECE(IB0,U,2)
+25 ;Counter
SET CTR=$GET(CTR)+1
+26 IF CTR#500=0
SET STOPIT=$$STOPIT^RCDMCUT2()
if STOPIT
QUIT
+27 SET BILLNO=$PIECE(IB0,U,11)
+28 IF BILLNO=""
QUIT
+29 ; ASF 8/10/19
+30 SET ARIEN=$ORDER(^PRCA(430,"B",BILLNO,""))
+31 IF ARIEN'>0
QUIT
+32 ;Grab the existing Fund. If it doesn't exist, calculate it.
+33 SET APPR=$$GET1^DIQ(430,ARIEN_",",203)
+34 IF APPR=""
SET APPR=$$GETFUNDB^RCXFMSUF(ARIEN,1)
+35 ;Grab the existing RSC. If it doesn't exist, calculate it.
+36 ;Check for accrued RSC
SET RSC=$$GET1^DIQ(430,ARIEN_",",255.1)
+37 ;if no accrued RSC, check for non-accrued.
if RSC=""
SET RSC=$$GET1^DIQ(430,ARIEN_",",255)
+38 ;if neither present, calculate
if RSC=""
SET RSC=$$CALCRSC^RCXFMSUR(ARIEN)
+39 ; only look at 1st party bills
+40 IF '$$FIRSTPAR^RCDMCUT1(ARIEN)
QUIT
+41 ; BILLPAYS of 1 means only bills with an IB Bill Status of Cancelled and an AR status of Closed/Collected
+42 ; Otherwise, show all bills regardless of the payment status (IB Cancelled, and with any AR Status)
+43 ; Note: we no longer check Collected/Closed as per customer. Instead, we check if any transactions associated
+44 ; with this bill are payments.
+45 IF BILLPAYS
SET PAID=0
Begin DoDot:3
+46 SET TRIEN=""
+47 FOR
SET TRIEN=$ORDER(^PRCA(433,"C",ARIEN,TRIEN))
if TRIEN=""
QUIT
IF $$GET1^DIQ(433,TRIEN_",",12,"E")?1"PAYMENT (".E
SET PAID=1
QUIT
End DoDot:3
if 'PAID
QUIT
+48 DO DEM^VADPT
+49 IF $GET(VAERR)>0
DO KVAR^VADPT
QUIT
+50 SET NAME=$GET(VADM(1))
+51 IF NAME']""
QUIT
+52 SET SSN=$PIECE(VADM(2),U,1)
+53 IF SSN']""
QUIT
+54 SET SERVDT=""
SET RXDT=""
SET RXNUM=""
SET RXNAM=""
SET CANCREAS=""
SET CANCUSER=""
KILL IBDATA
+55 SET IENS=IBIEN_","
+56 ;dbia 4541
DO GETS^DIQ(350,IENS,".1;11","E","IBDATA")
+57 SET BILLFRDT=$PIECE(IB0,U,14)
+58 SET CANCREAS=$GET(IBDATA(350,IENS,.1,"E"))
+59 SET CANCUSER=$GET(IBDATA(350,IENS,11,"E"))
+60 IF CANCUSER=""
SET CANCUSER="/"_$PIECE(IB1,U)
+61 ;dbia 4538
SET BILGROUP=$$GET1^DIQ(350.1,+ACTTYPE_",",.11,"I")
+62 SET RESULT=$PIECE(IB0,U,4)
+63 ;dbia 4541
SET CHGAMT=$$GET1^DIQ(350,$$PARENTC(IBIEN)_",",.07)
+64 ;dbia 4541
SET PARENTE=$$PARENTE(IBIEN)
SET RESULT=$$GET1^DIQ(350,PARENTE_",",.04,"I")
SET IENS=PARENTE_","
+65 SET SERVDT=""
+66 ;Inpatient Event
+67 IF $PIECE(RESULT,":",1)=405!($PIECE(RESULT,":",1)=45)
Begin DoDot:3
+68 SET VAIP("E")=$PIECE($PIECE(RESULT,";",1),":",2)
+69 ;Call to get Inpatient data
+70 DO IN5^VADPT
+71 if VAERR>0
QUIT
+72 SET SERVDT=$PIECE($GET(VAIP(17,1)),U,1)
+73 DO KVAR^VADPT
End DoDot:3
+74 ;Outpatient Event
+75 IF BILGROUP=4!($PIECE(RESULT,":",1)=44)!($PIECE(RESULT,":",1)=409.68)
Begin DoDot:3
+76 IF $PIECE(RESULT,":",1)=44
SET SERVDT=$PIECE($PIECE(RESULT,";",2),":",2)
+77 ;dbia 5040
IF $PIECE(RESULT,":",1)=409.68
SET SERVDT=$$GET1^DIQ(409.68,+$PIECE(RESULT,":",2)_",",.01,"I")
+78 IF $GET(SERVDT)'>0
SET SERVDT=BILLFRDT
End DoDot:3
+79 ;dbia 4538
IF SERVDT=""
SET SERVDT=$$GET1^DIQ(350,IENS,.17,"I")
+80 ;RX Event
+81 IF $PIECE(RESULT,":",1)=52
Begin DoDot:3
+82 NEW IENS
+83 ;Set up for RX Refills
+84 IF $PIECE(RESULT,";",2)]""
Begin DoDot:4
+85 SET IENS=+$PIECE($PIECE(RESULT,";",2),":",2)_","_+$PIECE($PIECE(RESULT,";",1),":",2)_","
+86 ;dbia 4858
SET RXDT=$$GET1^PSODI(52.1,IENS,17,"I")
+87 ;dbia 4858
if $PIECE(RXDT,U,2)'?7N.E
SET RXDT=$$GET1^PSODI(52.1,IENS,.01,"I")
+88 IF 'RXDT
SET RXDT="^"
+89 ;dbia 4858
SET RXNUM=$$GET1^PSODI(52,$PIECE($PIECE(RESULT,";",1),":",2)_",",.01,"I")
+90 IF 'RXNUM
SET RXNUM="^"
+91 ;dbia 4858
SET RXNAM=$$GET1^PSODI(52,$PIECE($PIECE(RESULT,";",1),":",2)_",",6,"E")
+92 IF 'RXNAM
SET RXNAM="^"
End DoDot:4
+93 ;Set up for RX Data (No refill)
+94 IF $PIECE(RESULT,";",2)']""
Begin DoDot:4
+95 SET IENS=+$PIECE($PIECE(RESULT,";",1),":",2)_","
+96 SET RXDT=$$GET1^PSODI(52,IENS,31,"I")
+97 ;dbia 4858
if $PIECE(RXDT,U,2)'?7N.E
SET RXDT=$$GET1^PSODI(52,IENS,22,"I")
+98 IF 'RXDT
SET RXDT="^"
+99 ;dbia 4858
SET RXNUM=$$GET1^PSODI(52,IENS,.01,"I")
+100 IF 'RXNUM
SET RXNUM="^"
+101 ;dbia 4858
SET RXNAM=$$GET1^PSODI(52,IENS,6,"E")
+102 IF 'RXNAM
SET RXNAM="^"
End DoDot:4
End DoDot:3
+103 ; ASF 8/10/19
+104 SET ^TMP($JOB,"RCDMCR5B","DETAIL",NAME,SSN,BILLNO,IBIEN)=SERVDT_U_$PIECE(RXDT,U,2)_U_CHGAMT_U_$PIECE(RXNUM,U,2)_U_$PIECE(RXNAM,U,2)_U_CANCDT_U_CANCREAS_U_CANCUSER_U_APPR_U_RSC
End DoDot:2
if $GET(STOPIT)>0
QUIT
End DoDot:1
if $GET(STOPIT)>0
QUIT
+105 QUIT
PARENTE(IBIEN) ; Go up the parenting event chain of IBIEN and return the original "parent"
+1 NEW NZ
+2 SET NZ=$GET(^IB(IBIEN,0))
+3 IF $PIECE(NZ,U,16)'=""
QUIT $SELECT(IBIEN=$PIECE(NZ,U,16):IBIEN,1:$$PARENTE($PIECE(NZ,U,16)))
+4 IF $PIECE(NZ,U,9)'=""
QUIT $SELECT(IBIEN=$PIECE(NZ,U,9):IBIEN,1:$$PARENTE($PIECE(NZ,U,9)))
+5 IF $PIECE(NZ,U,4)?1"350:".E
QUIT $SELECT(IBIEN=(+$PIECE($PIECE(NZ,U,4),":",2)):IBIEN,1:$$PARENTE($PIECE($PIECE(NZ,U,4),":",2)+0))
+6 QUIT IBIEN
PARENTC(IBIEN) ; Go up the parenting charge chain of IBIEN and return the original "parent" charge
+1 NEW NZ
+2 SET NZ=$GET(^IB(IBIEN,0))
+3 IF $PIECE(NZ,U,9)'=""
QUIT $SELECT(IBIEN=$PIECE(NZ,U,9):IBIEN,1:$$PARENTC($PIECE(NZ,U,9)))
+4 IF $PIECE(NZ,U,4)?1"350:".E
QUIT $SELECT(IBIEN=(+$PIECE($PIECE(NZ,U,4),":",2)):IBIEN,1:$$PARENTC($PIECE($PIECE(NZ,U,4),":",2)+0))
+5 QUIT IBIEN
