Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCALM

PRCALM.m

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