source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHFPT3.m@ 634

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

initial load of WorldVistAEHR
File size: 5.5 KB
Line 
1PRCHFPT3 ;WISC/RSD/RHD-CONT. OF PRINT ;7/21/99 13:19
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5ITEM S DIWL=1,DIWR=33,DIWF="",PRCHD=0 K ^UTILITY($J,"W")
6 F PRCHJJ=0:0 S PRCHD=$O(^PRC(442,D0,2,PRCH,1,PRCHD)) Q:PRCHD="" S X=$G(^(PRCHD,0)) D DIWP^PRCUTL($G(DA))
7 K ^TMP($J,"W") S %X="^UTILITY($J,""W"",1,",%Y="^TMP($J,""W"",1," D %XY^%RCR
8 K PRCHJJ S PRCHCNT=$G(^UTILITY($J,"W",1)),PRCHL=PRCHL+PRCHCNT+1 W !?2,$J(+$P(PRCHI0,U,1),3),?7,$G(^(1,1,0))
9 I PRCHTYPE'="S" W ?42,$J($P(PRCHI0,U,2),7),?52,$P($G(^PRCD(420.5,+$P(PRCHI0,U,3),0)),U,1) D
10 . S X=$P($P(PRCHI0,U,9),".",2) W ?55,$S($L(X)>3:$J($P(PRCHI0,U,9),8,4),$L(X)>2:$J($P(PRCHI0,U,9),8,3),$P(PRCHI0,U,9)="N/C":" N/C",1:$J($P(PRCHI0,U,9),8,2))
11 D AMT
12 I PRCHCNT>1 F K=2:1:$P(^TMP($J,"P",P,PRCH),U,2) W:$D(^TMP($J,"W",1,K,0)) !?8,^(0)
13 W ! S PRCHL=PRCHL+1 I $P(PRCHI0,U,6)]"" W ?8,"STK#: ",$P(PRCHI0,U,6),! S PRCHL=PRCHL+1
14 I $P(PRCHI0,U,13)]"" W ?8,"NSN: ",$P(PRCHI0,U,13) D:$D(PRCHNRQ) PSNO^PRCHFPNT W ! S PRCHL=PRCHL+1
15 I $P($G(^PRC(442,D0,2,PRCH,4)),U,12)]"" W ?8,"FOOD GROUP: ",$P(^(4),U,12),! S PRCHL=PRCHL+1
16 D EDISTAT^PRCHUTL(D0,PRCH,.PRCHL)
17 I PRCHDES="R",$P(PRCHI0,U,5)]"" W ?8,"IMF#: ",$P(PRCHI0,U,5)_" "
18 I $P(PRCHI0,U,12),PRCHTYPE'="S" W:$P(PRCHI0,U,5)']""!($P(PRCHI0,U,5)]""&(PRCHDES'="R")) ?8 W "Items per ",$P($G(^PRCD(420.5,+$P(PRCHI0,U,3),0)),U,1),": ",$P(PRCHI0,U,12),! S PRCHL=PRCHL+1
19 W ?8,"BOC: ",$P($P(PRCHI0,U,4)," ",1) S FMSLN=$O(^PRC(442,D0,22,"B",+$P(PRCHI0,U,4),0)) S PRCHL=PRCHL+1
20 I FMSLN>0,PRCHTYPE'="S" S FMSLN="00"_$P($G(^PRC(442,D0,22,FMSLN,0)),U,3),FMSLN=$E(FMSLN,$L(FMSLN)-2,99) W ?22,"FMS LINE: ",FMSLN
21 W:$P(PRCHI2,U,2)]"" ?40,"CONTRACT: ",$P(PRCHI2,U,2)
22 W ! S PRCHL=PRCHL+1
23 Q
24 ;
25AMT W ?66,$J($P(PRCHI2,U,1),8,2) S PRCHC=0,PRCHPT=PRCHPT+$P(PRCHI2,U,1),X=$O(^PRC(442,D0,2,PRCH,3,"AC",PRCHFPT,0))
26 I PRCHDES="R",X,$D(^PRC(442,D0,2,PRCH,3,X,0)) W ?76,$J($P(^(0),U,2),7),?86,$J($P(^(0),U,3),8,2)
27 Q
28 ;
29AUTH W !,"AUTHORITY FOR PURCHASE",?28,$S($D(PRCHNRQ):"REQ.",1:"P.O.")_" NO.",?42,$S($D(PRCHNRQ):"REQ.",1:"PO ")_"DATE" S Y=$P($G(^PRC(442,D0,7)),U,3) W:Y="Y" ?54,"EST." W ?59,"TOTAL: ",?66,$J($P(PRCH0,U,15),8,2)
30 I PRCHDES="R",PRCHDA W ?76,"DSCNT AMT: ",$J(PRCHDA,8,2) S PRCHDTA=PRCHDTA-PRCHDA
31 W !?2 S Y=0 F I=1:1 S Y=$O(^PRC(442,D0,14,Y)) Q:'Y W:I>1 "," W $P($G(^PRC(442.4,+^(Y,0),0)),U,2)
32 I $D(PRCHNRQ) W ?8,"P.O.# "_$P(PRCH0,U,1),?28 W:$D(^PRC(442,D0,18)) $P(^(18),U,10)
33 W:'$D(PRCHNRQ) ?28,$P(PRCH0,U,1) W ?42 S Y=$P(PRCH1,U,15) D DT
34 W:PRCHDES="R"&PRCHDTA ?76,"TOTAL AMT:",$J(PRCHDTA,10,2)
35 D FAXEMAIL(+$P($G(PRCH1),U,10),.PRCFAX,.PRCEMAIL)
36 W !,$S(PRCHTYPE'="":"AUTHORIZED BUYER",1:"CONTRACTING OFFICER"),?35,"DATE SIGNED",?52,"PHONE" W:PRCFAX'="" ?70,"FAX"
37 I PRCHDES="R",$D(^PRC(442,D0,11,PRCHFPT,0)) S X=$P(^(0),U,3)+$P(^(0),U,5) W:PRCHDTA-X ?76,"TERM DSCNT: ",$J(PRCHDTA-X,8,2) S PRCHDA=X
38 S P=+$P(PRCH1,U,10),Y=$P($G(^PRC(442,D0,12)),U,3) W !,"/ES/"_$$DECODE^PRCHES5(D0)
39 W ?35 D DT,DT1 W:$D(^VA(200,P,.13)) ?52,$P(^(.13),U,5),?70,PRCFAX
40 I (PRCEMAIL'="")!(PRCHDES="R"&(PRCHDTA-PRCHDA)) D
41 . W ! W:PRCEMAIL'="" "E-MAIL: ",PRCEMAIL
42 . W:PRCHDES="R"&(PRCHDTA-PRCHDA) ?76,"NET AMT: ",$J(PRCHDA,10,2)
43 K PRCFAX,PRCEMAIL W !,PRCHULN
44 ;
45APP W !,?7,"FUND CERTIFICATION: The supplies/services listed on this request are properly",!?5,"chargeable to the following allotments, the available balances of which are"
46 W !?5,"sufficient to cover the cost thereof, and funds have been obligated."
47 W !,"APPROPRIATION: ",$P(PRCH0,U,4),"-",$P($P(PRCH0,U,3)," ",1),?40,"OBLIGATED BY: " S (X,Y)="",P=0 I $D(^PRC(442,D0,10,1,0)) S Y=$P(^(0),U,6),P=+$P(^(0),U,2),X=$P(^(0),U,5)
48 I X]"" W "/ES/"_$$DECODE^PRCHES4(D0,1),?75,"DATE: " D:Y]"" DT
49 I X="",$D(^VA(200,+P,0)) S X=$P(^(0),"^",1) W $P(X,",",2)," ",$P(X,",",1),?75,"DATE: " D:Y]"" DT
50 K BOC S CHGSHP=$P($G(^PRC(442,D0,0)),U,13),BOC=0,CNT=1,BOCCT=$G(^PRC(442,D0,22,0)),BOCCT=$P(BOCCT,U,4) S:CHGSHP'>0 BOCCT=BOCCT-1 I BOCCT'>0 G APP1
51 F Q:CNT>2 S BOC=$O(^PRC(442,D0,22,BOC)) Q:BOC'>0 S BOC22=$G(^(BOC,0)) I $P(BOC22,U,3)'=991 S BOC(CNT)=BOC22,CNT=CNT+1
52 S PZZBOC=BOC_"^"_CNT
53APP1 W !,"COST CENTER: ",$P(PRCH0,U,5)
54 I $D(BOC(1)) W ?41,"BOC1:",?48,$P(BOC(1),U),?56,"AMOUNT1:",?66,$J($P(BOC(1),U,2),12,2),?80 S FMSLN="00"_$P(BOC(1),U,3),FMSLN=$E(FMSLN,$L(FMSLN)-2,99) W "FMS LINE: ",FMSLN
55 S Y=$G(^PRCD(420.8,+$P(PRCH1,U,7),0))
56 W !,"SOURCE CODE: " S X=$P(Y,U,1) W "SUPPLY-"_$S(X="B":"COMB.2,4,6",1:X_" ") S X=$P(Y,U,3) W " FISCAL-" W:X X
57 I $D(BOC(2)) W ?41,"BOC2:",?48,$P(BOC(2),U),?56,"AMOUNT2:",?66,$J($P(BOC(2),U,2),12,2),?80 S FMSLN="00"_$P(BOC(2),U,3),FMSLN=$E(FMSLN,$L(FMSLN)-2,99) W "FMS LINE: ",FMSLN
58 I CHGSHP>0&('$D(BOC(2))) W ?41,"BOC2:",?48,+$P($G(^PRC(442,D0,23)),U),?56,"AMOUNT2:",?66,$J(CHGSHP,12,2),?80,"FMS LINE: 991" S PRCHL=PRCHL+1
59 D SETUP^PRCHFPT4
60 W !,"FCP/PRJ: ",PRCHPRJ,?41,$S(P>1&(BOCCT>2):"**ADDITIONAL BOCs WILL BE FOUND AFTER ALL THE ITEMS.**",BOCCT>2:"**ADDITIONAL BOCs WILL BE FOUND ON THE NEXT PAGE.**",1:"")
61 K PRCHZ0,PRCHZ1,PRCHSTN,PRCHFCP,PRC("BBFY"),PODATE,MO,PRCHB,PRCHPRJ
62 W !
63 Q
64 ;
65DT W:Y Y\100#100,"/",Y#100\1,"/",Y\10000+1700
66 Q
67 ;
68DT1 Q:'Y S Y=$P(Y,".",2),Y=Y_$E("0000",1,(4-$L(Y))) Q:'Y W "@",$E(Y,1,2),":",$E(Y,3,4)
69 Q
70 ;1st argument is passed internal entry number of person
71 ;2nd argument is returned Fax Number
72 ;3rd argument is returned e-mail address
73FAXEMAIL(PRCA,PRCB,PRCC) ;
74 I PRCA'>0 S PRCB="",PRCC="" Q
75 I '$D(^VA(200,PRCA)) S PRCB="",PRCC="" Q
76 N PRCX,DIC,DR,DA,DIQ,D0 K ^UTILITY("DIQ1",$J)
77 S DIC=200,DR=".136;.151",DA=PRCA,DIQ="PRCX",DIQ(0)="I" D EN^DIQ1
78 S PRCB=PRCX(200,DA,.136,"I"),PRCC=PRCX(200,DA,.151,"I") K ^UTILITY("DIQ1",$J)
79 Q
Note: See TracBrowser for help on using the repository browser.