source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHLO2A.m@ 1226

Last change on this file since 1226 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.0 KB
Line 
1PRCHLO2A ;WOIFO/RLL/DAP-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ; 11/3/05 8:22am
2V ;;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 ;
9POOBL ; 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
24POPART ; 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
32POPMET ; 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
39POPPTER ; 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
48LPPOPTR ; 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
59LPPOOB ; 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
80LPPM ; 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 ;
94LPPART ; 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
Note: See TracBrowser for help on using the repository browser.