source: FOIAVistA/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCALM.m@ 1704

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

initial load of FOIAVistA 6/30/08 version

File size: 3.5 KB
Line 
1PRCALM ;SF-ISC/YJK-CREATE CALM CODE SHEET FOR NEW TRANSACTION ;7/15/93 12:20 PM
2V ;;4.5;Accounts Receivable;;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 N DIC,P0,PRCFASYS,PRCFX,LOOP,TRANNO,DIR,DIRUT,DUOUT
5 W ! S DIR("B")="YES",DIR("A")="Do you want to loop thru 'PENDING CALM CODE' Transactions",DIR(0)="Y" D ^DIR K DIR G:$D(DIRUT) END S LOOP=+Y,TRANNO=0
6EN K PRCFDEL,DIC I ('$D(PRC("SITE")))!('$D(PRC("FY"))) D ^PRCFSITE Q:'$D(PRC("SITE")) W !
7 I LOOP D:TRANNO S DIC="^PRCA(433,",(TRANNO,DA,Y)=$O(^PRCA(433,"AE",1,TRANNO)) W:DA="" !!,"*** Loop Done ***",! G:DA="" END
8 .S DIR("B")="YES",DIR("A")="Do you want continue looping",DIR(0)="Y" D ^DIR K DIR I $D(DIRUT)!'Y S TRANNO="A"
9 .Q
10 I 'LOOP W ! S DIC="^PRCA(433,",DIC("A")="ENTER BILL NO. OR TRANSACTION NO.: ",DIC(0)="AEQM",DIC("S")="I +$P(^(0),U,3)=1,+$P(^(0),U,4)=2" D ^DIC Q:Y<0 S DA=+Y
11 S PRCA("LOCK")=0 D LOCKF^PRCAWO1 I PRCA("LOCK")=1 K PRCA,DA,DIC Q
12 S PRCAEN=+Y,PRCABN=+$P(^PRCA(433,PRCAEN,0),U,2) I PRCABN'>0 L -^PRCA(433,PRCAEN) K PRCAEN,PRCABN Q
13 K DXS S D0=PRCAEN D ^PRCATP9 K DXS W !
14 D PROC L -^PRCA(433,+$G(PRCAEN)) K PRCAEN,PRCABN G EN
15PROC S PRCAENT=$P(^PRCA(433,PRCAEN,4,0),U,4),PRCALM=1
16 D @$S(+PRCAENT>1:"EN2",1:"EN1")
17 I PRCALM>1 S DIE="^PRCA(433,",DA=PRCAEN,DR="3////"_0_";5////"_DT_"" D ^DIE K ^PRCA(433,"AE",1,PRCAEN)
18END K DIE,DR,PRCAENT,PRCA,DA,DIC,PRCALM,PRCAEN1,PRCATY Q
19EN1 S PRCAEN1=+$P(^PRCA(433,PRCAEN,4,0),U,3) Q:PRCAEN1'>0 Q:$P(^PRCA(433,PRCAEN,4,PRCAEN1,0),U,4)=2 D CALM
20 Q ;end of EN1
21EN2 W !!,"This bill has multiple PAT REF Numbers.",!
22DIC1 S PRCACT=0 D PRPAT Q:PRCACT=0 K DIC S DIC="^PRCA(433,"_PRCAEN_",4,",DIC(0)="AEQM",DIC("S")="I +$P(^(0),U,4)<2" D ^DIC Q:Y<0 S PRCAEN1=+Y K DIC
23 D CALM K PRCACT G DIC1
24CALM S PRCALM=1,PRCANODE=^PRCA(433,PRCAEN,4,PRCAEN1,0)
25 S %=$P(^PRCA(433,PRCAEN,1),U,1),PRCFA("TTDATE")=$E(%,4,7)_$E(%,2,3) K %
26 S PRCFA("REF")="" S:+$P(PRCANODE,U,3)>0 PRCFA("REF")=$S($D(^PRC(442,$P(PRCANODE,U,3),0)):$P($P(^PRC(442,$P(PRCANODE,U,3),0),U,1),"-",2),1:"") I PRCFA("REF")="" W !,*7,"NO PAT REF # !",! Q
27 I PRC("SITE")'=$P($P(^PRC(442,$P(PRCANODE,U,3),0),U,1),"-",1) S PRCKST=PRC("SITE"),PRC("SITE")=$P($P(^PRC(442,$P(PRCANODE,U,3),0),U,1),"-",1)
28 S PRCAKFY=$S($D(PRC("FY")):PRC("FY"),1:""),PRC("FY")=$P(PRCANODE,U,1)
29 S A=$S($P(^PRCA(430,PRCABN,2,PRCAEN1,0),U,5)]"":$P(^(0),U,5),1:"")
30 S X=$S(+A>0:$P(^PRCD(420.3,A,0),U,4),1:"") S A=X
31 I $E(A,2,4)'=718 D SE^PRCFALD,YALD S PRCFA("ALD")=$S($D(Y):Y,1:"")
32 I $E(A,2,4)=718 S Y=$S($E(PRCFA("TTDATE"),1,2)>9:$E(PRCFA("TTDATE"),6)+1,1:$E(PRCFA("TTDATE"),6)) S Y=$E(Y)_$E(A,2,4) D YALD S PRCFA("ALD")=$S($D(Y):Y,1:"")
33 S X=A K A S:PRCAKFY'="" PRC("FY")=PRCAKFY K PRCAKFY
34 S PRCFA("AMT")=$S($P(PRCANODE,U,5)=0:"",1:$J($P(PRCANODE,U,5)*100,0,0)) D EN1^PRCACLM
35 I $D(PRCKST) S PRC("SITE")=PRCKST K PRCKST
36 Q:PRCALM'>1
37 S $P(^PRCA(433,PRCAEN,4,PRCAEN1,0),U,4)=2
38 K PRCANODE,PRCFA Q ;end of CALM
39PRPAT S A1=0
40 F J=0:0 S A1=$O(^PRCA(433,PRCAEN,4,A1)) Q:A1'>0 D P1
41 W !! K A1,A2,J Q
42P1 I $D(^PRCA(433,PRCAEN,4,A1,0)) S Z0=^(0),PRCAKPAT=$S($P(Z0,U,3)>0:$P($P(^PRC(442,$P(Z0,U,3),0),U,1),"-",2),1:"")
43 S PRCAKCLM=$P(Z0,U,4) Q:PRCAKCLM=2 S PRCAKCLM=$S(PRCAKCLM=1:"NO",PRCAKCLM=2:"YES",1:"N/A")
44 W !,"PAT REF #: ",PRCAKPAT,?30,"CALM CODE SHEET DONE: ",PRCAKCLM
45 S PRCACT=PRCACT+1 K Z0,PRCAKCLM,PRCAKPAT Q
46YALD S:Y="" Y=".." K:$L(Y)>4!(($L(Y)<2)&(Y'="$")) Y Q:Y=".."
47 I $D(Y),(Y'="$") S Y=$E(Y,1,2)_"."_$E(Y,3)_"."_$E(Y,4)
48 Q ;end of YALD
49APPR ;WRITE APPROPRIATION SYMBOL IN THE 430
50 Q:('$D(PRCABN))!('$D(X)) S X1=$P(X,U,1) Q:$L(X1)'=2 S Z1=$S(+X1>70:"2"_X1,1:"3"_X1)
51 I $D(^PRCA(430,+PRCABN,2,+Z1,0)) W ?10,$P(^(0),U,4)
52 K Z1,X1 Q
Note: See TracBrowser for help on using the repository browser.