source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCOE4.m@ 1621

Last change on this file since 1621 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 1.5 KB
Line 
1PRCOE4 ;WISC/DJM-IFCAP SEGMENTS AC ;7/28/96 16:17
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5AC(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 ;
32AC1 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 ;
39AC2 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
47AC3 D ^%DTC S DDS=X K %Y,X Q
Note: See TracBrowser for help on using the repository browser.