- PRCHNPO5 ;WISC/RSD,RHD/DL-INPUT TRANSFORM FOR FILE 440,441,442 ;11/23/16 13:36
- V ;;5.1;IFCAP;**113,159,198**;Oct 20, 2000;Build 6
- ;Per VA Directive 6402, this routine should not be modified.
- ;
- EN1 ;FILE 442, FCP #1
- I '$D(PRCHAMND),$D(^PRCS(410,+$P(^PRC(442,DA,0),U,12),0)),+$P(^(0),"-",4)'=+X W !,"Fund Control Point cannot be changed since 2237 has been selected." K X Q
- S Z0=$E($P(^PRC(442,DA,0),"-",2),1,2),Z1=+X D EN4^PRCHNPO6 I '$T K X,Z0,Z1 Q
- S DIC="^PRC(420,PRC(""SITE""),1,",DIC(0)="QEMNZ"
- S:$D(PRCHPUSH) DIC("S")="I $P(^(0),U,12)=2"
- I $G(PRCHPC)!$G(PRCHDELV) S DIC("S")="I $D(^PRC(420,""C"",DUZ,PRC(""SITE""),+Y))"
- S D="B^C" D MIX^DIC1 K:Y<0!('$D(PRC("FY"))) X K DIC,PRCHCPO,Z0,Z1 Q:'$D(X)
- N CCNODE S CCNODE=$G(^PRC(420,PRC("SITE"),1,+Y,2,0)) I $P(CCNODE,U,4)'>0!(CCNODE="") W !,"The Fund Control Point selected by you, does not have any",!,"Cost Centers listed under it.",!,$P(Y,U,2) K X Q
- I $P(Y(0),U,12)'=2,$P(Y(0),U,18)="" W $C(7),!,"LOG Department Number is missing!!" K X Q
- S Z0=$P(^PRC(442,DA,0),U,2),Z1=$P(Y(0),U,12) I Z1 I ((Z0=3)&(Z1=3)) S Z0=$P(^PRCD(442.5,Z0,0),U,1) W $C(7),!,"Fund Control Point not valid for a "_Z0_" order." K Z0,Z1,X Q
- S Z0=$P(Y(0),U,1),PRC("FY")=$E(100+$E(PRC("FY"),2,3)+$E(PRC("FY"),4),2,3) S:$P(Y(0),U,10)]"" PRCHN("SVC")=$P($G(^DIC(49,+$P(Y(0),U,10),0)),U,1)
- I $D(^PRC(420,PRC("SITE"),1,+Y,2,0)),$P(^(0),U,4)=1,$D(^($P(^(0),U,3),0)),$D(^PRCD(420.1,+^(0),0)) S PRCHN("CC")=$P(^(0)," ",1)
- S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q
- S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1
- I $P($G(^PRC(420,PRC("SITE"),1,+X,0)),U,19)=1 W !,"Sorry, this FCP is inactive!",! K X Q
- Q
- ;
- EN2 ;FILE 442, COST CENTER #2
- S PRCFA("ALL")=1,DIC="^PRCD(420.1,",DIC(0)="QEMZ" D ^DIC K DIC,PRCFA("ALL") I Y'>0 W !,"The Cost Center entered by you is not in the COST CENTER FILE.",! K X,Y,Z0 Q
- I $P(Y(0),U,2)=1 W !,"The Cost Center entered by you has been DEACTIVATED.",! K X,Y,Z0 Q
- S X=+Y(0)
- S Z1=$G(^PRC(420,PRC("SITE"),1,Z0,2,+Y(0),0)) I Z1'>0!(Z1="") W !,"This Cost Center isn't found in FCP "_$P(^PRC(420,PRC("SITE"),1,Z0,0),U,1)_".",! K X,Y,Z0,Z1 Q
- N BOCNOD S BOCNOD=$G(^PRCD(420.1,+Y,1,0)) I $P(BOCNOD,U,4)'>0!(BOCNOD="") W !,"The Cost Center selected by you, does not have any BOCs listed",!,"under it.",! K X
- K Y,Z0,Z1 Q
- ;
- EN3 ;FILE 442, VENDOR #5
- N REP,REP1
- I DIE["PRC(442,",$D(DA),$D(^PRC(442,DA,2,"AE")) K X
- Q:'$D(X)!$G(PRCHPC)
- I '$G(PRCHDELV) D Q:'$G(X)
- . S DIC("S")="S Z0=+$P($G(^(2)),U,2) I "_$E("'",'$D(PRCHNRQ))_"Z0,'$D(^PRC(440,""AC"",""S"",Y))" I $D(PRCHPUSH) S DIC("S")=DIC("S")_",(Z0=1!(Z0=3))"
- . D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X Q:'$D(X) S PRCHNVF=Y
- Q:'$D(^PRC(440,X,2)) S Z0=^(2) I $P(^PRC(442,DA,0),U,2)=4,$P(Z0,U,11)'="Y" W $C(7),!,"This Vendor is not set up as a GUARANTEED DELIVERY Vendor!." K X,Z0 Q
- ;
- ; SEE IF VENDOR IS INACTIVE.
- ;
- I $P($G(^PRC(440,X,10)),U,5)=1 K X Q
- ;
- ;
- ;
- K PRCHEDI I $P($G(^PRC(440,X,3)),U,2)="Y" S PRCHEDI="" ;CHECK FOR EDI VENDOR
- I $D(^PRCD(420.8,+$P(Z0,U,2),0)) S PRCHN("SC")=$P(^(0),U,1)
- K Z0
- Q
- ;
- EN4 ;FILE 442, EST. SHIPPING AND/OR HANDLING #13
- S %A=" FOB is Destination, Are you sure you want Handling Charges ",%B="",%=1 D ^PRCFYN I %'=1 K X W !?3,"<DELETED>",$C(7)
- Q
- ;
- EN5 ;FILE 442, REPETITIVE (PR CARD) NO. #1.5
- I $P(^PRC(442,DA(1),0),U,3)=""!($P(^(1),U,1)="") W !!,"Fund Control Point and Vendor must be entered before items !",$C(7) K X Q
- S:'$D(PRC("SITE")) PRC("SITE")=+^PRC(442,DA(1),0) D LCK^PRCHCRD
- Q
- ;
- EN6 ;FILE 442, UNIT OF PURCHASE #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 EN0^PRCHCRD
- Q
- ;
- EN8 ;FILE 442, CONTRACT FIELD #4
- D VEN Q:'$D(X) K DIC("S")
- S Z0=$P(^PRC(442,DA(1),1),U,1),ZA=DA,ZA(1)=DA(1)
- S DA(1)=Z0,DIC="^PRC(440,Z0,4,",DIC(0)="QELMZ",DLAYGO=440
- I $G(PRCHPC)!$G(PRCHDELV) S DIC(0)="QEMZ"
- D EN10,^DIC S X=$P(Y,U,2),DA=ZA,DA(1)=ZA(1) K ZA K:Y'>0 X
- I $D(X),$D(DT),$P(Y(0),U,2)-DT<0 W !?10,"**CONTRACT HAS EXPIRED**",$C(7),$C(7) K X,DLAYGO Q
- S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1) I $P(^PRC(442,DA(1),2,DA,0),U,5)]"" S PRCHCI=$P(^(0),U,5),PRCHCV=Z0,PRCHCPO=DA(1) D EN2^PRCHCRD
- K DLAYGO
- Q
- ;
- EN9 ;FILE 442, ACTUAL UNIT COST #5
- 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 EN1^PRCHCRD
- Q
- ;
- EN10 ;FILE 440 CONTRACT NUMBER
- I $D(Z0) S:'$D(^PRC(440,Z0,4,0)) ^PRC(440,Z0,4,0)="^440.03I^^"
- Q
- ;
- EN11 ;FILE 441 CONTRACT
- D EN10 S DIC="^PRC(440,Z0,4,",DIC(0)="QEMLZ",DLAYGO=440,ZD=DA(1),DA(1)=Z0 D ^DIC S X=+Y K:Y'>0 X S DA(1)=ZD K ZD,Z0,DIC
- I $D(X),$D(DT),$P(Y(0),U,2)-DT<0 D EN^DDIOL("**CONTRACT HAS EXPIRED**","","!?10") K X
- K DLAYGO
- Q
- ;
- EN12 ;FILE 442, VENDOR STOCK NO.#9
- 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 EN6^PRCHCRD
- Q
- ;
- EN13 ;DIC("S") for a look-up in CONTRACT field (File 442.01,4)
- S PRCHSCOD=$P($G(^PRC(442,D0,1)),U,7)
- I $E(X)="?" S DIC("S")=$S(PRCHSCOD=2:"I $P(^PRC(440,Z0,4,+Y,0),U,6)'=""B""",1:"I 1")
- Q
- ;
- EN14 ;input transform of Contract Flag field 5, file 440
- ;If PO exists, if source code=2 & contract flag is not 'C' set it 'C'
- I $G(PRCHPO)>0 D
- . S PRCHNOD1=$G(^PRC(442,PRCHPO,1))
- . S PRCHSOCO=$P(PRCHNOD1,U,7)
- . I PRCHSOCO=2 Q:X="C" D Q
- . . S X="C"
- . . S ARR(1)=""
- . . S ARR(2)=" Note: "
- . . S ARR(3)=" This PO's Source Code is Open Market, only Contract # is a valid entry."
- . . S ARR(4)=" 'C' has been entered for the Contract Flag prompt."
- . . S ARR(5)=" 'B' is not allowed, system allows only 'C'."
- . . S ARR(6)=""
- . . D EN^DDIOL(.ARR)
- . . S XQH="PRCH CONTRACT FLAG HELP" D:$E(X)="??" EN^XQH
- . . Q
- . Q
- ; If Source code is not equal to 2, C or B is ok for contr. flag
- S MSG(1)=""
- S MSG(2)="Enter 'C' if the Contract Number field is a Contract #."
- S MSG(2,"F")="!,?5"
- S MSG(3)="Otherwise enter 'B' if it is a Basic Ordering Agreement(BOA) #."
- S MSG(3,"F")="!,?5"
- S MSG(4)=""
- ;I PRCHSOCO'=2 D EN^DDIOL(.MSG) H 2
- ;any other route than via po
- I X="B" D
- . S Z=$P(^PRC(440,DA(1),4,DA,0),U)
- . K:'(Z?.UN) X
- . I '$D(X) S XQH="PRCH BOA" D EN^XQH
- . K Z,XQH
- . Q
- 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
- ;
- ODATE ;PRC*5.1*159 'old date' handler call for P.O. Date exception in input template [PRCH DETAILED PURCHASE CARD]
- K ^PRC(442,"AB",+$P(^PRC(442,DA,1),U,15),DA)
- S $P(^PRC(442,DA,1),U,15)=""
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHNPO5 6918 printed Feb 18, 2025@23:35:20 Page 2
- PRCHNPO5 ;WISC/RSD,RHD/DL-INPUT TRANSFORM FOR FILE 440,441,442 ;11/23/16 13:36
- V ;;5.1;IFCAP;**113,159,198**;Oct 20, 2000;Build 6
- +1 ;Per VA Directive 6402, this routine should not be modified.
- +2 ;
- EN1 ;FILE 442, FCP #1
- +1 IF '$DATA(PRCHAMND)
- IF $DATA(^PRCS(410,+$PIECE(^PRC(442,DA,0),U,12),0))
- IF +$PIECE(^(0),"-",4)'=+X
- WRITE !,"Fund Control Point cannot be changed since 2237 has been selected."
- KILL X
- QUIT
- +2 SET Z0=$EXTRACT($PIECE(^PRC(442,DA,0),"-",2),1,2)
- SET Z1=+X
- DO EN4^PRCHNPO6
- IF '$TEST
- KILL X,Z0,Z1
- QUIT
- +3 SET DIC="^PRC(420,PRC(""SITE""),1,"
- SET DIC(0)="QEMNZ"
- +4 if $DATA(PRCHPUSH)
- SET DIC("S")="I $P(^(0),U,12)=2"
- +5 IF $GET(PRCHPC)!$GET(PRCHDELV)
- SET DIC("S")="I $D(^PRC(420,""C"",DUZ,PRC(""SITE""),+Y))"
- +6 SET D="B^C"
- DO MIX^DIC1
- if Y<0!('$DATA(PRC("FY")))
- KILL X
- KILL DIC,PRCHCPO,Z0,Z1
- if '$DATA(X)
- QUIT
- +7 NEW CCNODE
- SET CCNODE=$GET(^PRC(420,PRC("SITE"),1,+Y,2,0))
- IF $PIECE(CCNODE,U,4)'>0!(CCNODE="")
- WRITE !,"The Fund Control Point selected by you, does not have any",!,"Cost Centers listed under it.",!,$PIECE(Y,U,2)
- KILL X
- QUIT
- +8 IF $PIECE(Y(0),U,12)'=2
- IF $PIECE(Y(0),U,18)=""
- WRITE $CHAR(7),!,"LOG Department Number is missing!!"
- KILL X
- QUIT
- +9 SET Z0=$PIECE(^PRC(442,DA,0),U,2)
- SET Z1=$PIECE(Y(0),U,12)
- IF Z1
- IF ((Z0=3)&(Z1=3))
- SET Z0=$PIECE(^PRCD(442.5,Z0,0),U,1)
- WRITE $CHAR(7),!,"Fund Control Point not valid for a "_Z0_" order."
- KILL Z0,Z1,X
- QUIT
- +10 SET Z0=$PIECE(Y(0),U,1)
- SET PRC("FY")=$EXTRACT(100+$EXTRACT(PRC("FY"),2,3)+$EXTRACT(PRC("FY"),4),2,3)
- if $PIECE(Y(0),U,10)]""
- SET PRCHN("SVC")=$PIECE($GET(^DIC(49,+$PIECE(Y(0),U,10),0)),U,1)
- +11 IF $DATA(^PRC(420,PRC("SITE"),1,+Y,2,0))
- IF $PIECE(^(0),U,4)=1
- IF $DATA(^($PIECE(^(0),U,3),0))
- IF $DATA(^PRCD(420.1,+^(0),0))
- SET PRCHN("CC")=$PIECE(^(0)," ",1)
- +12 SET PRC("APP")=""
- SET X=Z0
- SET PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X)
- IF PRC("BBFY")=""
- QUIT
- +13 SET PRC("APP")=$PIECE($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11)
- KILL Z0,Z1
- +14 IF $PIECE($GET(^PRC(420,PRC("SITE"),1,+X,0)),U,19)=1
- WRITE !,"Sorry, this FCP is inactive!",!
- KILL X
- QUIT
- +15 QUIT
- +16 ;
- EN2 ;FILE 442, COST CENTER #2
- +1 SET PRCFA("ALL")=1
- SET DIC="^PRCD(420.1,"
- SET DIC(0)="QEMZ"
- DO ^DIC
- KILL DIC,PRCFA("ALL")
- IF Y'>0
- WRITE !,"The Cost Center entered by you is not in the COST CENTER FILE.",!
- KILL X,Y,Z0
- QUIT
- +2 IF $PIECE(Y(0),U,2)=1
- WRITE !,"The Cost Center entered by you has been DEACTIVATED.",!
- KILL X,Y,Z0
- QUIT
- +3 SET X=+Y(0)
- +4 SET Z1=$GET(^PRC(420,PRC("SITE"),1,Z0,2,+Y(0),0))
- IF Z1'>0!(Z1="")
- WRITE !,"This Cost Center isn't found in FCP "_$PIECE(^PRC(420,PRC("SITE"),1,Z0,0),U,1)_".",!
- KILL X,Y,Z0,Z1
- QUIT
- +5 NEW BOCNOD
- SET BOCNOD=$GET(^PRCD(420.1,+Y,1,0))
- IF $PIECE(BOCNOD,U,4)'>0!(BOCNOD="")
- WRITE !,"The Cost Center selected by you, does not have any BOCs listed",!,"under it.",!
- KILL X
- +6 KILL Y,Z0,Z1
- QUIT
- +7 ;
- EN3 ;FILE 442, VENDOR #5
- +1 NEW REP,REP1
- +2 IF DIE["PRC(442,"
- IF $DATA(DA)
- IF $DATA(^PRC(442,DA,2,"AE"))
- KILL X
- +3 if '$DATA(X)!$GET(PRCHPC)
- QUIT
- +4 IF '$GET(PRCHDELV)
- Begin DoDot:1
- +5 SET DIC("S")="S Z0=+$P($G(^(2)),U,2) I "_$EXTRACT("'",'$DATA(PRCHNRQ))_"Z0,'$D(^PRC(440,""AC"",""S"",Y))"
- IF $DATA(PRCHPUSH)
- SET DIC("S")=DIC("S")_",(Z0=1!(Z0=3))"
- +6 DO ^DIC
- KILL DIC
- SET DIC=DIE
- SET X=+Y
- if Y<0
- KILL X
- if '$DATA(X)
- QUIT
- SET PRCHNVF=Y
- End DoDot:1
- if '$GET(X)
- QUIT
- +7 if '$DATA(^PRC(440,X,2))
- QUIT
- SET Z0=^(2)
- IF $PIECE(^PRC(442,DA,0),U,2)=4
- IF $PIECE(Z0,U,11)'="Y"
- WRITE $CHAR(7),!,"This Vendor is not set up as a GUARANTEED DELIVERY Vendor!."
- KILL X,Z0
- QUIT
- +8 ;
- +9 ; SEE IF VENDOR IS INACTIVE.
- +10 ;
- +11 IF $PIECE($GET(^PRC(440,X,10)),U,5)=1
- KILL X
- QUIT
- +12 ;
- +13 ;
- +14 ;
- +15 ;CHECK FOR EDI VENDOR
- KILL PRCHEDI
- IF $PIECE($GET(^PRC(440,X,3)),U,2)="Y"
- SET PRCHEDI=""
- +16 IF $DATA(^PRCD(420.8,+$PIECE(Z0,U,2),0))
- SET PRCHN("SC")=$PIECE(^(0),U,1)
- +17 KILL Z0
- +18 QUIT
- +19 ;
- EN4 ;FILE 442, EST. SHIPPING AND/OR HANDLING #13
- +1 SET %A=" FOB is Destination, Are you sure you want Handling Charges "
- SET %B=""
- SET %=1
- DO ^PRCFYN
- IF %'=1
- KILL X
- WRITE !?3,"<DELETED>",$CHAR(7)
- +2 QUIT
- +3 ;
- EN5 ;FILE 442, REPETITIVE (PR CARD) NO. #1.5
- +1 IF $PIECE(^PRC(442,DA(1),0),U,3)=""!($PIECE(^(1),U,1)="")
- WRITE !!,"Fund Control Point and Vendor must be entered before items !",$CHAR(7)
- KILL X
- QUIT
- +2 if '$DATA(PRC("SITE"))
- SET PRC("SITE")=+^PRC(442,DA(1),0)
- DO LCK^PRCHCRD
- +3 QUIT
- +4 ;
- EN6 ;FILE 442, UNIT OF PURCHASE #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 EN0^PRCHCRD
- +3 QUIT
- +4 ;
- EN8 ;FILE 442, CONTRACT FIELD #4
- +1 DO VEN
- if '$DATA(X)
- QUIT
- KILL DIC("S")
- +2 SET Z0=$PIECE(^PRC(442,DA(1),1),U,1)
- SET ZA=DA
- SET ZA(1)=DA(1)
- +3 SET DA(1)=Z0
- SET DIC="^PRC(440,Z0,4,"
- SET DIC(0)="QELMZ"
- SET DLAYGO=440
- +4 IF $GET(PRCHPC)!$GET(PRCHDELV)
- SET DIC(0)="QEMZ"
- +5 DO EN10
- DO ^DIC
- SET X=$PIECE(Y,U,2)
- SET DA=ZA
- SET DA(1)=ZA(1)
- KILL ZA
- if Y'>0
- KILL X
- +6 IF $DATA(X)
- IF $DATA(DT)
- IF $PIECE(Y(0),U,2)-DT<0
- WRITE !?10,"**CONTRACT HAS EXPIRED**",$CHAR(7),$CHAR(7)
- KILL X,DLAYGO
- QUIT
- +7 if '$DATA(PRC("SITE"))
- SET PRC("SITE")=$PIECE($PIECE(^PRC(442,DA(1),0),U,1),"-",1)
- IF $PIECE(^PRC(442,DA(1),2,DA,0),U,5)]""
- SET PRCHCI=$PIECE(^(0),U,5)
- SET PRCHCV=Z0
- SET PRCHCPO=DA(1)
- DO EN2^PRCHCRD
- +8 KILL DLAYGO
- +9 QUIT
- +10 ;
- EN9 ;FILE 442, ACTUAL UNIT COST #5
- +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 EN1^PRCHCRD
- +3 QUIT
- +4 ;
- EN10 ;FILE 440 CONTRACT NUMBER
- +1 IF $DATA(Z0)
- if '$DATA(^PRC(440,Z0,4,0))
- SET ^PRC(440,Z0,4,0)="^440.03I^^"
- +2 QUIT
- +3 ;
- EN11 ;FILE 441 CONTRACT
- +1 DO EN10
- SET DIC="^PRC(440,Z0,4,"
- SET DIC(0)="QEMLZ"
- SET DLAYGO=440
- SET ZD=DA(1)
- SET DA(1)=Z0
- DO ^DIC
- SET X=+Y
- if Y'>0
- KILL X
- SET DA(1)=ZD
- KILL ZD,Z0,DIC
- +2 IF $DATA(X)
- IF $DATA(DT)
- IF $PIECE(Y(0),U,2)-DT<0
- DO EN^DDIOL("**CONTRACT HAS EXPIRED**","","!?10")
- KILL X
- +3 KILL DLAYGO
- +4 QUIT
- +5 ;
- EN12 ;FILE 442, VENDOR STOCK NO.#9
- +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 EN6^PRCHCRD
- +3 QUIT
- +4 ;
- EN13 ;DIC("S") for a look-up in CONTRACT field (File 442.01,4)
- +1 SET PRCHSCOD=$PIECE($GET(^PRC(442,D0,1)),U,7)
- +2 IF $EXTRACT(X)="?"
- SET DIC("S")=$SELECT(PRCHSCOD=2:"I $P(^PRC(440,Z0,4,+Y,0),U,6)'=""B""",1:"I 1")
- +3 QUIT
- +4 ;
- EN14 ;input transform of Contract Flag field 5, file 440
- +1 ;If PO exists, if source code=2 & contract flag is not 'C' set it 'C'
- +2 IF $GET(PRCHPO)>0
- Begin DoDot:1
- +3 SET PRCHNOD1=$GET(^PRC(442,PRCHPO,1))
- +4 SET PRCHSOCO=$PIECE(PRCHNOD1,U,7)
- +5 IF PRCHSOCO=2
- if X="C"
- QUIT
- Begin DoDot:2
- +6 SET X="C"
- +7 SET ARR(1)=""
- +8 SET ARR(2)=" Note: "
- +9 SET ARR(3)=" This PO's Source Code is Open Market, only Contract # is a valid entry."
- +10 SET ARR(4)=" 'C' has been entered for the Contract Flag prompt."
- +11 SET ARR(5)=" 'B' is not allowed, system allows only 'C'."
- +12 SET ARR(6)=""
- +13 DO EN^DDIOL(.ARR)
- +14 SET XQH="PRCH CONTRACT FLAG HELP"
- if $EXTRACT(X)="??"
- DO EN^XQH
- +15 QUIT
- End DoDot:2
- QUIT
- +16 QUIT
- End DoDot:1
- +17 ; If Source code is not equal to 2, C or B is ok for contr. flag
- +18 SET MSG(1)=""
- +19 SET MSG(2)="Enter 'C' if the Contract Number field is a Contract #."
- +20 SET MSG(2,"F")="!,?5"
- +21 SET MSG(3)="Otherwise enter 'B' if it is a Basic Ordering Agreement(BOA) #."
- +22 SET MSG(3,"F")="!,?5"
- +23 SET MSG(4)=""
- +24 ;I PRCHSOCO'=2 D EN^DDIOL(.MSG) H 2
- +25 ;any other route than via po
- +26 IF X="B"
- Begin DoDot:1
- +27 SET Z=$PIECE(^PRC(440,DA(1),4,DA,0),U)
- +28 if '(Z?.UN)
- KILL X
- +29 IF '$DATA(X)
- SET XQH="PRCH BOA"
- DO EN^XQH
- +30 KILL Z,XQH
- +31 QUIT
- End DoDot:1
- +32 QUIT
- +33 ;
- 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 ;
- ODATE ;PRC*5.1*159 'old date' handler call for P.O. Date exception in input template [PRCH DETAILED PURCHASE CARD]
- +1 KILL ^PRC(442,"AB",+$PIECE(^PRC(442,DA,1),U,15),DA)
- +2 SET $PIECE(^PRC(442,DA,1),U,15)=""
- +3 QUIT