source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHSP1.m@ 1742

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1PRCHSP1 ;WOIFO/TKW,RHD/DL-TRANSFER 2237 TO PO ; 6/8/99 11:01am
2V ;;5.1;IFCAP;**81**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ; Entered from 2^PRCHNPO3.
6 ; Entered from ^PRCHSP.
7 ;
8 ; First lets check if any 2237 entries have Item Master File
9 ; pointers.
10 ; Next lets see if any of the IMF records do not have the P.O.
11 ; record Vendor.
12 ; Last lets a. tell user of Vendor difference and
13 ; b. find out if user wants to add Vender to IMF records.
14 ; If YES, proceed with transferring 2237 Items to P.O.
15 ; If NO, go back and see if user wants to add any other 2237
16 ; records to this P.O.
17 ;
18CHECK ;
19 S (PRCHX,FLG)=0
20 K DIRUT
21 S PRCHCV=$P($G(^PRC(442,PRCHPO,1)),U,1)
22 F S PRCHX=$O(^PRCS(410,PRCHSY,"IT",PRCHX)) Q:PRCHX=""!(PRCHX'>0) D Q:FLG>0!($D(DIRUT))
23 . S N0=$G(^PRCS(410,PRCHSY,"IT",PRCHX,0))
24 . S IMF=+$P(N0,U,5)
25 . Q:IMF'>0
26 . I $D(^PRC(441,IMF,2,PRCHCV,0)) Q
27 . S DIR("A",1)="This 2237 entry will update some ITEM MASTER FILE records"
28 . S DIR("A",2)="with a new vendor, "_$P(^PRC(440,PRCHCV,0),U)_"."
29 . S DIR("A",3)=" "
30 . S DIR("A")="Do you want to do this"
31 . S DIR("B")="NO"
32 . S DIR(0)="Y"
33 . D ^DIR
34 . K DIR
35 . Q:$D(DIRUT)
36 . S:Y=1 FLG=1 ; YES
37 . S:Y=0 FLG=2 ; NO
38 . Q
39 ;
40 I FLG=2!($D(DIRUT)) S PRCHSY=-2 K DIRUT Q
41 K DIRUT
42 ;
43 ;Moves 2237,PRCHSY, into PO,PRCHPO
44 ;
45 S (J,K,PRCHX)=0 I $D(^PRC(442,PRCHPO,2,0)) S I=0 F S I=$O(^PRC(442,PRCHPO,2,I)) Q:I=""!(I'>0) S J=J+1,K=I
46 S PRCHJ=J,PRCHK=K F PRCHJ=PRCHJ+1:1 S PRCHX=$O(^PRCS(410,PRCHSY,"IT",PRCHX)) Q:PRCHX=""!(PRCHX'>0) D
47 .S PRCHK=PRCHK+1,PRCHSN=^PRCS(410,PRCHSY,"IT",PRCHX,0) D IT
48 .K ^PRCS(410,PRCHSY,"IT","AB",PRCHX)
49 .S $P(^PRCS(410,PRCHSY,"IT",PRCHX,0),U,10)=PRCHPO
50 .Q
51 S PRCHJ=PRCHJ-1,^PRC(442,PRCHPO,2,0)="^442.01IA^"_PRCHK_U_PRCHJ
52 ;
53MV1 S X=$P($P(^PRC(442,PRCHPO,0),U,1),"-",2),$P(^PRCS(410,PRCHSY,4),U,5)=X,$P(^(10),U,3)=PRCHPO,^PRCS(410,"D",X,PRCHSY)=""
54 S Y=^PRCS(410,PRCHSY,3),X=$G(^PRC(420,PRC("SITE"),1,+Y,0))
55 I $P(^PRC(442,PRCHPO,0),U,3)="" S $P(^(0),U,3,5)=$P(Y,U,1,2)_U_+$P(Y,U,3),$P(^(0),U,19)=$P(X,U,12),$P(^(17),U,1)=$E($P(X,U,18),1,3),^PRC(442,"E",$P($P(Y,U,1)," ",1),PRCHPO)=""
56 S $P(^PRC(442,PRCHPO,0),U,14)=PRCHJ,$P(^(1),U,2)=$P(Y,U,5) S:$P(^(1),U,9)="" $P(^PRC(442,PRCHPO,1),U,9)=$P(^PRCS(410,PRCHSY,1),U,3)
57 I '$D(PRCHNRQ) S:$D(^PRCS(410,PRCHSY,9)) $P(^PRC(442,PRCHPO,0),U,13)=$P(^PRCS(410,PRCHSY,9),U,4)
58 S:$D(^PRCS(410,PRCHSY,9)) $P(^PRC(442,PRCHPO,1),U,11)=$P(^PRCS(410,PRCHSY,9),U,1)
59 I $D(^PRC(443,PRCHSY,0)) S $P(^PRC(442,PRCHPO,1),U,18)=$P(^(0),U,12),DA=PRCHSY,DIK="^PRC(443," D ^DIK K DIK
60 I PRCHS,$D(^PRC(443,PRCHS,0)),'$D(^PRCS(410,PRCHS,"IT","AB")) S $P(^PRCS(410,PRCHS,0),U,12)="O" S DA=PRCHS,DIK="^PRC(443," D ^DIK K DIK,PRCHRBST
61 K ^PRCS(410,PRCHSY,"IT","AB"),T,PRCHSN
62 S X=^PRC(442,PRCHPO,0),X1=$P(^(1),U,15)
63 S PRC("FY")=$E(100+$E(X1,2,3)+$E(X1,4),2,3)
64 I '$D(PRC("BBFY")) S PRC("BBFY")=$$BBFY^PRCSUT(+$P(X,U),PRC("FY"),+$P(X,U,3))
65 S PRC("BBFY")=PRC("BBFY")-1700_"0000"
66 S $P(^PRC(442,PRCHPO,23),U,2)=PRC("BBFY")
67 Q
68 ;
69IT ; CALLED FROM CHECK+25^PRCHSP1 (THIS ROUTINE). CALLED FOR EACH
70 ; LINE ITEM TO COPY 2237 LINE ITEM INTO P.O.
71 ;
72 S ^PRC(442,PRCHPO,2,PRCHK,0)=PRCHJ_U_$P(PRCHSN,U,2,99),$P(^(0),U,10)=PRCHSY,$P(^(2),U,13)=PRCHX,^PRC(442,PRCHPO,2,"B",PRCHJ,PRCHK)="",^PRC(442,PRCHPO,2,"C",PRCHJ,PRCHK)=""
73 S X=$P(PRCHSN,U,6) I X?4N1"-"2N1"-"3N1"-"4N.UN S $P(^PRC(442,PRCHPO,2,PRCHK,0),U,13)=X,$P(^(0),U,6)="" S:$D(^PRC(441.2,+X,0)) $P(^PRC(442,PRCHPO,2,PRCHK,2),U,3)=+X
74 ; PRC*5.1*81 move DM DOC ID to new 2237
75 S:$D(^PRCS(410,PRCHSY,"IT",PRCHX,4))#10=1 $P(^PRC(442,PRCHPO,2,PRCHK,2),U,15)=$P(^PRCS(410,PRCHSY,"IT",PRCHX,4),"^",1) ; DM DOC ID
76 ;
77 D MDEL
78 I $D(^PRC(441,+$P(PRCHSN,U,5),0)) G CRD
79 S %X="^PRCS(410,PRCHSY,""IT"",PRCHX,1,",%Y="^PRC(442,PRCHPO,2,PRCHK,1," D %XY^%RCR
80 Q
81 ;
82CRD N DA
83 S PRCHCCP=$P($P(^PRCS(410,PRCHSY,3),U,1)," ",1)
84 S PRCHCI=+$P(PRCHSN,U,5)
85 S PRCHCV=$S($P(^PRC(442,PRCHPO,1),U,1)]"":+$P(^(1),U,1),1:0)
86 S PRCHCPD=+$P(^PRC(442,PRCHPO,1),U,15)
87 S PRCHCPO=PRCHPO
88 S:$P(^PRC(442,PRCHPO,0),U,3)]"" PRCHCCP=$P($P(^(0),U,3)," ",1)
89 I $D(^PRCP(445,+$P(^PRCS(410,PRCHSY,0),U,6),1,PRCHCI,0)) S X=^(0),$P(^PRC(442,PRCHPO,2,PRCHK,4),U,2)=$P(X,U,9),$P(^(4),U,4,5)=$P(X,U,18)_"^"_$P(X,U,13) S:$P(X,U,18)=1 $P(^(4),U,7)="-"
90 I '$D(^PRC(441,PRCHCI,2,PRCHCV,0)) W !,"For item, ",$P(^PRC(441,PRCHCI,0),U,2),!?5,"Enter the following information: " D G CRDQ
91 . ;
92 . ; Suggested list of variables to New to make DIE and maybe DIC
93 . ; recursive.
94 . ;
95 . N DIC,DIE,DO,DA,DR,DD,DL,DP,I,J,X,DC,DE,D,D1,D2,D3,D4,D5,D6,DI
96 . N DH,DIA,DICR,DIK,DLAYGO,DM,DQ,DU,DW,DIEL,DOV,DIOV,DIEC,DB,DV
97 . N DK,DIFLD,DIADD,D0,DG
98 . S DIC="^PRC(441,PRCHCI,2,"
99 . S DIC(0)="LZ"
100 . S DLAYGO=441
101 . S DA(1)=PRCHCI
102 . S (DA,X)=PRCHCV
103 . D ^DIC
104 . S DIE=DIC
105 . S DR="1;1.5;2;3;4;1.6;10"
106 . S DIE("NO^")=""
107 . D ^DIE
108 . K DIC,DIE("NO^")
109 . S ^PRC(442,PRCHPO,2,"AE",PRCHCI,PRCHK)=""
110 . S DA(1)=PRCHPO
111 . S DA=PRCHK
112 . D EN3^PRCHCRD
113 . S DA=PRCHPO
114 . K DA(1)
115 . Q
116 ;
117 S (DA(1),PRCHCPO)=PRCHPO
118 S DA=PRCHK
119 S ^PRC(442,PRCHPO,2,"AE",PRCHCI,DA)=""
120 D EN3^PRCHCRD
121 ;
122CRDQ K PRCHCCP,PRCHCPO,PRCHCV,PRCHCI,PRCHCPD,DA
123 Q
124 ;
125MDEL ; MOVE DELIVERY SCHEDULE INFO FROM 2237 TO P.O. FOR ONE LINE ITEM
126 ; ENTRY. MDEL WILL BE CALLED FOR EACH LINE ITEM.
127 ;
128 ; CALLED FROM IT+2^PRCHSP1 (THIS ROUTINE).
129 ;
130 ; PRCHSY=410 INTERNAL RECORD NUMBER
131 ; PRCHX=410 ITEM MULTIPLE INTERNAL RECORD NUMBER
132 ; PRCHPO=442 INTERNAL RECORD NUMBER
133 ; PRCHK=442 ITEM MULTIPLE INTERNAL RECORD NUMBER
134 ;
135 NEW DIC,DR
136 K ^TMP("PRCHSP1",$J)
137 S PRCHPONO=$P(^PRC(442,PRCHPO,0),U,1)
138 S PRCHITM=$P(^PRC(442,PRCHPO,2,PRCHK,0),U,1)
139 W "."
140 S PRCHZ1=0
141 D RD
142 G:'$D(^TMP("PRCHSP1",$J)) Q
143 S PRCHZ1=""
144 F S PRCHZ1=$O(^TMP("PRCHSP1",$J,PRCHZ1)) Q:PRCHZ1="" S PRCHZ2="" F S PRCHZ2=$O(^TMP("PRCHSP1",$J,PRCHZ1,PRCHZ2)) Q:PRCHZ2="" S PRCHZ3="" D ADDS
145 ;
146Q K ^TMP("PRCHSP1",$J),PRCHITM,PRCHZ,PRCHZ0,PRCHZ1,PRCHZ2,PRCHZ3
147 Q
148 ;
149RD S PRCHZ1=$O(^PRCS(410,PRCHSY,"IT",PRCHX,2,PRCHZ1))
150 ;
151 ; PRCHZ1=DELIVERY SCHEDULE INTERNAL RECORD MULTIPLE NUMBER
152 ;
153 Q:PRCHZ1'>0
154 S PRCHZ0=$G(^PRCS(410,PRCHSY,"IT",PRCHX,2,PRCHZ1,0))
155 ;
156 ; PRCHZ0 PIECE 2=DELIVERY REFERENCE NUMBER POINTER
157 ;
158 G:+$P(PRCHZ0,U,2)'>0 RD
159 G:'$D(^PRCS(410.6,+$P(PRCHZ0,U,2),0)) RD
160 S PRCHZ2=^PRCS(410.6,+$P(PRCHZ0,U,2),0)
161 ;
162 ; PRCHZ2 PIECE 4=QTY TO BE DELIVERED
163 ;
164 G:'$P(PRCHZ2,U,4) RD
165 ;
166 ; PRCHZ2 PIECE 3=LOCATION (OF FILE 410.8 RECORD)
167 ;
168 G:+$P(PRCHZ2,U,3)'>0 RD
169 S X=$P($G(^PRCS(410.8,+$P(PRCHZ2,U,3),0)),U,1)
170 S:X="" X=" "
171 ;
172 ; PRCHZ2 PIECE 2=DELIVERY DATE
173 ;
174 S ^TMP("PRCHSP1",$J,+$P(PRCHZ2,U,2),X,PRCHZ1)=PRCHZ2
175 G RD
176 ;
177ADDS S PRCHZ3=$O(^TMP("PRCHSP1",$J,PRCHZ1,PRCHZ2,PRCHZ3))
178 Q:'PRCHZ3
179 S PRCHZ=^TMP("PRCHSP1",$J,PRCHZ1,PRCHZ2,PRCHZ3)
180 S DIC="^PRC(442.8,"
181 S DLAYGO=442.8
182 S DIC(0)="L"
183 S DIC("DR")="1///"_PRCHITM_";2///"_$P(PRCHZ,U,2)_";3////"_$P(PRCHZ,U,3)_";4///"_$P(PRCHZ,U,4),X=""""_PRCHPONO_""""
184 D ^DIC
185 G ADDS
Note: See TracBrowser for help on using the repository browser.