PRCHLO6 ;WOIFO/AS-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ; 10/8/10 1:11pm
;;5.1;IFCAP;**130,140,151,154**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
; DBIA 10093 - Read file 49 via FileMan.
; Continuation of PRCHLO1. This program builds the extracts for
; the Master PO Table and the associated multiples
GET410 ; get file 410 record
S U="^"
N PRCND,PRCIEN,PRCDT,PRCTMP,PRCTMB,PRCTR,PRCFR,PRCDAT,PRCDATO,PRCDATA,D0,X
N PRCDUZ,PRCIX,PRCAUIEN,PRCARY
; loop through file 410
S PRCIEN=0,PRCDT=""
F S PRCIEN=$O(^PRCS(410,PRCIEN)) Q:'PRCIEN D
. S PRCND=$G(^PRCS(410,PRCIEN,0)) ;NODE 0
. S PRCTR=$P(PRCND,U,2) ;TRANSACTION TYPE
. S PRCFR=$P(PRCND,U,4) ;FORM TYPE
. S PRCDAT=$P($G(^PRCS(410,PRCIEN,1)),U,1) ;DATE OF REQUEST
. S PRCDATO=$P($G(^PRCS(410,PRCIEN,4)),U,4) ;DATE OBLIGATED
. S PRCDATA=$P($G(^PRCS(410,PRCIEN,4)),U,7) ;DATE OBLIGATED ADJ
. ;TRANS TYPE IS ADJUSTMENT, FORM TYPE IS NOT NULL NOT ISSUE BOOK
. I PRCTR="A",PRCFR,PRCFR'=5,PRCDAT>CLOBGN,PRCDAT<CLOEND D DAT410 Q
. ;TRANS TYPE IS ADJUSTMENT, FORM TYPE ISSUE BOOK
. I PRCTR="A",PRCFR=5,PRCDATO>CLOBGN,PRCDATO<CLOEND D DAT410 Q
. ;TRANS TYPE IS OBLIGATION, WITH ANY FORM TYPE
. I PRCTR="O",PRCFR,PRCDAT>CLOBGN,PRCDAT<CLOEND D DAT410 Q
. ;TRANS TYPE IS CEILING, WITHOUT FORM TYPE
. I PRCTR="C",PRCDATO>CLOBGN,PRCDATO<CLOEND D DAT410 Q
. ;TRANS TYPE IS ADJUSTMENT, WITHOUT FORM TYPE
. I PRCTR="A",'PRCFR,PRCDATA>CLOBGN,PRCDATA<CLOEND D DAT410 Q
. Q
Q
DAT410 ;
S PRCDT=$P(PRCND,U,1)_U ;TRANSACTION NUMBER
S PRCDT=PRCDT_PRCIEN_U ;TRANSACTION IEN
S PRCDT=PRCDT_$P(PRCND,U,5)_U ;STATION NUMBER
S PRCDT=PRCDT_MNTHYR_U ;Month,Year of extract
S PRCDT=PRCDT_$$GET1^DIQ(410,PRCIEN_",",1)_U ;TRANSACTION TYPE
S PRCDT=PRCDT_$S(PRCFR>0:$P($G(^PRCS(410.5,PRCFR,0)),U),1:"")_U ;FORM TYPE
S X=$P(PRCND,U,10),PRCDT=PRCDT_X_U_$S(X>0:$P($G(^PRC(411,X,0)),U),1:"")_U ;SUBSTATION -internal and external
S X=$P(PRCND,U,11),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;RUNNING BAL QTR DATE
S PRCDT=PRCDT_$$GET1^DIQ(410,PRCIEN_",",450)_U ;RUNNING BAL STATUS
S PRCND=$G(^PRCS(410,PRCIEN,1)) ;NODE 1
S X=$P(PRCND,U,1),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE OF REQUEST
S PRCDT=PRCDT_$P(PRCND,U,5)_U ;CLASS OF REQUEST IEN
S PRCTMP=$P($G(^PRCS(410.2,+$P(PRCND,U,5),0)),U)
S PRCDT=PRCDT_PRCTMP_U ;CLASS OF REQUEST EXT
S PRCND=$G(^PRCS(410,PRCIEN,2)) ;NODE 2
S PRCDT=PRCDT_$P(PRCND,U,1)_U ;VENDOR
S PRCDT=PRCDT_$P(PRCND,U,2)_U ;VENDOR ADDRESS1
S PRCDT=PRCDT_$P(PRCND,U,3)_U ;VENDOR ADDRESS2
S PRCDT=PRCDT_$P(PRCND,U,4)_U ;VENDOR ADDRESS3
S PRCDT=PRCDT_$P(PRCND,U,5)_U ;VENDOR ADDRESS4
S PRCDT=PRCDT_$P(PRCND,U,6)_U ;VENDOR CITY
S X=$P(PRCND,U,7),PRCDT=PRCDT_$S(X>0:$$GET1^DIQ(5,X_",",1),1:"")_U ;VENDOR STATE
S PRCDT=PRCDT_$P(PRCND,U,8)_U ;VENDOR ZIP CODE
S PRCDT=PRCDT_$P(PRCND,U,9)_U ;VENDOR CONTACT
S PRCDT=PRCDT_$P(PRCND,U,10)_U ;VENDOR PHONE NO.
S PRCND=$G(^PRCS(410,PRCIEN,3)) ;NODE 3
S PRCTMP=$P(PRCND,U,4)
S PRCDT=PRCDT_PRCTMP_U,PRCTMP=+PRCTMP ;VENDOR IEN
S PRCTMB=$P($G(^PRC(440,PRCTMP,0)),U,1) ;
S PRCDT=PRCDT_PRCTMB_U ;VENDOR NAME
S PRCTMB=$P($G(^PRC(440,PRCTMP,3)),U,4) ;
S PRCDT=PRCDT_PRCTMB_U ;VENDOR FMS CODE
S PRCTMB=$P($G(^PRC(440,PRCTMP,3)),U,5)
S PRCDT=PRCDT_PRCTMB_U ;VENDOR ALT-ADDR-IND
S PRCTMB=$P($G(^PRC(440,PRCTMP,7)),U,12)
S PRCDT=PRCDT_PRCTMB_U ;VENDOR D & B
S PRCDT=PRCDT_$P(PRCND,U,10)_U ;VENDOR CONTRACT NUMBER
S PRCDT=PRCDT_$P(PRCND,U,1)_U ;CONTROL POINT
S PRCDT=PRCDT_$P(PRCND,U,3)_U ;COST CENTER
S PRCDT=PRCDT_$P(PRCND,U,6)_U ;BOC1
S PRCDT=PRCDT_$P(PRCND,U,7)_U ;BOC1 $ AMOUNT
S PRCDT=PRCDT_$P(PRCND,U,2)_U ;ACCOUNTING DATA
S PRCDT=PRCDT_$P(PRCND,U,12)_U ;FCP/PRJ
S X=$P(PRCND,U,11),PRCDT=PRCDT_$S(X>0:$E(X+17000000,1,4),1:"")_U ;BBFY
S PRCND=$G(^PRCS(410,PRCIEN,4)) ;NODE 4
S PRCDT=PRCDT_$P(PRCND,U,1)_U ;COMMITTED (EST.) COST
S X=$P(PRCND,U,2),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE COMMITTED
S PRCDT=PRCDT_$P(PRCND,U,3)_U ;OBLIGATED ACTUAL COST
S X=$P(PRCND,U,4),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE OBLIGATED
S PRCDT=PRCDT_$P(PRCND,U,5)_U ;PO / OBLIGATION NO
S PRCDT=PRCDT_$P(PRCND,U,6)_U ;ADJUSTMENT AMOUNT
S X=$P(PRCND,U,7),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE OBL ADJUSTED
S PRCDT=PRCDT_$P(PRCND,U,8)_U ;TRANSACTION AMOUNT
S PRCDUZ=$P(PRCND,U,9),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
S PRCDT=PRCDT_PRCDUZ_U ;OBLIGATED BY DUZ
S PRCDT=PRCDT_PRCTMP_U ;OBLIGATED BY NAME
S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;OBLIGATED SERVICE INT/EXT
S X=$P(PRCND,U,13),PRCDT=PRCDT_$S(X>0:$TR($$FMTE^XLFDT(X),"@"," "),1:"")_U ;OBL VAL CODE DATE/TIME
S PRCND=$G(^PRCS(410,PRCIEN,7)) ;NODE 7
S PRCDUZ=$P(PRCND,U,1),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
S PRCDT=PRCDT_PRCDUZ_U ;REQUESTOR DUZ
S PRCDT=PRCDT_PRCTMP_U ;REQUESTOR NAME
S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;REQUESTOR SERVICE INT/EXT
S PRCDT=PRCDT_$P(PRCND,U,2)_U ;REQUESTOR'S TITLE
S PRCDUZ=$P(PRCND,U,3),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
S PRCDT=PRCDT_PRCDUZ_U ;APPROVING OFFICIAL DUZ
S PRCDT=PRCDT_PRCTMP_U ;APPROVING OFFICIAL NAME
S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;APPROVING OFFICIAL SERVICE INT/EXT
S PRCDT=PRCDT_$P(PRCND,U,4)_U ;APPROVING OFFICIAL TITLE
S X=$P(PRCND,U,5),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE SIGNED (APPROVED)
S X=$P(PRCND,U,7),PRCDT=PRCDT_$S(X>0:$TR($$FMTE^XLFDT(X),"@"," "),1:"")_U ;ES CODE DATE/TIME
S ^TMP($J,"CONTRP",PRCIEN,1)=PRCDT,PRCDT=""
S PRCTMB=8 D WORDFLD ;NODE 8
S PRCDT=PRCDT_PRCTMP_U ;JUSTIFICATION
S ^TMP($J,"CONTRP",PRCIEN,2)=PRCDT,PRCDT=""
S PRCND=$G(^PRCS(410,PRCIEN,11)) ;NODE 11
S PRCTMP=$$GET1^DIQ(410,PRCIEN_",",49)
S PRCDT=PRCDT_PRCTMP_U ;SORT GROUP EXTERNAL
S PRCND=$G(^PRCS(410,PRCIEN,10)) ;NODE 10
S PRCTMP=$P(PRCND,U,3),PRCTMB=$P($G(^PRC(442,+PRCTMP,0)),U)
S PRCDT=PRCDT_PRCTMP_U ;STATION NO - P.O.NO IEN
S PRCDT=PRCDT_PRCTMB_U ;STATION NO - P.O.NO EXT
S PRCDT=PRCDT_$$PODATE(PRCTMP)_U ;PO DATE
S D0=PRCIEN D STATUS^PRCSES
S PRCDT=PRCDT_X_U ;STATUS
S PRCTMB="CO" D WORDFLD ;NODE CO
S PRCDT=PRCDT_PRCTMP_U ;COMMENTS
S ^TMP($J,"CONTRP",PRCIEN,3)=PRCDT,PRCDT=""
S PRCTMB=13 D WORDFLD ;NODE 13
S PRCDT=PRCDT_PRCTMP ;REASON FOR RETURN
S ^TMP($J,"CONTRP",PRCIEN,4)=PRCDT_U
;;authority;sub-authority ;AUTHORITY/SUB-AUTHORITY
S PRCDT=""
S PRCND=$G(^PRCS(410,PRCIEN,11)) ;NODE 11
F PRCIX=4,5 D
. S PRCAUIEN=$P(PRCND,U,PRCIX) ;auth ien
. S PRCDT=$S(PRCIX=4:PRCAUIEN,1:PRCDT_U_PRCAUIEN)
. D GETS^DIQ(410.9,+PRCAUIEN_",",".01;.02","","PRCARY")
. S PRCDT=PRCDT_U_$G(PRCARY(410.9,+PRCAUIEN_",",.01))_U_$G(PRCARY(410.9,+PRCAUIEN_",",.02))
;;service dates ;SERVICE DATES
S PRCND=$G(^PRCS(410,PRCIEN,1)) ;NODE 1
F PRCIX=6,7 D
. S PRCDT=PRCDT_U_$$FMTE^XLFDT($P(PRCND,U,PRCIX))
S ^TMP($J,"CONTRP",PRCIEN,5)=PRCDT
;
D GET4104
Q
GET4104 ; GET DATA FROM SUBFILE 410.04
N PRCX S PRCX=$P(^PRCS(410,PRCIEN,0),U)_U_PRCIEN_U_$P(^(0),U,5)_U
S X=$P($G(^PRCS(410,PRCIEN,10)),U,3),PRCX=PRCX_$S(X>0:X_U_$P($G(^PRC(442,X,0)),U),1:U)_U_$$PODATE(X)_U_MNTHYR_U
N PRCTMI
S PRCTMI=0 F S PRCTMI=$O(^PRCS(410,PRCIEN,12,PRCTMI)) Q:'PRCTMI D
. S PRCDT=PRCX
. S PRCND=$G(^PRCS(410,PRCIEN,12,PRCTMI,0))
. S PRCDT=PRCDT_$P($G(^PRCS(410.4,+$P(PRCND,U,1),0)),U)_U ;SUB-CONTROL POINT
. S PRCDT=PRCDT_$P(PRCND,U,2)_U ;AMOUNT
. S PRCTMB=$$GET1^DIQ(410.04,PRCTMI_","_PRCIEN_",",2)
. S PRCDT=PRCDT_PRCTMB ;SCP AMOUNT
. S ^TMP($J,"SUBCP",PRCIEN,PRCTMI)=PRCDT
Q
WORDFLD ; PROCESS WORD FIELD
N PRCTMI,PRCTMJ,PRCTMQ
S PRCTMI=$P($G(^PRCS(410,PRCIEN,PRCTMB,0)),U,3),PRCTMP="",PRCTMQ=0
I PRCTMI D
. F PRCTMI=1:1:PRCTMI D Q:PRCTMQ
.. S PRCTMJ=$G(^PRCS(410,PRCIEN,PRCTMB,PRCTMI,0))_" "
.. I $F(PRCTMJ,"^") S PRCTMJ=$TR(PRCTMJ,"^","*") ;CONVERT ^ TO *
.. I $L(PRCTMJ)+$L(PRCTMP)>200 S PRCTMP=$E(PRCTMP_PRCTMJ,1,200) S PRCTMQ=1 Q ; CANNOT ALLOW STRING 'PRCDT' TO EXCEED 256 BYTES, SO LIMITING WORD PROC FIELD TO 200 CHARS
.. S PRCTMP=PRCTMP_PRCTMJ
Q
;
GET424 ;
S U="^"
N PRCND,PRCIEN,PRCDT,PRCTMP,PRCTMB,PRCC,X
; loop through file 424, "C" Cross Reference
S PRCC=0
F S PRCC=$O(^PRC(424,"C",PRCC)) Q:'PRCC D
. I $D(^TMP($J,"POMAST",PRCC)) D DAT424
D GET4241
Q
DAT424 ;
N PRCPOID
S PRCIEN=0
F S PRCIEN=$O(^PRC(424,"C",PRCC,PRCIEN)) Q:'PRCIEN D
. S PRCDT=""
. S PRCND=$G(^PRC(424,PRCIEN,0)) ;NODE 0
. S (PRCPOID,X,Y)=$P(PRCND,U,2),PRCDT=PRCDT_X_U ;OBLIGATION INT
. S X=$S(X>0:$P($G(^PRC(442,X,0)),U),1:""),PRCDT=PRCDT_X_U ; OBL EXT
. S PRCDT=PRCDT_$$PODATE(PRCPOID)_U ;PO DATE
. S PRCDT=PRCDT_MNTHYR_U ;Month,Year of extract
. S PRCDT=PRCDT_$P(X,"-")_U ;STATION #
. S PRCDT=PRCDT_$P(PRCND,U,1)_U ;AUTHORIZATION #
. S PRCDT=PRCDT_$$GET1^DIQ(424,PRCIEN_",",.03)_U ;TRANSACTION TYPE
. S PRCDT=PRCDT_$P(PRCND,U,4)_U ;LIQUIDATION AMOUNT
. S PRCDT=PRCDT_$P(PRCND,U,5)_U ;AUTHORIZATION BALANCE
. S PRCDT=PRCDT_$P(PRCND,U,6)_U ;OBLIGATION AMOUNT
. S X=$P(PRCND,U,7),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE/TIME
. S PRCDUZ=$P(PRCND,U,8),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
. S PRCDT=PRCDT_PRCDUZ_U ;USER DUZ
. S PRCDT=PRCDT_PRCTMP_U ;USER NAME
. S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
. S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
. S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;USER SERVICE INT/EXT
. S PRCDT=PRCDT_$$GET1^DIQ(424,PRCIEN_",",.09)_U ;COMPLETED FLAG
. S PRCDT=PRCDT_$P(PRCND,U,10)_U ;REFERENCE
. S PRCDT=PRCDT_$P(PRCND,U,11)_U ;LAST SEQUENCE USED
. S PRCDT=PRCDT_$P(PRCND,U,12)_U ;AUTHORIZATION AMOUNT
. S PRCDT=PRCDT_$P(PRCND,U,13)_U ;ORIGINAL AUTH. AMOUNT
. S PRCDUZ=$P(PRCND,U,14),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
. S PRCDT=PRCDT_PRCDUZ_U ;LAST EDITED BY DUZ
. S PRCDT=PRCDT_PRCTMP_U ;LAST EDITED BY NAME
. S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
. S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
. S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;LAST EDITED BY SERVICE INT/EXT
. S PRCTMP=$P(PRCND,U,15),PRCTMP=$P($G(^PRCS(410,+PRCTMP,0)),U)
. S PRCDT=PRCDT_$P(PRCND,U,15)_U ;CPA POINTER IEN
. S PRCDT=PRCDT_PRCTMP_U ;CPA POINTER EXT
. S PRCND=$G(^PRC(424,PRCIEN,1)) ;NODE 1
. S PRCDT=PRCDT_$P(PRCND,U,1)_U ;COMMENTS
. S PRCND=$G(^PRC(424,PRCIEN,2)) ;NODE 2
. S PRCDT=PRCDT_$P(PRCND,U,2) ;INTERFACE ID
. S ^TMP($J,"DR1358",PRCIEN,1)=PRCDT
Q
GET4241 ;
; loop through file 424.1
S PRCC=0
F S PRCC=$O(^PRC(424.1,"C",PRCC)) Q:'PRCC D
. I $D(^TMP($J,"DR1358",PRCC)) D DAT4241
Q
DAT4241 ;
N Y,PRCSTN
S PRCIEN=0 F S PRCIEN=$O(^PRC(424.1,"C",PRCC,PRCIEN)) Q:'PRCIEN D
. S PRCDT=""
. S PRCND=$G(^PRC(424.1,PRCIEN,0)) ;NODE 0
. S X=$P(PRCND,U,2)
. S (X,PRCPOID)=$P($G(^PRC(424,+X,0)),U,2),PRCDT=PRCDT_X_U ;PO# INT
. S X=$S(X>0:$P($G(^PRC(442,X,0)),U),1:""),PRCDT=PRCDT_X_U ;PO# EXT
. S PRCSTN=$P(X,"-") S:PRCPOID="" PRCPOID=PRCIEN
. S PRCDT=PRCDT_$$PODATE(PRCPOID)_U ;PO DATE
. S PRCDT=PRCDT_MNTHYR_U ;Month,Year of extract
. S PRCDT=PRCDT_PRCSTN_U ;STATION
. S PRCDT=PRCDT_$P(PRCND,U,1)_U ;BILL NUMBER
. S PRCDT=PRCDT_$$GET1^DIQ(424.1,PRCIEN_",",.011)_U ;RECORD TYPE
. S PRCTMP=$P(PRCND,U,2),PRCTMP=$P($G(^PRC(424,+PRCTMP,0)),U)
. S PRCDT=PRCDT_$P(PRCND,U,2)_U ;AUTH. POINTER IEN
. S PRCDT=PRCDT_PRCTMP_U ;AUTH. POINTER EXT
. S PRCDT=PRCDT_$P(PRCND,U,3)_U ;AUTH. AMOUNT
. S X=$P(PRCND,U,4),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE/TIME
. S PRCDUZ=$P(PRCND,U,5),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
. S PRCDT=PRCDT_PRCDUZ_U ;USER DUZ
. S PRCDT=PRCDT_PRCTMP_U ;USER NAME
. S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
. S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
. S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;USER SERVICE INT/EXT
. S PRCDT=PRCDT_$P(PRCND,U,6)_U ;VENDOR INVOICE NUMBER
. S PRCDT=PRCDT_$$GET1^DIQ(424.1,PRCIEN_",",.07)_U ;FINAL BILL
. S PRCDT=PRCDT_$P(PRCND,U,8)_U ;REFERENCE
. S PRCDUZ=$P(PRCND,U,10),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
. S PRCDT=PRCDT_PRCDUZ_U ;LAST EDITED BY DUZ
. S PRCDT=PRCDT_PRCTMP_U ;LAST EDITED BY NAME
. S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
. S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
. S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;LAST EDITED BY SERVICE INT/EXT
. S PRCND=$G(^PRC(424.1,PRCIEN,1)) ;NODE 1
. S PRCDT=PRCDT_$P(PRCND,U,1) ;DESCRIPTION
. S ^TMP($J,"AD1358",PRCIEN,1)=PRCDT
Q
PODATE(PRCPOIEN) ;input PO's ien, output external form PO Date
N X
S X=$S(PRCPOIEN>0:$P($G(^PRC(442,PRCPOIEN,1)),U,15),1:"")
S:X'="" X=$$FMTE^XLFDT(X,"D")
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHLO6 14557 printed Oct 16, 2024@18:09:20 Page 2
PRCHLO6 ;WOIFO/AS-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ; 10/8/10 1:11pm
+1 ;;5.1;IFCAP;**130,140,151,154**;Oct 20, 2000;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ; DBIA 10093 - Read file 49 via FileMan.
+4 ; Continuation of PRCHLO1. This program builds the extracts for
+5 ; the Master PO Table and the associated multiples
GET410 ; get file 410 record
+1 SET U="^"
+2 NEW PRCND,PRCIEN,PRCDT,PRCTMP,PRCTMB,PRCTR,PRCFR,PRCDAT,PRCDATO,PRCDATA,D0,X
+3 NEW PRCDUZ,PRCIX,PRCAUIEN,PRCARY
+4 ; loop through file 410
+5 SET PRCIEN=0
SET PRCDT=""
+6 FOR
SET PRCIEN=$ORDER(^PRCS(410,PRCIEN))
if 'PRCIEN
QUIT
Begin DoDot:1
+7 ;NODE 0
SET PRCND=$GET(^PRCS(410,PRCIEN,0))
+8 ;TRANSACTION TYPE
SET PRCTR=$PIECE(PRCND,U,2)
+9 ;FORM TYPE
SET PRCFR=$PIECE(PRCND,U,4)
+10 ;DATE OF REQUEST
SET PRCDAT=$PIECE($GET(^PRCS(410,PRCIEN,1)),U,1)
+11 ;DATE OBLIGATED
SET PRCDATO=$PIECE($GET(^PRCS(410,PRCIEN,4)),U,4)
+12 ;DATE OBLIGATED ADJ
SET PRCDATA=$PIECE($GET(^PRCS(410,PRCIEN,4)),U,7)
+13 ;TRANS TYPE IS ADJUSTMENT, FORM TYPE IS NOT NULL NOT ISSUE BOOK
+14 IF PRCTR="A"
IF PRCFR
IF PRCFR'=5
IF PRCDAT>CLOBGN
IF PRCDAT<CLOEND
DO DAT410
QUIT
+15 ;TRANS TYPE IS ADJUSTMENT, FORM TYPE ISSUE BOOK
+16 IF PRCTR="A"
IF PRCFR=5
IF PRCDATO>CLOBGN
IF PRCDATO<CLOEND
DO DAT410
QUIT
+17 ;TRANS TYPE IS OBLIGATION, WITH ANY FORM TYPE
+18 IF PRCTR="O"
IF PRCFR
IF PRCDAT>CLOBGN
IF PRCDAT<CLOEND
DO DAT410
QUIT
+19 ;TRANS TYPE IS CEILING, WITHOUT FORM TYPE
+20 IF PRCTR="C"
IF PRCDATO>CLOBGN
IF PRCDATO<CLOEND
DO DAT410
QUIT
+21 ;TRANS TYPE IS ADJUSTMENT, WITHOUT FORM TYPE
+22 IF PRCTR="A"
IF 'PRCFR
IF PRCDATA>CLOBGN
IF PRCDATA<CLOEND
DO DAT410
QUIT
+23 QUIT
End DoDot:1
+24 QUIT
DAT410 ;
+1 ;TRANSACTION NUMBER
SET PRCDT=$PIECE(PRCND,U,1)_U
+2 ;TRANSACTION IEN
SET PRCDT=PRCDT_PRCIEN_U
+3 ;STATION NUMBER
SET PRCDT=PRCDT_$PIECE(PRCND,U,5)_U
+4 ;Month,Year of extract
SET PRCDT=PRCDT_MNTHYR_U
+5 ;TRANSACTION TYPE
SET PRCDT=PRCDT_$$GET1^DIQ(410,PRCIEN_",",1)_U
+6 ;FORM TYPE
SET PRCDT=PRCDT_$SELECT(PRCFR>0:$PIECE($GET(^PRCS(410.5,PRCFR,0)),U),1:"")_U
+7 ;SUBSTATION -internal and external
SET X=$PIECE(PRCND,U,10)
SET PRCDT=PRCDT_X_U_$SELECT(X>0:$PIECE($GET(^PRC(411,X,0)),U),1:"")_U
+8 ;RUNNING BAL QTR DATE
SET X=$PIECE(PRCND,U,11)
SET PRCDT=PRCDT_$SELECT(X>0:$$FMTE^XLFDT($PIECE(X,".")),1:"")_U
+9 ;RUNNING BAL STATUS
SET PRCDT=PRCDT_$$GET1^DIQ(410,PRCIEN_",",450)_U
+10 ;NODE 1
SET PRCND=$GET(^PRCS(410,PRCIEN,1))
+11 ;DATE OF REQUEST
SET X=$PIECE(PRCND,U,1)
SET PRCDT=PRCDT_$SELECT(X>0:$$FMTE^XLFDT($PIECE(X,".")),1:"")_U
+12 ;CLASS OF REQUEST IEN
SET PRCDT=PRCDT_$PIECE(PRCND,U,5)_U
+13 SET PRCTMP=$PIECE($GET(^PRCS(410.2,+$PIECE(PRCND,U,5),0)),U)
+14 ;CLASS OF REQUEST EXT
SET PRCDT=PRCDT_PRCTMP_U
+15 ;NODE 2
SET PRCND=$GET(^PRCS(410,PRCIEN,2))
+16 ;VENDOR
SET PRCDT=PRCDT_$PIECE(PRCND,U,1)_U
+17 ;VENDOR ADDRESS1
SET PRCDT=PRCDT_$PIECE(PRCND,U,2)_U
+18 ;VENDOR ADDRESS2
SET PRCDT=PRCDT_$PIECE(PRCND,U,3)_U
+19 ;VENDOR ADDRESS3
SET PRCDT=PRCDT_$PIECE(PRCND,U,4)_U
+20 ;VENDOR ADDRESS4
SET PRCDT=PRCDT_$PIECE(PRCND,U,5)_U
+21 ;VENDOR CITY
SET PRCDT=PRCDT_$PIECE(PRCND,U,6)_U
+22 ;VENDOR STATE
SET X=$PIECE(PRCND,U,7)
SET PRCDT=PRCDT_$SELECT(X>0:$$GET1^DIQ(5,X_",",1),1:"")_U
+23 ;VENDOR ZIP CODE
SET PRCDT=PRCDT_$PIECE(PRCND,U,8)_U
+24 ;VENDOR CONTACT
SET PRCDT=PRCDT_$PIECE(PRCND,U,9)_U
+25 ;VENDOR PHONE NO.
SET PRCDT=PRCDT_$PIECE(PRCND,U,10)_U
+26 ;NODE 3
SET PRCND=$GET(^PRCS(410,PRCIEN,3))
+27 SET PRCTMP=$PIECE(PRCND,U,4)
+28 ;VENDOR IEN
SET PRCDT=PRCDT_PRCTMP_U
SET PRCTMP=+PRCTMP
+29 ;
SET PRCTMB=$PIECE($GET(^PRC(440,PRCTMP,0)),U,1)
+30 ;VENDOR NAME
SET PRCDT=PRCDT_PRCTMB_U
+31 ;
SET PRCTMB=$PIECE($GET(^PRC(440,PRCTMP,3)),U,4)
+32 ;VENDOR FMS CODE
SET PRCDT=PRCDT_PRCTMB_U
+33 SET PRCTMB=$PIECE($GET(^PRC(440,PRCTMP,3)),U,5)
+34 ;VENDOR ALT-ADDR-IND
SET PRCDT=PRCDT_PRCTMB_U
+35 SET PRCTMB=$PIECE($GET(^PRC(440,PRCTMP,7)),U,12)
+36 ;VENDOR D & B
SET PRCDT=PRCDT_PRCTMB_U
+37 ;VENDOR CONTRACT NUMBER
SET PRCDT=PRCDT_$PIECE(PRCND,U,10)_U
+38 ;CONTROL POINT
SET PRCDT=PRCDT_$PIECE(PRCND,U,1)_U
+39 ;COST CENTER
SET PRCDT=PRCDT_$PIECE(PRCND,U,3)_U
+40 ;BOC1
SET PRCDT=PRCDT_$PIECE(PRCND,U,6)_U
+41 ;BOC1 $ AMOUNT
SET PRCDT=PRCDT_$PIECE(PRCND,U,7)_U
+42 ;ACCOUNTING DATA
SET PRCDT=PRCDT_$PIECE(PRCND,U,2)_U
+43 ;FCP/PRJ
SET PRCDT=PRCDT_$PIECE(PRCND,U,12)_U
+44 ;BBFY
SET X=$PIECE(PRCND,U,11)
SET PRCDT=PRCDT_$SELECT(X>0:$EXTRACT(X+17000000,1,4),1:"")_U
+45 ;NODE 4
SET PRCND=$GET(^PRCS(410,PRCIEN,4))
+46 ;COMMITTED (EST.) COST
SET PRCDT=PRCDT_$PIECE(PRCND,U,1)_U
+47 ;DATE COMMITTED
SET X=$PIECE(PRCND,U,2)
SET PRCDT=PRCDT_$SELECT(X>0:$$FMTE^XLFDT($PIECE(X,".")),1:"")_U
+48 ;OBLIGATED ACTUAL COST
SET PRCDT=PRCDT_$PIECE(PRCND,U,3)_U
+49 ;DATE OBLIGATED
SET X=$PIECE(PRCND,U,4)
SET PRCDT=PRCDT_$SELECT(X>0:$$FMTE^XLFDT($PIECE(X,".")),1:"")_U
+50 ;PO / OBLIGATION NO
SET PRCDT=PRCDT_$PIECE(PRCND,U,5)_U
+51 ;ADJUSTMENT AMOUNT
SET PRCDT=PRCDT_$PIECE(PRCND,U,6)_U
+52 ;DATE OBL ADJUSTED
SET X=$PIECE(PRCND,U,7)
SET PRCDT=PRCDT_$SELECT(X>0:$$FMTE^XLFDT($PIECE(X,".")),1:"")_U
+53 ;TRANSACTION AMOUNT
SET PRCDT=PRCDT_$PIECE(PRCND,U,8)_U
+54 SET PRCDUZ=$PIECE(PRCND,U,9)
SET PRCTMP=$PIECE($GET(^VA(200,+PRCDUZ,0)),U)
+55 ;OBLIGATED BY DUZ
SET PRCDT=PRCDT_PRCDUZ_U
+56 ;OBLIGATED BY NAME
SET PRCDT=PRCDT_PRCTMP_U
+57 SET PRCDUZ=$PIECE($GET(^VA(200,+PRCDUZ,5)),U)
+58 SET PRCTMP=$SELECT(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
+59 ;OBLIGATED SERVICE INT/EXT
SET PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U
+60 ;OBL VAL CODE DATE/TIME
SET X=$PIECE(PRCND,U,13)
SET PRCDT=PRCDT_$SELECT(X>0:$TRANSLATE($$FMTE^XLFDT(X),"@"," "),1:"")_U
+61 ;NODE 7
SET PRCND=$GET(^PRCS(410,PRCIEN,7))
+62 SET PRCDUZ=$PIECE(PRCND,U,1)
SET PRCTMP=$PIECE($GET(^VA(200,+PRCDUZ,0)),U)
+63 ;REQUESTOR DUZ
SET PRCDT=PRCDT_PRCDUZ_U
+64 ;REQUESTOR NAME
SET PRCDT=PRCDT_PRCTMP_U
+65 SET PRCDUZ=$PIECE($GET(^VA(200,+PRCDUZ,5)),U)
+66 SET PRCTMP=$SELECT(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
+67 ;REQUESTOR SERVICE INT/EXT
SET PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U
+68 ;REQUESTOR'S TITLE
SET PRCDT=PRCDT_$PIECE(PRCND,U,2)_U
+69 SET PRCDUZ=$PIECE(PRCND,U,3)
SET PRCTMP=$PIECE($GET(^VA(200,+PRCDUZ,0)),U)
+70 ;APPROVING OFFICIAL DUZ
SET PRCDT=PRCDT_PRCDUZ_U
+71 ;APPROVING OFFICIAL NAME
SET PRCDT=PRCDT_PRCTMP_U
+72 SET PRCDUZ=$PIECE($GET(^VA(200,+PRCDUZ,5)),U)
+73 SET PRCTMP=$SELECT(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
+74 ;APPROVING OFFICIAL SERVICE INT/EXT
SET PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U
+75 ;APPROVING OFFICIAL TITLE
SET PRCDT=PRCDT_$PIECE(PRCND,U,4)_U
+76 ;DATE SIGNED (APPROVED)
SET X=$PIECE(PRCND,U,5)
SET PRCDT=PRCDT_$SELECT(X>0:$$FMTE^XLFDT($PIECE(X,".")),1:"")_U
+77 ;ES CODE DATE/TIME
SET X=$PIECE(PRCND,U,7)
SET PRCDT=PRCDT_$SELECT(X>0:$TRANSLATE($$FMTE^XLFDT(X),"@"," "),1:"")_U
+78 SET ^TMP($JOB,"CONTRP",PRCIEN,1)=PRCDT
SET PRCDT=""
+79 ;NODE 8
SET PRCTMB=8
DO WORDFLD
+80 ;JUSTIFICATION
SET PRCDT=PRCDT_PRCTMP_U
+81 SET ^TMP($JOB,"CONTRP",PRCIEN,2)=PRCDT
SET PRCDT=""
+82 ;NODE 11
SET PRCND=$GET(^PRCS(410,PRCIEN,11))
+83 SET PRCTMP=$$GET1^DIQ(410,PRCIEN_",",49)
+84 ;SORT GROUP EXTERNAL
SET PRCDT=PRCDT_PRCTMP_U
+85 ;NODE 10
SET PRCND=$GET(^PRCS(410,PRCIEN,10))
+86 SET PRCTMP=$PIECE(PRCND,U,3)
SET PRCTMB=$PIECE($GET(^PRC(442,+PRCTMP,0)),U)
+87 ;STATION NO - P.O.NO IEN
SET PRCDT=PRCDT_PRCTMP_U
+88 ;STATION NO - P.O.NO EXT
SET PRCDT=PRCDT_PRCTMB_U
+89 ;PO DATE
SET PRCDT=PRCDT_$$PODATE(PRCTMP)_U
+90 SET D0=PRCIEN
DO STATUS^PRCSES
+91 ;STATUS
SET PRCDT=PRCDT_X_U
+92 ;NODE CO
SET PRCTMB="CO"
DO WORDFLD
+93 ;COMMENTS
SET PRCDT=PRCDT_PRCTMP_U
+94 SET ^TMP($JOB,"CONTRP",PRCIEN,3)=PRCDT
SET PRCDT=""
+95 ;NODE 13
SET PRCTMB=13
DO WORDFLD
+96 ;REASON FOR RETURN
SET PRCDT=PRCDT_PRCTMP
+97 SET ^TMP($JOB,"CONTRP",PRCIEN,4)=PRCDT_U
+98 ;;authority;sub-authority ;AUTHORITY/SUB-AUTHORITY
+99 SET PRCDT=""
+100 ;NODE 11
SET PRCND=$GET(^PRCS(410,PRCIEN,11))
+101 FOR PRCIX=4,5
Begin DoDot:1
+102 ;auth ien
SET PRCAUIEN=$PIECE(PRCND,U,PRCIX)
+103 SET PRCDT=$SELECT(PRCIX=4:PRCAUIEN,1:PRCDT_U_PRCAUIEN)
+104 DO GETS^DIQ(410.9,+PRCAUIEN_",",".01;.02","","PRCARY")
+105 SET PRCDT=PRCDT_U_$GET(PRCARY(410.9,+PRCAUIEN_",",.01))_U_$GET(PRCARY(410.9,+PRCAUIEN_",",.02))
End DoDot:1
+106 ;;service dates ;SERVICE DATES
+107 ;NODE 1
SET PRCND=$GET(^PRCS(410,PRCIEN,1))
+108 FOR PRCIX=6,7
Begin DoDot:1
+109 SET PRCDT=PRCDT_U_$$FMTE^XLFDT($PIECE(PRCND,U,PRCIX))
End DoDot:1
+110 SET ^TMP($JOB,"CONTRP",PRCIEN,5)=PRCDT
+111 ;
+112 DO GET4104
+113 QUIT
GET4104 ; GET DATA FROM SUBFILE 410.04
+1 NEW PRCX
SET PRCX=$PIECE(^PRCS(410,PRCIEN,0),U)_U_PRCIEN_U_$PIECE(^(0),U,5)_U
+2 SET X=$PIECE($GET(^PRCS(410,PRCIEN,10)),U,3)
SET PRCX=PRCX_$SELECT(X>0:X_U_$PIECE($GET(^PRC(442,X,0)),U),1:U)_U_$$PODATE(X)_U_MNTHYR_U
+3 NEW PRCTMI
+4 SET PRCTMI=0
FOR
SET PRCTMI=$ORDER(^PRCS(410,PRCIEN,12,PRCTMI))
if 'PRCTMI
QUIT
Begin DoDot:1
+5 SET PRCDT=PRCX
+6 SET PRCND=$GET(^PRCS(410,PRCIEN,12,PRCTMI,0))
+7 ;SUB-CONTROL POINT
SET PRCDT=PRCDT_$PIECE($GET(^PRCS(410.4,+$PIECE(PRCND,U,1),0)),U)_U
+8 ;AMOUNT
SET PRCDT=PRCDT_$PIECE(PRCND,U,2)_U
+9 SET PRCTMB=$$GET1^DIQ(410.04,PRCTMI_","_PRCIEN_",",2)
+10 ;SCP AMOUNT
SET PRCDT=PRCDT_PRCTMB
+11 SET ^TMP($JOB,"SUBCP",PRCIEN,PRCTMI)=PRCDT
End DoDot:1
+12 QUIT
WORDFLD ; PROCESS WORD FIELD
+1 NEW PRCTMI,PRCTMJ,PRCTMQ
+2 SET PRCTMI=$PIECE($GET(^PRCS(410,PRCIEN,PRCTMB,0)),U,3)
SET PRCTMP=""
SET PRCTMQ=0
+3 IF PRCTMI
Begin DoDot:1
+4 FOR PRCTMI=1:1:PRCTMI
Begin DoDot:2
+5 SET PRCTMJ=$GET(^PRCS(410,PRCIEN,PRCTMB,PRCTMI,0))_" "
+6 ;CONVERT ^ TO *
IF $FIND(PRCTMJ,"^")
SET PRCTMJ=$TRANSLATE(PRCTMJ,"^","*")
+7 ; CANNOT ALLOW STRING 'PRCDT' TO EXCEED 256 BYTES, SO LIMITING WORD PROC FIELD TO 200 CHARS
IF $LENGTH(PRCTMJ)+$LENGTH(PRCTMP)>200
SET PRCTMP=$EXTRACT(PRCTMP_PRCTMJ,1,200)
SET PRCTMQ=1
QUIT
+8 SET PRCTMP=PRCTMP_PRCTMJ
End DoDot:2
if PRCTMQ
QUIT
End DoDot:1
+9 QUIT
+10 ;
GET424 ;
+1 SET U="^"
+2 NEW PRCND,PRCIEN,PRCDT,PRCTMP,PRCTMB,PRCC,X
+3 ; loop through file 424, "C" Cross Reference
+4 SET PRCC=0
+5 FOR
SET PRCC=$ORDER(^PRC(424,"C",PRCC))
if 'PRCC
QUIT
Begin DoDot:1
+6 IF $DATA(^TMP($JOB,"POMAST",PRCC))
DO DAT424
End DoDot:1
+7 DO GET4241
+8 QUIT
DAT424 ;
+1 NEW PRCPOID
+2 SET PRCIEN=0
+3 FOR
SET PRCIEN=$ORDER(^PRC(424,"C",PRCC,PRCIEN))
if 'PRCIEN
QUIT
Begin DoDot:1
+4 SET PRCDT=""
+5 ;NODE 0
SET PRCND=$GET(^PRC(424,PRCIEN,0))
+6 ;OBLIGATION INT
SET (PRCPOID,X,Y)=$PIECE(PRCND,U,2)
SET PRCDT=PRCDT_X_U
+7 ; OBL EXT
SET X=$SELECT(X>0:$PIECE($GET(^PRC(442,X,0)),U),1:"")
SET PRCDT=PRCDT_X_U
+8 ;PO DATE
SET PRCDT=PRCDT_$$PODATE(PRCPOID)_U
+9 ;Month,Year of extract
SET PRCDT=PRCDT_MNTHYR_U
+10 ;STATION #
SET PRCDT=PRCDT_$PIECE(X,"-")_U
+11 ;AUTHORIZATION #
SET PRCDT=PRCDT_$PIECE(PRCND,U,1)_U
+12 ;TRANSACTION TYPE
SET PRCDT=PRCDT_$$GET1^DIQ(424,PRCIEN_",",.03)_U
+13 ;LIQUIDATION AMOUNT
SET PRCDT=PRCDT_$PIECE(PRCND,U,4)_U
+14 ;AUTHORIZATION BALANCE
SET PRCDT=PRCDT_$PIECE(PRCND,U,5)_U
+15 ;OBLIGATION AMOUNT
SET PRCDT=PRCDT_$PIECE(PRCND,U,6)_U
+16 ;DATE/TIME
SET X=$PIECE(PRCND,U,7)
SET PRCDT=PRCDT_$SELECT(X>0:$$FMTE^XLFDT($PIECE(X,".")),1:"")_U
+17 SET PRCDUZ=$PIECE(PRCND,U,8)
SET PRCTMP=$PIECE($GET(^VA(200,+PRCDUZ,0)),U)
+18 ;USER DUZ
SET PRCDT=PRCDT_PRCDUZ_U
+19 ;USER NAME
SET PRCDT=PRCDT_PRCTMP_U
+20 SET PRCDUZ=$PIECE($GET(^VA(200,+PRCDUZ,5)),U)
+21 SET PRCTMP=$SELECT(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
+22 ;USER SERVICE INT/EXT
SET PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U
+23 ;COMPLETED FLAG
SET PRCDT=PRCDT_$$GET1^DIQ(424,PRCIEN_",",.09)_U
+24 ;REFERENCE
SET PRCDT=PRCDT_$PIECE(PRCND,U,10)_U
+25 ;LAST SEQUENCE USED
SET PRCDT=PRCDT_$PIECE(PRCND,U,11)_U
+26 ;AUTHORIZATION AMOUNT
SET PRCDT=PRCDT_$PIECE(PRCND,U,12)_U
+27 ;ORIGINAL AUTH. AMOUNT
SET PRCDT=PRCDT_$PIECE(PRCND,U,13)_U
+28 SET PRCDUZ=$PIECE(PRCND,U,14)
SET PRCTMP=$PIECE($GET(^VA(200,+PRCDUZ,0)),U)
+29 ;LAST EDITED BY DUZ
SET PRCDT=PRCDT_PRCDUZ_U
+30 ;LAST EDITED BY NAME
SET PRCDT=PRCDT_PRCTMP_U
+31 SET PRCDUZ=$PIECE($GET(^VA(200,+PRCDUZ,5)),U)
+32 SET PRCTMP=$SELECT(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
+33 ;LAST EDITED BY SERVICE INT/EXT
SET PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U
+34 SET PRCTMP=$PIECE(PRCND,U,15)
SET PRCTMP=$PIECE($GET(^PRCS(410,+PRCTMP,0)),U)
+35 ;CPA POINTER IEN
SET PRCDT=PRCDT_$PIECE(PRCND,U,15)_U
+36 ;CPA POINTER EXT
SET PRCDT=PRCDT_PRCTMP_U
+37 ;NODE 1
SET PRCND=$GET(^PRC(424,PRCIEN,1))
+38 ;COMMENTS
SET PRCDT=PRCDT_$PIECE(PRCND,U,1)_U
+39 ;NODE 2
SET PRCND=$GET(^PRC(424,PRCIEN,2))
+40 ;INTERFACE ID
SET PRCDT=PRCDT_$PIECE(PRCND,U,2)
+41 SET ^TMP($JOB,"DR1358",PRCIEN,1)=PRCDT
End DoDot:1
+42 QUIT
GET4241 ;
+1 ; loop through file 424.1
+2 SET PRCC=0
+3 FOR
SET PRCC=$ORDER(^PRC(424.1,"C",PRCC))
if 'PRCC
QUIT
Begin DoDot:1
+4 IF $DATA(^TMP($JOB,"DR1358",PRCC))
DO DAT4241
End DoDot:1
+5 QUIT
DAT4241 ;
+1 NEW Y,PRCSTN
+2 SET PRCIEN=0
FOR
SET PRCIEN=$ORDER(^PRC(424.1,"C",PRCC,PRCIEN))
if 'PRCIEN
QUIT
Begin DoDot:1
+3 SET PRCDT=""
+4 ;NODE 0
SET PRCND=$GET(^PRC(424.1,PRCIEN,0))
+5 SET X=$PIECE(PRCND,U,2)
+6 ;PO# INT
SET (X,PRCPOID)=$PIECE($GET(^PRC(424,+X,0)),U,2)
SET PRCDT=PRCDT_X_U
+7 ;PO# EXT
SET X=$SELECT(X>0:$PIECE($GET(^PRC(442,X,0)),U),1:"")
SET PRCDT=PRCDT_X_U
+8 SET PRCSTN=$PIECE(X,"-")
if PRCPOID=""
SET PRCPOID=PRCIEN
+9 ;PO DATE
SET PRCDT=PRCDT_$$PODATE(PRCPOID)_U
+10 ;Month,Year of extract
SET PRCDT=PRCDT_MNTHYR_U
+11 ;STATION
SET PRCDT=PRCDT_PRCSTN_U
+12 ;BILL NUMBER
SET PRCDT=PRCDT_$PIECE(PRCND,U,1)_U
+13 ;RECORD TYPE
SET PRCDT=PRCDT_$$GET1^DIQ(424.1,PRCIEN_",",.011)_U
+14 SET PRCTMP=$PIECE(PRCND,U,2)
SET PRCTMP=$PIECE($GET(^PRC(424,+PRCTMP,0)),U)
+15 ;AUTH. POINTER IEN
SET PRCDT=PRCDT_$PIECE(PRCND,U,2)_U
+16 ;AUTH. POINTER EXT
SET PRCDT=PRCDT_PRCTMP_U
+17 ;AUTH. AMOUNT
SET PRCDT=PRCDT_$PIECE(PRCND,U,3)_U
+18 ;DATE/TIME
SET X=$PIECE(PRCND,U,4)
SET PRCDT=PRCDT_$SELECT(X>0:$$FMTE^XLFDT($PIECE(X,".")),1:"")_U
+19 SET PRCDUZ=$PIECE(PRCND,U,5)
SET PRCTMP=$PIECE($GET(^VA(200,+PRCDUZ,0)),U)
+20 ;USER DUZ
SET PRCDT=PRCDT_PRCDUZ_U
+21 ;USER NAME
SET PRCDT=PRCDT_PRCTMP_U
+22 SET PRCDUZ=$PIECE($GET(^VA(200,+PRCDUZ,5)),U)
+23 SET PRCTMP=$SELECT(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
+24 ;USER SERVICE INT/EXT
SET PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U
+25 ;VENDOR INVOICE NUMBER
SET PRCDT=PRCDT_$PIECE(PRCND,U,6)_U
+26 ;FINAL BILL
SET PRCDT=PRCDT_$$GET1^DIQ(424.1,PRCIEN_",",.07)_U
+27 ;REFERENCE
SET PRCDT=PRCDT_$PIECE(PRCND,U,8)_U
+28 SET PRCDUZ=$PIECE(PRCND,U,10)
SET PRCTMP=$PIECE($GET(^VA(200,+PRCDUZ,0)),U)
+29 ;LAST EDITED BY DUZ
SET PRCDT=PRCDT_PRCDUZ_U
+30 ;LAST EDITED BY NAME
SET PRCDT=PRCDT_PRCTMP_U
+31 SET PRCDUZ=$PIECE($GET(^VA(200,+PRCDUZ,5)),U)
+32 SET PRCTMP=$SELECT(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
+33 ;LAST EDITED BY SERVICE INT/EXT
SET PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U
+34 ;NODE 1
SET PRCND=$GET(^PRC(424.1,PRCIEN,1))
+35 ;DESCRIPTION
SET PRCDT=PRCDT_$PIECE(PRCND,U,1)
+36 SET ^TMP($JOB,"AD1358",PRCIEN,1)=PRCDT
End DoDot:1
+37 QUIT
PODATE(PRCPOIEN) ;input PO's ien, output external form PO Date
+1 NEW X
+2 SET X=$SELECT(PRCPOIEN>0:$PIECE($GET(^PRC(442,PRCPOIEN,1)),U,15),1:"")
+3 if X'=""
SET X=$$FMTE^XLFDT(X,"D")
+4 QUIT X
