| 1 | PRCOE4 ;WISC/DJM-IFCAP SEGMENTS AC ;7/28/96 16:17
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | AC(A,A1,VAR1,VAR2) ;ACCOUNTING INFORMATION SEGMENT
|
|---|
| 6 | N A23,B,D,DDS,DIS,E,ES,FOB,G,GBL,NET,PC,Q,X,X1,X2,X2D,X2M,X2Y
|
|---|
| 7 | S FOB=$S($P(A1,U,6)]"":$P(A1,U,6),1:"D")
|
|---|
| 8 | S B="AC^^"_FOB_"^^"
|
|---|
| 9 | ;
|
|---|
| 10 | S ES=$P(A,U,13),ES=$$VDEC^PRCOEDI(ES,2)
|
|---|
| 11 | S GBL=$G(^PRC(442,VAR1,12))
|
|---|
| 12 | I FOB="O",$P(GBL,U,7)="" S $P(B,U,2)=ES
|
|---|
| 13 | ;
|
|---|
| 14 | S Q=$P($G(^PRC(442,VAR1,5,0)),U,4)
|
|---|
| 15 | I Q'>0 S B=B_"^30^N^" G AC1
|
|---|
| 16 | ;
|
|---|
| 17 | S A23=$G(^PRC(442,VAR1,23))
|
|---|
| 18 | 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
|
|---|
| 19 | S (D,E)=""
|
|---|
| 20 | F S D=$O(^PRC(442,VAR1,5,D)) Q:D="" D
|
|---|
| 21 | . S DIS(D)=$G(^PRC(442,VAR1,5,D,0))
|
|---|
| 22 | . I +$P(DIS(D),U)=$P(DIS(D),U) S E=$S(E]"":E_"^"_D,1:D)
|
|---|
| 23 | I E]"" D G AC1
|
|---|
| 24 | . S G=$P(E,U),PC=$P(DIS(G),U)*100
|
|---|
| 25 | . S:$L(PC)=1 PC="0"_PC
|
|---|
| 26 | . S B=B_PC_"^"
|
|---|
| 27 | . D AC2
|
|---|
| 28 | . S B=B_DDS_"^^"
|
|---|
| 29 | ;
|
|---|
| 30 | S B=B_"^" D AC2 S B=B_DDS_"^N^"
|
|---|
| 31 | ;
|
|---|
| 32 | AC1 S NET=$P(A,U,16)
|
|---|
| 33 | I NET=""!($P($G(^PRC(442,VAR1,7)),"^",1)+0=45) S NET=0
|
|---|
| 34 | S NET=$TR($J(NET,10,2)," .","0")
|
|---|
| 35 | S B=B_NET_"^"_$E($P($P(A,U,4),"."),4,99)_"^^^"_$P(A,U,5)_"^"_$P($P(A,U,3)," ")_"^^^^^^|"
|
|---|
| 36 | S ^TMP($J,"STRING",6)=B
|
|---|
| 37 | Q
|
|---|
| 38 | ;
|
|---|
| 39 | AC2 I E]"" S DDS=DIS(G)
|
|---|
| 40 | I E="" S DDS=$O(DIS(0)),DDS=DIS(DDS)
|
|---|
| 41 | S DDS=$P(DDS,U,2) S:DDS="" DDS=30 Q:+DDS=DDS
|
|---|
| 42 | I '$G(DT) D NOW^%DTC K %,%I,%H
|
|---|
| 43 | S DDS=+DDS
|
|---|
| 44 | S X2=$S($G(DT):DT,1:X),X2Y=$E(X2,1,3),X2M=$E(X2,4,5),X2D=$E(X2,6,7)
|
|---|
| 45 | I DDS>X2D S X1=X2Y_X2M_DDS G AC3
|
|---|
| 46 | S X2M=X2M+1 S:X2M>12 X2M=1,X2Y=X2Y+1 S X1=X2Y_X2M_DDS
|
|---|
| 47 | AC3 D ^%DTC S DDS=X K %Y,X Q
|
|---|
