| [613] | 1 | PRCHLO2A ;WOIFO/RLL/DAP-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ; 11/3/05 8:22am
|
|---|
| 2 | V ;;5.1;IFCAP;**83**;; Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ; Continuation of PRCHLO2. This program includes the extract
|
|---|
| 5 | ; logic for each of the identified tables.
|
|---|
| 6 | ;
|
|---|
| 7 | Q
|
|---|
| 8 | ;
|
|---|
| 9 | POOBL ; PO Obligation data
|
|---|
| 10 | ;PoObligationData Table 442.09 (multiple)
|
|---|
| 11 | ; ^PRC(442,POID,10,0)=^442.09
|
|---|
| 12 | ;
|
|---|
| 13 | N CKOB,PPO,PPOVAL,CKOB1,PP1,PP2,PP3,PP4,PP5,PP5E1,PP5E2,PP1A,PPALL
|
|---|
| 14 | N PP2E1,PP2E2
|
|---|
| 15 | S CKOB=$G(^PRC(442,POID,10,0)),PPO=0
|
|---|
| 16 | ;
|
|---|
| 17 | S CKOB1=$P(CKOB,U,3)
|
|---|
| 18 | ;
|
|---|
| 19 | I +CKOB1>0 D ; Contains at least one Obligation, create rec.
|
|---|
| 20 | . ;
|
|---|
| 21 | . D LPPOOB
|
|---|
| 22 | . Q
|
|---|
| 23 | Q
|
|---|
| 24 | POPART ; PO Partial
|
|---|
| 25 | ;
|
|---|
| 26 | N CKPT,PPO,CKPT1,CKPT2
|
|---|
| 27 | S CKPT=$G(^PRC(442,POID,11,0)),PPO=0
|
|---|
| 28 | S CKPT2=$P(CKPT,U,3)
|
|---|
| 29 | I +CKPT2>0 D ; Contains at least one PARTIAL, create rec
|
|---|
| 30 | . D LPPART
|
|---|
| 31 | Q
|
|---|
| 32 | POPMET ; PoPurchaseMethod Table
|
|---|
| 33 | N CKPM,PPO,PPOVAL,CKPM1,PPOVAL1E,PPOVAL2E
|
|---|
| 34 | S CKPM=$G(^PRC(442,POID,14,0)),PPO=0
|
|---|
| 35 | S CKPM1=$P(CKPM,U,3)
|
|---|
| 36 | I +CKPM1>0 D ; Contains at lease one Purchase Method, create rec.
|
|---|
| 37 | . D LPPM
|
|---|
| 38 | Q
|
|---|
| 39 | POPPTER ; PopromptpaymentTermsTable
|
|---|
| 40 | N POPPT,POPPT1,PPO,PPOVAL,PPOVAL1
|
|---|
| 41 | S POPPT=$G(^PRC(442,POID,5,0))
|
|---|
| 42 | S POPPT1=$P(POPPT,U,3)
|
|---|
| 43 | I +POPPT1>0 D ;Contains at least one PromptPayment Term, create rec
|
|---|
| 44 | . D LPPOPTR
|
|---|
| 45 | Q
|
|---|
| 46 | ;
|
|---|
| 47 | Q
|
|---|
| 48 | LPPOPTR ; Loop on Prompt Payment Terms
|
|---|
| 49 | S PPO=0
|
|---|
| 50 | F S PPO=$O(^PRC(442,POID,5,PPO)) Q:PPO="" D
|
|---|
| 51 | . S PPOVAL=$G(^PRC(442,POID,5,PPO,0))
|
|---|
| 52 | . S PP1=$P(PPOVAL,U,1),PP2=$P(PPOVAL,U,2),PP3=$P(PPOVAL,U,3)
|
|---|
| 53 | . S PP4=$P(PPOVAL,U,4)
|
|---|
| 54 | . S PPOVAL1=PP1_U_PP2_U_PP3_U_PP4
|
|---|
| 55 | . ; add key to data
|
|---|
| 56 | . I PPOVAL'="" S ^TMP($J,"POPROMPT",POID,PPO,0)=PPOKEY_U_PPO_U_PPOVAL1
|
|---|
| 57 | . Q
|
|---|
| 58 | Q
|
|---|
| 59 | LPPOOB ; Loop on PO Obligation
|
|---|
| 60 | I CKOB1>0 D
|
|---|
| 61 | . S PPO=0
|
|---|
| 62 | . F S PPO=$O(^PRC(442,POID,10,PPO)) Q:PPO="" D
|
|---|
| 63 | . . S PPOVAL=$G(^PRC(442,POID,10,PPO,0))
|
|---|
| 64 | . . S PP1=$P(PPOVAL,U,1),PP2=$P(PPOVAL,U,2),PP3=$P(PPOVAL,U,3)
|
|---|
| 65 | . . ; get external for PP2, Obligated by
|
|---|
| 66 | . . I PP2'="" S PP2E1=$G(^VA(200,+PP2,0)),PP2E2=$P(PP2E1,U,1)
|
|---|
| 67 | . . I PP2="" S PP2E2=""
|
|---|
| 68 | . . S PP4=$P(PPOVAL,U,10),PP5=$P(PPOVAL,U,11)
|
|---|
| 69 | . . I PP5'="" S PP5E1=$G(^PRCS(410,+PP5,0)),PP5E2=$P(PP5E1,U,1)
|
|---|
| 70 | . . I PP5="" S PP5E2=""
|
|---|
| 71 | . . I PP1'="" S PP1A=$P(PP1,".",5),PP1=$P(PP1A,"@",1)
|
|---|
| 72 | . . S PPALL=PP1_U_PP2E2_U_PP3_U_PP4_U_PP5E2
|
|---|
| 73 | . . ;
|
|---|
| 74 | . . ;
|
|---|
| 75 | . . ;
|
|---|
| 76 | . . S ^TMP($J,"POOBLG",POID,PPO)=PPOKEY_U_PPO_U_PPALL
|
|---|
| 77 | . . Q
|
|---|
| 78 | . Q
|
|---|
| 79 | Q
|
|---|
| 80 | LPPM ; Loop PoPoPurchaseMethod Table
|
|---|
| 81 | F S PPO=$O(^PRC(442,POID,14,PPO)) Q:PPO="" D
|
|---|
| 82 | . Q:PPO="B" ; don't want B index
|
|---|
| 83 | . S PPOVAL=$G(^PRC(442,POID,14,PPO,0))
|
|---|
| 84 | . ;
|
|---|
| 85 | . S PPOVAL1=$P(PPOVAL,U,1)
|
|---|
| 86 | . ; Get external value of PPOVAL1
|
|---|
| 87 | . I PPOVAL1'="" S PPOVAL1E=$G(^PRC(442.4,+PPOVAL1,0)),PPOVAL2E=$P(PPOVAL1E,U,3)
|
|---|
| 88 | . I PPOVAL1="" S PPOVAL2E=""
|
|---|
| 89 | . S PPOVAL2=PPOKEY_U_PPO_U_PPOVAL2E
|
|---|
| 90 | . S ^TMP($J,"POPMETH",POID,PPO)=PPOVAL2
|
|---|
| 91 | . Q
|
|---|
| 92 | Q
|
|---|
| 93 | ;
|
|---|
| 94 | LPPART ; Loop on Partial
|
|---|
| 95 | N PPOVAL,PPV1,PPV2,PPV3,PPV4,PPV5,PPV6,PPV7,PPVALL,POKEY,PPOVAL2
|
|---|
| 96 | N PPOVAL1,PPV8,PPV9,PPV10,PPV11,PPV12,PPV13,PPVALL1
|
|---|
| 97 | N PPV3E1,PPV3E2,PPV5E1,PPV5E2,PPV1E,PPV1E1,PPV2E,PPV2E1
|
|---|
| 98 | F S PPO=$O(^PRC(442,POID,11,PPO)) Q:PPO="" D
|
|---|
| 99 | . S PPOVAL=$G(^PRC(442,POID,11,PPO,0))
|
|---|
| 100 | . S PPOVAL1=$G(^PRC(442,POID,11,PPO,1))
|
|---|
| 101 | . S PPV1=$P(PPOVAL,U,1),PPV2=$P(PPOVAL1,U,8),PPV3=$P(PPOVAL,U,2)
|
|---|
| 102 | . ; get external date value for Date
|
|---|
| 103 | . I PPV1'="" S PPV1E=$P(PPV1,".",1),PPV1E1=$$FMTE^XLFDT(PPV1E)
|
|---|
| 104 | . I PPV1="" S PPV1E1=""
|
|---|
| 105 | . ; get external date value for Scheduled delivery date
|
|---|
| 106 | . I PPV2'="" S PPV2E=$P(PPV2,".",1),PPV2E1=$$FMTE^XLFDT(PPV2E)
|
|---|
| 107 | . I PPV2="" S PPV2E1=""
|
|---|
| 108 | . ; get external value for PPV3
|
|---|
| 109 | . I PPV3'="" S PPV3E1=$G(^PRCD(420.2,+PPV3,0)),PPV3E2=$P(PPV3E1,U,1)
|
|---|
| 110 | . I PPV3="" S PPV3E2=""
|
|---|
| 111 | . S PPV4=$P(PPOVAL,U,3),PPV5=$P(PPOVAL,U,4),PPV6=$P(PPOVAL,U,5)
|
|---|
| 112 | . ; get external value for PPV5
|
|---|
| 113 | . I PPV5'="" S PPV5E1=$G(^PRCD(420.2,+PPV5,0)),PPV5E2=$P(PPV5E1,U,1)
|
|---|
| 114 | . I PPV5="" S PPV5E2=""
|
|---|
| 115 | . S PPV7=$P(PPOVAL,U,9),PPV8=$P(PPOVAL,U,10),PPV9=$P(PPOVAL,U,12)
|
|---|
| 116 | . S PPV10=$P(PPOVAL,U,13),PPV11=$P(PPOVAL,U,14),PPV12=$P(PPOVAL1,U,16)
|
|---|
| 117 | . S PPV13=$P(PPOVAL,U,21)
|
|---|
| 118 | . S PPVALL=PPV1E1_U_PPV2E1_U_PPV3E2_U_PPV4_U_PPV5E2_U_PPV6_U_PPV7
|
|---|
| 119 | . S PPVALL1=PPVALL_U_PPV8_U_PPV9_U_PPV10_U_PPV11_U_PPV12_U_PPV13
|
|---|
| 120 | . ;
|
|---|
| 121 | . S PPOVAL2=PPOKEY_U_PPO_U_PPVALL1
|
|---|
| 122 | . S ^TMP($J,"POPART",POID,PPO)=PPOVAL2
|
|---|
| 123 | . Q
|
|---|
| 124 | Q
|
|---|
