- 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 Feb 18, 2025@23:34:53 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