PRCHLO1A ;WOIFO/RLL-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ;5/22/09 14:11
;;5.1;IFCAP;**83,130**;Oct 20, 2000;Build 25
;Per VHA Directive 2004-038, this routine should not be modified.
; DBIA 10093 - Read file 49 via FileMan.
; Continuation of PRCHLO1. This program builds the extracts for
; the Master PO Table and the associated multiples
POMAST ; PoMaster Table
Q
PODISCW ; Write PO Discount table data
N GPOID,GPOND
S GPOID=0,GPOND=""
F S GPOID=$O(^TMP($J,"PODISC",GPOID)) Q:GPOID="" D
. F S GPOND=$O(^TMP($J,"PODISC",GPOID,GPOND)) Q:GPOND="" D
. . W $G(^TMP($J,"PODISC",GPOID,GPOND))
. . W !
. . Q
. Q
W !
Q
PODISC ;
;PoDiscount Table 442.03A (multiple)
; ^PRC(442,POID,3,0)=^442.03A
N CKDS,PPO,PPOVAL,CKDS1,V1,V2,V3,V4,V5,V6
S CKDS=$G(^PRC(442,POID,3,0)),PPO=0
S CKDS1=$P(CKDS,U,3)
I +CKDS1>0 D ; Contains at least one discount, create rec.
. D LPPODIS
. Q
Q
PO2237 ; 2237RefNum Table
N CK2237,PPO,PPOVAL,CK2237A,PPV4E1,PPV4E2
S CK2237=$G(^PRC(442,POID,13,0)),PPO=0
S CK2237A=$P(CK2237,U,3)
I +CK2237A>0 D ; Contains at least one 2237#, create rec
. D LP2237
Q
POBOC ; PoBoc Table
N CKBS,PPO,PPOVAL,PPOVAL1,CKBS1
S CKBS=$G(^PRC(442,POID,22,0)),PPO=0
S CKBS1=$P(CKBS,U,3)
I +CKBS1>0 D ; Contains at lease one BOC, create rec.
. D LPPOBC
Q
POAMT ; PO Amount table (multiple)
N POAMT,POAMT1,POAMT2,POAMT3,POAMT4,V1,V2,V3
N V1E,V1E1,V1E2,V2E,V2E1,V2E2,VE,VE1,VE2
S POAMT=$G(^PRC(442,POID,9,0))
S POAMT1=$P(POAMT,U,3)
I +POAMT1>0 D
. S POAMT2=0
. F S POAMT2=$O(^PRC(442,POID,9,POAMT2)) Q:POAMT2="" D
. . Q:+POAMT2<0
. . S POAMT3=$G(^PRC(442,POID,9,POAMT2,0))
. . Q:POAMT3=""
. . ; For V1-V3, Get the node, $P the data, pad with "^" delimiters
. . ; get external value for TypeCode
. . S VE=$P(POAMT3,U,2)
. . I VE'="" S VE1=$G(^PRCD(420.6,+VE,0)),VE2=$P(VE1,U,1)
. . I VE="" S VE2=""
. . ; get external value for CompStatus Business
. . S V1E=$P(POAMT3,U,4)
. . I V1E'="" S V1E1=$G(^PRCD(420.6,+V1E,0)),V1E2=$P(V1E1,U,1)
. . I V1E="" S V1E2=""
. . ;
. . S V1=$P(POAMT3,U,1)_U_VE2_U_V1E2_U
. . ; Get external value for PrefProgram
. . S V2E=$P(POAMT3,U,5)
. . I V2E'="" S V2E1=$G(^PRCD(420.6,+V2E,0)),V2E2=$P(V2E1,U,1)
. . I V2E="" S V2E2=""
. . S V2=V2E2_U_$P(POAMT3,U,3),V3=V1_V2
. . S POAMT4=PPOKEY_U_POAMT2_U_V3
. . I +POAMT2>0 S ^TMP($J,"POAMT",POID,POAMT2,0)=POAMT4
. . D PAMBCD ; Po Amount Breakout code
. . Q
. Q
Q
PAMBCD ; PO Amount Breakout code
N PAMBC,PAMBC1,PAMBC2,PAMBC3,PAMBC4,VBCE,VBCE1,VBCE2
S PAMBC=0,PAMBC1=0,PAMBC2=0,PAMBC3=0
S PAMBC=$G(^PRC(442,POID,9,POAMT2,1,0))
S PAMBC1=$P(PAMBC,U,3)
I +PAMBC1>0 D
. F S PAMBC2=$O(^PRC(442,POID,9,POAMT2,1,PAMBC2)) Q:PAMBC2="" D
. . Q:+PAMBC2<0
. . S PAMBC3=$G(^PRC(442,POID,9,POAMT2,1,PAMBC2,0))
. . ;
. . ; get external value for breakout code
. . S VBCE=$P(PAMBC3,U,1)
. . I VBCE'="" S VBCE1=$G(^PRCD(420.6,+VBCE,0)),VBCE2=$P(VBCE1,U,1)
. . I VBCE="" S VBCE2=""
. . S PAMBC4=PPOKEY_U_POAMT2_U_PAMBC2_U_VBCE2
. . I +PAMBC2>0 S ^TMP($J,"POBKCOD",POID,POAMT2,PAMBC2,0)=PAMBC4
. . Q
. Q
Q
POAMMD ; PO Amendment Table (multiple)
N POAMD,POAMD1,POAMD2,POAMD3,POAMD3A,POAMD4,V1,V2,V3,V2E,V2E1,V2E2
N V3E,V3E1,V3E2,V1E,V1E1,V1E2,VL6,VL7,VL8,VL9
S POAMD=$G(^PRC(442,POID,6,0))
S POAMD1=$P(POAMD,U,3)
S POAMD2=0
F S POAMD2=$O(^PRC(442,POID,6,POAMD2)) Q:+POAMD2'>0 D
. S POAMD3=$G(^PRC(442,POID,6,POAMD2,0))
. S POAMD3A=$G(^PRC(442,POID,6,POAMD2,1))
. ; V1-V3, $Get the data, $P the values, pad with "^" delimiters
. ; get external date for EffectiveDate
. S V1E=$P(POAMD3,U,2),V1E1=$P(V1E,".",1)
. I V1E'="" S V1E2=$$FMTE^XLFDT(V1E1)
. I V1E="" S V1E2=""
. S V1=$P(POAMD3,U,1)_U_V1E2_U_$P(POAMD3,U,3)_U
. ; get external value for pAPPMaUthorizedBuyer
. S V2E=$P(POAMD3A,U,1)
. I V2E'="" S V2E1=$G(^VA(200,+V2E,0)),V2E2=$P(V2E1,U,1)
. I V2E="" S V2E2=""
. S VL8=$P($G(^VA(200,+V2E,5)),U) ;SERVICE - pAPPMaUthorizedBuyer
. S VL9=$S(VL8="":"",1:$$GET1^DIQ(49,+VL8_",",.01)) ;SVC ext - pAPPMaUthorizedBuyer
. ; get external value for AmendmentAdjustment
. S V3E=$P(POAMD3A,U,4)
. I V3E'="" S V3E1=$G(^PRCD(442.3,+V3E,0)),V3E2=$P(V3E1,U,1)
. I V3E="" S V3E2=""
. S VL6=$P(POAMD3A,U,5),VL7=$P($G(^VA(200,+VL6,0)),U) ;Fiscal Approv
. S V2=V2E2_U_V3E2,V3=V1_V2_U_V2E_U_VL6_U_VL7
. S V1=$P($G(^VA(200,+VL6,5)),U) ;SERVICE - Fiscal Approv
. S V2=$S(V1="":"",1:$$GET1^DIQ(49,+V1_",",.01)) ;SVC ext - Fiscal Approv
. S POAMD4=PPOKEY_U_POAMD2_U_V3_U_VL8_U_VL9_U_V1_U_V2
. S ^TMP($J,"POAMMD",POID,POAMD2,0)=POAMD4
. D POAMCH ; Check for Amendment Changes
. D POAMDS ; Check for Amendment Description
. Q
Q
POAMCH ; PO Amendment Changes Table (mulitple)
N POAMC,POAMC1,POAMC2,POAMC3,POAMC4,POAMC5,POAMC6
S POAMC=$G(^PRC(442,POID,6,POAMD2,3,0))
S POAMC1=$P(POAMC,U,3)
S POAMC2=0
F S POAMC2=$O(^PRC(442,POID,6,POAMD2,3,POAMC2)) Q:+POAMC2'>0 D
. S POAMC3=$G(^PRC(442,POID,6,POAMD2,3,POAMC2,0))
. S POAMC4=$P(POAMC3,U,1),POAMC5=$P(POAMC3,U,2)
. S POAMC6=PPOKEY_U_POAMD2_U_POAMC2_U_POAMC4_U_POAMC5
. S ^TMP($J,"POAMMDCH",POID,POAMD2,POAMC2,0)=POAMC6
. Q
Q
POAMDS ; PO Amendment Description Table
N POADD,POADD1,POADD2,POADD3,POADD4
S POADD=$G(^PRC(442,POID,6,POAMD2,2,0))
I $D(POADD) D
. S POADD1=0
. F S POADD1=$O(^PRC(442,POID,6,POAMD2,2,POADD1)) Q:POADD1="" D
. . S POADD2=$G(^PRC(442,POID,6,POAMD2,2,POADD1,0)) ; mult
. . S POADD3=PPOKEY_U_POAMD2_U_POADD1_U_POADD2
. . Q:+POADD1>1 ; Get the 1st "1"
. . I +POAMD2>0 S ^TMP($J,"POAMMDDES",POID,POAMD2,POADD1,0)=POADD3
. . Q
. Q
Q
POCMTS ; PocommentsTable
N POCMTS,POCMTS1
S POCMTS=$G(^PRC(442,POID,4,1,0)) ; 1st line
S POCMTS1=$E(POCMTS,1,175) ; Get the 1st 175 Chars
; Get the 1st 175 Char of 1st comment only
I POCMTS'="" S ^TMP($J,"POCOMMENTS",POID)=PPOKEY_U_1_U_POCMTS1
Q
PORMKS ; PoRemarks Table
N PORMKS,PORMKS1
S PORMKS=$G(^PRC(442,POID,16,1,0)) ; 1st Line, 1st Comment
S PORMKS1=$E(PORMKS,1,175) ; Get the 1st 175 Chars
; gET 1st 175 Characters of 1st remark
I PORMKS'="" S ^TMP($J,"POREMARKS",POID)=PPOKEY_U_1_U_PORMKS1
Q
LPPODIS ; Loop on PO Discount
I CKDS1>0 D
. F S PPO=$O(^PRC(442,POID,3,PPO)) Q:PPO="" D
. . S PPOVAL=$G(^PRC(442,POID,3,PPO,0))
. . S V1=$P(PPOVAL,U,1)_U_$P(PPOVAL,U,2)_U ; disc itm & %$tot
. . S V2=$P(PPOVAL,U,3)_U_$P(PPOVAL,U,4)_U ; DiscAmt & ItmCt
. . S V3=$P(PPOVAL,U,5)_U_$P(PPOVAL,U,6) ; contract & lineItem
. . S V4=V1_V2_V3 ; all data
. . S PPOVAL1=PPOKEY_U_PPO_U_V4
. . S ^TMP($J,"PODISC",POID,PPO)=PPOVAL1
. . Q
. Q
Q
LPPOBC ; Loop PoBoc Table
F S PPO=$O(^PRC(442,POID,22,PPO)) Q:PPO="" D
. Q:PPO="B" ; don't want B index
. S PPOVAL=$G(^PRC(442,POID,22,PPO,0))
. S PPOVAL1=$P(PPOVAL,U,1)_U_$P(PPOVAL,U,2)
. S PPOVAL1=PPOVAL1_U_$P(PPOVAL,U,3) ;FMS LINE
. S PPOVAL2=PPOKEY_U_PPO_U_PPOVAL1
. S ^TMP($J,"POBOC",POID,PPO)=PPOVAL2
. Q
Q
LP2237 ; Loop 2237
N PPOVAL,PPV1,PPV2,PPV3,PPV4,PPV5,PPV6,PPV7,PPVALL,POKEY,PPOVAL2
N PPV1E,PPV1E1,PPV2E,PPV2E1,PPV4E1,PPV4E2,PPV7E,PPV7E1,PPV7E2
N PPV3E,PPV3E1,VL6,VL7,VL8,VL9
F S PPO=$O(^PRC(442,POID,13,PPO)) Q:PPO="" D
. S PPOVAL=$G(^PRC(442,POID,13,PPO,0))
. S PPV1=$P(PPOVAL,U,1),PPV2=$P(PPOVAL,U,2),PPV3=$P(PPOVAL,U,4)
. ; external value for 2237 PPV1
. I PPV1'="" S PPV1E=$G(^PRCS(410,+PPV1,0)),PPV1E1=$P(PPV1E,U,1)
. I PPV1="" S PPV1E1=""
. ; external value for Accountable Officer PPV2
. I PPV2'="" S PPV2E=$G(^VA(200,+PPV2,0)),PPV2E1=$P(PPV2E,U,1)
. I PPV2="" S PPV2E1=""
. S VL6=$P($G(^VA(200,+PPV2,5)),"^") ;Service - Acc Office
. S VL7=$S(VL6="":"",1:$$GET1^DIQ(49,+VL6_",",.01)) ;SVC ext - Acc Office
. ; ext. date value for Date Signed
. I PPV3'="" S PPV3E=$P(PPV3,".",1),PPV3E1=$$FMTE^XLFDT(PPV3E)
. I PPV3="" S PPV3E1=""
. S PPV4=$P(PPOVAL,U,5),PPV5=$P(PPOVAL,U,9),PPV6=$P(PPOVAL,U,10)
. ; external for Purchasing agent PPV4
. ;
. I PPV4'="" S PPV4E1=$G(^VA(200,+PPV4,0)),PPV4E2=$P(PPV4E1,U,1)
. I PPV4="" S PPV4E2=""
. S VL8=$P($G(^VA(200,+PPV4,5)),"^") ;Service - Purchase Agent
. S VL9=$S(VL8="":"",1:$$GET1^DIQ(49,+VL8_",",.01)) ;SVC ext - Purchase Agent
. ; get external value for InvDistPoint
. S PPV7E=$P(PPOVAL,U,11)
. I PPV7E'="" S PPV7E1=$G(^PRCP(445,+PPV7E,0)),PPV7E2=$P(PPV7E1,U,1)
. I PPV7E="" S PPV7E2=""
. S PPV7=PPV7E2
. S PPVALL=PPV1E1_U_PPV2E1_U_PPV3E1_U_PPV4E2_U_PPV5_U_PPV6_U_PPV7_U_$P(PPOVAL,U,5)_U_$P(PPOVAL,U,2)
. ;
. S PPOVAL2=PPOKEY_U_PPO_U_PPVALL
. S ^TMP($J,"PO2237",POID,PPO)=PPOVAL2_U_VL8_U_VL9_U_VL6_U_VL7
. Q
Q
PODISCH ; PO Discount Header File
; Header file for PO Discount Multiple
W "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
W "DiscountIdNum^DiscountItem^PercentDollarAmount^"
W "DiscountAmount^ItemCount^Contract^LineItem",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHLO1A 8880 printed Nov 22, 2024@17:18:34 Page 2
PRCHLO1A ;WOIFO/RLL-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ;5/22/09 14:11
+1 ;;5.1;IFCAP;**83,130**;Oct 20, 2000;Build 25
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; DBIA 10093 - Read file 49 via FileMan.
+4 ; Continuation of PRCHLO1. This program builds the extracts for
+5 ; the Master PO Table and the associated multiples
POMAST ; PoMaster Table
+1 QUIT
PODISCW ; Write PO Discount table data
+1 NEW GPOID,GPOND
+2 SET GPOID=0
SET GPOND=""
+3 FOR
SET GPOID=$ORDER(^TMP($JOB,"PODISC",GPOID))
if GPOID=""
QUIT
Begin DoDot:1
+4 FOR
SET GPOND=$ORDER(^TMP($JOB,"PODISC",GPOID,GPOND))
if GPOND=""
QUIT
Begin DoDot:2
+5 WRITE $GET(^TMP($JOB,"PODISC",GPOID,GPOND))
+6 WRITE !
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
+9 WRITE !
+10 QUIT
PODISC ;
+1 ;PoDiscount Table 442.03A (multiple)
+2 ; ^PRC(442,POID,3,0)=^442.03A
+3 NEW CKDS,PPO,PPOVAL,CKDS1,V1,V2,V3,V4,V5,V6
+4 SET CKDS=$GET(^PRC(442,POID,3,0))
SET PPO=0
+5 SET CKDS1=$PIECE(CKDS,U,3)
+6 ; Contains at least one discount, create rec.
IF +CKDS1>0
Begin DoDot:1
+7 DO LPPODIS
+8 QUIT
End DoDot:1
+9 QUIT
PO2237 ; 2237RefNum Table
+1 NEW CK2237,PPO,PPOVAL,CK2237A,PPV4E1,PPV4E2
+2 SET CK2237=$GET(^PRC(442,POID,13,0))
SET PPO=0
+3 SET CK2237A=$PIECE(CK2237,U,3)
+4 ; Contains at least one 2237#, create rec
IF +CK2237A>0
Begin DoDot:1
+5 DO LP2237
End DoDot:1
+6 QUIT
POBOC ; PoBoc Table
+1 NEW CKBS,PPO,PPOVAL,PPOVAL1,CKBS1
+2 SET CKBS=$GET(^PRC(442,POID,22,0))
SET PPO=0
+3 SET CKBS1=$PIECE(CKBS,U,3)
+4 ; Contains at lease one BOC, create rec.
IF +CKBS1>0
Begin DoDot:1
+5 DO LPPOBC
End DoDot:1
+6 QUIT
POAMT ; PO Amount table (multiple)
+1 NEW POAMT,POAMT1,POAMT2,POAMT3,POAMT4,V1,V2,V3
+2 NEW V1E,V1E1,V1E2,V2E,V2E1,V2E2,VE,VE1,VE2
+3 SET POAMT=$GET(^PRC(442,POID,9,0))
+4 SET POAMT1=$PIECE(POAMT,U,3)
+5 IF +POAMT1>0
Begin DoDot:1
+6 SET POAMT2=0
+7 FOR
SET POAMT2=$ORDER(^PRC(442,POID,9,POAMT2))
if POAMT2=""
QUIT
Begin DoDot:2
+8 if +POAMT2<0
QUIT
+9 SET POAMT3=$GET(^PRC(442,POID,9,POAMT2,0))
+10 if POAMT3=""
QUIT
+11 ; For V1-V3, Get the node, $P the data, pad with "^" delimiters
+12 ; get external value for TypeCode
+13 SET VE=$PIECE(POAMT3,U,2)
+14 IF VE'=""
SET VE1=$GET(^PRCD(420.6,+VE,0))
SET VE2=$PIECE(VE1,U,1)
+15 IF VE=""
SET VE2=""
+16 ; get external value for CompStatus Business
+17 SET V1E=$PIECE(POAMT3,U,4)
+18 IF V1E'=""
SET V1E1=$GET(^PRCD(420.6,+V1E,0))
SET V1E2=$PIECE(V1E1,U,1)
+19 IF V1E=""
SET V1E2=""
+20 ;
+21 SET V1=$PIECE(POAMT3,U,1)_U_VE2_U_V1E2_U
+22 ; Get external value for PrefProgram
+23 SET V2E=$PIECE(POAMT3,U,5)
+24 IF V2E'=""
SET V2E1=$GET(^PRCD(420.6,+V2E,0))
SET V2E2=$PIECE(V2E1,U,1)
+25 IF V2E=""
SET V2E2=""
+26 SET V2=V2E2_U_$PIECE(POAMT3,U,3)
SET V3=V1_V2
+27 SET POAMT4=PPOKEY_U_POAMT2_U_V3
+28 IF +POAMT2>0
SET ^TMP($JOB,"POAMT",POID,POAMT2,0)=POAMT4
+29 ; Po Amount Breakout code
DO PAMBCD
+30 QUIT
End DoDot:2
+31 QUIT
End DoDot:1
+32 QUIT
PAMBCD ; PO Amount Breakout code
+1 NEW PAMBC,PAMBC1,PAMBC2,PAMBC3,PAMBC4,VBCE,VBCE1,VBCE2
+2 SET PAMBC=0
SET PAMBC1=0
SET PAMBC2=0
SET PAMBC3=0
+3 SET PAMBC=$GET(^PRC(442,POID,9,POAMT2,1,0))
+4 SET PAMBC1=$PIECE(PAMBC,U,3)
+5 IF +PAMBC1>0
Begin DoDot:1
+6 FOR
SET PAMBC2=$ORDER(^PRC(442,POID,9,POAMT2,1,PAMBC2))
if PAMBC2=""
QUIT
Begin DoDot:2
+7 if +PAMBC2<0
QUIT
+8 SET PAMBC3=$GET(^PRC(442,POID,9,POAMT2,1,PAMBC2,0))
+9 ;
+10 ; get external value for breakout code
+11 SET VBCE=$PIECE(PAMBC3,U,1)
+12 IF VBCE'=""
SET VBCE1=$GET(^PRCD(420.6,+VBCE,0))
SET VBCE2=$PIECE(VBCE1,U,1)
+13 IF VBCE=""
SET VBCE2=""
+14 SET PAMBC4=PPOKEY_U_POAMT2_U_PAMBC2_U_VBCE2
+15 IF +PAMBC2>0
SET ^TMP($JOB,"POBKCOD",POID,POAMT2,PAMBC2,0)=PAMBC4
+16 QUIT
End DoDot:2
+17 QUIT
End DoDot:1
+18 QUIT
POAMMD ; PO Amendment Table (multiple)
+1 NEW POAMD,POAMD1,POAMD2,POAMD3,POAMD3A,POAMD4,V1,V2,V3,V2E,V2E1,V2E2
+2 NEW V3E,V3E1,V3E2,V1E,V1E1,V1E2,VL6,VL7,VL8,VL9
+3 SET POAMD=$GET(^PRC(442,POID,6,0))
+4 SET POAMD1=$PIECE(POAMD,U,3)
+5 SET POAMD2=0
+6 FOR
SET POAMD2=$ORDER(^PRC(442,POID,6,POAMD2))
if +POAMD2'>0
QUIT
Begin DoDot:1
+7 SET POAMD3=$GET(^PRC(442,POID,6,POAMD2,0))
+8 SET POAMD3A=$GET(^PRC(442,POID,6,POAMD2,1))
+9 ; V1-V3, $Get the data, $P the values, pad with "^" delimiters
+10 ; get external date for EffectiveDate
+11 SET V1E=$PIECE(POAMD3,U,2)
SET V1E1=$PIECE(V1E,".",1)
+12 IF V1E'=""
SET V1E2=$$FMTE^XLFDT(V1E1)
+13 IF V1E=""
SET V1E2=""
+14 SET V1=$PIECE(POAMD3,U,1)_U_V1E2_U_$PIECE(POAMD3,U,3)_U
+15 ; get external value for pAPPMaUthorizedBuyer
+16 SET V2E=$PIECE(POAMD3A,U,1)
+17 IF V2E'=""
SET V2E1=$GET(^VA(200,+V2E,0))
SET V2E2=$PIECE(V2E1,U,1)
+18 IF V2E=""
SET V2E2=""
+19 ;SERVICE - pAPPMaUthorizedBuyer
SET VL8=$PIECE($GET(^VA(200,+V2E,5)),U)
+20 ;SVC ext - pAPPMaUthorizedBuyer
SET VL9=$SELECT(VL8="":"",1:$$GET1^DIQ(49,+VL8_",",.01))
+21 ; get external value for AmendmentAdjustment
+22 SET V3E=$PIECE(POAMD3A,U,4)
+23 IF V3E'=""
SET V3E1=$GET(^PRCD(442.3,+V3E,0))
SET V3E2=$PIECE(V3E1,U,1)
+24 IF V3E=""
SET V3E2=""
+25 ;Fiscal Approv
SET VL6=$PIECE(POAMD3A,U,5)
SET VL7=$PIECE($GET(^VA(200,+VL6,0)),U)
+26 SET V2=V2E2_U_V3E2
SET V3=V1_V2_U_V2E_U_VL6_U_VL7
+27 ;SERVICE - Fiscal Approv
SET V1=$PIECE($GET(^VA(200,+VL6,5)),U)
+28 ;SVC ext - Fiscal Approv
SET V2=$SELECT(V1="":"",1:$$GET1^DIQ(49,+V1_",",.01))
+29 SET POAMD4=PPOKEY_U_POAMD2_U_V3_U_VL8_U_VL9_U_V1_U_V2
+30 SET ^TMP($JOB,"POAMMD",POID,POAMD2,0)=POAMD4
+31 ; Check for Amendment Changes
DO POAMCH
+32 ; Check for Amendment Description
DO POAMDS
+33 QUIT
End DoDot:1
+34 QUIT
POAMCH ; PO Amendment Changes Table (mulitple)
+1 NEW POAMC,POAMC1,POAMC2,POAMC3,POAMC4,POAMC5,POAMC6
+2 SET POAMC=$GET(^PRC(442,POID,6,POAMD2,3,0))
+3 SET POAMC1=$PIECE(POAMC,U,3)
+4 SET POAMC2=0
+5 FOR
SET POAMC2=$ORDER(^PRC(442,POID,6,POAMD2,3,POAMC2))
if +POAMC2'>0
QUIT
Begin DoDot:1
+6 SET POAMC3=$GET(^PRC(442,POID,6,POAMD2,3,POAMC2,0))
+7 SET POAMC4=$PIECE(POAMC3,U,1)
SET POAMC5=$PIECE(POAMC3,U,2)
+8 SET POAMC6=PPOKEY_U_POAMD2_U_POAMC2_U_POAMC4_U_POAMC5
+9 SET ^TMP($JOB,"POAMMDCH",POID,POAMD2,POAMC2,0)=POAMC6
+10 QUIT
End DoDot:1
+11 QUIT
POAMDS ; PO Amendment Description Table
+1 NEW POADD,POADD1,POADD2,POADD3,POADD4
+2 SET POADD=$GET(^PRC(442,POID,6,POAMD2,2,0))
+3 IF $DATA(POADD)
Begin DoDot:1
+4 SET POADD1=0
+5 FOR
SET POADD1=$ORDER(^PRC(442,POID,6,POAMD2,2,POADD1))
if POADD1=""
QUIT
Begin DoDot:2
+6 ; mult
SET POADD2=$GET(^PRC(442,POID,6,POAMD2,2,POADD1,0))
+7 SET POADD3=PPOKEY_U_POAMD2_U_POADD1_U_POADD2
+8 ; Get the 1st "1"
if +POADD1>1
QUIT
+9 IF +POAMD2>0
SET ^TMP($JOB,"POAMMDDES",POID,POAMD2,POADD1,0)=POADD3
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
POCMTS ; PocommentsTable
+1 NEW POCMTS,POCMTS1
+2 ; 1st line
SET POCMTS=$GET(^PRC(442,POID,4,1,0))
+3 ; Get the 1st 175 Chars
SET POCMTS1=$EXTRACT(POCMTS,1,175)
+4 ; Get the 1st 175 Char of 1st comment only
+5 IF POCMTS'=""
SET ^TMP($JOB,"POCOMMENTS",POID)=PPOKEY_U_1_U_POCMTS1
+6 QUIT
PORMKS ; PoRemarks Table
+1 NEW PORMKS,PORMKS1
+2 ; 1st Line, 1st Comment
SET PORMKS=$GET(^PRC(442,POID,16,1,0))
+3 ; Get the 1st 175 Chars
SET PORMKS1=$EXTRACT(PORMKS,1,175)
+4 ; gET 1st 175 Characters of 1st remark
+5 IF PORMKS'=""
SET ^TMP($JOB,"POREMARKS",POID)=PPOKEY_U_1_U_PORMKS1
+6 QUIT
LPPODIS ; Loop on PO Discount
+1 IF CKDS1>0
Begin DoDot:1
+2 FOR
SET PPO=$ORDER(^PRC(442,POID,3,PPO))
if PPO=""
QUIT
Begin DoDot:2
+3 SET PPOVAL=$GET(^PRC(442,POID,3,PPO,0))
+4 ; disc itm & %$tot
SET V1=$PIECE(PPOVAL,U,1)_U_$PIECE(PPOVAL,U,2)_U
+5 ; DiscAmt & ItmCt
SET V2=$PIECE(PPOVAL,U,3)_U_$PIECE(PPOVAL,U,4)_U
+6 ; contract & lineItem
SET V3=$PIECE(PPOVAL,U,5)_U_$PIECE(PPOVAL,U,6)
+7 ; all data
SET V4=V1_V2_V3
+8 SET PPOVAL1=PPOKEY_U_PPO_U_V4
+9 SET ^TMP($JOB,"PODISC",POID,PPO)=PPOVAL1
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
LPPOBC ; Loop PoBoc Table
+1 FOR
SET PPO=$ORDER(^PRC(442,POID,22,PPO))
if PPO=""
QUIT
Begin DoDot:1
+2 ; don't want B index
if PPO="B"
QUIT
+3 SET PPOVAL=$GET(^PRC(442,POID,22,PPO,0))
+4 SET PPOVAL1=$PIECE(PPOVAL,U,1)_U_$PIECE(PPOVAL,U,2)
+5 ;FMS LINE
SET PPOVAL1=PPOVAL1_U_$PIECE(PPOVAL,U,3)
+6 SET PPOVAL2=PPOKEY_U_PPO_U_PPOVAL1
+7 SET ^TMP($JOB,"POBOC",POID,PPO)=PPOVAL2
+8 QUIT
End DoDot:1
+9 QUIT
LP2237 ; Loop 2237
+1 NEW PPOVAL,PPV1,PPV2,PPV3,PPV4,PPV5,PPV6,PPV7,PPVALL,POKEY,PPOVAL2
+2 NEW PPV1E,PPV1E1,PPV2E,PPV2E1,PPV4E1,PPV4E2,PPV7E,PPV7E1,PPV7E2
+3 NEW PPV3E,PPV3E1,VL6,VL7,VL8,VL9
+4 FOR
SET PPO=$ORDER(^PRC(442,POID,13,PPO))
if PPO=""
QUIT
Begin DoDot:1
+5 SET PPOVAL=$GET(^PRC(442,POID,13,PPO,0))
+6 SET PPV1=$PIECE(PPOVAL,U,1)
SET PPV2=$PIECE(PPOVAL,U,2)
SET PPV3=$PIECE(PPOVAL,U,4)
+7 ; external value for 2237 PPV1
+8 IF PPV1'=""
SET PPV1E=$GET(^PRCS(410,+PPV1,0))
SET PPV1E1=$PIECE(PPV1E,U,1)
+9 IF PPV1=""
SET PPV1E1=""
+10 ; external value for Accountable Officer PPV2
+11 IF PPV2'=""
SET PPV2E=$GET(^VA(200,+PPV2,0))
SET PPV2E1=$PIECE(PPV2E,U,1)
+12 IF PPV2=""
SET PPV2E1=""
+13 ;Service - Acc Office
SET VL6=$PIECE($GET(^VA(200,+PPV2,5)),"^")
+14 ;SVC ext - Acc Office
SET VL7=$SELECT(VL6="":"",1:$$GET1^DIQ(49,+VL6_",",.01))
+15 ; ext. date value for Date Signed
+16 IF PPV3'=""
SET PPV3E=$PIECE(PPV3,".",1)
SET PPV3E1=$$FMTE^XLFDT(PPV3E)
+17 IF PPV3=""
SET PPV3E1=""
+18 SET PPV4=$PIECE(PPOVAL,U,5)
SET PPV5=$PIECE(PPOVAL,U,9)
SET PPV6=$PIECE(PPOVAL,U,10)
+19 ; external for Purchasing agent PPV4
+20 ;
+21 IF PPV4'=""
SET PPV4E1=$GET(^VA(200,+PPV4,0))
SET PPV4E2=$PIECE(PPV4E1,U,1)
+22 IF PPV4=""
SET PPV4E2=""
+23 ;Service - Purchase Agent
SET VL8=$PIECE($GET(^VA(200,+PPV4,5)),"^")
+24 ;SVC ext - Purchase Agent
SET VL9=$SELECT(VL8="":"",1:$$GET1^DIQ(49,+VL8_",",.01))
+25 ; get external value for InvDistPoint
+26 SET PPV7E=$PIECE(PPOVAL,U,11)
+27 IF PPV7E'=""
SET PPV7E1=$GET(^PRCP(445,+PPV7E,0))
SET PPV7E2=$PIECE(PPV7E1,U,1)
+28 IF PPV7E=""
SET PPV7E2=""
+29 SET PPV7=PPV7E2
+30 SET PPVALL=PPV1E1_U_PPV2E1_U_PPV3E1_U_PPV4E2_U_PPV5_U_PPV6_U_PPV7_U_$PIECE(PPOVAL,U,5)_U_$PIECE(PPOVAL,U,2)
+31 ;
+32 SET PPOVAL2=PPOKEY_U_PPO_U_PPVALL
+33 SET ^TMP($JOB,"PO2237",POID,PPO)=PPOVAL2_U_VL8_U_VL9_U_VL6_U_VL7
+34 QUIT
End DoDot:1
+35 QUIT
PODISCH ; PO Discount Header File
+1 ; Header file for PO Discount Multiple
+2 WRITE "PoIdNum^PurchaseOrderNum^PoDate^MonthYrRun^StationNum^"
+3 WRITE "DiscountIdNum^DiscountItem^PercentDollarAmount^"
+4 WRITE "DiscountAmount^ItemCount^Contract^LineItem",!
+5 QUIT
