source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBJDF71.m@ 686

Last change on this file since 686 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.5 KB
Line 
1IBJDF71 ;ALB/MR - REPAYMENT PLAN REPORT (COMPILE);15-AUG-00
2 ;;2.0;INTEGRATED BILLING;**123**;21-MAR-94
3 ;
4ST ; - Tasked entry point.
5 K IB,^TMP("IBJDF7",$J),^TMP("IBJDF7PAT",$J) S IBQ=0
6 ;
7 ; - Initialize the array IB
8 F I=1:1:12 S IB(I)=0
9 ;
10 ; - Find the data required for report. Loops through all the Active
11 ; Bills (Status 16) and checks if bill has a Repayment Plan
12 ;
13 S IBDA=""
14 F S IBDA=$O(^PRCA(430,"AC",16,IBDA)) Q:'IBDA D Q:IBQ
15 . I IBDA#100=0 S IBQ=$$STOP^IBOUTL("Repayment Plan Report") Q:IBQ
16 . S IBAR=$G(^PRCA(430,IBDA,0)) Q:'IBAR
17 . I '$P($G(^PRCA(430,IBDA,4)),"^") Q ; No Repayment Plan
18 . S IBCAT=+$P(IBAR,"^",2) ; Gets valid AR category.
19 . I '$$MCCR(IBCAT) Q ; Checks MCCR vs. NON-MCCR
20 . S DEB=$P(IBAR,"^",9) ; Gets the pointer to the Debtor
21 . S IBPAT=$$PAT(DEB) Q:IBPAT="" ; Gets patient info.
22 . S DFN=$P(IBPAT,"^",5) ; Gets the pointer to the Patient
23 . ;
24 . ; - Retrieves Repayment Plan Data
25 . S IBRP=$$REPDATA^RCBECHGA(IBDA,IBDAYS)
26 . S IBCHK=0 I IBRP="" S IBCHK=$$DBLCHK(IBDA) I 'IBCHK Q
27 . ;
28 . ; - Set the temporary global
29 . I IBPLN="B"!(IBPLN="C"&'$P(IBRP,"^",8))!(IBPLN="D"&$P(IBRP,"^",8)) D
30 . . S KEY=$P(IBPAT,"^")
31 . . S IBPT=$G(^TMP("IBJDF7",$J,KEY,DFN))
32 . . I IBPT="" S IBPT=$P(IBPAT,"^",2,4)
33 . . I $P(IBRP,"^",8),'$P(IBPT,"^",4) S $P(IBPT,"^",4)=1
34 . . S ^TMP("IBJDF7",$J,KEY,DFN)=IBPT
35 . . S ^TMP("IBJDF7",$J,KEY,DFN,$P(IBAR,"^"))=IBRP_"^"_$$BAL(IBDA)
36 . ;
37 . ; - Updates the IB array for the Summary Report
38 . I 'IBCHK D SUM(IBRP,DFN)
39 ;
40 I 'IBQ D EN^IBJDF72 ; Print the report.
41 ;
42ENQ K ^TMP("IBJDF7",$J),^TMP("IBJDF7PAT",$J)
43 I $D(ZTQUEUED) S ZTREQ="@" G ENQ1
44 ;
45 D ^%ZISC
46ENQ1 K DFN,I,IB,IBCHK,IBDA,IBAR,IBCAT,IBCD,IBPAT,IBPT,IBQ,IBRP,KEY
47 Q
48 ;
49MCCR(X) ; - Checks if the Bill category is the type selected by the users
50 ; (MCCR or NON-MCCR)
51 ; Input: X=AR category pointer to file #430.2
52 ; Output: Y= 1 - Matches user selection / 0 - Doesn't match
53 ;
54 I (X>11&(X<18))!(X=19)!(X=20)!(X>26&(X<32)) Q:IBMCR="N" 1 Q 0
55 I IBMCR="M" Q 1
56 Q 0
57 ;
58PAT(DEB) ; - Find the AR patient and decide to include the AR.
59 ; Input: DEB=Debtor file pointer (file #340)
60 ; Output: Y=Sort key (name or SSN) ^ Name ^ SSN ^ Date of death (if any)
61 ; ^Pointer to Patient file
62 ;
63 N DEATH,DFN,KEY,NAME,SSN,VA,VADM,VAERR,Y,RCDZ
64 S Y="" I 'DEB G PATQ
65 S RCDZ=$G(^RCD(340,DEB,0)) I $P(RCDZ,"^")'["DPT" G PATQ
66 S DFN=+RCDZ
67 D DEM^VADPT S NAME=VADM(1),SSN=$P(VADM(2),"^",2),DEATH=$P(VADM(6),".")
68 S KEY=$S(IBSN="N":NAME,1:$P(SSN,"-",3))
69 S Y="" I KEY=""!(IBSNF'="@"&('DFN)) G PATQ
70 I $D(IBSNA) G:IBSNA="ALL"&('DFN) PATQ G:IBSNA="NULL"&(DFN) PATQ
71 I IBSNF="@",IBSNL="zzzzz" G PATC
72 I IBSNF]KEY!(KEY]IBSNL) G PATQ
73 ;
74PATC S Y=KEY_"^"_NAME_"^"_SSN_"^"_DEATH_"^"_DFN
75PATQ Q Y
76 ;
77BAL(BILL) ; Calculates the Account Balance for the Bill
78 ; Input: BILL - Bill internal # - Pointer to file #430
79 ; Output: BAL - Bill Balance
80 ;
81 N B7,BAL,I
82 ;
83 S B7=$G(^PRCA(430,BILL,7))
84 S BAL=0 F I=1:1:5 S BAL=BAL+$P(B7,"^",I)
85 ;
86 Q BAL
87 ;
88DBLCHK(BILL) ; Double-checks if the receivable does not have any Repayment
89 ; Plan information at all
90 ; Output: 0 - No Repayment Plan Info or Repayment Plan paid in full
91 ; 1 - Some Repayment Plan Info
92 ;
93 N ARZ,DBLCHK,I,IBPMT
94 ;
95 S DBLCHK=0
96 ; - Repayment Plan has been paid in full
97 S IBPMT=$O(^PRCA(430,BILL,5,999),-1)
98 I IBPMT,$P($G(^PRCA(430,BILL,5,IBPMT)),"^",2) Q DBLCHK
99 ;
100 ; - Looks for some information on file about the Repayment Plan
101 S ARZ=$G(^PRCA(430,BILL,4))
102 F I=1:1:4 I $P(ARZ,"^",I)'="" S DBLCHK=1 Q
103 ;
104 Q DBLCHK
105 ;
106SUM(IBRP,DFN) ; Sets the array IB with the Summary information
107 ; Input: IBRP=Array returned by the function $$RP (See estructure above)
108 ; DFN=Pointer to the Patient file
109 ; Output: Updates the IB array with summary iformation
110 ;
111 N X S X=$S($P(IBRP,"^",8):"D",1:"C")
112 ;
113 ; - Updates summary information for Defaulted Plans
114 I X="D" D
115 . S IB(1)=IB(1)+1
116 . I '$D(^TMP("IBJDF7PAT",$J,DFN,X)) S IB(2)=IB(2)+1
117 ;
118 ; - Updates summary information for Current Plans
119 I X="C" D
120 . S IB(5)=IB(5)+1
121 . I '$D(^TMP("IBJDF7PAT",$J,DFN,X)) S IB(6)=IB(6)+1
122 ;
123 ; - Defaulted Outstanding balance and # of Payments
124 S IB(3)=IB(3)+($P(IBRP,"^",3)*$P(IBRP,"^",8))
125 S IB(4)=IB(4)+$P(IBRP,"^",8)
126 ;
127 ; - Current Outstanding balance and # of Payments
128 S IB(7)=IB(7)+($P(IBRP,"^",3)*($P(IBRP,"^",7)-$P(IBRP,"^",8)))
129 S IB(8)=IB(8)+($P(IBRP,"^",7)-$P(IBRP,"^",8))
130 ;
131 ; - Total Number of Patients (Unique)
132 I '$D(^TMP("IBJDF7PAT",$J,DFN)) S IB(10)=IB(10)+1
133 ;
134 ; - Used to prevent counting the same patient twice
135 S ^TMP("IBJDF7PAT",$J,DFN,X)=""
136 Q
Note: See TracBrowser for help on using the repository browser.