source: FOIAVistA/tag/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/PRCALM.m@ 628

PRCALM ;SF-ISC/YJK-CREATE CALM CODE SHEET FOR NEW TRANSACTION ;7/15/93  12:20 PM
V ;;4.5;Accounts Receivable;;Mar 20, 1995
 ;;Per VHA Directive 10-93-142, this routine should not be modified.
 N DIC,P0,PRCFASYS,PRCFX,LOOP,TRANNO,DIR,DIRUT,DUOUT
 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
EN K PRCFDEL,DIC I ('$D(PRC("SITE")))!('$D(PRC("FY"))) D ^PRCFSITE Q:'$D(PRC("SITE"))  W !
 I LOOP D:TRANNO  S DIC="^PRCA(433,",(TRANNO,DA,Y)=$O(^PRCA(433,"AE",1,TRANNO)) W:DA="" !!,"*** Loop Done ***",! G:DA="" END
 .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"
 .Q
 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
 S PRCA("LOCK")=0 D LOCKF^PRCAWO1 I PRCA("LOCK")=1 K PRCA,DA,DIC Q
 S PRCAEN=+Y,PRCABN=+$P(^PRCA(433,PRCAEN,0),U,2) I PRCABN'>0 L -^PRCA(433,PRCAEN) K PRCAEN,PRCABN Q
 K DXS S D0=PRCAEN D ^PRCATP9 K DXS W !
 D PROC L -^PRCA(433,+$G(PRCAEN)) K PRCAEN,PRCABN G EN
PROC S PRCAENT=$P(^PRCA(433,PRCAEN,4,0),U,4),PRCALM=1
 D @$S(+PRCAENT>1:"EN2",1:"EN1")
 I PRCALM>1 S DIE="^PRCA(433,",DA=PRCAEN,DR="3////"_0_";5////"_DT_"" D ^DIE K ^PRCA(433,"AE",1,PRCAEN)
END K DIE,DR,PRCAENT,PRCA,DA,DIC,PRCALM,PRCAEN1,PRCATY Q
EN1 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
 Q  ;end of EN1
EN2 W !!,"This bill has multiple PAT REF Numbers.",!
DIC1 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
 D CALM K PRCACT G DIC1
CALM S PRCALM=1,PRCANODE=^PRCA(433,PRCAEN,4,PRCAEN1,0)
 S %=$P(^PRCA(433,PRCAEN,1),U,1),PRCFA("TTDATE")=$E(%,4,7)_$E(%,2,3) K %
 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
 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)
 S PRCAKFY=$S($D(PRC("FY")):PRC("FY"),1:""),PRC("FY")=$P(PRCANODE,U,1)
 S A=$S($P(^PRCA(430,PRCABN,2,PRCAEN1,0),U,5)]"":$P(^(0),U,5),1:"")
 S X=$S(+A>0:$P(^PRCD(420.3,A,0),U,4),1:"") S A=X
 I $E(A,2,4)'=718 D SE^PRCFALD,YALD S PRCFA("ALD")=$S($D(Y):Y,1:"")
 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:"")
 S X=A K A S:PRCAKFY'="" PRC("FY")=PRCAKFY K PRCAKFY
 S PRCFA("AMT")=$S($P(PRCANODE,U,5)=0:"",1:$J($P(PRCANODE,U,5)*100,0,0)) D EN1^PRCACLM
 I $D(PRCKST) S PRC("SITE")=PRCKST K PRCKST
 Q:PRCALM'>1
 S $P(^PRCA(433,PRCAEN,4,PRCAEN1,0),U,4)=2
 K PRCANODE,PRCFA Q  ;end of CALM
PRPAT S A1=0
 F J=0:0 S A1=$O(^PRCA(433,PRCAEN,4,A1)) Q:A1'>0  D P1
 W !! K A1,A2,J Q
P1 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:"")
 S PRCAKCLM=$P(Z0,U,4) Q:PRCAKCLM=2  S PRCAKCLM=$S(PRCAKCLM=1:"NO",PRCAKCLM=2:"YES",1:"N/A")
 W !,"PAT REF #: ",PRCAKPAT,?30,"CALM CODE SHEET DONE: ",PRCAKCLM
 S PRCACT=PRCACT+1 K Z0,PRCAKCLM,PRCAKPAT Q
YALD S:Y="" Y=".." K:$L(Y)>4!(($L(Y)<2)&(Y'="$")) Y Q:Y=".."
 I $D(Y),(Y'="$") S Y=$E(Y,1,2)_"."_$E(Y,3)_"."_$E(Y,4)
 Q  ;end of YALD
APPR ;WRITE APPROPRIATION SYMBOL IN THE 430
 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)
 I $D(^PRCA(430,+PRCABN,2,+Z1,0)) W ?10,$P(^(0),U,4)
 K Z1,X1 Q