- 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 Feb 18, 2025@23:34:51 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