48 lines
1.5 KiB
Mathematica
48 lines
1.5 KiB
Mathematica
PRCOE4 ;WISC/DJM-IFCAP SEGMENTS AC ;7/28/96 16:17
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
;
|
|
AC(A,A1,VAR1,VAR2) ;ACCOUNTING INFORMATION SEGMENT
|
|
N A23,B,D,DDS,DIS,E,ES,FOB,G,GBL,NET,PC,Q,X,X1,X2,X2D,X2M,X2Y
|
|
S FOB=$S($P(A1,U,6)]"":$P(A1,U,6),1:"D")
|
|
S B="AC^^"_FOB_"^^"
|
|
;
|
|
S ES=$P(A,U,13),ES=$$VDEC^PRCOEDI(ES,2)
|
|
S GBL=$G(^PRC(442,VAR1,12))
|
|
I FOB="O",$P(GBL,U,7)="" S $P(B,U,2)=ES
|
|
;
|
|
S Q=$P($G(^PRC(442,VAR1,5,0)),U,4)
|
|
I Q'>0 S B=B_"^30^N^" G AC1
|
|
;
|
|
S A23=$G(^PRC(442,VAR1,23))
|
|
I $P(A23,U,11)'="P",+A1>0,Q'>0 I $D(^PRC(440,+A1,3)),$P(^(3),U,2)="Y" S VAR2="NPPT" Q
|
|
S (D,E)=""
|
|
F S D=$O(^PRC(442,VAR1,5,D)) Q:D="" D
|
|
. S DIS(D)=$G(^PRC(442,VAR1,5,D,0))
|
|
. I +$P(DIS(D),U)=$P(DIS(D),U) S E=$S(E]"":E_"^"_D,1:D)
|
|
I E]"" D G AC1
|
|
. S G=$P(E,U),PC=$P(DIS(G),U)*100
|
|
. S:$L(PC)=1 PC="0"_PC
|
|
. S B=B_PC_"^"
|
|
. D AC2
|
|
. S B=B_DDS_"^^"
|
|
;
|
|
S B=B_"^" D AC2 S B=B_DDS_"^N^"
|
|
;
|
|
AC1 S NET=$P(A,U,16)
|
|
I NET=""!($P($G(^PRC(442,VAR1,7)),"^",1)+0=45) S NET=0
|
|
S NET=$TR($J(NET,10,2)," .","0")
|
|
S B=B_NET_"^"_$E($P($P(A,U,4),"."),4,99)_"^^^"_$P(A,U,5)_"^"_$P($P(A,U,3)," ")_"^^^^^^|"
|
|
S ^TMP($J,"STRING",6)=B
|
|
Q
|
|
;
|
|
AC2 I E]"" S DDS=DIS(G)
|
|
I E="" S DDS=$O(DIS(0)),DDS=DIS(DDS)
|
|
S DDS=$P(DDS,U,2) S:DDS="" DDS=30 Q:+DDS=DDS
|
|
I '$G(DT) D NOW^%DTC K %,%I,%H
|
|
S DDS=+DDS
|
|
S X2=$S($G(DT):DT,1:X),X2Y=$E(X2,1,3),X2M=$E(X2,4,5),X2D=$E(X2,6,7)
|
|
I DDS>X2D S X1=X2Y_X2M_DDS G AC3
|
|
S X2M=X2M+1 S:X2M>12 X2M=1,X2Y=X2Y+1 S X1=X2Y_X2M_DDS
|
|
AC3 D ^%DTC S DDS=X K %Y,X Q
|