source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO6.m@ 1150

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

initial load of WorldVistAEHR
File size: 4.2 KB
RevLine 
[613]1PRCHNPO6 ;WISC/RHD-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 442 ;6/22/94 3:19 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN1 ;INPUT TRANSFORM FOR FILE 442, P.O.DATE #.1
6 Q:'$D(^PRC(442,DA,0)) Q:'$P(^(0),U,3) S PRCHSAVX=X,PRC("FY")=X S:'$D(PRC("SITE")) PRC("SITE")=+^(0) S X=$P(^(0),U,3)
7 D EN1^PRCHNPO5 S:$D(X) $P(^PRC(442,DA,0),U,4)=PRC("APP")
8 S X=PRCHSAVX K PRCHSAVX
9 Q
10 ;
11EN2 ;SCREEN--P.O.#['X' (FRESH FOOD) OR 'Z' (CASCA)--INVOICE ADDRESS="FISCAL", P.O.#['C' (CERT.INV.)--MOP='CERT.INV.', INV.ADDR.="FISCAL", IMPREST FUNDS--INV.ADDR.="".
12 S Z1=$E($P(^PRC(442,DA,0),"-",2),1,2),PRCHN("INV")="FMS",Z2=+$P(^(0),U,2) I $D(^PRCD(442.5,Z2,0)) S PRCHN("MP")=$P(^(0),U,3) I PRCHN("MP")=12 S Z1="IF",PRCHN("INV")="" G EN20
13 I (Z1["X")!(Z1["Z") S PRCHN("INV")="FISCAL" K Z1,Z2 Q
14 I Z1'["C" K Z1,Z2 Q
15 S PRCHN("MP")=2,$P(^PRC(442,DA,0),U,2)=2,^PRC(442,"F",2,DA)="",Z2=2,PRCHN("INV")="FISCAL"
16EN20 W !,"Method of Processing="_$P(^PRCD(442.5,Z2,0),U,1) K Z1,Z2
17 Q
18 ;
19EN3 ;SCREEN FCP--CALLED FROM PRCHNPO3
20 G:'$D(PRCHPO) FALSE S Z0=$E($P(^PRC(442,PRCHPO,0),"-",2),1,2),Z1=+$P(^PRCS(410,Y,0),"-",4)
21 ;
22EN4 ;SCREEN FCP FOR SPECIAL P.O.NUMBERS--Z0=1ST 2 DIGITS OF P.O.NO.,Z1=FCP
23 G:(Z0["H")&('$D(^PRC(420,"AD",1,PRC("SITE"),Z1))) FALSE
24 I Z0["G",$D(^PRC(411,+PRC("SITE"),0)),$D(^PRC(411.2,+$P(^(0),U,7),0)),"^DEPOT^VACO^DDC^"[("^"_$P(^(0),U,1)_"^") G TRUE
25 G:(Z0["G")&('$D(^PRC(420,"AD",2,PRC("SITE"),Z1)))&('$D(^PRC(420,"AD",3,PRC("SITE"),Z1)))&('$D(^PRC(420,"AD",4,PRC("SITE"),Z1))) FALSE
26 G:(Z0["Z")&('$D(^PRC(420,"AD",3,PRC("SITE"),Z1)))&('$D(^PRC(420,"AD",4,PRC("SITE"),Z1))) FALSE
27 I $G(PRCHPC)!$G(PRCHDELV) I '$D(^PRC(420,"C",DUZ,PRC("SITE"),Z1)) G FALSE
28 ;
29TRUE I 1 Q
30 ;
31FALSE I 0
32 Q
33 ;
34EN5 ;FILE #442, FIELD #1 (FCP) ONLINE HELP
35 S Z1=Y D EN4 ;S FLAG=1
36 Q
37 ;
38EST ;Find Line Item # for Field #13.1
39 S N="" F PRCHESTA=1:1 S N=$O(^PRC(442,PRCHPO,2,"B",N)) Q:'N
40 S N=0 F PRCHDIS=1:1 S N=$O(^PRC(442,PRCHPO,3,N)) Q:'N
41 S PRCHDIS=PRCHDIS+PRCHESTA-1,$P(^PRC(442,PRCHPO,0),U,18)=PRCHDIS,$P(^(0),U,14)=PRCHDIS
42 K N,PRCHESTA,PRCHDIS
43 Q
44 ;
45EN7 ;FILE 442, PKG.MULT. #3.1
46 D VEN^PRCHNPO5 Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="")
47 S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) S PRCHCV=+$P(^PRC(442,DA(1),1),U,1),PRCHCI=+$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN7^PRCHCRD1
48 Q
49 ;
50EN8 ;FILE 442, P.O.NO. .01 CALLED BY THE SCREEN ON THE .01 FIELD
51 Q:'$D(X) Q:$D(PRCHNEW)&$D(^PRC(442,"B",X))
52 L +^PRC(442,0):5 I '$T W $C(7),"ANOTHER USER IS EDITING SOME FILE 442 ENTRY! Please retry in a minute." K X Q
53 S Z=$P(^PRC(442,0),"^",3)-1 S:Z<1 Z=100000000 F Z=Z-1:-1 I '$D(^PRC(442,Z)) L +^PRC(442,Z):0 Q:$T
54 L -^PRC(442,0) I Z'>0 K X L -^PRC(442,Z)
55 E S DINUM=Z
56 K Z
57 Q
58 ;
59EN9 ;FILE 442, MAX.ORD.QTY.#9.6
60 D VEN^PRCHNPO5 Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="")
61 S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) S PRCHCV=+$P(^PRC(442,DA(1),1),U,1),PRCHCI=+$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN9^PRCHCRD1
62 Q
63 ;
64 ; ER-ER3 ARE CALLED FROM PRCHNPO1
65ER W !," ** Error in Discount ",PRCH,", item ",PRCHN," has a unit cost of zero ",$C(7) S PRCHER=""
66 Q
67 ;
68ER1 W !," ** Error in Discount ",PRCH,", item ",PRCHN," has been changed. Discount will be deleted",!?4,"and must be re-edited!",$C(7) S PRCHER="",DR="14///^S X=PRCH",DR(2,442.03)=".01///@" D ^DIE K DR
69 Q
70 ;
71ER2 W !," Type Code is undefined.",$C(7) K PRCHPO
72 Q
73 ;
74ER3 W !,$S('PRCHDT:"Breakout Code is undefined.",1:"Socioeconomic Group (FY89) not defined in Vendor file."),$C(7) K PRCHPO
75 Q
76 ;
77SPRMK ;FORMAT & DISPLAY REMARKS FROM REQUEST TO PO
78 Q:'$D(^PRCS(410,PRCHSY,"RM")) K ^UTILITY($J,"W")
79 W !,"2237 Special Remarks: " S U="^",PRCHZZ=0,DIWL=1,DIWR=78,DIWF="W"
80 F PRCHJJ=0:0 S PRCHZZ=$O(^PRCS(410,PRCHSY,"RM",PRCHZZ)) Q:'PRCHZZ I $D(^(PRCHZZ,0)) S X=^(0) D DIWP^PRCUTL($G(DA)),^DIWW
81 ;
82SP1 K PRCHJJ W !,"Would you like to transfer the Special Remarks to the New P.O. Comments" S %=1 D YN^DICN
83 I %=0 W !,"Enter 'Y' to have the Special Remarks added to the end of the P.O. Comments.",! G SP1
84 G END:%'=1 S:'$D(^PRC(442,D0,4,0)) ^(0)="^^0^0^"_DT S PRCHNN=$P(^(0),U,3),PRCHX=0
85 F I=0:0 S PRCHX=$O(^PRCS(410,PRCHSY,"RM",PRCHX)) Q:'PRCHX I $D(^(PRCHX,0)) S PRCHNN=PRCHNN+1,^PRC(442,D0,4,PRCHNN,0)=^(0)
86 S ^PRC(442,D0,4,0)="^^"_PRCHNN_U_PRCHNN_U_DT
87 ;
88END K PRCHNN,PRCHX,PRCHZZ,DIWL,DIWR,DISF,I,%
89 Q
Note: See TracBrowser for help on using the repository browser.