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