RCAMFN01 ;WASH-ISC@ALTOONA,PA/RGY-MISCELLANEOUS AR FUNCTIONS ;4/30/96 8:39 AM
V ;;4.5;Accounts Receivable;**39,86**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
FPS(DATE,STM) ;
;Get a future or past statement date
;P1(STM)=statement date, P2(STM)=months to add or subtract
NEW X,Y,END,YR,MT
S Y=-1
I $G(DATE)'?7N G Q1
I $G(STM)'?.1"-"1N.N G Q1
S YR=$E(DATE,1,3),MT=$E(DATE,4,5),Y=$S(STM<0:-STM,1:STM)
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
S Y=YR_$S(MT<10:0_MT,1:MT)_$E(DATE,6,7)
Q1 Q Y
PST(Y) ;Input: debtor variable pointer value (EX: 1;DPT(, 34;DIC(36, etc)
;Return: Statement day or -1
I '$D(Y) S Y=-1
S:Y?1N.N Y=$P($G(^RCD(340,Y,0)),"^")
S Y=$P($G(^RCD(340,+$O(^RCD(340,"B",Y,0)),0)),"^",3) S:'Y Y=-1
Q Y
REC(DEB) ;Return receivable code for debtor
NEW X
S X=""
I $G(DEB)="" G Q4
S:DEB'?1N.N DEB=$O(^RCD(340,"B",DEB,0))
S X=$G(^RCD(340,DEB,0)) G:$P(X,"^")="" Q4
I $P(X,"^")[";DPT(" S X=2 G Q4
I $P(X,"^")[";VA(200," S X=2 G Q4
I $P(X,"^")[";DIC(36" S X=$S($P(X,"^",5)=3:3,$P(X,"^",5)=1:1,1:2) G Q4
I $P(X,"^")[";DIC(4," S X=$S($P(X,"^",5)=3:3,$P(X,"^",5)=2:2,1:1) G Q4
I $P(X,"^")[";PRC(" S X=$S($P(X,"^",5)=3:3,$P(X,"^",5)=1:1,1:2) G Q4
Q4 Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCAMFN01 1282 printed Dec 13, 2024@01:42:27 Page 2
RCAMFN01 ;WASH-ISC@ALTOONA,PA/RGY-MISCELLANEOUS AR FUNCTIONS ;4/30/96 8:39 AM
V ;;4.5;Accounts Receivable;**39,86**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
FPS(DATE,STM) ;
+1 ;Get a future or past statement date
+2 ;P1(STM)=statement date, P2(STM)=months to add or subtract
+3 NEW X,Y,END,YR,MT
+4 SET Y=-1
+5 IF $GET(DATE)'?7N
GOTO Q1
+6 IF $GET(STM)'?.1"-"1N.N
GOTO Q1
+7 SET YR=$EXTRACT(DATE,1,3)
SET MT=$EXTRACT(DATE,4,5)
SET Y=$SELECT(STM<0:-STM,1:STM)
+8 FOR X=1:1:Y
SET MT=MT+$SELECT(STM<0:-1,1:1)
if MT>12
SET YR=YR+1
SET MT=1
if MT<1
SET YR=YR-1
SET MT=12
+9 SET Y=YR_$SELECT(MT<10:0_MT,1:MT)_$EXTRACT(DATE,6,7)
Q1 QUIT Y
PST(Y) ;Input: debtor variable pointer value (EX: 1;DPT(, 34;DIC(36, etc)
+1 ;Return: Statement day or -1
+2 IF '$DATA(Y)
SET Y=-1
+3 if Y?1N.N
SET Y=$PIECE($GET(^RCD(340,Y,0)),"^")
+4 SET Y=$PIECE($GET(^RCD(340,+$ORDER(^RCD(340,"B",Y,0)),0)),"^",3)
if 'Y
SET Y=-1
+5 QUIT Y
REC(DEB) ;Return receivable code for debtor
+1 NEW X
+2 SET X=""
+3 IF $GET(DEB)=""
GOTO Q4
+4 if DEB'?1N.N
SET DEB=$ORDER(^RCD(340,"B",DEB,0))
+5 SET X=$GET(^RCD(340,DEB,0))
if $PIECE(X,"^")=""
GOTO Q4
+6 IF $PIECE(X,"^")[";DPT("
SET X=2
GOTO Q4
+7 IF $PIECE(X,"^")[";VA(200,"
SET X=2
GOTO Q4
+8 IF $PIECE(X,"^")[";DIC(36"
SET X=$SELECT($PIECE(X,"^",5)=3:3,$PIECE(X,"^",5)=1:1,1:2)
GOTO Q4
+9 IF $PIECE(X,"^")[";DIC(4,"
SET X=$SELECT($PIECE(X,"^",5)=3:3,$PIECE(X,"^",5)=2:2,1:1)
GOTO Q4
+10 IF $PIECE(X,"^")[";PRC("
SET X=$SELECT($PIECE(X,"^",5)=3:3,$PIECE(X,"^",5)=1:1,1:2)
GOTO Q4
Q4 QUIT X
