source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO9.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.8 KB
RevLine 
[613]1PRCHNPO9 ;WISC/SC/JDM-SPLITTED PRCHNPO ROUTINE, ENTER NEW P.O./REQ. ; [12/10/98 12:22pm]
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4EDITMSG ;messages-when editing P.O.
5 S PRCHEST=$P($G(^PRC(442,PRCHPO,0)),U,13),PRCHESTL=$P($G(^(0)),U,18)
6CKSHBOC I PRCHEST>0 S ESTBOC=+$P($G(^PRC(442,PRCHPO,23)),U) I ESTBOC=""!(ESTBOC'>0) W ?5,!!,"The Estimated Shipping Charges is missing BOC!",$C(7) S PRCHER="",ERROR1=1
7 S SHPGBOC=$G(^PRC(442,PRCHPO,23))
8 I PRCHEST<0 S SHBOC="",PRCHEST="",$P(^PRC(442,PRCHPO,0),U,13)=PRCHEST,$P(^PRC(442,PRCHPO,23),U)=SHBOC
9CKSRCCD I PRCHSC="",'$D(PRCHPC) W !!?5,"Source Code for "_$S($D(PRCHNRQ):"Requisition",1:"Purchase Order")_" is undefined !",$C(7) S ERROR1=1
10CKPRCHD S PRCHDT=$S($P($G(^PRC(442,PRCHPO,1)),U,15)<2881001:0,$P($G(^(1)),U,15)>2880930:1,1:"")
11 I PRCHDT="" W !,$S($D(PRCHNRQ):"Requisition",1:"Purchase Order")_" has no date. ",$C(7) S ERROR1=1
12CKSINFO I $P($G(^PRC(442,PRCHPO,1)),U,12),$P($G(^(0)),U,2)'=4,$P($G(^(0)),U,2)'=25,$P($G(^(1)),U,3)'="" W $C(7),!!,"P.O. contains both a 'Ship to Address' and a 'Direct Delivery Patient'.",!,"Shipping information is unclear!" S ERROR1=1
13 S PRCHNDX=+$P($G(^PRC(442,PRCHPO,0)),U,2),PRCHN("MP")="" G:PRCHNDX'>0 CKPMETH
14 S PRCHN("MP")=$P($G(^PRCD(442.5,PRCHNDX,0)),U,3)
15CKPMETH I 'PRCHN("MP") W !,$C(7),"Method of Processing is not entered!" S ERROR1=1
16CKFOBOR I $P($G(^PRC(442,PRCHPO,1)),U,6)="O"&(($P($G(^(0)),U,13)<0)!($P($G(^(0)),U,13)="")) W !,"F.O.B. Point with ORIGIN must have a Est. Shipping and/or Handling Charges" S ERROR1=1
17 Q
18CKLI ;Messages if req'd Packaging Multiple, UCF or Drug Type Code are null
19 S ERMS1=" ",IMF=$P(^PRC(442,PRCHPO,2,LI,0),U,5),IMFD=$P(^PRC(441,IMF,0),U,2),VND=$P(^PRC(442,PRCHPO,1),U,1)
20 S ERMS2="Line item "_$P(^PRC(442,PRCHPO,2,LI,0),U)_" is missing "
21 I PRCHMUL=""&(PRTY=1!(PRTY=25)!(PRTY=26)) K E S E(1)=ERMS2,E(1,"F")="!",E(2)="Packaging Multiple!",E(2,"F")="",E(3)=ERMS1,E(3,"F")="!" D EN^DDIOL(.E) S ERRFL=1
22 I PRCHUCF=""&(PRTY=1!(PRTY=25)!(PRTY=26)) K E S E(1)=ERMS2,E(1,"F")="!",E(2)="Unit Conversion Factor!",E(2,"F")="",E(3)=ERMS1,E(3,"F")="!" D EN^DDIOL(.E) S ERRFL=2
23 I PRCHDRTY=""&(PRCHFSCD="6505") K E S E(1)=ERMS2,E(1,"F")="!",E(2)="Drug Type Code!",E(2,"F")="" D EN^DDIOL(.E) S ERRFL=3
24 Q
25TSTREQ1 ;EP;Called from PO Input Templates to warn blank Packaging Multiple field will be required to complete transaction.
26 Q:$P($G(^PRC(442,PRCHPO,2,DA,0)),U,5)=""
27 S:'$D(^VA(200,DUZ,400)) SUPUSR=0
28 S:'$D(SUPUSR) SUPUSR=$P(^VA(200,DUZ,400),U,1)
29 S PRTY=$P($G(^PRC(442,PRCHPO,0)),U,2),LI=$P($G(^PRC(442,PRCHPO,2,0)),U,4),CUROPT=$P(XQY0,U,1),ERRFL=0
30 Q:(PRTY=25!(PRTY=26))&(SUPUSR'>2)
31 Q:PRTY'=1&(PRTY'=25)&(PRTY'=26)
32 I $P($G(^PRC(442,PRCHPO,2,DA,0)),U,12)']"" K W S W(1)="Pkg. Multiple is blank. It must be supplied to later complete this document!",W(1,"F")="!" D EN^DDIOL(.W)
33 Q
34TSTREQ2 ;EP;Called from PO Input Templates to warn blank Drug Type Code will be required to complete transaction.
35 Q:$P($G(^PRC(442,PRCHPO,2,DA,2)),U,3)'="6505"
36 I $P($G(^PRC(442,PRCHPO,2,DA,4)),U,11)']"" K W S W(1)="For FSC 6505, DRUG TYPE CODE must be supplied to later complete document",W(1,"F")="!" D EN^DDIOL(.W)
37 Q
38ERRCHKS ;EP;Called from routine PRCHNPO before allowing completion of transaction. Checks all line items for blank required fields (as appropriate) Pkg. Mult., UCF & Drug Type Code.
39 S ERRFL=0
40 S PRTY=$P(^PRC(442,PRCHPO,0),U,2),LI=0
41 K SUPUSR S:'$D(^VA(200,DUZ,400)) SUPUSR=0
42 S:'$D(SUPUSR) SUPUSR=$P(^VA(200,DUZ,400),U,1)
43 S CUROPT=$P(XQY0,U,1)
44 G:(PRTY=25!(PRTY=26))&(SUPUSR'>2) NOIMF
45 G:PRTY'=1&(PRTY'=25)&(PRTY'=26) NOIMF
46 F Q:$O(^PRC(442,PRCHPO,2,LI))'>0 S LI=$O(^PRC(442,PRCHPO,2,LI)) D
47 .Q:$P($G(^PRC(442,PRCHPO,2,LI,0)),U,5)=""
48 .S PRCHMUL=$P($G(^PRC(442,PRCHPO,2,LI,0)),U,12),PRCHUCF=$P(^PRC(442,PRCHPO,2,LI,0),U,17)
49 .S PRCHDRTY=$P($G(^PRC(442,PRCHPO,2,LI,4)),U,11),PRCHFSCD=$P(^PRC(442,PRCHPO,2,LI,2),U,3) D CKLI
50NOIMF Q
Note: See TracBrowser for help on using the repository browser.