source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHFPT0.m@ 1710

Last change on this file since 1710 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.0 KB
RevLine 
[613]1PRCHFPT0 ;WISC/RSD/RHD/BGJ-CONTINUATION--PRINT FREE FORM 2138 ;4/21/99 18:05
2V ;;5.1;IFCAP;**7**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5STP ;PRINT HEADER ON FIRST PAGE
6 S Y=$P(PRCH1,U,9) W:$Y>0 @IOF W !,?5,$S(Y="EM":"**EMERGENCY**",Y="SP":"*SPECIAL*",1:"") W:$D(PRCHREPR) ?20,"*REPRINT* "
7 S PRCHTYPE=$P($G(^PRC(442,D0,23)),U,11)
8 W ?28,$S("D"=PRCHTYPE:"DELIVERY ORDER",PRCHTYPE]"":"PURCHASE CARD ORDER",PRCHDES="US":" USING SERVICE COPY",$D(PRCHNRQ):"REQUISITION FOR SUPPLIES OR SERVICES",1:"PURCHASE ORDER FOR SUPPLIES OR SERVICES"),?70
9 I $P(PRCHST,U,15)="Y" S %H=$H D YX^%DTC W "("_Y_")"
10 W !?28,$E(PRCHULN,1,39),!,"ISSUING OFFICE:",?50,"REQUESTING SERVICE:",! S:'$D(PRC("SITE")) PRC("SITE")=+PRCH0 D FTYP^PRCHFPNT W "Dept. of Veterans Affairs "_$P(PRCHFTYP," ",2,99),?61
11 S Y=$G(^DIC(49,+$P(PRCH1,U,2),0)) W $P(Y,U,1) W:$P(Y,U,8)]"" "(",$P(Y,U,8),")" W !,$P(PRCHHSP,U,1)," ",$P(PRCHHSP,U,2)
12 W !,$P(PRCHHSP,U,3),", ",$P($G(^DIC(5,+$P(PRCHHSP,U,4),0)),U,2)," ",$P(PRCHHSP,U,5),?61,"DEL. TO: ",$P(PRCH1,U,11),!,PRCHULN
13 S PRCHV=$G(^PRC(440,+PRCH1,0),U_">> No info for vendor: "_PRCH1)
14 N T S T=$P(PRCHV,U,1) I T="SIMPLIFIED" N R S R=$P($G(^PRC(442,D0,24)),U,2) I R]"" S T=R
15 W !,"VENDOR:",?53,"|SHIP TO:",!,?9,T,?53,"|",?62,$P(PRCHSHP,U,1) W:'PRCHS " ",$P($P(PRCH0,U,1),"-",2)
16 S S=1 S:'PRCHS S(S)=PRCHFTYP,S=S+1
17 I S V=1
18 E D
19 . S V(1)=$P(PRCHV,U,2),V=2
20 . I $P(PRCHV,U,3)]"" S V(V)=$P(PRCHV,U,3),V=V+1 S:$P(PRCHV,U,4)]"" V(V)=$P(PRCHV,U,4),V=V+1 S:$P(PRCHV,U,5)]"" V(V)=$P(PRCHV,U,5),V=V+1
21 . S V(V)=$S($P(PRCHV,U,6)]"":($P(PRCHV,U,6)_" "),1:"")_$P($G(^DIC(5,+$P(PRCHV,U,7),0)),U,2)_" "_$P(PRCHV,U,8),V=$S(V<5:3,1:2)+V
22 I $D(^PRC(440,+PRCH1,2)) S:$P(^(2),U,1)]"" V(V)="ACCT # "_$P(^(2),U,1),V=V+1 S V(V)=""
23 S:$P(PRCHV,U,10)]"" V(V)=$P(PRCHV,U,10) S PRCVFAX=$P($G(^PRC(440,+PRCH1,10)),U,6) S:PRCVFAX'="" V(V)=$G(V(V))_" FAX: "_PRCVFAX K PRCVFAX
24 I V<9 S V=V+1,V(V)=""
25 I $P(PRCHST,U,19)="Y",$D(^PRC(440,+PRCH1,3)),$P(^(3),U,4)'="" S V(V)=V(V)_"FMS Vendor Code: "_$P(^(3),U,4)_$P(^(3),U,5)
26 I $P(PRCH1,U,4)="Y" S V(10)=" VERBAL PURCHASE ORDER" S:$P(PRCH1,U,5)="Y" V(10)=" CONFIRMATION COPY, PLEASE DO NOT DUPLICATE"
27 S PRCHEDI=$G(^PRC(440,+PRCH1,3)) I PRCHEDI]"",$P(PRCHEDI,U,2)="Y",$P($G(^PRC(442,D0,12)),U,16)'="n" D S V(10)=PRCHEDIT_" DO NOT MAIL"
28 .S PRCHEDIT="",PRCHEDIT=$P($G(^PRC(442,D0,12)),U,14)
29 .S PRCHEDIT=$S(PRCHEDIT'="":"*EDI EMERGENCY ORDER-"_$P($G(^PRC(443.4,PRCHEDIT,0)),U)_"*",1:"*EDI ORDER*") Q
30 K PRCHEDI,PRCHEDIT
31 S:$P(PRCHSHP,U,2)]"" S(S)=$P(PRCHSHP,U,2),S=S+1 S:$P(PRCHSHP,U,3)]"" S(S)=$P(PRCHSHP,U,3),S=S+1 S:$P(PRCHSHP,U,4)]"" S(S)=$P(PRCHSHP,U,4),S=S+1
32 S S(S)=$S($P(PRCHSHP,U,5)]"":($P(PRCHSHP,U,5)_", "),1:" ")_$P($G(^DIC(5,+$P(PRCHSHP,U,6),0)),U,2)_" "_$P(PRCHSHP,U,7),S=S+2
33 I $P(PRCHSHP,U,8)]"",'PRCHS S S(S)="DELIVERY HOURS:",S=S+1,S(S)=$P(PRCHSHP,U,8)
34 F I=1:1:9 W ! W:$D(V(I)) ?9,V(I) W ?53,"|" W:$D(S(I)) ?62,S(I)
35 W ! W:$D(V(10)) ?5,V(10) W ?53,"|" W:$D(S(10)) ?62,S(10)
36 F I=1:1:96 W @IOBS
37 W $E(PRCHULN,1,53),"|",$E(PRCHULN,1,42)
38 G ^PRCHFPT1
Note: See TracBrowser for help on using the repository browser.