PRCHDAM ;WISC/DJM,ID/RSD-DISPLAY AN AMENDMENT ;2/12/98 2:38 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
N X8,X9
S D0=$S($D(PRCHPO):PRCHPO,1:D0),D1=$S($D(PRCHAM):PRCHAM,1:D1),U="^"
Q:'$D(^PRC(443.6,D0,6,D1)) S IOP="HOME",%ZIS="",PRCHD0=^(D1,0),PRCHD1=^(1),PRCHDP0=^PRC(443.6,D0,0),PRCHDP1=^PRC(443.6,D0,1),PRCHDAV=$S($P(PRCHD0,U,8)="Y":1,1:0),PRC("SITE")=+PRCHDP0,U="^",PRCHDUL="",$P(PRCHDUL,"_",80)=""
D ^%ZIS W:$Y>0 @IOF G:PRCHDAV EN2 W !,"2. MOD. NO.: ",?15,"| 3. EFFECTIVE DATE: ",?46,"| 4. REQUISITION/P.O. REQ. NO.: "
W !?6,$P(PRCHD0,U,1),?15,"| " S Y=$P(PRCHD0,U,2) D DT
S Y=0 I $P(PRCHDP0,U,12),$D(^PRCS(410,+$P(PRCHDP0,U,12),0)) S Y=$P(^(0),U)
W ?46,"| ",$S(Y:Y_"/",1:" "),$P($P($G(^PRC(443.6,D0,0)),U,1),"-",2),!,PRCHDUL
S X=$G(^PRC(440,+PRCHDP1,0)) W !,"8. NAME AND ADDRESS OF CONTRACTOR ",?40,"| 10A. MODIFICATION OF CONTRACT/ORDER",!?5,$P(X,U,1),?40,"| NO."
W ?52,$P($G(^PRC(443.6,PRCHPO,0)),U)
D X8 S J=1 F I=2:1:5 I $P(X,U,I)]"" W !?5,$P(X,U,I),?40,"|" I J<X8 X X(J)
W !?5,$P(X,U,6),", ",$P($G(^DIC(5,+$P(X,U,7),0)),U,2)," ",$P(X,U,8),?40,"|" I J<X8 X X(J)
I J<X8 W:$X>40 ! F W ?40,"|" X X(J) Q:J>(X8-1) W !
ACC W !,PRCHDUL,!,"12. ACCOUNTING AND APPROPRIATION DATA (If required)" S X=$P(PRCHD0,U,3) W !?5,$S('X:"",X<0:"Decrease ",1:"Increase "),$P(PRCHDP0,U,4),"-",$P($P(PRCHDP0,U,3)," ",1) W:X " $",$J($S(X<0:-X,1:X),10,2)
I X W ?50,"TOTAL AMOUNT: $",$J($P(PRCHDP0,U,15),10,2)
W !,PRCHDUL S Y=$G(^PRCD(442.2,+$P(PRCHD0,U,4),0)) W !,$P(Y,U,1),". ",$P(Y,U,2),!?3,$P(PRCHD0,U,7),!,PRCHDUL
W !," IMPORTANT: Contractor is ",$S($P(PRCHD0,U,5)="Y":"",1:"not "),"required to sign this document and return"
W !,?4,$S($P(PRCHD0,U,5)="Y":+$P(PRCHD0,U,6)_" ",1:""),"copies to the issuing office."
W !!?8,"ENTER '^' TO HALT: " R X:DTIME G Q:X["^" W @IOF
S PRCHLC1=6,PRCHLC2=0
W !,"14. DESCRIPTION OF MODIFICATION (organized by UCF section heading,",!?5," including contract subject matter where feasible.)",!,PRCHDUL,!! D ITEM G:PRCHLC1["^" Q
D:(IOSL-7-PRCHLC2)<3 PGE G:PRCHLC1["^" Q
W !!,"Except as provided herein, all terms and conditions of the document referenced",!,"in Item 10A, as heretofore changed, remains unchanged and in full force and",!,"effect.",!,PRCHDUL
D REASON^PRCHDAM0
CO W !,"CONTRACTING OFFICER: " S Y=+$P(PRCHD1,U,1),Y=$P($G(^VA(200,Y,0)),U,1) W ?22,$P(Y,",",2)," ",$P(Y,",",1),!!
W ?8,"ENTER '^' TO HALT: " R X:DTIME
Q ;exit point
K PRCHD0,PRCHD1,PRCHDP0,PRCHDP1,PRCHDAV,PRCHDUL,PRCHII,PRCHLC1,PRCHLC2,X,^UTILITY($J,"W") Q
ITEM K ^UTILITY($J,"W") S DIWL=3,DIWR=75,DIWF="" I PRCHDAV'>0,$P($G(^PRC(443.6,D0,6,D1,2,0)),U,4)'>0 D START^PRCHDAM1(D0,D1) S DIWL=1 G CONT
S PRCHII=0 F S PRCHII=$O(^PRC(443.6,D0,6,D1,2,PRCHII)) Q:PRCHII=""!(PRCHII'>0) S X=^(PRCHII,0) D DIWP^PRCUTL($G(DA))
CONT K J S J=0,L=0 F I=0:0 S I=$O(^UTILITY($J,"W",DIWL,I)) S:'I J(L)=J Q:'I S:'L L=I S J=J+1 I " "[^(I,0) S J(L)=J,J=0,L=0
F I=0:0 S I=$O(^UTILITY($J,"W",DIWL,I)) Q:'I D:$D(J(I)) CHKP Q:PRCHLC1["^" W !,^(I,0) S PRCHLC2=PRCHLC2+1
Q
CHKP D:(IOSL-PRCHLC1-PRCHLC2-J(I))<3 PGE
Q
PGE W !!?8,"ENTER '^' TO HALT: " R X:DTIME I X["^" S PRCHLC1="^" Q
W:$Y>0 @IOF S PRCHLC1=3,PRCHLC2=0
Q
DT Q:'Y W Y\100#100,"/",Y#100\1,"/",Y\10000+1700
Q
X8 S (CTNO,X8)=0 F X8=1:1:3 S CTNO=$O(^PRC(443.6,D0,2,"AC",CTNO)) Q:CTNO="" D
.S X(X8)="W ?47,""CONTRACT # ",X(X8)=X(X8)_X8,X(X8)=X(X8)_": ",X(X8)=X(X8)_CTNO,X(X8)=X(X8)_""" S J=",X9=X8+1,X(X8)=X(X8)_X9
I $G(X(X8))]"" S X8=X8+1
S X(X8)="S J=",X9=X8+1,X(X8)=X(X8)_X9,X(X8)=X(X8)_" F K=1:1:38 W ""_""" S X8=X8+1
S X(X8)="W ?40,"" 10B. DATED (See Item 13) "" S Y=$P(PRCHDP1,U,15),J=",X9=X8+1,X(X8)=X(X8)_X9,X(X8)=X(X8)_" D DT",X8=X8+1
Q
EN2 ;ADJUSTMENT VOUCHER DISPLAY
W !?10,"ADJUSTMENT VOUCHER " S Y=$P(PRCHD0,U,2) D DT W !,PRCHDUL S PRCHLC1=3,PRCHLC2=0 D ITEM D:(IOSL-3-PRCHLC2)<3 PGE G CO
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDAM 3917 printed Sep 23, 2025@19:42:30 Page 2
PRCHDAM ;WISC/DJM,ID/RSD-DISPLAY AN AMENDMENT ;2/12/98 2:38 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW X8,X9
+3 SET D0=$SELECT($DATA(PRCHPO):PRCHPO,1:D0)
SET D1=$SELECT($DATA(PRCHAM):PRCHAM,1:D1)
SET U="^"
+4 if '$DATA(^PRC(443.6,D0,6,D1))
QUIT
SET IOP="HOME"
SET %ZIS=""
SET PRCHD0=^(D1,0)
SET PRCHD1=^(1)
SET PRCHDP0=^PRC(443.6,D0,0)
SET PRCHDP1=^PRC(443.6,D0,1)
SET PRCHDAV=$SELECT($PIECE(PRCHD0,U,8)="Y":1,1:0)
SET PRC("SITE")=+PRCHDP0
SET U="^"
SET PRCHDUL=""
SET $PIECE(PRCHDUL,"_",80)=""
+5 DO ^%ZIS
if $Y>0
WRITE @IOF
if PRCHDAV
GOTO EN2
WRITE !,"2. MOD. NO.: ",?15,"| 3. EFFECTIVE DATE: ",?46,"| 4. REQUISITION/P.O. REQ. NO.: "
+6 WRITE !?6,$PIECE(PRCHD0,U,1),?15,"| "
SET Y=$PIECE(PRCHD0,U,2)
DO DT
+7 SET Y=0
IF $PIECE(PRCHDP0,U,12)
IF $DATA(^PRCS(410,+$PIECE(PRCHDP0,U,12),0))
SET Y=$PIECE(^(0),U)
+8 WRITE ?46,"| ",$SELECT(Y:Y_"/",1:" "),$PIECE($PIECE($GET(^PRC(443.6,D0,0)),U,1),"-",2),!,PRCHDUL
+9 SET X=$GET(^PRC(440,+PRCHDP1,0))
WRITE !,"8. NAME AND ADDRESS OF CONTRACTOR ",?40,"| 10A. MODIFICATION OF CONTRACT/ORDER",!?5,$PIECE(X,U,1),?40,"| NO."
+10 WRITE ?52,$PIECE($GET(^PRC(443.6,PRCHPO,0)),U)
+11 DO X8
SET J=1
FOR I=2:1:5
IF $PIECE(X,U,I)]""
WRITE !?5,$PIECE(X,U,I),?40,"|"
IF J<X8
XECUTE X(J)
+12 WRITE !?5,$PIECE(X,U,6),", ",$PIECE($GET(^DIC(5,+$PIECE(X,U,7),0)),U,2)," ",$PIECE(X,U,8),?40,"|"
IF J<X8
XECUTE X(J)
+13 IF J<X8
if $X>40
WRITE !
FOR
WRITE ?40,"|"
XECUTE X(J)
if J>(X8-1)
QUIT
WRITE !
ACC WRITE !,PRCHDUL,!,"12. ACCOUNTING AND APPROPRIATION DATA (If required)"
SET X=$PIECE(PRCHD0,U,3)
WRITE !?5,$SELECT('X:"",X<0:"Decrease ",1:"Increase "),$PIECE(PRCHDP0,U,4),"-",$PIECE($PIECE(PRCHDP0,U,3)," ",1)
if X
WRITE " $",$JUSTIFY($SELECT(X<0:-X,1:X),10,2)
+1 IF X
WRITE ?50,"TOTAL AMOUNT: $",$JUSTIFY($PIECE(PRCHDP0,U,15),10,2)
+2 WRITE !,PRCHDUL
SET Y=$GET(^PRCD(442.2,+$PIECE(PRCHD0,U,4),0))
WRITE !,$PIECE(Y,U,1),". ",$PIECE(Y,U,2),!?3,$PIECE(PRCHD0,U,7),!,PRCHDUL
+3 WRITE !," IMPORTANT: Contractor is ",$SELECT($PIECE(PRCHD0,U,5)="Y":"",1:"not "),"required to sign this document and return"
+4 WRITE !,?4,$SELECT($PIECE(PRCHD0,U,5)="Y":+$PIECE(PRCHD0,U,6)_" ",1:""),"copies to the issuing office."
+5 WRITE !!?8,"ENTER '^' TO HALT: "
READ X:DTIME
if X["^"
GOTO Q
WRITE @IOF
+6 SET PRCHLC1=6
SET PRCHLC2=0
+7 WRITE !,"14. DESCRIPTION OF MODIFICATION (organized by UCF section heading,",!?5," including contract subject matter where feasible.)",!,PRCHDUL,!!
DO ITEM
if PRCHLC1["^"
GOTO Q
+8 if (IOSL-7-PRCHLC2)<3
DO PGE
if PRCHLC1["^"
GOTO Q
+9 WRITE !!,"Except as provided herein, all terms and conditions of the document referenced",!,"in Item 10A, as heretofore changed, remains unchanged and in full force and",!,"effect.",!,PRCHDUL
+10 DO REASON^PRCHDAM0
CO WRITE !,"CONTRACTING OFFICER: "
SET Y=+$PIECE(PRCHD1,U,1)
SET Y=$PIECE($GET(^VA(200,Y,0)),U,1)
WRITE ?22,$PIECE(Y,",",2)," ",$PIECE(Y,",",1),!!
+1 WRITE ?8,"ENTER '^' TO HALT: "
READ X:DTIME
Q ;exit point
+1 KILL PRCHD0,PRCHD1,PRCHDP0,PRCHDP1,PRCHDAV,PRCHDUL,PRCHII,PRCHLC1,PRCHLC2,X,^UTILITY($JOB,"W")
QUIT
ITEM KILL ^UTILITY($JOB,"W")
SET DIWL=3
SET DIWR=75
SET DIWF=""
IF PRCHDAV'>0
IF $PIECE($GET(^PRC(443.6,D0,6,D1,2,0)),U,4)'>0
DO START^PRCHDAM1(D0,D1)
SET DIWL=1
GOTO CONT
+1 SET PRCHII=0
FOR
SET PRCHII=$ORDER(^PRC(443.6,D0,6,D1,2,PRCHII))
if PRCHII=""!(PRCHII'>0)
QUIT
SET X=^(PRCHII,0)
DO DIWP^PRCUTL($GET(DA))
CONT KILL J
SET J=0
SET L=0
FOR I=0:0
SET I=$ORDER(^UTILITY($JOB,"W",DIWL,I))
if 'I
SET J(L)=J
if 'I
QUIT
if 'L
SET L=I
SET J=J+1
IF " "[^(I,0)
SET J(L)=J
SET J=0
SET L=0
+1 FOR I=0:0
SET I=$ORDER(^UTILITY($JOB,"W",DIWL,I))
if 'I
QUIT
if $DATA(J(I))
DO CHKP
if PRCHLC1["^"
QUIT
WRITE !,^(I,0)
SET PRCHLC2=PRCHLC2+1
+2 QUIT
CHKP if (IOSL-PRCHLC1-PRCHLC2-J(I))<3
DO PGE
+1 QUIT
PGE WRITE !!?8,"ENTER '^' TO HALT: "
READ X:DTIME
IF X["^"
SET PRCHLC1="^"
QUIT
+1 if $Y>0
WRITE @IOF
SET PRCHLC1=3
SET PRCHLC2=0
+2 QUIT
DT if 'Y
QUIT
WRITE Y\100#100,"/",Y#100\1,"/",Y\10000+1700
+1 QUIT
X8 SET (CTNO,X8)=0
FOR X8=1:1:3
SET CTNO=$ORDER(^PRC(443.6,D0,2,"AC",CTNO))
if CTNO=""
QUIT
Begin DoDot:1
+1 SET X(X8)="W ?47,""CONTRACT # "
SET X(X8)=X(X8)_X8
SET X(X8)=X(X8)_": "
SET X(X8)=X(X8)_CTNO
SET X(X8)=X(X8)_""" S J="
SET X9=X8+1
SET X(X8)=X(X8)_X9
End DoDot:1
+2 IF $GET(X(X8))]""
SET X8=X8+1
+3 SET X(X8)="S J="
SET X9=X8+1
SET X(X8)=X(X8)_X9
SET X(X8)=X(X8)_" F K=1:1:38 W ""_"""
SET X8=X8+1
+4 SET X(X8)="W ?40,"" 10B. DATED (See Item 13) "" S Y=$P(PRCHDP1,U,15),J="
SET X9=X8+1
SET X(X8)=X(X8)_X9
SET X(X8)=X(X8)_" D DT"
SET X8=X8+1
+5 QUIT
EN2 ;ADJUSTMENT VOUCHER DISPLAY
+1 WRITE !?10,"ADJUSTMENT VOUCHER "
SET Y=$PIECE(PRCHD0,U,2)
DO DT
WRITE !,PRCHDUL
SET PRCHLC1=3
SET PRCHLC2=0
DO ITEM
if (IOSL-3-PRCHLC2)<3
DO PGE
GOTO CO
