PRCHNPO7 ;WISC/RHD-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 442 ; 7/27/05 10:16am
V ;;5.1;IFCAP;**79,100**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN1 ;INPUT TRANSFORM-FILE 442, NSN #9.5
I '$D(^PRC(441.2,+X,0)) W !!,$C(7),"Invalid NSN--first 4 characters must be FSC code!!" K X Q
S PRCHCI=+$P(^PRC(442,DA(1),2,DA,0),U,5)
S Z=$O(^PRC(441,"BB",X,0)) S:Z=PRCHCI Z=$O(^(Z)) I Z W !!,$C(7),"This NSN has already been assigned to item # "_$O(^(0))_"!!" K X Q
I $P(^PRC(441.2,+X,0),U,4)="" W $C(7),!,"Commodity Code missing on this FSC--Required for LOG code sheets!" K X Q
S $P(^PRC(442,DA(1),2,DA,2),U,3)=+X
Q:$P(^PRC(442,DA(1),2,DA,0),U,5)=""
S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) S PRCHCPO=DA(1) D EN5^PRCHCRD
S PRCHSAVX=X,X=+X
G EN11
;
EN10 ;UPDATE FEDERAL SUPPLY CLASSIFICATION/PRODUCT SERVICE CODE (FSC/PSC), field #8, file #442.
;PRC*5.1*79: if entering a service item, don't check for commodity code.
;The field title is now called 'FSC/PSC' to hold either a Federal Supply
;Classification (FSC) code or a Product Service Code (PSC) to support a
;new FPDS report for the Austin Automation Center (AAC). The variable
;PRCSAVE is killed in various PO input templates where it is used.
;
I '$D(PRCSAVE)&(X'=$P(^PRC(441.2,+X,0),U,1))&($P(^PRC(442,DA(1),2,DA,0),U,5)'="") D EN102 K A,X Q
;
I ($P(^PRC(441.2,+X,0),U,4)="")&(X=$P(^PRC(441.2,+X,0),U,1)) D EN104 K A,X Q
S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0)
I $G(PRCSAVE)="G"&(X'=$P(^PRC(441.2,+X,0),U,1)) D EN102 K A,X Q
;
I $G(PRCSAVE)="S"&(X=$P(^PRC(441.2,+X,0),U,1))&($P(^PRC(442,DA(1),2,DA,0),U,5)="") D EN103 K A,X Q
;
EN11 S PRCHCI=+$P(^PRC(442,DA(1),2,DA,0),U,5),PRCHCPO=DA(1) I $D(^PRC(441,+PRCHCI,0)) D EN8^PRCHCRD1
S:$D(PRCHSAVX) X=PRCHSAVX K PRCHSAVX
Q
;
EN100 ;Come here for amended orders - check FSC/PSC, field #8, file #443.6.
;PRC*5.1*79: if entering a service item, don't check for commodity code
I X=""&($P(^PRC(443.6,DA(1),2,DA,2),U,3)="") D EN^DDIOL("This field is Required!!") S Y="@6" Q
I '$D(PRCSAVE)&(X'=$P(^PRC(441.2,+X,0),U,1))&($P(^PRC(443.6,DA(1),2,DA,0),U,5)'="") D EN102 K A,X Q
;
I ($P(^PRC(441.2,+X,0),U,4)="")&(X=$P(^PRC(441.2,+X,0),U,1)) D EN104 K A,X Q
S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0)
I $G(PRCSAVE)="G"&(X'=$P(^PRC(441.2,+X,0),U,1)) D EN102 K A,X Q
;
I $G(PRCSAVE)="S"&(X=$P(^PRC(441.2,+X,0),U,1))&($P(^PRC(443.6,DA(1),2,DA,0),U,5)="") D EN103 K A,X Q
;
S PRCHCI=+$P(^PRC(443.6,DA(1),2,DA,0),U,5),PRCHCPO=DA(1) I $D(^PRC(441,+PRCHCI,0)) D EN8^PRCHCRD1
S:$D(PRCHSAVX) X=PRCHSAVX K PRCHSAVX
Q
;
EN101 ;Check Request for Quotations - check FSC/PSC, field #4, file #444.
I '$D(PRCSAVE)&($P(^PRC(444,DA(1),2,DA,0),U,4)'="")&(X'=$P(^PRC(441.2,+X,0),U,1)) D EN102 K A,X Q
;
I ($P(^PRC(441.2,+X,0),U,4)="")&(X=$P(^PRC(441.2,+X,0),U,1)) D EN104 K A,X Q
I $G(PRCSAVE)="G"&(X'=$P(^PRC(441.2,+X,0),U,1)) D EN102 K A,X Q
;
I $G(PRCSAVE)="S"&(X=$P(^PRC(441.2,+X,0),U,1)) D EN103 K A,X Q
;
S PRCHCI=+$P(^PRC(444,DA(1),2,DA,0),U,5),PRCHCPO=DA(1) I $D(^PRC(441,+PRCHCI,0)) D EN8^PRCHCRD1
S:$D(PRCHSAVX) X=PRCHSAVX K PRCHSAVX
Q
;
EN102 ;Stop assignment of a PSC to an item.
S A(1)="This is a Product Service Code - Not allowed on ITEMS!!"
S A(2,"F")="!"
D EN^DDIOL(.A)
Q
;
EN103 ;Stop assignment of an FSC to a service.
S A(1)="This is a Federal Supply Classification Code - Not allowed on SERVICES!!"
S A(2,"F")="!"
D EN^DDIOL(.A)
Q
;
EN104 ;Stop user if commodity code is missing.
S A(1)="Commodity Code missing on this Federal Supply Classification--Required for LOG code sheets!"
S A(2,"F")="!"
D EN^DDIOL(.A)
Q
;
EN105 ;Stop a PO if a line item does not contain an FSC or PSC. This tag is
;called from the routine PRCHNP04. Do not clean up variables here.
;This check is for all POs that may be required by FPDS. PRC*5.1*100.
I $P(^PRC(442,PRCHPO,1),U,7)]"" D
. S PRCHITM=0 F S PRCHITM=$O(^PRC(442,PRCHPO,2,PRCHITM)) Q:'PRCHITM I $P($G(^PRC(442,PRCHPO,2,PRCHITM,2)),U,3)="" D EN^DDIOL("Line item "_PRCHITM_" on this PO does not contain an FSC or PSC.","","!!?5") S ERROR=1
;End of changes for PRC*5.1*79
Q
;
EN106 ;PRC*5.1*100: stop amended PO with line items lacking an FSC or PSC.
I $P(^PRC(443.6,PRCHPO,1),U,7)]"" D
. S PRCHITM=0 F S PRCHITM=$O(^PRC(443.6,PRCHPO,2,PRCHITM)) Q:'PRCHITM I $P($G(^PRC(443.6,PRCHPO,2,PRCHITM,2)),U,3)="" D EN^DDIOL("Line item "_PRCHITM_" on this PO does not contain an FSC or PSC.","","!!?5") S ERROR=1
Q
;
EN2 ;IF 'ESTIMATED P.O.' MOVE VERBAGE INTO COMMENTS
D EN2A
Q:'$D(^PRC(442,PRCHPO,7)) Q:$P(^(7),U,3)'="Y" S WX="*** ESTIMATED PURCHASE ORDER ***" I $D(^PRC(442,PRCHPO,4,1,0)),^(0)[WX K WX Q
S WX=WX_" ",PRCH="^PRC(442,PRCHPO,4," D WORD^PRCHUTL K PRCH
Q
;
EN2A ;CHECK DELIVERY SCHEDULES-QUANTITY DELIVERED MUST BE >0
N NUM,J,K,DA
S NUM=$P(^PRC(442,PRCHPO,0),U)
I $D(^PRC(442.8,"AC",NUM)) D
. F J=0:0 S J=$O(^PRC(442.8,"AC",NUM,J)) Q:J'>0 D
. . F K=0:0 S K=$O(^PRC(442.8,"AC",NUM,J,K)) Q:K'>0 D
. . . I $P(^PRC(442.8,K,0),U,5)'>0 S DIK="^PRC(442.8,",DA=K D ^DIK K DIK
Q
EN3 ;COMPLETE DEPOT/GSA PUSH ORDERS
S I=$P(^PRC(442,PRCHPO,0),U,15)
W !!,"Total Dollar Amount: "_I_" //" R X:DTIME S:'$T X="^" S:X="" X=I I X["^" S X=1 G EN31
I X=""!(X=0) G EN30
I X["?" W !!,"You can either enter the total dollar amount for the entire PUSH, or just the",!,"dollar amount for this part (regular, subsistence or drugs). This is just",!,"used to update the P.O.register." G EN3
S:X["$" X=$P(X,"$",2) I X'?.N.1".".2N!(X>9999999.99)!(X<1) W $C(7),"??" G EN3
S $P(^PRC(442,PRCHPO,0),U,15)=X
;
EN30 S X=1,%A="Complete this Requisition ",%B="This action will change the status to 'Transaction Complete'.",%=1 D ^PRCFYN I %=1 S X=40
;
EN31 S DA=PRCHPO D ENS^PRCHSTAT
Q
;
EN6 ;FILE 442, SKU #9.4
D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="")
S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) S PRCHCV=$P(^PRC(442,DA(1),1),U,1),PRCHCI=$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN10^PRCHCRD1
Q
;
EN7 ;FILE 442, UNIT CONVERSION FACTOR #9.7
D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="")
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 EN11^PRCHCRD1
Q
;
VEN I $S('$D(^PRC(442,DA(1),1)):1,$P(^(1),U,1)="":1,1:0) W !!,"Vendor must be entered before items ! ",$C(7) K X
Q
;
VENA I $S('$D(^PRC(442,DA,1)):1,$P(^(1),U,1)="":1,1:0) W !!,"Vendor must be entered before items ! ",$C(7) K X
Q
;
VEN1 I $S('$D(^PRC(443.6,DA(1),1)):1,$P(^(1),U,1)="":1,1:0) W !!,"Vendor must be entered before items ! ",$C(7) K X
Q
;
VEN1A I $S('$D(^PRC(443.6,DA,1)):1,$P(^(1),U,1)="":1,1:0) W !!,"Vendor must be entered before items ! ",$C(7) K X
Q
;
;
;
SUPBOC(QUIETLY) ;stmts.to compute pre-implied BOC, moved from template PRCH2138 into this routine and also called in BOC input transform
N PRCHIDA,SPFCP,PRCHBOCC,ACCT
S:$G(QUIETLY)=-1 X=$P($G(^PRC(442,DA(1),2,DA,0)),U,4)
D VEN Q:'$D(X) ""
S PRCHIDA=+$P(^PRC(442,DA(1),2,DA,0),U,5),SPFCP=+$P(^PRC(442,DA(1),0),U,19)
I SPFCP=2 D
. S PRCHN("SFC")=SPFCP,ACCT=$$ACCT^PRCPUX1($E($$NSN^PRCPUX1(PRCHIDA),1,4))
. D ;:$D(ACCT)
. . S PRCHBOCC=$P($G(^PRCD(420.2,$S(ACCT=1:2697,ACCT=2:2698,ACCT=3:2699,ACCT=6:2699,ACCT=8:2696,1:2699),0)),U)
. . I PRCHBOCC S $P(^PRC(442,DA(1),2,DA,0),U,4)=PRCHBOCC D
. . . I PRCHBOCC'=X,PRCHBOCC W:'$G(QUIETLY) !,?5,"BOC must be ",PRCHBOCC,!,?5,"For a supply fund order, a BOC ",X," is invalid.",! S X=PRCHBOCC
Q X
;
;
;
EN8 ;FILE 442, ITEM #40; BOC #3.5 -- Z0 must = BOC on entry
N DIC D VEN Q:'$D(X)
S DIC="^PRCD(420.1,"_Z0_",1,",DIC(0)="QEMZ"
I $P(^PRC(442,DA(1),0),U,19)'=2 D
. D ^DIC K:Y<0 X K Z0
. I $D(X) S X=$P(Y(0,0),"^",1) D
. . S PRCHBOC=+Y ;D EN2^PRCHNPO8
. . W !,X
Q
;
;
EN88 ;FILE 442, EST. SHIPPING BOC #13.05 -- Z0 must = BOC on entry
N DIC D VENA Q:'$D(X)
S DIC="^PRCD(420.1,"_Z0_",1,",DIC(0)="QEMZ" D ^DIC K:Y<0 X K Z0
I $D(X) S X=$P(Y(0,0),"^",1) W !,X
Q
;
EN9 ;CHECK FOR PAYMENT FIELDS AND OTHER FIELDS IN VENDOR FILE
;CALLED FROM FILE 442 INPUT TEMPLATES.
;FLAG --is set to 1 in template when certain VENDOR conditions are met
S PRCHOV7=$G(^PRC(440,+^PRC(442,D0,1),7)) G:PRCHOV7="" EXIT
I $P(PRCHOV7,U,3)]"",($P(PRCHOV7,U,7)]""),($P(PRCHOV7,U,8)]""),($P(PRCHOV7,U,9)]""),$P(PRCHOV3,U,11)]"",$P(PRCHOV3,U,14)]"",$P(PRCHOV3,U,13)]"",FLAG S Y="@20" G EXIT
S VEN=+^PRC(442,D0,1),%X="^PRC(440,VEN,",%Y="^PRC(440.3,VEN," D %XY^%RCR K VEN
EXIT Q
;
EN12 ;UPDATE NATIONAL DRUG CODE #9.3
D VEN Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="")
S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) S PRCHCV=$P(^PRC(442,DA(1),1),U,1),PRCHCI=$P(^(2,DA,0),U,5),PRCHCPO=DA(1) D EN12^PRCHCRD1
Q
;
EN13 ;FILE 443.6, ITEM #40;BOC #3.5, EST. SHIPPING BOC #13.05
D VEN1 Q:'$D(X) S DIC="^PRCD(420.1,"_Z0_",1,",DIC(0)="QEMZ" D ^DIC K:Y<0 X K DIC,Z0 I $D(X) S X=$P(Y(0,0),"^",1) W !,X
Q
EN133 ;FILE 443.6, EST. SHIPPING BOC #13.05
D VEN1A Q:'$D(X) S DIC="^PRCD(420.1,"_Z0_",1,",DIC(0)="QEMZ" D ^DIC K:Y<0 X K DIC,Z0 I $D(X) S X=$P(Y(0,0),"^",1) W !,X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHNPO7 9248 printed Dec 13, 2024@02:08:59 Page 2
PRCHNPO7 ;WISC/RHD-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 442 ; 7/27/05 10:16am
V ;;5.1;IFCAP;**79,100**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
EN1 ;INPUT TRANSFORM-FILE 442, NSN #9.5
+1 IF '$DATA(^PRC(441.2,+X,0))
WRITE !!,$CHAR(7),"Invalid NSN--first 4 characters must be FSC code!!"
KILL X
QUIT
+2 SET PRCHCI=+$PIECE(^PRC(442,DA(1),2,DA,0),U,5)
+3 SET Z=$ORDER(^PRC(441,"BB",X,0))
if Z=PRCHCI
SET Z=$ORDER(^(Z))
IF Z
WRITE !!,$CHAR(7),"This NSN has already been assigned to item # "_$ORDER(^(0))_"!!"
KILL X
QUIT
+4 IF $PIECE(^PRC(441.2,+X,0),U,4)=""
WRITE $CHAR(7),!,"Commodity Code missing on this FSC--Required for LOG code sheets!"
KILL X
QUIT
+5 SET $PIECE(^PRC(442,DA(1),2,DA,2),U,3)=+X
+6 if $PIECE(^PRC(442,DA(1),2,DA,0),U,5)=""
QUIT
+7 if '$DATA(PRC("SITE"))
SET PRC("SITE")=+^PRC(442,DA(1),0)
SET PRCHCPO=DA(1)
DO EN5^PRCHCRD
+8 SET PRCHSAVX=X
SET X=+X
+9 GOTO EN11
+10 ;
EN10 ;UPDATE FEDERAL SUPPLY CLASSIFICATION/PRODUCT SERVICE CODE (FSC/PSC), field #8, file #442.
+1 ;PRC*5.1*79: if entering a service item, don't check for commodity code.
+2 ;The field title is now called 'FSC/PSC' to hold either a Federal Supply
+3 ;Classification (FSC) code or a Product Service Code (PSC) to support a
+4 ;new FPDS report for the Austin Automation Center (AAC). The variable
+5 ;PRCSAVE is killed in various PO input templates where it is used.
+6 ;
+7 IF '$DATA(PRCSAVE)&(X'=$PIECE(^PRC(441.2,+X,0),U,1))&($PIECE(^PRC(442,DA(1),2,DA,0),U,5)'="")
DO EN102
KILL A,X
QUIT
+8 ;
+9 IF ($PIECE(^PRC(441.2,+X,0),U,4)="")&(X=$PIECE(^PRC(441.2,+X,0),U,1))
DO EN104
KILL A,X
QUIT
+10 if '$DATA(PRC("SITE"))
SET PRC("SITE")=+^PRC(442,DA(1),0)
+11 IF $GET(PRCSAVE)="G"&(X'=$PIECE(^PRC(441.2,+X,0),U,1))
DO EN102
KILL A,X
QUIT
+12 ;
+13 IF $GET(PRCSAVE)="S"&(X=$PIECE(^PRC(441.2,+X,0),U,1))&($PIECE(^PRC(442,DA(1),2,DA,0),U,5)="")
DO EN103
KILL A,X
QUIT
+14 ;
EN11 SET PRCHCI=+$PIECE(^PRC(442,DA(1),2,DA,0),U,5)
SET PRCHCPO=DA(1)
IF $DATA(^PRC(441,+PRCHCI,0))
DO EN8^PRCHCRD1
+1 if $DATA(PRCHSAVX)
SET X=PRCHSAVX
KILL PRCHSAVX
+2 QUIT
+3 ;
EN100 ;Come here for amended orders - check FSC/PSC, field #8, file #443.6.
+1 ;PRC*5.1*79: if entering a service item, don't check for commodity code
+2 IF X=""&($PIECE(^PRC(443.6,DA(1),2,DA,2),U,3)="")
DO EN^DDIOL("This field is Required!!")
SET Y="@6"
QUIT
+3 IF '$DATA(PRCSAVE)&(X'=$PIECE(^PRC(441.2,+X,0),U,1))&($PIECE(^PRC(443.6,DA(1),2,DA,0),U,5)'="")
DO EN102
KILL A,X
QUIT
+4 ;
+5 IF ($PIECE(^PRC(441.2,+X,0),U,4)="")&(X=$PIECE(^PRC(441.2,+X,0),U,1))
DO EN104
KILL A,X
QUIT
+6 if '$DATA(PRC("SITE"))
SET PRC("SITE")=+^PRC(442,DA(1),0)
+7 IF $GET(PRCSAVE)="G"&(X'=$PIECE(^PRC(441.2,+X,0),U,1))
DO EN102
KILL A,X
QUIT
+8 ;
+9 IF $GET(PRCSAVE)="S"&(X=$PIECE(^PRC(441.2,+X,0),U,1))&($PIECE(^PRC(443.6,DA(1),2,DA,0),U,5)="")
DO EN103
KILL A,X
QUIT
+10 ;
+11 SET PRCHCI=+$PIECE(^PRC(443.6,DA(1),2,DA,0),U,5)
SET PRCHCPO=DA(1)
IF $DATA(^PRC(441,+PRCHCI,0))
DO EN8^PRCHCRD1
+12 if $DATA(PRCHSAVX)
SET X=PRCHSAVX
KILL PRCHSAVX
+13 QUIT
+14 ;
EN101 ;Check Request for Quotations - check FSC/PSC, field #4, file #444.
+1 IF '$DATA(PRCSAVE)&($PIECE(^PRC(444,DA(1),2,DA,0),U,4)'="")&(X'=$PIECE(^PRC(441.2,+X,0),U,1))
DO EN102
KILL A,X
QUIT
+2 ;
+3 IF ($PIECE(^PRC(441.2,+X,0),U,4)="")&(X=$PIECE(^PRC(441.2,+X,0),U,1))
DO EN104
KILL A,X
QUIT
+4 IF $GET(PRCSAVE)="G"&(X'=$PIECE(^PRC(441.2,+X,0),U,1))
DO EN102
KILL A,X
QUIT
+5 ;
+6 IF $GET(PRCSAVE)="S"&(X=$PIECE(^PRC(441.2,+X,0),U,1))
DO EN103
KILL A,X
QUIT
+7 ;
+8 SET PRCHCI=+$PIECE(^PRC(444,DA(1),2,DA,0),U,5)
SET PRCHCPO=DA(1)
IF $DATA(^PRC(441,+PRCHCI,0))
DO EN8^PRCHCRD1
+9 if $DATA(PRCHSAVX)
SET X=PRCHSAVX
KILL PRCHSAVX
+10 QUIT
+11 ;
EN102 ;Stop assignment of a PSC to an item.
+1 SET A(1)="This is a Product Service Code - Not allowed on ITEMS!!"
+2 SET A(2,"F")="!"
+3 DO EN^DDIOL(.A)
+4 QUIT
+5 ;
EN103 ;Stop assignment of an FSC to a service.
+1 SET A(1)="This is a Federal Supply Classification Code - Not allowed on SERVICES!!"
+2 SET A(2,"F")="!"
+3 DO EN^DDIOL(.A)
+4 QUIT
+5 ;
EN104 ;Stop user if commodity code is missing.
+1 SET A(1)="Commodity Code missing on this Federal Supply Classification--Required for LOG code sheets!"
+2 SET A(2,"F")="!"
+3 DO EN^DDIOL(.A)
+4 QUIT
+5 ;
EN105 ;Stop a PO if a line item does not contain an FSC or PSC. This tag is
+1 ;called from the routine PRCHNP04. Do not clean up variables here.
+2 ;This check is for all POs that may be required by FPDS. PRC*5.1*100.
+3 IF $PIECE(^PRC(442,PRCHPO,1),U,7)]""
Begin DoDot:1
+4 SET PRCHITM=0
FOR
SET PRCHITM=$ORDER(^PRC(442,PRCHPO,2,PRCHITM))
if 'PRCHITM
QUIT
IF $PIECE($GET(^PRC(442,PRCHPO,2,PRCHITM,2)),U,3)=""
DO EN^DDIOL("Line item "_PRCHITM_" on this PO does not contain an FSC or PSC.","","!!?5")
SET ERROR=1
End DoDot:1
+5 ;End of changes for PRC*5.1*79
+6 QUIT
+7 ;
EN106 ;PRC*5.1*100: stop amended PO with line items lacking an FSC or PSC.
+1 IF $PIECE(^PRC(443.6,PRCHPO,1),U,7)]""
Begin DoDot:1
+2 SET PRCHITM=0
FOR
SET PRCHITM=$ORDER(^PRC(443.6,PRCHPO,2,PRCHITM))
if 'PRCHITM
QUIT
IF $PIECE($GET(^PRC(443.6,PRCHPO,2,PRCHITM,2)),U,3)=""
DO EN^DDIOL("Line item "_PRCHITM_" on this PO does not contain an FSC or PSC.","","!!?5")
SET ERROR=1
End DoDot:1
+3 QUIT
+4 ;
EN2 ;IF 'ESTIMATED P.O.' MOVE VERBAGE INTO COMMENTS
+1 DO EN2A
+2 if '$DATA(^PRC(442,PRCHPO,7))
QUIT
if $PIECE(^(7),U,3)'="Y"
QUIT
SET WX="*** ESTIMATED PURCHASE ORDER ***"
IF $DATA(^PRC(442,PRCHPO,4,1,0))
IF ^(0)[WX
KILL WX
QUIT
+3 SET WX=WX_" "
SET PRCH="^PRC(442,PRCHPO,4,"
DO WORD^PRCHUTL
KILL PRCH
+4 QUIT
+5 ;
EN2A ;CHECK DELIVERY SCHEDULES-QUANTITY DELIVERED MUST BE >0
+1 NEW NUM,J,K,DA
+2 SET NUM=$PIECE(^PRC(442,PRCHPO,0),U)
+3 IF $DATA(^PRC(442.8,"AC",NUM))
Begin DoDot:1
+4 FOR J=0:0
SET J=$ORDER(^PRC(442.8,"AC",NUM,J))
if J'>0
QUIT
Begin DoDot:2
+5 FOR K=0:0
SET K=$ORDER(^PRC(442.8,"AC",NUM,J,K))
if K'>0
QUIT
Begin DoDot:3
+6 IF $PIECE(^PRC(442.8,K,0),U,5)'>0
SET DIK="^PRC(442.8,"
SET DA=K
DO ^DIK
KILL DIK
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT
EN3 ;COMPLETE DEPOT/GSA PUSH ORDERS
+1 SET I=$PIECE(^PRC(442,PRCHPO,0),U,15)
+2 WRITE !!,"Total Dollar Amount: "_I_" //"
READ X:DTIME
if '$TEST
SET X="^"
if X=""
SET X=I
IF X["^"
SET X=1
GOTO EN31
+3 IF X=""!(X=0)
GOTO EN30
+4 IF X["?"
WRITE !!,"You can either enter the total dollar amount for the entire PUSH, or just the",!,"dollar amount for this part (regular, subsistence or drugs). This is just",!,"used to update the P.O.register."
GOTO EN3
+5 if X["$"
SET X=$PIECE(X,"$",2)
IF X'?.N.1".".2N!(X>9999999.99)!(X<1)
WRITE $CHAR(7),"??"
GOTO EN3
+6 SET $PIECE(^PRC(442,PRCHPO,0),U,15)=X
+7 ;
EN30 SET X=1
SET %A="Complete this Requisition "
SET %B="This action will change the status to 'Transaction Complete'."
SET %=1
DO ^PRCFYN
IF %=1
SET X=40
+1 ;
EN31 SET DA=PRCHPO
DO ENS^PRCHSTAT
+1 QUIT
+2 ;
EN6 ;FILE 442, SKU #9.4
+1 DO VEN
if '$DATA(X)!($PIECE(^PRC(442,DA(1),2,DA,0),U,5)="")
QUIT
+2 if '$DATA(PRC("SITE"))
SET PRC("SITE")=$PIECE($PIECE(^PRC(442,DA(1),0),U,1),"-",1)
SET PRCHCV=$PIECE(^PRC(442,DA(1),1),U,1)
SET PRCHCI=$PIECE(^(2,DA,0),U,5)
SET PRCHCPO=DA(1)
DO EN10^PRCHCRD1
+3 QUIT
+4 ;
EN7 ;FILE 442, UNIT CONVERSION FACTOR #9.7
+1 DO VEN
if '$DATA(X)!($PIECE(^PRC(442,DA(1),2,DA,0),U,5)="")
QUIT
+2 if '$DATA(PRC("SITE"))
SET PRC("SITE")=+^PRC(442,DA(1),0)
SET PRCHCV=+$PIECE(^PRC(442,DA(1),1),U,1)
SET PRCHCI=+$PIECE(^(2,DA,0),U,5)
SET PRCHCPO=DA(1)
DO EN11^PRCHCRD1
+3 QUIT
+4 ;
VEN IF $SELECT('$DATA(^PRC(442,DA(1),1)):1,$PIECE(^(1),U,1)="":1,1:0)
WRITE !!,"Vendor must be entered before items ! ",$CHAR(7)
KILL X
+1 QUIT
+2 ;
VENA IF $SELECT('$DATA(^PRC(442,DA,1)):1,$PIECE(^(1),U,1)="":1,1:0)
WRITE !!,"Vendor must be entered before items ! ",$CHAR(7)
KILL X
+1 QUIT
+2 ;
VEN1 IF $SELECT('$DATA(^PRC(443.6,DA(1),1)):1,$PIECE(^(1),U,1)="":1,1:0)
WRITE !!,"Vendor must be entered before items ! ",$CHAR(7)
KILL X
+1 QUIT
+2 ;
VEN1A IF $SELECT('$DATA(^PRC(443.6,DA,1)):1,$PIECE(^(1),U,1)="":1,1:0)
WRITE !!,"Vendor must be entered before items ! ",$CHAR(7)
KILL X
+1 QUIT
+2 ;
+3 ;
+4 ;
SUPBOC(QUIETLY) ;stmts.to compute pre-implied BOC, moved from template PRCH2138 into this routine and also called in BOC input transform
+1 NEW PRCHIDA,SPFCP,PRCHBOCC,ACCT
+2 if $GET(QUIETLY)=-1
SET X=$PIECE($GET(^PRC(442,DA(1),2,DA,0)),U,4)
+3 DO VEN
if '$DATA(X)
QUIT ""
+4 SET PRCHIDA=+$PIECE(^PRC(442,DA(1),2,DA,0),U,5)
SET SPFCP=+$PIECE(^PRC(442,DA(1),0),U,19)
+5 IF SPFCP=2
Begin DoDot:1
+6 SET PRCHN("SFC")=SPFCP
SET ACCT=$$ACCT^PRCPUX1($EXTRACT($$NSN^PRCPUX1(PRCHIDA),1,4))
+7 ;:$D(ACCT)
Begin DoDot:2
+8 SET PRCHBOCC=$PIECE($GET(^PRCD(420.2,$SELECT(ACCT=1:2697,ACCT=2:2698,ACCT=3:2699,ACCT=6:2699,ACCT=8:2696,1:2699),0)),U)
+9 IF PRCHBOCC
SET $PIECE(^PRC(442,DA(1),2,DA,0),U,4)=PRCHBOCC
Begin DoDot:3
+10 IF PRCHBOCC'=X
IF PRCHBOCC
if '$GET(QUIETLY)
WRITE !,?5,"BOC must be ",PRCHBOCC,!,?5,"For a supply fund order, a BOC ",X," is invalid.",!
SET X=PRCHBOCC
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT X
+12 ;
+13 ;
+14 ;
EN8 ;FILE 442, ITEM #40; BOC #3.5 -- Z0 must = BOC on entry
+1 NEW DIC
DO VEN
if '$DATA(X)
QUIT
+2 SET DIC="^PRCD(420.1,"_Z0_",1,"
SET DIC(0)="QEMZ"
+3 IF $PIECE(^PRC(442,DA(1),0),U,19)'=2
Begin DoDot:1
+4 DO ^DIC
if Y<0
KILL X
KILL Z0
+5 IF $DATA(X)
SET X=$PIECE(Y(0,0),"^",1)
Begin DoDot:2
+6 ;D EN2^PRCHNPO8
SET PRCHBOC=+Y
+7 WRITE !,X
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
+10 ;
EN88 ;FILE 442, EST. SHIPPING BOC #13.05 -- Z0 must = BOC on entry
+1 NEW DIC
DO VENA
if '$DATA(X)
QUIT
+2 SET DIC="^PRCD(420.1,"_Z0_",1,"
SET DIC(0)="QEMZ"
DO ^DIC
if Y<0
KILL X
KILL Z0
+3 IF $DATA(X)
SET X=$PIECE(Y(0,0),"^",1)
WRITE !,X
+4 QUIT
+5 ;
EN9 ;CHECK FOR PAYMENT FIELDS AND OTHER FIELDS IN VENDOR FILE
+1 ;CALLED FROM FILE 442 INPUT TEMPLATES.
+2 ;FLAG --is set to 1 in template when certain VENDOR conditions are met
+3 SET PRCHOV7=$GET(^PRC(440,+^PRC(442,D0,1),7))
if PRCHOV7=""
GOTO EXIT
+4 IF $PIECE(PRCHOV7,U,3)]""
IF ($PIECE(PRCHOV7,U,7)]"")
IF ($PIECE(PRCHOV7,U,8)]"")
IF ($PIECE(PRCHOV7,U,9)]"")
IF $PIECE(PRCHOV3,U,11)]""
IF $PIECE(PRCHOV3,U,14)]""
IF $PIECE(PRCHOV3,U,13)]""
IF FLAG
SET Y="@20"
GOTO EXIT
+5 SET VEN=+^PRC(442,D0,1)
SET %X="^PRC(440,VEN,"
SET %Y="^PRC(440.3,VEN,"
DO %XY^%RCR
KILL VEN
EXIT QUIT
+1 ;
EN12 ;UPDATE NATIONAL DRUG CODE #9.3
+1 DO VEN
if '$DATA(X)!($PIECE(^PRC(442,DA(1),2,DA,0),U,5)="")
QUIT
+2 if '$DATA(PRC("SITE"))
SET PRC("SITE")=$PIECE($PIECE(^PRC(442,DA(1),0),U,1),"-",1)
SET PRCHCV=$PIECE(^PRC(442,DA(1),1),U,1)
SET PRCHCI=$PIECE(^(2,DA,0),U,5)
SET PRCHCPO=DA(1)
DO EN12^PRCHCRD1
+3 QUIT
+4 ;
EN13 ;FILE 443.6, ITEM #40;BOC #3.5, EST. SHIPPING BOC #13.05
+1 DO VEN1
if '$DATA(X)
QUIT
SET DIC="^PRCD(420.1,"_Z0_",1,"
SET DIC(0)="QEMZ"
DO ^DIC
if Y<0
KILL X
KILL DIC,Z0
IF $DATA(X)
SET X=$PIECE(Y(0,0),"^",1)
WRITE !,X
+2 QUIT
EN133 ;FILE 443.6, EST. SHIPPING BOC #13.05
+1 DO VEN1A
if '$DATA(X)
QUIT
SET DIC="^PRCD(420.1,"_Z0_",1,"
SET DIC(0)="QEMZ"
DO ^DIC
if Y<0
KILL X
KILL DIC,Z0
IF $DATA(X)
SET X=$PIECE(Y(0,0),"^",1)
WRITE !,X
+2 QUIT
