source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHL6.m@ 724

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

initial load of WorldVistAEHR
File size: 3.0 KB
Line 
1PRCHL6 ;VACO/HNC/VAC - ITEM DETAIL GRID ; 1/31/07 3:38pm
2 ;;5.1;IFCAP;**103**;Oct 20, 2000;Build 25
3 ;Per VHA Directive 2004-038, this routine should not be modified
4 ;DBIA# 4345 giving permission to reference Prosthetics data
5 ;VAC - Limit number of PO line items to 80 or less
6 ;
7 ;piece 1 - line item number
8 ;piece 2 - Item Master number
9 ;piece 3 - qty
10 ;piece 4 - unit of purchase
11 ;piece 5 - BOC
12 ;piece 6 - contract BOA
13 ;piece 7 - actual unit cost
14 ;piece 8 - fed supply classification
15 ;piece 9 - vendor stock number
16 ;piece 10 - unit conversion factor
17 ;piece 11 - total cost
18 ;piece 12 - nif number
19 ;piece 13 - item master short description 441- .05
20 ;
21 ;roll and scroll testing entry point
22A1(IEN) G A2
23 ;
24EN(RESULTS,IEN) ;broker entry point
25A2 ;
26 I IEN="" S RESULTS(0)="No Data"_U_"No Items Found for this PO" Q
27 ;First check number of line items on PO, stop if more than 80
28 I $P(^PRC(442,IEN,0),U,14)>80 S RESULTS(0)="MORE THAN 80^TOO MANY" Q
29 S CNT=0
30 D GETS^DIQ(442,IEN,"40*;.01","EN","ITM")
31 S PRCHPO=$G(ITM("442",IEN_",",".01","E"))
32 S PRCHPIEN=""
33 I PRCHPO'="" S PRCHPIEN=$O(^RMPR(664,"G",$P(PRCHPO,"-",2),PRCHPIEN))
34 I PRCHPIEN'="" D GETS^DIQ(664,PRCHPIEN,"2*;11;12","E","PITMSTR")
35 I $D(PITMSTR) D
36 .;Prosthetic item
37 .S PRCHB="" F S PRCHB=$O(PITMSTR(664.02,PRCHB)) Q:'PRCHB D
38 . .S QTY=$G(PITMSTR(664.02,PRCHB,3,"E"))
39 . .S UOP=$G(PITMSTR(664.02,PRCHB,4,"E"))
40 . .S CBOA=$G(PITMSTR(664.02,PRCHB,13,"E"))
41 . .S ITMD=$G(PITMSTR(664.02,PRCHB,1,"E"))
42 . .S AUC=$G(PITMSTR(664.02,PRCHB,6,"E"))
43 . .I AUC="" S AUC=$G(PITMSTR(664.02,PRCHB,2,"E"))
44 . .S HCPCS=$G(PITMSTR(664.02,PRCHB,16,"E"))
45 . .S VSN=$G(PITMSTR(664.02,PRCHB,15.4,"E"))
46 . .S TCST=QTY*AUC
47 . .S CNT=CNT+1
48 . .S RESULTS(CNT)="P "_CNT_U_HCPCS_U_QTY_U_UOP_U_""_U_CBOA_U_AUC_U_""_U_""_U_1_U_TCST_U_""_U_ITMD
49 . S SHIP="",SHIPF=""
50 . S SHIP=$G(PITMSTR(664,PRCHPIEN_",",11,"E"))
51 . S SHIPF=$G(PITMSTR(664,PRCHPIEN_",",12,"E"))
52 . I SHIPF'="" S SHIP=SHIPF
53 . I SHIP'="" S CNT=CNT+1,RESULTS(CNT)="P "_CNT_U_"SHIPPING"_U_""_U_""_U_""_U_""_U_""_U_""_U_""_U_1_U_SHIP_U_""_U_"Shipping Cost"
54 S B="" F S B=$O(ITM(442.01,B)) Q:'B D
55 . S IFITM=$G(ITM(442.01,B,1.5,"E"))
56 . D GETS^DIQ(441,IFITM,".01;.05;51","E","ITMSTR")
57 . S ITMD=$G(ITMSTR(441,IFITM_",",.05,"E"))
58 . S IFITM1=$G(ITMSTR(441,IFITM_",",.01,"E"))
59 . S NIF=$G(ITMSTR(441,IFITM_",",51,"E"))
60 . S LICNT=$P(B,",",1)
61 . S QTY=$G(ITM(442.01,B,2,"E"))
62 . S UOP=$G(ITM(442.01,B,3,"E"))
63 . S BOC=$G(ITM(442.01,B,3.5,"E"))
64 . S CBOA=$G(ITM(442.01,B,4,"E"))
65 . S AUC=$TR($G(ITM(442.01,B,5,"E")),"$","")
66 . S FSC=$G(ITM(442.01,B,8,"E"))
67 . S VSN=$G(ITM(442.01,B,9,"E"))
68 . S UCF=$G(ITM(442.01,B,9.7,"E"))
69 . S TCST=$G(ITM(442.01,B,15,"E"))
70 . S ITMDD=$G(ITM(442.01,B,1,1))
71 . I ITMD'="" S ITMD=ITMD_" "
72 . S ITMD=ITMD_"1st Line: "_ITMDD
73 . K ITMDD
74 . S CNT=CNT+1
75 . S RESULTS(CNT)="I "_LICNT_U_IFITM1_U_QTY_U_UOP_U_BOC_U_CBOA_U_AUC_U_FSC_U_VSN_U_UCF_U_TCST_U_NIF_U_ITMD
76END I '$D(RESULTS) S RESULTS(1)="No Data"_U_"No Item Detail"
77 K IEN,CNT,ITM,ITMSTR,IFITM,ITMD,IFITM1,LICNT,QTY,UOP,BOC,CBOA,AUC,FSC,VSN,UCF,TCST,NIF,B,PRCHPO,PITMSTR,PRCHB,PRCHPIEN,HCPCS,SHIP,SHIPF
78 Q
79 ;END
Note: See TracBrowser for help on using the repository browser.