PRCHL4 ;VACO/HNC/VAC - REMOTE PROCEDURE, LIST LOGISTICS DATA FILE 442 ; 4/17/07 3:47pm
;;5.1;IFCAP;**103,121**;Oct 20, 2000;Build 2
;Per VHA Directive 2004-038, this routine should not be modified
;DBIA# 4345 giving permission to reference Prosthetics data
;hnc - Aug 21, 2006 add item detail to main grid
;VAC - Set limit on 80 po line items
;
;RESULTS passed to broker in ^TMP($J,
;delimited by ^
;piece 1 = .1 date; display 2
;piece 2 = 91 cost; display 5
;piece 3 = 19 agent assigned PO; display 9
;piece 4 = primary 2237; display 15
;piece 5 = 93 liq amount; display 17
;piece 6 = FOB; display 13
;piece 7 = 1.4 Appropriation; display 14
;piece 8 = 2 cost center; display 8
;piece 9 = 5 vendor; display 12
;piece 10 = 15 number of line items on po; display 11
;piece 11 = station, derived from PO Number; display 1
;piece 12 = 6.4 IEN 442; display 18
;piece 13 = .02 method; display 4
;piece 14 = .01 purchase order number; display 3
;piece 15 = .5 Status; display 6
;piece 16 = 1 FCP; display 7
;piece 17 =5.4 Ship To; display 10
;piece 18 =61 purchase card holder; display 16
;piece 19 = Optional Flex Field
;piece 20 = Optional Flex Field
;piece 21 = Optional Flex Field
EN(RESULT,DATE1,DATE2,FLEXF,FLEX2,FLEX3) ;broker entry point
;
K ^TMP($J)
I '$D(DATE1)!('$D(DATE2)) G EXIT
S DATE=DATE1-1
F S DATE=$O(^PRC(442,"AB",DATE)) Q:(DATE="")!($P(DATE,".",1)>DATE2) D
.S RMPRB=0
.F S RMPRB=$O(^PRC(442,"AB",DATE,RMPRB)) Q:RMPRB="" D
..D DATA
S RESULT=$NA(^TMP($J))
K DATE,DFN,HDES,LINE,PHCPCS,RMPRB,RMPRFLD,TYPE,PRCHLB
Q
;
DATA ;
S PRCHLB=RMPRB
I (FLEXF'="")&(FLEXF'="ITM") S RMPRFLD=".1;91;19;.5;2;20;15;.02;.01;7.2;93;1.4;6.4;5.4;1;61;5;.07;"_FLEXF
I (FLEXF="")!(FLEXF="ITM") S RMPRFLD=".1;91;19;.5;2;20;15;.02;.01;7.2;93;1.4;6.4;5.4;1;61;5;.07"
I (FLEX2'="")&(FLEX2'="ITM") S RMPRFLD=RMPRFLD_";"_FLEX2
I (FLEX3'="")&(FLEX3'="ITM") S RMPRFLD=RMPRFLD_";"_FLEX3
D GETS^DIQ(442,PRCHLB,RMPRFLD,"","RMXM")
;flat data
S $P(^TMP($J,PRCHLB),U,1)=$G(RMXM(442,PRCHLB_",",.1))
S $P(^TMP($J,PRCHLB),U,2)=$G(RMXM(442,PRCHLB_",",91))
S $P(^TMP($J,PRCHLB),U,3)=$G(RMXM(442,PRCHLB_",",19))
S $P(^TMP($J,PRCHLB),U,4)=$G(RMXM(442,PRCHLB_",",.07))
S $P(^TMP($J,PRCHLB),U,5)=$G(RMXM(442,PRCHLB_",",93))
S $P(^TMP($J,PRCHLB),U,6)=PRCHLB
S $P(^TMP($J,PRCHLB),U,7)=$G(RMXM(442,PRCHLB_",",1.4))
S $P(^TMP($J,PRCHLB),U,8)=$G(RMXM(442,PRCHLB_",",2))
S $P(^TMP($J,PRCHLB),U,9)=$G(RMXM(442,PRCHLB_",",5))
S $P(^TMP($J,PRCHLB),U,10)=$G(RMXM(442,PRCHLB_",",15))
S $P(^TMP($J,PRCHLB),U,11)=$P($G(RMXM(442,PRCHLB_",",.01)),"-",1)
S $P(^TMP($J,PRCHLB),U,12)=$G(RMXM(442,PRCHLB_",",6.4))
S $P(^TMP($J,PRCHLB),U,13)=$G(RMXM(442,PRCHLB_",",.02))
S $P(^TMP($J,PRCHLB),U,14)=$G(RMXM(442,PRCHLB_",",.01))
S $P(^TMP($J,PRCHLB),U,15)=$G(RMXM(442,PRCHLB_",",.5))
S $P(^TMP($J,PRCHLB),U,16)=$G(RMXM(442,PRCHLB_",",1))
S $P(^TMP($J,PRCHLB),U,17)=$G(RMXM(442,PRCHLB_",",5.4))
S $P(^TMP($J,PRCHLB),U,18)=$G(RMXM(442,PRCHLB_",",61))
;
I FLEXF'="" S $P(^TMP($J,PRCHLB),U,19)=$G(RMXM(442,PRCHLB_",",FLEXF))
I FLEXF="" S $P(^TMP($J,PRCHLB),U,19)=""
I FLEX2'="" S $P(^TMP($J,PRCHLB),U,20)=$G(RMXM(442,PRCHLB_",",FLEX2))
I FLEX2="" S $P(^TMP($J,PRCHLB),U,20)=""
I FLEX3'="" S $P(^TMP($J,PRCHLB),U,21)=$G(RMXM(442,PRCHLB_",",FLEX3))
I FLEX3="" S $P(^TMP($J,PRCHLB),U,21)=""
;
I (FLEXF="ITM")!(FLEX2="ITM")!(FLEX3="ITM") D ITMDET
K RMXM,PRCHLB
Q
ITMDET ;item detail
I PRCHLB="" Q
S CNT=0
;First check number of line items on PO, stop if more than 80
I $P(^TMP($J,PRCHLB),U,10)>80 S $P(^TMP($J,PRCHLB,1),U,10)="<** More than 80 Line Items **>" Q
D GETS^DIQ(442,PRCHLB,".01","EN","ITM")
S PRCHPO=$G(ITM("442",PRCHLB_",",".01","E"))
S PRCHIEN=""
I PRCHPO'="" S PRCHIEN=$O(^RMPR(664,"G",$P(PRCHPO,"-",2),PRCHIEN))
I PRCHIEN'="" D GETS^DIQ(664,PRCHIEN,"2*;11;12","EN","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 $P(^TMP($J,PRCHLB,CNT),U,1)=$G(RMXM(442,PRCHLB_",",.1))
. .S $P(^TMP($J,PRCHLB,CNT),U,2)=TCST
. .S $P(^TMP($J,PRCHLB,CNT),U,8)=CBOA
. .S $P(^TMP($J,PRCHLB,CNT),U,7)=VSN
. .S $P(^TMP($J,PRCHLB,CNT),U,11)=$P($G(RMXM(442,PRCHLB_",",.01)),"-",1)
. .I HCPCS'="" S $P(^TMP($J,PRCHLB,CNT),U,13)="HCPCS: "_HCPCS
. .S $P(^TMP($J,PRCHLB,CNT),U,14)=$G(RMXM(442,PRCHLB_",",.01))_"-P "_CNT
. .I FLEXF="ITM" S $P(^TMP($J,PRCHLB,CNT),U,19)=$TR(ITMD,","," ")
. .I FLEX2="ITM" S $P(^TMP($J,PRCHLB,CNT),U,20)=$TR(ITMD,","," ")
. .I FLEX3="ITM" S $P(^TMP($J,PRCHLB,CNT),U,21)=$TR(ITMD,","," ")
.;prosthetic shipping
. S SHIP="",SHIPF=""
. S SHIP=$G(PITMSTR(664,PRCHIEN_",",11,"E"))
. S SHIPF=$G(PITMSTR(664,PRCHIEN_",",12,"E"))
. I SHIPF'="" S SHIP=SHIPF
. I SHIP'="" D
. .S CNT=CNT+1
. .S $P(^TMP($J,PRCHLB,CNT),U,2)=SHIP
. .S $P(^TMP($J,PRCHLB,CNT),U,1)=$G(RMXM(442,PRCHLB_",",.1))
. .S $P(^TMP($J,PRCHLB,CNT),U,11)=$P($G(RMXM(442,PRCHLB_",",.01)),"-",1)
. .S $P(^TMP($J,PRCHLB,CNT),U,14)=$G(RMXM(442,PRCHLB_",",.01))_"-P "_CNT
. .I FLEXF="ITM" S $P(^TMP($J,PRCHLB,CNT),U,19)="Shipping"
. .I FLEX2="ITM" S $P(^TMP($J,PRCHLB,CNT),U,20)="Shipping"
. .I FLEX3="ITM" S $P(^TMP($J,PRCHLB,CNT),U,21)="Shipping"
.;IFCAP item
S B=0 F S B=$O(^PRC(442,PRCHLB,2,B)) Q:'B D
. S PRCR=$G(^PRC(442,PRCHLB,2,B,0)),PRCR2=$G(^PRC(442,PRCHLB,2,B,2))
. S IFITM=$P(PRCR,U,5)
. 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=$P(PRCR,U,2)
. S UOP="" S:$P(PRCR,U,3)'="" UOP=$P($G(^PRCD(420.5,$P(PRCR,U,3),0)),U)
. S BOC=$P(PRCR,U,4)
. S CBOA=$P(PRCR2,U,2)
. S AUC=$TR($P(PRCR,U,9),"$","")
. S FSC=$P(PRCR2,U,3)
. S VSN=$P(PRCR,U,6)
. S UCF=$P(PRCR,U,17)
. S TCST=$P(PRCR2,U)
. S ITMDD=$G(^PRC(442,PRCHLB,2,B,1,1,0))
. I ITMD'="" S ITMD=ITMD_" "
. S ITMD=ITMD_"1st Line: "_ITMDD
. K ITMDD
. S CNT=CNT+1
. ;S ^TMP($J,PRCHLB,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
.S $P(^TMP($J,PRCHLB,CNT),U,2)=TCST
.I FLEXF="ITM" S $P(^TMP($J,PRCHLB,CNT),U,19)=$TR(ITMD,","," ")
.I FLEX2="ITM" S $P(^TMP($J,PRCHLB,CNT),U,20)=$TR(ITMD,","," ")
.I FLEX3="ITM" S $P(^TMP($J,PRCHLB,CNT),U,21)=$TR(ITMD,","," ")
.S $P(^TMP($J,PRCHLB,CNT),U,1)=$G(RMXM(442,PRCHLB_",",.1))
.S $P(^TMP($J,PRCHLB,CNT),U,8)=BOC
.S $P(^TMP($J,PRCHLB,CNT),U,9)=VSN
.S $P(^TMP($J,PRCHLB,CNT),U,11)=$P($G(RMXM(442,PRCHLB_",",.01)),"-",1)
.I NIF'="" S IFITM1=IFITM1_" NIF: "_NIF
.I IFITM1'="" S $P(^TMP($J,PRCHLB,CNT),U,13)="Item Master: "_IFITM1
.S $P(^TMP($J,PRCHLB,CNT),U,14)=$G(RMXM(442,PRCHLB_",",.01))_"-I "_LICNT
K PRCR,PRCR2,PRCHLB,CNT,ITM,ITMSTR,IFITM,ITMD,IFITM1,LICNT,QTY,UOP,BOC,CBOA,AUC,FSC,VSN,UCF,TCST,NIF,B,PRCHPO,PITMSTR,PRCHB,PRCHIEN,HCPCS,SHIP,SHIPF
Q
EXIT ;
Q
;END
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHL4 7377 printed Sep 23, 2025@19:44:27 Page 2
PRCHL4 ;VACO/HNC/VAC - REMOTE PROCEDURE, LIST LOGISTICS DATA FILE 442 ; 4/17/07 3:47pm
+1 ;;5.1;IFCAP;**103,121**;Oct 20, 2000;Build 2
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 ;DBIA# 4345 giving permission to reference Prosthetics data
+4 ;hnc - Aug 21, 2006 add item detail to main grid
+5 ;VAC - Set limit on 80 po line items
+6 ;
+7 ;RESULTS passed to broker in ^TMP($J,
+8 ;delimited by ^
+9 ;piece 1 = .1 date; display 2
+10 ;piece 2 = 91 cost; display 5
+11 ;piece 3 = 19 agent assigned PO; display 9
+12 ;piece 4 = primary 2237; display 15
+13 ;piece 5 = 93 liq amount; display 17
+14 ;piece 6 = FOB; display 13
+15 ;piece 7 = 1.4 Appropriation; display 14
+16 ;piece 8 = 2 cost center; display 8
+17 ;piece 9 = 5 vendor; display 12
+18 ;piece 10 = 15 number of line items on po; display 11
+19 ;piece 11 = station, derived from PO Number; display 1
+20 ;piece 12 = 6.4 IEN 442; display 18
+21 ;piece 13 = .02 method; display 4
+22 ;piece 14 = .01 purchase order number; display 3
+23 ;piece 15 = .5 Status; display 6
+24 ;piece 16 = 1 FCP; display 7
+25 ;piece 17 =5.4 Ship To; display 10
+26 ;piece 18 =61 purchase card holder; display 16
+27 ;piece 19 = Optional Flex Field
+28 ;piece 20 = Optional Flex Field
+29 ;piece 21 = Optional Flex Field
EN(RESULT,DATE1,DATE2,FLEXF,FLEX2,FLEX3) ;broker entry point
+1 ;
+2 KILL ^TMP($JOB)
+3 IF '$DATA(DATE1)!('$DATA(DATE2))
GOTO EXIT
+4 SET DATE=DATE1-1
+5 FOR
SET DATE=$ORDER(^PRC(442,"AB",DATE))
if (DATE="")!($PIECE(DATE,".",1)>DATE2)
QUIT
Begin DoDot:1
+6 SET RMPRB=0
+7 FOR
SET RMPRB=$ORDER(^PRC(442,"AB",DATE,RMPRB))
if RMPRB=""
QUIT
Begin DoDot:2
+8 DO DATA
End DoDot:2
End DoDot:1
+9 SET RESULT=$NAME(^TMP($JOB))
+10 KILL DATE,DFN,HDES,LINE,PHCPCS,RMPRB,RMPRFLD,TYPE,PRCHLB
+11 QUIT
+12 ;
DATA ;
+1 SET PRCHLB=RMPRB
+2 IF (FLEXF'="")&(FLEXF'="ITM")
SET RMPRFLD=".1;91;19;.5;2;20;15;.02;.01;7.2;93;1.4;6.4;5.4;1;61;5;.07;"_FLEXF
+3 IF (FLEXF="")!(FLEXF="ITM")
SET RMPRFLD=".1;91;19;.5;2;20;15;.02;.01;7.2;93;1.4;6.4;5.4;1;61;5;.07"
+4 IF (FLEX2'="")&(FLEX2'="ITM")
SET RMPRFLD=RMPRFLD_";"_FLEX2
+5 IF (FLEX3'="")&(FLEX3'="ITM")
SET RMPRFLD=RMPRFLD_";"_FLEX3
+6 DO GETS^DIQ(442,PRCHLB,RMPRFLD,"","RMXM")
+7 ;flat data
+8 SET $PIECE(^TMP($JOB,PRCHLB),U,1)=$GET(RMXM(442,PRCHLB_",",.1))
+9 SET $PIECE(^TMP($JOB,PRCHLB),U,2)=$GET(RMXM(442,PRCHLB_",",91))
+10 SET $PIECE(^TMP($JOB,PRCHLB),U,3)=$GET(RMXM(442,PRCHLB_",",19))
+11 SET $PIECE(^TMP($JOB,PRCHLB),U,4)=$GET(RMXM(442,PRCHLB_",",.07))
+12 SET $PIECE(^TMP($JOB,PRCHLB),U,5)=$GET(RMXM(442,PRCHLB_",",93))
+13 SET $PIECE(^TMP($JOB,PRCHLB),U,6)=PRCHLB
+14 SET $PIECE(^TMP($JOB,PRCHLB),U,7)=$GET(RMXM(442,PRCHLB_",",1.4))
+15 SET $PIECE(^TMP($JOB,PRCHLB),U,8)=$GET(RMXM(442,PRCHLB_",",2))
+16 SET $PIECE(^TMP($JOB,PRCHLB),U,9)=$GET(RMXM(442,PRCHLB_",",5))
+17 SET $PIECE(^TMP($JOB,PRCHLB),U,10)=$GET(RMXM(442,PRCHLB_",",15))
+18 SET $PIECE(^TMP($JOB,PRCHLB),U,11)=$PIECE($GET(RMXM(442,PRCHLB_",",.01)),"-",1)
+19 SET $PIECE(^TMP($JOB,PRCHLB),U,12)=$GET(RMXM(442,PRCHLB_",",6.4))
+20 SET $PIECE(^TMP($JOB,PRCHLB),U,13)=$GET(RMXM(442,PRCHLB_",",.02))
+21 SET $PIECE(^TMP($JOB,PRCHLB),U,14)=$GET(RMXM(442,PRCHLB_",",.01))
+22 SET $PIECE(^TMP($JOB,PRCHLB),U,15)=$GET(RMXM(442,PRCHLB_",",.5))
+23 SET $PIECE(^TMP($JOB,PRCHLB),U,16)=$GET(RMXM(442,PRCHLB_",",1))
+24 SET $PIECE(^TMP($JOB,PRCHLB),U,17)=$GET(RMXM(442,PRCHLB_",",5.4))
+25 SET $PIECE(^TMP($JOB,PRCHLB),U,18)=$GET(RMXM(442,PRCHLB_",",61))
+26 ;
+27 IF FLEXF'=""
SET $PIECE(^TMP($JOB,PRCHLB),U,19)=$GET(RMXM(442,PRCHLB_",",FLEXF))
+28 IF FLEXF=""
SET $PIECE(^TMP($JOB,PRCHLB),U,19)=""
+29 IF FLEX2'=""
SET $PIECE(^TMP($JOB,PRCHLB),U,20)=$GET(RMXM(442,PRCHLB_",",FLEX2))
+30 IF FLEX2=""
SET $PIECE(^TMP($JOB,PRCHLB),U,20)=""
+31 IF FLEX3'=""
SET $PIECE(^TMP($JOB,PRCHLB),U,21)=$GET(RMXM(442,PRCHLB_",",FLEX3))
+32 IF FLEX3=""
SET $PIECE(^TMP($JOB,PRCHLB),U,21)=""
+33 ;
+34 IF (FLEXF="ITM")!(FLEX2="ITM")!(FLEX3="ITM")
DO ITMDET
+35 KILL RMXM,PRCHLB
+36 QUIT
ITMDET ;item detail
+1 IF PRCHLB=""
QUIT
+2 SET CNT=0
+3 ;First check number of line items on PO, stop if more than 80
+4 IF $PIECE(^TMP($JOB,PRCHLB),U,10)>80
SET $PIECE(^TMP($JOB,PRCHLB,1),U,10)="<** More than 80 Line Items **>"
QUIT
+5 DO GETS^DIQ(442,PRCHLB,".01","EN","ITM")
+6 SET PRCHPO=$GET(ITM("442",PRCHLB_",",".01","E"))
+7 SET PRCHIEN=""
+8 IF PRCHPO'=""
SET PRCHIEN=$ORDER(^RMPR(664,"G",$PIECE(PRCHPO,"-",2),PRCHIEN))
+9 IF PRCHIEN'=""
DO GETS^DIQ(664,PRCHIEN,"2*;11;12","EN","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 $PIECE(^TMP($JOB,PRCHLB,CNT),U,1)=$GET(RMXM(442,PRCHLB_",",.1))
+24 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,2)=TCST
+25 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,8)=CBOA
+26 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,7)=VSN
+27 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,11)=$PIECE($GET(RMXM(442,PRCHLB_",",.01)),"-",1)
+28 IF HCPCS'=""
SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,13)="HCPCS: "_HCPCS
+29 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,14)=$GET(RMXM(442,PRCHLB_",",.01))_"-P "_CNT
+30 IF FLEXF="ITM"
SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,19)=$TRANSLATE(ITMD,","," ")
+31 IF FLEX2="ITM"
SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,20)=$TRANSLATE(ITMD,","," ")
+32 IF FLEX3="ITM"
SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,21)=$TRANSLATE(ITMD,","," ")
End DoDot:2
+33 ;prosthetic shipping
+34 SET SHIP=""
SET SHIPF=""
+35 SET SHIP=$GET(PITMSTR(664,PRCHIEN_",",11,"E"))
+36 SET SHIPF=$GET(PITMSTR(664,PRCHIEN_",",12,"E"))
+37 IF SHIPF'=""
SET SHIP=SHIPF
+38 IF SHIP'=""
Begin DoDot:2
+39 SET CNT=CNT+1
+40 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,2)=SHIP
+41 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,1)=$GET(RMXM(442,PRCHLB_",",.1))
+42 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,11)=$PIECE($GET(RMXM(442,PRCHLB_",",.01)),"-",1)
+43 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,14)=$GET(RMXM(442,PRCHLB_",",.01))_"-P "_CNT
+44 IF FLEXF="ITM"
SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,19)="Shipping"
+45 IF FLEX2="ITM"
SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,20)="Shipping"
+46 IF FLEX3="ITM"
SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,21)="Shipping"
End DoDot:2
+47 ;IFCAP item
End DoDot:1
+48 SET B=0
FOR
SET B=$ORDER(^PRC(442,PRCHLB,2,B))
if 'B
QUIT
Begin DoDot:1
+49 SET PRCR=$GET(^PRC(442,PRCHLB,2,B,0))
SET PRCR2=$GET(^PRC(442,PRCHLB,2,B,2))
+50 SET IFITM=$PIECE(PRCR,U,5)
+51 DO GETS^DIQ(441,IFITM,".01;.05;51","E","ITMSTR")
+52 SET ITMD=$GET(ITMSTR(441,IFITM_",",.05,"E"))
+53 SET IFITM1=$GET(ITMSTR(441,IFITM_",",.01,"E"))
+54 SET NIF=$GET(ITMSTR(441,IFITM_",",51,"E"))
+55 SET LICNT=$PIECE(B,",",1)
+56 SET QTY=$PIECE(PRCR,U,2)
+57 SET UOP=""
if $PIECE(PRCR,U,3)'=""
SET UOP=$PIECE($GET(^PRCD(420.5,$PIECE(PRCR,U,3),0)),U)
+58 SET BOC=$PIECE(PRCR,U,4)
+59 SET CBOA=$PIECE(PRCR2,U,2)
+60 SET AUC=$TRANSLATE($PIECE(PRCR,U,9),"$","")
+61 SET FSC=$PIECE(PRCR2,U,3)
+62 SET VSN=$PIECE(PRCR,U,6)
+63 SET UCF=$PIECE(PRCR,U,17)
+64 SET TCST=$PIECE(PRCR2,U)
+65 SET ITMDD=$GET(^PRC(442,PRCHLB,2,B,1,1,0))
+66 IF ITMD'=""
SET ITMD=ITMD_" "
+67 SET ITMD=ITMD_"1st Line: "_ITMDD
+68 KILL ITMDD
+69 SET CNT=CNT+1
+70 ;S ^TMP($J,PRCHLB,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
+71 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,2)=TCST
+72 IF FLEXF="ITM"
SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,19)=$TRANSLATE(ITMD,","," ")
+73 IF FLEX2="ITM"
SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,20)=$TRANSLATE(ITMD,","," ")
+74 IF FLEX3="ITM"
SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,21)=$TRANSLATE(ITMD,","," ")
+75 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,1)=$GET(RMXM(442,PRCHLB_",",.1))
+76 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,8)=BOC
+77 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,9)=VSN
+78 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,11)=$PIECE($GET(RMXM(442,PRCHLB_",",.01)),"-",1)
+79 IF NIF'=""
SET IFITM1=IFITM1_" NIF: "_NIF
+80 IF IFITM1'=""
SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,13)="Item Master: "_IFITM1
+81 SET $PIECE(^TMP($JOB,PRCHLB,CNT),U,14)=$GET(RMXM(442,PRCHLB_",",.01))_"-I "_LICNT
End DoDot:1
+82 KILL PRCR,PRCR2,PRCHLB,CNT,ITM,ITMSTR,IFITM,ITMD,IFITM1,LICNT,QTY,UOP,BOC,CBOA,AUC,FSC,VSN,UCF,TCST,NIF,B,PRCHPO,PITMSTR,PRCHB,PRCHIEN,HCPCS,SHIP,SHIPF
+83 QUIT
EXIT ;
+1 QUIT
+2 ;END
