RMPRP22 ;PHX/RFM-CONT RMPRP21 ;8/29/1994
;;3.0;PROSTHETICS;**3**;Feb 09, 1996
S RO=0 F I=1:1 S RO=$O(R664(1,RO)) Q:RO'>0 D Q:$D(J1)
.I I>4 S J1=1 W !!,?9,"***SEE ATTACHED CONTINUATION SHEET FOR ITEM DESCRIPTION(S)***",!! Q
.I $D(R664(1,RO,1,0)) S RP=0 F J=1:1 S RP=$O(R664(1,RO,1,RP)) Q:RP="" D Q:$D(J1)
..I I>4!((J+I)>4) S J1=1 W !!,?9,"***SEE ATTACHED CONTINUATION SHEET FOR ITEM DESCRIPTION(S)***",!! Q
D ADD
S RO=0 F S RO=$O(R664(1,RO)) Q:RO'>0 D:'$D(RMPRMOR)&($Y>36) CONT D:$D(RMPRMOR)&($Y>58) CONT D:'$D(RMPRMOR) ADD D START
I '$D(RMPRMOR)&($Y<37) F W ! Q:$Y>36
Q
START W !,"#"_RO_"."
W ?4,$P(R664(1,RO,0),U,2)
W ?50,$J($P(R664(1,RO,0),U,4),6) S RMPRUT=$P(R664(1,RO,0),U,5) W:$D(^PRCD(420.5,+RMPRUT,0)) ?61,$P(^PRCD(420.5,+RMPRUT,0),U,1),?65,$J($FN($P(R664(1,RO,0),U,3),"P",2),6)
ZWE S RMPRTOT=$P(R664(1,RO,0),U,3)*$P(R664(1,RO,0),U,4) W ?72,$J($FN(RMPRTOT,"P",2),8) D EXT
Q
EXT ;CHECKING FOR EXTENDED DESCRIPTION
S RMPRCH=$G(R664(1,RO,1,0)) Q:RMPRCH="" S (RMPR90,RMPRX)=$Q(R664(1,RO,0,0)),RMPRX=$E(RMPRX,1,10) Q:RMPR90="" F S RMPR90=$Q(@RMPR90) Q:RMPRX'=$E(RMPR90,1,10) D:$D(RMPRMOR)&($Y>58) CONT D:'$D(RMPRMOR)&($Y>36) CONT D WRI
Q
WRI ;CONTINUATION OF 10-2421
W !,@RMPR90 Q
CONT D:'$D(RMPRMOR) CON W @IOF,!,"CONTINUATION OF 2421",?27,"ORDER NUMBER: ",RTN,?71,"PAGE ",RMPRPAGE S RMPRMOR=1,RMPRPAGE=RMPRPAGE+1 D HDR^RMPRP21
Q
ADD S (RMPRAMT2,RMPRAMT,RMPRAMT1,RMPRAMTN)=0
S RC=0 F S RC=$O(R664(1,RC)) Q:RC=""!(RC["B") D ADD1
I $D(R664(2)) S RMPRDISC=$S($P(R664(2),U,6)'="":$P(R664(2),U,6),1:"") I $D(RMPRDISC) S RMPRAMT2=$J(RMPRDISC*RMPRAMT/100,0,2),RMPRAMTN=RMPRAMT-$J(RMPRAMT2,0,2),RMPRAMTN=$J(RMPRAMTN+$P(R664(0),U,10),0,2) Q
Q
ADD1 S RMPRAMT1=$J($P(R664(1,RC,0),U,4)*$P(R664(1,RC,0),U,3),0,2) S RMPRAMT=RMPRAMT+RMPRAMT1 Q
CON ;CONTINUATION OF 2421
W !,RMPRB,!,"16. Contract Number: " S RO("C")=$O(R664(1,0)) W:RO("C") $P(R664(1,RO("C"),0),U,14) W ?61,"Subtotal: ",$J($FN(RMPRAMT,"P",2),8)
W !," ACCT.#: ",RMPRVACN K RMPRVACN
W ?28,"Discount $" I $D(RMPRAMT2) W $J($FN(RMPRAMT2,"P",2),7)
W ?45,"Shipping: ",$J($FN($P(R664(0),U,10),"P",2),5)
W ?62,"Total",?69,"$",$J($FN(RMPRAMTN,"P",2),9)
W !,RMPRB,!,"17. Signature and Title of"
W ?28,"18. DATE",?39,"19. Signature and Title of",?70,"20. Date"
W !,?5,"Requesting Official",?39,"Contracting/Accountable Officer"
W !!,?5,RDUZ,?39,RMPR("SIG") S Y=$P($G(R664(4)),U,5) I Y'="" D DD^%DT W ?68,Y
W !,RMPRB,!?25,"Order and Receipt Action",!,RMPRB
W !,"21. Order Number",?18,"22. Date of Order",?37,"23. Date Item Received",?62,"24. Date Delivered"
W !,?3,RTN,?22,RMPRODTE
W !,RMPRB
W !,"25. The articles or services listed herein have been received, or rendered",!,"ordered in the quantity and quality specified orginally or as shown by"
W !,"authenticated changes, except as noted.",!!?40,"Signature of Veteran or VA Official",!,RMPRB,!?30,"VOUCHER AUDIT BLOCK (For use by VA Facility only)",!,RMPRB
W !,"Approved For",?25,"Date",?50,"Voucher Auditor",!!,$E(RMPRB,1,50),!,"Acct. Symbol",?54,"ADP Form 10-2421 APR 1991" S RMPRMOR1=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRP22 3085 printed Apr 09, 2024@21:40:14 Page 2
RMPRP22 ;PHX/RFM-CONT RMPRP21 ;8/29/1994
+1 ;;3.0;PROSTHETICS;**3**;Feb 09, 1996
+2 SET RO=0
FOR I=1:1
SET RO=$ORDER(R664(1,RO))
if RO'>0
QUIT
Begin DoDot:1
+3 IF I>4
SET J1=1
WRITE !!,?9,"***SEE ATTACHED CONTINUATION SHEET FOR ITEM DESCRIPTION(S)***",!!
QUIT
+4 IF $DATA(R664(1,RO,1,0))
SET RP=0
FOR J=1:1
SET RP=$ORDER(R664(1,RO,1,RP))
if RP=""
QUIT
Begin DoDot:2
+5 IF I>4!((J+I)>4)
SET J1=1
WRITE !!,?9,"***SEE ATTACHED CONTINUATION SHEET FOR ITEM DESCRIPTION(S)***",!!
QUIT
End DoDot:2
if $DATA(J1)
QUIT
End DoDot:1
if $DATA(J1)
QUIT
+6 DO ADD
+7 SET RO=0
FOR
SET RO=$ORDER(R664(1,RO))
if RO'>0
QUIT
if '$DATA(RMPRMOR)&($Y>36)
DO CONT
if $DATA(RMPRMOR)&($Y>58)
DO CONT
if '$DATA(RMPRMOR)
DO ADD
DO START
+8 IF '$DATA(RMPRMOR)&($Y<37)
FOR
WRITE !
if $Y>36
QUIT
+9 QUIT
START WRITE !,"#"_RO_"."
+1 WRITE ?4,$PIECE(R664(1,RO,0),U,2)
+2 WRITE ?50,$JUSTIFY($PIECE(R664(1,RO,0),U,4),6)
SET RMPRUT=$PIECE(R664(1,RO,0),U,5)
if $DATA(^PRCD(420.5,+RMPRUT,0))
WRITE ?61,$PIECE(^PRCD(420.5,+RMPRUT,0),U,1),?65,$JUSTIFY($FNUMBER($PIECE(R664(1,RO,0),U,3),"P",2),6)
ZWE SET RMPRTOT=$PIECE(R664(1,RO,0),U,3)*$PIECE(R664(1,RO,0),U,4)
WRITE ?72,$JUSTIFY($FNUMBER(RMPRTOT,"P",2),8)
DO EXT
+1 QUIT
EXT ;CHECKING FOR EXTENDED DESCRIPTION
+1 SET RMPRCH=$GET(R664(1,RO,1,0))
if RMPRCH=""
QUIT
SET (RMPR90,RMPRX)=$QUERY(R664(1,RO,0,0))
SET RMPRX=$EXTRACT(RMPRX,1,10)
if RMPR90=""
QUIT
FOR
SET RMPR90=$QUERY(@RMPR90)
if RMPRX'=$EXTRACT(RMPR90,1,10)
QUIT
if $DATA(RMPRMOR)&($Y>58)
DO CONT
if '$DATA(RMPRMOR)&($Y>36)
DO CONT
DO WRI
+2 QUIT
WRI ;CONTINUATION OF 10-2421
+1 WRITE !,@RMPR90
QUIT
CONT if '$DATA(RMPRMOR)
DO CON
WRITE @IOF,!,"CONTINUATION OF 2421",?27,"ORDER NUMBER: ",RTN,?71,"PAGE ",RMPRPAGE
SET RMPRMOR=1
SET RMPRPAGE=RMPRPAGE+1
DO HDR^RMPRP21
+1 QUIT
ADD SET (RMPRAMT2,RMPRAMT,RMPRAMT1,RMPRAMTN)=0
+1 SET RC=0
FOR
SET RC=$ORDER(R664(1,RC))
if RC=""!(RC["B")
QUIT
DO ADD1
+2 IF $DATA(R664(2))
SET RMPRDISC=$SELECT($PIECE(R664(2),U,6)'="":$PIECE(R664(2),U,6),1:"")
IF $DATA(RMPRDISC)
SET RMPRAMT2=$JUSTIFY(RMPRDISC*RMPRAMT/100,0,2)
SET RMPRAMTN=RMPRAMT-$JUSTIFY(RMPRAMT2,0,2)
SET RMPRAMTN=$JUSTIFY(RMPRAMTN+$PIECE(R664(0),U,10),0,2)
QUIT
+3 QUIT
ADD1 SET RMPRAMT1=$JUSTIFY($PIECE(R664(1,RC,0),U,4)*$PIECE(R664(1,RC,0),U,3),0,2)
SET RMPRAMT=RMPRAMT+RMPRAMT1
QUIT
CON ;CONTINUATION OF 2421
+1 WRITE !,RMPRB,!,"16. Contract Number: "
SET RO("C")=$ORDER(R664(1,0))
if RO("C")
WRITE $PIECE(R664(1,RO("C"),0),U,14)
WRITE ?61,"Subtotal: ",$JUSTIFY($FNUMBER(RMPRAMT,"P",2),8)
+2 WRITE !," ACCT.#: ",RMPRVACN
KILL RMPRVACN
+3 WRITE ?28,"Discount $"
IF $DATA(RMPRAMT2)
WRITE $JUSTIFY($FNUMBER(RMPRAMT2,"P",2),7)
+4 WRITE ?45,"Shipping: ",$JUSTIFY($FNUMBER($PIECE(R664(0),U,10),"P",2),5)
+5 WRITE ?62,"Total",?69,"$",$JUSTIFY($FNUMBER(RMPRAMTN,"P",2),9)
+6 WRITE !,RMPRB,!,"17. Signature and Title of"
+7 WRITE ?28,"18. DATE",?39,"19. Signature and Title of",?70,"20. Date"
+8 WRITE !,?5,"Requesting Official",?39,"Contracting/Accountable Officer"
+9 WRITE !!,?5,RDUZ,?39,RMPR("SIG")
SET Y=$PIECE($GET(R664(4)),U,5)
IF Y'=""
DO DD^%DT
WRITE ?68,Y
+10 WRITE !,RMPRB,!?25,"Order and Receipt Action",!,RMPRB
+11 WRITE !,"21. Order Number",?18,"22. Date of Order",?37,"23. Date Item Received",?62,"24. Date Delivered"
+12 WRITE !,?3,RTN,?22,RMPRODTE
+13 WRITE !,RMPRB
+14 WRITE !,"25. The articles or services listed herein have been received, or rendered",!,"ordered in the quantity and quality specified orginally or as shown by"
+15 WRITE !,"authenticated changes, except as noted.",!!?40,"Signature of Veteran or VA Official",!,RMPRB,!?30,"VOUCHER AUDIT BLOCK (For use by VA Facility only)",!,RMPRB
+16 WRITE !,"Approved For",?25,"Date",?50,"Voucher Auditor",!!,$EXTRACT(RMPRB,1,50),!,"Acct. Symbol",?54,"ADP Form 10-2421 APR 1991"
SET RMPRMOR1=1
+17 QUIT
