- 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 Jan 18, 2025@02:44:51 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