source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSRIG2.m@ 623

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

initial load of WorldVistAEHR
File size: 7.5 KB
Line 
1PRCSRIG2 ;SF-ISC/LJP/KMB/BMM-GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE (CON'T) ; 3/25/05 3:05pm
2V ;;5.1;IFCAP;**13,81,101**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;PRCSRI is the ordered item from the RIL. PX(3) is
5 ;the ordered item from the Item Master File. PRCSV1 is
6 ;the vendor from the RIL. X2 is the vendor listed for
7 ;the item from the Item Master File. PX(1) holds Item
8 ;Master File data, PX(2) holds Vendor File data.
9 ;
10 ;2/16/05 BMM per PRC*5.1*81, added code in ITEMG1 to capture
11 ;data from two new fields in files 410 and 410.3:
12 ;DM Doc ID (410 #17, 410.3 #6) and Date Needed (410 #18, 410.3 #7)
13 ;added variables PRCVDN, PRCVDTN in ITEMG
14 ;
15 ;3/9/05 BMM per PRC*5.1*81, added sub UPDAUD to update the DM Audit
16 ;file when a 2237 is created.
17 ;
18ITEMG N STOP,PRCVDN,PRCVDTN S (PRCSRI,PRCSCS,STOP)="",(PRCSIT(1),K,BFLAG)=0
19 S (PRCVDN,PRCVDTN)=""
20 F PRCSRIM=0:1 S PRCSRI=$O(^TMP($J,410.3,PRCSRID0,1,"AC",PRCSV1,PRCSRI)) Q:PRCSRI="" S PRCSIT=PRCSIT+1,PRCSIT(1)=PRCSIT(1)+1 D ITEMG1 D:STOP'=1 ITEMG3 Q:BFLAG S STOP=""
21 D:'BFLAG
22 . D:$D(DA) ITEMG2 I $D(PRCSL),PRCSL L
23 . D:IOSL-$Y<2 HOLD,HDRG W !!," Finished building request.",!,"This request contains ",PRCSIT(1)_$S(PRCSIT(1)=1:" item.",1:" items.")," The total cost for this request is $",$J(PRCSCS,0,2),! S L="",$P(L,"-",IOM)="-" W L S L=""
24 . S PRCSTC=PRCSTC+PRCSCS Q
25 D:BFLAG
26 . I (PRCSIT>0) D
27 . . S PRCSIT=PRCSIT-1
28 . I (PRCSCT>0) D
29 . . S PRCSCT=PRCSCT-1
30 Q
31 ;
32ITEMG1 S PX=^PRCS(410.3,PRCSRID0,1,PRCSRI,0),PX(3)=$P(PX,"^"),PX(1)=^PRC(441,PX(3),0),X2=$P(PX,"^",5),PX(2)=^PRC(440,X2,0),PRCVDN=$P(PX,"^",7),PRCVDTN=$P(PX,"^",8)
33 ; If a discrepancy is found, set STOP=1, skip item
34 I $D(PX(1)),$P(PX(1),"^",10)'?4N W !,"The budget object code for this item is not entered in the Item Master File.",!,"This item cannot be processed.",! S STOP=1
35 I '$D(^PRC(441,PX(3),2,X2,0)) D:IOSL-$Y<2 HOLD,HDRG W !,$C(7),"WARNING!!! Item # ",PX(3)," is not available from ",$P(PRCSV1,";")," (",$P(PRCSV1,";",2),")",!,"This item cannot be processed.",! S PRCSIT=PRCSIT-1,PRCSIT(1)=PRCSIT(1)-1 S STOP=1
36 Q
37 ;
38ITEMG3 I '$D(Z1)!'$D(Z2) D DVERR Q
39 I 'K S Z=Z1,X=Z2 D EN1^PRCSUT3 G:'X EX S X1=X D EN2^PRCSUT3 G:'$D(X1) EX L +^PRCS(410,DA):15 G:$T=0 EX
40 D:IOSL-$Y<7 HOLD,HDRG
41 I 'K W !,"A request with Transaction Number ",$P(Y(0),"^")," has been generated.",!!,"The vendor for this request is ",$P(PRCSV1,";")," (",$P(PRCSV1,";",2),")",!,"Now entering items for this request."
42 ;PRC*5.1*81 update audit file for 2237 creation
43 I 'K S PRCV2=$P(Y(0),"^",1)
44 ;S K=K+1,X(3)=^PRC(441,PX(3),2,X2,0) I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),U,12)<1 S PRCSS=$S($P(PX(1),"^",10):$E($P(^PRCD(420.2,$P(PX(1),"^",10),0),"^"),1,30),1:"")
45 ;
46 ;For a Supply Fund Requests adding code to derive BOC from NSN
47 S K=K+1
48 S X(3)=^PRC(441,PX(3),2,X2,0)
49 S ITNSN=$E($P($G(^PRC(441,+PX(3),0)),U,5),1,4)
50 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) D
51 . I $P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,12)'=2!($P(^(0),U,12)'=4) D
52 . . S PRCSS=$S($P(PX(1),"^",10):$E($P(^PRCD(420.2,$P(PX(1),"^",10),0),"^"),1,30),1:"")
53 . . Q
54 . I $P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,12)=2!($P(^(0),U,12)=4) D
55 . . S ITACCT=$$ACCT^PRCPUX1(ITNSN)
56 . . S ITBOC=$S(ITACCT=1:2697,ITACCT=2:2698,ITACCT=3:2699,ITACCT=6:2699,ITACCT=8:2696,1:2699)
57 . . S PRCSS=$E($P(^PRCD(420.2,ITBOC,0),U,1),1,30)
58 . . Q
59 . Q
60 S:'$D(PRCSS) PRCSS="" S ^PRCS(410,DA,"IT",K,0)=K_"^"_$P(PX,"^",2)_"^"_$P(X(3),"^",7)_"^"_PRCSS_"^"_PX(3)_"^"_$P(X(3),"^",4)_"^"_$P(PX,"^",4),^PRCS(410,DA,"IT",K,1,0)="^^1^1^"_PRCSD1_"^^",^(1,0)=$P(PX(1),"^",2)
61 ;PRC*5.1*81 add DM Doc ID, Date Needed to new line item
62 ;
63 I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D
64 . Q:'$D(^PRCV(414.02,"C",PRCSNO))
65 . S ^PRCS(410,DA,"IT",K,4)=PRCVDN_"^"_PRCVDTN
66 . D UPDAUD(PRCV2)
67 S ^PRCS(410,DA,"IT","B",K,K)="",^PRCS(410,DA,"IT","AB",K,K)="" S:PRCSS ^PRCS(410,"AD",PRCSS,DA)=""
68 S PRCSCS=PRCSCS+($P(PX,"^",2)*($P(PX,"^",4))) G EX2
69 ;
70ITEMG2 S ^PRCS(410,DA,"IT",0)="^"_"410.02AI"_"^"_K_"^"_K,%=$P(^PRCS(410.3,PRCSRID0,0),"^",3),$P(^PRCS(410,DA,0),"^",2)="O" S:% $P(^(0),"^",6)=%,^PRCS(410,"AO",%,DA)="" S $P(^PRCS(410,DA,0),"^",4)=$S($D(^PRC(440,"AC","S",X2)):5,1:3)
71 S ^PRCS(410,DA,1)=PRCSD1_"^^"_"ST"_"^"_PRCSD(1),^(2)=PX(2),^PRCS(410,DA,3)=$P(^PRCS(410,DA,3),"^",1,2)_"^"_PRCSCC_"^"_X2_"^"_$S($D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)):$P(^(0),"^",10),1:"")
72 S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7)
73 S:PRC("ACC") $P(^PRCS(410,DA,3),"^",12)=$P(PRC("ACC"),"^",3)
74 S ^PRCS(410,DA,4)=PRCSCS_"^"_PRCSD1_"^^^^^^"_PRCSCS,^(10)=K,^(7)=+PRC("PER")_"^"_$P(PRC("PER"),"^",3) S:'$D(^(11)) ^(11)=""
75 S ^PRCS(410,"E",$E($P(PX(2),"^"),1,30),DA)="" S:PRCSCC ^PRCS(410,"AC",$E(PRCSCC,1,30),DA)=""
76 I IO'=IO(0)!$D(ZTQUEUED) S $P(^PRCS(410,DA,11),U,3)=1,^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$P($P(^PRCS(410,DA,0),U),"-",5),DA)="",^PRCS(410,"F1",$P($P(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA)=""
77 I IO'=IO(0)!$D(ZTQUEUED) S ^PRCS(410,"AQ",1,DA)="" L -^PRCS(410,DA) G END
78 S PRC("QTR")=$P($P(^PRCS(410,DA,0),U),"-",3) D ASK^PRCSRIG1 L -^PRCS(410,DA)
79END K DA,PRCSDR,PRCSCQT,PRCSOCK,PRCSOCP,PRCSOCS,PRCST,PRCST1,PX,X2 Q
80 ;
81HDRG W @IOF,"GENERATE REQUESTS FROM REPETITIVE ITEM LIST FILE",?55,"DATE: ",PRCSD,!,"Requests Generated From Repetitive Item List Entry # ",PRCSNO,! S L="",$P(L,"-",IOM)="-" W L S L=""
82 Q
83 ;
84HOLD Q:IO'=IO(0)!($D(ZTQUEUED)) W !,"Press return to continue: " R Z(1):DTIME Q
85EX K PX,X,X1,X2,Z S PRCSCT=PRCSCT-1 W $C(7),!,"Could not create a request" Q
86EX1 K X,X2 D KRL K PX Q
87EX2 K PRCSS,Y D KRL K PX(3),X(3) Q
88KRL Q
89 ;
90UPDAUD(PRCV2) ;per PRC*5.1*81, update DM Audit file (#414.02) when 2237 is created
91 ;PRCV2 - 2237's .01 value
92 ;PRCVDYN - DM Doc ID for each item
93 ;PRCSRID0 - RIL IEN from above
94 ;
95 ;first check DM flag
96 ;Q:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
97 N PRCVA,PRCVAC,PRCVC,PRCVDI,PRCVDYN,PRCVI,PRCVIEN,PRCVFCP
98 N PRCVFL,PRCVJ,PRCVST,PRCVTMP,XMB
99 S (PRCVC,PRCVDYN,PRCVIEN)="",PRCVFL=0
100 ;get #items for RIL in 414.02
101 ;F PRCVI=0:1 S PRCVC=$O(^PRCV(414.02,"C",PRCSNO,PRCVC)) Q:PRCVC=""
102 ;for each item, update entry in 414.02
103 ;F PRCVJ=1:1:PRCVI Q:PRCVFL=1 D
104 S PRCVJ=PRCSRI D
105 . S PRCVDYN=$$GET1^DIQ(410.31,PRCVJ_","_PRCSRID0_",",6)
106 . ;
107 . I PRCVDYN="" D Q
108 . . ;DM Doc ID missing
109 . . S PRCVTMP="PRCSRIG2",PRCVST=$P(PRCSNO,"-")
110 . . S PRCVFCP=$P(PRCSNO,"-",4)
111 . . S XMB(1)="creating a new 2237 record"
112 . . S XMB(2)=" <missing>"
113 . . S XMB(3)="DM doc ID value missing from line item in 2237"
114 . . S ^TMP($J,"PRCSRIG2",1,0)=""
115 . . S ^TMP($J,"PRCSRIG2",2,0)="2237 #: "_PRCV2
116 . . S ^TMP($J,"PRCSRIG2",3,0)="Item #: "_PX(3)
117 . . D DMERXMB^PRCVLIC(PRCVTMP,PRCVST,PRCVFCP)
118 . ;
119 . S PRCVIEN=$O(^PRCV(414.02,"B",PRCVDYN,0))
120 . S PRCVA(414.02,PRCVIEN_",",7)=PRCV2
121 . D FILE^DIE("","PRCVA")
122 . I $D(^TMP("DIERR",$J)) D Q
123 . . ;error updating Audit file
124 . . S PRCVTMP="PRCSRIG2",PRCVST=$P(PRCSNO,"-")
125 . . S PRCVFCP=$P(PRCSNO,"-",4)
126 . . S XMB(1)="updating the DynaMed IFCAP Interface Audit file (#414.02)"
127 . . S XMB(2)=PRCVDYN
128 . . S XMB(3)="unable to add update to Audit file entry"
129 . . S ^TMP($J,"PRCSRIG2",1,0)=""
130 . . S ^TMP($J,"PRCSRIG2",2,0)="2237 #: "_PRCV2
131 . . S ^TMP($J,"PRCSRIG2",3,0)="Item #: "_PX(3)
132 . . S ^TMP($J,"PRCSRIG2",4,0)="Error text: "_$G(^TMP("DIERR",$J,1,"TEXT",1))
133 . . D DMERXMB^PRCVLIC(PRCVTMP,PRCVST,PRCVFCP)
134 Q
135DVERR D BLNKON
136 W !,"There is an error with the default device defined in file 411.",!,"Please contact IRM before proceeding.",!
137 D BLNKOFF
138 S BFLAG=1
139 Q
140 ;
141BLNKON ;if terminal-type exists turn-on blink
142 D:$D(IOST(0))
143 . S X="IOBON"
144 . D ENDR^%ZISS
145 . W IOBON
146 Q
147BLNKOFF ;if terminal-type exists turn-off blink
148 D:$D(IOST(0))
149 . S X="IOBOFF"
150 . D ENDR^%ZISS
151 . W IOBOFF
152 Q
Note: See TracBrowser for help on using the repository browser.