Released PRC*5.1*158 SEQ #134 Extracted from mail message **KIDS**:PRC*5.1*158^ **INSTALL NAME** PRC*5.1*158 "BLD",6649,0) PRC*5.1*158^IFCAP^0^3110705^y "BLD",6649,1,0) ^^2^2^3110602^ "BLD",6649,1,1,0) This patch modifies IFCAP to remove the reference "Miscellaneous" or "BLD",6649,1,2,0) "MISC." from 1358 Obligations. "BLD",6649,4,0) ^9.64PA^410^1 "BLD",6649,4,410,0) 410 "BLD",6649,4,410,2,0) ^9.641^410^1 "BLD",6649,4,410,2,410,0) CONTROL POINT ACTIVITY (File-top level) "BLD",6649,4,410,2,410,1,0) ^9.6411^34^2 "BLD",6649,4,410,2,410,1,33,0) END DATE FOR 1358 "BLD",6649,4,410,2,410,1,34,0) AUTO ACCURE "BLD",6649,4,410,222) y^n^p^^^^n^^n "BLD",6649,4,410,224) "BLD",6649,4,"APDD",410,410) "BLD",6649,4,"APDD",410,410,33) "BLD",6649,4,"APDD",410,410,34) "BLD",6649,4,"B",410,410) "BLD",6649,6.3) 1 "BLD",6649,"ABPKG") n "BLD",6649,"INID") ^y "BLD",6649,"INIT") POST^PRC51158 "BLD",6649,"KRN",0) ^9.67PA^779.2^20 "BLD",6649,"KRN",.4,0) .4 "BLD",6649,"KRN",.4,"NM",0) ^9.68A^1^1 "BLD",6649,"KRN",.4,"NM",1,0) PRCS1358 FORM PRINT FILE #442^442^1^ "BLD",6649,"KRN",.4,"NM","B","PRCS1358 FORM PRINT FILE #442",1) "BLD",6649,"KRN",.401,0) .401 "BLD",6649,"KRN",.401,"NM",0) ^9.68A^2^2 "BLD",6649,"KRN",.401,"NM",1,0) PRCH OBLIGATED 1358 LIST FILE #442^442^0 "BLD",6649,"KRN",.401,"NM",2,0) PRCFA 1358 EOM REPORT FILE #442^442^0 "BLD",6649,"KRN",.401,"NM","B","PRCFA 1358 EOM REPORT FILE #442",2) "BLD",6649,"KRN",.401,"NM","B","PRCH OBLIGATED 1358 LIST FILE #442",1) "BLD",6649,"KRN",.402,0) .402 "BLD",6649,"KRN",.403,0) .403 "BLD",6649,"KRN",.5,0) .5 "BLD",6649,"KRN",.84,0) .84 "BLD",6649,"KRN",3.6,0) 3.6 "BLD",6649,"KRN",3.8,0) 3.8 "BLD",6649,"KRN",9.2,0) 9.2 "BLD",6649,"KRN",9.8,0) 9.8 "BLD",6649,"KRN",9.8,"NM",0) ^9.68A^11^11 "BLD",6649,"KRN",9.8,"NM",1,0) PRCE58P0^^0^B17204092 "BLD",6649,"KRN",9.8,"NM",2,0) PRCE58P2^^0^B16749881 "BLD",6649,"KRN",9.8,"NM",3,0) PRCEMOA^^0^B39455655 "BLD",6649,"KRN",9.8,"NM",4,0) PRCE58P1^^0^B16647166 "BLD",6649,"KRN",9.8,"NM",5,0) PRCSP11^^0^B15814288 "BLD",6649,"KRN",9.8,"NM",6,0) PRCE58P3^^0^B17424731 "BLD",6649,"KRN",9.8,"NM",7,0) PRCFFU13^^0^B15091179 "BLD",6649,"KRN",9.8,"NM",8,0) PRCFFERU^^0^B9629227 "BLD",6649,"KRN",9.8,"NM",9,0) PRCFFERM^^0^B5398839 "BLD",6649,"KRN",9.8,"NM",10,0) PRCFDPV1^^0^B6007702 "BLD",6649,"KRN",9.8,"NM",11,0) PRCFDPV2^^0^B7956553 "BLD",6649,"KRN",9.8,"NM","B","PRCE58P0",1) "BLD",6649,"KRN",9.8,"NM","B","PRCE58P1",4) "BLD",6649,"KRN",9.8,"NM","B","PRCE58P2",2) "BLD",6649,"KRN",9.8,"NM","B","PRCE58P3",6) "BLD",6649,"KRN",9.8,"NM","B","PRCEMOA",3) "BLD",6649,"KRN",9.8,"NM","B","PRCFDPV1",10) "BLD",6649,"KRN",9.8,"NM","B","PRCFDPV2",11) "BLD",6649,"KRN",9.8,"NM","B","PRCFFERM",9) "BLD",6649,"KRN",9.8,"NM","B","PRCFFERU",8) "BLD",6649,"KRN",9.8,"NM","B","PRCFFU13",7) "BLD",6649,"KRN",9.8,"NM","B","PRCSP11",5) "BLD",6649,"KRN",19,0) 19 "BLD",6649,"KRN",19,"NM",0) ^9.68A^^ "BLD",6649,"KRN",19.1,0) 19.1 "BLD",6649,"KRN",101,0) 101 "BLD",6649,"KRN",409.61,0) 409.61 "BLD",6649,"KRN",771,0) 771 "BLD",6649,"KRN",779.2,0) 779.2 "BLD",6649,"KRN",870,0) 870 "BLD",6649,"KRN",8989.51,0) 8989.51 "BLD",6649,"KRN",8989.52,0) 8989.52 "BLD",6649,"KRN",8994,0) 8994 "BLD",6649,"KRN","B",.4,.4) "BLD",6649,"KRN","B",.401,.401) "BLD",6649,"KRN","B",.402,.402) "BLD",6649,"KRN","B",.403,.403) "BLD",6649,"KRN","B",.5,.5) "BLD",6649,"KRN","B",.84,.84) "BLD",6649,"KRN","B",3.6,3.6) "BLD",6649,"KRN","B",3.8,3.8) "BLD",6649,"KRN","B",9.2,9.2) "BLD",6649,"KRN","B",9.8,9.8) "BLD",6649,"KRN","B",19,19) "BLD",6649,"KRN","B",19.1,19.1) "BLD",6649,"KRN","B",101,101) "BLD",6649,"KRN","B",409.61,409.61) "BLD",6649,"KRN","B",771,771) "BLD",6649,"KRN","B",779.2,779.2) "BLD",6649,"KRN","B",870,870) "BLD",6649,"KRN","B",8989.51,8989.51) "BLD",6649,"KRN","B",8989.52,8989.52) "BLD",6649,"KRN","B",8994,8994) "BLD",6649,"QUES",0) ^9.62^^ "BLD",6649,"REQB",0) ^9.611^2^2 "BLD",6649,"REQB",1,0) PRC*5.1*148^1 "BLD",6649,"REQB",2,0) PRC*5.1*152^1 "BLD",6649,"REQB","B","PRC*5.1*148",1) "BLD",6649,"REQB","B","PRC*5.1*152",2) "FIA",410) CONTROL POINT ACTIVITY "FIA",410,0) ^PRCS(410, "FIA",410,0,0) 410I "FIA",410,0,1) y^n^p^^^^n^^n "FIA",410,0,10) "FIA",410,0,11) "FIA",410,0,"RLRO") "FIA",410,0,"VR") 5.1^PRC "FIA",410,410) 1 "FIA",410,410,33) "FIA",410,410,34) "INIT") POST^PRC51158 "KRN",.4,2828,-1) 1^1 "KRN",.4,2828,0) PRCS1358 FORM PRINT FILE #442 "KRN",.401,1800,-1) 0^2 "KRN",.401,1800,0) PRCFA 1358 EOM REPORT^3110621.1552^^442^^^3110621 "KRN",.401,1800,2,0) ^.4014^6^6 "KRN",.401,1800,2,1,0) 442^^METHOD OF PROCESSING["1358 OBLIGATION"^'"@B^;L1^^^^^4 "KRN",.401,1800,2,1,"CM") S Y(1)=$S($D(^PRC(442,D0,0)):^(0),1:"") S X=$P($G(^PRCD(442.5,+$P(Y(1),U,2),0)),U)["1358 OBLIGATION" I D0>0 S DISX(1)=X "KRN",.401,1800,2,1,"F") 0 "KRN",.401,1800,2,1,"GET") S Y(1)=$S($D(^PRC(442,D0,0)):^(0),1:"") S X=$P($G(^PRCD(442.5,+$P(Y(1),U,2),0)),U)["1358 OBLIGATION" I D0>0 S DISX(1)=X "KRN",.401,1800,2,1,"QCON") I DISX(1) "KRN",.401,1800,2,1,"T") 1 "KRN",.401,1800,2,1,"TXT") METHOD OF PROCESSING[""1358 OBLIGATION"" "KRN",.401,1800,2,2,0) 442^^$E(PURCHASE ORDER NUMBER,1,3)^@#"^^^^^^4 "KRN",.401,1800,2,2,"CM") S Y(1)=$S($D(^PRC(442,D0,0)):^(0),1:"") S X=$P(Y(1),U,1),Y(2)=$G(X) S X=1,Y(3)=$G(X) S X=3,X=$E(Y(2),Y(3),X) I D0>0 S DISX(2)=X "KRN",.401,1800,2,2,"GET") S Y(1)=$S($D(^PRC(442,D0,0)):^(0),1:"") S X=$P(Y(1),U,1),Y(2)=$G(X) S X=1,Y(3)=$G(X) S X=3,X=$E(Y(2),Y(3),X) I D0>0 S DISX(2)=X "KRN",.401,1800,2,2,"QCON") I DISX(2)'="" "KRN",.401,1800,2,2,"TXT") $E(PURCHASE ORDER NUMBER,1,3) not null "KRN",.401,1800,2,3,0) 442^1.4^APPROPRIATION^^;S3^^^^^4 "KRN",.401,1800,2,3,"GET") S DISX(3)=$P($G(^PRC(442,D0,0)),U,4) "KRN",.401,1800,2,3,"QCON") I DISX(3)'="" "KRN",.401,1800,2,3,"SER") 0.1881^0.1881 "KRN",.401,1800,2,3,"TXT") APPROPRIATION not null "KRN",.401,1800,2,4,0) 442^^$E(1ST(OBLIGATION DATA:TT/DATE/REF),1,6)^@"^^^^^^4 "KRN",.401,1800,2,4,3,0) ^.401419^3^3 "KRN",.401,1800,2,4,3,1,0) OVF0^9.2 "KRN",.401,1800,2,4,3,1,"OVF0") N Y S Y(1)=$S($D(^PRC(442,D0,"10",D1,0)):^(0),1:"") S X=$P(Y(1),U,1) "KRN",.401,1800,2,4,3,2,0) OVF0^9.3 "KRN",.401,1800,2,4,3,2,"OVF0") F D=0:0 S (D,D1)=$O(^PRC(442,D0,10,D)) Q:D'>0 I $D(^(D,0))#2 S X=$P(^(0),U) X DPP(4,"OVF0",9.2) S Y=X S:Y'?." " Y(2)=Y(2)+1 I Y(2)=1,Y'?." " S Y(1)=Y Q Q:'$D(D) S D=D1 "KRN",.401,1800,2,4,3,3,0) OVF0^9.4 "KRN",.401,1800,2,4,3,3,"OVF0") S I(1,0)=$G(D1) X DPP(4,"OVF0",9.3):D0>0 S X="" S D1=I(1,0) "KRN",.401,1800,2,4,3,"B","OVF0",1) "KRN",.401,1800,2,4,3,"B","OVF0",2) "KRN",.401,1800,2,4,3,"B","OVF0",3) "KRN",.401,1800,2,4,"CM") S Y(2)=0 S Y(1)="" X DPP(4,"OVF0",9.4) S X=Y(1),Y(3)=$G(X) S X=1,Y(4)=$G(X) S X=6,X=$E(Y(3),Y(4),X) I D0>0 S DISX(4)=X "KRN",.401,1800,2,4,"GET") S Y(2)=0 S Y(1)="" X DPP(4,"OVF0",9.4) S X=Y(1),Y(3)=$G(X) S X=1,Y(4)=$G(X) S X=6,X=$E(Y(3),Y(4),X) I D0>0 S DISX(4)=X "KRN",.401,1800,2,4,"QCON") I DISX(4)'="" "KRN",.401,1800,2,4,"TXT") $E(1ST(OBLIGATION DATA:TT/DATE/REF),1,6) not null "KRN",.401,1800,2,5,0) 442^.01^PURCHASE ORDER NUMBER^^^^^^^4 "KRN",.401,1800,2,5,"GET") S DISX(5)=$P($G(^PRC(442,D0,0)),U) "KRN",.401,1800,2,5,"IX") ^PRC(442,"B",^PRC(442,^2 "KRN",.401,1800,2,5,"QCON") I DISX(5)'="" "KRN",.401,1800,2,5,"SER") 0^0 "KRN",.401,1800,2,5,"TXT") PURCHASE ORDER NUMBER not null "KRN",.401,1800,2,6,0) 442^^FISCAL 1358 BALANCE'=0^"@B^;L1^^^^^4 "KRN",.401,1800,2,6,"CM") S Y(1)=$S($D(^PRC(442,D0,8)):^(8),1:"") S X=$P(Y(1),U,2)'=0 I D0>0 S DISX(6)=X "KRN",.401,1800,2,6,"F") 0 "KRN",.401,1800,2,6,"GET") S Y(1)=$S($D(^PRC(442,D0,8)):^(8),1:"") S X=$P(Y(1),U,2)'=0 I D0>0 S DISX(6)=X "KRN",.401,1800,2,6,"QCON") I DISX(6) "KRN",.401,1800,2,6,"T") 1 "KRN",.401,1800,2,6,"TXT") FISCAL 1358 BALANCE'=0 "KRN",.401,1800,2,"B",442,1) "KRN",.401,1800,2,"B",442,2) "KRN",.401,1800,2,"B",442,3) "KRN",.401,1800,2,"B",442,4) "KRN",.401,1800,2,"B",442,5) "KRN",.401,1800,2,"B",442,6) "KRN",.401,1919,-1) 0^1 "KRN",.401,1919,0) PRCH OBLIGATED 1358 LIST^3110614.1536^@^442^^@^3110630 "KRN",.401,1919,2,0) ^.4014^3^3 "KRN",.401,1919,2,1,0) 442^.1^P.O. DATE^@^^^^^^1 "KRN",.401,1919,2,1,"ASK") 1 "KRN",.401,1919,2,1,"F") 3110614.999999^061511^Jun 15,2011 "KRN",.401,1919,2,1,"GET") S DISX(1)=$P($G(^PRC(442,D0,1)),U,15) "KRN",.401,1919,2,1,"IX") ^PRC(442,"AB",^PRC(442,^2 "KRN",.401,1919,2,1,"QCON") I (DISX(1)]]3110614.999999)&(DISX(1)']]3110620.24) "KRN",.401,1919,2,1,"SER") 32.6667^0.9703 "KRN",.401,1919,2,1,"T") 3110620.24^062011@2400^Jun 20,2011@24:00 "KRN",.401,1919,2,1,"TXT") P.O. DATE from Jun 15,2011 to Jun 20,2011@24:00 "KRN",.401,1919,2,2,0) 442^.01^PURCHASE ORDER NUMBER^@^^^^^^4 "KRN",.401,1919,2,2,"GET") S DISX(2)=$P($G(^PRC(442,D0,0)),U) "KRN",.401,1919,2,2,"IX") ^PRC(442,"B",^PRC(442,^2 "KRN",.401,1919,2,2,"QCON") I DISX(2)'="" "KRN",.401,1919,2,2,"SER") 0^0 "KRN",.401,1919,2,2,"TXT") PURCHASE ORDER NUMBER not null "KRN",.401,1919,2,3,0) 442^^METHOD OF PROCESSING^@".02^^^^^^4 "KRN",.401,1919,2,3,"CM") S Y(1)=$S($D(^PRC(442,D0,0)):^(0),1:"") S X=$P($G(^PRCD(442.5,+$P(Y(1),U,2),0)),U) I D0>0 S DISX(3)=X "KRN",.401,1919,2,3,"F") 1358 OBLIGATIOMz^1358 OBLIGATION "KRN",.401,1919,2,3,"GET") S Y(1)=$S($D(^PRC(442,D0,0)):^(0),1:"") S X=$P($G(^PRCD(442.5,+$P(Y(1),U,2),0)),U) I D0>0 S DISX(3)=X "KRN",.401,1919,2,3,"IX") ^PRC(442,"F",^PRC(442,^2 "KRN",.401,1919,2,3,"PTRIX") ^PRCD(442.5,"B", "KRN",.401,1919,2,3,"QCON") I DISX(3)="1358 OBLIGATION" "KRN",.401,1919,2,3,"SER") 4.9412^0.8317 "KRN",.401,1919,2,3,"T") 1358 OBLIGATION^1358 OBLIGATION "KRN",.401,1919,2,3,"TXT") METHOD OF PROCESSING equals 1358 OBLIGATION "KRN",.401,1919,2,"B",442,1) "KRN",.401,1919,2,"B",442,2) "KRN",.401,1919,2,"B",442,3) "KRN",.401,1919,"%D",0) ^.4012^9^9^3110614^^^^ "KRN",.401,1919,"%D",1,0) This is a new option to support a new FPDS report for the Austin "KRN",.401,1919,"%D",2,0) Automation Center (AAC). "KRN",.401,1919,"%D",3,0) "KRN",.401,1919,"%D",4,0) This sort template is used to find purchase orders generated from 1358 "KRN",.401,1919,"%D",5,0) obligations with a dollar value of $0 and higher. The resulting list "KRN",.401,1919,"%D",6,0) can include vendors and contract information if they were entered when "KRN",.401,1919,"%D",7,0) the 1358's were created. Users are required to enter a date range for "KRN",.401,1919,"%D",8,0) this option. It is recommended that the printout be done in landscape "KRN",.401,1919,"%D",9,0) mode with a right margin of 132 characters. "MBREQ") 0 "ORD",5,.4) .4;5;;;EDEOUT^DIFROMSO(.4,DA,"",XPDA);FPRE^DIFROMSI(.4,"",XPDA);EPRE^DIFROMSI(.4,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.4,DA,"",XPDA);DEL^DIFROMSK(.4,"",%) "ORD",5,.4,0) PRINT TEMPLATE "ORD",6,.401) .401;6;;;EDEOUT^DIFROMSO(.401,DA,"",XPDA);FPRE^DIFROMSI(.401,"",XPDA);EPRE^DIFROMSI(.401,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.401,DA,"",XPDA);DEL^DIFROMSK(.401,"",%) "ORD",6,.401,0) SORT TEMPLATE "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) 158^3110705 "PKG",455,22,1,"PAH",1,1,0) ^^2^2^3110705 "PKG",455,22,1,"PAH",1,1,1,0) This patch modifies IFCAP to remove the reference "Miscellaneous" or "PKG",455,22,1,"PAH",1,1,2,0) "MISC." from 1358 Obligations. "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") 12 "RTN","PRC51158") 0^^B1290947^n/a "RTN","PRC51158",1,0) PRC51158 ;SSOI&TFO/LKG - POST-INIT PRC*5.1*158 ;6/30/11 16:00 "RTN","PRC51158",2,0) V ;;5.1;IFCAP;**158**;Oct 20, 2000;Build 1 "RTN","PRC51158",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRC51158",4,0) Q "RTN","PRC51158",5,0) POST ;Beginning of post-init logic "RTN","PRC51158",6,0) ;Renaming PAT TYPE entry with IEN of 21 from 'MISC. OBLIGATION (1358)' "RTN","PRC51158",7,0) ; to '1358 OBLIGATION'. "RTN","PRC51158",8,0) N PRCARR,PRCERR,PRCMSG,PRCI "RTN","PRC51158",9,0) S PRCARR(442.5,"21,",.01)="1358 OBLIGATION" "RTN","PRC51158",10,0) D FILE^DIE("EK","PRCARR","PRCERR") "RTN","PRC51158",11,0) I $D(PRCERR("DIERR")) D "RTN","PRC51158",12,0) . D BMES^XPDUTL("PAT TYPE entry with IEN 21 was not renamed to '1358 OBLIGATION'.") "RTN","PRC51158",13,0) . S PRCI=0 "RTN","PRC51158",14,0) . F S PRCI=$O(PRCERR("DIERR",1,"TEXT",PRCI)) Q:PRCI'>0 S PRCMSG(PRCI)=PRCERR("DIERR",1,"TEXT",PRCI) "RTN","PRC51158",15,0) . D:$D(PRCMSG) MES^XPDUTL(.PRCMSG) "RTN","PRC51158",16,0) Q "RTN","PRCE58P0") 0^1^B17204092^B17096977 "RTN","PRCE58P0",1,0) PRCE58P0 ;WISC/SAW/LDB-DISPLAY 1358 FORM CONT. 19-FEB-92 ;6/7/11 16:26 "RTN","PRCE58P0",2,0) V ;;5.1;IFCAP;**148,158**;Oct 20, 2000;Build 1 "RTN","PRCE58P0",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCE58P0",4,0) PRCSD11 ;Entry for print "RTN","PRCE58P0",5,0) U IO W @IOF S U="^",PRCSP=1 D NOW^%DTC S Y=% D DD^%DT W !,$P(TRNODE(0),U),?34,Y,?73,"PAGE ",PRCSP S L="",$P(L,"_",IOM)="_" W !,L "RTN","PRCE58P0",6,0) D NEWP1 W !,"Originator of Request: " I $G(TRNODE(14)),TRNODE(14)'="" W $P($G(^VA(200,+TRNODE(14),0)),"^"),! "RTN","PRCE58P0",7,0) W !,"Requestor:",?34,"|Date Requested:",?62,"|Obligation No.:" "RTN","PRCE58P0",8,0) W ! K P1 I $D(TRNODE(7)) S P1=TRNODE(7) I +P1 S X=$P($G(^VA(200,+P1,0)),U) W X "RTN","PRCE58P0",9,0) W ?34,"|" I $D(TRNODE(1)) S Y=$P(TRNODE(1),U) I Y D DD^%DT W Y "RTN","PRCE58P0",10,0) W ?62,"|" I $D(TRNODE(4)),$P(TRNODE(4),U,5)'="" S PRCSPO=$P(TRNODE(4),U,5) W ?65,PRC("SITE")_"-"_PRCSPO "RTN","PRCE58P0",11,0) W !,L W !,"Vendor:",?34,"|Contract Number:" "RTN","PRCE58P0",12,0) W ! I $D(TRNODE(2)) S X=$P(TRNODE(2),U) I X]"" W $E(X,1,31) "RTN","PRCE58P0",13,0) W ?34,"|" K PRCSG I $D(TRNODE(3)) S PRCSG=TRNODE(3) I $P(PRCSG,U,10)]"" W $P(PRCSG,U,10) "RTN","PRCE58P0",14,0) W !,L W !,"Name and Title Approving Off.:",?41,"|Signature:",?62,"|Date Signed:" "RTN","PRCE58P0",15,0) K P W ! I $D(P1) S P=$P(P1,U,3) S X=$S($D(^VA(200,+P,20)):$P(^(20),U,2),1:"") W $E(X,1,30) "RTN","PRCE58P0",16,0) W ?41,"|" I $D(P),P,$P(P1,U,6)'="" S X=$$DECODE^PRCSC1(DA) W "/ES/"_$E(X,1,23) "RTN","PRCE58P0",17,0) W ?62,"|" I $D(P1) S Y=$S($P(P1,U,7):$P(P1,U,7),1:$P(P1,U,5)) I Y D DD^%DT W Y K Y "RTN","PRCE58P0",18,0) W ! I $D(P1) W $P(P1,U,4) "RTN","PRCE58P0",19,0) W ?41,"|",?62,"|" W !,L W !,"FUND CERTIFICATION: The supplies and services listed on this request are" "RTN","PRCE58P0",20,0) W !,"properly chargeable to the following allotments, the available balances of" "RTN","PRCE58P0",21,0) W !,"which are sufficient to cover the cost thereof, and funds have been obligated." "RTN","PRCE58P0",22,0) W !,L D HOLD G EXIT:Z3=U D NEWP "RTN","PRCE58P0",23,0) W !,"Appropriation & Acct. Symbols:",?41,"|Obligated By: ",?62,"|Date Obligated:" "RTN","PRCE58P0",24,0) TST S DIWL=0,DIWR=80,DIWF="" K ^UTILITY($J) "RTN","PRCE58P0",25,0) I $D(TRNODE(8)) S X1=0 F I=1:1 S X1=$O(TRNODE(8,X1)) Q:X1="" S X=TRNODE(8,X1),PRCSDAA=DA D DIWP^PRCUTL($G(DA)) S DA=PRCSDAA K PRCSDAA "RTN","PRCE58P0",26,0) S P=PRC("SITE") I $D(PRCSG) S:$P(PRCSG,U,2)]"" P=P_"-"_$P(PRCSG,U,2) S P=P_"-"_$P(PRC("CP")," ") S:$P(PRCSG,U,3)]"" P=P_"-"_$P($P(PRCSG,U,3)," ") S:$P(PRCSG,U,6)]"" P=P_"-"_+$P(PRCSG,U,6) "RTN","PRCE58P0",27,0) N PROJ I $D(TRNODE(3)),$P($G(TRNODE(3)),"^",12)'="" S PROJ=$P(TRNODE(3),"^",12),P=P_" "_PROJ "RTN","PRCE58P0",28,0) W !,P,?41,"|" K PRCSG I $D(TRNODE(4)) S PRCSG=TRNODE(4) I $P(PRCSG,U,9),$P(PRCSG,U,10)'="" S X=$$DECODE^PRCSC2(DA) W "/ES/"_$E(X,1,27) "RTN","PRCE58P0",29,0) W ?62,"|" I $D(PRCSG) S Y=$P(PRCSG,U,4) I Y D DD^%DT W Y "RTN","PRCE58P0",30,0) W !,L "RTN","PRCE58P0",31,0) W !,"AUTHORITY: " I $P($G(TRNODE(11)),U,4) W $P($G(^PRCS(410.9,$P(TRNODE(11),U,4),0)),U) "RTN","PRCE58P0",32,0) W:$P($G(TRNODE(11)),U,5) ?40,"SUB: ",$P($G(^PRCS(410.9,$P(TRNODE(11),U,5),0)),U) "RTN","PRCE58P0",33,0) W !,"SERVICE START DATE: ",$$FMTE^XLFDT($P($G(TRNODE(1)),U,6),"2DZ"),?40,"SERVICE END DATE: ",$$FMTE^XLFDT($P($G(TRNODE(1)),U,7),"2DZ") "RTN","PRCE58P0",34,0) W !,L,!,"Purpose: " "RTN","PRCE58P0",35,0) I $D(^UTILITY($J,"W",DIWL)) S Z=^UTILITY($J,"W",DIWL) F I=1:1:Z W !,^UTILITY($J,"W",DIWL,I,0) I IOSL-$Y<3 W !,L D HOLD Q:Z3=U D NEWP "RTN","PRCE58P0",36,0) G EXIT:Z3=U W !,L I IOSL-$Y<14 D HOLD G EXIT:Z3=U D NEWP "RTN","PRCE58P0",37,0) D ^PRCE58P1 I Z3'=U D HOLD "RTN","PRCE58P0",38,0) EXIT K %DT,CT,UT,P1,P,PRCSP,PRCSA,PRCSA1,PRCSA2,PRCSG,PRCSPO,PRCSY,TRNODE,X,X1,Y,DIWL,DIWR,DIWF,Z,Z1,Z2,Z3,DA,I,L,^UTILITY($J) D:$D(ZTQUEUED) KILL^%ZTLOAD Q "RTN","PRCE58P0",39,0) NEWP ;PRINT HEADER FOR NEW PAGE "RTN","PRCE58P0",40,0) W @IOF S PRCSP=PRCSP+1 W !,$P(TRNODE(0),U) W:$D(PRCSPO) ?35,PRC("SITE")_"-"_PRCSPO W ?73,"PAGE ",PRCSP W !,L "RTN","PRCE58P0",41,0) NEWP1 N PRCX S PRCX=$$AUTHR^PRCEMOA($P($G(TRNODE(11)),U,4,5)) "RTN","PRCE58P0",42,0) W !,"1358 OBLIGATION OR CHANGE" W:$P(PRCX,U)]"" ":",$P(PRCX,U) "RTN","PRCE58P0",43,0) W:$P(PRCX,U,2)]"" !,?5,$P(PRCX,U,2) W !,L "RTN","PRCE58P0",44,0) Q "RTN","PRCE58P0",45,0) HOLD R !,"Press return to continue, ""^"" to exit: ",Z3:DTIME S:'$T Z3=U Q "RTN","PRCE58P0",46,0) W2 W !!,"Enter information for another report or an uparrow to return to the menu.",! Q "RTN","PRCE58P0",47,0) W1 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT "RTN","PRCE58P0",48,0) W I $E(IOST,1)="C" W !!,"Press return to continue: " R X:DTIME "RTN","PRCE58P0",49,0) I IO'=IO(0) D ^%ZISC "RTN","PRCE58P1") 0^4^B16647166^B16244569 "RTN","PRCE58P1",1,0) PRCE58P1 ;WISC/SAW,LDB/BGJ-CONTROL POINT ACTIVITY 1358 DISPLAY CON'T ;6/17/11 17:51 "RTN","PRCE58P1",2,0) V ;;5.1;IFCAP;**158**;Oct 20, 2000;Build 1 "RTN","PRCE58P1",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCE58P1",4,0) S Z=$S($D(PRCSPO):PRC("SITE")_"-"_PRCSPO,1:0) "RTN","PRCE58P1",5,0) I I 'Z!('$D(^PRC(424,"AD",Z))) W !,"Daily Record entries have not yet been entered for this request.",!,"The total committed cost of this request is $" W:$D(TRNODE(4)) $J($P(TRNODE(4),U),0,2) W !,L G P "RTN","PRCE58P1",6,0) D HDR1 S PRCSX=0 D OB S (ET,AT,UT)="" D PO1 Q:Z3=U "RTN","PRCE58P1",7,0) W !!,?7,"TOTALS",?29,"$" "RTN","PRCE58P1",8,0) ;Display of dollar amounts staggered if any amount $1 million or more "RTN","PRCE58P1",9,0) D "RTN","PRCE58P1",10,0) . I ET>999999.99!(AT>999999.99)!(CET>999999.99) D Q "RTN","PRCE58P1",11,0) . . W $J(ET,9,2),?51,"$",$J(CET,9,2),?69,"$",$J((PRCSOT-UT),9,2) W !,?40,"$",$J(AT,9,2) "RTN","PRCE58P1",12,0) . W $J(ET,9,2),?40,"$",$J(AT,9,2),?51,"$",$J(CET,9,2),?69,"$",$J((PRCSOT-UT),9,2) "RTN","PRCE58P1",13,0) K PRCSX,PRCSOT,UT,CT,AT,ET,CAT,CET,PRCSR,PRCSX,PRCSXX,J,JJ "RTN","PRCE58P1",14,0) D P "RTN","PRCE58P1",15,0) Q "RTN","PRCE58P1",16,0) OB ;DISPLAY ONLY OBLIGATIONS "RTN","PRCE58P1",17,0) I '$D(^PRC(424,"AD",Z)) G OB1 "RTN","PRCE58P1",18,0) S (PRCSOT,X1,UT)="" F S X1=$O(^PRC(424,"AF",Z,X1)) Q:X1'>0 I $D(^PRC(424,X1,0)) S Z1=^(0),PRCSOT=PRCSOT+$P(Z1,U,6) X "I IOSL-$Y<5 D HOLD^PRCE58P0 Q:Z3=U D NEWP^PRCE58P0,HDR1" D DR1 "RTN","PRCE58P1",19,0) W !,L Q:$D(PRCSX) "RTN","PRCE58P1",20,0) OB1 W !!,"The following 1358 obligation/adjustment request is ready for processing:" "RTN","PRCE58P1",21,0) S X=$P(TRNODE(0),U,1,2) W !,"TRANSACTION NUMBER: ",$P(X,U),?40,"TYPE: ",$S($P(X,U,2)="O":"OBLIGATION",1:"ADJUSTMENT"),?50,"AMOUNT: $",$J($P(TRNODE(4),U,8),0,2) W !,L G P "RTN","PRCE58P1",22,0) PO1 I $D(TRNODE(10)) S PRCSY=$P(TRNODE(10),U,3) I PRCSY K PO D PO^PRCH58OB(PRCSY,.PO) D:$D(PO(0)) PO11 "RTN","PRCE58P1",23,0) Q "RTN","PRCE58P1",24,0) PO11 K ^TMP("PRCSR",$J) "RTN","PRCE58P1",25,0) I IOSL-$Y<15 D HOLD^PRCE58P0 Q:Z3=U D NEWP^PRCE58P0 "RTN","PRCE58P1",26,0) D HDR S CET=0 F S PRCSX=$O(^PRC(424,"C",PRCSY,PRCSX)) Q:'PRCSX D "RTN","PRCE58P1",27,0) . I $D(^PRC(424,PRCSX,0)),"^AU^L^"[("^"_$P(^(0),U,3)_"^") S Z1=^(0) I Z1 S ^TMP("PRCSR",$J,$P($P(Z1,U),"-",3),PRCSX)=Z1 "RTN","PRCE58P1",28,0) S PRCSXX="" F S PRCSXX=$O(^TMP("PRCSR",$J,PRCSXX)) Q:PRCSXX="" S (A,E)=0 D PO12 Q:Z3=U "RTN","PRCE58P1",29,0) K ^TMP("PRCSR",$J) Q "RTN","PRCE58P1",30,0) PO12 S PRCSX=0 F S PRCSX=$O(^TMP("PRCSR",$J,PRCSXX,PRCSX)) Q:PRCSX'>0 S Z1=^TMP("PRCSR",$J,PRCSXX,PRCSX),Y=$P(Z1,U,7) D T X "I IOSL-$Y<3 D HOLD^PRCE58P0 Q:Z3=U D NEWP^PRCE58P0,HDR" D PO2 Q:Z3=U "RTN","PRCE58P1",31,0) K A,E Q "RTN","PRCE58P1",32,0) PO2 W !,Y,?7,PRCSXX,?12,$P(Z1,U,10),?29,"$" "RTN","PRCE58P1",33,0) S E=$P(Z1,U,12),A=$P(Z1,U,5),UT=UT+$P(Z1,U,4),AT=AT+A,ET=ET+E,CET=CET+E "RTN","PRCE58P1",34,0) ;Display of dollar amounts staggered if any amount $1 million or more "RTN","PRCE58P1",35,0) D "RTN","PRCE58P1",36,0) . I E>999999.99!(A>999999.99)!(CET>999999.99)!(Z1>999999.99) D Q "RTN","PRCE58P1",37,0) . . W $J(E,9,2),?51,"$",$J(CET,9,2) W ! W:$D(PRCSA) ?12,$G(^PRC(424,PRCSX,1)) W ?40,"$",$J(A,9,2),?62,"$",$J($P(Z1,U,4),9,2) "RTN","PRCE58P1",38,0) . W $J(E,9,2),?40,"$",$J(A,9,2),?51,"$",$J(CET,9,2),?62,"$",$J($P(Z1,U,4),9,2) I $D(PRCSA) W !,?12,$G(^PRC(424,PRCSX,1)) "RTN","PRCE58P1",39,0) I $D(^PRC(424.1,"C",PRCSX)),$G(PRCSA1)=1 S I=0 F S I=$O(^PRC(424.1,"C",PRCSX,I)) Q:'I I $D(^PRC(424.1,I,0)),$P(^(0),U,11)="P" D Q:Z3=U W ! "RTN","PRCE58P1",40,0) . W ! I IOSL-$Y<5 D HOLD^PRCE58P0 Q:Z3=U D NEWP^PRCE58P0,HDR "RTN","PRCE58P1",41,0) . W ! S Y=$P(^PRC(424.1,I,0),U,4) D T W Y,?7,$P($P(^(0),U),"-",3,4) W !,?12,$P(^(0),U,8),?29,"$",$J(($P(^(0),U,3)/-1),9,2) "RTN","PRCE58P1",42,0) . I IOSL-$Y<5 D HOLD^PRCE58P0 Q:Z3=U D NEWP^PRCE58P0,HDR "RTN","PRCE58P1",43,0) . I PRCSA2=1,$D(^PRC(424.1,I,1)) W !,?12,^(1) "RTN","PRCE58P1",44,0) Q "RTN","PRCE58P1",45,0) P W:Z3'=U !!,"VA FORM 4-1358a-ADP (NOV 1987)",! Q "RTN","PRCE58P1",46,0) DR1 S Y=$P(Z1,U,7) D T W !,Y,?7,$P($P(Z1,U),"-",3) "RTN","PRCE58P1",47,0) S DA=$P(Z1,U,15) I DA D NODE^PRCS58OB(DA,.TRNODE) W ?13,$P(TRNODE(0),U) "RTN","PRCE58P1",48,0) W ?36,"$",$J($P(Z1,U,6),9,2) W:$D(PRCSX) ?56,"$",$J(PRCSOT,9,2) Q "RTN","PRCE58P1",49,0) HDR W !,"AUTHORIZATION & ORDER RECORD",?62,"LIQUIDATION RECORD" "RTN","PRCE58P1",50,0) W !!,?30,"AUTH.",?41,"AUTH.",?53,"CUMULATIVE",?74,"UNLIQ",!,"DATE",?7,"SEQ#",?14,"REFERENCE",?30,"AMOUNT",?41,"BALANCE",?53,"AUTH. AMT.",?64,"LIQUID",?74,"BAL" W !,L Q "RTN","PRCE58P1",51,0) HDR1 W !,"ESTIMATED OBLIGATION RECAP",!,"DATE",?7,"REF#",?13,"CPA#",?37,"AMOUNT",?57,"BALANCE" Q "RTN","PRCE58P1",52,0) T S Y=$E(Y,4,5)_"/"_$E(Y,6,7) Q "RTN","PRCE58P2") 0^2^B16749881^B16930657 "RTN","PRCE58P2",1,0) PRCE58P2 ;WISC/SAW,LDB-CONTROL POINT ACTIVITY 1358 PRINTOUT ;6/7/11 18:56 "RTN","PRCE58P2",2,0) V ;;5.1;IFCAP;**148,158**;Oct 20, 2000;Build 1 "RTN","PRCE58P2",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCE58P2",4,0) G P "RTN","PRCE58P2",5,0) QUE I $D(ZTQUEUED) S DA=D0 "RTN","PRCE58P2",6,0) S DA=D0,PRCSOB=1 "RTN","PRCE58P2",7,0) P U IO W:$Y>0 @IOF S U="^",PRCSP=1,L="",$P(L,"-",80)="-" D NOW^%DTC S Y=% D DD^%DT "RTN","PRCE58P2",8,0) D NODE^PRCS58OB(DA,.TRNODE) S PRCSTN=$P($G(TRNODE(0)),U),PRC("SITE")=+PRCSTN W !,PRCSTN,?36,Y,?72,"PAGE ",PRCSP D UL "RTN","PRCE58P2",9,0) D NEWP1 W !,"Originator of Request: " I $D(TRNODE(14)),TRNODE(14)'="" W $P($G(^VA(200,TRNODE(14),0)),"^"),! "RTN","PRCE58P2",10,0) W !,"Requestor:",?41,"|Date Requested:",?62,"|Obligation No.:" "RTN","PRCE58P2",11,0) W ! K P1 I $D(TRNODE(7)) S P1=TRNODE(7) I +P1 S X=$P($G(^VA(200,+P1,0)),U) W X "RTN","PRCE58P2",12,0) W ?41,"|" I $D(TRNODE(1)) S Y=$P(TRNODE(1),U) I Y D DD^%DT W Y "RTN","PRCE58P2",13,0) W ?62,"|" I $D(TRNODE(4)),$P(TRNODE(4),U,5)'="" S PRCSPO=$P(TRNODE(4),U,5) W ?65,PRC("SITE")_"-"_PRCSPO "RTN","PRCE58P2",14,0) D UL W !,"Vendor:",?41,"|Contract Number:" "RTN","PRCE58P2",15,0) W ! I $D(TRNODE(2)) W $P(TRNODE(2),U) "RTN","PRCE58P2",16,0) W ?41,"|" K PRCSG I $D(TRNODE(3)) S PRCSG=TRNODE(3) I $P(PRCSG,U,10)]"" W $P(PRCSG,U,10) "RTN","PRCE58P2",17,0) W ! I $D(TRNODE(2)),TRNODE(2)]"" W $P(TRNODE(2),U,2),?41,"|",!,$P(TRNODE(2),U,6)_", " W $S($D(^DIC(5,+$P(TRNODE(2),U,7),0)):$P(^(0),U,2),1:" ")_" "_$P(TRNODE(2),U,8) "RTN","PRCE58P2",18,0) W ?41,"|" D UL W !,"Name and Title Approving Official:",?41,"|Signature/Date Signed:" "RTN","PRCE58P2",19,0) K P W ! I $D(P1) S P=$P(P1,U,3) I P S X=$S($D(^VA(200,P,20)):$P(^(20),U,2),1:"") W $E(X,1,30) "RTN","PRCE58P2",20,0) ;K P W ! I $D(P1) S P=$P(P1,U,3) I P S X=$S($G(^VA(200,P,20)):$P(^(20),U,2),1:"") W $E(X,1,30) "RTN","PRCE58P2",21,0) W ?41,"|" I $D(P),P,$P(P1,U,6)'="" S X=$$DECODE^PRCSC1(DA) W "/ES/"_$E(X,1,28) "RTN","PRCE58P2",22,0) W ?62,"/" I $D(P1) S Y=$S($P(P1,U,7):$P(P1,U,7),1:$P(P1,U,5)) I Y D DD^%DT W Y K Y "RTN","PRCE58P2",23,0) W ! I $D(P1) W $P(P1,U,4) "RTN","PRCE58P2",24,0) W ?41,"|" D UL W !,"FUND CERTIFICATION:",!,"The supplies and services listed on this request are properly chargeable" "RTN","PRCE58P2",25,0) W !,"to the following allotments, the available balances of which are" "RTN","PRCE58P2",26,0) W !,"sufficient to cover the cost thereof, and funds have been obligated." "RTN","PRCE58P2",27,0) D UL W !,"Appropriation and Accounting Symbols:",?41,"|Obligated By: ",?62,"|Date Obligated:" "RTN","PRCE58P2",28,0) S DIWL=0,DIWR=80,DIWF="" K ^UTILITY($J) "RTN","PRCE58P2",29,0) I $D(TRNODE(8)) S X1=0 F I=1:1 S X1=$O(TRNODE(8,X1)) Q:X1="" S X=TRNODE(8,X1),PRCSDAA=DA D DIWP^PRCUTL($G(DA)) S DA=PRCSDAA K PRCSDAA "RTN","PRCE58P2",30,0) S P=PRC("SITE") I $D(PRCSG) S:$P(PRCSG,U,2)]"" P=P_"-"_$P(PRCSG,U,2) S P=P_"-"_$P(PRCSTN,"-",4) S:$P(PRCSG,U,3)]"" P=P_"-"_$P($P(PRCSG,U,3)," ") S:$P(PRCSG,U,6) P=P_"-"_+$P(PRCSG,U,6) "RTN","PRCE58P2",31,0) I $D(TRNODE(3)),$P($G(TRNODE(3)),"^",12)'="" S PROJ=$P(TRNODE(3),"^",12),P=P_" "_PROJ "RTN","PRCE58P2",32,0) W !,P,?41,"|" K PRCSG I $D(TRNODE(4)) S PRCSG=TRNODE(4) I $P(PRCSG,U,9),$P(PRCSG,U,10)'="" S X=$$DECODE^PRCSC2(DA) W "/ES/"_$E(X,1,28) "RTN","PRCE58P2",33,0) W ?62,"|" I $D(PRCSG) S Y=$P(PRCSG,U,4) I Y D DD^%DT W Y "RTN","PRCE58P2",34,0) D UL "RTN","PRCE58P2",35,0) W !,"AUTHORITY: " I $P($G(TRNODE(11)),U,4) W $P($G(^PRCS(410.9,$P(TRNODE(11),U,4),0)),U) "RTN","PRCE58P2",36,0) W:$P($G(TRNODE(11)),U,5) ?40,"SUB: ",$P($G(^PRCS(410.9,$P(TRNODE(11),U,5),0)),U) "RTN","PRCE58P2",37,0) W !,"SERVICE START DATE: ",$$FMTE^XLFDT($P($G(TRNODE(1)),U,6),"2DZ"),?40,"SERVICE END DATE: ",$$FMTE^XLFDT($P($G(TRNODE(1)),U,7),"2DZ") "RTN","PRCE58P2",38,0) D UL W !,"Purpose: " "RTN","PRCE58P2",39,0) I $D(^UTILITY($J,"W",DIWL)) S Z=^UTILITY($J,"W",DIWL) F I=1:1:Z W !,^UTILITY($J,"W",DIWL,I,0) I IOSL-$Y<3 D UL,NEWP "RTN","PRCE58P2",40,0) I IOSL-$Y<10 D NEWP "RTN","PRCE58P2",41,0) D ^PRCE58P3 "RTN","PRCE58P2",42,0) K %DT,CT,UT,P1,P,PRCSP,PRCSA,PRCSG,PRCSOB,PRCSPO,PRCSTN,X,X1,Y,DIWL,DIWR,DIWF,Z,DA,I,L,^UTILITY($J) D:$D(ZTQUEUED) KILL^%ZTLOAD Q "RTN","PRCE58P2",43,0) UL W ! N I F I=1:1:80 W @IOBS "RTN","PRCE58P2",44,0) W L Q "RTN","PRCE58P2",45,0) NEWP ;PRINT HEADER FOR NEW PAGE "RTN","PRCE58P2",46,0) W !!,"VA FORM 4-1358a-ADP (NOV 1987)" W:$Y>0 @IOF "RTN","PRCE58P2",47,0) S PRCSP=PRCSP+1 W !,$P(TRNODE(0),U) W:$D(PRCSPO) ?40,PRC("SITE")_"-"_PRCSPO W ?72,"PAGE ",PRCSP D UL "RTN","PRCE58P2",48,0) NEWP1 N PRCX S PRCX=$$AUTHR^PRCEMOA($P($G(TRNODE(11)),U,4,5)) "RTN","PRCE58P2",49,0) I '$D(PRCSOB) D "RTN","PRCE58P2",50,0) . W !,"1358 OBLIGATION OR CHANGE" W:$P(PRCX,U)]"" ":",$P(PRCX,U) "RTN","PRCE58P2",51,0) . W:$P(PRCX,U,2)]"" !,?5,$P(PRCX,U,2) "RTN","PRCE58P2",52,0) . D UL "RTN","PRCE58P2",53,0) E D "RTN","PRCE58P2",54,0) . W !,"REQUEST 1358 OBLIG/ADJUST" W:$P(PRCX,U)]"" ":",$P(PRCX,U) "RTN","PRCE58P2",55,0) . W:$P(PRCX,U,2)]"" !,?5,$P(PRCX,U,2) "RTN","PRCE58P2",56,0) . D UL "RTN","PRCE58P2",57,0) Q "RTN","PRCE58P3") 0^6^B17424731^B17336618 "RTN","PRCE58P3",1,0) PRCE58P3 ;WISC/SAW,LDB/BGJ-CONTROL POINT ACTIVITY 1358 PRINOUT CON'T ;6/17/11 17:53 "RTN","PRCE58P3",2,0) V ;;5.1;IFCAP;**158**;Oct 20, 2000;Build 1 "RTN","PRCE58P3",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCE58P3",4,0) S Z=$S($D(PRCSPO):PRC("SITE")_"-"_PRCSPO,1:0) G OB:$D(PRCSOB) "RTN","PRCE58P3",5,0) I 'Z!('$D(^PRC(424,"AD",Z))) W !,"Daily Record entries have not yet been entered for this request.",!,"The total committed cost of this request is $" W:$D(TRNODE(4)) $J($P(TRNODE(4),U),0,2) D UL^PRCE58P2 G P "RTN","PRCE58P3",6,0) PO D HDR1 S PRCSX=0 D OB S (CET,ET,AT,UT)="" D PO1 "RTN","PRCE58P3",7,0) W !!,?7,"TOTALS",?29,"$" "RTN","PRCE58P3",8,0) ;Display of dollar amounts staggered if any amount $1 million or more "RTN","PRCE58P3",9,0) D "RTN","PRCE58P3",10,0) . I ET>999999.99!(AT>999999.99)!(CET>999999.99) D Q "RTN","PRCE58P3",11,0) . . W $J(ET,9,2),?51,"$",$J(CET,9,2),?69,"$",$J((PRCSOT-UT),9,2) W !,?40,"$",$J(AT,9,2) "RTN","PRCE58P3",12,0) . W $J(ET,9,2),?40,"$",$J(AT,9,2),?51,"$",$J(CET,9,2),?69,"$",$J((PRCSOT-UT),9,2) "RTN","PRCE58P3",13,0) K PRCSX,PRCSOT,UT,CT,AT,ET,CAT,CET,PRCSR,PRCSX,PRCSXX,J,JJ,TRNODE "RTN","PRCE58P3",14,0) D P "RTN","PRCE58P3",15,0) Q "RTN","PRCE58P3",16,0) PO1 I $D(TRNODE(10)) S PRCSY=$P(TRNODE(10),U,3) I PRCSY K PO D PO^PRCH58OB(PRCSY,.PO) D:$D(PO(0)) PO11 "RTN","PRCE58P3",17,0) Q "RTN","PRCE58P3",18,0) PO11 K ^TMP("PRCSR",$J) D HDR S CET=0 F S PRCSX=$O(^PRC(424,"C",PRCSY,PRCSX)) Q:PRCSX'>0 I $D(^PRC(424,PRCSX,0)),"^AU^L^"[("^"_$P(^(0),U,3)_"^") S Z1=^(0) I Z1 S ^TMP("PRCSR",$J,$P($P(Z1,U),"-",3),PRCSX)=Z1 "RTN","PRCE58P3",19,0) S PRCSXX="" F S PRCSXX=$O(^TMP("PRCSR",$J,PRCSXX)) Q:PRCSXX="" D PO12 "RTN","PRCE58P3",20,0) K ^TMP("PRCSR",$J) Q "RTN","PRCE58P3",21,0) PO12 S PRCSX=0 F JJ=1:1 S PRCSX=$O(^TMP("PRCSR",$J,PRCSXX,PRCSX)) Q:PRCSX'>0 S Z1=^TMP("PRCSR",$J,PRCSXX,PRCSX),Y=$P(Z1,U,7) D T D:IOSL-$Y<6 NEWP^PRCE58P2,HDR D PO2 "RTN","PRCE58P3",22,0) K A,E Q "RTN","PRCE58P3",23,0) ; "RTN","PRCE58P3",24,0) PO2 W !,Y,?7,PRCSXX,?12,$P(Z1,U,10),?29,"$" "RTN","PRCE58P3",25,0) S E=$P(Z1,U,12),A=$P(Z1,U,5),UT=UT+$P(Z1,U,4),AT=AT+A,ET=ET+E,CET=CET+E "RTN","PRCE58P3",26,0) ;Display of dollar amounts staggered if any amount $1 million or more "RTN","PRCE58P3",27,0) D "RTN","PRCE58P3",28,0) . I E>999999.99!(A>999999.99)!(CET>999999.99)!(Z1>999999.99) D Q "RTN","PRCE58P3",29,0) . . W $J(E,9,2),?51,"$",$J(CET,9,2) W ! W:$D(PRCSA)&($G(^PRC(424,PRCSX,1))'="") ?12,^(1) W ?40,"$",$J(A,9,2),?62,"$",$J($P(Z1,U,4),9,2) "RTN","PRCE58P3",30,0) . W $J(E,9,2),?40,"$",$J(A,9,2),?51,"$",$J(CET,9,2),?62,"$",$J($P(Z1,U,4),9,2) I $D(PRCSA),$G(^PRC(424,PRCSX,1))'="" W !,?12,^(1) "RTN","PRCE58P3",31,0) I $D(^PRC(424.1,"C",PRCSX)),$D(PRCSA1),PRCSA1=1 S I=0 F S I=$O(^PRC(424.1,"C",PRCSX,I)) Q:'I I $D(^PRC(424.1,I,0)),$P(^(0),U,11)="P" D "RTN","PRCE58P3",32,0) . I IOSL-$Y<6 D NEWP^PRCE58P2,HDR "RTN","PRCE58P3",33,0) . W ! S Y=$P(^PRC(424.1,I,0),U,4) D T W Y,?7,$P($P(^(0),U),"-",3,4) W !,?12,$P(^(0),U,8),?29,"$",$J(($P(^(0),U,3)/-1),9,2) "RTN","PRCE58P3",34,0) . I IOSL-$Y<6 D NEWP^PRCE58P2,HDR "RTN","PRCE58P3",35,0) . I $D(PRCSA2),PRCSA2=1,$D(^PRC(424.1,I,1)) W !,?12,^(1) "RTN","PRCE58P3",36,0) W ! Q "RTN","PRCE58P3",37,0) P W !!,"VA FORM 4-1358a-ADP (NOV 1987)",! Q "RTN","PRCE58P3",38,0) OB ;PRINT ONLY OBLIGATIONS "RTN","PRCE58P3",39,0) I '$D(^PRC(424,"AD",Z)) G OB1 "RTN","PRCE58P3",40,0) S (PRCSOT,X1,UT)="" F I=1:1 S X1=$O(^PRC(424,"AF",Z,X1)) Q:X1'>0 I $D(^PRC(424,X1,0)) S Z1=^(0),PRCSOT=PRCSOT+$P(^(0),U,6) D:IOSL-$Y<3 NEWP^PRCSP11,HDR1 S ZDA=DA D DR1 S DA=ZDA K ZDA D NODE^PRCS58OB(DA,.TRNODE) "RTN","PRCE58P3",41,0) D UL^PRCE58P2 Q:$D(PRCSX) "RTN","PRCE58P3",42,0) OB1 W !!,"The following 1358 obligation/adjustment request is ready for processing:" "RTN","PRCE58P3",43,0) S X=$P(TRNODE(0),U,1,2) W !,"TRANSACTION NUMBER: ",$P(X,U),?40,"TYPE: ",$S($P(X,U,2)="O":"OBLIGATION",1:"ADJUSTMENT"),?60,"AMOUNT: $",$J($P(TRNODE(4),U,8),0,2) D UL^PRCE58P2 G P "RTN","PRCE58P3",44,0) DR1 S Y=$P(Z1,U,7) D T W !,Y,?7,$P($P(Z1,U),"-",3) "RTN","PRCE58P3",45,0) S DA=$P(Z1,U,15) I DA D NODE^PRCS58OB(DA,.TRNODE) W ?13,$P($G(TRNODE(0)),U) "RTN","PRCE58P3",46,0) W ?36,"$",$J($P(Z1,U,6),9,2) W:$D(PRCSX) ?56,"$",$J(PRCSOT,9,2) Q "RTN","PRCE58P3",47,0) HDR W !,"AUTHORIZATION & ORDER RECORD",?62,"LIQUIDATION RECORD" "RTN","PRCE58P3",48,0) W !!,?30,"AUTH.",?41,"AUTH.",?53,"CUMULATIVE",?74,"UNLIQ",!,"DATE",?7,"SEQ#",?14,"REFERENCE",?30,"AMOUNT",?41,"BALANCE",?53,"AUTH. AMT.",?64,"LIQUID",?74,"BAL" D UL^PRCE58P2 Q "RTN","PRCE58P3",49,0) HDR1 W !,"ESTIMATED OBLIGATION RECAP",!,"DATE",?7,"REF#",?13,"CPA#",?37,"AMOUNT",?57,"BALANCE" Q "RTN","PRCE58P3",50,0) T S Y=$E(Y,4,5)_"/"_$E(Y,6,7) Q "RTN","PRCEMOA") 0^3^B39455655^B37610580 "RTN","PRCEMOA",1,0) PRCEMOA ;WOIFO/SAB - 1358 OBLIGATION APIS ;6/30/11 15:34 "RTN","PRCEMOA",2,0) V ;;5.1;IFCAP;**152,158**;Oct 20, 2000;Build 1 "RTN","PRCEMOA",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCEMOA",4,0) Q "RTN","PRCEMOA",5,0) ; "RTN","PRCEMOA",6,0) UOKCERT(PRCOUT,PRC1358,PRCPER) ; User OK as Certifier for a 1358 "RTN","PRCEMOA",7,0) ; This API verifies that the person would not violate segregation of "RTN","PRCEMOA",8,0) ; duty when certifying an invoice associated with a 1358 obligation "RTN","PRCEMOA",9,0) ; by ensuring that they have not previously acted as a requestor, "RTN","PRCEMOA",10,0) ; approver, or obligator on that 1358. "RTN","PRCEMOA",11,0) ; "RTN","PRCEMOA",12,0) ; inputs "RTN","PRCEMOA",13,0) ; PRCOUT - output variable, passed by reference "RTN","PRCEMOA",14,0) ; PRC1358 - 1358 obligation number (e.g. 688-C15001) "RTN","PRCEMOA",15,0) ; PRCPER - User, NEW PERSON (#200) file IEN "RTN","PRCEMOA",16,0) ; output "RTN","PRCEMOA",17,0) ; PRCOUT will be set equal to one of the following values "RTN","PRCEMOA",18,0) ; =1 if person can certify an invoice associated with the 1358 "RTN","PRCEMOA",19,0) ; =0^text if person not OK as certifier due to segregation of duties "RTN","PRCEMOA",20,0) ; where text is of the form "RTN","PRCEMOA",21,0) ; You are the 'role' of 'an event'. "RTN","PRCEMOA",22,0) ; e.g. "You are the Requestor of an Adjustment to the 1358." "RTN","PRCEMOA",23,0) ; =E^text if problem with inputs or the 1358 data "RTN","PRCEMOA",24,0) ; where list of possible error text is: "RTN","PRCEMOA",25,0) ; The 1358 number was not specified. "RTN","PRCEMOA",26,0) ; The Person was not specified. "RTN","PRCEMOA",27,0) ; The 1358 was not found in file 442. "RTN","PRCEMOA",28,0) ; The document is not a 1358. "RTN","PRCEMOA",29,0) ; The PRIMARY 2237 value is missing. "RTN","PRCEMOA",30,0) ; "RTN","PRCEMOA",31,0) N PRC410P,PRC442,PRCLIST,PRCODI "RTN","PRCEMOA",32,0) S PRCOUT=1 ; init output value "RTN","PRCEMOA",33,0) ; "RTN","PRCEMOA",34,0) ; verify inputs "RTN","PRCEMOA",35,0) D "RTN","PRCEMOA",36,0) . N PRCY0 "RTN","PRCEMOA",37,0) . ; check for required inputs "RTN","PRCEMOA",38,0) . I $G(PRC1358)="" S PRCOUT="E^The 1358 number was not specified." Q "RTN","PRCEMOA",39,0) . I $G(PRCPER)="" S PRCOUT="E^The Person was not specified." Q "RTN","PRCEMOA",40,0) . ; "RTN","PRCEMOA",41,0) . ; find 1358 in file 442 "RTN","PRCEMOA",42,0) . S PRC442=$O(^PRC(442,"B",PRC1358,0)) "RTN","PRCEMOA",43,0) . I PRC442'>0 S PRCOUT="E^The 1358 was not found in file 442." Q "RTN","PRCEMOA",44,0) . ; "RTN","PRCEMOA",45,0) . S PRCY0=$G(^PRC(442,PRC442,0)) "RTN","PRCEMOA",46,0) . ; "RTN","PRCEMOA",47,0) . ; Verify METHOD OF PROCESSING = IEN 21 1358 OBLIGATION "RTN","PRCEMOA",48,0) . I $P(PRCY0,U,2)'=21 S PRCOUT="E^The document is not a 1358." Q "RTN","PRCEMOA",49,0) . ; "RTN","PRCEMOA",50,0) . ; get PRIMARY 2237 "RTN","PRCEMOA",51,0) . S PRC410P=$P(PRCY0,U,12) "RTN","PRCEMOA",52,0) . I PRC410P="" S PRCOUT="E^The PRIMARY 2237 value is missing." Q "RTN","PRCEMOA",53,0) ; "RTN","PRCEMOA",54,0) ; loop thru OBLIGATION DATA multiple "RTN","PRCEMOA",55,0) I PRCOUT D "RTN","PRCEMOA",56,0) . S PRCODI=0 "RTN","PRCEMOA",57,0) . F S PRCODI=$O(^PRC(442,PRC442,10,PRCODI)) Q:'PRCODI D Q:'PRCOUT "RTN","PRCEMOA",58,0) . . N PRC410,PRC410A,PRC7Y,PRCACT,PRCEVENT,PRCODY0,PRCROLE "RTN","PRCEMOA",59,0) . . S PRCODY0=$G(^PRC(442,PRC442,10,PRCODI,0)) "RTN","PRCEMOA",60,0) . . ; "RTN","PRCEMOA",61,0) . . ; skip entries that are not SO or AR code sheet (excludes PV) "RTN","PRCEMOA",62,0) . . Q:"^SO^AR^"'[(U_$E(PRCODY0,1,2)_U) "RTN","PRCEMOA",63,0) . . ; "RTN","PRCEMOA",64,0) . . S PRC410A=$P(PRCODY0,U,11) ; 1358 ADJUSTMENT "RTN","PRCEMOA",65,0) . . S PRC410=$S(PRC410A]"":PRC410A,1:PRC410P) ; associated 410 entry "RTN","PRCEMOA",66,0) . . ; "RTN","PRCEMOA",67,0) . . ; determine event type and if not rebuild add 410 entry to list "RTN","PRCEMOA",68,0) . . I $D(PRCLIST(PRC410)) S PRCEVENT="R" ; rebuild "RTN","PRCEMOA",69,0) . . E S PRCEVENT=$S(PRC410A]"":"A",1:"O"),PRCLIST(PRC410)="" "RTN","PRCEMOA",70,0) . . ; "RTN","PRCEMOA",71,0) . . ; quit if rebuild since that does not impact certifier role "RTN","PRCEMOA",72,0) . . Q:PRCEVENT="R" "RTN","PRCEMOA",73,0) . . ; "RTN","PRCEMOA",74,0) . . I $P(PRCODY0,U,2) S PRCACT($P(PRCODY0,U,2))="O" ; OBLIGATED BY "RTN","PRCEMOA",75,0) . . ; get REQUESTOR and APPROVER from file 410 "RTN","PRCEMOA",76,0) . . S PRC7Y=$G(^PRCS(410,PRC410,7)) "RTN","PRCEMOA",77,0) . . I $P(PRC7Y,U,1) S PRCACT($P(PRC7Y,U,1))="R" ; REQUESTOR "RTN","PRCEMOA",78,0) . . I $P(PRC7Y,U,3) S PRCACT($P(PRC7Y,U,3))="A" ; APPROVING OFFICIAL "RTN","PRCEMOA",79,0) . . ; "RTN","PRCEMOA",80,0) . . ; check if person acted on this 1358 event in IFCAP "RTN","PRCEMOA",81,0) . . S PRCROLE=$G(PRCACT(PRCPER)) "RTN","PRCEMOA",82,0) . . I PRCROLE]"" D "RTN","PRCEMOA",83,0) . . . S PRCOUT="0^You are the " "RTN","PRCEMOA",84,0) . . . S PRCOUT=PRCOUT_$S(PRCROLE="R":"Requestor",PRCROLE="A":"Approving Official",1:"Obligator") "RTN","PRCEMOA",85,0) . . . S PRCOUT=PRCOUT_" "_$S(PRCEVENT="O":"of the 1358",1:"of an Adjustment to the 1358")_"." "RTN","PRCEMOA",86,0) ; "RTN","PRCEMOA",87,0) Q "RTN","PRCEMOA",88,0) ; "RTN","PRCEMOA",89,0) EV1358(PRC1358,PRCARR) ; Events (and Actors) for a 1358 "RTN","PRCEMOA",90,0) ; input "RTN","PRCEMOA",91,0) ; PRC1358 - 1358 number (e.g. 688-C15001) "RTN","PRCEMOA",92,0) ; PRCARR - (optional) results array name, passed by value, "RTN","PRCEMOA",93,0) ; closed root, default value is "^TMP(""PRC1358"",$J)" "RTN","PRCEMOA",94,0) ; The root must NOT be a variable name newed by this API "RTN","PRCEMOA",95,0) ; (PRC1358,PRCARR,PRC410P,PRC442,PRCLIST,PRCODI,PRCRET) "RTN","PRCEMOA",96,0) ; return value = 1 or E^text "RTN","PRCEMOA",97,0) ; = 1 if no problems "RTN","PRCEMOA",98,0) ; = E^text if problem with inputs or 1358 data "RTN","PRCEMOA",99,0) ; List of possible errors "RTN","PRCEMOA",100,0) ; The array name is invalid. "RTN","PRCEMOA",101,0) ; The 1358 number was not specified. "RTN","PRCEMOA",102,0) ; The 1358 was not found in file 442. "RTN","PRCEMOA",103,0) ; The document is not a 1358. "RTN","PRCEMOA",104,0) ; The PRIMARY 2237 value is missing. "RTN","PRCEMOA",105,0) ; output "RTN","PRCEMOA",106,0) ; PRCARR - array is initialized and populated "RTN","PRCEMOA",107,0) ; PRCARR(DATE/TIME,EVENT)=REQUESTOR^APPROVER^OBLIGATOR "RTN","PRCEMOA",108,0) ; where "RTN","PRCEMOA",109,0) ; DATE/TIME is a FileMan Date/Time (internal format) when "RTN","PRCEMOA",110,0) ; the transaction was obligated "RTN","PRCEMOA",111,0) ; EVENT is O (OBLIGATE), or A (ADJUST) "RTN","PRCEMOA",112,0) ; REQUESTOR is a NEW PERSON ien or null value "RTN","PRCEMOA",113,0) ; APPROVER is a NEW PERSON ien or null value "RTN","PRCEMOA",114,0) ; OBLIGATOR is a NEW PERSON ien or null value "RTN","PRCEMOA",115,0) ; e.g. ^TMP("PRCS1358",$J,3101005.091223,"O")=134^5432^43 "RTN","PRCEMOA",116,0) ; ^TMP("PRCS1358",$J,3101007.101501,"A")=134^9473^4677 "RTN","PRCEMOA",117,0) ; "RTN","PRCEMOA",118,0) N PRC410P,PRC442,PRCLIST,PRCODI,PRCRET "RTN","PRCEMOA",119,0) K ^TMP("PRC1358",$J) ; init results "RTN","PRCEMOA",120,0) S PRCRET=1 ; init return value "RTN","PRCEMOA",121,0) ; "RTN","PRCEMOA",122,0) ; verify inputs "RTN","PRCEMOA",123,0) D "RTN","PRCEMOA",124,0) . N PRCY0 "RTN","PRCEMOA",125,0) . ; check optional array root name "RTN","PRCEMOA",126,0) . I "^PRC1358^PRCARR^PRC410P^PRC442^PRCLIST^PRCODI^PRCRET^"[(U_$P($G(PRCARR),"(")_U) S PRCRET="E^The array name is invalid." Q "RTN","PRCEMOA",127,0) . ; "RTN","PRCEMOA",128,0) . ; check for required inputs "RTN","PRCEMOA",129,0) . I $G(PRC1358)="" S PRCRET="E^The 1358 number was not specified." Q "RTN","PRCEMOA",130,0) . ; "RTN","PRCEMOA",131,0) . ; find 1358 in file 442 "RTN","PRCEMOA",132,0) . S PRC442=$O(^PRC(442,"B",PRC1358,0)) "RTN","PRCEMOA",133,0) . I PRC442'>0 S PRCRET="E^The 1358 was not found in file 442." Q "RTN","PRCEMOA",134,0) . ; "RTN","PRCEMOA",135,0) . S PRCY0=$G(^PRC(442,PRC442,0)) "RTN","PRCEMOA",136,0) . ; "RTN","PRCEMOA",137,0) . ; Verify METHOD OF PROCESSING = IEN 21 1358 OBLIGATION "RTN","PRCEMOA",138,0) . I $P(PRCY0,U,2)'=21 S PRCRET="E^The document is not a 1358." Q "RTN","PRCEMOA",139,0) . ; "RTN","PRCEMOA",140,0) . ; get PRIMARY 2237 "RTN","PRCEMOA",141,0) . S PRC410P=$P(PRCY0,U,12) "RTN","PRCEMOA",142,0) . I PRC410P="" S PRCRET="E^The PRIMARY 2237 value is missing." Q "RTN","PRCEMOA",143,0) ; "RTN","PRCEMOA",144,0) ; loop thru OBLIGATION DATA multiple "RTN","PRCEMOA",145,0) I PRCRET D "RTN","PRCEMOA",146,0) . S PRCODI=0 F S PRCODI=$O(^PRC(442,PRC442,10,PRCODI)) Q:'PRCODI D "RTN","PRCEMOA",147,0) . . N PRC410,PRC410A,PRC7Y,PRCDT,PRCODY0,PRCEVENT,PRCRA,PRCRO,PRCRR "RTN","PRCEMOA",148,0) . . S PRCODY0=$G(^PRC(442,PRC442,10,PRCODI,0)) "RTN","PRCEMOA",149,0) . . ; "RTN","PRCEMOA",150,0) . . ; skip entries that are not SO or AR code sheet (excludes PV) "RTN","PRCEMOA",151,0) . . Q:"^SO^AR^"'[(U_$E(PRCODY0,1,2)_U) "RTN","PRCEMOA",152,0) . . ; "RTN","PRCEMOA",153,0) . . S PRCDT=$P(PRCODY0,U,6) ; DATE SIGNED "RTN","PRCEMOA",154,0) . . S PRC410A=$P(PRCODY0,U,11) ; 1358 ADJUSTMENT "RTN","PRCEMOA",155,0) . . S PRC410=$S(PRC410A]"":PRC410A,1:PRC410P) ; associated 410 entry "RTN","PRCEMOA",156,0) . . ; "RTN","PRCEMOA",157,0) . . ; determine event type and if not rebuild add 410 entry to list "RTN","PRCEMOA",158,0) . . I $D(PRCLIST(PRC410)) S PRCEVENT="R" ; REBUILD "RTN","PRCEMOA",159,0) . . E S PRCEVENT=$S(PRC410A]"":"A",1:"O"),PRCLIST(PRC410)="" "RTN","PRCEMOA",160,0) . . ; "RTN","PRCEMOA",161,0) . . ; quit if rebuild since that does not impact certifier role "RTN","PRCEMOA",162,0) . . Q:PRCEVENT="R" "RTN","PRCEMOA",163,0) . . ; "RTN","PRCEMOA",164,0) . . S PRCRO=$P(PRCODY0,U,2) ; OBLIGATED BY "RTN","PRCEMOA",165,0) . . ; get REQUESTOR and APPROVER from file 410 "RTN","PRCEMOA",166,0) . . S PRC7Y=$G(^PRCS(410,PRC410,7)) "RTN","PRCEMOA",167,0) . . S PRCRR=$P(PRC7Y,U,1) ; REQUESTOR "RTN","PRCEMOA",168,0) . . S PRCRA=$P(PRC7Y,U,3) ; APPROVING OFFICIAL "RTN","PRCEMOA",169,0) . . ; "RTN","PRCEMOA",170,0) . . ; save data to ^TMP "RTN","PRCEMOA",171,0) . . S ^TMP("PRC1358",$J,PRCDT,PRCEVENT)=$G(PRCRR)_U_$G(PRCRA)_U_$G(PRCRO) "RTN","PRCEMOA",172,0) ; "RTN","PRCEMOA",173,0) ; if an output array was specified, move the data to it "RTN","PRCEMOA",174,0) I PRCRET,$G(PRCARR)]"",$D(^TMP("PRC1358",$J)) D "RTN","PRCEMOA",175,0) . Q:($NA(@PRCARR,2))=("^TMP(""PRC1358"","_$J_")") ; same as default "RTN","PRCEMOA",176,0) . K @PRCARR "RTN","PRCEMOA",177,0) . M @PRCARR=^TMP("PRC1358",$J) "RTN","PRCEMOA",178,0) . K ^TMP("PRC1358",$J) "RTN","PRCEMOA",179,0) ; "RTN","PRCEMOA",180,0) Q PRCRET "RTN","PRCEMOA",181,0) ; "RTN","PRCEMOA",182,0) ; "RTN","PRCEMOA",183,0) AUTHR(PRCSTR) ;Returns string AuthorityDesc^Sub-AuthorityDesc for 1358 request "RTN","PRCEMOA",184,0) ; given string of AuthorityIEN^Sub-AuthorityIEN "RTN","PRCEMOA",185,0) N PRCX S PRCX="" "RTN","PRCEMOA",186,0) I PRCSTR]"" S PRCX=$P($G(^PRCS(410.9,+PRCSTR,0)),U,2)_"^"_$P($G(^PRCS(410.9,+$P(PRCSTR,U,2),0)),U,2) "RTN","PRCEMOA",187,0) Q PRCX "RTN","PRCFDPV1") 0^10^B6007702^B6229471 "RTN","PRCFDPV1",1,0) PRCFDPV1 ;WISC/LEM-PAYMENT ERROR PROCESSING CON'T ;6/21/11 17:52 "RTN","PRCFDPV1",2,0) ;;5.1;IFCAP;**158**;Oct 20, 2000;Build 1 "RTN","PRCFDPV1",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCFDPV1",4,0) QUIT "RTN","PRCFDPV1",5,0) ; No top level entry "RTN","PRCFDPV1",6,0) STATT ; Transmitted "RTN","PRCFDPV1",7,0) W !!,"This FMS document has been transmitted to FMS." "RTN","PRCFDPV1",8,0) W !,"No error processing can be performed at this time.",!! "RTN","PRCFDPV1",9,0) D PAUSE^PRCFDPVU "RTN","PRCFDPV1",10,0) S PRCFA("ERROR")=0 "RTN","PRCFDPV1",11,0) Q "RTN","PRCFDPV1",12,0) STATQ ; Queued for transmission "RTN","PRCFDPV1",13,0) W !!,"This FMS document has been queued for transmission to FMS." "RTN","PRCFDPV1",14,0) W !,"No error processing can be performed at this time.",!! "RTN","PRCFDPV1",15,0) D PAUSE^PRCFDPVU "RTN","PRCFDPV1",16,0) S PRCFA("ERROR")=0 "RTN","PRCFDPV1",17,0) Q "RTN","PRCFDPV1",18,0) STATM ; Marked for immediate transmission "RTN","PRCFDPV1",19,0) W !!,"This FMS document has been marked for immediate transmission to FMS." "RTN","PRCFDPV1",20,0) W !,"No error processing can be performed at this time.",!! "RTN","PRCFDPV1",21,0) D PAUSE^PRCFDPVU "RTN","PRCFDPV1",22,0) S PRCFA("ERROR")=0 "RTN","PRCFDPV1",23,0) Q "RTN","PRCFDPV1",24,0) STATE ; Error in transmission "RTN","PRCFDPV1",25,0) W !!,"This FMS document had an error during transmission." "RTN","PRCFDPV1",26,0) W !,"Use the option to 'Retransmit Stack File Document' on the FMS" "RTN","PRCFDPV1",27,0) W !,"Code Sheet Menu.",! "RTN","PRCFDPV1",28,0) D PAUSE^PRCFDPVU "RTN","PRCFDPV1",29,0) S PRCFA("ERROR")=0 "RTN","PRCFDPV1",30,0) Q "RTN","PRCFDPV1",31,0) STATA ; Accepted by FMS "RTN","PRCFDPV1",32,0) W !!,"This FMS document has been accepted by FMS." "RTN","PRCFDPV1",33,0) W !,"No error processing is necessary.",!! "RTN","PRCFDPV1",34,0) D PAUSE^PRCFDPVU "RTN","PRCFDPV1",35,0) S PRCFA("ERROR")=0 "RTN","PRCFDPV1",36,0) Q "RTN","PRCFDPV1",37,0) STATR ; Rejected by FMS "RTN","PRCFDPV1",38,0) W !!,"This FMS document has rejected due to one or more errors." "RTN","PRCFDPV1",39,0) S PRCFA("ERROR")=1 "RTN","PRCFDPV1",40,0) Q "RTN","PRCFDPV1",41,0) STATR1 S:$G(MOP)="" MOP=2 "RTN","PRCFDPV1",42,0) S LABEL=$S(MOP=1:"Purchase Order",MOP=21:"1358 Obligation",MOP=8:"Requistion",MOP=2:"Certified Invoice",0:"Obligation") "RTN","PRCFDPV1",43,0) W !,"The "_LABEL_" will now be displayed for your review.",!! "RTN","PRCFDPV1",44,0) W "Please review the source document very carefully and take",!,"the appropriate corrective action.",! "RTN","PRCFDPV1",45,0) D PAUSE^PRCFDPVU "RTN","PRCFDPV1",46,0) Q "RTN","PRCFDPV2") 0^11^B7956553^B8185376 "RTN","PRCFDPV2",1,0) PRCFDPV2 ;WISC/LEM-PAYMENT ERROR PROCESSING REBUILD/RETRANS CON'T ;6/21/11 17:59 "RTN","PRCFDPV2",2,0) ;;5.1;IFCAP;**158**;Oct 20, 2000;Build 1 "RTN","PRCFDPV2",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCFDPV2",4,0) QUIT "RTN","PRCFDPV2",5,0) ; No top level entry "RTN","PRCFDPV2",6,0) STATT ; Transmitted "RTN","PRCFDPV2",7,0) W !!,"This FMS document has been transmitted to FMS." "RTN","PRCFDPV2",8,0) ;W !,"It cannot be rebuilt and retransmitted at this time.",!! "RTN","PRCFDPV2",9,0) D PAUSE^PRCFDPVU "RTN","PRCFDPV2",10,0) S PRCFA("ERROR")=0 "RTN","PRCFDPV2",11,0) S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you still wish to rebuild and retransmit this Payment Voucher" "RTN","PRCFDPV2",12,0) D ^DIR K DIR S:+Y>0 PRCFA("TRANS")=1 "RTN","PRCFDPV2",13,0) Q "RTN","PRCFDPV2",14,0) STATQ ; Queued for transmission "RTN","PRCFDPV2",15,0) W !!,"This FMS document has been queued for transmission to FMS." "RTN","PRCFDPV2",16,0) W !,"It cannot be rebuilt and retransmitted at this time.",!! "RTN","PRCFDPV2",17,0) D PAUSE^PRCFDPVU "RTN","PRCFDPV2",18,0) S PRCFA("ERROR")=0 "RTN","PRCFDPV2",19,0) Q "RTN","PRCFDPV2",20,0) STATM ; Marked for immediate transmission "RTN","PRCFDPV2",21,0) W !!,"This FMS document has been marked for immediate transmission to FMS." "RTN","PRCFDPV2",22,0) W !,"It cannot be rebuilt and retransmitted at this time.",!! "RTN","PRCFDPV2",23,0) D PAUSE^PRCFDPVU "RTN","PRCFDPV2",24,0) S PRCFA("ERROR")=0 "RTN","PRCFDPV2",25,0) Q "RTN","PRCFDPV2",26,0) STATE ; Error in transmission "RTN","PRCFDPV2",27,0) W !!,"This FMS document has an error in transmission." "RTN","PRCFDPV2",28,0) W !,"Use the option to 'Retransmit Stack File Document' on the FMS" "RTN","PRCFDPV2",29,0) W !,"Code Sheet Menu to retransmit without rebuilding.",! "RTN","PRCFDPV2",30,0) D PAUSE^PRCFDPVU "RTN","PRCFDPV2",31,0) S PRCFA("ERROR")=0 "RTN","PRCFDPV2",32,0) S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to rebuild Payment Voucher prior to retransmitting" "RTN","PRCFDPV2",33,0) D ^DIR K DIR S:+Y>0 PRCFA("TRANS")=1 "RTN","PRCFDPV2",34,0) Q "RTN","PRCFDPV2",35,0) STATA ; Accepted by FMS "RTN","PRCFDPV2",36,0) W !!,"This FMS document has been accepted by FMS." "RTN","PRCFDPV2",37,0) W !,"No rebuilding and retransmitting is necessary.",!! "RTN","PRCFDPV2",38,0) D PAUSE^PRCFDPVU "RTN","PRCFDPV2",39,0) S PRCFA("ERROR")=0 "RTN","PRCFDPV2",40,0) Q "RTN","PRCFDPV2",41,0) STATR ; Rejected by FMS "RTN","PRCFDPV2",42,0) W !!,"This FMS document has rejected due to one or more errors." "RTN","PRCFDPV2",43,0) S PRCFA("ERROR")=1 "RTN","PRCFDPV2",44,0) Q "RTN","PRCFDPV2",45,0) STATR1 S:$G(MOP)="" MOP=2 "RTN","PRCFDPV2",46,0) S LABEL=$S(MOP=1:"Purchase Order",MOP=21:"1358 Obligation",MOP=8:"Requisition",MOP=2:"Certified Invoice",0:"Obligation") "RTN","PRCFDPV2",47,0) W !,"The "_LABEL_" can now be displayed for your review.",!! "RTN","PRCFDPV2",48,0) W "Please review the source document very carefully and take",!,"the appropriate corrective action.",! "RTN","PRCFDPV2",49,0) W ! S RESP=$$REVIEW^PRCFDPVU "RTN","PRCFDPV2",50,0) Q "RTN","PRCFFERM") 0^9^B5398839^B5746342 "RTN","PRCFFERM",1,0) PRCFFERM ;WISC/SJG-OBLIGATION ERROR PROCESSING MESSAGES ;6/17/11 17:55 "RTN","PRCFFERM",2,0) V ;;5.1;IFCAP;**158**;Oct 20, 2000;Build 1 "RTN","PRCFFERM",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCFFERM",4,0) QUIT "RTN","PRCFFERM",5,0) ; No top level entry "RTN","PRCFFERM",6,0) ; "RTN","PRCFFERM",7,0) MSG1 ; Message Processing "RTN","PRCFFERM",8,0) W !!,"This document is not a Miscellaneous Order (MO) or a Service Order (SO).",!,"Error processing cannot continue using this routine.",!! "RTN","PRCFFERM",9,0) Q "RTN","PRCFFERM",10,0) MSG2 W !!,"This Purchase Order or 1358 source document is not found. Error processing",!,"cannot continue." "RTN","PRCFFERM",11,0) Q "RTN","PRCFFERM",12,0) MSG3 W !!,"The Method of Processing is missing. Error processing cannot continue.",!! "RTN","PRCFFERM",13,0) Q "RTN","PRCFFERM",14,0) MSG4 W !!,"No further action taken on this rejected document.",!! "RTN","PRCFFERM",15,0) Q "RTN","PRCFFERM",16,0) MSG5 K MSG N TYPE "RTN","PRCFFERM",17,0) S TYPE=$S(MOP=1:"a Purchase Order.",MOP=2:"a Certified Invoice.",MOP=3:"a Payment in Advance.",MOP=4:"a Guaranteed Delivery.",MOP=7:"an Imprest Fund.",MOP=8:"a Requistion.",MOP=26:"a Direct Delivery.",21:"a 1358 Obligation.") "RTN","PRCFFERM",18,0) S MSG(1)="This FMS Document is "_TYPE "RTN","PRCFFERM",19,0) I ("^1^2^3^4^7^8^26^"[("^"_MOP_"^")) S MSG(2)="Use the option to process MOs and SOs." "RTN","PRCFFERM",20,0) I MOP=21 S MSG(2)="Use the option to process SOs." "RTN","PRCFFERM",21,0) D EN^DDIOL(.MSG) K MSG "RTN","PRCFFERM",22,0) Q "RTN","PRCFFERU") 0^8^B9629227^B9964660 "RTN","PRCFFERU",1,0) PRCFFERU ;WISC/SJG/DL-OBLIGATION ERROR PROCESSING CON'T ;6/17/11 17:56 "RTN","PRCFFERU",2,0) V ;;5.1;IFCAP;**158**;Oct 20, 2000;Build 1 "RTN","PRCFFERU",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCFFERU",4,0) QUIT "RTN","PRCFFERU",5,0) ; No top level entry "RTN","PRCFFERU",6,0) NUM S PONUM=$G(GECSDATA(2100.1,GECSDATA,.01,"E")) "RTN","PRCFFERU",7,0) S PONUM=$P(PONUM,"-",2) "RTN","PRCFFERU",8,0) S PATNUM=$E(PONUM,4,9) "RTN","PRCFFERU",9,0) S SITE=$E(PONUM,1,3) "RTN","PRCFFERU",10,0) S PONUM=SITE_"-"_PATNUM "RTN","PRCFFERU",11,0) S PONUM=$$STRIP(PONUM) "RTN","PRCFFERU",12,0) Q "RTN","PRCFFERU",13,0) GET(DIC,X) ; Get P.O. information for review "RTN","PRCFFERU",14,0) K Y "RTN","PRCFFERU",15,0) S DIC(0)="MNZ" "RTN","PRCFFERU",16,0) D ^DIC "RTN","PRCFFERU",17,0) K DIC "RTN","PRCFFERU",18,0) Q "RTN","PRCFFERU",19,0) STRIP(X) ; Strip trailing spaces "RTN","PRCFFERU",20,0) N LOOP "RTN","PRCFFERU",21,0) F LOOP=$L(X):-1:1 Q:$E(X,LOOP)'=" " "RTN","PRCFFERU",22,0) S VAR=$E(X,1,LOOP) "RTN","PRCFFERU",23,0) Q VAR "RTN","PRCFFERU",24,0) PAUSE ; Pause screen when data is displayed "RTN","PRCFFERU",25,0) W !!,"Press 'RETURN' to continue" "RTN","PRCFFERU",26,0) R X:DTIME "RTN","PRCFFERU",27,0) I $D(IOF) W @IOF "RTN","PRCFFERU",28,0) Q "RTN","PRCFFERU",29,0) PAUSE1 ; Pause screen when data is displayed "RTN","PRCFFERU",30,0) W !!,"Press 'RETURN' to start the display" "RTN","PRCFFERU",31,0) R X:DTIME "RTN","PRCFFERU",32,0) I $D(IOF) W @IOF "RTN","PRCFFERU",33,0) Q "RTN","PRCFFERU",34,0) REVIEW(X) ; Prompt user to review obligation document "RTN","PRCFFERU",35,0) S DIR(0)="Y" "RTN","PRCFFERU",36,0) S DIR("B")="YES" "RTN","PRCFFERU",37,0) S DIR("A")="Do you wish to display the source document" "RTN","PRCFFERU",38,0) S DIR("?")="Enter 'NO' or 'N' or '^' if the display is not necessary." "RTN","PRCFFERU",39,0) S DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to display the source document." "RTN","PRCFFERU",40,0) D ^DIR "RTN","PRCFFERU",41,0) K DIR "RTN","PRCFFERU",42,0) S RESP=Y "RTN","PRCFFERU",43,0) I $D(Y(0)) S $P(RESP,U,2)=Y(0) "RTN","PRCFFERU",44,0) I $D(DIRUT) S $P(RESP,U,3)=DIRUT "RTN","PRCFFERU",45,0) Q RESP "RTN","PRCFFERU",46,0) RETRANS(X) ; Prompt user to rebuild FMS doc from source doc and retransmit "RTN","PRCFFERU",47,0) S DIR(0)="Y" "RTN","PRCFFERU",48,0) S DIR("B")="YES" "RTN","PRCFFERU",49,0) S DIR("A")="Do you wish to rebuild and retransmit this FMS document" "RTN","PRCFFERU",50,0) S DIR("?")="Enter 'NO' or 'N' or '^' to exit." "RTN","PRCFFERU",51,0) S DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to rebuild/retransmit this document." "RTN","PRCFFERU",52,0) D ^DIR K DIR "RTN","PRCFFERU",53,0) S RETRAN=Y "RTN","PRCFFERU",54,0) I $D(Y(0)) S $P(RETRAN,U,2)=Y(0) "RTN","PRCFFERU",55,0) I $D(DIRUT) S $P(RETRAN,U,3)=DIRUT "RTN","PRCFFERU",56,0) Q RETRAN "RTN","PRCFFERU",57,0) ; "RTN","PRCFFERU",58,0) ; OPT = 1 if inquiry, 2 if rebuild/retransmit "RTN","PRCFFERU",59,0) STATR1(OPT) ; "RTN","PRCFFERU",60,0) S LABEL=$S(MOP=1:"Purchase Order",MOP=21:"1358 Obligation",MOP=7:"Imprest Fund",MOP=8:"Requistion",MOP=2:"Certified Invoice",MOP=3:"Payment in Advance",MOP=4:"Guaranteed Delivery",1:"Obligation") "RTN","PRCFFERU",61,0) W !,"The "_LABEL_$S(OPT=1:" will",1:" can") "RTN","PRCFFERU",62,0) W " now be displayed for your review.",!! "RTN","PRCFFERU",63,0) W "Please review the source document very carefully and take",!,"the appropriate corrective action.",! "RTN","PRCFFERU",64,0) I OPT=1 D PAUSE "RTN","PRCFFERU",65,0) I OPT=2 W ! S RESP=$$REVIEW(.RESP) "RTN","PRCFFERU",66,0) Q "RTN","PRCFFERU",67,0) ; "RTN","PRCFFERU",68,0) FYQ(Z) ; Get Fiscal Year and Quarter "RTN","PRCFFERU",69,0) N X,A,B,C,D "RTN","PRCFFERU",70,0) S %DT="",X="T" D ^%DT "RTN","PRCFFERU",71,0) S A=$E(Y,2,3) "RTN","PRCFFERU",72,0) S B=$E(Y,4,5) "RTN","PRCFFERU",73,0) S C=$E(100+$S(B>9:A+1,1:A),2,3) "RTN","PRCFFERU",74,0) S D=$S(B<4:2,B<7:3,B<10:4,1:1) "RTN","PRCFFERU",75,0) Q C_"^"_D "RTN","PRCFFU13") 0^7^B15091179^B15290042 "RTN","PRCFFU13",1,0) PRCFFU13 ;WISC/SJG-ROUTINE TO PROCESS OBLIGATIONS CONT ;6/17/11 17:58 "RTN","PRCFFU13",2,0) V ;;5.1;IFCAP;**158**;Oct 20, 2000;Build 1 "RTN","PRCFFU13",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCFFU13",4,0) ; Allows FIscal to edit Cost Center and BOCs prior to 1358 obligation "RTN","PRCFFU13",5,0) 1358 ; 1358 Correction "RTN","PRCFFU13",6,0) N CCEDIT,BOCEDIT D PROMPT "RTN","PRCFFU13",7,0) Q:'Y!($D(DIRUT)) "RTN","PRCFFU13",8,0) S ESIGCHK=$$VERIFY^PRCSC1(OB) I 'ESIGCHK W !!,"This 1358 Obligation has been tampered with. Please notify IFCAP APPLICATION COORDINATOR." Q "RTN","PRCFFU13",9,0) S (BOCEDIT,CCEDIT)=0 "RTN","PRCFFU13",10,0) S OLDCC=$P(TRNODE(3),U,3),OLDBOC=+$P(TRNODE(3),U,6) "RTN","PRCFFU13",11,0) W !! K MSG S MSG="...now editing Cost Center and BOC information..." D EN^DDIOL(MSG) K MSG W ! "RTN","PRCFFU13",12,0) D OB^PRCS58OB(DA) "RTN","PRCFFU13",13,0) S:+OLDCC'=+NEWCC CCEDIT=1 S:+OLDBOC'=+NEWBOC BOCEDIT=1 "RTN","PRCFFU13",14,0) I CCEDIT!(BOCEDIT) D Q "RTN","PRCFFU13",15,0) .S FISCEDIT=1,ESIGMSG="",ROUTINE=$T(+0) "RTN","PRCFFU13",16,0) .D RECODE^PRCSC1(OB,.ESIGMSG) "RTN","PRCFFU13",17,0) .I ESIGMSG<1 D "RTN","PRCFFU13",18,0) ..S:'$D(ROUTINE) ROUTINE=$T(+0) "RTN","PRCFFU13",19,0) ..W !!,$$ERROR(ROUTINE,ESIGMSG) "RTN","PRCFFU13",20,0) ..W:ESIGMSG=0!(ESIGMSG=-3) !,"Notify IFCAP APPLICATION COORDINATOR!",$C(7) "RTN","PRCFFU13",21,0) ..S DIR(0)="EAO",DIR("A")="Press RETURN to continue" D ^DIR K DIR "RTN","PRCFFU13",22,0) ..Q "RTN","PRCFFU13",23,0) .N X S X=$P($G(TRNODE(4)),U,5) D VER^PRCH58OB(.PRC,.X) I X]"" D "RTN","PRCFFU13",24,0) ..S PO=POIEN K ^PRC(442,POIEN,22) S NODE=$G(^PRC(442,POIEN,22,0)) I NODE="" D "RTN","PRCFFU13",25,0) ...S ^PRC(442,POIEN,22,0)="^"_$P(^DD(442,41,0),U,2) "RTN","PRCFFU13",26,0) ...N DA S DIE=442,DA=POIEN,DR="3///^S X=+NEWBOC" D ^DIE K DIE,DR "RTN","PRCFFU13",27,0) ...D MSG1,NODE22^PRCFFU5 "RTN","PRCFFU13",28,0) .Q "RTN","PRCFFU13",29,0) D MSG6 "RTN","PRCFFU13",30,0) Q "RTN","PRCFFU13",31,0) PROMPT ; Prompt for user "RTN","PRCFFU13",32,0) S DIR(0)="Y",DIR("A")="Should the Cost Center or BOC information be edited at this time",DIR("B")="NO" "RTN","PRCFFU13",33,0) S DIR("?")="Enter 'NO' or 'N' or 'RETURN' if no editing is needed." "RTN","PRCFFU13",34,0) S DIR("?",1)="Enter '^' to exit the option." "RTN","PRCFFU13",35,0) S DIR("?",2)="Enter 'YES' or 'Y' to edit this information." "RTN","PRCFFU13",36,0) W ! D ^DIR K DIR "RTN","PRCFFU13",37,0) Q "RTN","PRCFFU13",38,0) ; Message processing "RTN","PRCFFU13",39,0) MSG1 K MSG W !! S MSG="...now recalculating FMS accounting lines..." D EN^DDIOL(MSG) K MSG W ! "RTN","PRCFFU13",40,0) Q "RTN","PRCFFU13",41,0) ; "RTN","PRCFFU13",42,0) MSG2 K MSG W !! S MSG(1)="...Cost Center is missing - cannot continue..." "RTN","PRCFFU13",43,0) MSG21 S MSG(2)=" ",MSG(3)="No further action is being taken on this obligation." "RTN","PRCFFU13",44,0) D EN^DDIOL(.MSG) K MSG W ! "RTN","PRCFFU13",45,0) Q "RTN","PRCFFU13",46,0) ; "RTN","PRCFFU13",47,0) MSG3 K MSG W !! S MSG="BOC "_+SA_" is not valid with Cost Center "_$P(PO(0),U,5)_"." "RTN","PRCFFU13",48,0) D EN^DDIOL(MSG) K MSG W ! "RTN","PRCFFU13",49,0) Q "RTN","PRCFFU13",50,0) ; "RTN","PRCFFU13",51,0) MSG4 W !! S DIR(0)="Y",DIR("A",1)="I will now enter BOC "_+SA_" on all line items.",DIR("A")="Is this OK",DIR("B")="YES" "RTN","PRCFFU13",52,0) D ^DIR K DIR "RTN","PRCFFU13",53,0) Q "RTN","PRCFFU13",54,0) ; "RTN","PRCFFU13",55,0) MSG5 K MSG W !! S MSG="...now changing the BOCs on all line items..." "RTN","PRCFFU13",56,0) D EN^DDIOL(MSG) K MSG W ! "RTN","PRCFFU13",57,0) Q "RTN","PRCFFU13",58,0) MSG6 I (CCEDIT=1)!(BOCEDIT=1) Q "RTN","PRCFFU13",59,0) K MSG W !! "RTN","PRCFFU13",60,0) S MSG(1)=" ",MSG(2)=" " "RTN","PRCFFU13",61,0) S:CCEDIT=0 MSG(1)="Cost Center has not changed.",MSG(3)=" " "RTN","PRCFFU13",62,0) S:BOCEDIT=0 MSG(2)="BOC has not changed.",MSG(4)=" " "RTN","PRCFFU13",63,0) S MSG(5)="No further editing is being done on this obligation.",MSG(6)=" " "RTN","PRCFFU13",64,0) S MSG(7)="Returning to the Obligation processing." "RTN","PRCFFU13",65,0) D EN^DDIOL(.MSG) K MSG W ! "RTN","PRCFFU13",66,0) Q "RTN","PRCFFU13",67,0) ERROR(ROUTINE,ERROR) ; "RTN","PRCFFU13",68,0) I ROUTINE'="PRCUESIG" G NEXT "RTN","PRCFFU13",69,0) I ERROR=-3 Q "NO SIGNATURE BLOCK IN FILE 200." "RTN","PRCFFU13",70,0) I ERROR=-2 Q "TIME OUT OCCURRED DURING SIGNING PROCESS." "RTN","PRCFFU13",71,0) I ERROR=-1 Q "USER CANCELLED SIGNING PROCESS." "RTN","PRCFFU13",72,0) I ERROR=0 Q "INVALID SIGNATURE ENTERED." "RTN","PRCFFU13",73,0) Q "PROBLEM WITH ELECTRONIC SIGNATURE. ERROR= "_ERROR_" CALLING ROUTINE "_ROUTINE "RTN","PRCFFU13",74,0) NEXT I ERROR=-4 Q "CAN'T RE-SIGN RECORD." "RTN","PRCFFU13",75,0) I ERROR=-3 Q "NO VALID USER NUMBER FOR FILING." "RTN","PRCFFU13",76,0) I ERROR=-2 Q "NO SIGNATURE BLOCK IN FILE 200." "RTN","PRCFFU13",77,0) I ERROR=-1 Q "A REQUIRED RECORD IS NULL." "RTN","PRCFFU13",78,0) Q "PROBLEM WITH ELECTRONIC SIGNATURE. ERROR= "_ERROR_" CALLING ROUTINE "_ROUTINE "RTN","PRCFFU13",79,0) Q "RTN","PRCSP11") 0^5^B15814288^B13657459 "RTN","PRCSP11",1,0) PRCSP11 ;WISC/SAW-CONTROL POINT ACTIVITY 1358 PRINTOUT ;6/17/11 17:59 "RTN","PRCSP11",2,0) V ;;5.1;IFCAP;**158**;Oct 20, 2000;Build 1 "RTN","PRCSP11",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCSP11",4,0) G P "RTN","PRCSP11",5,0) QUE I $D(ZTQUEUED) S DA=D0 "RTN","PRCSP11",6,0) S DA=D0,PRCSOB=1 "RTN","PRCSP11",7,0) P U IO W:$Y>0 @IOF S U="^",PRCSP=1,L="",$P(L,"-",80)="-" D NOW^%DTC S Y=% D DD^%DT S PRCSTN=$P(^PRCS(410,DA,0),U),PRC("SITE")=+PRCSTN W !,PRCSTN,?36,Y,?72,"PAGE ",PRCSP D UL "RTN","PRCSP11",8,0) D NEWP1 W !,"Requestor:",?41,"|Date Requested:",?62,"|Obligation No.:" "RTN","PRCSP11",9,0) W ! K P1 I $D(^PRCS(410,DA,7)) S P1=^(7) I +P1 S X=$S($D(^VA(200,+P1,0)):$P(^(0),U),1:"") W X "RTN","PRCSP11",10,0) W ?41,"|" I $D(^PRCS(410,DA,1)) S Y=$P(^(1),U) I Y D DD^%DT W Y "RTN","PRCSP11",11,0) W ?62,"|" I $D(^PRCS(410,DA,4)),$P(^(4),U,5)'="" S PRCSPO=$P(^(4),U,5) W ?65,PRC("SITE")_"-"_PRCSPO "RTN","PRCSP11",12,0) D UL W !,"Vendor:",?41,"|Contract Number:" "RTN","PRCSP11",13,0) W ! I $D(^PRCS(410,DA,2)) W $P(^(2),U) ;S X=$P(^(2),U) I X]"" W X "RTN","PRCSP11",14,0) W ?41,"|" K PRCSG I $D(^PRCS(410,DA,3)) S PRCSG=^(3) I $P(PRCSG,U,10)]"" W $P(PRCSG,U,10) "RTN","PRCSP11",15,0) W ! I $D(^PRCS(410,DA,2)) W $P(^(2),U,2),?41,"|",!,$P(^(2),U,6)_", " W $S($D(^DIC(5,+$P(^PRCS(410,DA,2),U,7),0)):$P(^(0),U,2),1:" ")_" "_$P(^PRCS(410,DA,2),U,8) "RTN","PRCSP11",16,0) W ?41,"|" D UL W !,"Name and Title Approving Official:",?41,"|Signature/Date Signed:" "RTN","PRCSP11",17,0) N PRSHLD S PRSHLD=^DD(410,42,0) K P W ! I $D(P1),$P(PRSHLD,"^",2)[200 S P=$P(P1,U,3) I P S X=$S($D(^VA(200,P,20)):$P(^(20),U,2),1:"") W $E(X,1,30) "RTN","PRCSP11",18,0) W ?41,"|" I $D(P),P,$P(P1,U,6)'="" W "/ES/"_$$DECODE^PRCSC1(DA) "RTN","PRCSP11",19,0) W ?62,"/" I $D(P1) S Y=$S($P(P1,U,7):$P(P1,U,7),1:$P(P1,U,5)) I Y D DD^%DT W Y K Y "RTN","PRCSP11",20,0) W ! I $D(P1) W $P(P1,U,4) "RTN","PRCSP11",21,0) W ?41,"|" D UL W !,"FUND CERTIFICATION:",!,"The supplies and services listed on this request are properly chargeable" "RTN","PRCSP11",22,0) W !,"to the following allotments, the available balances of which are" "RTN","PRCSP11",23,0) W !,"sufficient to cover the cost thereof, and funds have been obligated." "RTN","PRCSP11",24,0) D UL W !,"Appropriation and Accounting Symbols:",?41,"|Obligated By: ",?62,"|Date Obligated:" "RTN","PRCSP11",25,0) S DIWL=0,DIWR=80,DIWF="" K ^UTILITY($J) "RTN","PRCSP11",26,0) I $D(^PRCS(410,DA,8,0)) S X1=0 F I=1:1 S X1=$O(^PRCS(410,DA,8,X1)) Q:X1="" S X=^(X1,0) D DIWP^PRCUTL($G(DA)) "RTN","PRCSP11",27,0) S P=PRC("SITE") I $D(PRCSG) S:$P(PRCSG,U,2)]"" P=P_"-"_$P(PRCSG,U,2) S P=P_"-"_$P(PRCSTN,"-",4) S:$P(PRCSG,U,3)]"" P=P_"-"_$P($P(PRCSG,U,3)," ") S:$P(PRCSG,U,6) P=P_"-"_+$P(PRCSG,U,6) "RTN","PRCSP11",28,0) W !,P,?41,"|" K PRCSG I $D(^PRCS(410,DA,4)) S PRCSG=^(4) I $P(PRCSG,U,9),$P(PRCSG,U,10)'="" W "/ES/"_$$DECODE^PRCSC2(DA) "RTN","PRCSP11",29,0) W ?62,"|" I $D(PRCSG) S Y=$P(PRCSG,U,4) I Y D DD^%DT W Y "RTN","PRCSP11",30,0) D UL W !,"AUTHORITY: " S Y=$P($G(^PRCS(410,DA,11)),U,4) I Y>0 W $P($G(^PRCS(410.9,Y,0)),U) "RTN","PRCSP11",31,0) S Y=$P($G(^PRCS(410,DA,11)),U,5) I Y>0 W ?40,"SUB: ",$P($G(^PRCS(410.9,Y,0)),U) "RTN","PRCSP11",32,0) S Y=$G(^PRCS(410,DA,1)) W !,"SERVICE START DATE: ",$$FMTE^XLFDT($P(Y,U,6),"2DZ"),?40,"SERVICE END DATE: ",$$FMTE^XLFDT($P(Y,U,7),"2DZ") "RTN","PRCSP11",33,0) D UL W !,"Purpose:" I $D(^UTILITY($J,"W",DIWL)) S Z=^UTILITY($J,"W",DIWL) F I=1:1:Z W !,^UTILITY($J,"W",DIWL,I,0) I IOSL-$Y<3 D UL,NEWP "RTN","PRCSP11",34,0) I IOSL-$Y<10 D NEWP "RTN","PRCSP11",35,0) D ^PRCSP111 "RTN","PRCSP11",36,0) W @IOF K %DT,CT,UT,P1,P,PRCSP,PRCSA,PRCSG,PRCSOB,PRCSPO,PRCSTN,X,X1,Y,DIWL,DIWR,DIWF,Z,DA,I,L,^UTILITY($J) D:$D(ZTSK) KILL^%ZTLOAD Q "RTN","PRCSP11",37,0) UL W ! F I=1:1:80 W @IOBS "RTN","PRCSP11",38,0) W L Q "RTN","PRCSP11",39,0) NEWP ;PRINT HEADER FOR NEW PAGE "RTN","PRCSP11",40,0) W !!,"VA FORM 4-1358a-ADP (NOV 1987)" W:$Y>0 @IOF "RTN","PRCSP11",41,0) S PRCSP=PRCSP+1 W !,$P(^PRCS(410,DA,0),U) W:$D(PRCSPO) ?40,PRC("SITE")_"-"_PRCSPO W ?72,"PAGE ",PRCSP D UL "RTN","PRCSP11",42,0) NEWP1 N PRCX S PRCX=$$AUTHR^PRCEMOA($P($G(^PRCS(410,DA,11)),U,4,5)) "RTN","PRCSP11",43,0) I '$D(PRCSOB) D "RTN","PRCSP11",44,0) . W !,"1358 OBLIGATION OR CHANGE" W:$P(PRCX,U)]"" ":",$P(PRCX,U) "RTN","PRCSP11",45,0) . W:$P(PRCX,U,2)]"" !,?5,$P(PRCX,U,2) "RTN","PRCSP11",46,0) . D UL "RTN","PRCSP11",47,0) E D "RTN","PRCSP11",48,0) . W !,"REQUEST 1358 OBLIG/ADJUST" W:$P(PRCX,U)]"" ":",$P(PRCX,U) "RTN","PRCSP11",49,0) . W:$P(PRCX,U,2)]"" !,?5,$P(PRCX,U,2) "RTN","PRCSP11",50,0) . D UL "RTN","PRCSP11",51,0) Q "VER") 8.0^22.0 "^DD",410,410,33,0) END DATE FOR 1358^D^^5;4^S %DT="E" D ^%DT S X=Y K:Y<1 X "^DD",410,410,33,3) Enter the ending date for this 1358 Obligation. "^DD",410,410,33,21,0) ^.001^5^5^3110614^^^^ "^DD",410,410,33,21,1,0) This field is the ending date for the 1358 Obligation, used when the "^DD",410,410,33,21,2,0) length of the service contract extends over a period greater than "^DD",410,410,33,21,3,0) one month. It is used by Fiscal service at the time of obligation. "^DD",410,410,33,21,4,0) When used in conjunction with the Auto Accrue flag, the ending date "^DD",410,410,33,21,5,0) will be used to determine the monthly accrual. "^DD",410,410,33,"DT") 2940812 "^DD",410,410,34,0) AUTO ACCRUE^S^1:YES;0:NO;^5;5^Q "^DD",410,410,34,3) Enter YES for Auto Accrual; enter NO for no Auto Accrual. "^DD",410,410,34,21,0) ^.001^2^2^3110614^^^ "^DD",410,410,34,21,1,0) This field is used by Fiscal service to indicate whether a 1358 "^DD",410,410,34,21,2,0) Obligation should be accrued in FMS. "^DD",410,410,34,"DT") 3110614 "BLD",6649,6) ^134 **END** **END**