PRCHPAM1 ;WISC/AKS,ID/TKW/RSD-PRINT AMENDMENT ;4/22/99 18:40
V ;;5.1;IFCAP;**132**;Oct 20, 2000;Build 3
;Per VHA Directive 2004-038, this routine should not be modified.
;
ACC W PRCHUL,!,"12.ACCOUNTING AND APPROPRIATION DATA (If required)" S X=$P(PRCH0,U,3) W ?56,"TOTAL AMOUNT: $",$J($P(PRCHP0,U,15),10,2)
W !?5,$S('X:"",X<0:"Decrease ",1:"Increase "),$P(PRCHP0,U,4),"-",$P($P(PRCHP0,U,3)," ",1),"-",$P(PRCHP0,U,5),$S($P(PRCHP0,U,6)>0:"-"_$P(PRCHP0,U,6),1:""),$S($P(PRCHP0,U,8)>0:"-"_$P(PRCHP0,U,8),1:"")
I X W " $",$J($S(X<0:-X,1:X),10,2)
S X=$P(PRCH1,U,6) I X]"" S X=$$DECODE^PRCHES7(D0,D1) W ?56,"/ES/"_X
W !,PRCHUL,!?16,"13.THIS ITEM APPLIES ONLY TO MODIFICATIONS OF CONTRACTS/ORDERS.",!?19,"IT MODIFIES THE CONTRACT/ORDER NO. AS DESCRIBED IN ITEM 14.",!,PRCHUL,!
S Y=$G(^PRCD(442.2,+$P(PRCH0,U,4),0)),PRCHX=$P(Y,U,1),DIWL=1,DIWR=92,DIWF=""
S PRCHI=$S($P(PRCHP0,U,2)=8:10,1:0)
F S PRCHI=$O(^PRCD(442.2,PRCHI)) Q:PRCHI>$S($P(PRCHP0,U,2)=8:19,1:10) S Y=^(PRCHI,0),PRCHTYP=$P(Y,U,1) I PRCHTYP="A"!(PRCHTYP="B")!(PRCHTYP="C")!(PRCHTYP="D") D A
S X="_",Y="_" S:$P(PRCH0,U,5)="Y" X="X" S:$P(PRCH0,U,5)'="Y" Y="X"
W "IMPORTANT: Contractor __"_Y_"__ is not, __"_X_"__ is required to sign this document and return",!?14
S Y=$S($P(PRCH0,U,6):$P(PRCH0,U,6),1:"_") W "__"_Y_"__ copies to the issuing office.",!,PRCHUL
D HDR
W !!,"14.DESCRIPTION OF AMENDMENT/MODIFICATION (Organized by UCF section headings, including solicita-",!?42,"tion/contract subject matter where feasible.)",!! S PRCHDY=PRCHDY+5
;
ITEM F I=0:0 S I=$O(^TMP($J,"AMD",1,I)) Q:'I D:PRCHDY>60 H W ?3,^(I,0),! S PRCHDY=PRCHDY+1
D:PRCHDY>57 HDR W !,"Except as provided herein, all terms and conditions of the document referenced in Item 9A or ,",!,"10A as heretofore changed, remains unchanged and in full force and effect.",!,PRCHUL,! S PRCHDY=PRCHDY+4
D:PRCHDY>47 HDR W "15A.NAME AND TITLE OF SIGNER (Type or print)",?46,"|16A.NAME AND TITLE OF CONTRACTING OFFICER (Type",!?46,"| or print)",!
S X=$P(PRCH1,U,2) I X]"" S DA=D0,P=+PRCH1
W ?46,"| ",$$DECODE^PRCHES6(D0,D1)," Contracting Officer"
D FAXEMAIL^PRCHFPT3(+PRCH1,.PRCFAX,.PRCEMAIL)
W:PRCFAX'="" !?46,"|FAX: ",PRCFAX
W:PRCEMAIL'="" !?46,"|E-MAIL",!?46,"|",PRCEMAIL K PRCFAX,PRCEMAIL
W !,$E(PRCHUL,1,46),"|",$E(PRCHUL,1,49),!
W "15B.CONTRACTOR/OFFEROR",?34,"|15C.DATE",?46,"|16B.UNITED STATES OF AMERICA",?82,"|16C.DATE",!,?34,"| SIGNED",?46,"|",?82,"| SIGNED",!
W ?2,$E(PRCHUL,1,28),?34,"|",?46,"| BY ",$E(PRCHUL,1,29),?82,"|",!
W ?1,"(Signature of person authorized",?34,"|",?46,"|(Signature of Contracting Officer)",?82,"|",!
W ?2,"to sign)",?34,"|",?46,"|",?82,"|",!,$E(PRCHUL,1,34),"|",$E(PRCHUL,1,11),"|",$E(PRCHUL,1,35),"|",$E(PRCHUL,1,13),!
W "Exception to SF-30",?75,"SF-30 ADP (Rev 10-83)",!,"Approved by OIRM ____",!
;
EXIT K D0,D1,DA,P,I,J,X,Y,DIWF,DIWL,DIWR,PRCH0,PRCH1,PRCHAV,PRCHP0,PRCHP1,PRCHI,PRCHTYP,PRCHUL,PRCHX,PRCHDY,PRCHPG,PRCHPGT,PRCHREPR,PRCHTPG,^UTILITY($J),^TMP($J) D:$D(ZTSK) KILL^%ZTLOAD K ZTSK
Q
;
A K ^UTILITY($J,"W") S X=$P(Y,U,2) D DIWP^PRCUTL($G(DA)) S X="" S:PRCHX=PRCHTYP X=$P(PRCH0,U,7) D:X]"" DIWP^PRCUTL($G(DA))
W:PRCHX=PRCHTYP ?1,"X" S J=0 F I=0:0 S I=$O(^UTILITY($J,"W",1,I)) Q:'I S J=J+1 W ?3,"|" W:J=1 PRCHTYP,"." W ?6,^(I,0),!
W "___|",$E(PRCHUL,1,92),!
Q
;
H D HDR W ! S PRCHDY=PRCHDY+1
Q
;
HDR W:$Y>0 @IOF W !,$S($D(PRCHREPR):$E(PRCHUL,1,35)_" **REPRINT** "_$E(PRCHUL,49,96),1:PRCHUL)
W !,"AMENDMENT OF SOLICITATION/MODIFICATION OF CONTRACT",?55,"|1.CONTRACT ID CODE",?76,"|PAGE OF PAGES",!
W $E(PRCHUL,1,55),"|",$E(PRCHUL,1,20),"|"
S X=(8-$L(PRCHPG))/2,Y=$P(X,".",1),Z=$P(X,".",2) W $E(PRCHUL,1,Y) W:Z "_" W PRCHPG,$E(PRCHUL,1,Y),"|_" S X=7-$L(PRCHPGT) W PRCHPGT W:X>0 $E(PRCHUL,1,X) W !
S PRCHPG=PRCHPG+1,PRCHDY=4
Q
;
EN2 ;ADJUSTMENT VOUCHER
D EN2H F I=0:0 S I=$O(^TMP($J,"AMD",1,I)) Q:'I D:PRCHDY>50 EN2H W ?3,^(I,0),! S PRCHDY=PRCHDY+1
F I=PRCHDY:1:50 W !
W !,PRCHUL,!,"Approve subject to final action on R/S on items indicated.",?65,"| DATE | P.O. NO.",!,$E(PRCHUL,1,65),"|",?77,"|",!
W "SIGNATURE OF CONTRACTING OFFICER",?65,"|",?77,"|",!,?65,"|",?77,"|",! S X=$$DECODE^PRCHES6(D0,D1) W "/ES/"_X_" " S Y=$P(PRCH1,U,3) D DT^PRCHPAM
W ?65,"| " S Y=$P(PRCH0,U,2) D DT^PRCHPAM W ?77,"|",!,$E(PRCHUL,1,65),"|",$E(PRCHUL,1,11),"|",$E(PRCHUL,1,19),!
G EXIT
;
EN2H W:$Y>0 @IOF W ?5,"SUBJECT: ADJUSTMENT VOUCHER" W:$D(PRCHREPR) " **REPRINT**" W !!!! S PRCHDY=0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHPAM1 4469 printed Sep 23, 2025@19:45:18 Page 2
PRCHPAM1 ;WISC/AKS,ID/TKW/RSD-PRINT AMENDMENT ;4/22/99 18:40
V ;;5.1;IFCAP;**132**;Oct 20, 2000;Build 3
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
ACC WRITE PRCHUL,!,"12.ACCOUNTING AND APPROPRIATION DATA (If required)"
SET X=$PIECE(PRCH0,U,3)
WRITE ?56,"TOTAL AMOUNT: $",$JUSTIFY($PIECE(PRCHP0,U,15),10,2)
+1 WRITE !?5,$SELECT('X:"",X<0:"Decrease ",1:"Increase "),$PIECE(PRCHP0,U,4),"-",$PIECE($PIECE(PRCHP0,U,3)," ",1),"-",$PIECE(PRCHP0,U,5),$SELECT($PIECE(PRCHP0,U,6)>0:"-"_$PIECE(PRCHP0,U,6),1:""),$SELECT($PIECE(PRCHP0,U,8)>0:"-"_$PIECE(PRCHP0,U,8),
1:"")
+2 IF X
WRITE " $",$JUSTIFY($SELECT(X<0:-X,1:X),10,2)
+3 SET X=$PIECE(PRCH1,U,6)
IF X]""
SET X=$$DECODE^PRCHES7(D0,D1)
WRITE ?56,"/ES/"_X
+4 WRITE !,PRCHUL,!?16,"13.THIS ITEM APPLIES ONLY TO MODIFICATIONS OF CONTRACTS/ORDERS.",!?19,"IT MODIFIES THE CONTRACT/ORDER NO. AS DESCRIBED IN ITEM 14.",!,PRCHUL,!
+5 SET Y=$GET(^PRCD(442.2,+$PIECE(PRCH0,U,4),0))
SET PRCHX=$PIECE(Y,U,1)
SET DIWL=1
SET DIWR=92
SET DIWF=""
+6 SET PRCHI=$SELECT($PIECE(PRCHP0,U,2)=8:10,1:0)
+7 FOR
SET PRCHI=$ORDER(^PRCD(442.2,PRCHI))
if PRCHI>$SELECT($PIECE(PRCHP0,U,2)=8
QUIT
SET Y=^(PRCHI,0)
SET PRCHTYP=$PIECE(Y,U,1)
IF PRCHTYP="A"!(PRCHTYP="B")!(PRCHTYP="C")!(PRCHTYP="D")
DO A
+8 SET X="_"
SET Y="_"
if $PIECE(PRCH0,U,5)="Y"
SET X="X"
if $PIECE(PRCH0,U,5)'="Y"
SET Y="X"
+9 WRITE "IMPORTANT: Contractor __"_Y_"__ is not, __"_X_"__ is required to sign this document and return",!?14
+10 SET Y=$SELECT($PIECE(PRCH0,U,6):$PIECE(PRCH0,U,6),1:"_")
WRITE "__"_Y_"__ copies to the issuing office.",!,PRCHUL
+11 DO HDR
+12 WRITE !!,"14.DESCRIPTION OF AMENDMENT/MODIFICATION (Organized by UCF section headings, including solicita-",!?42,"tion/contract subject matter where feasible.)",!!
SET PRCHDY=PRCHDY+5
+13 ;
ITEM FOR I=0:0
SET I=$ORDER(^TMP($JOB,"AMD",1,I))
if 'I
QUIT
if PRCHDY>60
DO H
WRITE ?3,^(I,0),!
SET PRCHDY=PRCHDY+1
+1 if PRCHDY>57
DO HDR
WRITE !,"Except as provided herein, all terms and conditions of the document referenced in Item 9A or ,",!,"10A as heretofore changed, remains unchanged and in full force and effect.",!,PRCHUL,!
SET PRCHDY=PRCHDY+4
+2 if PRCHDY>47
DO HDR
WRITE "15A.NAME AND TITLE OF SIGNER (Type or print)",?46,"|16A.NAME AND TITLE OF CONTRACTING OFFICER (Type",!?46,"| or print)",!
+3 SET X=$PIECE(PRCH1,U,2)
IF X]""
SET DA=D0
SET P=+PRCH1
+4 WRITE ?46,"| ",$$DECODE^PRCHES6(D0,D1)," Contracting Officer"
+5 DO FAXEMAIL^PRCHFPT3(+PRCH1,.PRCFAX,.PRCEMAIL)
+6 if PRCFAX'=""
WRITE !?46,"|FAX: ",PRCFAX
+7 if PRCEMAIL'=""
WRITE !?46,"|E-MAIL",!?46,"|",PRCEMAIL
KILL PRCFAX,PRCEMAIL
+8 WRITE !,$EXTRACT(PRCHUL,1,46),"|",$EXTRACT(PRCHUL,1,49),!
+9 WRITE "15B.CONTRACTOR/OFFEROR",?34,"|15C.DATE",?46,"|16B.UNITED STATES OF AMERICA",?82,"|16C.DATE",!,?34,"| SIGNED",?46,"|",?82,"| SIGNED",!
+10 WRITE ?2,$EXTRACT(PRCHUL,1,28),?34,"|",?46,"| BY ",$EXTRACT(PRCHUL,1,29),?82,"|",!
+11 WRITE ?1,"(Signature of person authorized",?34,"|",?46,"|(Signature of Contracting Officer)",?82,"|",!
+12 WRITE ?2,"to sign)",?34,"|",?46,"|",?82,"|",!,$EXTRACT(PRCHUL,1,34),"|",$EXTRACT(PRCHUL,1,11),"|",$EXTRACT(PRCHUL,1,35),"|",$EXTRACT(PRCHUL,1,13),!
+13 WRITE "Exception to SF-30",?75,"SF-30 ADP (Rev 10-83)",!,"Approved by OIRM ____",!
+14 ;
EXIT KILL D0,D1,DA,P,I,J,X,Y,DIWF,DIWL,DIWR,PRCH0,PRCH1,PRCHAV,PRCHP0,PRCHP1,PRCHI,PRCHTYP,PRCHUL,PRCHX,PRCHDY,PRCHPG,PRCHPGT,PRCHREPR,PRCHTPG,^UTILITY($JOB),^TMP($JOB)
if $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
+1 QUIT
+2 ;
A KILL ^UTILITY($JOB,"W")
SET X=$PIECE(Y,U,2)
DO DIWP^PRCUTL($GET(DA))
SET X=""
if PRCHX=PRCHTYP
SET X=$PIECE(PRCH0,U,7)
if X]""
DO DIWP^PRCUTL($GET(DA))
+1 if PRCHX=PRCHTYP
WRITE ?1,"X"
SET J=0
FOR I=0:0
SET I=$ORDER(^UTILITY($JOB,"W",1,I))
if 'I
QUIT
SET J=J+1
WRITE ?3,"|"
if J=1
WRITE PRCHTYP,"."
WRITE ?6,^(I,0),!
+2 WRITE "___|",$EXTRACT(PRCHUL,1,92),!
+3 QUIT
+4 ;
H DO HDR
WRITE !
SET PRCHDY=PRCHDY+1
+1 QUIT
+2 ;
HDR if $Y>0
WRITE @IOF
WRITE !,$SELECT($DATA(PRCHREPR):$EXTRACT(PRCHUL,1,35)_" **REPRINT** "_$EXTRACT(PRCHUL,49,96),1:PRCHUL)
+1 WRITE !,"AMENDMENT OF SOLICITATION/MODIFICATION OF CONTRACT",?55,"|1.CONTRACT ID CODE",?76,"|PAGE OF PAGES",!
+2 WRITE $EXTRACT(PRCHUL,1,55),"|",$EXTRACT(PRCHUL,1,20),"|"
+3 SET X=(8-$LENGTH(PRCHPG))/2
SET Y=$PIECE(X,".",1)
SET Z=$PIECE(X,".",2)
WRITE $EXTRACT(PRCHUL,1,Y)
if Z
WRITE "_"
WRITE PRCHPG,$EXTRACT(PRCHUL,1,Y),"|_"
SET X=7-$LENGTH(PRCHPGT)
WRITE PRCHPGT
if X>0
WRITE $EXTRACT(PRCHUL,1,X)
WRITE !
+4 SET PRCHPG=PRCHPG+1
SET PRCHDY=4
+5 QUIT
+6 ;
EN2 ;ADJUSTMENT VOUCHER
+1 DO EN2H
FOR I=0:0
SET I=$ORDER(^TMP($JOB,"AMD",1,I))
if 'I
QUIT
if PRCHDY>50
DO EN2H
WRITE ?3,^(I,0),!
SET PRCHDY=PRCHDY+1
+2 FOR I=PRCHDY:1:50
WRITE !
+3 WRITE !,PRCHUL,!,"Approve subject to final action on R/S on items indicated.",?65,"| DATE | P.O. NO.",!,$EXTRACT(PRCHUL,1,65),"|",?77,"|",!
+4 WRITE "SIGNATURE OF CONTRACTING OFFICER",?65,"|",?77,"|",!,?65,"|",?77,"|",!
SET X=$$DECODE^PRCHES6(D0,D1)
WRITE "/ES/"_X_" "
SET Y=$PIECE(PRCH1,U,3)
DO DT^PRCHPAM
+5 WRITE ?65,"| "
SET Y=$PIECE(PRCH0,U,2)
DO DT^PRCHPAM
WRITE ?77,"|",!,$EXTRACT(PRCHUL,1,65),"|",$EXTRACT(PRCHUL,1,11),"|",$EXTRACT(PRCHUL,1,19),!
+6 GOTO EXIT
+7 ;
EN2H if $Y>0
WRITE @IOF
WRITE ?5,"SUBJECT: ADJUSTMENT VOUCHER"
if $DATA(PRCHREPR)
WRITE " **REPRINT**"
WRITE !!!!
SET PRCHDY=0
+1 QUIT
