PRCHHI5.m

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 ---PRCHHI5   1424     printed  Apr 09, 2024@21:13:51                                                                                                                                                                                                     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