source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCH442A.m@ 1607

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

initial load of FOIAVistA 6/30/08 version
File size: 8.4 KB
Line 
1PRCH442A ;WISC/KMB/CR/DXH/DGL-CREATE PURCHASE CARD ORDER FROM RIL ;4/13/00 1:32pm
2 ;;5.1;IFCAP;**8,35,26,57,81,106**;Oct 20, 2000
3 ;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5SETUP ; create 442 entry
6 D ENPO^PRCHUTL
7 ;
8 ; PRC*5.1*81 - If this is a DynaMed RIL, double dare users who try to exit before all items on the RIL are transferred to purchase card orders
9 I '$D(DA),'PRCVDYN S OUTRIL=1 W !,"Unable to create 442 entry. Try later." Q
10 I '$D(DA) D G SETUP:Y=0 S OUTRIL=1 Q
11 . N DIR
12 . S DIR(0)="Y",DIR("B")="NO"
13 . S DIR("A",1)=" "
14 . S DIR("A",2)="NOTE: This RIL Contains DynaMed Orders!!!"
15 . S DIR("A",3)="-----------------------------------------"
16 . S DIR("A",4)="You must enter a valid PURCHASE ORDER NUMBER to continue. If no valid"
17 . S DIR("A",5)="PURCHASE ORDER is entered, all items remaining on the RIL will be deleted."
18 . S DIR("A",6)=" "
19 . S DIR("A")="Do you want to exit and delete the RIL?"
20 . S DIR("?")="Enter 'NO' or <return> to go back to the PURCHASE ORDER prompt"
21 . D ^DIR Q:Y=0
22 . S DIR("A")="Are you sure that you want to cancel ALL DynaMed Orders on this RIL?"
23 . D ^DIR
24 ;
25 I '$G(^PRCS(410.3,XDA,0)) D S OUTRIL=1 W !!,"Another user has deleted this RIL, Purchase Order will now be deleted.",!! Q
26 . S DIK="^PRC(442,",DA=DA
27 . D ^DIK
28 N PRCHCPD,CP1
29 S PDA=DA L +^PRC(442,PDA):15 Q:'$T
30 S DIE="^PRC(442,",DR=".5////1"_";"_"1.4////"_APP D ^DIE ;LIT-0400-70331
31 I $G(RLFLAG)'=1 S DR=".02///25"_";"_"48///P" D ^DIE
32 I $G(RLFLAG)=1 S DR=".02///1"_";"_"47///Y"_";"_"48///D" D ^DIE
33 S $P(^PRC(442,PDA,1),"^")=VENDOR,$P(^(0),"^",3)=FCP,$P(^(0),"^",5)=CCEN,$P(^(23),"^",7)=PRC("SST"),$P(^(23),"^",14)=VENDOR
34 S DIE="^PRC(442,",DR=".03///"_SPEC_";"_".1////"_TDATE D ^DIE
35 ;
36 ; PRC*5.1*81
37 I PRCVDYN S DR="7///"_PRCVDATE_";"_"54///Y" D ^DIE ; save earliest Need By Date in RIL for vendor in PC order delivery date, force 'Requested Receipt?' to Yes
38 ;
39 ;BUT-0701-21784 & WAS-0498-22000
40 S CP1=$P($P(^PRCS(410.3,XDA,0),U),"-",4)
41 S ^PRC(442,"E",CP1,PDA)=""
42 ;
43 S $P(^PRC(442,PDA,1),"^",10)=DUZ,^PRC(442,"D",$E(VENDOR,1,30),PDA)=""
44 I NCOST'=0 F II=1:1:CNNT D SETIT
45 I NCOST'=0 S ^PRC(442,PDA,2,0)="^442.01IA^"_CNNT_"^"_CNNT
46 S EE($J,PDA)=""
47 ;
48 N NCST,NLP,NCNT,NQTY,NSUB
49LOOP S %=1 W !,"Edit request ",$P(^PRC(442,PDA,0),"^")
50 D YN^DICN G:%=0 LOOP G:%=2 LQ
51 S (PRCHPO,DA)=PDA,PRC("PER")=DUZ,X=1
52 D ^PRCHNPO,LOOPA
53 K PRC("PER"),X,PRCHPO
54LQ L -^PRC(442,PDA) Q
55 ;
56LOOPA Q:$G(^PRC(442,PDA,2,0))="" S NCNT=$P($G(^PRC(442,PDA,2,0)),U,4) Q:NCNT="" S NSUB=0 F NLP=1:1:NCNT D
57 .S NQTY=$P($G(^PRC(442,PDA,2,NLP,0)),U,2),NCST=$P($G(^PRC(442,PDA,2,NLP,0)),U,9),NSUB=NSUB+(NQTY*NCST)
58 S CNNT=NCNT,NCOST=NSUB Q
59 ;
60SETIT ;set item data on 442 record
61 S ^PRC(442,PDA,2,II,0)=AA(II)
62 I CNNT1'="" F J=1:1:CNNT1 S ^PRC(442,PDA,2,II,1,J,0)=$G(BB(II,J))
63 S ^PRC(442,PDA,2,II,2)=CC(II)
64 ;
65 ; PRC*5.1*81
66 I PRCVDYN D
67 . N PRCV S PRCV=0
68 . I $P(CC(II),"^",15)]"" S PRCV=$O(^PRCV(414.02,"B",$P(CC(II),"^",15),"")) ; get ien of DM DOC ID
69 . I +PRCV=0 D Q ; if not in audit file update ^TMP to alert user
70 . . S ^TMP($J,"PRCVHMSG",YDA,ITEM)=$P(CC(II),"^",15)_"^"_$P(^PRC(442,PDA,0),"^",1) Q ; update msg to user to show DM, DOC ID & PO#
71 . S $P(^PRCV(414.02,PRCV,0),"^",11)=$P(^PRC(442,PDA,0),"^",1) ; SET PO Number into Audit file
72 ;
73 S ^PRC(442,PDA,2,II,1,0)="^^"_CNNT1_"^"_CNNT1_"^"_TDATE_"^"
74 S ^PRC(442,PDA,2,"B",II,II)="",^PRC(442,PDA,2,"C",II,II)=""
75 S ^PRC(442,PDA,2,"AE",ITEM,II)="" S:BOC'="" ^PRC(442,PDA,2,"AH",+BOC,II,II)="",^PRC(442,PDA,2,"D",+BOC,II)=""
76 I $G(PRCSIP) D
77 . N DIC,DIE,DA,DLAYGO
78 . S DIC="^PRC(442,"_PDA_",2,"_II_",5,",DA(1)=II,DA(2)=PDA,X=PRCSIP
79 . S DIC(0)="L",DIC("P")=$P(^DD(442.01,47,0),U,2),DLAYGO=442
80 . D FILE^DICN
81 K DIE
82 ;
83 ; PRC*5.1*81 - delete items from RIL as they are moved to a PC order
84 I PRCVDYN D
85 . N DA,DIK
86 . S DA=GG(II),DA(1)=YDA,DIK="^PRCS(410.3,"_DA(1)_",1,"
87 . D ^DIK
88 ;
89 S PRCHCPD=TDATE,PRCHCV=VENDOR,(DA(1),PRCHCPO)=PDA,PRCHCCP=CP1,(PRCHCI,PRCHCII,X)=$P(AA(II),"^",5),DA=II
90 I PRCHCI'="" D EN3^PRCHCRD S ^PRC(442,PDA,2,"AE",PRCHCII,II)=""
91 K PRCHCCP,PRCHCPO,PRCHCV,PRCHCI,PRCHCII
92 QUIT
93 ;
94INCOM1 S FLAG=0
95INCOM2 S:$G(FLAG)="" FLAG=1
96INCOM ;
97 K ^TMP($J)
98 N ZP,LABEL,PC1,PONUM,PODATE,STAT,PANAME,ADATE,Y,XXZ,EX,P,P1,P12,P2,P23,STR,TIMEDATE
99 S:$G(FLAG)="" LABEL="INCOM" S:$G(FLAG)=0 LABEL="INCOM1" S:$G(FLAG)=1 LABEL="INCOM2"
100 W @IOF
101 S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(PRC("SITE"))="^"
102 W !,"Please select a device for printing this report."
103 S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
104 I $D(IO("Q")) S ZTSAVE("*")="",ZTRTN="DETAIL^PRCH442A" D ^%ZTLOAD,^%ZISC K FLAG Q
105 D DETAIL,^%ZISC K FLAG
106 Q
107 ;
108DETAIL ;
109 S X=DT D NOW^%DTC,YX^%DTC S TIMEDATE=Y,CNT=0
110 S ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D
111 .Q:$P($G(^PRC(442,ZP,7)),"^")=45
112 .Q:$D(^PRC(442,ZP,11))
113 .Q:$P($G(^PRC(442,ZP,12)),"^",2)'=""
114 .S P1=$G(^PRC(442,ZP,0)),PONUM=$P(P1,"^")
115 .I $D(PRC("SITE")) Q:$P(P1,"-")'=PRC("SITE")
116 .S PC1=$P($G(^PRC(442,ZP,23)),"^",8) I PC1="" D DETAIL1
117 .Q:PC1=""
118 .I $G(FLAG)=0 Q:$P($G(^PRC(440.5,PC1,0)),"^",8)'=DUZ
119 .I $G(FLAG)=1 I $P($G(^PRC(440.5,PC1,0)),"^",10)'=DUZ,$P($G(^PRC(440.5,PC1,0)),"^",9)'=DUZ Q
120 .S P2=$G(^PRC(442,ZP,1)),PA=$P($G(^PRC(440.5,PC1,0)),"^",8) Q:PA=""
121 .S PANAME=$P($G(^VA(200,PA,0)),"^") Q:PANAME=""
122 .S Y=$P(P2,"^",15) D DD^%DT S PODATE=Y
123 .S STAT=$P($G(^PRC(442,ZP,7)),"^") S:STAT'="" STAT=$P($G(^PRCD(442.3,STAT,0)),"^")
124 .S Y=$P($G(^PRC(442,ZP,12)),"^",5) D DD^%DT S ADATE=Y
125 .S ^TMP($J,ZP)=PONUM_"^"_PODATE_"^"_STAT_"^"_PANAME_"^"_ADATE,CNT=$G(CNT)+1
126 D WRTE
127 W:$D(^TMP($J)) !!!,?10,"Total number of orders found: "_CNT
128 K ^TMP($J),CNT
129 Q
130 ;
131DETAIL1 ;Get tally for the PC user and exclude the Approving Official.
132 Q:$G(FLAG)=1
133 ;if the PC Coordinator is asking for the report, get the orders.
134 I $G(FLAG)="" D DETAIL2
135 Q:$P($G(^PRC(442,ZP,12)),"^",4)'=DUZ!($G(FLAG)'=0)
136 S PA=$P(^PRC(442,ZP,12),"^",4),PANAME=$P(^VA(200,PA,0),"^") Q:PANAME=""
137 S Y=$P(^PRC(442,ZP,12),"^",5) D DD^%DT S ADATE=Y,PODATE=$P(Y,"@",1)
138 S STAT=$P($G(^PRC(442,ZP,7)),"^") S:STAT'="" STAT=$P($G(^PRCD(442.3,STAT,0)),"^")
139 S ^TMP($J,ZP)=PONUM_"^"_PODATE_"^"_STAT_"^"_PANAME_"^"_ADATE,CNT=$G(CNT)+1
140 Q
141 ;
142DETAIL2 ;Get tally for the PC Coordinator.
143 S PA=$P(^PRC(442,ZP,12),"^",4),PANAME=$P(^VA(200,PA,0),"^") Q:PANAME=""
144 S Y=$P(^PRC(442,ZP,12),"^",5) D DD^%DT S ADATE=Y,PODATE=$P(Y,"@",1)
145 S STAT=$P($G(^PRC(442,ZP,7)),"^") S:STAT'="" STAT=$P($G(^PRCD(442.3,STAT,0)),"^")
146 S ^TMP($J,ZP)=PONUM_"^"_PODATE_"^"_STAT_"^"_PANAME_"^"_ADATE,CNT=$G(CNT)+1
147 Q
148 ;
149WRTE ;
150 U IO S (P,EX)=1
151 I '$D(^TMP($J)) D HDR W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
152 S ZP="" F S ZP=$O(^TMP($J,ZP)) Q:ZP="" Q:EX="^" D
153 .D:P=1 HDR
154 .W !,$P(^TMP($J,ZP),"^"),?21,$P(^TMP($J,ZP),"^",2),?40,$P(^TMP($J,ZP),"^",3),!,?10,$P(^TMP($J,ZP),"^",4),?40,$P(^TMP($J,ZP),"^",5),!
155 .I (IOSL-$Y)<6 D HLD Q:EX="^"
156 QUIT
157 ;
158C2237 ;cancel 2237 from PC order
159 N I,N,T,X,ZX,PRCVIEN
160 Q:'$D(DA) S YDA=DA,PRCVIEN=DA,XDA=$P($G(^PRC(442,DA,23)),"^",23) Q:XDA="" L +^PRCS(410,XDA):15 Q:'$T
161 S PRC("CP")=$P($G(^PRC(442,YDA,0)),"^",3) Q:+PRC("CP")=""
162 S T=$P(^PRCS(410,XDA,0),"^"),$P(^(11),"^",3)="",$P(^(0),"^",2)="CA",$P(^(5),"^")=0,$P(^(6),"^")=0 K ^PRCS(410,"F",+T_"-"_+PRC("CP")_"-"_$P(T,"-",5),XDA),^PRCS(410,"F1",$P(T,"-",5)_"-"_+T_"-"_+PRC("CP"),XDA),^PRCS(410,"AQ",1,XDA)
163 K ZX I $D(^PRCS(410,XDA,4)) S ZX=^(4),X=$P(ZX,"^",8) F I=1,3,6,8 S $P(ZX,"^",I)=0
164 I $D(ZX) S ^PRCS(410,XDA,4)=ZX K ZX
165 I $D(^PRCS(410,XDA,12,0)) S N=0 F I=0:0 S N=$O(^PRCS(410,XDA,12,N)) Q:N'>0 S X=$P(^(N,0),"^",2) I X S DA(1)=XDA,DA=N D TRANK^PRCSEZZ S XDA=DA(1)
166 D ERS410^PRC0G(XDA_"^C")
167 L -^PRCS(410,XDA)
168 I $D(^PRC(443,XDA,0)) S DA=XDA,DIK="^PRC(443," D ^DIK K DIK
169 S DA=YDA
170 ; PRC*5.1*81 - if site runs DynaMed, may need to build update txn
171 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D DEL^PRCV442A(PRCVIEN)
172 QUIT
173 ;
174RENUM ; delete delivery order items from repetitive item list
175 Q:$G(^PRCS(410.3,YDA,0))=""
176 L +^PRCS(410.3,YDA):15 Q:'$T
177 S IJ="" F S IJ=$O(^PRCS(410.3,YDA,1,IJ)) Q:IJ="" D
178 .I $P($G(^PRCS(410.3,YDA,1,IJ,0)),"^",6)="O" S DA=IJ,DA(1)=YDA,DIK="^PRCS(410.3,"_DA(1)_",1," D ^DIK
179 L -^PRCS(410.3,YDA)
180 I $P($G(^PRCS(410.3,YDA,1,0)),"^",4)=0 W !,"This Repetitive Item List has no more items, and will be deleted." S DA=YDA,DIK="^PRCS(410.3," D ^DIK
181 K DIK QUIT
182 ;
183HDR W @IOF
184 W !,"INCOMPLETE PURCHASE CARD ORDERS REPORT",?45,TIMEDATE,?70,"PAGE ",P
185 W !,"PURCHASE CARD ORDER",?21,"PO DATE",?40,"SUPPLY STATUS",!,?10,"BUYER",?40,"DATE PO ASSIGNED"
186 W ! F I=1:1:8 W "----------"
187 S P=P+1
188 QUIT
189 ;
190HLD G HDR:$P(IOST,"-")="P" W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ="^" EX="^" S:'$T EX="^" D:EX'["^" HDR QUIT
Note: See TracBrowser for help on using the repository browser.