PRCHLO2A ;WOIFO/RLL/DAP-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ;5/22/09 14:12
;;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 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
N X
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 PPALL=PPALL_U_PP2 ;DUZ Obligated By
. . S PPALL=PPALL_U_PP5 ;IEN 1358 Adjustment
. . S X=$P(PPOVAL,U,6) S:X'="" X=$$FMTE^XLFDT($P(X,"."))
. . S PPALL=PPALL_U_X ;Date Signed
. . S X=$P(PPOVAL,U,12) S:X'="" X=$$FMTE^XLFDT(X)
. . S PPALL=PPALL_U_X ;Obligation Process Date
. . S X=$P(PPOVAL,U,13) S:X'="" X=$P("JAN;FEB;MAR;APR;MAY;JUN;JUL;AUG;SEP;OCT;NOV;DEC",";",+$E(X,4,5))_" "_(1700+$E(X,1,3))
. . S PPALL=PPALL_U_X ;Accounting Period
. . ;
. . S PP2=$P($G(^VA(200,+PP2,5)),U)
. . S PP3=$S(PP2="":"",1:$$GET1^DIQ(49,+PP2_",",.01))
. . S PPALL=PPALL_U_PP2_U_PP3 ;OBL BY SERVICE INT/EXT
. . ;
. . 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHLO2A 4959 printed Nov 22, 2024@17:18:36 Page 2
PRCHLO2A ;WOIFO/RLL/DAP-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ;5/22/09 14:12
+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 PRCHLO2. This program includes the extract
+5 ; logic for each of the identified tables.
+6 ;
+7 QUIT
+8 ;
POOBL ; PO Obligation data
+1 ;PoObligationData Table 442.09 (multiple)
+2 ; ^PRC(442,POID,10,0)=^442.09
+3 ;
+4 NEW CKOB,PPO,PPOVAL,CKOB1,PP1,PP2,PP3,PP4,PP5,PP5E1,PP5E2,PP1A,PPALL
+5 NEW PP2E1,PP2E2
+6 SET CKOB=$GET(^PRC(442,POID,10,0))
SET PPO=0
+7 ;
+8 SET CKOB1=$PIECE(CKOB,U,3)
+9 ;
+10 ; Contains at least one Obligation, create rec.
IF +CKOB1>0
Begin DoDot:1
+11 ;
+12 DO LPPOOB
+13 QUIT
End DoDot:1
+14 QUIT
POPART ; PO Partial
+1 ;
+2 NEW CKPT,PPO,CKPT1,CKPT2
+3 SET CKPT=$GET(^PRC(442,POID,11,0))
SET PPO=0
+4 SET CKPT2=$PIECE(CKPT,U,3)
+5 ; Contains at least one PARTIAL, create rec
IF +CKPT2>0
Begin DoDot:1
+6 DO LPPART
End DoDot:1
+7 QUIT
POPMET ; PoPurchaseMethod Table
+1 NEW CKPM,PPO,PPOVAL,CKPM1,PPOVAL1E,PPOVAL2E
+2 SET CKPM=$GET(^PRC(442,POID,14,0))
SET PPO=0
+3 SET CKPM1=$PIECE(CKPM,U,3)
+4 ; Contains at lease one Purchase Method, create rec.
IF +CKPM1>0
Begin DoDot:1
+5 DO LPPM
End DoDot:1
+6 QUIT
POPPTER ; PopromptpaymentTermsTable
+1 NEW POPPT,POPPT1,PPO,PPOVAL,PPOVAL1
+2 SET POPPT=$GET(^PRC(442,POID,5,0))
+3 SET POPPT1=$PIECE(POPPT,U,3)
+4 ;Contains at least one PromptPayment Term, create rec
IF +POPPT1>0
Begin DoDot:1
+5 DO LPPOPTR
End DoDot:1
+6 QUIT
+7 ;
+8 QUIT
LPPOPTR ; Loop on Prompt Payment Terms
+1 SET PPO=0
+2 FOR
SET PPO=$ORDER(^PRC(442,POID,5,PPO))
if PPO=""
QUIT
Begin DoDot:1
+3 SET PPOVAL=$GET(^PRC(442,POID,5,PPO,0))
+4 SET PP1=$PIECE(PPOVAL,U,1)
SET PP2=$PIECE(PPOVAL,U,2)
SET PP3=$PIECE(PPOVAL,U,3)
+5 SET PP4=$PIECE(PPOVAL,U,4)
+6 SET PPOVAL1=PP1_U_PP2_U_PP3_U_PP4
+7 ; add key to data
+8 IF PPOVAL'=""
SET ^TMP($JOB,"POPROMPT",POID,PPO,0)=PPOKEY_U_PPO_U_PPOVAL1
+9 QUIT
End DoDot:1
+10 QUIT
LPPOOB ; Loop on PO Obligation
+1 NEW X
+2 IF CKOB1>0
Begin DoDot:1
+3 SET PPO=0
+4 FOR
SET PPO=$ORDER(^PRC(442,POID,10,PPO))
if PPO=""
QUIT
Begin DoDot:2
+5 SET PPOVAL=$GET(^PRC(442,POID,10,PPO,0))
+6 SET PP1=$PIECE(PPOVAL,U,1)
SET PP2=$PIECE(PPOVAL,U,2)
SET PP3=$PIECE(PPOVAL,U,3)
+7 ; get external for PP2, Obligated by
+8 IF PP2'=""
SET PP2E1=$GET(^VA(200,+PP2,0))
SET PP2E2=$PIECE(PP2E1,U,1)
+9 IF PP2=""
SET PP2E2=""
+10 SET PP4=$PIECE(PPOVAL,U,10)
SET PP5=$PIECE(PPOVAL,U,11)
+11 IF PP5'=""
SET PP5E1=$GET(^PRCS(410,+PP5,0))
SET PP5E2=$PIECE(PP5E1,U,1)
+12 IF PP5=""
SET PP5E2=""
+13 IF PP1'=""
SET PP1A=$PIECE(PP1,".",5)
SET PP1=$PIECE(PP1A,"@",1)
+14 SET PPALL=PP1_U_PP2E2_U_PP3_U_PP4_U_PP5E2
+15 ;DUZ Obligated By
SET PPALL=PPALL_U_PP2
+16 ;IEN 1358 Adjustment
SET PPALL=PPALL_U_PP5
+17 SET X=$PIECE(PPOVAL,U,6)
if X'=""
SET X=$$FMTE^XLFDT($PIECE(X,"."))
+18 ;Date Signed
SET PPALL=PPALL_U_X
+19 SET X=$PIECE(PPOVAL,U,12)
if X'=""
SET X=$$FMTE^XLFDT(X)
+20 ;Obligation Process Date
SET PPALL=PPALL_U_X
+21 SET X=$PIECE(PPOVAL,U,13)
if X'=""
SET X=$PIECE("JAN;FEB;MAR;APR;MAY;JUN;JUL;AUG;SEP;OCT;NOV;DEC",";",+$EXTRACT(X,4,5))_" "_(1700+$EXTRACT(X,1,3))
+22 ;Accounting Period
SET PPALL=PPALL_U_X
+23 ;
+24 SET PP2=$PIECE($GET(^VA(200,+PP2,5)),U)
+25 SET PP3=$SELECT(PP2="":"",1:$$GET1^DIQ(49,+PP2_",",.01))
+26 ;OBL BY SERVICE INT/EXT
SET PPALL=PPALL_U_PP2_U_PP3
+27 ;
+28 SET ^TMP($JOB,"POOBLG",POID,PPO)=PPOKEY_U_PPO_U_PPALL
+29 QUIT
End DoDot:2
+30 QUIT
End DoDot:1
+31 QUIT
LPPM ; Loop PoPoPurchaseMethod Table
+1 FOR
SET PPO=$ORDER(^PRC(442,POID,14,PPO))
if PPO=""
QUIT
Begin DoDot:1
+2 ; don't want B index
if PPO="B"
QUIT
+3 SET PPOVAL=$GET(^PRC(442,POID,14,PPO,0))
+4 ;
+5 SET PPOVAL1=$PIECE(PPOVAL,U,1)
+6 ; Get external value of PPOVAL1
+7 IF PPOVAL1'=""
SET PPOVAL1E=$GET(^PRC(442.4,+PPOVAL1,0))
SET PPOVAL2E=$PIECE(PPOVAL1E,U,3)
+8 IF PPOVAL1=""
SET PPOVAL2E=""
+9 SET PPOVAL2=PPOKEY_U_PPO_U_PPOVAL2E
+10 SET ^TMP($JOB,"POPMETH",POID,PPO)=PPOVAL2
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
LPPART ; Loop on Partial
+1 NEW PPOVAL,PPV1,PPV2,PPV3,PPV4,PPV5,PPV6,PPV7,PPVALL,POKEY,PPOVAL2
+2 NEW PPOVAL1,PPV8,PPV9,PPV10,PPV11,PPV12,PPV13,PPVALL1
+3 NEW PPV3E1,PPV3E2,PPV5E1,PPV5E2,PPV1E,PPV1E1,PPV2E,PPV2E1
+4 FOR
SET PPO=$ORDER(^PRC(442,POID,11,PPO))
if PPO=""
QUIT
Begin DoDot:1
+5 SET PPOVAL=$GET(^PRC(442,POID,11,PPO,0))
+6 SET PPOVAL1=$GET(^PRC(442,POID,11,PPO,1))
+7 SET PPV1=$PIECE(PPOVAL,U,1)
SET PPV2=$PIECE(PPOVAL1,U,8)
SET PPV3=$PIECE(PPOVAL,U,2)
+8 ; get external date value for Date
+9 IF PPV1'=""
SET PPV1E=$PIECE(PPV1,".",1)
SET PPV1E1=$$FMTE^XLFDT(PPV1E)
+10 IF PPV1=""
SET PPV1E1=""
+11 ; get external date value for Scheduled delivery date
+12 IF PPV2'=""
SET PPV2E=$PIECE(PPV2,".",1)
SET PPV2E1=$$FMTE^XLFDT(PPV2E)
+13 IF PPV2=""
SET PPV2E1=""
+14 ; get external value for PPV3
+15 IF PPV3'=""
SET PPV3E1=$GET(^PRCD(420.2,+PPV3,0))
SET PPV3E2=$PIECE(PPV3E1,U,1)
+16 IF PPV3=""
SET PPV3E2=""
+17 SET PPV4=$PIECE(PPOVAL,U,3)
SET PPV5=$PIECE(PPOVAL,U,4)
SET PPV6=$PIECE(PPOVAL,U,5)
+18 ; get external value for PPV5
+19 IF PPV5'=""
SET PPV5E1=$GET(^PRCD(420.2,+PPV5,0))
SET PPV5E2=$PIECE(PPV5E1,U,1)
+20 IF PPV5=""
SET PPV5E2=""
+21 SET PPV7=$PIECE(PPOVAL,U,9)
SET PPV8=$PIECE(PPOVAL,U,10)
SET PPV9=$PIECE(PPOVAL,U,12)
+22 SET PPV10=$PIECE(PPOVAL,U,13)
SET PPV11=$PIECE(PPOVAL,U,14)
SET PPV12=$PIECE(PPOVAL1,U,16)
+23 SET PPV13=$PIECE(PPOVAL,U,21)
+24 SET PPVALL=PPV1E1_U_PPV2E1_U_PPV3E2_U_PPV4_U_PPV5E2_U_PPV6_U_PPV7
+25 SET PPVALL1=PPVALL_U_PPV8_U_PPV9_U_PPV10_U_PPV11_U_PPV12_U_PPV13
+26 ;
+27 SET PPOVAL2=PPOKEY_U_PPO_U_PPVALL1
+28 SET ^TMP($JOB,"POPART",POID,PPO)=PPOVAL2
+29 QUIT
End DoDot:1
+30 QUIT
