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

RCAMFN01.m

Go to the documentation of this file.
  1. RCAMFN01 ;WASH-ISC@ALTOONA,PA/RGY-MISCELLANEOUS AR FUNCTIONS ;4/30/96 8:39 AM
  1. V ;;4.5;Accounts Receivable;**39,86**;Mar 20, 1995
  1. ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1. FPS(DATE,STM) ;
  1. ;Get a future or past statement date
  1. ;P1(STM)=statement date, P2(STM)=months to add or subtract
  1. NEW X,Y,END,YR,MT
  1. S Y=-1
  1. I $G(DATE)'?7N G Q1
  1. I $G(STM)'?.1"-"1N.N G Q1
  1. S YR=$E(DATE,1,3),MT=$E(DATE,4,5),Y=$S(STM<0:-STM,1:STM)
  1. F X=1:1:Y S MT=MT+$S(STM<0:-1,1:1) S:MT>12 YR=YR+1,MT=1 S:MT<1 YR=YR-1,MT=12
  1. S Y=YR_$S(MT<10:0_MT,1:MT)_$E(DATE,6,7)
  1. Q1 Q Y
  1. PST(Y) ;Input: debtor variable pointer value (EX: 1;DPT(, 34;DIC(36, etc)
  1. ;Return: Statement day or -1
  1. I '$D(Y) S Y=-1
  1. S:Y?1N.N Y=$P($G(^RCD(340,Y,0)),"^")
  1. S Y=$P($G(^RCD(340,+$O(^RCD(340,"B",Y,0)),0)),"^",3) S:'Y Y=-1
  1. Q Y
  1. REC(DEB) ;Return receivable code for debtor
  1. NEW X
  1. S X=""
  1. I $G(DEB)="" G Q4
  1. S:DEB'?1N.N DEB=$O(^RCD(340,"B",DEB,0))
  1. S X=$G(^RCD(340,DEB,0)) G:$P(X,"^")="" Q4
  1. I $P(X,"^")[";DPT(" S X=2 G Q4
  1. I $P(X,"^")[";VA(200," S X=2 G Q4
  1. I $P(X,"^")[";DIC(36" S X=$S($P(X,"^",5)=3:3,$P(X,"^",5)=1:1,1:2) G Q4
  1. I $P(X,"^")[";DIC(4," S X=$S($P(X,"^",5)=3:3,$P(X,"^",5)=2:2,1:1) G Q4
  1. I $P(X,"^")[";PRC(" S X=$S($P(X,"^",5)=3:3,$P(X,"^",5)=1:1,1:2) G Q4
  1. Q4 Q X