source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAGF.m@ 738

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

initial load of WorldVistAEHR
File size: 5.0 KB
Line 
1PRCAGF ;WASH-ISC@ALTOONA,PA/CMS-Print Form Letters ;5/1/95 3:04 PM
2V ;;4.5;Accounts Receivable;**1,48,141,190,225**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4EN(DEB,SB,PRNT) ;entry send Debtor number and statemet bal
5 NEW PRCABN,CR,NOT,STAT
6 S (CR,NOT)=0 I '$D(SITE) D SITE^PRCAGU
7 F STAT=16,42 F PRCABN=0:0 S PRCABN=$O(^PRCA(430,"AS",DEB,STAT,PRCABN)) Q:'PRCABN D
8 .I $P(^RCD(340,DEB,0),U,1)'["DPT",$G(^PRCA(430,PRCABN,1))>0 Q
9 .I $P(^RCD(340,DEB,0),U)'["DPT",($P($G(^PRCA(430,PRCABN,6)),U,4)>0) Q
10 .D LT(PRCABN,$G(SB))
11 Q
12LT(PRCABN,SB,REPNOT) ;find which letter to print needs Site variable
13 NEW BY,CAT,CE,CN,EH,EXE,FR,I,INE,IOP,LET,LT,PG,TO,VEN,X,TOPLTR
14 I '$D(^PRCA(430,PRCABN,0)) Q
15 S:'$D(CR) (NOT,CR)="" S:'$G(DEB) DEB=+$P(^PRCA(430,PRCABN,0),U,9)
16 S CAT=$P($G(^PRCA(430,PRCABN,0)),U,2),LET=$G(^PRCA(430,PRCABN,6)) Q:CAT=""
17 I $G(SB)="",CAT=26,^PRCA(430,PRCABN,7) S SB=-(+^(7))
18 I $G(SB)="" S X=$G(^PRCA(430,PRCABN,7)) F I=1:1:5 S SB=+$G(SB)+$P(X,U,I)
19 I SB<0 Q:CR S LT=$O(^RC(343,"B","CREDIT",0)) D PRT(LT,PRCABN) S CR=1 Q
20 I $P($G(^PRCA(430,PRCABN,1)),U,1),$P($G(^RCD(340,$P(^PRCA(430,PRCABN,0),U,9),0)),U,1)[";DPT" Q
21 I $G(REPNOT)>0 S:REPNOT=4 REPNOT=3 S $P(LET,U,REPNOT)=""
22 I NOT=0 F CN=24,29,30 I CAT=$O(^PRCA(430.2,"AC",CN,0)),$P(LET,U,3)="" D
23 .I SITE("SUP") S NOT=1 Q
24 .S LT=$S('$G(BBAL("INT")):"FL 4-513",1:"FL 4-513w")
25 .S LT=$O(^RC(343,"B",LT,0)) D PRT(LT,PRCABN) S NOT=1
26 S INE=$O(^PRCA(430.2,"AC",20,0)),EH=$O(^PRCA(430.2,"AC",25,0)),CV=$O(^PRCA(430.2,"AC",34,0))
27 S CU=$O(^PRCA(430.2,"AC",38,0))
28 I CAT=INE!(CAT=CV)!(CAT=CU),$P(LET,U,1)="" S LT=$O(^RC(343,"B","FL 4-480",0)) D PRT(LT,PRCABN) Q
29 I CAT=EH,$P(LET,U,1)="" S LT=$O(^RC(343,"B","FL 4-481",0)) D PRT(LT,PRCABN) Q
30 I CAT=EH!(CAT=INE)!(CAT=CV)!(CAT=CU),$P(LET,U,2)="" S LT=$O(^RC(343,"B","FL 4-482",0)) D PRT(LT,PRCABN) Q
31 ;THIRD PARAMETER (1) FOR CALLING PRINT SUBROUTINE INSTRUCTS
32 ;SOFTWARE TO PRINT "TOP ATTACHMENT LETTER"
33 I CAT=EH!(CAT=INE)!(CAT=CV)!(CAT=CU),SB>599.99,SB<1200,$P(LET,U,3)="" S LT=$O(^RC(343,"B","FL 4-484",0)) D PRT(LT,PRCABN,1) Q
34 I CAT=EH!(CAT=INE)!(CAT=CV)!(CAT=CU),SB>1199.99,$P(LET,U,3)="" S LT=$O(^RC(343,"B","FL 4-485",0)) D PRT(LT,PRCABN,1) Q
35 S VEN=","_$O(^PRCA(430.2,"AC",6,0))_","_$O(^PRCA(430.2,"AC",7,0))_","_$O(^PRCA(430.2,"AC",11,0))_",",EXE=$O(^PRCA(430.2,"AC",13,0)),CE=$O(^PRCA(430.2,"AC",14,0))
36 I CAT=EXE,$P(LET,U,1)="" S LT=$O(^RC(343,"B","FL 4-520b",0)) D PRT(LT,PRCABN) Q
37 I CAT=CE,$P(LET,U,1)="" S LT=$O(^RC(343,"B","FL 4-520a",0)) D PRT(LT,PRCABN) Q
38 I VEN[(","_CAT_","),$P(LET,U,1)="" S LT=$O(^RC(343,"B","FL 4-521",0)) D PRT(LT,PRCABN) Q
39 I CAT=CE!(CAT=EXE)!(VEN[(","_CAT_",")),$P(LET,U,2)="" S LT=$O(^RC(343,"B","FL 4-483a",0)) D PRT(LT,PRCABN) Q
40 I CAT=CE!(CAT=EH)!(CAT=INE)!(CAT=EXE)!(VEN[(","_CAT_","))!(CAT=CV)!(CAT=CU),$P(LET,U,3)="",SB>25,SB<600 S LT=$O(^RC(343,"B","FL 4-483",0)) D PRT(LT,PRCABN,1) Q
41 I CAT=CE!(CAT=EXE)!(VEN[(","_CAT_",")),SB>599.99,$P(LET,U,3)="" S LT=$O(^RC(343,"B","FL 4-485",0)) D PRT(LT,PRCABN,1) Q
42 Q
43PRT(LT,PRCABN,TOP) ;print letter
44 NEW DA,DIWF,DIWL,DIWR,LINE,LTP,X,D0
45 S TOP=$G(TOP),LTP=0 I '$D(^RC(343,LT,0)) G PRTQ
46 I LT'=+$O(^RC(343,"B","CREDIT",0)),LT'=+$O(^RC(343,"B","FL 4-513",0)),LT'=+$O(^RC(343,"B","FL 4-513w",0)) S LTP=1 ;s ltp if letter (not statement)
47 S DEB=+$P(^PRCA(430,PRCABN,0),U,9)
48 S NAM=$$NAM^RCFN01(DEB),SSN=$$SSN^RCFN01(DEB),SSN=$S(SSN=-1:"",1:SSN)
49 I LTP D LTH ;print header on letter
50 K ^UTILITY($J) ;print main body text from 343
51 S ^UTILITY($J,1)="W "_IOF
52 F LINE=0:0 S LINE=$O(^RC(343,LT,1,LINE)) Q:'LINE S X=$G(^(LINE,0)) I X]"" W:($Y+2)>IOSL @IOF S DIWL=1,DIWR=80,DIWF="W" D ^DIWP
53 D ^DIWW S:$G(PRNT)="FL" PRNT=1 K ^UTILITY($J)
54 I LTP,",15,16,17,41,42,"[(","_$P($G(^PRCA(430,PRCABN,0)),U,2)_",") D DESC(PRCABN) ;print bill desc from 430 for cat. Ex-Emp, Curr Emp., Vendor, Cwt & Parking Fees
55 ;CALL TO PRINT "TOP ATTACHMENT LETTER" FOR FL 4-483,FL 4-484,FL 4-485
56 I TOP D TOP
57 I LTP D PAY^PRCAGF1 W !,$P(^RC(343,LT,0),U,1) ;print letter payment remittance and Form number
58PRTQ Q
59LTH ;print letter header
60 NEW ADD,X,Y
61 W @IOF D:'$D(SITE) SITE^PRCAGU
62 S ADD=$$SADD^RCFN01(8) I ADD="" S ADD=$$SADD^RCFN01(1)
63 W !!,?30,"Department of Veterans Affairs"
64 F Y=1:1:3 I $P(ADD,U,Y)]"" W !,?32,$P(ADD,U,Y)
65 W !,?32,$P(ADD,U,4)_", "_$P(ADD,U,5)_" "_$P(ADD,U,6)
66 W !!!!,?50,"In Reply Refer To:"
67 W !,?50,"File No./SSAN: ",$S($D(RCIRSTOT):SSN,1:$P(^PRCA(430,PRCABN,0),U,1))
68 W !,?14,NAM
69 S ADD=$$DADD^RCAMADD(DEB,1) ; Get debtor address (confidential if applicable)
70 F Y=1:1:3 I $P(ADD,U,Y)]"" W !,?14,$P(ADD,U,Y) I Y=1 W ?50 X SITE("SCAN")
71 W !,?14,$P(ADD,U,4)_", "_$P(ADD,U,5)_" "_$P(ADD,U,6)
72 S Y=DT X ^DD("DD") W !!!!!!,Y,!!
73 Q
74DESC(PRCABN) ;print description multiple from file 430
75 NEW PRCABT,X,Y
76 I '$G(PRCABN),$G(^PRCA(430,PRCABN,100))'=3 Q
77 W !!,"Detailed Description:"
78 D DES^PRCABD(PRCABN,3) W !
79 Q
80TOP ;PRINT TOP ATTACHMENT LETTER FOR FL 4-483,FL 4-484, FL 4-485
81 S TOPLTR=$O(^RC(343,"B","TOP ATTACHMENT LETTER",0))
82 Q:'TOPLTR K ^UTILITY($J)
83 S ^UTILITY($J,1)="W "_IOF
84 F LINE=0:0 S LINE=$O(^RC(343,TOPLTR,1,LINE)) Q:'LINE S X=$G(^(LINE,0)) I X]"" W:($Y+2)>IOSL @IOF S DIWL=1,DIWR=80,DIWF="W" D ^DIWP
85 D ^DIWW K ^UTILITY($J)
86 Q
Note: See TracBrowser for help on using the repository browser.