- 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 Feb 18, 2025@23:34:14 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