source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCAREP.m@ 1006

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

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1PRCAREP ;SF-ISC/YJK-CREATE REPAYMENT DATE SCHEDULE ;10/15/93 9:47 AM
2V ;;4.5;Accounts Receivable;;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;This sets up repayment schedule for A/R.
5BEGIN K DIC
6EN W !! D BILL^PRCAUTL G:('$D(PRCABN)) END I +PRCA("STATUS")>0,$P(^PRCA(430.3,PRCA("STATUS"),0),U,3)'=102 W !,*7,"NOT AN ACTIVE ACCOUNT !" G EN
7 I $D(^PRCA(430,PRCABN,5)) W *7,!,"THIS ACCOUNT ALREADY HAS A REPAYMENT PLAN !",!
8 S PRCAPB=$S($D(^PRCA(430,PRCABN,7)):$P(^(7),U,1)+$P(^(7),U,2)+$P(^(7),U,3)+$P(^(7),U,4)+$P(^(7),U,5),1:$P(^(0),U,3)),PRCAMT=0
9 S PRCADT="" D DIE G:PRCA("LOCK")=1 EN I (+PRCADT>0)&(+PRCAMT>0) D SET G EN
10 I '$D(^PRCA(430,PRCABN,4)) W !,"NO REPAYMENT PLAN!",*7 K ^PRCA(430,PRCABN,5) G EN
11 I $P(^PRCA(430,PRCABN,4),U,1)="" W *7,!,"NO REPAYMENT PLAN !" K ^PRCA(430,PRCABN,5) G EN
12 W !,"NOTHING CHANGED !",! G EN
13 ;
14DIE S DIC="^PRCA(430,",DIE=DIC,DA=PRCABN,DR="41;S PRCADT=X;42;S PRCADAY=X;43;S PRCAMT=X" S PRCA("LOCK")=0 D LOCKF^PRCAWO1 D:PRCA("LOCK")=0 ^DIE
15 K DIE,DR L -^PRCA(430,+$G(PRCABN)) Q ;end of DIE
16SET S PRCANPAY=PRCAPB/PRCAMT,PRCANPAY=$S(PRCANPAY>(PRCAPB\PRCAMT):PRCAPB\PRCAMT+1,1:PRCAPB\PRCAMT)
17 W !!,"NUMBER OF PAYMENTS WILL BE ",PRCANPAY,! I PRCANPAY>60 W !,*7,"THIS NUMBER SHOULD BE LESS THAN 60 !, CHECK THE INPUT AGAIN",! Q
18 S %DT="AEFX",%DT("A")="DUE DATE OF 1ST PAYMENT: " D ^%DT K %DT
19 I Y<0 W !,*7,"NOTHING CHANGED !" Q
20 K ^PRCA(430,PRCABN,5) S PRCAYR=$E(Y,1,3),PRCAMON=$E(Y,4,5) S:$L(PRCADAY)=1 PRCADAY="0"_PRCADAY D HOLD^PRCAUT1
21 F Z0=1:1:PRCANPAY S Z1=PRCAYR_$S((PRCAMON<10&($E(PRCAMON,1)'=0)):0_PRCAMON,1:PRCAMON)_PRCADAY,^PRCA(430,DA,5,Z0,0)=Z1_U_"0",PRCAMON=PRCAMON+1 S:PRCAMON=13 PRCAMON=1,PRCAYR=PRCAYR+1
22 S ^PRCA(430,DA,5,0)="^430.051DA^"_PRCANPAY_"^"_PRCANPAY,$P(^PRCA(430,DA,4),U,4)=PRCANPAY
23 S PRCAKTY=$O(^PRCA(430.3,"AC",16,"")) D TRAN,IXDIK S $P(^PRCA(433,PRCAEN,0),U,4)=2
24 W !!,"THE REPAYMENT PLAN HAS BEEN ESTABLISHED.",!
25EXIT K PRCAKTY,PRCAMON,PRCAYR,PRCANPAY,DA1,DIK,DA Q ;end of SET
26IXDIK S DIK="^PRCA(430,"_PRCABN_",5,",DA(1)=PRCABN D IXALL^DIK K DIK Q
27TRAN S PRCAEN=-1 D SETTR^PRCAUTL Q:PRCAEN<0 S DA=PRCAEN
28 S DIE="^PRCA(433,",DR=".03////"_PRCABN_";11///"_PRCADT_";12///"_PRCAKTY_";15///"_PRCAPB_"" D ^DIE
29 K DIE,DR,PRCADT Q
30END K PRCAS,PRCAMT,PRCA,PRCAKTY,PRCADT,DA,DIE,PRCAYR,PRCAMON,PRCANPAY,DR,PRCAEN,PRCABN,PRCAPB,Z0,PRCADAY,DIC,PRCAS,PRCATY D KVAR^VADPT Q ;end of PRCAREP
31PROFILE ;print the repayment plan profile.
32 K %ZIS,DXS,IOP
33 D BILL^PRCAUTL G:'$D(PRCABN) END
34 S %ZIS="Q" D ^%ZIS Q:POP S IOM=80,PRCAIO=IO,PRCAIO(0)=IO(0)
35 I IO=IO(0) W:$D(IOF) @IOF D TR,CLOSE K PRCAIO,PRCATY G PROFILE
36 I $D(IO("Q")) K IO("Q") S ZTRTN="TR^PRCAREP",ZTSAVE("PRCABN")=PRCABN,ZTSAVE("PRCAIO(0)")=PRCAIO(0),ZTSAVE("PRCAIO")=PRCAIO,ZTDESC="Repayment Plan Profile"
37 I D ^%ZTLOAD,CLOSE W:(IOM-$X)<20 ! W " <REQUEST QUEUED>",*7,! K PRCA,PRCATY G PROFILE
38 U IO D TR,CLOSE G PROFILE
39TR S D0=PRCABN K DXS D ^PRCATR1 K DXS W !! K PRCABN,PRCAKTY,PRCA Q
40CLOSE D ^%ZISC K IOP,%ZIS,PRCAIO Q
Note: See TracBrowser for help on using the repository browser.