PRCH442 ;WISC/KMB/DL/DXH - CREATE PURCHASE CARD ORDER FROM RIL ;12.1.99
;;5.1;IFCAP;**13,81,165**;Oct 20, 2000;Build 12
;Per VHA Directive 2004-038, this routine should not be modified.
START ; entry point for delivery orders
S1 N RLFLAG S RLFLAG=1
S2 ; entry point for purchase card orders
N RPUSE,SS,FSC,AA,BB,CC,EE,FF,CP,FCP,IB,J,ITEM,UCOST,MAX,PMULT,VSTOCK,VENDOR,VENDOR1,NDC,CONT,UOP,CONV,SKU,SPEC,APP,QTY,ORDTOT,PDA,CTT,CNNT,NCOST,COSTTOT,REQCT
N HM,CCDA,II,PP,IB,IJ,CTT,CTR,OUTRL,SERV,TDATE,CNNT1,ZS,ZS0,XDA,YDA,WHSE,COMMENT,PRCS,PRCVDYN,PRCKILL,GG
W ! S DIC="^PRCS(410.3,",DIC(0)="AEMQ",DIC("S")="S PRC(""SITE"")=+^(0),PRC(""CP"")=$P(^(0),""-"",4),$P(^(0),U,5)="""" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))" D ^DIC K DIC("S") Q:Y'>0
K DIC S (YDA,XDA,DA)=+Y
S:'$D(PRC("SST")) PRC("SST")="" S DIC("B")=PRC("SST") I $D(^PRC(411,"UP",+PRC("SITE"))) S DIC="^PRC(411,",DIC(0)="AEQZS",DIC("A")="Select SUBSTATION: ",DIC("S")="I $E($G(^PRC(411,+Y,0)),1,3)=PRC(""SITE"")" D ^DIC I Y>0 S PRC("SST")=+Y
K DIC Q:Y'>0
I '$D(PRC("PARAM")) S PRC("PARAM")=$$NODE^PRC0B("^PRC(411,PRC(""SITE""),",0)
S COMMENT="purchase card",WHSE=+$O(^PRC(440,"AC","S",0)) S:$G(RLFLAG)=1 COMMENT="delivery"
; introducing prcsip as package-wide
S OUTRL=0,PRCSIP=$P(^PRCS(410.3,XDA,0),U,3)
S CTT=$P($G(^PRCS(410.3,XDA,1,0)),"^",4) I +CTT=0 W !,"There are no items on this repetitive item list." Q
;
;See NOIS MON-0399-51726
KILL ^TMP($J)
S IB=0,PRCVDYN=0
;
; PRC*5.1*81 set flag (PRCVDYN) for DynaMed RIL
I $O(^PRCV(414.02,"C",$P(^PRCS(410.3,XDA,0),"^",1),0))]"" S PRCVDYN=1
;
F S IB=$O(^PRCS(410.3,XDA,1,IB)) Q:'IB D ;
. S FF=$G(^PRCS(410.3,XDA,1,IB,0))
. S ^TMP($J,410.3,XDA,1,"AC",$P(FF,"^",3)_";"_$P(FF,"^",5),IB)=""
;
W !,"This repetitive item list has the following vendors:",!
;
S HM=""
F S HM=$O(^TMP($J,410.3,XDA,1,"AC",HM)) Q:HM="" D
. W !,$P(HM,";"),?40,"NUMBER: ",$P(HM,";",2)
;
W !
S ZS=$P(^PRCS(410.3,XDA,0),"^"),PRC("SITE")=$P(ZS,"-"),CP=+$P(ZS,"-",4),CCEN=$P(ZS,"-",5)
D FY
S SPEC=$P($G(^PRC(420,PRC("SITE"),1,CP,0)),"^",12),(FCP,PRC("CP"))=$P($G(^PRC(420,PRC("SITE"),1,CP,0)),"^"),SERV=$P($G(^(0)),"^",10)
S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP")),APP=$P($$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY")),"^",11)
PROCESS ;
; get item data from repetitive item list
S VENDOR1=0,(REQCT,COSTTOT,IB)=0
F S VENDOR1=$O(^TMP($J,410.3,XDA,1,"AC",VENDOR1)) Q:VENDOR1="" D PROCESS1
W !!!,"Total number of requests generated: ",REQCT,!,"Total cost of all requests: $",$J(COSTTOT,0,2)
Q:REQCT=0
W !,"Generating ",COMMENT," orders...."
I $D(EE($J)) S PP="",RPUSE=1 F S PP=$O(EE($J,PP)) Q:PP="" S DA=PP D
.K CCDA D ^PRCH410
.I $G(CCDA)'="" W !,"Request ",$P(^PRCS(410,CCDA,0),"^")," created.",!
;
; PRC*5.1*81 if DynaMed RIL and trouble with item, save RIL# to ^TMP
I PRCVDYN,$O(^TMP($J,"PRCVHMSG","")) S ^TMP($J,"PRCVHMSG",YDA)=$P(^PRCS(410.3,YDA,0),"^",1)
;
D RENUM^PRCH442A
SLIST S PRCKILL=0 I 'PRCVDYN D
. I $G(^PRCS(410.3,YDA,0))'="" S %=2 W !,"Do you wish to re-use this list" D YN^DICN G:%=0 SLIST I %=2 S PRCKILL=1
;
; PRC*5.1*81 - send DynaMed a cancel txn for any items not moved to a PC
I PRCVDYN D
. I +$O(^PRCS(410.3,YDA,1,0))>0 D EN^PRCVRCA(YDA)
;
I PRCVDYN!PRCKILL S DA=YDA,DIK="^PRCS(410.3," D ^DIK K DIK
;
; PRC*5.1*81 - send message to user of problems found
I PRCVDYN,$O(^TMP($J,"PRCVHMSG","")) D DYNAMSG
;
W !,"End of processing."
K RLFLAG,PRCHPC,PRCS,^TMP($J) QUIT
;
PROCESS1 ;
N PRCVDATE
S NCOST=0,CNNT=0,PRCVDATE=""
S IB=$O(^TMP($J,410.3,XDA,1,"AC",VENDOR1,0)),VENDOR=$P($G(^PRCS(410.3,XDA,1,IB,0)),"^",5)
I VENDOR="" Q
I VENDOR=WHSE,$G(SPEC)'=2 Q
I OUTRL=1 Q
I $G(RLFLAG) N ITMCKER S ITMCKER=0 D ITMCK K % Q:ITMCKER ;PRC*5.1*165 for item exclusion for no vendor contract# on Delivery Order
S IB=0 F S IB=$O(^TMP($J,410.3,XDA,1,"AC",VENDOR1,IB)) Q:IB="" D ITEM Q:OUTRL
Q:CNNT=0
K PDA D SETUP^PRCH442A
I '$D(PDA) Q
S REQCT=REQCT+1,COSTTOT=COSTTOT+NCOST
W !,"Request ",$P($G(^PRC(442,PDA,0)),"^")," has been created."
W !,"The vendor for this request is: ",$P(VENDOR1,";")," "
W "(",$P(VENDOR1,";",2),")"
W !,"Total cost of request: $",$J(NCOST,0,2),!,"Total items on ",COMMENT," request: ",CNNT
QUIT
ITEM ;
S SS=$G(^PRCS(410.3,XDA,1,IB,0))
I $G(RLFLAG)=1,$P(SS,"^",6)'="Y" Q
S ITEM=$P(SS,"^"),QTY=$P(SS,"^",2),EST=$P(SS,"^",4)
I '$D(^PRC(441,+ITEM,2,+VENDOR,0)) Q
S ZS0=$G(^PRC(441,ITEM,2,VENDOR,0))
S ZS=$G(^PRC(441,ITEM,0)),NSN=$P(ZS,"^",5),BOC=$P(ZS,"^",10),FSC=$P(ZS,"^",3)
I SPEC=2 S BOC=$$ACCT^PRCPUX1($E($$NSN^PRCPUX1(ITEM),1,4)) S BOC=$S(BOC=1:2697,BOC=1:2698,BOC=8:2696,1:2699)
I BOC'="" S BOC=$P($G(^PRCD(420.2,BOC,0)),"^"),BOC=$E(BOC,1,30)
S SKU=$P($G(^PRC(441,ITEM,3)),"^",8)
S UCOST=$P(ZS0,"^",2),CONT=$P(ZS0,"^",3),VSTOCK=$P(ZS0,"^",4),NDC=$P(ZS0,"^",5),UOP=$P(ZS0,"^",7),PMULT=$P(ZS0,"^",8),MAX=$P(ZS0,"^",9),CONV=$P(ZS0,"^",10)
S:CONT'="" CONT=$P($G(^PRC(440,+VENDOR,4,CONT,0)),"^")
S CNNT=CNNT+1
S AA(CNNT)=CNNT_"^"_QTY_"^"_UOP_"^"_BOC_"^"_ITEM_"^"_VSTOCK_"^"_UCOST_"^^"_UCOST_"^^^"_PMULT_"^"_NSN_"^"_MAX_"^"_NDC_"^"_SKU_"^"_CONV
; enter item description from file
S CNNT1=$P($G(^PRC(441,ITEM,1,0)),"^",4)
I CNNT1'="" F J=1:1:CNNT1 S BB(CNNT,J)=$G(^PRC(441,ITEM,1,J,0))
S TOTAL=QTY*UCOST,CC(CNNT)=TOTAL_"^"_CONT_"^"_FSC,NCOST=NCOST+TOTAL
;
; PRC*5.1*81 - save DM DOC ID and earliest DATE NEEDED BY, set any problems into ^TMP
I PRCVDYN D
. S $P(CC(CNNT),"^",15)=$P(^PRCS(410.3,XDA,1,IB,0),"^",7) ; DM DOC ID
. I $P(CC(CNNT),"^",15)']"" S ^TMP($J,"PRCVHMSG",XDA,ITEM)="<missing>" ; no DOCID
. I $P(SS,"^",8)>0,$P(SS,"^",8)<PRCVDATE S PRCVDATE=$P(SS,"^",8)
. I PRCVDATE="" S PRCVDATE=$P(SS,"^",8)
;
I $P(SS,"^",6)="Y" S $P(^PRCS(410.3,XDA,1,IB,0),"^",6)="O"
S GG(CNNT)=IB
QUIT
;
FY D NOW^%DTC S TDATE=X,SDATE=$$FMADD^XLFDT(TDATE,10),(FY,PRC("FY"))=$E(X,2,3),QTR=$E(X,4,5),PRC("QTR")=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",+QTR)
I PRC("QTR")=1 S FY=$E(100+FY+1,2,3),PRC("FY")=FY
QUIT
;
DYNAMSG ; PRC*5.1*81 - Build message to user of items not in audit file
N I,XMB,PRCDATA,PRCNT,PRCVI,PRCVIEN,PRCRIL
S PRCVIEN=$O(^TMP($J,"PRCVHMSG",0)) Q:+PRCVIEN=0
S PRCRIL=^TMP($J,"PRCVHMSG",PRCVIEN)
S XMB(1)=" generating PC orders from RIL# "_PRCRIL
S XMB(2)=" <SEE BELOW>"
S XMB(3)=" unable to enter PO# for item in audit file (#414.02)"
S PRCVI=0,PRCNT=0
F S PRCVI=$O(^TMP($J,"PRCVHMSG",PRCVIEN,PRCVI)) Q:+PRCVI=0 D
. S PRCDATA=$G(^TMP($J,"PRCVHMSG",PRCVIEN,PRCVI))
. F I=1,2 I $P(PRCDATA,"^",I)']"" S $P(PRCDATA,"^",I)="<missing>"
. S PRCNT=PRCNT+1
. S ^TMP($J,"PRCV442M",PRCNT)="ITEM# "_PRCVI_" placed on PO# "_$P(PRCDATA,"^",2)_" has DM DOC ID# "_$P(PRCDATA,"^",1)
D DMERXMB^PRCVLIC("PRCV442M",+PRCRIL,$P(PRCRIL,"-",4))
Q
ITMCK ;PRC*5.1*165 Checks to notify user of items with missing contract number that
; will be excluded from Delivery Order
N IB,CNT,ECNT,ITEMR
S IB=0,CNT=0,ECNT=0
F S IB=$O(^TMP($J,410.3,XDA,1,"AC",VENDOR1,IB)) Q:IB="" D
. S CNT=CNT+1
. S ITEMR=$G(^PRCS(410.3,XDA,1,IB,0)) Q:$P(ITEMR,"^",6)="Y"
. S ECNT=ECNT+1 I ECNT=1 W !!,"Excluded item(s) with no vendor contract#: "
. W !!,?5,+ITEMR,?13,$E($P($G(^PRC(441,+ITEMR,0)),"^",2),1,30),?47,"QTY= ",$P(ITEMR,"^",2),?60,"COST: ",$J($FN($P(ITEMR,"^",4),",",2),9)
Q:'ECNT
I ECNT=CNT W ! S DIR("A")=">> Cannot continue with delivery order as all items have no associated contract# <Hit return to continue>",DIR(0)="EA" D ^DIR K DIR S ITMCKER=1 Q
S %=2 W !!,"Do you wish to continue with this order excluding the above item(s)" D YN^DICN Q:%=1
S ITMCKER=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCH442 7704 printed Sep 23, 2025@19:41:18 Page 2
PRCH442 ;WISC/KMB/DL/DXH - CREATE PURCHASE CARD ORDER FROM RIL ;12.1.99
+1 ;;5.1;IFCAP;**13,81,165**;Oct 20, 2000;Build 12
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
START ; entry point for delivery orders
S1 NEW RLFLAG
SET RLFLAG=1
S2 ; entry point for purchase card orders
+1 NEW RPUSE,SS,FSC,AA,BB,CC,EE,FF,CP,FCP,IB,J,ITEM,UCOST,MAX,PMULT,VSTOCK,VENDOR,VENDOR1,NDC,CONT,UOP,CONV,SKU,SPEC,APP,QTY,ORDTOT,PDA,CTT,CNNT,NCOST,COSTTOT,REQCT
+2 NEW HM,CCDA,II,PP,IB,IJ,CTT,CTR,OUTRL,SERV,TDATE,CNNT1,ZS,ZS0,XDA,YDA,WHSE,COMMENT,PRCS,PRCVDYN,PRCKILL,GG
+3 WRITE !
SET DIC="^PRCS(410.3,"
SET DIC(0)="AEMQ"
SET DIC("S")="S PRC(""SITE"")=+^(0),PRC(""CP"")=$P(^(0),""-"",4),$P(^(0),U,5)="""" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
DO ^DIC
KILL DIC("S")
if Y'>0
QUIT
+4 KILL DIC
SET (YDA,XDA,DA)=+Y
+5 if '$DATA(PRC("SST"))
SET PRC("SST")=""
SET DIC("B")=PRC("SST")
IF $DATA(^PRC(411,"UP",+PRC("SITE")))
SET DIC="^PRC(411,"
SET DIC(0)="AEQZS"
SET DIC("A")="Select SUBSTATION: "
SET DIC("S")="I $E($G(^PRC(411,+Y,0)),1,3)=PRC(""SITE"")"
DO ^DIC
IF Y>0
SET PRC("SST")=+Y
+6 KILL DIC
if Y'>0
QUIT
+7 IF '$DATA(PRC("PARAM"))
SET PRC("PARAM")=$$NODE^PRC0B("^PRC(411,PRC(""SITE""),",0)
+8 SET COMMENT="purchase card"
SET WHSE=+$ORDER(^PRC(440,"AC","S",0))
if $GET(RLFLAG)=1
SET COMMENT="delivery"
+9 ; introducing prcsip as package-wide
+10 SET OUTRL=0
SET PRCSIP=$PIECE(^PRCS(410.3,XDA,0),U,3)
+11 SET CTT=$PIECE($GET(^PRCS(410.3,XDA,1,0)),"^",4)
IF +CTT=0
WRITE !,"There are no items on this repetitive item list."
QUIT
+12 ;
+13 ;See NOIS MON-0399-51726
+14 KILL ^TMP($JOB)
+15 SET IB=0
SET PRCVDYN=0
+16 ;
+17 ; PRC*5.1*81 set flag (PRCVDYN) for DynaMed RIL
+18 IF $ORDER(^PRCV(414.02,"C",$PIECE(^PRCS(410.3,XDA,0),"^",1),0))]""
SET PRCVDYN=1
+19 ;
+20 ;
FOR
SET IB=$ORDER(^PRCS(410.3,XDA,1,IB))
if 'IB
QUIT
Begin DoDot:1
+21 SET FF=$GET(^PRCS(410.3,XDA,1,IB,0))
+22 SET ^TMP($JOB,410.3,XDA,1,"AC",$PIECE(FF,"^",3)_";"_$PIECE(FF,"^",5),IB)=""
End DoDot:1
+23 ;
+24 WRITE !,"This repetitive item list has the following vendors:",!
+25 ;
+26 SET HM=""
+27 FOR
SET HM=$ORDER(^TMP($JOB,410.3,XDA,1,"AC",HM))
if HM=""
QUIT
Begin DoDot:1
+28 WRITE !,$PIECE(HM,";"),?40,"NUMBER: ",$PIECE(HM,";",2)
End DoDot:1
+29 ;
+30 WRITE !
+31 SET ZS=$PIECE(^PRCS(410.3,XDA,0),"^")
SET PRC("SITE")=$PIECE(ZS,"-")
SET CP=+$PIECE(ZS,"-",4)
SET CCEN=$PIECE(ZS,"-",5)
+32 DO FY
+33 SET SPEC=$PIECE($GET(^PRC(420,PRC("SITE"),1,CP,0)),"^",12)
SET (FCP,PRC("CP"))=$PIECE($GET(^PRC(420,PRC("SITE"),1,CP,0)),"^")
SET SERV=$PIECE($GET(^(0)),"^",10)
+34 SET PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"))
SET APP=$PIECE($$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY")),"^",11)
PROCESS ;
+1 ; get item data from repetitive item list
+2 SET VENDOR1=0
SET (REQCT,COSTTOT,IB)=0
+3 FOR
SET VENDOR1=$ORDER(^TMP($JOB,410.3,XDA,1,"AC",VENDOR1))
if VENDOR1=""
QUIT
DO PROCESS1
+4 WRITE !!!,"Total number of requests generated: ",REQCT,!,"Total cost of all requests: $",$JUSTIFY(COSTTOT,0,2)
+5 if REQCT=0
QUIT
+6 WRITE !,"Generating ",COMMENT," orders...."
+7 IF $DATA(EE($JOB))
SET PP=""
SET RPUSE=1
FOR
SET PP=$ORDER(EE($JOB,PP))
if PP=""
QUIT
SET DA=PP
Begin DoDot:1
+8 KILL CCDA
DO ^PRCH410
+9 IF $GET(CCDA)'=""
WRITE !,"Request ",$PIECE(^PRCS(410,CCDA,0),"^")," created.",!
End DoDot:1
+10 ;
+11 ; PRC*5.1*81 if DynaMed RIL and trouble with item, save RIL# to ^TMP
+12 IF PRCVDYN
IF $ORDER(^TMP($JOB,"PRCVHMSG",""))
SET ^TMP($JOB,"PRCVHMSG",YDA)=$PIECE(^PRCS(410.3,YDA,0),"^",1)
+13 ;
+14 DO RENUM^PRCH442A
SLIST SET PRCKILL=0
IF 'PRCVDYN
Begin DoDot:1
+1 IF $GET(^PRCS(410.3,YDA,0))'=""
SET %=2
WRITE !,"Do you wish to re-use this list"
DO YN^DICN
if %=0
GOTO SLIST
IF %=2
SET PRCKILL=1
End DoDot:1
+2 ;
+3 ; PRC*5.1*81 - send DynaMed a cancel txn for any items not moved to a PC
+4 IF PRCVDYN
Begin DoDot:1
+5 IF +$ORDER(^PRCS(410.3,YDA,1,0))>0
DO EN^PRCVRCA(YDA)
End DoDot:1
+6 ;
+7 IF PRCVDYN!PRCKILL
SET DA=YDA
SET DIK="^PRCS(410.3,"
DO ^DIK
KILL DIK
+8 ;
+9 ; PRC*5.1*81 - send message to user of problems found
+10 IF PRCVDYN
IF $ORDER(^TMP($JOB,"PRCVHMSG",""))
DO DYNAMSG
+11 ;
+12 WRITE !,"End of processing."
+13 KILL RLFLAG,PRCHPC,PRCS,^TMP($JOB)
QUIT
+14 ;
PROCESS1 ;
+1 NEW PRCVDATE
+2 SET NCOST=0
SET CNNT=0
SET PRCVDATE=""
+3 SET IB=$ORDER(^TMP($JOB,410.3,XDA,1,"AC",VENDOR1,0))
SET VENDOR=$PIECE($GET(^PRCS(410.3,XDA,1,IB,0)),"^",5)
+4 IF VENDOR=""
QUIT
+5 IF VENDOR=WHSE
IF $GET(SPEC)'=2
QUIT
+6 IF OUTRL=1
QUIT
+7 ;PRC*5.1*165 for item exclusion for no vendor contract# on Delivery Order
IF $GET(RLFLAG)
NEW ITMCKER
SET ITMCKER=0
DO ITMCK
KILL %
if ITMCKER
QUIT
+8 SET IB=0
FOR
SET IB=$ORDER(^TMP($JOB,410.3,XDA,1,"AC",VENDOR1,IB))
if IB=""
QUIT
DO ITEM
if OUTRL
QUIT
+9 if CNNT=0
QUIT
+10 KILL PDA
DO SETUP^PRCH442A
+11 IF '$DATA(PDA)
QUIT
+12 SET REQCT=REQCT+1
SET COSTTOT=COSTTOT+NCOST
+13 WRITE !,"Request ",$PIECE($GET(^PRC(442,PDA,0)),"^")," has been created."
+14 WRITE !,"The vendor for this request is: ",$PIECE(VENDOR1,";")," "
+15 WRITE "(",$PIECE(VENDOR1,";",2),")"
+16 WRITE !,"Total cost of request: $",$JUSTIFY(NCOST,0,2),!,"Total items on ",COMMENT," request: ",CNNT
+17 QUIT
ITEM ;
+1 SET SS=$GET(^PRCS(410.3,XDA,1,IB,0))
+2 IF $GET(RLFLAG)=1
IF $PIECE(SS,"^",6)'="Y"
QUIT
+3 SET ITEM=$PIECE(SS,"^")
SET QTY=$PIECE(SS,"^",2)
SET EST=$PIECE(SS,"^",4)
+4 IF '$DATA(^PRC(441,+ITEM,2,+VENDOR,0))
QUIT
+5 SET ZS0=$GET(^PRC(441,ITEM,2,VENDOR,0))
+6 SET ZS=$GET(^PRC(441,ITEM,0))
SET NSN=$PIECE(ZS,"^",5)
SET BOC=$PIECE(ZS,"^",10)
SET FSC=$PIECE(ZS,"^",3)
+7 IF SPEC=2
SET BOC=$$ACCT^PRCPUX1($EXTRACT($$NSN^PRCPUX1(ITEM),1,4))
SET BOC=$SELECT(BOC=1:2697,BOC=1:2698,BOC=8:2696,1:2699)
+8 IF BOC'=""
SET BOC=$PIECE($GET(^PRCD(420.2,BOC,0)),"^")
SET BOC=$EXTRACT(BOC,1,30)
+9 SET SKU=$PIECE($GET(^PRC(441,ITEM,3)),"^",8)
+10 SET UCOST=$PIECE(ZS0,"^",2)
SET CONT=$PIECE(ZS0,"^",3)
SET VSTOCK=$PIECE(ZS0,"^",4)
SET NDC=$PIECE(ZS0,"^",5)
SET UOP=$PIECE(ZS0,"^",7)
SET PMULT=$PIECE(ZS0,"^",8)
SET MAX=$PIECE(ZS0,"^",9)
SET CONV=$PIECE(ZS0,"^",10)
+11 if CONT'=""
SET CONT=$PIECE($GET(^PRC(440,+VENDOR,4,CONT,0)),"^")
+12 SET CNNT=CNNT+1
+13 SET AA(CNNT)=CNNT_"^"_QTY_"^"_UOP_"^"_BOC_"^"_ITEM_"^"_VSTOCK_"^"_UCOST_"^^"_UCOST_"^^^"_PMULT_"^"_NSN_"^"_MAX_"^"_NDC_"^"_SKU_"^"_CONV
+14 ; enter item description from file
+15 SET CNNT1=$PIECE($GET(^PRC(441,ITEM,1,0)),"^",4)
+16 IF CNNT1'=""
FOR J=1:1:CNNT1
SET BB(CNNT,J)=$GET(^PRC(441,ITEM,1,J,0))
+17 SET TOTAL=QTY*UCOST
SET CC(CNNT)=TOTAL_"^"_CONT_"^"_FSC
SET NCOST=NCOST+TOTAL
+18 ;
+19 ; PRC*5.1*81 - save DM DOC ID and earliest DATE NEEDED BY, set any problems into ^TMP
+20 IF PRCVDYN
Begin DoDot:1
+21 ; DM DOC ID
SET $PIECE(CC(CNNT),"^",15)=$PIECE(^PRCS(410.3,XDA,1,IB,0),"^",7)
+22 ; no DOCID
IF $PIECE(CC(CNNT),"^",15)']""
SET ^TMP($JOB,"PRCVHMSG",XDA,ITEM)="<missing>"
+23 IF $PIECE(SS,"^",8)>0
IF $PIECE(SS,"^",8)<PRCVDATE
SET PRCVDATE=$PIECE(SS,"^",8)
+24 IF PRCVDATE=""
SET PRCVDATE=$PIECE(SS,"^",8)
End DoDot:1
+25 ;
+26 IF $PIECE(SS,"^",6)="Y"
SET $PIECE(^PRCS(410.3,XDA,1,IB,0),"^",6)="O"
+27 SET GG(CNNT)=IB
+28 QUIT
+29 ;
FY DO NOW^%DTC
SET TDATE=X
SET SDATE=$$FMADD^XLFDT(TDATE,10)
SET (FY,PRC("FY"))=$EXTRACT(X,2,3)
SET QTR=$EXTRACT(X,4,5)
SET PRC("QTR")=$PIECE("2^2^2^3^3^3^4^4^4^1^1^1","^",+QTR)
+1 IF PRC("QTR")=1
SET FY=$EXTRACT(100+FY+1,2,3)
SET PRC("FY")=FY
+2 QUIT
+3 ;
DYNAMSG ; PRC*5.1*81 - Build message to user of items not in audit file
+1 NEW I,XMB,PRCDATA,PRCNT,PRCVI,PRCVIEN,PRCRIL
+2 SET PRCVIEN=$ORDER(^TMP($JOB,"PRCVHMSG",0))
if +PRCVIEN=0
QUIT
+3 SET PRCRIL=^TMP($JOB,"PRCVHMSG",PRCVIEN)
+4 SET XMB(1)=" generating PC orders from RIL# "_PRCRIL
+5 SET XMB(2)=" <SEE BELOW>"
+6 SET XMB(3)=" unable to enter PO# for item in audit file (#414.02)"
+7 SET PRCVI=0
SET PRCNT=0
+8 FOR
SET PRCVI=$ORDER(^TMP($JOB,"PRCVHMSG",PRCVIEN,PRCVI))
if +PRCVI=0
QUIT
Begin DoDot:1
+9 SET PRCDATA=$GET(^TMP($JOB,"PRCVHMSG",PRCVIEN,PRCVI))
+10 FOR I=1,2
IF $PIECE(PRCDATA,"^",I)']""
SET $PIECE(PRCDATA,"^",I)="<missing>"
+11 SET PRCNT=PRCNT+1
+12 SET ^TMP($JOB,"PRCV442M",PRCNT)="ITEM# "_PRCVI_" placed on PO# "_$PIECE(PRCDATA,"^",2)_" has DM DOC ID# "_$PIECE(PRCDATA,"^",1)
End DoDot:1
+13 DO DMERXMB^PRCVLIC("PRCV442M",+PRCRIL,$PIECE(PRCRIL,"-",4))
+14 QUIT
ITMCK ;PRC*5.1*165 Checks to notify user of items with missing contract number that
+1 ; will be excluded from Delivery Order
+2 NEW IB,CNT,ECNT,ITEMR
+3 SET IB=0
SET CNT=0
SET ECNT=0
+4 FOR
SET IB=$ORDER(^TMP($JOB,410.3,XDA,1,"AC",VENDOR1,IB))
if IB=""
QUIT
Begin DoDot:1
+5 SET CNT=CNT+1
+6 SET ITEMR=$GET(^PRCS(410.3,XDA,1,IB,0))
if $PIECE(ITEMR,"^",6)="Y"
QUIT
+7 SET ECNT=ECNT+1
IF ECNT=1
WRITE !!,"Excluded item(s) with no vendor contract#: "
+8 WRITE !!,?5,+ITEMR,?13,$EXTRACT($PIECE($GET(^PRC(441,+ITEMR,0)),"^",2),1,30),?47,"QTY= ",$PIECE(ITEMR,"^",2),?60,"COST: ",$JUSTIFY($FNUMBER($PIECE(ITEMR,"^",4),",",2),9)
End DoDot:1
+9 if 'ECNT
QUIT
+10 IF ECNT=CNT
WRITE !
SET DIR("A")=">> Cannot continue with delivery order as all items have no associated contract# <Hit return to continue>"
SET DIR(0)="EA"
DO ^DIR
KILL DIR
SET ITMCKER=1
QUIT
+11 SET %=2
WRITE !!,"Do you wish to continue with this order excluding the above item(s)"
DO YN^DICN
if %=1
QUIT
+12 SET ITMCKER=1
+13 QUIT
