Released PRC*5.1*140 SEQ #119 Extracted from mail message **KIDS**:PRC*5.1*140^ **INSTALL NAME** PRC*5.1*140 "BLD",6035,0) PRC*5.1*140^IFCAP^0^3100308^y "BLD",6035,1,0) ^^7^7^3100308^ "BLD",6035,1,1,0) This patch will address the following issues: "BLD",6035,1,2,0) "BLD",6035,1,3,0) 1. No CLRS data feed "BLD",6035,1,4,0) "BLD",6035,1,5,0) 2. Contract Number on original 1358 but dropped on adjustments "BLD",6035,1,6,0) "BLD",6035,1,7,0) 3. Option PRCSR1358 has wrong line label in routine "BLD",6035,4,0) ^9.64PA^^ "BLD",6035,6.3) 4 "BLD",6035,"ABPKG") n "BLD",6035,"KRN",0) ^9.67PA^779.2^20 "BLD",6035,"KRN",.4,0) .4 "BLD",6035,"KRN",.401,0) .401 "BLD",6035,"KRN",.402,0) .402 "BLD",6035,"KRN",.403,0) .403 "BLD",6035,"KRN",.5,0) .5 "BLD",6035,"KRN",.84,0) .84 "BLD",6035,"KRN",3.6,0) 3.6 "BLD",6035,"KRN",3.8,0) 3.8 "BLD",6035,"KRN",9.2,0) 9.2 "BLD",6035,"KRN",9.8,0) 9.8 "BLD",6035,"KRN",9.8,"NM",0) ^9.68A^2^2 "BLD",6035,"KRN",9.8,"NM",1,0) PRCHLO6^^0^B125729852 "BLD",6035,"KRN",9.8,"NM",2,0) PRCEADJ^^0^B31997445 "BLD",6035,"KRN",9.8,"NM","B","PRCEADJ",2) "BLD",6035,"KRN",9.8,"NM","B","PRCHLO6",1) "BLD",6035,"KRN",19,0) 19 "BLD",6035,"KRN",19,"NM",0) ^9.68A^1^1 "BLD",6035,"KRN",19,"NM",1,0) PRCSR1358^^1^ "BLD",6035,"KRN",19,"NM","B","PRCSR1358",1) "BLD",6035,"KRN",19.1,0) 19.1 "BLD",6035,"KRN",101,0) 101 "BLD",6035,"KRN",409.61,0) 409.61 "BLD",6035,"KRN",771,0) 771 "BLD",6035,"KRN",779.2,0) 779.2 "BLD",6035,"KRN",870,0) 870 "BLD",6035,"KRN",8989.51,0) 8989.51 "BLD",6035,"KRN",8989.52,0) 8989.52 "BLD",6035,"KRN",8994,0) 8994 "BLD",6035,"KRN","B",.4,.4) "BLD",6035,"KRN","B",.401,.401) "BLD",6035,"KRN","B",.402,.402) "BLD",6035,"KRN","B",.403,.403) "BLD",6035,"KRN","B",.5,.5) "BLD",6035,"KRN","B",.84,.84) "BLD",6035,"KRN","B",3.6,3.6) "BLD",6035,"KRN","B",3.8,3.8) "BLD",6035,"KRN","B",9.2,9.2) "BLD",6035,"KRN","B",9.8,9.8) "BLD",6035,"KRN","B",19,19) "BLD",6035,"KRN","B",19.1,19.1) "BLD",6035,"KRN","B",101,101) "BLD",6035,"KRN","B",409.61,409.61) "BLD",6035,"KRN","B",771,771) "BLD",6035,"KRN","B",779.2,779.2) "BLD",6035,"KRN","B",870,870) "BLD",6035,"KRN","B",8989.51,8989.51) "BLD",6035,"KRN","B",8989.52,8989.52) "BLD",6035,"KRN","B",8994,8994) "BLD",6035,"QUES",0) ^9.62^^ "BLD",6035,"REQB",0) ^9.611^1^1 "BLD",6035,"REQB",1,0) PRC*5.1*130^2 "BLD",6035,"REQB","B","PRC*5.1*130",1) "KRN",19,12807,-1) 1^1 "KRN",19,12807,0) PRCSR1358 "MBREQ") 0 "ORD",18,19) 19;18;;;OPT^XPDTA;OPTF1^XPDIA;OPTE1^XPDIA;OPTF2^XPDIA;;OPTDEL^XPDIA "ORD",18,19,0) OPTION "PKG",455,-1) 1^1 "PKG",455,0) IFCAP^PRC^IFCAP System Files "PKG",455,20,0) ^9.402P^^ "PKG",455,22,0) ^9.49I^1^1 "PKG",455,22,1,0) 5.1^3001012^3001019^68 "PKG",455,22,1,"PAH",1,0) 140^3100308 "PKG",455,22,1,"PAH",1,1,0) ^^7^7^3100308 "PKG",455,22,1,"PAH",1,1,1,0) This patch will address the following issues: "PKG",455,22,1,"PAH",1,1,2,0) "PKG",455,22,1,"PAH",1,1,3,0) 1. No CLRS data feed "PKG",455,22,1,"PAH",1,1,4,0) "PKG",455,22,1,"PAH",1,1,5,0) 2. Contract Number on original 1358 but dropped on adjustments "PKG",455,22,1,"PAH",1,1,6,0) "PKG",455,22,1,"PAH",1,1,7,0) 3. Option PRCSR1358 has wrong line label in routine "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") NO "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 2 "RTN","PRCEADJ") 0^2^B31997445^B23324366 "RTN","PRCEADJ",1,0) PRCEADJ ;WISC/CLH/LDB/PLT/SJG-CP 1358 ADJUSTMENTS ; 04/21/93 10:52 AM "RTN","PRCEADJ",2,0) V ;;5.1;IFCAP;**140**;Oct 20, 2000;Build 4 "RTN","PRCEADJ",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCEADJ",4,0) ;Create increase/decrease adjustment "RTN","PRCEADJ",5,0) EN N PRC410,PRC442,PRCS,DIE,DR,PRC,PRCS2,DIC,X,X410,X442,X1,X2,X3,X4,PRCSIP,Y,Y410,DIR,TRNODE,Z,Z410,PRCSOBN "RTN","PRCEADJ",6,0) EN1 ; "RTN","PRCEADJ",7,0) D EN^PRCSUT ; ask site, fiscal year, quarter, control point; set X & Z "RTN","PRCEADJ",8,0) I '$D(PRC("SITE")) W !,$C(7),"You are not an authorized control point user.",! G OUT "RTN","PRCEADJ",9,0) G OUT:'$D(PRC("QTR"))!(Y<0) "RTN","PRCEADJ",10,0) S X410=X ; station-FY-FCP "RTN","PRCEADJ",11,0) S Z410=Z ; station-FY-quarter-FCP "RTN","PRCEADJ",12,0) ENA1 S DIC=410,Y="" "RTN","PRCEADJ",13,0) D OROBL^PRCS58OB(DIC,.PRC,.Y) ; get obligation # from old 1358 "RTN","PRCEADJ",14,0) I $D(DTOUT)!$D(DUOUT) G OUT "RTN","PRCEADJ",15,0) I Y<0 W $C(7),!!," Obligation number is required. Use '^' to exit this option.",! G ENA1 "RTN","PRCEADJ",16,0) S Y410=Y "RTN","PRCEADJ",17,0) S X442=X "RTN","PRCEADJ",18,0) D NODE^PRCS58OB(+Y,.TRNODE) ; set up TRNODE array from data in 410 "RTN","PRCEADJ",19,0) S X="0101"_$P(TRNODE(0),"-",2),%DT="X" D ^%DT "RTN","PRCEADJ",20,0) S X2=$E(Y,1,3) ; FY of original 1358 "RTN","PRCEADJ",21,0) S X="0101"_PRC("FY"),%DT="X" D ^%DT "RTN","PRCEADJ",22,0) S X3=$E(Y,1,3) ; adjustment FY "RTN","PRCEADJ",23,0) I X2_"-"_$P(TRNODE(0),"-",3)](X3_"-"_PRC("QTR")) D EN^DDIOL("Adjustments cannot be earlier than the original 1358's FY-QTR.") G ENA1 "RTN","PRCEADJ",24,0) N POOBL S POOBL=$P($G(TRNODE(10)),U,3) "RTN","PRCEADJ",25,0) I POOBL="" D EN^DDIOL(" Obligation number is required.") W ! G ENA1 "RTN","PRCEADJ",26,0) N OBLSTAT S OBLSTAT=$$NP^PRC0B("^PRC(442,"_POOBL_",",7,1) "RTN","PRCEADJ",27,0) I $G(OBLSTAT)=40 D EN^DDIOL(" Adjusting a closed 1358 request is not allowed.") W ! G ENA1 "RTN","PRCEADJ",28,0) ENA2 N EXIT S EXIT=0 "RTN","PRCEADJ",29,0) D FMSTAT(POOBL,.FMSDOC,.STATUS) "RTN","PRCEADJ",30,0) I $D(STATUS),"AF"'[$E(STATUS,1) D I EXIT D MSG1,OUT G EN1 "RTN","PRCEADJ",31,0) .Q:STATUS="CALM" "RTN","PRCEADJ",32,0) .; S TMP=Y,%X="Y",%Y="TMP(" D %XY^%RCR K %X,%Y ; PRC*5*231 - saves Y earlier "RTN","PRCEADJ",33,0) .K MSG W ! "RTN","PRCEADJ",34,0) .S MSG(1)=" Note that one of the previous documents has not been processed in FMS." "RTN","PRCEADJ",35,0) .S MSG(2)=" The adjustment to this 1358 cannot be obligated until the previous" "RTN","PRCEADJ",36,0) .S MSG(3)=" document has been processed in FMS.",MSG(5)=" " "RTN","PRCEADJ",37,0) .S MSG(6)=" FMS Document: "_FMSDOC,MSG(7)=" Status: "_STATUS "RTN","PRCEADJ",38,0) .D EN^DDIOL(.MSG) K MSG "RTN","PRCEADJ",39,0) .W ! D PROMPT "RTN","PRCEADJ",40,0) .S:Y EXIT=0 I 'Y!($D(DIRUT)) S EXIT=1 "RTN","PRCEADJ",41,0) .Q "RTN","PRCEADJ",42,0) ;The following lines commented out by PRC*5*231 - Y doesn't need to be restored "RTN","PRCEADJ",43,0) ; I $D(STATUS) S:"AF"[$E(STATUS,1)!(STATUS="CALM") EXIT=1 "RTN","PRCEADJ",44,0) ENA3 ; I $D(EXIT) I 'EXIT S Y=TMP,%X="TMP",%Y="Y(" D %XY^%RCR,MSG2 K TMP,%X,%Y "RTN","PRCEADJ",45,0) S PRC442=$P($G(TRNODE(10)),U,3) "RTN","PRCEADJ",46,0) S PRCSOBN=$$BAL^PRCH58(PRC442) ; get obligation# from file 442,node 8 "RTN","PRCEADJ",47,0) I PRCSOBN'=-1 W !," Original Obligation Amount: $ ",$FN($P(PRCSOBN,U),",P",2) "RTN","PRCEADJ",48,0) I PRCSOBN'=-1 D "RTN","PRCEADJ",49,0) .W ?46,"Service Balance: $ ",$FN((+PRCSOBN-$P(PRCSOBN,U,3)),",P",2),! "RTN","PRCEADJ",50,0) .W ?4," Fiscal's 1358 Balance: $ ",$FN(+PRCSOBN-$P(PRCSOBN,U,2),",P",2),! "RTN","PRCEADJ",51,0) S Y=Y410,X=X410,X1=X,Z=Z410 "RTN","PRCEADJ",52,0) D EN1^PRCSUT3 Q:'X S X1=X "RTN","PRCEADJ",53,0) D EN2 Q:'$D(X1) S X=X1 ; add data to record in 410 "RTN","PRCEADJ",54,0) W !,"This transaction is assigned transaction number: ",X "RTN","PRCEADJ",55,0) L +^PRCS(410,DA):0 I $T=0 D EN^DDIOL("File in use.... Please try again later") D KILL G EN1 "RTN","PRCEADJ",56,0) I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),U,11)="Y" PRCS2=1 "RTN","PRCEADJ",57,0) S PRC410=DA "RTN","PRCEADJ",58,0) S PRCSIP=$S($D(PRCSIP):PRCSIP,1:"") "RTN","PRCEADJ",59,0) D ADJ^PRCS58OB(DIC,DA,PRCSIP,.X4) "RTN","PRCEADJ",60,0) K PRCSOBN "RTN","PRCEADJ",61,0) D ADJ1^PRCS58OB(DA,X,Y410) "RTN","PRCEADJ",62,0) D ADJ2^PRCS58OB(.PRC,X442,DA) "RTN","PRCEADJ",63,0) L -^PRCS(410,DA) "RTN","PRCEADJ",64,0) S DIR("A")="Enter another increase/decrease adjustment" "RTN","PRCEADJ",65,0) S DIR(0)="YO",DIR("B")="NO" "RTN","PRCEADJ",66,0) S DIR("?")="Yes to enter an adjustment, return or '^' to quit" "RTN","PRCEADJ",67,0) D ^DIR I Y D KILL G EN1 "RTN","PRCEADJ",68,0) OUT K DIRUT,DTOUT,DUOUT "RTN","PRCEADJ",69,0) KILL K PRC410,PRC442,PRCS,DIE,DR,PRC,PRCSL,PRCS2,DIC,X,X410,X442,X1,X4,PRCSIP,Y,Y410,DIR,TRNODE,Z,Z410,PRCSOBN "RTN","PRCEADJ",70,0) K DA,FMSDOC,STATUS,TMP,%DT "RTN","PRCEADJ",71,0) QUIT "RTN","PRCEADJ",72,0) ; "RTN","PRCEADJ",73,0) ASK ; entry point from other options "RTN","PRCEADJ",74,0) S DIR(0)="YO" "RTN","PRCEADJ",75,0) S DIR("A")="Do you want to enter an increase adjustment at this time" "RTN","PRCEADJ",76,0) S DIR("B")="NO" "RTN","PRCEADJ",77,0) S DIR("?")="Yes to enter an increase adjustment, return or '^' to quit" "RTN","PRCEADJ",78,0) D ^DIR I 'Y&'$D(DIRUT) W !!,"No action can be taken with this authorization amount now.",! K DIR Q "RTN","PRCEADJ",79,0) K DIR,DIC,X,Y I $D(DIRUT) Q "RTN","PRCEADJ",80,0) G EN "RTN","PRCEADJ",81,0) ; "RTN","PRCEADJ",82,0) FMSTAT(POOBL,FMSDOC,STATUS) ; Check status of prior FMS Documents "RTN","PRCEADJ",83,0) N LOOP,NODE "RTN","PRCEADJ",84,0) S LOOP=0,(FMSDOC,STATUS)="" "RTN","PRCEADJ",85,0) F S LOOP=$O(^PRC(442,+POOBL,10,LOOP)) Q:LOOP'>0 D "RTN","PRCEADJ",86,0) .S NODE=^PRC(442,+POOBL,10,LOOP,0) "RTN","PRCEADJ",87,0) .I $E(NODE,1,2)="SO"!($E(NODE,1,2)="AR") D "RTN","PRCEADJ",88,0) ..S FMSDOC=$P($G(^PRC(442,+POOBL,10,LOOP,0)),U,4) "RTN","PRCEADJ",89,0) ..S STATUS=$$STATUS^GECSSGET(FMSDOC) "RTN","PRCEADJ",90,0) ..Q "RTN","PRCEADJ",91,0) .I $E(NODE,1,6)?3N1"."2N S STATUS="CALM" "RTN","PRCEADJ",92,0) Q "RTN","PRCEADJ",93,0) PROMPT ; "RTN","PRCEADJ",94,0) S DIR(0)="Y" "RTN","PRCEADJ",95,0) S DIR("A")=" Do you wish to create the adjustment to this 1358" "RTN","PRCEADJ",96,0) S DIR("B")="YES" "RTN","PRCEADJ",97,0) S DIR("?")=" Enter 'YES' or 'Y' or 'RETURN' to create the adjustment." "RTN","PRCEADJ",98,0) S DIR("?",1)=" Enter 'NO' or 'N' or '^' to exit." "RTN","PRCEADJ",99,0) D ^DIR K DIR "RTN","PRCEADJ",100,0) Q "RTN","PRCEADJ",101,0) ; "RTN","PRCEADJ",102,0) EN2 ;add record in file 410 "RTN","PRCEADJ",103,0) S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="LXZ" D ^DIC K DLAYGO G:Y<0 W4 "RTN","PRCEADJ",104,0) EN2A S DA=+Y S:'$D(T(2)) T(2)="" "RTN","PRCEADJ",105,0) S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY")) "RTN","PRCEADJ",106,0) S PRCSAPP=$P(PRC("ACC"),U,11) "RTN","PRCEADJ",107,0) S ^PRCS(410,DA,0)=$P(^PRCS(410,DA,0),U)_"^^"_T(2)_"^^"_PRC("SITE") "RTN","PRCEADJ",108,0) S ^PRCS(410,DA,2)=$G(^PRCS(410,+Y410,2)) "RTN","PRCEADJ",109,0) S ^PRCS(410,DA,3)=PRC("CP")_U_PRCSAPP,$P(^(3),U,12)=$P(PRC("ACC"),U,3) "RTN","PRCEADJ",110,0) S $P(^PRCS(410,DA,3),U,11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),U,7) "RTN","PRCEADJ",111,0) S $P(^PRCS(410,DA,3),U,10)=$P($G(^PRCS(410,+Y410,3)),U,10) "RTN","PRCEADJ",112,0) S ^PRCS(410,"AN",$E(PRC("CP"),1,30),DA)="" "RTN","PRCEADJ",113,0) D ERS410^PRC0G(DA_"^E") "RTN","PRCEADJ",114,0) S:T(2)'="" ^PRCS(410,"H",$E(T(2),1,30),DA)=DUZ,$P(^PRCS(410,DA,11),U,2)=DUZ,^PRCS(410,"K",+$P(PRC("CP")," "),DA)="",$P(^PRCS(410,DA,6),U,4)=+$P(PRC("CP")," ") K PRCSAPP "RTN","PRCEADJ",115,0) EN2B S:$D(PRC("SST")) $P(^PRCS(410,DA,0),U,10)=PRC("SST") "RTN","PRCEADJ",116,0) D:$D(MYY) ERS410^PRC0G(DA_"^E") "RTN","PRCEADJ",117,0) K T(2),MYY "RTN","PRCEADJ",118,0) Q "RTN","PRCEADJ",119,0) W4 W !!,"Another user is accessing this file... Try later.",$C(7) R:$E(IOST,1,2)="C-" X:5 "RTN","PRCEADJ",120,0) Q "RTN","PRCEADJ",121,0) ; "RTN","PRCEADJ",122,0) MSG1 W ! D EN^DDIOL(" No further action taken on this adjustment.") W ! Q "RTN","PRCEADJ",123,0) MSG2 W ! D EN^DDIOL(" Returning to creating the 1358 adjustment...") W !! Q "RTN","PRCHLO6") 0^1^B125729852^B122486114 "RTN","PRCHLO6",1,0) PRCHLO6 ;WOIFO/AS-EXTRACT ROUTINE (cont.)CLO REPORT SERVER ;5/17/09 23:45 "RTN","PRCHLO6",2,0) ;;5.1;IFCAP;**130,140**;Oct 20, 2000;Build 4 "RTN","PRCHLO6",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCHLO6",4,0) ; DBIA 10093 - Read file 49 via FileMan. "RTN","PRCHLO6",5,0) ; Continuation of PRCHLO1. This program builds the extracts for "RTN","PRCHLO6",6,0) ; the Master PO Table and the associated multiples "RTN","PRCHLO6",7,0) GET410 ; get file 410 record "RTN","PRCHLO6",8,0) S U="^" "RTN","PRCHLO6",9,0) N PRCND,PRCIEN,PRCDT,PRCTMP,PRCTMB,PRCTR,PRCFR,PRCDAT,PRCDATO,PRCDATA,D0,X "RTN","PRCHLO6",10,0) N PRCDUZ "RTN","PRCHLO6",11,0) ; loop through file 410 "RTN","PRCHLO6",12,0) S PRCIEN=0,PRCDT="" "RTN","PRCHLO6",13,0) F S PRCIEN=$O(^PRCS(410,PRCIEN)) Q:'PRCIEN D "RTN","PRCHLO6",14,0) . S PRCND=$G(^PRCS(410,PRCIEN,0)) ;NODE 0 "RTN","PRCHLO6",15,0) . S PRCTR=$P(PRCND,U,2) ;TRANSACTION TYPE "RTN","PRCHLO6",16,0) . S PRCFR=$P(PRCND,U,4) ;FORM TYPE "RTN","PRCHLO6",17,0) . S PRCDAT=$P($G(^PRCS(410,PRCIEN,1)),U,1) ;DATE OF REQUEST "RTN","PRCHLO6",18,0) . S PRCDATO=$P($G(^PRCS(410,PRCIEN,4)),U,4) ;DATE OBLIGATED "RTN","PRCHLO6",19,0) . S PRCDATA=$P($G(^PRCS(410,PRCIEN,4)),U,7) ;DATE OBLIGATED ADJ "RTN","PRCHLO6",20,0) . ;TRANS TYPE IS ADJUSTMENT, FORM TYPE IS NOT NULL NOT ISSUE BOOK "RTN","PRCHLO6",21,0) . I PRCTR="A",PRCFR,PRCFR'=5,PRCDAT>CLOBGN,PRCDATCLOBGN,PRCDATOCLOBGN,PRCDATCLOBGN,PRCDATOCLOBGN,PRCDATA0:$P($G(^PRCS(410.5,PRCFR,0)),U),1:"")_U ;FORM TYPE "RTN","PRCHLO6",39,0) 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 "RTN","PRCHLO6",40,0) S X=$P(PRCND,U,11),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;RUNNING BAL QTR DATE "RTN","PRCHLO6",41,0) S PRCDT=PRCDT_$$GET1^DIQ(410,PRCIEN_",",450)_U ;RUNNING BAL STATUS "RTN","PRCHLO6",42,0) S PRCND=$G(^PRCS(410,PRCIEN,1)) ;NODE 1 "RTN","PRCHLO6",43,0) S X=$P(PRCND,U,1),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE OF REQUEST "RTN","PRCHLO6",44,0) S PRCDT=PRCDT_$P(PRCND,U,5)_U ;CLASS OF REQUEST IEN "RTN","PRCHLO6",45,0) S PRCTMP=$P($G(^PRCS(410.2,+$P(PRCND,U,5),0)),U) "RTN","PRCHLO6",46,0) S PRCDT=PRCDT_PRCTMP_U ;CLASS OF REQUEST EXT "RTN","PRCHLO6",47,0) S PRCND=$G(^PRCS(410,PRCIEN,2)) ;NODE 2 "RTN","PRCHLO6",48,0) S PRCDT=PRCDT_$P(PRCND,U,1)_U ;VENDOR "RTN","PRCHLO6",49,0) S PRCDT=PRCDT_$P(PRCND,U,2)_U ;VENDOR ADDRESS1 "RTN","PRCHLO6",50,0) S PRCDT=PRCDT_$P(PRCND,U,3)_U ;VENDOR ADDRESS2 "RTN","PRCHLO6",51,0) S PRCDT=PRCDT_$P(PRCND,U,4)_U ;VENDOR ADDRESS3 "RTN","PRCHLO6",52,0) S PRCDT=PRCDT_$P(PRCND,U,5)_U ;VENDOR ADDRESS4 "RTN","PRCHLO6",53,0) S PRCDT=PRCDT_$P(PRCND,U,6)_U ;VENDOR CITY "RTN","PRCHLO6",54,0) S X=$P(PRCND,U,7),PRCDT=PRCDT_$S(X>0:$$GET1^DIQ(5,X_",",1),1:"")_U ;VENDOR STATE "RTN","PRCHLO6",55,0) S PRCDT=PRCDT_$P(PRCND,U,8)_U ;VENDOR ZIP CODE "RTN","PRCHLO6",56,0) S PRCDT=PRCDT_$P(PRCND,U,9)_U ;VENDOR CONTACT "RTN","PRCHLO6",57,0) S PRCDT=PRCDT_$P(PRCND,U,10)_U ;VENDOR PHONE NO. "RTN","PRCHLO6",58,0) S PRCND=$G(^PRCS(410,PRCIEN,3)) ;NODE 3 "RTN","PRCHLO6",59,0) S PRCTMP=$P(PRCND,U,4) "RTN","PRCHLO6",60,0) S PRCDT=PRCDT_PRCTMP_U,PRCTMP=+PRCTMP ;VENDOR IEN "RTN","PRCHLO6",61,0) S PRCTMB=$P($G(^PRC(440,PRCTMP,0)),U,1) ; "RTN","PRCHLO6",62,0) S PRCDT=PRCDT_PRCTMB_U ;VENDOR NAME "RTN","PRCHLO6",63,0) S PRCTMB=$P($G(^PRC(440,PRCTMP,3)),U,4) ; "RTN","PRCHLO6",64,0) S PRCDT=PRCDT_PRCTMB_U ;VENDOR FMS CODE "RTN","PRCHLO6",65,0) S PRCTMB=$P($G(^PRC(440,PRCTMP,3)),U,5) "RTN","PRCHLO6",66,0) S PRCDT=PRCDT_PRCTMB_U ;VENDOR ALT-ADDR-IND "RTN","PRCHLO6",67,0) S PRCTMB=$P($G(^PRC(440,PRCTMP,7)),U,12) "RTN","PRCHLO6",68,0) S PRCDT=PRCDT_PRCTMB_U ;VENDOR D & B "RTN","PRCHLO6",69,0) S PRCDT=PRCDT_$P(PRCND,U,10)_U ;VENDOR CONTRACT NUMBER "RTN","PRCHLO6",70,0) S PRCDT=PRCDT_$P(PRCND,U,1)_U ;CONTROL POINT "RTN","PRCHLO6",71,0) S PRCDT=PRCDT_$P(PRCND,U,3)_U ;COST CENTER "RTN","PRCHLO6",72,0) S PRCDT=PRCDT_$P(PRCND,U,6)_U ;BOC1 "RTN","PRCHLO6",73,0) S PRCDT=PRCDT_$P(PRCND,U,7)_U ;BOC1 $ AMOUNT "RTN","PRCHLO6",74,0) S PRCDT=PRCDT_$P(PRCND,U,2)_U ;ACCOUNTING DATA "RTN","PRCHLO6",75,0) S PRCDT=PRCDT_$P(PRCND,U,12)_U ;FCP/PRJ "RTN","PRCHLO6",76,0) S X=$P(PRCND,U,11),PRCDT=PRCDT_$S(X>0:$E(X+17000000,1,4),1:"")_U ;BBFY "RTN","PRCHLO6",77,0) S PRCND=$G(^PRCS(410,PRCIEN,4)) ;NODE 4 "RTN","PRCHLO6",78,0) S PRCDT=PRCDT_$P(PRCND,U,1)_U ;COMMITTED (EST.) COST "RTN","PRCHLO6",79,0) S X=$P(PRCND,U,2),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE COMMITTED "RTN","PRCHLO6",80,0) S PRCDT=PRCDT_$P(PRCND,U,3)_U ;OBLIGATED ACTUAL COST "RTN","PRCHLO6",81,0) S X=$P(PRCND,U,4),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE OBLIGATED "RTN","PRCHLO6",82,0) S PRCDT=PRCDT_$P(PRCND,U,5)_U ;PO / OBLIGATION NO "RTN","PRCHLO6",83,0) S PRCDT=PRCDT_$P(PRCND,U,6)_U ;ADJUSTMENT AMOUNT "RTN","PRCHLO6",84,0) S X=$P(PRCND,U,7),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE OBL ADJUSTED "RTN","PRCHLO6",85,0) S PRCDT=PRCDT_$P(PRCND,U,8)_U ;TRANSACTION AMOUNT "RTN","PRCHLO6",86,0) S PRCDUZ=$P(PRCND,U,9),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U) "RTN","PRCHLO6",87,0) S PRCDT=PRCDT_PRCDUZ_U ;OBLIGATED BY DUZ "RTN","PRCHLO6",88,0) S PRCDT=PRCDT_PRCTMP_U ;OBLIGATED BY NAME "RTN","PRCHLO6",89,0) S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U) "RTN","PRCHLO6",90,0) S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01)) "RTN","PRCHLO6",91,0) S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;OBLIGATED SERVICE INT/EXT "RTN","PRCHLO6",92,0) S X=$P(PRCND,U,13),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;OBL VAL CODE DATE/TIME "RTN","PRCHLO6",93,0) S PRCND=$G(^PRCS(410,PRCIEN,7)) ;NODE 7 "RTN","PRCHLO6",94,0) S PRCDUZ=$P(PRCND,U,1),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U) "RTN","PRCHLO6",95,0) S PRCDT=PRCDT_PRCDUZ_U ;REQUESTOR DUZ "RTN","PRCHLO6",96,0) S PRCDT=PRCDT_PRCTMP_U ;REQUESTOR NAME "RTN","PRCHLO6",97,0) S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U) "RTN","PRCHLO6",98,0) S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01)) "RTN","PRCHLO6",99,0) S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;REQUESTOR SERVICE INT/EXT "RTN","PRCHLO6",100,0) S PRCDT=PRCDT_$P(PRCND,U,2)_U ;REQUESTOR'S TITLE "RTN","PRCHLO6",101,0) S PRCDUZ=$P(PRCND,U,3),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U) "RTN","PRCHLO6",102,0) S PRCDT=PRCDT_PRCDUZ_U ;APPROVING OFFICIAL DUZ "RTN","PRCHLO6",103,0) S PRCDT=PRCDT_PRCTMP_U ;APPROVING OFFICIAL NAME "RTN","PRCHLO6",104,0) S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U) "RTN","PRCHLO6",105,0) S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01)) "RTN","PRCHLO6",106,0) S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;APPROVING OFFICIAL SERVICE INT/EXT "RTN","PRCHLO6",107,0) S PRCDT=PRCDT_$P(PRCND,U,4)_U ;APPROVING OFFICIAL TITLE "RTN","PRCHLO6",108,0) S X=$P(PRCND,U,5),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE SIGNED (APPROVED) "RTN","PRCHLO6",109,0) S X=$P(PRCND,U,7),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;ES CODE DATE/TIME "RTN","PRCHLO6",110,0) S ^TMP($J,"CONTRP",PRCIEN,1)=PRCDT,PRCDT="" "RTN","PRCHLO6",111,0) S PRCTMB=8 D WORDFLD ;NODE 8 "RTN","PRCHLO6",112,0) S PRCDT=PRCDT_PRCTMP_U ;JUSTIFICATION "RTN","PRCHLO6",113,0) S ^TMP($J,"CONTRP",PRCIEN,2)=PRCDT,PRCDT="" "RTN","PRCHLO6",114,0) S PRCND=$G(^PRCS(410,PRCIEN,11)) ;NODE 11 "RTN","PRCHLO6",115,0) S PRCTMP=$P(PRCND,U) I PRCTMP'="" D "RTN","PRCHLO6",116,0) . S PRCTMB=$P(PRCTMP,";",2),PRCTMP=$P(PRCTMP,";") "RTN","PRCHLO6",117,0) . S PRCTMP=$P($G(@("^"_PRCTMB_+PRCTMP_",0)")),U) "RTN","PRCHLO6",118,0) S PRCDT=PRCDT_PRCTMP_U ;SORT GROUP EXTERNAL "RTN","PRCHLO6",119,0) S PRCND=$G(^PRCS(410,PRCIEN,10)) ;NODE 10 "RTN","PRCHLO6",120,0) S PRCTMP=$P(PRCND,U,3),PRCTMB=$P($G(^PRC(442,+PRCTMP,0)),U) "RTN","PRCHLO6",121,0) S PRCDT=PRCDT_PRCTMP_U ;STATION NO - P.O.NO IEN "RTN","PRCHLO6",122,0) S PRCDT=PRCDT_PRCTMB_U ;STATION NO - P.O.NO EXT "RTN","PRCHLO6",123,0) S PRCDT=PRCDT_$$PODATE(PRCTMP)_U ;PO DATE "RTN","PRCHLO6",124,0) S D0=PRCIEN D STATUS^PRCSES "RTN","PRCHLO6",125,0) S PRCDT=PRCDT_X_U ;STATUS "RTN","PRCHLO6",126,0) S PRCTMB="CO" D WORDFLD ;NODE CO "RTN","PRCHLO6",127,0) S PRCDT=PRCDT_PRCTMP_U ;COMMENTS "RTN","PRCHLO6",128,0) S ^TMP($J,"CONTRP",PRCIEN,3)=PRCDT,PRCDT="" "RTN","PRCHLO6",129,0) S PRCTMB=13 D WORDFLD ;NODE 13 "RTN","PRCHLO6",130,0) S PRCDT=PRCDT_PRCTMP ;REASON FOR RETURN "RTN","PRCHLO6",131,0) S ^TMP($J,"CONTRP",PRCIEN,4)=PRCDT "RTN","PRCHLO6",132,0) D GET4104 "RTN","PRCHLO6",133,0) Q "RTN","PRCHLO6",134,0) GET4104 ; GET DATA FROM SUBFILE 410.04 "RTN","PRCHLO6",135,0) N PRCX S PRCX=$P(^PRCS(410,PRCIEN,0),U)_U_PRCIEN_U_$P(^(0),U,5)_U "RTN","PRCHLO6",136,0) 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 "RTN","PRCHLO6",137,0) N PRCTMI "RTN","PRCHLO6",138,0) S PRCTMI=0 F S PRCTMI=$O(^PRCS(410,PRCIEN,12,PRCTMI)) Q:'PRCTMI D "RTN","PRCHLO6",139,0) . S PRCDT=PRCX "RTN","PRCHLO6",140,0) . S PRCND=$G(^PRCS(410,PRCIEN,12,PRCTMI,0)) "RTN","PRCHLO6",141,0) . S PRCDT=PRCDT_$P($G(^PRCS(410.4,+$P(PRCND,U,1),0)),U)_U ;SUB-CONTROL POINT "RTN","PRCHLO6",142,0) . S PRCDT=PRCDT_$P(PRCND,U,2)_U ;AMOUNT "RTN","PRCHLO6",143,0) . S PRCTMB=$$GET1^DIQ(410.04,PRCTMI_","_PRCIEN_",",2) "RTN","PRCHLO6",144,0) . S PRCDT=PRCDT_PRCTMB ;SCP AMOUNT "RTN","PRCHLO6",145,0) . S ^TMP($J,"SUBCP",PRCIEN,PRCTMI)=PRCDT "RTN","PRCHLO6",146,0) Q "RTN","PRCHLO6",147,0) WORDFLD ; PROCESS WORD FIELD "RTN","PRCHLO6",148,0) N PRCTMI,PRCTMJ,PRCTMQ "RTN","PRCHLO6",149,0) S PRCTMI=$P($G(^PRCS(410,PRCIEN,PRCTMB,0)),U,3),PRCTMP="",PRCTMQ=0 "RTN","PRCHLO6",150,0) I PRCTMI D "RTN","PRCHLO6",151,0) . F PRCTMI=1:1:PRCTMI D Q:PRCTMQ "RTN","PRCHLO6",152,0) .. S PRCTMJ=$G(^PRCS(410,PRCIEN,PRCTMB,PRCTMI,0))_" " "RTN","PRCHLO6",153,0) .. I $F(PRCTMJ,"^") S PRCTMJ=$TR(PRCTMJ,"^","*") ;CONVERT ^ TO * "RTN","PRCHLO6",154,0) .. 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 "RTN","PRCHLO6",155,0) .. S PRCTMP=PRCTMP_PRCTMJ "RTN","PRCHLO6",156,0) Q "RTN","PRCHLO6",157,0) ; "RTN","PRCHLO6",158,0) GET424 ; "RTN","PRCHLO6",159,0) S U="^" "RTN","PRCHLO6",160,0) N PRCND,PRCIEN,PRCDT,PRCTMP,PRCTMB,PRCC,X "RTN","PRCHLO6",161,0) ; loop through file 424, "C" Cross Reference "RTN","PRCHLO6",162,0) S PRCC=0 "RTN","PRCHLO6",163,0) F S PRCC=$O(^PRC(424,"C",PRCC)) Q:'PRCC D "RTN","PRCHLO6",164,0) . I $D(^TMP($J,"POMAST",PRCC)) D DAT424 "RTN","PRCHLO6",165,0) D GET4241 "RTN","PRCHLO6",166,0) Q "RTN","PRCHLO6",167,0) DAT424 ; "RTN","PRCHLO6",168,0) N PRCPOID "RTN","PRCHLO6",169,0) S PRCIEN=0 "RTN","PRCHLO6",170,0) F S PRCIEN=$O(^PRC(424,"C",PRCC,PRCIEN)) Q:'PRCIEN D "RTN","PRCHLO6",171,0) . S PRCDT="" "RTN","PRCHLO6",172,0) . S PRCND=$G(^PRC(424,PRCIEN,0)) ;NODE 0 "RTN","PRCHLO6",173,0) . S (PRCPOID,X,Y)=$P(PRCND,U,2),PRCDT=PRCDT_X_U ;OBLIGATION INT "RTN","PRCHLO6",174,0) . S X=$S(X>0:$P($G(^PRC(442,X,0)),U),1:""),PRCDT=PRCDT_X_U ; OBL EXT "RTN","PRCHLO6",175,0) . S PRCDT=PRCDT_$$PODATE(PRCPOID)_U ;PO DATE "RTN","PRCHLO6",176,0) . S PRCDT=PRCDT_MNTHYR_U ;Month,Year of extract "RTN","PRCHLO6",177,0) . S PRCDT=PRCDT_$P(X,"-")_U ;STATION # "RTN","PRCHLO6",178,0) . S PRCDT=PRCDT_$P(PRCND,U,1)_U ;AUTHORIZATION # "RTN","PRCHLO6",179,0) . S PRCDT=PRCDT_$$GET1^DIQ(424,PRCIEN_",",.03)_U ;TRANSACTION TYPE "RTN","PRCHLO6",180,0) . S PRCDT=PRCDT_$P(PRCND,U,4)_U ;LIQUIDATION AMOUNT "RTN","PRCHLO6",181,0) . S PRCDT=PRCDT_$P(PRCND,U,5)_U ;AUTHORIZATION BALANCE "RTN","PRCHLO6",182,0) . S PRCDT=PRCDT_$P(PRCND,U,6)_U ;OBLIGATION AMOUNT "RTN","PRCHLO6",183,0) . S X=$P(PRCND,U,7),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE/TIME "RTN","PRCHLO6",184,0) . S PRCDUZ=$P(PRCND,U,8),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U) "RTN","PRCHLO6",185,0) . S PRCDT=PRCDT_PRCDUZ_U ;USER DUZ "RTN","PRCHLO6",186,0) . S PRCDT=PRCDT_PRCTMP_U ;USER NAME "RTN","PRCHLO6",187,0) . S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U) "RTN","PRCHLO6",188,0) . S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01)) "RTN","PRCHLO6",189,0) . S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;USER SERVICE INT/EXT "RTN","PRCHLO6",190,0) . S PRCDT=PRCDT_$$GET1^DIQ(424,PRCIEN_",",.09)_U ;COMPLETED FLAG "RTN","PRCHLO6",191,0) . S PRCDT=PRCDT_$P(PRCND,U,10)_U ;REFERENCE "RTN","PRCHLO6",192,0) . S PRCDT=PRCDT_$P(PRCND,U,11)_U ;LAST SEQUENCE USED "RTN","PRCHLO6",193,0) . S PRCDT=PRCDT_$P(PRCND,U,12)_U ;AUTHORIZATION AMOUNT "RTN","PRCHLO6",194,0) . S PRCDT=PRCDT_$P(PRCND,U,13)_U ;ORIGINAL AUTH. AMOUNT "RTN","PRCHLO6",195,0) . S PRCDUZ=$P(PRCND,U,14),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U) "RTN","PRCHLO6",196,0) . S PRCDT=PRCDT_PRCDUZ_U ;LAST EDITED BY DUZ "RTN","PRCHLO6",197,0) . S PRCDT=PRCDT_PRCTMP_U ;LAST EDITED BY NAME "RTN","PRCHLO6",198,0) . S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U) "RTN","PRCHLO6",199,0) . S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01)) "RTN","PRCHLO6",200,0) . S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;LAST EDITED BY SERVICE INT/EXT "RTN","PRCHLO6",201,0) . S PRCTMP=$P(PRCND,U,15),PRCTMP=$P($G(^PRCS(410,+PRCTMP,0)),U) "RTN","PRCHLO6",202,0) . S PRCDT=PRCDT_$P(PRCND,U,15)_U ;CPA POINTER IEN "RTN","PRCHLO6",203,0) . S PRCDT=PRCDT_PRCTMP_U ;CPA POINTER EXT "RTN","PRCHLO6",204,0) . S PRCND=$G(^PRC(424,PRCIEN,1)) ;NODE 1 "RTN","PRCHLO6",205,0) . S PRCDT=PRCDT_$P(PRCND,U,1)_U ;COMMENTS "RTN","PRCHLO6",206,0) . S PRCND=$G(^PRC(424,PRCIEN,2)) ;NODE 2 "RTN","PRCHLO6",207,0) . S PRCDT=PRCDT_$P(PRCND,U,2) ;INTERFACE ID "RTN","PRCHLO6",208,0) . S ^TMP($J,"DR1358",PRCIEN,1)=PRCDT "RTN","PRCHLO6",209,0) Q "RTN","PRCHLO6",210,0) GET4241 ; "RTN","PRCHLO6",211,0) ; loop through file 424.1 "RTN","PRCHLO6",212,0) S PRCC=0 "RTN","PRCHLO6",213,0) F S PRCC=$O(^PRC(424.1,"C",PRCC)) Q:'PRCC D "RTN","PRCHLO6",214,0) . I $D(^TMP($J,"DR1358",PRCC)) D DAT4241 "RTN","PRCHLO6",215,0) Q "RTN","PRCHLO6",216,0) DAT4241 ; "RTN","PRCHLO6",217,0) N Y,PRCSTN "RTN","PRCHLO6",218,0) S PRCIEN=0 F S PRCIEN=$O(^PRC(424.1,"C",PRCC,PRCIEN)) Q:'PRCIEN D "RTN","PRCHLO6",219,0) . S PRCDT="" "RTN","PRCHLO6",220,0) . S PRCND=$G(^PRC(424.1,PRCIEN,0)) ;NODE 0 "RTN","PRCHLO6",221,0) . S X=$P(PRCND,U,2) "RTN","PRCHLO6",222,0) . S (X,PRCPOID)=$P($G(^PRC(424,+X,0)),U,2),PRCDT=PRCDT_X_U ;PO# INT "RTN","PRCHLO6",223,0) . S X=$S(X>0:$P($G(^PRC(442,X,0)),U),1:""),PRCDT=PRCDT_X_U ;PO# EXT "RTN","PRCHLO6",224,0) . S PRCSTN=$P(X,"-") S:PRCPOID="" PRCPOID=PRCIEN "RTN","PRCHLO6",225,0) . S PRCDT=PRCDT_$$PODATE(PRCPOID)_U ;PO DATE "RTN","PRCHLO6",226,0) . S PRCDT=PRCDT_MNTHYR_U ;Month,Year of extract "RTN","PRCHLO6",227,0) . S PRCDT=PRCDT_PRCSTN_U ;STATION "RTN","PRCHLO6",228,0) . S PRCDT=PRCDT_$P(PRCND,U,1)_U ;BILL NUMBER "RTN","PRCHLO6",229,0) . S PRCDT=PRCDT_$$GET1^DIQ(424.1,PRCIEN_",",.011)_U ;RECORD TYPE "RTN","PRCHLO6",230,0) . S PRCTMP=$P(PRCND,U,2),PRCTMP=$P($G(^PRC(424,+PRCTMP,0)),U) "RTN","PRCHLO6",231,0) . S PRCDT=PRCDT_$P(PRCND,U,2)_U ;AUTH. POINTER IEN "RTN","PRCHLO6",232,0) . S PRCDT=PRCDT_PRCTMP_U ;AUTH. POINTER EXT "RTN","PRCHLO6",233,0) . S PRCDT=PRCDT_$P(PRCND,U,3)_U ;AUTH. AMOUNT "RTN","PRCHLO6",234,0) . S X=$P(PRCND,U,4),PRCDT=PRCDT_$S(X>0:$$FMTE^XLFDT($P(X,".")),1:"")_U ;DATE/TIME "RTN","PRCHLO6",235,0) . S PRCDUZ=$P(PRCND,U,5),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U) "RTN","PRCHLO6",236,0) . S PRCDT=PRCDT_PRCDUZ_U ;USER DUZ "RTN","PRCHLO6",237,0) . S PRCDT=PRCDT_PRCTMP_U ;USER NAME "RTN","PRCHLO6",238,0) . S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U) "RTN","PRCHLO6",239,0) . S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01)) "RTN","PRCHLO6",240,0) . S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;USER SERVICE INT/EXT "RTN","PRCHLO6",241,0) . S PRCDT=PRCDT_$P(PRCND,U,6)_U ;VENDOR INVOICE NUMBER "RTN","PRCHLO6",242,0) . S PRCDT=PRCDT_$$GET1^DIQ(424.1,PRCIEN_",",.07)_U ;FINAL BILL "RTN","PRCHLO6",243,0) . S PRCDT=PRCDT_$P(PRCND,U,8)_U ;REFERENCE "RTN","PRCHLO6",244,0) . S PRCDUZ=$P(PRCND,U,10),PRCTMP=$P($G(^VA(200,+PRCDUZ,0)),U) "RTN","PRCHLO6",245,0) . S PRCDT=PRCDT_PRCDUZ_U ;LAST EDITED BY DUZ "RTN","PRCHLO6",246,0) . S PRCDT=PRCDT_PRCTMP_U ;LAST EDITED BY NAME "RTN","PRCHLO6",247,0) . S PRCDUZ=$P($G(^VA(200,+PRCDUZ,5)),U) "RTN","PRCHLO6",248,0) . S PRCTMP=$S(PRCDUZ="":"",1:$$GET1^DIQ(49,+PRCDUZ_",",.01)) "RTN","PRCHLO6",249,0) . S PRCDT=PRCDT_PRCDUZ_U_PRCTMP_U ;LAST EDITED BY SERVICE INT/EXT "RTN","PRCHLO6",250,0) . S PRCND=$G(^PRC(424.1,PRCIEN,1)) ;NODE 1 "RTN","PRCHLO6",251,0) . S PRCDT=PRCDT_$P(PRCND,U,1) ;DESCRIPTION "RTN","PRCHLO6",252,0) . S ^TMP($J,"AD1358",PRCIEN,1)=PRCDT "RTN","PRCHLO6",253,0) Q "RTN","PRCHLO6",254,0) PODATE(PRCPOIEN) ;input PO's ien, output external form PO Date "RTN","PRCHLO6",255,0) N X "RTN","PRCHLO6",256,0) S X=$S(PRCPOIEN>0:$P($G(^PRC(442,PRCPOIEN,1)),U,15),1:"") "RTN","PRCHLO6",257,0) S:X'="" X=$$FMTE^XLFDT(X,"D") "RTN","PRCHLO6",258,0) Q X "VER") 8.0^22.0 "BLD",6035,6) ^119 **END** **END**