source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCH442.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 6.4 KB
Line 
1PRCH442 ;WISC/KMB/DL/DXH - CREATE PURCHASE CARD ORDER FROM RIL ;12.1.99
2 ;;5.1;IFCAP;**13,81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4START ; entry point for delivery orders
5S1 N RLFLAG S RLFLAG=1
6S2 ; entry point for purchase card orders
7 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
8 N HM,CCDA,II,PP,IB,IJ,CTT,CTR,OUTRL,SERV,TDATE,CNNT1,ZS,ZS0,XDA,YDA,WHSE,COMMENT,PRCS,PRCVDYN,PRCKILL,GG
9 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
10 K DIC S (YDA,XDA,DA)=+Y
11 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
12 K DIC Q:Y'>0
13 I '$D(PRC("PARAM")) S PRC("PARAM")=$$NODE^PRC0B("^PRC(411,PRC(""SITE""),",0)
14 S COMMENT="purchase card",WHSE=+$O(^PRC(440,"AC","S",0)) S:$G(RLFLAG)=1 COMMENT="delivery"
15 ; introducing prcsip as package-wide
16 S OUTRL=0,PRCSIP=$P(^PRCS(410.3,XDA,0),U,3)
17 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
18 ;
19 ;See NOIS MON-0399-51726
20 KILL ^TMP($J)
21 S IB=0,PRCVDYN=0
22 ;
23 ; PRC*5.1*81 set flag (PRCVDYN) for DynaMed RIL
24 I $O(^PRCV(414.02,"C",$P(^PRCS(410.3,XDA,0),"^",1),0))]"" S PRCVDYN=1
25 ;
26 F S IB=$O(^PRCS(410.3,XDA,1,IB)) Q:'IB D ;
27 . S FF=$G(^PRCS(410.3,XDA,1,IB,0))
28 . S ^TMP($J,410.3,XDA,1,"AC",$P(FF,"^",3)_";"_$P(FF,"^",5),IB)=""
29 ;
30 W !,"This repetitive item list has the following vendors:",!
31 ;
32 S HM=""
33 F S HM=$O(^TMP($J,410.3,XDA,1,"AC",HM)) Q:HM="" D
34 . W !,$P(HM,";"),?40,"NUMBER: ",$P(HM,";",2)
35 ;
36 W !
37 S ZS=$P(^PRCS(410.3,XDA,0),"^"),PRC("SITE")=$P(ZS,"-"),CP=+$P(ZS,"-",4),CCEN=$P(ZS,"-",5)
38 D FY
39 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)
40 S PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP")),APP=$P($$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY")),"^",11)
41PROCESS ;
42 ; get item data from repetitive item list
43 S VENDOR1=0,(REQCT,COSTTOT,IB)=0
44 F S VENDOR1=$O(^TMP($J,410.3,XDA,1,"AC",VENDOR1)) Q:VENDOR1="" D PROCESS1
45 W !!!,"Total number of requests generated: ",REQCT,!,"Total cost of all requests: $",$J(COSTTOT,0,2)
46 Q:REQCT=0
47 W !,"Generating ",COMMENT," orders...."
48 I $D(EE($J)) S PP="",RPUSE=1 F S PP=$O(EE($J,PP)) Q:PP="" S DA=PP D
49 .K CCDA D ^PRCH410
50 .I $G(CCDA)'="" W !,"Request ",$P(^PRCS(410,CCDA,0),"^")," created.",!
51 ;
52 ; PRC*5.1*81 if DynaMed RIL and trouble with item, save RIL# to ^TMP
53 I PRCVDYN,$O(^TMP($J,"PRCVHMSG","")) S ^TMP($J,"PRCVHMSG",YDA)=$P(^PRCS(410.3,YDA,0),"^",1)
54 ;
55 D RENUM^PRCH442A
56SLIST S PRCKILL=0 I 'PRCVDYN D
57 . 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
58 ;
59 ; PRC*5.1*81 - send DynaMed a cancel txn for any items not moved to a PC
60 I PRCVDYN D
61 . I +$O(^PRCS(410.3,YDA,1,0))>0 D EN^PRCVRCA(YDA)
62 ;
63 I PRCVDYN!PRCKILL S DA=YDA,DIK="^PRCS(410.3," D ^DIK K DIK
64 ;
65 ; PRC*5.1*81 - send message to user of problems found
66 I PRCVDYN,$O(^TMP($J,"PRCVHMSG","")) D DYNAMSG
67 ;
68 W !,"End of processing."
69 K RLFLAG,PRCHPC,PRCS,^TMP($J) QUIT
70 ;
71PROCESS1 ;
72 N PRCVDATE
73 S NCOST=0,CNNT=0,PRCVDATE=""
74 S IB=$O(^TMP($J,410.3,XDA,1,"AC",VENDOR1,0)),VENDOR=$P($G(^PRCS(410.3,XDA,1,IB,0)),"^",5)
75 I VENDOR="" Q
76 I VENDOR=WHSE,$G(SPEC)'=2 Q
77 I OUTRL=1 Q
78 S IB=0 F S IB=$O(^TMP($J,410.3,XDA,1,"AC",VENDOR1,IB)) Q:IB="" D ITEM Q:OUTRL
79 Q:CNNT=0
80 K PDA D SETUP^PRCH442A
81 I '$D(PDA) Q
82 S REQCT=REQCT+1,COSTTOT=COSTTOT+NCOST
83 W !,"Request ",$P($G(^PRC(442,PDA,0)),"^")," has been created."
84 W !,"The vendor for this request is: ",$P(VENDOR1,";")," "
85 W "(",$P(VENDOR1,";",2),")"
86 W !,"Total cost of request: $",$J(NCOST,0,2),!,"Total items on ",COMMENT," request: ",CNNT
87 QUIT
88ITEM ;
89 S SS=$G(^PRCS(410.3,XDA,1,IB,0))
90 I $G(RLFLAG)=1,$P(SS,"^",6)'="Y" Q
91 S ITEM=$P(SS,"^"),QTY=$P(SS,"^",2),EST=$P(SS,"^",4)
92 I '$D(^PRC(441,+ITEM,2,+VENDOR,0)) Q
93 S ZS0=$G(^PRC(441,ITEM,2,VENDOR,0))
94 S ZS=$G(^PRC(441,ITEM,0)),NSN=$P(ZS,"^",5),BOC=$P(ZS,"^",10),FSC=$P(ZS,"^",3)
95 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)
96 I BOC'="" S BOC=$P($G(^PRCD(420.2,BOC,0)),"^"),BOC=$E(BOC,1,30)
97 S SKU=$P($G(^PRC(441,ITEM,3)),"^",8)
98 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)
99 S:CONT'="" CONT=$P($G(^PRC(440,+VENDOR,4,CONT,0)),"^")
100 S CNNT=CNNT+1
101 S AA(CNNT)=CNNT_"^"_QTY_"^"_UOP_"^"_BOC_"^"_ITEM_"^"_VSTOCK_"^"_UCOST_"^^"_UCOST_"^^^"_PMULT_"^"_NSN_"^"_MAX_"^"_NDC_"^"_SKU_"^"_CONV
102 ; enter item description from file
103 S CNNT1=$P($G(^PRC(441,ITEM,1,0)),"^",4)
104 I CNNT1'="" F J=1:1:CNNT1 S BB(CNNT,J)=$G(^PRC(441,ITEM,1,J,0))
105 S TOTAL=QTY*UCOST,CC(CNNT)=TOTAL_"^"_CONT_"^"_FSC,NCOST=NCOST+TOTAL
106 ;
107 ; PRC*5.1*81 - save DM DOC ID and earliest DATE NEEDED BY, set any problems into ^TMP
108 I PRCVDYN D
109 . S $P(CC(CNNT),"^",15)=$P(^PRCS(410.3,XDA,1,IB,0),"^",7) ; DM DOC ID
110 . I $P(CC(CNNT),"^",15)']"" S ^TMP($J,"PRCVHMSG",XDA,ITEM)="<missing>" ; no DOCID
111 . I $P(SS,"^",8)>0,$P(SS,"^",8)<PRCVDATE S PRCVDATE=$P(SS,"^",8)
112 . I PRCVDATE="" S PRCVDATE=$P(SS,"^",8)
113 ;
114 I $P(SS,"^",6)="Y" S $P(^PRCS(410.3,XDA,1,IB,0),"^",6)="O"
115 S GG(CNNT)=IB
116 QUIT
117 ;
118FY 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)
119 I PRC("QTR")=1 S FY=$E(100+FY+1,2,3),PRC("FY")=FY
120 QUIT
121 ;
122DYNAMSG ; PRC*5.1*81 - Build message to user of items not in audit file
123 N I,XMB,PRCDATA,PRCNT,PRCVI,PRCVIEN,PRCRIL
124 S PRCVIEN=$O(^TMP($J,"PRCVHMSG",0)) Q:+PRCVIEN=0
125 S PRCRIL=^TMP($J,"PRCVHMSG",PRCVIEN)
126 S XMB(1)=" generating PC orders from RIL# "_PRCRIL
127 S XMB(2)=" <SEE BELOW>"
128 S XMB(3)=" unable to enter PO# for item in audit file (#414.02)"
129 S PRCVI=0,PRCNT=0
130 F S PRCVI=$O(^TMP($J,"PRCVHMSG",PRCVIEN,PRCVI)) Q:+PRCVI=0 D
131 . S PRCDATA=$G(^TMP($J,"PRCVHMSG",PRCVIEN,PRCVI))
132 . F I=1,2 I $P(PRCDATA,"^",I)']"" S $P(PRCDATA,"^",I)="<missing>"
133 . S PRCNT=PRCNT+1
134 . S ^TMP($J,"PRCV442M",PRCNT)="ITEM# "_PRCVI_" placed on PO# "_$P(PRCDATA,"^",2)_" has DM DOC ID# "_$P(PRCDATA,"^",1)
135 D DMERXMB^PRCVLIC("PRCV442M",+PRCRIL,$P(PRCRIL,"-",4))
136 Q
Note: See TracBrowser for help on using the repository browser.