| 1 | PRCHHI5 ;WISC/TGH/DL-IFCAP SEGMENT AC ;2/2/98 1350
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | AC(A,A1,VAR1,CNTR,NUM) ;ACCOUNTING INFORMATION SEGMENT
|
|---|
| 5 | N PRCHAPPR,PRCHAPLE,FILL,OBCL,CL22,PRCHOB22
|
|---|
| 6 | S PRCHED=A
|
|---|
| 7 | S PRCHFOB=$P(A1,U,6)
|
|---|
| 8 | S PRCHTP(1,CNTR+1)="S X=""|AC"";570"
|
|---|
| 9 | S PRCHTP(1,CNTR+2)="S X=$P(PRCHED,U,4);578"
|
|---|
| 10 | ;
|
|---|
| 11 | ;APPROPRIATION CODE UPTO 6 CHARS. W TRAILING SPACES
|
|---|
| 12 | S PRCHAPPR=$E($P($P(PRCHED,U,4),"."),4,99)
|
|---|
| 13 | ;I $D(PRCHAPPR) S PRCHAPLE=6-$L(PRCHAPPR) F FILL=1:1:PRCHAPLE S PRCHAPPR=PRCHAPPR_" "
|
|---|
| 14 | I $D(PRCHAPPR) S PRCHAPPR=PRCHAPPR_" ",PRCHAPPR=$E(PRCHAPPR,1,6)
|
|---|
| 15 | ;
|
|---|
| 16 | S PRCHEFY=$P(A1,U,15)
|
|---|
| 17 | S PRCHEFY=$E(100+$E(PRCHEFY,2,3)+$E(PRCHEFY,4),2,3)
|
|---|
| 18 | S PRCHTP(1,CNTR+3)="S X=PRCHEFY;580"
|
|---|
| 19 | S PRCHTP(1,CNTR+4)="S X=$P(PRCHED,U,5);581"
|
|---|
| 20 | S PRCHTP(1,CNTR+5)="S X=$P(PRCHED,U,3);582"
|
|---|
| 21 | S PRCHTP(1,CNTR+6)="S X=$P(PRCHED,U,6);584"
|
|---|
| 22 | ;S PRCHTP(1,CNTR+7)="S X=PRCHFOB;572"
|
|---|
| 23 | ;S PRCHTP(1,CNTR+8)="S X=$P(PRCHED,U,6);574"
|
|---|
| 24 | ;S PRCHTP(1,CNTR+9)="S X=+$P(PRCHED,U,6);575"
|
|---|
| 25 | S NUM=NUM+1
|
|---|
| 26 | ;
|
|---|
| 27 | ;OBJECT CLASS (BOC OR BOC1)
|
|---|
| 28 | ;V4 HAD ROLLED-UP 2 SUBA/C WHERE AS V5 HAS MULTI BOC'S IN NODE 22
|
|---|
| 29 | S OBCL=0
|
|---|
| 30 | S OBCL=$O(^PRC(442,VAR1,22,OBCL)) Q:OBCL'>0 D
|
|---|
| 31 | .S CL22=$G(^PRC(442,VAR1,22,OBCL,0))
|
|---|
| 32 | .S PRCHOB22=$P(CL22,"^")
|
|---|
| 33 | ;
|
|---|
| 34 | S ^TMP($J,"STRING",NUM)="AC"_"^^^^^^^^"_PRCHAPPR_"^^"_PRCHEFY_"^"_$P(PRCHED,U,5)_"^"_+$P(PRCHED,U,3)_"^^"_PRCHOB22_"^^^^|"
|
|---|
| 35 | S CNTR=CNTR+6
|
|---|
| 36 | Q
|
|---|
