Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHLO6

PRCHLO6.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ; DBIA 10093 - Read file 49 via FileMan.
  1. ; Continuation of PRCHLO1. This program builds the extracts for
  1. ; the Master PO Table and the associated multiples
  1. GET410 ; get file 410 record
  1. S U="^"
  1. N PRCND,PRCIEN,PRCDT,PRCTMP,PRCTMB,PRCTR,PRCFR,PRCDAT,PRCDATO,PRCDATA,D0,X
  1. N PRCDUZ,PRCIX,PRCAUIEN,PRCARY
  1. ; loop through file 410
  1. S PRCIEN=0,PRCDT=""
  1. F S PRCIEN=$O(^PRCS(410,PRCIEN)) Q:'PRCIEN D
  1. . S PRCND=$G(^PRCS(410,PRCIEN,0)) ;NODE 0
  1. . S PRCTR=$P(PRCND,U,2) ;TRANSACTION TYPE
  1. . S PRCFR=$P(PRCND,U,4) ;FORM TYPE
  1. . S PRCDAT=$P($G(^PRCS(410,PRCIEN,1)),U,1) ;DATE OF REQUEST
  1. . S PRCDATO=$P($G(^PRCS(410,PRCIEN,4)),U,4) ;DATE OBLIGATED
  1. . S PRCDATA=$P($G(^PRCS(410,PRCIEN,4)),U,7) ;DATE OBLIGATED ADJ
  1. . ;TRANS TYPE IS ADJUSTMENT, FORM TYPE IS NOT NULL NOT ISSUE BOOK
  1. . I PRCTR="A",PRCFR,PRCFR'=5,PRCDAT>CLOBGN,PRCDAT<CLOEND D DAT410 Q
  1. . ;TRANS TYPE IS ADJUSTMENT, FORM TYPE ISSUE BOOK
  1. . I PRCTR="A",PRCFR=5,PRCDATO>CLOBGN,PRCDATO<CLOEND D DAT410 Q
  1. . ;TRANS TYPE IS OBLIGATION, WITH ANY FORM TYPE
  1. . I PRCTR="O",PRCFR,PRCDAT>CLOBGN,PRCDAT<CLOEND D DAT410 Q
  1. . ;TRANS TYPE IS CEILING, WITHOUT FORM TYPE
  1. . I PRCTR="C",PRCDATO>CLOBGN,PRCDATO<CLOEND D DAT410 Q
  1. . ;TRANS TYPE IS ADJUSTMENT, WITHOUT FORM TYPE
  1. . I PRCTR="A",'PRCFR,PRCDATA>CLOBGN,PRCDATA<CLOEND D DAT410 Q
  1. . Q
  1. Q
  1. DAT410 ;
  1. S PRCDT=$P(PRCND,U,1)_U ;TRANSACTION NUMBER
  1. S PRCDT=PRCDT_PRCIEN_U ;TRANSACTION IEN
  1. S PRCDT=PRCDT_$P(PRCND,U,5)_U ;STATION NUMBER
  1. S PRCDT=PRCDT_MNTHYR_U ;Month,Year of extract
  1. S PRCDT=PRCDT_$$GET1^DIQ(410,PRCIEN_",",1)_U ;TRANSACTION TYPE
  1. S PRCDT=PRCDT_$S(PRCFR>0:$P($G(^PRCS(410.5,PRCFR,0)),U),1:"")_U ;FORM TYPE
  1. 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
  1. S X=$P(PRCND,U,11),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;RUNNING BAL QTR DATE
  1. S PRCDT=PRCDT_$$GET1^DIQ(410,PRCIEN_",",450)_U ;RUNNING BAL STATUS
  1. S PRCND=$G(^PRCS(410,PRCIEN,1)) ;NODE 1
  1. S X=$P(PRCND,U,1),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE OF REQUEST
  1. S PRCDT=PRCDT_$P(PRCND,U,5)_U ;CLASS OF REQUEST IEN
  1. S PRCTMP=$P($G(^PRCS(410.2,+$P(PRCND,U,5),0)),U)
  1. S PRCDT=PRCDT_PRCTMP_U ;CLASS OF REQUEST EXT
  1. S PRCND=$G(^PRCS(410,PRCIEN,2)) ;NODE 2
  1. S PRCDT=PRCDT_$P(PRCND,U,1)_U ;VENDOR
  1. S PRCDT=PRCDT_$P(PRCND,U,2)_U ;VENDOR ADDRESS1
  1. S PRCDT=PRCDT_$P(PRCND,U,3)_U ;VENDOR ADDRESS2
  1. S PRCDT=PRCDT_$P(PRCND,U,4)_U ;VENDOR ADDRESS3
  1. S PRCDT=PRCDT_$P(PRCND,U,5)_U ;VENDOR ADDRESS4
  1. S PRCDT=PRCDT_$P(PRCND,U,6)_U ;VENDOR CITY
  1. S X=$P(PRCND,U,7),PRCDT=PRCDT_$S(X>0:$$GET1^DIQ(5,X_",",1),1:"")_U ;VENDOR STATE
  1. S PRCDT=PRCDT_$P(PRCND,U,8)_U ;VENDOR ZIP CODE
  1. S PRCDT=PRCDT_$P(PRCND,U,9)_U ;VENDOR CONTACT
  1. S PRCDT=PRCDT_$P(PRCND,U,10)_U ;VENDOR PHONE NO.
  1. S PRCND=$G(^PRCS(410,PRCIEN,3)) ;NODE 3
  1. S PRCTMP=$P(PRCND,U,4)
  1. S PRCDT=PRCDT_PRCTMP_U,PRCTMP=+PRCTMP ;VENDOR IEN
  1. S PRCTMB=$P($G(^PRC(440,PRCTMP,0)),U,1) ;
  1. S PRCDT=PRCDT_PRCTMB_U ;VENDOR NAME
  1. S PRCTMB=$P($G(^PRC(440,PRCTMP,3)),U,4) ;
  1. S PRCDT=PRCDT_PRCTMB_U ;VENDOR FMS CODE
  1. S PRCTMB=$P($G(^PRC(440,PRCTMP,3)),U,5)
  1. S PRCDT=PRCDT_PRCTMB_U ;VENDOR ALT-ADDR-IND
  1. S PRCTMB=$P($G(^PRC(440,PRCTMP,7)),U,12)
  1. S PRCDT=PRCDT_PRCTMB_U ;VENDOR D & B
  1. S PRCDT=PRCDT_$P(PRCND,U,10)_U ;VENDOR CONTRACT NUMBER
  1. S PRCDT=PRCDT_$P(PRCND,U,1)_U ;CONTROL POINT
  1. S PRCDT=PRCDT_$P(PRCND,U,3)_U ;COST CENTER
  1. S PRCDT=PRCDT_$P(PRCND,U,6)_U ;BOC1
  1. S PRCDT=PRCDT_$P(PRCND,U,7)_U ;BOC1 $ AMOUNT
  1. S PRCDT=PRCDT_$P(PRCND,U,2)_U ;ACCOUNTING DATA
  1. S PRCDT=PRCDT_$P(PRCND,U,12)_U ;FCP/PRJ
  1. S X=$P(PRCND,U,11),PRCDT=PRCDT_$S(X>0:$E(X+17000000,1,4),1:"")_U ;BBFY
  1. S PRCND=$G(^PRCS(410,PRCIEN,4)) ;NODE 4
  1. S PRCDT=PRCDT_$P(PRCND,U,1)_U ;COMMITTED (EST.) COST
  1. S X=$P(PRCND,U,2),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE COMMITTED
  1. S PRCDT=PRCDT_$P(PRCND,U,3)_U ;OBLIGATED ACTUAL COST
  1. S X=$P(PRCND,U,4),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE OBLIGATED
  1. S PRCDT=PRCDT_$P(PRCND,U,5)_U ;PO / OBLIGATION NO
  1. S PRCDT=PRCDT_$P(PRCND,U,6)_U ;ADJUSTMENT AMOUNT
  1. S X=$P(PRCND,U,7),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE OBL ADJUSTED
  1. S PRCDT=PRCDT_$P(PRCND,U,8)_U ;TRANSACTION AMOUNT
  1. S PRCDUZ=$P(PRCND,U,9),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
  1. S PRCDT=PRCDT_PRCDUZ_U ;OBLIGATED BY DUZ
  1. S PRCDT=PRCDT_PRCTMP_U ;OBLIGATED BY NAME
  1. S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
  1. S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
  1. S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;OBLIGATED SERVICE INT/EXT
  1. S X=$P(PRCND,U,13),PRCDT=PRCDT_$S(X>0:$TR($$FMTE^XLFDT(X),"@"," "),1:"")_U ;OBL VAL CODE DATE/TIME
  1. S PRCND=$G(^PRCS(410,PRCIEN,7)) ;NODE 7
  1. S PRCDUZ=$P(PRCND,U,1),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
  1. S PRCDT=PRCDT_PRCDUZ_U ;REQUESTOR DUZ
  1. S PRCDT=PRCDT_PRCTMP_U ;REQUESTOR NAME
  1. S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
  1. S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
  1. S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;REQUESTOR SERVICE INT/EXT
  1. S PRCDT=PRCDT_$P(PRCND,U,2)_U ;REQUESTOR'S TITLE
  1. S PRCDUZ=$P(PRCND,U,3),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
  1. S PRCDT=PRCDT_PRCDUZ_U ;APPROVING OFFICIAL DUZ
  1. S PRCDT=PRCDT_PRCTMP_U ;APPROVING OFFICIAL NAME
  1. S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
  1. S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
  1. S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;APPROVING OFFICIAL SERVICE INT/EXT
  1. S PRCDT=PRCDT_$P(PRCND,U,4)_U ;APPROVING OFFICIAL TITLE
  1. S X=$P(PRCND,U,5),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE SIGNED (APPROVED)
  1. S X=$P(PRCND,U,7),PRCDT=PRCDT_$S(X>0:$TR($$FMTE^XLFDT(X),"@"," "),1:"")_U ;ES CODE DATE/TIME
  1. S ^TMP($J,"CONTRP",PRCIEN,1)=PRCDT,PRCDT=""
  1. S PRCTMB=8 D WORDFLD ;NODE 8
  1. S PRCDT=PRCDT_PRCTMP_U ;JUSTIFICATION
  1. S ^TMP($J,"CONTRP",PRCIEN,2)=PRCDT,PRCDT=""
  1. S PRCND=$G(^PRCS(410,PRCIEN,11)) ;NODE 11
  1. S PRCTMP=$$GET1^DIQ(410,PRCIEN_",",49)
  1. S PRCDT=PRCDT_PRCTMP_U ;SORT GROUP EXTERNAL
  1. S PRCND=$G(^PRCS(410,PRCIEN,10)) ;NODE 10
  1. S PRCTMP=$P(PRCND,U,3),PRCTMB=$P($G(^PRC(442,+PRCTMP,0)),U)
  1. S PRCDT=PRCDT_PRCTMP_U ;STATION NO - P.O.NO IEN
  1. S PRCDT=PRCDT_PRCTMB_U ;STATION NO - P.O.NO EXT
  1. S PRCDT=PRCDT_$$PODATE(PRCTMP)_U ;PO DATE
  1. S D0=PRCIEN D STATUS^PRCSES
  1. S PRCDT=PRCDT_X_U ;STATUS
  1. S PRCTMB="CO" D WORDFLD ;NODE CO
  1. S PRCDT=PRCDT_PRCTMP_U ;COMMENTS
  1. S ^TMP($J,"CONTRP",PRCIEN,3)=PRCDT,PRCDT=""
  1. S PRCTMB=13 D WORDFLD ;NODE 13
  1. S PRCDT=PRCDT_PRCTMP ;REASON FOR RETURN
  1. S ^TMP($J,"CONTRP",PRCIEN,4)=PRCDT_U
  1. ;;authority;sub-authority ;AUTHORITY/SUB-AUTHORITY
  1. S PRCDT=""
  1. S PRCND=$G(^PRCS(410,PRCIEN,11)) ;NODE 11
  1. F PRCIX=4,5 D
  1. . S PRCAUIEN=$P(PRCND,U,PRCIX) ;auth ien
  1. . S PRCDT=$S(PRCIX=4:PRCAUIEN,1:PRCDT_U_PRCAUIEN)
  1. . D GETS^DIQ(410.9,+PRCAUIEN_",",".01;.02","","PRCARY")
  1. . S PRCDT=PRCDT_U_$G(PRCARY(410.9,+PRCAUIEN_",",.01))_U_$G(PRCARY(410.9,+PRCAUIEN_",",.02))
  1. ;;service dates ;SERVICE DATES
  1. S PRCND=$G(^PRCS(410,PRCIEN,1)) ;NODE 1
  1. F PRCIX=6,7 D
  1. . S PRCDT=PRCDT_U_$$FMTE^XLFDT($P(PRCND,U,PRCIX))
  1. S ^TMP($J,"CONTRP",PRCIEN,5)=PRCDT
  1. ;
  1. D GET4104
  1. Q
  1. GET4104 ; GET DATA FROM SUBFILE 410.04
  1. N PRCX S PRCX=$P(^PRCS(410,PRCIEN,0),U)_U_PRCIEN_U_$P(^(0),U,5)_U
  1. 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
  1. N PRCTMI
  1. S PRCTMI=0 F S PRCTMI=$O(^PRCS(410,PRCIEN,12,PRCTMI)) Q:'PRCTMI D
  1. . S PRCDT=PRCX
  1. . S PRCND=$G(^PRCS(410,PRCIEN,12,PRCTMI,0))
  1. . S PRCDT=PRCDT_$P($G(^PRCS(410.4,+$P(PRCND,U,1),0)),U)_U ;SUB-CONTROL POINT
  1. . S PRCDT=PRCDT_$P(PRCND,U,2)_U ;AMOUNT
  1. . S PRCTMB=$$GET1^DIQ(410.04,PRCTMI_","_PRCIEN_",",2)
  1. . S PRCDT=PRCDT_PRCTMB ;SCP AMOUNT
  1. . S ^TMP($J,"SUBCP",PRCIEN,PRCTMI)=PRCDT
  1. Q
  1. WORDFLD ; PROCESS WORD FIELD
  1. N PRCTMI,PRCTMJ,PRCTMQ
  1. S PRCTMI=$P($G(^PRCS(410,PRCIEN,PRCTMB,0)),U,3),PRCTMP="",PRCTMQ=0
  1. I PRCTMI D
  1. . F PRCTMI=1:1:PRCTMI D Q:PRCTMQ
  1. .. S PRCTMJ=$G(^PRCS(410,PRCIEN,PRCTMB,PRCTMI,0))_" "
  1. .. I $F(PRCTMJ,"^") S PRCTMJ=$TR(PRCTMJ,"^","*") ;CONVERT ^ TO *
  1. .. 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
  1. .. S PRCTMP=PRCTMP_PRCTMJ
  1. Q
  1. ;
  1. GET424 ;
  1. S U="^"
  1. N PRCND,PRCIEN,PRCDT,PRCTMP,PRCTMB,PRCC,X
  1. ; loop through file 424, "C" Cross Reference
  1. S PRCC=0
  1. F S PRCC=$O(^PRC(424,"C",PRCC)) Q:'PRCC D
  1. . I $D(^TMP($J,"POMAST",PRCC)) D DAT424
  1. D GET4241
  1. Q
  1. DAT424 ;
  1. N PRCPOID
  1. S PRCIEN=0
  1. F S PRCIEN=$O(^PRC(424,"C",PRCC,PRCIEN)) Q:'PRCIEN D
  1. . S PRCDT=""
  1. . S PRCND=$G(^PRC(424,PRCIEN,0)) ;NODE 0
  1. . S (PRCPOID,X,Y)=$P(PRCND,U,2),PRCDT=PRCDT_X_U ;OBLIGATION INT
  1. . S X=$S(X>0:$P($G(^PRC(442,X,0)),U),1:""),PRCDT=PRCDT_X_U ; OBL EXT
  1. . S PRCDT=PRCDT_$$PODATE(PRCPOID)_U ;PO DATE
  1. . S PRCDT=PRCDT_MNTHYR_U ;Month,Year of extract
  1. . S PRCDT=PRCDT_$P(X,"-")_U ;STATION #
  1. . S PRCDT=PRCDT_$P(PRCND,U,1)_U ;AUTHORIZATION #
  1. . S PRCDT=PRCDT_$$GET1^DIQ(424,PRCIEN_",",.03)_U ;TRANSACTION TYPE
  1. . S PRCDT=PRCDT_$P(PRCND,U,4)_U ;LIQUIDATION AMOUNT
  1. . S PRCDT=PRCDT_$P(PRCND,U,5)_U ;AUTHORIZATION BALANCE
  1. . S PRCDT=PRCDT_$P(PRCND,U,6)_U ;OBLIGATION AMOUNT
  1. . S X=$P(PRCND,U,7),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE/TIME
  1. . S PRCDUZ=$P(PRCND,U,8),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
  1. . S PRCDT=PRCDT_PRCDUZ_U ;USER DUZ
  1. . S PRCDT=PRCDT_PRCTMP_U ;USER NAME
  1. . S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
  1. . S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
  1. . S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;USER SERVICE INT/EXT
  1. . S PRCDT=PRCDT_$$GET1^DIQ(424,PRCIEN_",",.09)_U ;COMPLETED FLAG
  1. . S PRCDT=PRCDT_$P(PRCND,U,10)_U ;REFERENCE
  1. . S PRCDT=PRCDT_$P(PRCND,U,11)_U ;LAST SEQUENCE USED
  1. . S PRCDT=PRCDT_$P(PRCND,U,12)_U ;AUTHORIZATION AMOUNT
  1. . S PRCDT=PRCDT_$P(PRCND,U,13)_U ;ORIGINAL AUTH. AMOUNT
  1. . S PRCDUZ=$P(PRCND,U,14),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
  1. . S PRCDT=PRCDT_PRCDUZ_U ;LAST EDITED BY DUZ
  1. . S PRCDT=PRCDT_PRCTMP_U ;LAST EDITED BY NAME
  1. . S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
  1. . S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
  1. . S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;LAST EDITED BY SERVICE INT/EXT
  1. . S PRCTMP=$P(PRCND,U,15),PRCTMP=$P($G(^PRCS(410,+PRCTMP,0)),U)
  1. . S PRCDT=PRCDT_$P(PRCND,U,15)_U ;CPA POINTER IEN
  1. . S PRCDT=PRCDT_PRCTMP_U ;CPA POINTER EXT
  1. . S PRCND=$G(^PRC(424,PRCIEN,1)) ;NODE 1
  1. . S PRCDT=PRCDT_$P(PRCND,U,1)_U ;COMMENTS
  1. . S PRCND=$G(^PRC(424,PRCIEN,2)) ;NODE 2
  1. . S PRCDT=PRCDT_$P(PRCND,U,2) ;INTERFACE ID
  1. . S ^TMP($J,"DR1358",PRCIEN,1)=PRCDT
  1. Q
  1. GET4241 ;
  1. ; loop through file 424.1
  1. S PRCC=0
  1. F S PRCC=$O(^PRC(424.1,"C",PRCC)) Q:'PRCC D
  1. . I $D(^TMP($J,"DR1358",PRCC)) D DAT4241
  1. Q
  1. DAT4241 ;
  1. N Y,PRCSTN
  1. S PRCIEN=0 F S PRCIEN=$O(^PRC(424.1,"C",PRCC,PRCIEN)) Q:'PRCIEN D
  1. . S PRCDT=""
  1. . S PRCND=$G(^PRC(424.1,PRCIEN,0)) ;NODE 0
  1. . S X=$P(PRCND,U,2)
  1. . S (X,PRCPOID)=$P($G(^PRC(424,+X,0)),U,2),PRCDT=PRCDT_X_U ;PO# INT
  1. . S X=$S(X>0:$P($G(^PRC(442,X,0)),U),1:""),PRCDT=PRCDT_X_U ;PO# EXT
  1. . S PRCSTN=$P(X,"-") S:PRCPOID="" PRCPOID=PRCIEN
  1. . S PRCDT=PRCDT_$$PODATE(PRCPOID)_U ;PO DATE
  1. . S PRCDT=PRCDT_MNTHYR_U ;Month,Year of extract
  1. . S PRCDT=PRCDT_PRCSTN_U ;STATION
  1. . S PRCDT=PRCDT_$P(PRCND,U,1)_U ;BILL NUMBER
  1. . S PRCDT=PRCDT_$$GET1^DIQ(424.1,PRCIEN_",",.011)_U ;RECORD TYPE
  1. . S PRCTMP=$P(PRCND,U,2),PRCTMP=$P($G(^PRC(424,+PRCTMP,0)),U)
  1. . S PRCDT=PRCDT_$P(PRCND,U,2)_U ;AUTH. POINTER IEN
  1. . S PRCDT=PRCDT_PRCTMP_U ;AUTH. POINTER EXT
  1. . S PRCDT=PRCDT_$P(PRCND,U,3)_U ;AUTH. AMOUNT
  1. . S X=$P(PRCND,U,4),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE/TIME
  1. . S PRCDUZ=$P(PRCND,U,5),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
  1. . S PRCDT=PRCDT_PRCDUZ_U ;USER DUZ
  1. . S PRCDT=PRCDT_PRCTMP_U ;USER NAME
  1. . S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
  1. . S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
  1. . S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;USER SERVICE INT/EXT
  1. . S PRCDT=PRCDT_$P(PRCND,U,6)_U ;VENDOR INVOICE NUMBER
  1. . S PRCDT=PRCDT_$$GET1^DIQ(424.1,PRCIEN_",",.07)_U ;FINAL BILL
  1. . S PRCDT=PRCDT_$P(PRCND,U,8)_U ;REFERENCE
  1. . S PRCDUZ=$P(PRCND,U,10),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U)
  1. . S PRCDT=PRCDT_PRCDUZ_U ;LAST EDITED BY DUZ
  1. . S PRCDT=PRCDT_PRCTMP_U ;LAST EDITED BY NAME
  1. . S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U)
  1. . S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01))
  1. . S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;LAST EDITED BY SERVICE INT/EXT
  1. . S PRCND=$G(^PRC(424.1,PRCIEN,1)) ;NODE 1
  1. . S PRCDT=PRCDT_$P(PRCND,U,1) ;DESCRIPTION
  1. . S ^TMP($J,"AD1358",PRCIEN,1)=PRCDT
  1. Q
  1. PODATE(PRCPOIEN) ;input PO's ien, output external form PO Date
  1. N X
  1. S X=$S(PRCPOIEN>0:$P($G(^PRC(442,PRCPOIEN,1)),U,15),1:"")
  1. S:X'="" X=$$FMTE^XLFDT(X,"D")
  1. Q X