PRCHNPO ;WISC/SC,ID/RSD/RHD/DGL/BGJ-ENTER NEW PURCHASE ORDER/REQUISITION ; Jun 30, 2021@12:03
V ;;5.1;IFCAP;**7,11,79,108,123,184,192,208,224**;Oct 20, 2000;Build 5
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*184 Added check for Purchase Card orders to insure there
; are sufficient requsition sequence entries (>5) for
; requistion created in file 410 for realted FCP used
; and control for Running Balance Report.
;
;PRC*5.1*208 Changed order limit in opening message to $10000 at tag MSG
;
;PRC*5.1*224 changes the IENs to match the line numbers, and removed any associated discounts when a line item is deleted.
;
S NOTCOMPL=0 ;Initialize for Incomplete Template.
D SWITCH^PRCHUTL K ERRFLG ; SET LOG/ISMS SWITCH
K PRCSIP ; Initialize Inventory point variable
I $S('$G(PRCHPO):1,'$D(PRC("SITE")):1,1:0) G Q
S DIE="^PRC(442,",DR="["_$S($D(PRCHNRQ):"PRCHNREQ",1:"PRCH2138")_"]",DIC("DR")="[PRCHVENDOR]"
I $G(PRCPROST)=1 S DR="[PRCH PROSTHETIC]" D ^DIE QUIT
I $G(PRCHPC)=1 S DR="[PRCHSIMP]"
I $G(PRCHPC)=2 S DR="[PRCH DETAILED PURCHASE CARD]"
I $G(PRCHPC)=3 S DR="[PRCH PC DIRECT DELIVERY]"
I $G(PRCHDELV)=1,'$G(PRCHPHAM) S DR="[PRCH DELIVERY ORDER]"
I $G(PRCHPHAM)=1 S DR="[PRCH DIRECT DELIVERY ORDER]"
D ^DIE
;PRC*5.1*224- if Line Item removed, remove discount
N PRCDA,PRCDISC,PRCDA1,PRCDSC,PRCFLG
S PRCDA=0 F S PRCDA=$O(^PRC(442,PRCHPO,3,PRCDA)) Q:'PRCDA S PRCDISC=$P(^PRC(442,PRCHPO,3,PRCDA,0),U) D
.S PRCDA1=0,PRCFLG=0 F S PRCDA1=$O(^PRC(442,PRCHPO,2,PRCDA1)) Q:'PRCDA1 I PRCDISC=$P(^PRC(442,PRCHPO,2,PRCDA1,0),U) S PRCFLG=1 Q
.I 'PRCFLG N DIE,DA,DR S DIE="^PRC(442,"_PRCHPO_",3,",DR=".01///@",DA=PRCDA,DA(1)=PRCHPO D ^DIE D
..W !!,"***Discount associated with deleted Line Item # ",PRCDISC," has been deleted.***",!
;end PRC*5.1*224
;
; Check ERRFLG to see if the user entered an up-arrow to get out or
; did not select a credit card name. The flag ERRFLG is set at the
; input templates above.
I $G(ERRFLG)=99 G ERR ;PRC*5.1*184 Check for error flag coming from Input Template for Purchase Cards
I $G(ERRFLG)=42 G ERR
I $G(ERRFLG)=38 G ERR
I $G(ERRFLG)=1 G ERR
I $G(ERRFLG)=2 G ERR
I $G(ERRFLG)=3 G ERR
;Look for incomplete Input-Template when PRCHPC is defined.
I $D(PRCHPC) D
. I $D(Y)'=0 S NOTCOMPL=1
I NOTCOMPL G INCMSG
I $G(PRCHPC)=1 Q:$D(Y) D Q:$D(Y)
. S:'$D(^PRC(442,PRCHPO,2,0)) $P(^PRC(442,PRCHPO,2,0),U,2)=$P(^DD(442,40,0),U,2)
. S DA(1)=PRCHPO,DIE="^PRC(442,"_DA(1)_",2,",DA=1
. 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;"
. S DR(1,442.01,1)="I PRCHN(""SFC"")=2 S PRCHBOCC=2696;I '$G(PRCHBOCC) S Y=""@87"";"
. 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"
. D ^DIE Q:$D(Y)
. S DIE="^PRC(442,",DA=PRCHPO,DR=20 D ^DIE
PROS I $P($G(^PRC(442,PRCHPO,23)),U,11)]"" Q:$D(Y) D Q:$D(Y) Q:'$G(CDA)
. S PODIE=DIE,PODA=DA
. S CDA=$P($G(^PRC(442,PRCHPO,23)),U,23),PRC("CP")=$P($G(^PRC(442,PRCHPO,0)),U,3)
. I +$G(PRC("CP"))'=0 S DA=PRCHPO D START^PRCH410 I $G(PRCRMPR)=1,$G(X)="#" Q
. 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
. S DIE=PODIE,DA=PODA
I $G(PRCRMPR)=1,X="#" Q
S VEN=+$G(^PRC(442,PRCHPO,1))
I '$P($G(^PRC(442,PRCHPO,23)),U,11),$P($G(PRCHNVF),U,3)!($G(^PRC(440.3,+$G(VEN),0))]"") D
. I $P($G(^PRC(411,PRC("SITE"),9)),U,3)="Y" D Q
. . S PRCHXXDA=DA
. . S PRCHXDIE=DIE
. . S DA=VEN
. . Q:$$NEW^PRCOVTST(VEN,PRC("SITE"),1)
. . I $P($G(PRCHNVF),U,3) D
. . . S %X="^PRC(440,DA,"
. . . S %Y="^PRC(440.3,DA,"
. . . D %XY^%RCR
. . . Q
. . S DIE="^PRC(440.3,",DR="47///^S X=1;48///^S X=VEN;49///^S X=PRC(""SITE"")"
. . D ^DIE
. . S DA=PRCHXXDA
. . S DIE=PRCHXDIE
. . K PRCHXXDA
. . K PRCHXDIE
. D NEW^PRCOVRQ(VEN,PRC("SITE"))
K VEN
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
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:"")
;K PRCHER F S PRCH=$O(^PRC(442,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D G ERR:$D(PRCHER)
K PRCHER F S PRCH=$O(^PRC(442,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D
.S $P(^PRC(442,PRCHPO,2,PRCH,2),U,6)=""
.S PRCHLN=$G(^PRC(442,PRCHPO,2,PRCH,0)) ;I PRCHLN="" D ERR2 Q
.S SUBACC=$P(PRCHLN,U,4) ;I SUBACC="" D ERR2 Q
.D ERR2
.Q
K ^PRC(442,PRCHPO,2,"B"),^("C"),^("AC"),^("AE"),^("AH")
N PRCHCNYS,PRCHCNNO S (PRCHCNYS,PRCHCNNO)=0 ;FLGS FOR CONTRACT # ON ITEM
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
.S PRCHAM=+$P(^PRC(442,PRCHPO,2,PRCH,2),U,1),PRCHCN=$P(^(2),U,2) D CN:PRCHCN]"",OM:PRCHCN=""
.I PRCHCN]"" S PRCHCNYS=1
.E S PRCHCNNO=1
.S $P(^PRC(442,PRCHPO,2,PRCH,2),U,5)=""
.Q
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."
G ERRCHKS:'$D(^PRC(442,PRCHPO,1))!('$D(^(2)))
I $P(^PRC(442,PRCHPO,0),U,3)=""!($P(^(0),U,4))="" W !!?5,"Fund Control Point is undefined !",$C(7)
S PRCHV=$P(^PRC(442,PRCHPO,1),U,1) I PRCHV="" W !!?5,"Vendor is undefined !",$C(7) ;G ERR
ERRCHKS S ERRFL=0 D ERRCHKS^PRCHNPO9 ;I ERRFL=0 K ERRFL G CONT
;K ERRFL G ERR
CONT ;
S ERROR1="" D ^PRCHNPO9
I ERROR1=1!(ERRFL>0)!($D(PRCHER)) G ERR
D BBFY^PRCHNPO8(PRCHPO) I PRC("BBFY")'>0 W !!?5,"BBFY can not be checked/updated.",$C(7) G ERR
S PRCH=0 F I=0:1 S PRCH=$O(PRCH("AM",PRCH)) Q:PRCH="" S PRCH("COUNT",+PRCH("AM",PRCH),PRCH)=""
I PRCHCNNO,PRCHCNYS D ASTR ; <<< only call on ASTR
G:I=1 ^PRCHNRQ:$D(PRCHNRQ),^PRCHNPO1 S J=1 F PRCHJ=0:0 S PRCH=$O(PRCH("COUNT",PRCH)) Q:PRCH="" D MISS
G ^PRCHNRQ:$D(PRCHNRQ),^PRCHNPO1
;
LI S PRCHL0=$P(PRCH("AM",PRCHL3),U,3) Q:PRCHL0="" F J=1:1 S PRCHL1=$E(PRCHL0,$L(PRCHL0)-J) Q:PRCHL1'=+PRCHL1
S PRCHL2=$E(PRCHL0,$L(PRCHL0)-J+1,$L(PRCHL0)-1),PRCHL2=PRCHL2+1 I PRCHL2'=PRCHLI S PRCHLI=PRCHL0_PRCHLI Q
I PRCHL1=":" S PRCHLI=$E(PRCHL0,1,$L(PRCHL0)-J)_PRCHLI Q
S PRCHLI=$E(PRCHL0,1,$L(PRCHL0)-1)_":1:"_PRCHLI
Q
;
CHG 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=""
S PRCOIEN=$P(^PRC(442,PRCHPO,2,PRCH,0),U,1),$P(^PRC(442,PRCHPO,2,PRCH,0),U,1)=I,X=$P(^(0),U,5),X1=$P(^(0),U,4) ;PRC*5.1*224 - Update IEN to match line items
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)=""
S PRCDA=0 F S PRCDA=$O(^PRC(442,PRCHPO,3,PRCDA)) Q:'PRCDA S PRCDLN=$P(^PRC(442,PRCHPO,3,PRCDA,0),U) I PRCDLN=PRCOIEN D ;PRC*5.1*224 - update discount when line item is deleted
.S $P(^PRC(442,PRCHPO,3,PRCH,0),U,1)=I ;PRC*5.1*224 - update discount when line item is updated
Q
;
ERR2 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=""
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=""
I $P(^PRC(442,PRCHPO,2,PRCH,0),U,4)="" W !,"Line item ",+^(0)," is missing BOC !",!,$C(7) S PRCHER=""
Q
;
CN S:'$D(PRCH("AM",PRCHCN)) PRCH("AM",PRCHCN)="",PRCHEC=PRCHEC+1 S PRCHL3=PRCHCN
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)=""
Q
;
OM 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_","
Q
;
MISS 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
Q
;
ASTR ;IF SOME ITEMS HAVE CN, SOME DO NOT, PLACE '*' ON DISPLAY OF PO
N CN,ITM,DESC,ROOT
S ROOT="^PRC(442,PRCHPO)"
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)="*"
S:PRCHSC="B" $P(^PRC(442,PRCHPO,1),U,14)="*"
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)="*"
;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("*")
;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)
Q
;
ERR ;
W !!?5,$S($D(PRCHNRQ):"Requisition",1:"Purchase Order")_" is incomplete and must be re-edited !",$C(7)
INCMSG ;
I '$D(NOTCOMPL) D
. S NOTCOMPL=0
I NOTCOMPL D
. W !!,?5,"Incomplete transaction. It must be re-edited !",$C(7)
Q 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
G Q^PRCHNPO4
;
MSG ;Call by the "ENTRY ACTION" for Simplified PC (PRC*5.1*79)
NEW MSG
S MSG(1)="*********************************************"
S MSG(1,"F")="!!?15"
S MSG(2)="* IF THE ORDER IS MORE THAN $10000.00 *" ;PRC*5.1*208
S MSG(2,"F")="!?15"
S MSG(3)="* OR IS ON A CONTRACT, YOU CANNOT USE *"
S MSG(3,"F")="!?15"
S MSG(4)="* SIMPLIFIED PURCHASE CARD. *"
S MSG(4,"F")="!?15"
S MSG(5)="* YOU MUST USE DETAILED PURCHASE CARD!! *"
S MSG(5,"F")="!?15"
S MSG(6)="*********************************************"
S MSG(6,"F")="!?15"
S MSG(7,"F")="!"
;
D EN^DDIOL(.MSG)
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHNPO 10096 printed Oct 16, 2024@18:09:38 Page 2
PRCHNPO ;WISC/SC,ID/RSD/RHD/DGL/BGJ-ENTER NEW PURCHASE ORDER/REQUISITION ; Jun 30, 2021@12:03
V ;;5.1;IFCAP;**7,11,79,108,123,184,192,208,224**;Oct 20, 2000;Build 5
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*184 Added check for Purchase Card orders to insure there
+4 ; are sufficient requsition sequence entries (>5) for
+5 ; requistion created in file 410 for realted FCP used
+6 ; and control for Running Balance Report.
+7 ;
+8 ;PRC*5.1*208 Changed order limit in opening message to $10000 at tag MSG
+9 ;
+10 ;PRC*5.1*224 changes the IENs to match the line numbers, and removed any associated discounts when a line item is deleted.
+11 ;
+12 ;Initialize for Incomplete Template.
SET NOTCOMPL=0
+13 ; SET LOG/ISMS SWITCH
DO SWITCH^PRCHUTL
KILL ERRFLG
+14 ; Initialize Inventory point variable
KILL PRCSIP
+15 IF $SELECT('$GET(PRCHPO):1,'$DATA(PRC("SITE")):1,1:0)
GOTO Q
+16 SET DIE="^PRC(442,"
SET DR="["_$SELECT($DATA(PRCHNRQ):"PRCHNREQ",1:"PRCH2138")_"]"
SET DIC("DR")="[PRCHVENDOR]"
+17 IF $GET(PRCPROST)=1
SET DR="[PRCH PROSTHETIC]"
DO ^DIE
QUIT
+18 IF $GET(PRCHPC)=1
SET DR="[PRCHSIMP]"
+19 IF $GET(PRCHPC)=2
SET DR="[PRCH DETAILED PURCHASE CARD]"
+20 IF $GET(PRCHPC)=3
SET DR="[PRCH PC DIRECT DELIVERY]"
+21 IF $GET(PRCHDELV)=1
IF '$GET(PRCHPHAM)
SET DR="[PRCH DELIVERY ORDER]"
+22 IF $GET(PRCHPHAM)=1
SET DR="[PRCH DIRECT DELIVERY ORDER]"
+23 DO ^DIE
+24 ;PRC*5.1*224- if Line Item removed, remove discount
+25 NEW PRCDA,PRCDISC,PRCDA1,PRCDSC,PRCFLG
+26 SET PRCDA=0
FOR
SET PRCDA=$ORDER(^PRC(442,PRCHPO,3,PRCDA))
if 'PRCDA
QUIT
SET PRCDISC=$PIECE(^PRC(442,PRCHPO,3,PRCDA,0),U)
Begin DoDot:1
+27 SET PRCDA1=0
SET PRCFLG=0
FOR
SET PRCDA1=$ORDER(^PRC(442,PRCHPO,2,PRCDA1))
if 'PRCDA1
QUIT
IF PRCDISC=$PIECE(^PRC(442,PRCHPO,2,PRCDA1,0),U)
SET PRCFLG=1
QUIT
+28 IF 'PRCFLG
NEW DIE,DA,DR
SET DIE="^PRC(442,"_PRCHPO_",3,"
SET DR=".01///@"
SET DA=PRCDA
SET DA(1)=PRCHPO
DO ^DIE
Begin DoDot:2
+29 WRITE !!,"***Discount associated with deleted Line Item # ",PRCDISC," has been deleted.***",!
End DoDot:2
End DoDot:1
+30 ;end PRC*5.1*224
+31 ;
+32 ; Check ERRFLG to see if the user entered an up-arrow to get out or
+33 ; did not select a credit card name. The flag ERRFLG is set at the
+34 ; input templates above.
+35 ;PRC*5.1*184 Check for error flag coming from Input Template for Purchase Cards
IF $GET(ERRFLG)=99
GOTO ERR
+36 IF $GET(ERRFLG)=42
GOTO ERR
+37 IF $GET(ERRFLG)=38
GOTO ERR
+38 IF $GET(ERRFLG)=1
GOTO ERR
+39 IF $GET(ERRFLG)=2
GOTO ERR
+40 IF $GET(ERRFLG)=3
GOTO ERR
+41 ;Look for incomplete Input-Template when PRCHPC is defined.
+42 IF $DATA(PRCHPC)
Begin DoDot:1
+43 IF $DATA(Y)'=0
SET NOTCOMPL=1
End DoDot:1
+44 IF NOTCOMPL
GOTO INCMSG
+45 IF $GET(PRCHPC)=1
if $DATA(Y)
QUIT
Begin DoDot:1
+46 if '$DATA(^PRC(442,PRCHPO,2,0))
SET $PIECE(^PRC(442,PRCHPO,2,0),U,2)=$PIECE(^DD(442,40,0),U,2)
+47 SET DA(1)=PRCHPO
SET DIE="^PRC(442,"_DA(1)_",2,"
SET DA=1
+48 SET 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;"
+49 SET DR(1,442.01,1)="I PRCHN(""SFC"")=2 S PRCHBOCC=2696;I '$G(PRCHBOCC) S Y=""@87"";"
+50 SET 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"
+51 DO ^DIE
if $DATA(Y)
QUIT
+52 SET DIE="^PRC(442,"
SET DA=PRCHPO
SET DR=20
DO ^DIE
End DoDot:1
if $DATA(Y)
QUIT
PROS IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)]""
if $DATA(Y)
QUIT
Begin DoDot:1
+1 SET PODIE=DIE
SET PODA=DA
+2 SET CDA=$PIECE($GET(^PRC(442,PRCHPO,23)),U,23)
SET PRC("CP")=$PIECE($GET(^PRC(442,PRCHPO,0)),U,3)
+3 IF +$GET(PRC("CP"))'=0
SET DA=PRCHPO
DO START^PRCH410
IF $GET(PRCRMPR)=1
IF $GET(X)="#"
QUIT
+4 IF '$GET(PRCHPHAM)
IF '$GET(PRCPROST)
IF +$GET(PRC("CP"))'=0
SET DIE="^PRCS(410,"
SET DA=$PIECE($GET(^PRC(442,PRCHPO,23)),U,23)
SET DR=16
DO ^DIE
+5 SET DIE=PODIE
SET DA=PODA
End DoDot:1
if $DATA(Y)
QUIT
if '$GET(CDA)
QUIT
+6 IF $GET(PRCRMPR)=1
IF X="#"
QUIT
+7 SET VEN=+$GET(^PRC(442,PRCHPO,1))
+8 IF '$PIECE($GET(^PRC(442,PRCHPO,23)),U,11)
IF $PIECE($GET(PRCHNVF),U,3)!($GET(^PRC(440.3,+$GET(VEN),0))]"")
Begin DoDot:1
+9 IF $PIECE($GET(^PRC(411,PRC("SITE"),9)),U,3)="Y"
Begin DoDot:2
+10 SET PRCHXXDA=DA
+11 SET PRCHXDIE=DIE
+12 SET DA=VEN
+13 if $$NEW^PRCOVTST(VEN,PRC("SITE"),1)
QUIT
+14 IF $PIECE($GET(PRCHNVF),U,3)
Begin DoDot:3
+15 SET %X="^PRC(440,DA,"
+16 SET %Y="^PRC(440.3,DA,"
+17 DO %XY^%RCR
+18 QUIT
End DoDot:3
+19 SET DIE="^PRC(440.3,"
SET DR="47///^S X=1;48///^S X=VEN;49///^S X=PRC(""SITE"")"
+20 DO ^DIE
+21 SET DA=PRCHXXDA
+22 SET DIE=PRCHXDIE
+23 KILL PRCHXXDA
+24 KILL PRCHXDIE
End DoDot:2
QUIT
+25 DO NEW^PRCOVRQ(VEN,PRC("SITE"))
End DoDot:1
+26 KILL VEN
+27 LOCK +^PRC(442,PRCHPO):0
if '$TEST
GOTO ERR
SET PRCHSTAT=$PIECE($GET(^PRC(442,PRCHPO,7)),U,2)
if $DATA(Y)&('$DATA(PRCHNRQ))&(PRCHSTAT'=22)
SET PRCHER=""
SET (PRCH,PRCHEC,PRCHX)=0
+28 SET PRCHSC=""
IF $DATA(^PRC(442,PRCHPO,1))
IF $DATA(^PRCD(420.8,+$PIECE(^(1),U,7),0))
SET PRCHSC=$PIECE(^(0),U,1)
SET $PIECE(^PRC(442,PRCHPO,1),U,14)=$SELECT(PRCHSC="B":"*",1:"")
+29 ;K PRCHER F S PRCH=$O(^PRC(442,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D G ERR:$D(PRCHER)
+30 KILL PRCHER
FOR
SET PRCH=$ORDER(^PRC(442,PRCHPO,2,PRCH))
if PRCH=""!(PRCH'>0)
QUIT
Begin DoDot:1
+31 SET $PIECE(^PRC(442,PRCHPO,2,PRCH,2),U,6)=""
+32 ;I PRCHLN="" D ERR2 Q
SET PRCHLN=$GET(^PRC(442,PRCHPO,2,PRCH,0))
+33 ;I SUBACC="" D ERR2 Q
SET SUBACC=$PIECE(PRCHLN,U,4)
+34 DO ERR2
+35 QUIT
End DoDot:1
+36 KILL ^PRC(442,PRCHPO,2,"B"),^("C"),^("AC"),^("AE"),^("AH")
+37 ;FLGS FOR CONTRACT # ON ITEM
NEW PRCHCNYS,PRCHCNNO
SET (PRCHCNYS,PRCHCNNO)=0
+38 SET PRCH=0
FOR I=1:1
SET PRCH=$ORDER(^PRC(442,PRCHPO,2,PRCH))
if PRCH=""!(PRCH'>0)
QUIT
DO CHG
IF $DATA(^PRC(442,PRCHPO,2,PRCH,0))
Begin DoDot:1
+39 SET PRCHAM=+$PIECE(^PRC(442,PRCHPO,2,PRCH,2),U,1)
SET PRCHCN=$PIECE(^(2),U,2)
if PRCHCN]""
DO CN
if PRCHCN=""
DO OM
+40 IF PRCHCN]""
SET PRCHCNYS=1
+41 IF '$TEST
SET PRCHCNNO=1
+42 SET $PIECE(^PRC(442,PRCHPO,2,PRCH,2),U,5)=""
+43 QUIT
End DoDot:1
+44 SET PRCHLCNT=I-1
SET $PIECE(^PRC(442,PRCHPO,0),U,14)=PRCHLCNT
if $DATA(^PRC(442,PRCHPO,2,0))
SET $PIECE(^(0),U,3,4)="1^"_PRCHLCNT
IF 'PRCHLCNT
SET PRCHER=""
WRITE !,"There are no line items listed in the Purchase Order."
+45 if '$DATA(^PRC(442,PRCHPO,1))!('$DATA(^(2)))
GOTO ERRCHKS
+46 IF $PIECE(^PRC(442,PRCHPO,0),U,3)=""!($PIECE(^(0),U,4))=""
WRITE !!?5,"Fund Control Point is undefined !",$CHAR(7)
+47 ;G ERR
SET PRCHV=$PIECE(^PRC(442,PRCHPO,1),U,1)
IF PRCHV=""
WRITE !!?5,"Vendor is undefined !",$CHAR(7)
ERRCHKS ;I ERRFL=0 K ERRFL G CONT
SET ERRFL=0
DO ERRCHKS^PRCHNPO9
+1 ;K ERRFL G ERR
CONT ;
+1 SET ERROR1=""
DO ^PRCHNPO9
+2 IF ERROR1=1!(ERRFL>0)!($DATA(PRCHER))
GOTO ERR
+3 DO BBFY^PRCHNPO8(PRCHPO)
IF PRC("BBFY")'>0
WRITE !!?5,"BBFY can not be checked/updated.",$CHAR(7)
GOTO ERR
+4 SET PRCH=0
FOR I=0:1
SET PRCH=$ORDER(PRCH("AM",PRCH))
if PRCH=""
QUIT
SET PRCH("COUNT",+PRCH("AM",PRCH),PRCH)=""
+5 ; <<< only call on ASTR
IF PRCHCNNO
IF PRCHCNYS
DO ASTR
+6 if I=1
if $DATA(PRCHNRQ)
GOTO ^PRCHNRQ
GOTO ^PRCHNPO1
SET J=1
FOR PRCHJ=0:0
SET PRCH=$ORDER(PRCH("COUNT",PRCH))
if PRCH=""
QUIT
DO MISS
+7 if $DATA(PRCHNRQ)
GOTO ^PRCHNRQ
GOTO ^PRCHNPO1
+8 ;
LI SET PRCHL0=$PIECE(PRCH("AM",PRCHL3),U,3)
if PRCHL0=""
QUIT
FOR J=1:1
SET PRCHL1=$EXTRACT(PRCHL0,$LENGTH(PRCHL0)-J)
if PRCHL1'=+PRCHL1
QUIT
+1 SET PRCHL2=$EXTRACT(PRCHL0,$LENGTH(PRCHL0)-J+1,$LENGTH(PRCHL0)-1)
SET PRCHL2=PRCHL2+1
IF PRCHL2'=PRCHLI
SET PRCHLI=PRCHL0_PRCHLI
QUIT
+2 IF PRCHL1=":"
SET PRCHLI=$EXTRACT(PRCHL0,1,$LENGTH(PRCHL0)-J)_PRCHLI
QUIT
+3 SET PRCHLI=$EXTRACT(PRCHL0,1,$LENGTH(PRCHL0)-1)_":1:"_PRCHLI
+4 QUIT
+5 ;
CHG IF '$PIECE(^PRC(442,PRCHPO,2,PRCH,0),"^",5)
IF '$ORDER(^(1,0))
SET $PIECE(^PRC(442,PRCHPO,2,PRCH,2),U,4,6)="^^"
WRITE !,"Line item ",+^PRC(442,PRCHPO,2,PRCH,0)," is missing its description!"
SET PRCHER=""
+1 ;PRC*5.1*224 - Update IEN to match line items
SET PRCOIEN=$PIECE(^PRC(442,PRCHPO,2,PRCH,0),U,1)
SET $PIECE(^PRC(442,PRCHPO,2,PRCH,0),U,1)=I
SET X=$PIECE(^(0),U,5)
SET X1=$PIECE(^(0),U,4)
+2 SET ^PRC(442,PRCHPO,2,"B",I,PRCH)=""
SET ^PRC(442,PRCHPO,2,"C",I,PRCH)=""
SET ^PRC(442,PRCHPO,2,"AH",+X1,I,PRCH)=""
SET PRCHLI=I
SET PRCHX=PRCH
if X]""
SET ^PRC(442,PRCHPO,2,"AE",X,PRCH)=""
+3 ;PRC*5.1*224 - update discount when line item is deleted
SET PRCDA=0
FOR
SET PRCDA=$ORDER(^PRC(442,PRCHPO,3,PRCDA))
if 'PRCDA
QUIT
SET PRCDLN=$PIECE(^PRC(442,PRCHPO,3,PRCDA,0),U)
IF PRCDLN=PRCOIEN
Begin DoDot:1
+4 ;PRC*5.1*224 - update discount when line item is updated
SET $PIECE(^PRC(442,PRCHPO,3,PRCH,0),U,1)=I
End DoDot:1
+5 QUIT
+6 ;
ERR2 IF $SELECT('$DATA(^PRC(442,PRCHPO,2,PRCH,2)):1,$PIECE(^(2),U,1)="":1,1:0)
SET $PIECE(^(2),U,1)=""
SET $PIECE(^(2),U,4,7)=""
WRITE !,"Line item ",+^(0)," is incomplete !",$CHAR(7)
SET PRCHER=""
+1 IF '$GET(PRCHPC)
IF $DATA(PRCHNRQ)
IF PRCHSC'=9
IF $PIECE(^PRC(442,PRCHPO,2,PRCH,0),U,13)=""
WRITE !,"Line item ",+^(0)," is missing NSN !",$CHAR(7)
SET PRCHER=""
+2 IF $PIECE(^PRC(442,PRCHPO,2,PRCH,0),U,4)=""
WRITE !,"Line item ",+^(0)," is missing BOC !",!,$CHAR(7)
SET PRCHER=""
+3 QUIT
+4 ;
CN if '$DATA(PRCH("AM",PRCHCN))
SET PRCH("AM",PRCHCN)=""
SET PRCHEC=PRCHEC+1
SET PRCHL3=PRCHCN
+1 DO LI
SET PRCH("AM",PRCHCN)=($PIECE(PRCH("AM",PRCHCN),U,1)+1)_U_($PIECE(PRCH("AM",PRCHCN),U,2)+PRCHAM)_U_PRCHLI_","
SET ^PRC(442,PRCHPO,2,"AC",$EXTRACT(PRCHCN,1,30),PRCH)=""
+2 QUIT
+3 ;
OM if '$DATA(PRCH("AM",".OM"))
SET PRCH("AM",".OM")=""
SET PRCHEC=PRCHEC+1
SET PRCHL3=".OM"
DO LI
SET PRCH("AM",".OM")=($PIECE(PRCH("AM",".OM"),U,1)+1)_U_($PIECE(PRCH("AM",".OM"),U,2)+PRCHAM)_U_PRCHLI_","
+1 QUIT
+2 ;
MISS SET PRCHN=0
FOR K=1:1
SET PRCHN=$ORDER(PRCH("COUNT",PRCH,PRCHN))
if PRCHN=""!(J>(I-1))
QUIT
SET J=J+1
SET L=0
SET Y=$PIECE(PRCH("AM",PRCHN),U,3)
SET Y="F PRCHLI="_$EXTRACT(Y,1,$LENGTH(Y)-1)_" S L=L+1 G ERR2:PRCHX<0"
XECUTE Y
+1 QUIT
+2 ;
ASTR ;IF SOME ITEMS HAVE CN, SOME DO NOT, PLACE '*' ON DISPLAY OF PO
+1 NEW CN,ITM,DESC,ROOT
+2 SET ROOT="^PRC(442,PRCHPO)"
+3 SET CN=0
FOR M=1:1
SET CN=$ORDER(@ROOT@(2,"AC",CN))
if CN=""
QUIT
if $DATA(^(CN))
SET ITM=$ORDER(^(CN,0))
SET ^PRC(442,PRCHPO,2,"AC",CN,ITM)="*"
+4 if PRCHSC="B"
SET $PIECE(^PRC(442,PRCHPO,1),U,14)="*"
+5 SET DESC=0
FOR I=1:1
SET DESC=$ORDER(@ROOT@(2,DESC))
if DESC=""!(DESC'>0)
QUIT
IF $PIECE(@ROOT@(2,DESC,2),U,2)']""
SET $PIECE(^PRC(442,PRCHPO,2,DESC,2),U,5)="*"
+6 ;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("*")
+7 ;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)
+8 QUIT
+9 ;
ERR ;
+1 WRITE !!?5,$SELECT($DATA(PRCHNRQ):"Requisition",1:"Purchase Order")_" is incomplete and must be re-edited !",$CHAR(7)
INCMSG ;
+1 IF '$DATA(NOTCOMPL)
Begin DoDot:1
+2 SET NOTCOMPL=0
End DoDot:1
+3 IF NOTCOMPL
Begin DoDot:1
+4 WRITE !!,?5,"Incomplete transaction. It must be re-edited !",$CHAR(7)
End DoDot:1
Q KILL 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
+1 GOTO Q^PRCHNPO4
+2 ;
MSG ;Call by the "ENTRY ACTION" for Simplified PC (PRC*5.1*79)
+1 NEW MSG
+2 SET MSG(1)="*********************************************"
+3 SET MSG(1,"F")="!!?15"
+4 ;PRC*5.1*208
SET MSG(2)="* IF THE ORDER IS MORE THAN $10000.00 *"
+5 SET MSG(2,"F")="!?15"
+6 SET MSG(3)="* OR IS ON A CONTRACT, YOU CANNOT USE *"
+7 SET MSG(3,"F")="!?15"
+8 SET MSG(4)="* SIMPLIFIED PURCHASE CARD. *"
+9 SET MSG(4,"F")="!?15"
+10 SET MSG(5)="* YOU MUST USE DETAILED PURCHASE CARD!! *"
+11 SET MSG(5,"F")="!?15"
+12 SET MSG(6)="*********************************************"
+13 SET MSG(6,"F")="!?15"
+14 SET MSG(7,"F")="!"
+15 ;
+16 DO EN^DDIOL(.MSG)
+17 QUIT
