125 lines
4.0 KiB
Mathematica
125 lines
4.0 KiB
Mathematica
PRCHLO2A ;WOIFO/RLL/DAP-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ; 11/3/05 8:22am
|
|
V ;;5.1;IFCAP;**83**;; Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
; Continuation of PRCHLO2. This program includes the extract
|
|
; logic for each of the identified tables.
|
|
;
|
|
Q
|
|
;
|
|
POOBL ; PO Obligation data
|
|
;PoObligationData Table 442.09 (multiple)
|
|
; ^PRC(442,POID,10,0)=^442.09
|
|
;
|
|
N CKOB,PPO,PPOVAL,CKOB1,PP1,PP2,PP3,PP4,PP5,PP5E1,PP5E2,PP1A,PPALL
|
|
N PP2E1,PP2E2
|
|
S CKOB=$G(^PRC(442,POID,10,0)),PPO=0
|
|
;
|
|
S CKOB1=$P(CKOB,U,3)
|
|
;
|
|
I +CKOB1>0 D ; Contains at least one Obligation, create rec.
|
|
. ;
|
|
. D LPPOOB
|
|
. Q
|
|
Q
|
|
POPART ; PO Partial
|
|
;
|
|
N CKPT,PPO,CKPT1,CKPT2
|
|
S CKPT=$G(^PRC(442,POID,11,0)),PPO=0
|
|
S CKPT2=$P(CKPT,U,3)
|
|
I +CKPT2>0 D ; Contains at least one PARTIAL, create rec
|
|
. D LPPART
|
|
Q
|
|
POPMET ; PoPurchaseMethod Table
|
|
N CKPM,PPO,PPOVAL,CKPM1,PPOVAL1E,PPOVAL2E
|
|
S CKPM=$G(^PRC(442,POID,14,0)),PPO=0
|
|
S CKPM1=$P(CKPM,U,3)
|
|
I +CKPM1>0 D ; Contains at lease one Purchase Method, create rec.
|
|
. D LPPM
|
|
Q
|
|
POPPTER ; PopromptpaymentTermsTable
|
|
N POPPT,POPPT1,PPO,PPOVAL,PPOVAL1
|
|
S POPPT=$G(^PRC(442,POID,5,0))
|
|
S POPPT1=$P(POPPT,U,3)
|
|
I +POPPT1>0 D ;Contains at least one PromptPayment Term, create rec
|
|
. D LPPOPTR
|
|
Q
|
|
;
|
|
Q
|
|
LPPOPTR ; Loop on Prompt Payment Terms
|
|
S PPO=0
|
|
F S PPO=$O(^PRC(442,POID,5,PPO)) Q:PPO="" D
|
|
. S PPOVAL=$G(^PRC(442,POID,5,PPO,0))
|
|
. S PP1=$P(PPOVAL,U,1),PP2=$P(PPOVAL,U,2),PP3=$P(PPOVAL,U,3)
|
|
. S PP4=$P(PPOVAL,U,4)
|
|
. S PPOVAL1=PP1_U_PP2_U_PP3_U_PP4
|
|
. ; add key to data
|
|
. I PPOVAL'="" S ^TMP($J,"POPROMPT",POID,PPO,0)=PPOKEY_U_PPO_U_PPOVAL1
|
|
. Q
|
|
Q
|
|
LPPOOB ; Loop on PO Obligation
|
|
I CKOB1>0 D
|
|
. S PPO=0
|
|
. F S PPO=$O(^PRC(442,POID,10,PPO)) Q:PPO="" D
|
|
. . S PPOVAL=$G(^PRC(442,POID,10,PPO,0))
|
|
. . S PP1=$P(PPOVAL,U,1),PP2=$P(PPOVAL,U,2),PP3=$P(PPOVAL,U,3)
|
|
. . ; get external for PP2, Obligated by
|
|
. . I PP2'="" S PP2E1=$G(^VA(200,+PP2,0)),PP2E2=$P(PP2E1,U,1)
|
|
. . I PP2="" S PP2E2=""
|
|
. . S PP4=$P(PPOVAL,U,10),PP5=$P(PPOVAL,U,11)
|
|
. . I PP5'="" S PP5E1=$G(^PRCS(410,+PP5,0)),PP5E2=$P(PP5E1,U,1)
|
|
. . I PP5="" S PP5E2=""
|
|
. . I PP1'="" S PP1A=$P(PP1,".",5),PP1=$P(PP1A,"@",1)
|
|
. . S PPALL=PP1_U_PP2E2_U_PP3_U_PP4_U_PP5E2
|
|
. . ;
|
|
. . ;
|
|
. . ;
|
|
. . S ^TMP($J,"POOBLG",POID,PPO)=PPOKEY_U_PPO_U_PPALL
|
|
. . Q
|
|
. Q
|
|
Q
|
|
LPPM ; Loop PoPoPurchaseMethod Table
|
|
F S PPO=$O(^PRC(442,POID,14,PPO)) Q:PPO="" D
|
|
. Q:PPO="B" ; don't want B index
|
|
. S PPOVAL=$G(^PRC(442,POID,14,PPO,0))
|
|
. ;
|
|
. S PPOVAL1=$P(PPOVAL,U,1)
|
|
. ; Get external value of PPOVAL1
|
|
. I PPOVAL1'="" S PPOVAL1E=$G(^PRC(442.4,+PPOVAL1,0)),PPOVAL2E=$P(PPOVAL1E,U,3)
|
|
. I PPOVAL1="" S PPOVAL2E=""
|
|
. S PPOVAL2=PPOKEY_U_PPO_U_PPOVAL2E
|
|
. S ^TMP($J,"POPMETH",POID,PPO)=PPOVAL2
|
|
. Q
|
|
Q
|
|
;
|
|
LPPART ; Loop on Partial
|
|
N PPOVAL,PPV1,PPV2,PPV3,PPV4,PPV5,PPV6,PPV7,PPVALL,POKEY,PPOVAL2
|
|
N PPOVAL1,PPV8,PPV9,PPV10,PPV11,PPV12,PPV13,PPVALL1
|
|
N PPV3E1,PPV3E2,PPV5E1,PPV5E2,PPV1E,PPV1E1,PPV2E,PPV2E1
|
|
F S PPO=$O(^PRC(442,POID,11,PPO)) Q:PPO="" D
|
|
. S PPOVAL=$G(^PRC(442,POID,11,PPO,0))
|
|
. S PPOVAL1=$G(^PRC(442,POID,11,PPO,1))
|
|
. S PPV1=$P(PPOVAL,U,1),PPV2=$P(PPOVAL1,U,8),PPV3=$P(PPOVAL,U,2)
|
|
. ; get external date value for Date
|
|
. I PPV1'="" S PPV1E=$P(PPV1,".",1),PPV1E1=$$FMTE^XLFDT(PPV1E)
|
|
. I PPV1="" S PPV1E1=""
|
|
. ; get external date value for Scheduled delivery date
|
|
. I PPV2'="" S PPV2E=$P(PPV2,".",1),PPV2E1=$$FMTE^XLFDT(PPV2E)
|
|
. I PPV2="" S PPV2E1=""
|
|
. ; get external value for PPV3
|
|
. I PPV3'="" S PPV3E1=$G(^PRCD(420.2,+PPV3,0)),PPV3E2=$P(PPV3E1,U,1)
|
|
. I PPV3="" S PPV3E2=""
|
|
. S PPV4=$P(PPOVAL,U,3),PPV5=$P(PPOVAL,U,4),PPV6=$P(PPOVAL,U,5)
|
|
. ; get external value for PPV5
|
|
. I PPV5'="" S PPV5E1=$G(^PRCD(420.2,+PPV5,0)),PPV5E2=$P(PPV5E1,U,1)
|
|
. I PPV5="" S PPV5E2=""
|
|
. S PPV7=$P(PPOVAL,U,9),PPV8=$P(PPOVAL,U,10),PPV9=$P(PPOVAL,U,12)
|
|
. S PPV10=$P(PPOVAL,U,13),PPV11=$P(PPOVAL,U,14),PPV12=$P(PPOVAL1,U,16)
|
|
. S PPV13=$P(PPOVAL,U,21)
|
|
. S PPVALL=PPV1E1_U_PPV2E1_U_PPV3E2_U_PPV4_U_PPV5E2_U_PPV6_U_PPV7
|
|
. S PPVALL1=PPVALL_U_PPV8_U_PPV9_U_PPV10_U_PPV11_U_PPV12_U_PPV13
|
|
. ;
|
|
. S PPOVAL2=PPOKEY_U_PPO_U_PPVALL1
|
|
. S ^TMP($J,"POPART",POID,PPO)=PPOVAL2
|
|
. Q
|
|
Q
|