PRCHL6 ;VACO/HNC/VAC - ITEM DETAIL GRID ; 1/31/07 3:38pm
;;5.1;IFCAP;**103**;Oct 20, 2000;Build 25
;Per VHA Directive 2004-038, this routine should not be modified
;DBIA# 4345 giving permission to reference Prosthetics data
;VAC - Limit number of PO line items to 80 or less
;
;piece 1 - line item number
;piece 2 - Item Master number
;piece 3 - qty
;piece 4 - unit of purchase
;piece 5 - BOC
;piece 6 - contract BOA
;piece 7 - actual unit cost
;piece 8 - fed supply classification
;piece 9 - vendor stock number
;piece 10 - unit conversion factor
;piece 11 - total cost
;piece 12 - nif number
;piece 13 - item master short description 441- .05
;
;roll and scroll testing entry point
A1(IEN) G A2
;
EN(RESULTS,IEN) ;broker entry point
A2 ;
I IEN="" S RESULTS(0)="No Data"_U_"No Items Found for this PO" Q
;First check number of line items on PO, stop if more than 80
I $P(^PRC(442,IEN,0),U,14)>80 S RESULTS(0)="MORE THAN 80^TOO MANY" Q
S CNT=0
D GETS^DIQ(442,IEN,"40*;.01","EN","ITM")
S PRCHPO=$G(ITM("442",IEN_",",".01","E"))
S PRCHPIEN=""
I PRCHPO'="" S PRCHPIEN=$O(^RMPR(664,"G",$P(PRCHPO,"-",2),PRCHPIEN))
I PRCHPIEN'="" D GETS^DIQ(664,PRCHPIEN,"2*;11;12","E","PITMSTR")
I $D(PITMSTR) D
.;Prosthetic item
.S PRCHB="" F S PRCHB=$O(PITMSTR(664.02,PRCHB)) Q:'PRCHB D
. .S QTY=$G(PITMSTR(664.02,PRCHB,3,"E"))
. .S UOP=$G(PITMSTR(664.02,PRCHB,4,"E"))
. .S CBOA=$G(PITMSTR(664.02,PRCHB,13,"E"))
. .S ITMD=$G(PITMSTR(664.02,PRCHB,1,"E"))
. .S AUC=$G(PITMSTR(664.02,PRCHB,6,"E"))
. .I AUC="" S AUC=$G(PITMSTR(664.02,PRCHB,2,"E"))
. .S HCPCS=$G(PITMSTR(664.02,PRCHB,16,"E"))
. .S VSN=$G(PITMSTR(664.02,PRCHB,15.4,"E"))
. .S TCST=QTY*AUC
. .S CNT=CNT+1
. .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
. S SHIP="",SHIPF=""
. S SHIP=$G(PITMSTR(664,PRCHPIEN_",",11,"E"))
. S SHIPF=$G(PITMSTR(664,PRCHPIEN_",",12,"E"))
. I SHIPF'="" S SHIP=SHIPF
. 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"
S B="" F S B=$O(ITM(442.01,B)) Q:'B D
. S IFITM=$G(ITM(442.01,B,1.5,"E"))
. D GETS^DIQ(441,IFITM,".01;.05;51","E","ITMSTR")
. S ITMD=$G(ITMSTR(441,IFITM_",",.05,"E"))
. S IFITM1=$G(ITMSTR(441,IFITM_",",.01,"E"))
. S NIF=$G(ITMSTR(441,IFITM_",",51,"E"))
. S LICNT=$P(B,",",1)
. S QTY=$G(ITM(442.01,B,2,"E"))
. S UOP=$G(ITM(442.01,B,3,"E"))
. S BOC=$G(ITM(442.01,B,3.5,"E"))
. S CBOA=$G(ITM(442.01,B,4,"E"))
. S AUC=$TR($G(ITM(442.01,B,5,"E")),"$","")
. S FSC=$G(ITM(442.01,B,8,"E"))
. S VSN=$G(ITM(442.01,B,9,"E"))
. S UCF=$G(ITM(442.01,B,9.7,"E"))
. S TCST=$G(ITM(442.01,B,15,"E"))
. S ITMDD=$G(ITM(442.01,B,1,1))
. I ITMD'="" S ITMD=ITMD_" "
. S ITMD=ITMD_"1st Line: "_ITMDD
. K ITMDD
. S CNT=CNT+1
. 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
END I '$D(RESULTS) S RESULTS(1)="No Data"_U_"No Item Detail"
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
Q
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHL6 3193 printed Oct 16, 2024@18:09:09 Page 2
PRCHL6 ;VACO/HNC/VAC - ITEM DETAIL GRID ; 1/31/07 3:38pm
+1 ;;5.1;IFCAP;**103**;Oct 20, 2000;Build 25
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 ;DBIA# 4345 giving permission to reference Prosthetics data
+4 ;VAC - Limit number of PO line items to 80 or less
+5 ;
+6 ;piece 1 - line item number
+7 ;piece 2 - Item Master number
+8 ;piece 3 - qty
+9 ;piece 4 - unit of purchase
+10 ;piece 5 - BOC
+11 ;piece 6 - contract BOA
+12 ;piece 7 - actual unit cost
+13 ;piece 8 - fed supply classification
+14 ;piece 9 - vendor stock number
+15 ;piece 10 - unit conversion factor
+16 ;piece 11 - total cost
+17 ;piece 12 - nif number
+18 ;piece 13 - item master short description 441- .05
+19 ;
+20 ;roll and scroll testing entry point
A1(IEN) GOTO A2
+1 ;
EN(RESULTS,IEN) ;broker entry point
A2 ;
+1 IF IEN=""
SET RESULTS(0)="No Data"_U_"No Items Found for this PO"
QUIT
+2 ;First check number of line items on PO, stop if more than 80
+3 IF $PIECE(^PRC(442,IEN,0),U,14)>80
SET RESULTS(0)="MORE THAN 80^TOO MANY"
QUIT
+4 SET CNT=0
+5 DO GETS^DIQ(442,IEN,"40*;.01","EN","ITM")
+6 SET PRCHPO=$GET(ITM("442",IEN_",",".01","E"))
+7 SET PRCHPIEN=""
+8 IF PRCHPO'=""
SET PRCHPIEN=$ORDER(^RMPR(664,"G",$PIECE(PRCHPO,"-",2),PRCHPIEN))
+9 IF PRCHPIEN'=""
DO GETS^DIQ(664,PRCHPIEN,"2*;11;12","E","PITMSTR")
+10 IF $DATA(PITMSTR)
Begin DoDot:1
+11 ;Prosthetic item
+12 SET PRCHB=""
FOR
SET PRCHB=$ORDER(PITMSTR(664.02,PRCHB))
if 'PRCHB
QUIT
Begin DoDot:2
+13 SET QTY=$GET(PITMSTR(664.02,PRCHB,3,"E"))
+14 SET UOP=$GET(PITMSTR(664.02,PRCHB,4,"E"))
+15 SET CBOA=$GET(PITMSTR(664.02,PRCHB,13,"E"))
+16 SET ITMD=$GET(PITMSTR(664.02,PRCHB,1,"E"))
+17 SET AUC=$GET(PITMSTR(664.02,PRCHB,6,"E"))
+18 IF AUC=""
SET AUC=$GET(PITMSTR(664.02,PRCHB,2,"E"))
+19 SET HCPCS=$GET(PITMSTR(664.02,PRCHB,16,"E"))
+20 SET VSN=$GET(PITMSTR(664.02,PRCHB,15.4,"E"))
+21 SET TCST=QTY*AUC
+22 SET CNT=CNT+1
+23 SET RESULTS(CNT)="P "_CNT_U_HCPCS_U_QTY_U_UOP_U_""_U_CBOA_U_AUC_U_""_U_""_U_1_U_TCST_U_""_U_ITMD
End DoDot:2
+24 SET SHIP=""
SET SHIPF=""
+25 SET SHIP=$GET(PITMSTR(664,PRCHPIEN_",",11,"E"))
+26 SET SHIPF=$GET(PITMSTR(664,PRCHPIEN_",",12,"E"))
+27 IF SHIPF'=""
SET SHIP=SHIPF
+28 IF SHIP'=""
SET CNT=CNT+1
SET RESULTS(CNT)="P "_CNT_U_"SHIPPING"_U_""_U_""_U_""_U_""_U_""_U_""_U_""_U_1_U_SHIP_U_""_U_"Shipping Cost"
End DoDot:1
+29 SET B=""
FOR
SET B=$ORDER(ITM(442.01,B))
if 'B
QUIT
Begin DoDot:1
+30 SET IFITM=$GET(ITM(442.01,B,1.5,"E"))
+31 DO GETS^DIQ(441,IFITM,".01;.05;51","E","ITMSTR")
+32 SET ITMD=$GET(ITMSTR(441,IFITM_",",.05,"E"))
+33 SET IFITM1=$GET(ITMSTR(441,IFITM_",",.01,"E"))
+34 SET NIF=$GET(ITMSTR(441,IFITM_",",51,"E"))
+35 SET LICNT=$PIECE(B,",",1)
+36 SET QTY=$GET(ITM(442.01,B,2,"E"))
+37 SET UOP=$GET(ITM(442.01,B,3,"E"))
+38 SET BOC=$GET(ITM(442.01,B,3.5,"E"))
+39 SET CBOA=$GET(ITM(442.01,B,4,"E"))
+40 SET AUC=$TRANSLATE($GET(ITM(442.01,B,5,"E")),"$","")
+41 SET FSC=$GET(ITM(442.01,B,8,"E"))
+42 SET VSN=$GET(ITM(442.01,B,9,"E"))
+43 SET UCF=$GET(ITM(442.01,B,9.7,"E"))
+44 SET TCST=$GET(ITM(442.01,B,15,"E"))
+45 SET ITMDD=$GET(ITM(442.01,B,1,1))
+46 IF ITMD'=""
SET ITMD=ITMD_" "
+47 SET ITMD=ITMD_"1st Line: "_ITMDD
+48 KILL ITMDD
+49 SET CNT=CNT+1
+50 SET 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
End DoDot:1
END IF '$DATA(RESULTS)
SET RESULTS(1)="No Data"_U_"No Item Detail"
+1 KILL 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
+2 QUIT
+3 ;END
