IBJDF71 ;ALB/MR - REPAYMENT PLAN REPORT (COMPILE);15-AUG-00
;;2.0;INTEGRATED BILLING;**123**;21-MAR-94
;
ST ; - Tasked entry point.
K IB,^TMP("IBJDF7",$J),^TMP("IBJDF7PAT",$J) S IBQ=0
;
; - Initialize the array IB
F I=1:1:12 S IB(I)=0
;
; - Find the data required for report. Loops through all the Active
; Bills (Status 16) and checks if bill has a Repayment Plan
;
S IBDA=""
F S IBDA=$O(^PRCA(430,"AC",16,IBDA)) Q:'IBDA D Q:IBQ
. I IBDA#100=0 S IBQ=$$STOP^IBOUTL("Repayment Plan Report") Q:IBQ
. S IBAR=$G(^PRCA(430,IBDA,0)) Q:'IBAR
. I '$P($G(^PRCA(430,IBDA,4)),"^") Q ; No Repayment Plan
. S IBCAT=+$P(IBAR,"^",2) ; Gets valid AR category.
. I '$$MCCR(IBCAT) Q ; Checks MCCR vs. NON-MCCR
. S DEB=$P(IBAR,"^",9) ; Gets the pointer to the Debtor
. S IBPAT=$$PAT(DEB) Q:IBPAT="" ; Gets patient info.
. S DFN=$P(IBPAT,"^",5) ; Gets the pointer to the Patient
. ;
. ; - Retrieves Repayment Plan Data
. S IBRP=$$REPDATA^RCBECHGA(IBDA,IBDAYS)
. S IBCHK=0 I IBRP="" S IBCHK=$$DBLCHK(IBDA) I 'IBCHK Q
. ;
. ; - Set the temporary global
. I IBPLN="B"!(IBPLN="C"&'$P(IBRP,"^",8))!(IBPLN="D"&$P(IBRP,"^",8)) D
. . S KEY=$P(IBPAT,"^")
. . S IBPT=$G(^TMP("IBJDF7",$J,KEY,DFN))
. . I IBPT="" S IBPT=$P(IBPAT,"^",2,4)
. . I $P(IBRP,"^",8),'$P(IBPT,"^",4) S $P(IBPT,"^",4)=1
. . S ^TMP("IBJDF7",$J,KEY,DFN)=IBPT
. . S ^TMP("IBJDF7",$J,KEY,DFN,$P(IBAR,"^"))=IBRP_"^"_$$BAL(IBDA)
. ;
. ; - Updates the IB array for the Summary Report
. I 'IBCHK D SUM(IBRP,DFN)
;
I 'IBQ D EN^IBJDF72 ; Print the report.
;
ENQ K ^TMP("IBJDF7",$J),^TMP("IBJDF7PAT",$J)
I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
;
D ^%ZISC
ENQ1 K DFN,I,IB,IBCHK,IBDA,IBAR,IBCAT,IBCD,IBPAT,IBPT,IBQ,IBRP,KEY
Q
;
MCCR(X) ; - Checks if the Bill category is the type selected by the users
; (MCCR or NON-MCCR)
; Input: X=AR category pointer to file #430.2
; Output: Y= 1 - Matches user selection / 0 - Doesn't match
;
I (X>11&(X<18))!(X=19)!(X=20)!(X>26&(X<32)) Q:IBMCR="N" 1 Q 0
I IBMCR="M" Q 1
Q 0
;
PAT(DEB) ; - Find the AR patient and decide to include the AR.
; Input: DEB=Debtor file pointer (file #340)
; Output: Y=Sort key (name or SSN) ^ Name ^ SSN ^ Date of death (if any)
; ^Pointer to Patient file
;
N DEATH,DFN,KEY,NAME,SSN,VA,VADM,VAERR,Y,RCDZ
S Y="" I 'DEB G PATQ
S RCDZ=$G(^RCD(340,DEB,0)) I $P(RCDZ,"^")'["DPT" G PATQ
S DFN=+RCDZ
D DEM^VADPT S NAME=VADM(1),SSN=$P(VADM(2),"^",2),DEATH=$P(VADM(6),".")
S KEY=$S(IBSN="N":NAME,1:$P(SSN,"-",3))
S Y="" I KEY=""!(IBSNF'="@"&('DFN)) G PATQ
I $D(IBSNA) G:IBSNA="ALL"&('DFN) PATQ G:IBSNA="NULL"&(DFN) PATQ
I IBSNF="@",IBSNL="zzzzz" G PATC
I IBSNF]KEY!(KEY]IBSNL) G PATQ
;
PATC S Y=KEY_"^"_NAME_"^"_SSN_"^"_DEATH_"^"_DFN
PATQ Q Y
;
BAL(BILL) ; Calculates the Account Balance for the Bill
; Input: BILL - Bill internal # - Pointer to file #430
; Output: BAL - Bill Balance
;
N B7,BAL,I
;
S B7=$G(^PRCA(430,BILL,7))
S BAL=0 F I=1:1:5 S BAL=BAL+$P(B7,"^",I)
;
Q BAL
;
DBLCHK(BILL) ; Double-checks if the receivable does not have any Repayment
; Plan information at all
; Output: 0 - No Repayment Plan Info or Repayment Plan paid in full
; 1 - Some Repayment Plan Info
;
N ARZ,DBLCHK,I,IBPMT
;
S DBLCHK=0
; - Repayment Plan has been paid in full
S IBPMT=$O(^PRCA(430,BILL,5,999),-1)
I IBPMT,$P($G(^PRCA(430,BILL,5,IBPMT)),"^",2) Q DBLCHK
;
; - Looks for some information on file about the Repayment Plan
S ARZ=$G(^PRCA(430,BILL,4))
F I=1:1:4 I $P(ARZ,"^",I)'="" S DBLCHK=1 Q
;
Q DBLCHK
;
SUM(IBRP,DFN) ; Sets the array IB with the Summary information
; Input: IBRP=Array returned by the function $$RP (See estructure above)
; DFN=Pointer to the Patient file
; Output: Updates the IB array with summary iformation
;
N X S X=$S($P(IBRP,"^",8):"D",1:"C")
;
; - Updates summary information for Defaulted Plans
I X="D" D
. S IB(1)=IB(1)+1
. I '$D(^TMP("IBJDF7PAT",$J,DFN,X)) S IB(2)=IB(2)+1
;
; - Updates summary information for Current Plans
I X="C" D
. S IB(5)=IB(5)+1
. I '$D(^TMP("IBJDF7PAT",$J,DFN,X)) S IB(6)=IB(6)+1
;
; - Defaulted Outstanding balance and # of Payments
S IB(3)=IB(3)+($P(IBRP,"^",3)*$P(IBRP,"^",8))
S IB(4)=IB(4)+$P(IBRP,"^",8)
;
; - Current Outstanding balance and # of Payments
S IB(7)=IB(7)+($P(IBRP,"^",3)*($P(IBRP,"^",7)-$P(IBRP,"^",8)))
S IB(8)=IB(8)+($P(IBRP,"^",7)-$P(IBRP,"^",8))
;
; - Total Number of Patients (Unique)
I '$D(^TMP("IBJDF7PAT",$J,DFN)) S IB(10)=IB(10)+1
;
; - Used to prevent counting the same patient twice
S ^TMP("IBJDF7PAT",$J,DFN,X)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBJDF71 4751 printed Sep 23, 2025@19:59:20 Page 2
IBJDF71 ;ALB/MR - REPAYMENT PLAN REPORT (COMPILE);15-AUG-00
+1 ;;2.0;INTEGRATED BILLING;**123**;21-MAR-94
+2 ;
ST ; - Tasked entry point.
+1 KILL IB,^TMP("IBJDF7",$JOB),^TMP("IBJDF7PAT",$JOB)
SET IBQ=0
+2 ;
+3 ; - Initialize the array IB
+4 FOR I=1:1:12
SET IB(I)=0
+5 ;
+6 ; - Find the data required for report. Loops through all the Active
+7 ; Bills (Status 16) and checks if bill has a Repayment Plan
+8 ;
+9 SET IBDA=""
+10 FOR
SET IBDA=$ORDER(^PRCA(430,"AC",16,IBDA))
if 'IBDA
QUIT
Begin DoDot:1
+11 IF IBDA#100=0
SET IBQ=$$STOP^IBOUTL("Repayment Plan Report")
if IBQ
QUIT
+12 SET IBAR=$GET(^PRCA(430,IBDA,0))
if 'IBAR
QUIT
+13 ; No Repayment Plan
IF '$PIECE($GET(^PRCA(430,IBDA,4)),"^")
QUIT
+14 ; Gets valid AR category.
SET IBCAT=+$PIECE(IBAR,"^",2)
+15 ; Checks MCCR vs. NON-MCCR
IF '$$MCCR(IBCAT)
QUIT
+16 ; Gets the pointer to the Debtor
SET DEB=$PIECE(IBAR,"^",9)
+17 ; Gets patient info.
SET IBPAT=$$PAT(DEB)
if IBPAT=""
QUIT
+18 ; Gets the pointer to the Patient
SET DFN=$PIECE(IBPAT,"^",5)
+19 ;
+20 ; - Retrieves Repayment Plan Data
+21 SET IBRP=$$REPDATA^RCBECHGA(IBDA,IBDAYS)
+22 SET IBCHK=0
IF IBRP=""
SET IBCHK=$$DBLCHK(IBDA)
IF 'IBCHK
QUIT
+23 ;
+24 ; - Set the temporary global
+25 IF IBPLN="B"!(IBPLN="C"&'$PIECE(IBRP,"^",8))!(IBPLN="D"&$PIECE(IBRP,"^",8))
Begin DoDot:2
+26 SET KEY=$PIECE(IBPAT,"^")
+27 SET IBPT=$GET(^TMP("IBJDF7",$JOB,KEY,DFN))
+28 IF IBPT=""
SET IBPT=$PIECE(IBPAT,"^",2,4)
+29 IF $PIECE(IBRP,"^",8)
IF '$PIECE(IBPT,"^",4)
SET $PIECE(IBPT,"^",4)=1
+30 SET ^TMP("IBJDF7",$JOB,KEY,DFN)=IBPT
+31 SET ^TMP("IBJDF7",$JOB,KEY,DFN,$PIECE(IBAR,"^"))=IBRP_"^"_$$BAL(IBDA)
End DoDot:2
+32 ;
+33 ; - Updates the IB array for the Summary Report
+34 IF 'IBCHK
DO SUM(IBRP,DFN)
End DoDot:1
if IBQ
QUIT
+35 ;
+36 ; Print the report.
IF 'IBQ
DO EN^IBJDF72
+37 ;
ENQ KILL ^TMP("IBJDF7",$JOB),^TMP("IBJDF7PAT",$JOB)
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
GOTO ENQ1
+2 ;
+3 DO ^%ZISC
ENQ1 KILL DFN,I,IB,IBCHK,IBDA,IBAR,IBCAT,IBCD,IBPAT,IBPT,IBQ,IBRP,KEY
+1 QUIT
+2 ;
MCCR(X) ; - Checks if the Bill category is the type selected by the users
+1 ; (MCCR or NON-MCCR)
+2 ; Input: X=AR category pointer to file #430.2
+3 ; Output: Y= 1 - Matches user selection / 0 - Doesn't match
+4 ;
+5 IF (X>11&(X<18))!(X=19)!(X=20)!(X>26&(X<32))
if IBMCR="N"
QUIT 1
QUIT 0
+6 IF IBMCR="M"
QUIT 1
+7 QUIT 0
+8 ;
PAT(DEB) ; - Find the AR patient and decide to include the AR.
+1 ; Input: DEB=Debtor file pointer (file #340)
+2 ; Output: Y=Sort key (name or SSN) ^ Name ^ SSN ^ Date of death (if any)
+3 ; ^Pointer to Patient file
+4 ;
+5 NEW DEATH,DFN,KEY,NAME,SSN,VA,VADM,VAERR,Y,RCDZ
+6 SET Y=""
IF 'DEB
GOTO PATQ
+7 SET RCDZ=$GET(^RCD(340,DEB,0))
IF $PIECE(RCDZ,"^")'["DPT"
GOTO PATQ
+8 SET DFN=+RCDZ
+9 DO DEM^VADPT
SET NAME=VADM(1)
SET SSN=$PIECE(VADM(2),"^",2)
SET DEATH=$PIECE(VADM(6),".")
+10 SET KEY=$SELECT(IBSN="N":NAME,1:$PIECE(SSN,"-",3))
+11 SET Y=""
IF KEY=""!(IBSNF'="@"&('DFN))
GOTO PATQ
+12 IF $DATA(IBSNA)
if IBSNA="ALL"&('DFN)
GOTO PATQ
if IBSNA="NULL"&(DFN)
GOTO PATQ
+13 IF IBSNF="@"
IF IBSNL="zzzzz"
GOTO PATC
+14 IF IBSNF]KEY!(KEY]IBSNL)
GOTO PATQ
+15 ;
PATC SET Y=KEY_"^"_NAME_"^"_SSN_"^"_DEATH_"^"_DFN
PATQ QUIT Y
+1 ;
BAL(BILL) ; Calculates the Account Balance for the Bill
+1 ; Input: BILL - Bill internal # - Pointer to file #430
+2 ; Output: BAL - Bill Balance
+3 ;
+4 NEW B7,BAL,I
+5 ;
+6 SET B7=$GET(^PRCA(430,BILL,7))
+7 SET BAL=0
FOR I=1:1:5
SET BAL=BAL+$PIECE(B7,"^",I)
+8 ;
+9 QUIT BAL
+10 ;
DBLCHK(BILL) ; Double-checks if the receivable does not have any Repayment
+1 ; Plan information at all
+2 ; Output: 0 - No Repayment Plan Info or Repayment Plan paid in full
+3 ; 1 - Some Repayment Plan Info
+4 ;
+5 NEW ARZ,DBLCHK,I,IBPMT
+6 ;
+7 SET DBLCHK=0
+8 ; - Repayment Plan has been paid in full
+9 SET IBPMT=$ORDER(^PRCA(430,BILL,5,999),-1)
+10 IF IBPMT
IF $PIECE($GET(^PRCA(430,BILL,5,IBPMT)),"^",2)
QUIT DBLCHK
+11 ;
+12 ; - Looks for some information on file about the Repayment Plan
+13 SET ARZ=$GET(^PRCA(430,BILL,4))
+14 FOR I=1:1:4
IF $PIECE(ARZ,"^",I)'=""
SET DBLCHK=1
QUIT
+15 ;
+16 QUIT DBLCHK
+17 ;
SUM(IBRP,DFN) ; Sets the array IB with the Summary information
+1 ; Input: IBRP=Array returned by the function $$RP (See estructure above)
+2 ; DFN=Pointer to the Patient file
+3 ; Output: Updates the IB array with summary iformation
+4 ;
+5 NEW X
SET X=$SELECT($PIECE(IBRP,"^",8):"D",1:"C")
+6 ;
+7 ; - Updates summary information for Defaulted Plans
+8 IF X="D"
Begin DoDot:1
+9 SET IB(1)=IB(1)+1
+10 IF '$DATA(^TMP("IBJDF7PAT",$JOB,DFN,X))
SET IB(2)=IB(2)+1
End DoDot:1
+11 ;
+12 ; - Updates summary information for Current Plans
+13 IF X="C"
Begin DoDot:1
+14 SET IB(5)=IB(5)+1
+15 IF '$DATA(^TMP("IBJDF7PAT",$JOB,DFN,X))
SET IB(6)=IB(6)+1
End DoDot:1
+16 ;
+17 ; - Defaulted Outstanding balance and # of Payments
+18 SET IB(3)=IB(3)+($PIECE(IBRP,"^",3)*$PIECE(IBRP,"^",8))
+19 SET IB(4)=IB(4)+$PIECE(IBRP,"^",8)
+20 ;
+21 ; - Current Outstanding balance and # of Payments
+22 SET IB(7)=IB(7)+($PIECE(IBRP,"^",3)*($PIECE(IBRP,"^",7)-$PIECE(IBRP,"^",8)))
+23 SET IB(8)=IB(8)+($PIECE(IBRP,"^",7)-$PIECE(IBRP,"^",8))
+24 ;
+25 ; - Total Number of Patients (Unique)
+26 IF '$DATA(^TMP("IBJDF7PAT",$JOB,DFN))
SET IB(10)=IB(10)+1
+27 ;
+28 ; - Used to prevent counting the same patient twice
+29 SET ^TMP("IBJDF7PAT",$JOB,DFN,X)=""
+30 QUIT
