- 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 Feb 18, 2025@23:31:36 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
