source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHHI5.m@ 1005

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

initial load of WorldVistAEHR

File size: 1.4 KB
Line 
1PRCHHI5 ;WISC/TGH/DL-IFCAP SEGMENT AC ;2/2/98 1350
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4AC(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
Note: See TracBrowser for help on using the repository browser.