Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHLO1A

PRCHLO1A.m

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