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