source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHNPO.m@ 1500

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

initial load of WorldVistAEHR
File size: 8.2 KB
Line 
1PRCHNPO ;WISC/SC,ID/RSD/RHD/DGL/BGJ-ENTER NEW PURCHASE ORDER/REQUISITION ; 4/2/01 1:50pm
2V ;;5.1;IFCAP;**7,11,79,108**;Oct 20, 2000;Build 10
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 S NOTCOMPL=0 ;Initialize for Incomplete Template.
5 D SWITCH^PRCHUTL K ERRFLG ; SET LOG/ISMS SWITCH
6 K PRCSIP ; Initialize Inventory point variable
7 I $S('$G(PRCHPO):1,'$D(PRC("SITE")):1,1:0) G Q
8 S DIE="^PRC(442,",DR="["_$S($D(PRCHNRQ):"PRCHNREQ",1:"PRCH2138")_"]",DIC("DR")="[PRCHVENDOR]"
9 I $G(PRCPROST)=1 S DR="[PRCH PROSTHETIC]" D ^DIE QUIT
10 I $G(PRCHPC)=1 S DR="[PRCHSIMP]"
11 I $G(PRCHPC)=2 S DR="[PRCH DETAILED PURCHASE CARD]"
12 I $G(PRCHPC)=3 S DR="[PRCH PC DIRECT DELIVERY]"
13 I $G(PRCHDELV)=1,'$G(PRCHPHAM) S DR="[PRCH DELIVERY ORDER]"
14 I $G(PRCHPHAM)=1 S DR="[PRCH DIRECT DELIVERY ORDER]"
15 D ^DIE
16 ;
17 ; Check ERRFLG to see if the user entered an up-arrow to get out or
18 ; did not select a credit card name. The flag ERRFLG is set at the
19 ; input templates above.
20 I $G(ERRFLG)=42 G ERR
21 I $G(ERRFLG)=38 G ERR
22 I $G(ERRFLG)=1 G ERR
23 I $G(ERRFLG)=2 G ERR
24 I $G(ERRFLG)=3 G ERR
25 ;Look for incomplete Input-Template when PRCHPC is defined.
26 I $D(PRCHPC) D
27 . I $D(Y)'=0 S NOTCOMPL=1
28 I NOTCOMPL G INCMSG
29 I $G(PRCHPC)=1 Q:$D(Y) D Q:$D(Y)
30 . S:'$D(^PRC(442,PRCHPO,2,0)) $P(^PRC(442,PRCHPO,2,0),U,2)=$P(^DD(442,40,0),U,2)
31 . S DA(1)=PRCHPO,DIE="^PRC(442,"_DA(1)_",2,",DA=1
32 . S DR=".01///^S X=1;1;I '$D(^PRC(442,DA(1),2,DA,1)) W !,""Description is Required!!"" S Y=1;2///^S X=1;3///^S X=""EA"";5////^S X=PRCHTOT;3.1///^S X=1;9.7///^S X=1;9///^S X="""";8///^S X=9999;K PRCHBOCC;"
33 . S DR(1,442.01,1)="I PRCHN(""SFC"")=2 S PRCHBOCC=2696;I '$G(PRCHBOCC) S Y=""@87"";"
34 . S DR(1,442.01,2)="S PRCHBOCC=$P($G(^PRCD(420.2,PRCHBOCC,0)),U);3.5////^S X=PRCHBOCC;S Y=""@89"";@87;3.5//^S X=PRCHBOC1;@89;K PRCHBOCC"
35 . D ^DIE Q:$D(Y)
36 . S DIE="^PRC(442,",DA=PRCHPO,DR=20 D ^DIE
37PROS I $P($G(^PRC(442,PRCHPO,23)),U,11)]"" Q:$D(Y) D Q:$D(Y) Q:'$G(CDA)
38 . S PODIE=DIE,PODA=DA
39 . S CDA=$P($G(^PRC(442,PRCHPO,23)),U,23),PRC("CP")=$P($G(^PRC(442,PRCHPO,0)),U,3)
40 . I +$G(PRC("CP"))'=0 S DA=PRCHPO D START^PRCH410
41 . I '$G(PRCHPHAM),'$G(PRCPROST),+$G(PRC("CP"))'=0 S DIE="^PRCS(410,",DA=$P($G(^PRC(442,PRCHPO,23)),U,23),DR=16 D ^DIE
42 . S DIE=PODIE,DA=PODA
43 S VEN=+$G(^PRC(442,PRCHPO,1))
44 I '$P($G(^PRC(442,PRCHPO,23)),U,11),$P($G(PRCHNVF),U,3)!($G(^PRC(440.3,+$G(VEN),0))]"") D
45 . I $P($G(^PRC(411,PRC("SITE"),9)),U,3)="Y" D Q
46 . . S PRCHXXDA=DA
47 . . S PRCHXDIE=DIE
48 . . S DA=VEN
49 . . Q:$$NEW^PRCOVTST(VEN,PRC("SITE"),1)
50 . . I $P($G(PRCHNVF),U,3) D
51 . . . S %X="^PRC(440,DA,"
52 . . . S %Y="^PRC(440.3,DA,"
53 . . . D %XY^%RCR
54 . . . Q
55 . . S DIE="^PRC(440.3,",DR="47///^S X=1;48///^S X=VEN;49///^S X=PRC(""SITE"")"
56 . . D ^DIE
57 . . S DA=PRCHXXDA
58 . . S DIE=PRCHXDIE
59 . . K PRCHXXDA
60 . . K PRCHXDIE
61 . D NEW^PRCOVRQ(VEN,PRC("SITE"))
62 K VEN
63 L ^PRC(442,PRCHPO):0 G ERR:'$T S PRCHSTAT=$P($G(^PRC(442,PRCHPO,7)),U,2) S:$D(Y)&('$D(PRCHNRQ))&(PRCHSTAT'=22) PRCHER="" S (PRCH,PRCHEC,PRCHX)=0
64 S PRCHSC="" I $D(^PRC(442,PRCHPO,1)),$D(^PRCD(420.8,+$P(^(1),U,7),0)) S PRCHSC=$P(^(0),U,1) S $P(^PRC(442,PRCHPO,1),U,14)=$S(PRCHSC="B":"*",1:"")
65 ;K PRCHER F S PRCH=$O(^PRC(442,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D G ERR:$D(PRCHER)
66 K PRCHER F S PRCH=$O(^PRC(442,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D
67 .S $P(^PRC(442,PRCHPO,2,PRCH,2),U,6)=""
68 .S PRCHLN=$G(^PRC(442,PRCHPO,2,PRCH,0)) ;I PRCHLN="" D ERR2 Q
69 .S SUBACC=$P(PRCHLN,U,4) ;I SUBACC="" D ERR2 Q
70 .D ERR2
71 .Q
72 K ^PRC(442,PRCHPO,2,"B"),^("C"),^("AC"),^("AE"),^("AH")
73 N PRCHCNYS,PRCHCNNO S (PRCHCNYS,PRCHCNNO)=0 ;FLGS FOR CONTRACT # ON ITEM
74 S PRCH=0 F I=1:1 S PRCH=$O(^PRC(442,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D CHG I $D(^PRC(442,PRCHPO,2,PRCH,0)) D
75 .S PRCHAM=+$P(^PRC(442,PRCHPO,2,PRCH,2),U,1),PRCHCN=$P(^(2),U,2) D CN:PRCHCN]"",OM:PRCHCN=""
76 .I PRCHCN]"" S PRCHCNYS=1
77 .E S PRCHCNNO=1
78 .S $P(^PRC(442,PRCHPO,2,PRCH,2),U,5)=""
79 .Q
80 S PRCHLCNT=I-1,$P(^PRC(442,PRCHPO,0),U,14)=PRCHLCNT S:$D(^PRC(442,PRCHPO,2,0)) $P(^(0),U,3,4)="1^"_PRCHLCNT I 'PRCHLCNT S PRCHER="" W !,"There are no line items listed in the Purchase Order."
81 G ERRCHKS:'$D(^PRC(442,PRCHPO,1))!('$D(^(2)))
82 I $P(^PRC(442,PRCHPO,0),U,3)=""!($P(^(0),U,4))="" W !!?5,"Fund Control Point is undefined !",$C(7)
83 S PRCHV=$P(^PRC(442,PRCHPO,1),U,1) I PRCHV="" W !!?5,"Vendor is undefined !",$C(7) ;G ERR
84ERRCHKS S ERRFL=0 D ERRCHKS^PRCHNPO9 ;I ERRFL=0 K ERRFL G CONT
85 ;K ERRFL G ERR
86CONT ;
87 S ERROR1="" D ^PRCHNPO9
88 I ERROR1=1!(ERRFL>0)!($D(PRCHER)) G ERR
89 D BBFY^PRCHNPO8(PRCHPO) I PRC("BBFY")'>0 W !!?5,"BBFY can not be checked/updated.",$C(7) G ERR
90 S PRCH=0 F I=0:1 S PRCH=$O(PRCH("AM",PRCH)) Q:PRCH="" S PRCH("COUNT",+PRCH("AM",PRCH),PRCH)=""
91 I PRCHCNNO,PRCHCNYS D ASTR ; <<< only call on ASTR
92 G:I=1 ^PRCHNRQ:$D(PRCHNRQ),^PRCHNPO1 S J=1 F PRCHJ=0:0 S PRCH=$O(PRCH("COUNT",PRCH)) Q:PRCH="" D MISS
93 G ^PRCHNRQ:$D(PRCHNRQ),^PRCHNPO1
94 ;
95LI S PRCHL0=$P(PRCH("AM",PRCHL3),U,3) Q:PRCHL0="" F J=1:1 S PRCHL1=$E(PRCHL0,$L(PRCHL0)-J) Q:PRCHL1'=+PRCHL1
96 S PRCHL2=$E(PRCHL0,$L(PRCHL0)-J+1,$L(PRCHL0)-1),PRCHL2=PRCHL2+1 I PRCHL2'=PRCHLI S PRCHLI=PRCHL0_PRCHLI Q
97 I PRCHL1=":" S PRCHLI=$E(PRCHL0,1,$L(PRCHL0)-J)_PRCHLI Q
98 S PRCHLI=$E(PRCHL0,1,$L(PRCHL0)-1)_":1:"_PRCHLI
99 Q
100 ;
101CHG I '$P(^PRC(442,PRCHPO,2,PRCH,0),"^",5),'$O(^(1,0)) S $P(^PRC(442,PRCHPO,2,PRCH,2),U,4,6)="^^" W !,"Line item ",+^PRC(442,PRCHPO,2,PRCH,0)," is missing its description!" S PRCHER=""
102 S $P(^PRC(442,PRCHPO,2,PRCH,0),U,1)=I,X=$P(^(0),U,5),X1=$P(^(0),U,4)
103 S ^PRC(442,PRCHPO,2,"B",I,PRCH)="",^PRC(442,PRCHPO,2,"C",I,PRCH)="",^PRC(442,PRCHPO,2,"AH",+X1,I,PRCH)="",PRCHLI=I,PRCHX=PRCH S:X]"" ^PRC(442,PRCHPO,2,"AE",X,PRCH)=""
104 Q
105 ;
106ERR2 I $S('$D(^PRC(442,PRCHPO,2,PRCH,2)):1,$P(^(2),U,1)="":1,1:0) S $P(^(2),U,1)="",$P(^(2),U,4,7)="" W !,"Line item ",+^(0)," is incomplete !",$C(7) S PRCHER=""
107 I '$G(PRCHPC),$D(PRCHNRQ),PRCHSC'=9,$P(^PRC(442,PRCHPO,2,PRCH,0),U,13)="" W !,"Line item ",+^(0)," is missing NSN !",$C(7) S PRCHER=""
108 I $P(^PRC(442,PRCHPO,2,PRCH,0),U,4)="" W !,"Line item ",+^(0)," is missing BOC !",!,$C(7) S PRCHER=""
109 Q
110 ;
111CN S:'$D(PRCH("AM",PRCHCN)) PRCH("AM",PRCHCN)="",PRCHEC=PRCHEC+1 S PRCHL3=PRCHCN
112 D LI S PRCH("AM",PRCHCN)=($P(PRCH("AM",PRCHCN),U,1)+1)_U_($P(PRCH("AM",PRCHCN),U,2)+PRCHAM)_U_PRCHLI_",",^PRC(442,PRCHPO,2,"AC",$E(PRCHCN,1,30),PRCH)=""
113 Q
114 ;
115OM S:'$D(PRCH("AM",".OM")) PRCH("AM",".OM")="",PRCHEC=PRCHEC+1 S PRCHL3=".OM" D LI S PRCH("AM",".OM")=($P(PRCH("AM",".OM"),U,1)+1)_U_($P(PRCH("AM",".OM"),U,2)+PRCHAM)_U_PRCHLI_","
116 Q
117 ;
118MISS S PRCHN=0 F K=1:1 S PRCHN=$O(PRCH("COUNT",PRCH,PRCHN)) Q:PRCHN=""!(J>(I-1)) S J=J+1,L=0,Y=$P(PRCH("AM",PRCHN),U,3),Y="F PRCHLI="_$E(Y,1,$L(Y)-1)_" S L=L+1 G ERR2:PRCHX<0" X Y
119 Q
120 ;
121ASTR ;IF SOME ITEMS HAVE CN, SOME DO NOT, PLACE '*' ON DISPLAY OF PO
122 N CN,ITM,DESC,ROOT
123 S ROOT="^PRC(442,PRCHPO)"
124 S CN=0 F M=1:1 S CN=$O(@ROOT@(2,"AC",CN)) Q:CN="" S:$D(^(CN)) ITM=$O(^(CN,0)) S ^PRC(442,PRCHPO,2,"AC",CN,ITM)="*"
125 S:PRCHSC="B" $P(^PRC(442,PRCHPO,1),U,14)="*"
126 S DESC=0 F I=1:1 S DESC=$O(@ROOT@(2,DESC)) Q:DESC=""!(DESC'>0) I $P(@ROOT@(2,DESC,2),U,2)']"" S $P(^PRC(442,PRCHPO,2,DESC,2),U,5)="*"
127 ;S PRCHX=$O(^PRC(442,PRCHPO,2,"B",PRCHLI,0)) Q:PRCHX=""!('$D(^PRC(442,PRCHPO,2,PRCHX,2))) S $P(^(2),U,5)=PRCHN("*") S:PRCHN'=".OM" ^PRC(442,PRCHPO,2,"AC",PRCHN,PRCHLI)=PRCHN("*")
128 ;I PRCHSC="B",PRCHN=".OM",$D(^PRC(442,PRCHPO,1)),L=1 S ^(1)=$P(^(1),U,1,13)_U_PRCHN("*")_U_$P(^(1),U,15,99)
129 Q
130 ;
131ERR ;
132 W !!?5,$S($D(PRCHNRQ):"Requisition",1:"Purchase Order")_" is incomplete and must be re-edited !",$C(7)
133INCMSG ;
134 I '$D(NOTCOMPL) D
135 . S NOTCOMPL=0
136 I NOTCOMPL D
137 . W !!,?5,"Incomplete transaction. It must be re-edited !",$C(7)
138Q K ERRDEL,ERRPC,ERRPO,DR,NOTCOMPL,DRTY,IMF,IMFD,LI,MUL,MULMSG,PRCHDRTY,PRCHFSCD,PRCHLCNT,PRCHMUL,PRCHM10,PRCHMS10,PRCHMS11,PRCHUCF,PRTY,SUPUSR,UCF,UCFMSG,UFL,VND
139 G Q^PRCHNPO4
140 ;
141MSG ;Call by the "ENTRY ACTION" for Simplified PC (PRC*5.1*79)
142 NEW MSG
143 S MSG(1)="*********************************************"
144 S MSG(1,"F")="!!?15"
145 S MSG(2)="* IF THE ORDER IS MORE THAN $3000.00 *"
146 S MSG(2,"F")="!?15"
147 S MSG(3)="* OR IS ON A CONTRACT, YOU CANNOT USE *"
148 S MSG(3,"F")="!?15"
149 S MSG(4)="* SIMPLIFIED PURCHASE CARD. *"
150 S MSG(4,"F")="!?15"
151 S MSG(5)="* YOU MUST USE DETAILED PURCHASE CARD!! *"
152 S MSG(5,"F")="!?15"
153 S MSG(6)="*********************************************"
154 S MSG(6,"F")="!?15"
155 S MSG(7,"F")="!"
156 ;
157 D EN^DDIOL(.MSG)
158 QUIT
Note: See TracBrowser for help on using the repository browser.