- RMPR4P22 ;PHX/HNC/RVD-CONT PURCHASE CARD ;3/1/1996
- ;;3.0;PROSTHETICS;**3,20,26,90,115,132**;Feb 09, 1996;Build 13
- S RO=0,J2=0 F I=1:1 S RO=$O(R664(1,RO)) Q:RO'>0 D Q:$D(J1)
- .I I>2 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="" S J2=J2+1 D Q:$D(J1)
- ..I J2+I>2 S J1=1 W !!,?9,"***SEE ATTACHED CONTINUATION SHEET FOR ITEM DESCRIPTION(S)***",! Q
- .Q:$D(J1)
- .S RMPRCNT=0
- .S RMPRSSM(1)=$P($G(R664(1,RO,0)),U,15)
- .S RMPRSSM(2)=$P($G(R664(1,RO,2)),U,1)
- .S RMPRSSM(3)=$P($G(R664(1,RO,2)),U,2)
- .S RMPRSSM(4)=$P($G(R664(1,RO,2)),U,3)
- .F II=1:1:4 S:RMPRSSM(II)'="" RMPRCNT=RMPRCNT+1
- .K II I J2+I+(RMPRCNT+1\2)>2 S J1=1 W !!,?9,"***SEE ATTACHED CONTINUATION SHEET FOR ITEM DESCRIPTION(S)***",!
- 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>56) CONT D:'$D(RMPRMOR) ADD D START
- I '$D(RMPRMOR)&($Y<37) F W ! Q:$Y>36
- Q
- START W !,"#"_RO_"."
- S RMPRI=$S($P(R664(1,RO,0),U,7)'="":$P(R664(1,RO,0),U,7),1:$P(R664(1,RO,0),U,3))
- 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(RMPRI,"P",2),6)
- ZWE S RMPRTOT=RMPRI*$P(R664(1,RO,0),U,4) W ?72,$J($FN(RMPRTOT,"P",2),8) D EXT
- Q
- EXT ;CHECKING FOR EXTENDED DESCRIPTION
- ;serial number
- N RMPRCNT,RMPRSSM,LNCT
- S RMPRCNT=0,LNCT=0
- S RMPRSSM(1)=$P($G(R664(1,RO,0)),U,15)
- S RMPRSSM(2)=$P($G(R664(1,RO,2)),U,1)
- S RMPRSSM(3)=$P($G(R664(1,RO,2)),U,2)
- S RMPRSSM(4)=$P($G(R664(1,RO,2)),U,3)
- I RMPRSSM(1)'="" D
- .I LNCT#2=0 D:$D(RMPRMOR)&($Y>56) CONT W !
- .W " Serial Number: "_RMPRSSM(1) S LNCT=LNCT+1
- I RMPRSSM(4)'="" D
- .I LNCT#2=0 D:$D(RMPRMOR)&($Y>56) CONT W !
- .W " Lot #: "_RMPRSSM(4) S LNCT=LNCT+1
- I RMPRSSM(3)'="" D
- .I LNCT#2=0 D:$D(RMPRMOR)&($Y>56) CONT W !
- .W " Model: "_RMPRSSM(3) S LNCT=LNCT+1
- I RMPRSSM(2)'="" D
- .I LNCT#2=0 D:$D(RMPRMOR)&($Y>56) CONT W !
- .W " Make: "_RMPRSSM(2)
- K RMPRSSM,RMPRCNT,LNCT
- ;
- S RMPRCH=$G(R664(1,RO,1,0))
- I RMPRCH="" Q
- ;S (RMPR90,RMPRX)=$Q(R664(1,RO,0,0))
- ;S RMPRX=$E(RMPRX,1,10)
- ;Q:RMPR90=""
- S RMPR90=0
- F S RMPR90=$O(R664(1,RO,1,RMPR90)) Q:RMPR90="" D
- .D:$D(RMPRMOR)&($Y>56) CONT
- .D:'$D(RMPRMOR)&($Y>36) CONT
- .W !,R664(1,RO,1,RMPR90,0)
- ;F S RMPR90=$Q(@RMPR90) Q:RMPRX'=$E(RMPR90,1,10) D:$D(RMPRMOR)&($Y>57) CONT D:'$D(RMPRMOR)&($Y>36) CONT
- ;D WRI
- Q
- WRI ;CONTINUATION OF 10-2421
- W !,@RMPR90
- Q
- CONT D:'$D(RMPRMOR) CON
- I $G(RMPRMOR)=1 W !!,?9,"***CONTINUATION OF PURCHASE CARD ITEMS ON NEXT PAGE***"
- W @IOF,!,"CONTINUATION OF PURCHASE CARD ",?27,"ORDER NUMBER: ",$P($G(^RMPR(664,RMPRA,4)),U,5),?71,"PAGE ",RMPRPAGE S RMPRMOR=1,RMPRPAGE=RMPRPAGE+1 D HDR^RMPR4P21
- Q
- ADD S (RMPRAMT2,RMPRAMT,RMPRAMT1,RMPRAMTN)=0
- S RMSHI=$S($P(R664(0),U,11)'="":$P(R664(0),U,11),1:$P(R664(0),U,10))
- S RC=0 F S RC=$O(R664(1,RC)) Q:RC=""!(RC["B") S RMPRI=$S($P(R664(1,RC,0),U,7)'="":$P(R664(1,RC,0),U,7),1:$P(R664(1,RC,0),U,3)) 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+RMSHI,0,2) Q
- Q
- ADD1 S RMPRAMT1=$J($P(R664(1,RC,0),U,4)*RMPRI,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(RMSHI,"P",2),5)
- W ?62,"Total",?69,"$",$J($FN(RMPRAMTN,"P",2),9)
- W !,RMPRB,!,"17. Signature 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")
- W !,RMPRB,!?25,"Order and Receipt Action",!,RMPRB
- W !,"21. Order Number",?18,"22. Exp Date",?37,"23. Date Item Received",?62,"24. Date Delivered"
- I DUZ=$P(^RMPR(664,RMPRA,0),U,9)!($D(^XUSEC("RMPR FCP MANAGER",DUZ))) D
- .;W !,"************"
- .N RMPRPRCD
- .S RMPRPRCD=$$DEC^RMPR4LI($P(^RMPR(664,RMPRA,4),U,1),$P(^RMPR(664,RMPRA,0),U,9),RMPRA)
- .;W $E(RMPRPRCD,13,16)
- .W !,RMPRPRCD
- E W !,?3,"encrypted"
- ;W !,?3,$$DEC^RMPR4LI($P(^RMPR(664,RMPRA,4),U,1),DUZ,RMPRA)
- ;DATE REMOVED
- W !,RMPRB
- W !,"25. The articles or services listed herein have been received, or rendered",!,"ordered in the quantity and quality specified originally or as shown by"
- W !,"authenticated changes, except as noted.",!!?40,"Signature of Veteran or VA Official",!,RMPRB
- ;W !?30,"VOUCHER AUDIT BLOCK (For use by VA Facility only)",!,RMPRB
- ;W !,"Bank Authorization Number: ",$P(^RMPR(664,RMPRA,4),U,2)
- W !,?$X+6,"Acct. Symbol ",$$STA^RMPRUTIL,"-"_$P($G(^RMPR(664,RMPRA,4)),U,5)
- W !,RMPRB,!,?52,"ADP Form 10-2421PC APR 1991" S RMPRMOR1=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR4P22 4964 printed Jan 18, 2025@03:34:03 Page 2
- RMPR4P22 ;PHX/HNC/RVD-CONT PURCHASE CARD ;3/1/1996
- +1 ;;3.0;PROSTHETICS;**3,20,26,90,115,132**;Feb 09, 1996;Build 13
- +2 SET RO=0
- SET J2=0
- FOR I=1:1
- SET RO=$ORDER(R664(1,RO))
- if RO'>0
- QUIT
- Begin DoDot:1
- +3 IF I>2
- 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
- SET J2=J2+1
- Begin DoDot:2
- +5 IF J2+I>2
- SET J1=1
- WRITE !!,?9,"***SEE ATTACHED CONTINUATION SHEET FOR ITEM DESCRIPTION(S)***",!
- QUIT
- End DoDot:2
- if $DATA(J1)
- QUIT
- +6 if $DATA(J1)
- QUIT
- +7 SET RMPRCNT=0
- +8 SET RMPRSSM(1)=$PIECE($GET(R664(1,RO,0)),U,15)
- +9 SET RMPRSSM(2)=$PIECE($GET(R664(1,RO,2)),U,1)
- +10 SET RMPRSSM(3)=$PIECE($GET(R664(1,RO,2)),U,2)
- +11 SET RMPRSSM(4)=$PIECE($GET(R664(1,RO,2)),U,3)
- +12 FOR II=1:1:4
- if RMPRSSM(II)'=""
- SET RMPRCNT=RMPRCNT+1
- +13 KILL II
- IF J2+I+(RMPRCNT+1\2)>2
- SET J1=1
- WRITE !!,?9,"***SEE ATTACHED CONTINUATION SHEET FOR ITEM DESCRIPTION(S)***",!
- End DoDot:1
- if $DATA(J1)
- QUIT
- +14 DO ADD
- +15 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>56)
- DO CONT
- if '$DATA(RMPRMOR)
- DO ADD
- DO START
- +16 IF '$DATA(RMPRMOR)&($Y<37)
- FOR
- WRITE !
- if $Y>36
- QUIT
- +17 QUIT
- START WRITE !,"#"_RO_"."
- +1 SET RMPRI=$SELECT($PIECE(R664(1,RO,0),U,7)'="":$PIECE(R664(1,RO,0),U,7),1:$PIECE(R664(1,RO,0),U,3))
- +2 WRITE ?4,$PIECE(R664(1,RO,0),U,2)
- +3 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(RMPRI,"P",2),6)
- ZWE SET RMPRTOT=RMPRI*$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 ;serial number
- +2 NEW RMPRCNT,RMPRSSM,LNCT
- +3 SET RMPRCNT=0
- SET LNCT=0
- +4 SET RMPRSSM(1)=$PIECE($GET(R664(1,RO,0)),U,15)
- +5 SET RMPRSSM(2)=$PIECE($GET(R664(1,RO,2)),U,1)
- +6 SET RMPRSSM(3)=$PIECE($GET(R664(1,RO,2)),U,2)
- +7 SET RMPRSSM(4)=$PIECE($GET(R664(1,RO,2)),U,3)
- +8 IF RMPRSSM(1)'=""
- Begin DoDot:1
- +9 IF LNCT#2=0
- if $DATA(RMPRMOR)&($Y>56)
- DO CONT
- WRITE !
- +10 WRITE " Serial Number: "_RMPRSSM(1)
- SET LNCT=LNCT+1
- End DoDot:1
- +11 IF RMPRSSM(4)'=""
- Begin DoDot:1
- +12 IF LNCT#2=0
- if $DATA(RMPRMOR)&($Y>56)
- DO CONT
- WRITE !
- +13 WRITE " Lot #: "_RMPRSSM(4)
- SET LNCT=LNCT+1
- End DoDot:1
- +14 IF RMPRSSM(3)'=""
- Begin DoDot:1
- +15 IF LNCT#2=0
- if $DATA(RMPRMOR)&($Y>56)
- DO CONT
- WRITE !
- +16 WRITE " Model: "_RMPRSSM(3)
- SET LNCT=LNCT+1
- End DoDot:1
- +17 IF RMPRSSM(2)'=""
- Begin DoDot:1
- +18 IF LNCT#2=0
- if $DATA(RMPRMOR)&($Y>56)
- DO CONT
- WRITE !
- +19 WRITE " Make: "_RMPRSSM(2)
- End DoDot:1
- +20 KILL RMPRSSM,RMPRCNT,LNCT
- +21 ;
- +22 SET RMPRCH=$GET(R664(1,RO,1,0))
- +23 IF RMPRCH=""
- QUIT
- +24 ;S (RMPR90,RMPRX)=$Q(R664(1,RO,0,0))
- +25 ;S RMPRX=$E(RMPRX,1,10)
- +26 ;Q:RMPR90=""
- +27 SET RMPR90=0
- +28 FOR
- SET RMPR90=$ORDER(R664(1,RO,1,RMPR90))
- if RMPR90=""
- QUIT
- Begin DoDot:1
- +29 if $DATA(RMPRMOR)&($Y>56)
- DO CONT
- +30 if '$DATA(RMPRMOR)&($Y>36)
- DO CONT
- +31 WRITE !,R664(1,RO,1,RMPR90,0)
- End DoDot:1
- +32 ;F S RMPR90=$Q(@RMPR90) Q:RMPRX'=$E(RMPR90,1,10) D:$D(RMPRMOR)&($Y>57) CONT D:'$D(RMPRMOR)&($Y>36) CONT
- +33 ;D WRI
- +34 QUIT
- WRI ;CONTINUATION OF 10-2421
- +1 WRITE !,@RMPR90
- +2 QUIT
- CONT if '$DATA(RMPRMOR)
- DO CON
- +1 IF $GET(RMPRMOR)=1
- WRITE !!,?9,"***CONTINUATION OF PURCHASE CARD ITEMS ON NEXT PAGE***"
- +2 WRITE @IOF,!,"CONTINUATION OF PURCHASE CARD ",?27,"ORDER NUMBER: ",$PIECE($GET(^RMPR(664,RMPRA,4)),U,5),?71,"PAGE ",RMPRPAGE
- SET RMPRMOR=1
- SET RMPRPAGE=RMPRPAGE+1
- DO HDR^RMPR4P21
- +3 QUIT
- ADD SET (RMPRAMT2,RMPRAMT,RMPRAMT1,RMPRAMTN)=0
- +1 SET RMSHI=$SELECT($PIECE(R664(0),U,11)'="":$PIECE(R664(0),U,11),1:$PIECE(R664(0),U,10))
- +2 SET RC=0
- FOR
- SET RC=$ORDER(R664(1,RC))
- if RC=""!(RC["B")
- QUIT
- SET RMPRI=$SELECT($PIECE(R664(1,RC,0),U,7)'="":$PIECE(R664(1,RC,0),U,7),1:$PIECE(R664(1,RC,0),U,3))
- DO ADD1
- +3 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+RMSHI,0,2)
- QUIT
- +4 QUIT
- ADD1 SET RMPRAMT1=$JUSTIFY($PIECE(R664(1,RC,0),U,4)*RMPRI,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(RMSHI,"P",2),5)
- +5 WRITE ?62,"Total",?69,"$",$JUSTIFY($FNUMBER(RMPRAMTN,"P",2),9)
- +6 WRITE !,RMPRB,!,"17. Signature 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")
- +10 WRITE !,RMPRB,!?25,"Order and Receipt Action",!,RMPRB
- +11 WRITE !,"21. Order Number",?18,"22. Exp Date",?37,"23. Date Item Received",?62,"24. Date Delivered"
- +12 IF DUZ=$PIECE(^RMPR(664,RMPRA,0),U,9)!($DATA(^XUSEC("RMPR FCP MANAGER",DUZ)))
- Begin DoDot:1
- +13 ;W !,"************"
- +14 NEW RMPRPRCD
- +15 SET RMPRPRCD=$$DEC^RMPR4LI($PIECE(^RMPR(664,RMPRA,4),U,1),$PIECE(^RMPR(664,RMPRA,0),U,9),RMPRA)
- +16 ;W $E(RMPRPRCD,13,16)
- +17 WRITE !,RMPRPRCD
- End DoDot:1
- +18 IF '$TEST
- WRITE !,?3,"encrypted"
- +19 ;W !,?3,$$DEC^RMPR4LI($P(^RMPR(664,RMPRA,4),U,1),DUZ,RMPRA)
- +20 ;DATE REMOVED
- +21 WRITE !,RMPRB
- +22 WRITE !,"25. The articles or services listed herein have been received, or rendered",!,"ordered in the quantity and quality specified originally or as shown by"
- +23 WRITE !,"authenticated changes, except as noted.",!!?40,"Signature of Veteran or VA Official",!,RMPRB
- +24 ;W !?30,"VOUCHER AUDIT BLOCK (For use by VA Facility only)",!,RMPRB
- +25 ;W !,"Bank Authorization Number: ",$P(^RMPR(664,RMPRA,4),U,2)
- +26 WRITE !,?$X+6,"Acct. Symbol ",$$STA^RMPRUTIL,"-"_$PIECE($GET(^RMPR(664,RMPRA,4)),U,5)
- +27 WRITE !,RMPRB,!,?52,"ADP Form 10-2421PC APR 1991"
- SET RMPRMOR1=1
- +28 QUIT