Released PRC*5.1*174 SEQ #154 Extracted from mail message **KIDS**:PRC*5.1*174^ **INSTALL NAME** PRC*5.1*174 "BLD",7273,0) PRC*5.1*174^IFCAP^0^3130728^y "BLD",7273,1,0) ^^2^2^3130716^^ "BLD",7273,1,1,0) This patch delivers Phase 2, Increment 1 of the IFCAP/eCMS Interface "BLD",7273,1,2,0) project. "BLD",7273,4,0) ^9.64PA^410^3 "BLD",7273,4,410,0) 410 "BLD",7273,4,410,2,0) ^9.641^410^1 "BLD",7273,4,410,2,410,0) CONTROL POINT ACTIVITY (File-top level) "BLD",7273,4,410,2,410,1,0) ^9.6411^6.3^3 "BLD",7273,4,410,2,410,1,6.3,0) REQUESTING SERVICE "BLD",7273,4,410,2,410,1,104,0) CANCELLED BY "BLD",7273,4,410,2,410,1,105,0) CANCEL DATE/TIME "BLD",7273,4,410,222) y^n^p^^^^n^^n "BLD",7273,4,410,224) "BLD",7273,4,414.06,0) 414.06 "BLD",7273,4,414.06,2,0) ^9.641^414.06^2 "BLD",7273,4,414.06,2,414.06,0) IFCAP/ECMS TRANSACTION (File-top level) "BLD",7273,4,414.06,2,414.06,1,0) ^9.6411^.01^1 "BLD",7273,4,414.06,2,414.06,1,.01,0) IFCAP REFERENCE NUMBER "BLD",7273,4,414.06,2,414.061,0) EVENT (sub-file) "BLD",7273,4,414.06,2,414.061,1,0) ^9.6411^6^2 "BLD",7273,4,414.06,2,414.061,1,.02,0) EVENT TYPE "BLD",7273,4,414.06,2,414.061,1,6,0) ECMS EMAIL "BLD",7273,4,414.06,222) y^y^p^^^^n^^n "BLD",7273,4,414.06,224) "BLD",7273,4,414.07,0) 414.07 "BLD",7273,4,414.07,222) y^y^f^^n^^y^o^n "BLD",7273,4,414.07,224) I Y<12 "BLD",7273,4,"APDD",410,410) "BLD",7273,4,"APDD",410,410,6.3) "BLD",7273,4,"APDD",410,410,104) "BLD",7273,4,"APDD",410,410,105) "BLD",7273,4,"APDD",414.06,414.06) "BLD",7273,4,"APDD",414.06,414.06,.01) "BLD",7273,4,"APDD",414.06,414.061) "BLD",7273,4,"APDD",414.06,414.061,.02) "BLD",7273,4,"APDD",414.06,414.061,6) "BLD",7273,4,"B",410,410) "BLD",7273,4,"B",414.06,414.06) "BLD",7273,4,"B",414.07,414.07) "BLD",7273,6) ^131 "BLD",7273,6.3) 23 "BLD",7273,"ABPKG") n "BLD",7273,"INID") y^y "BLD",7273,"INIT") POST^PRC174P "BLD",7273,"KRN",0) ^9.67PA^779.2^20 "BLD",7273,"KRN",.4,0) .4 "BLD",7273,"KRN",.4,"NM",0) ^9.68A^^ "BLD",7273,"KRN",.401,0) .401 "BLD",7273,"KRN",.401,"NM",0) ^9.68A^1^1 "BLD",7273,"KRN",.401,"NM",1,0) PRCH OUTSTANDING REQUEST/PA FILE #443^443^0 "BLD",7273,"KRN",.401,"NM","B","PRCH OUTSTANDING REQUEST/PA FILE #443",1) "BLD",7273,"KRN",.402,0) .402 "BLD",7273,"KRN",.402,"NM",0) ^9.68A^3^3 "BLD",7273,"KRN",.402,"NM",1,0) PRCSEN2237B FILE #410^410^0 "BLD",7273,"KRN",.402,"NM",2,0) PRCSENR&NR FILE #410^410^0 "BLD",7273,"KRN",.402,"NM",3,0) PRCSENPR FILE #410^410^0 "BLD",7273,"KRN",.402,"NM","B","PRCSEN2237B FILE #410",1) "BLD",7273,"KRN",.402,"NM","B","PRCSENPR FILE #410",3) "BLD",7273,"KRN",.402,"NM","B","PRCSENR&NR FILE #410",2) "BLD",7273,"KRN",.403,0) .403 "BLD",7273,"KRN",.5,0) .5 "BLD",7273,"KRN",.84,0) .84 "BLD",7273,"KRN",3.6,0) 3.6 "BLD",7273,"KRN",3.8,0) 3.8 "BLD",7273,"KRN",3.8,"NM",0) ^9.68A^^0 "BLD",7273,"KRN",9.2,0) 9.2 "BLD",7273,"KRN",9.8,0) 9.8 "BLD",7273,"KRN",9.8,"NM",0) ^9.68A^30^24 "BLD",7273,"KRN",9.8,"NM",1,0) PRCHG^^0^B46345680 "BLD",7273,"KRN",9.8,"NM",5,0) PRCHJS01^^0^B34864195 "BLD",7273,"KRN",9.8,"NM",6,0) PRCHJS07^^0^B50659801 "BLD",7273,"KRN",9.8,"NM",7,0) PRCHJS05^^0^B105148815 "BLD",7273,"KRN",9.8,"NM",8,0) PRCSD12^^0^B5349838 "BLD",7273,"KRN",9.8,"NM",9,0) PRCSP12^^0^B8060908 "BLD",7273,"KRN",9.8,"NM",10,0) PRCHJR01^^0^B172209901 "BLD",7273,"KRN",9.8,"NM",11,0) PRCHJUTL^^0^B45318911 "BLD",7273,"KRN",9.8,"NM",12,0) PRCSEB^^0^B19745869 "BLD",7273,"KRN",9.8,"NM",15,0) PRCHJMSG^^0^B13099425 "BLD",7273,"KRN",9.8,"NM",16,0) PRCSEA^^0^B77709239 "BLD",7273,"KRN",9.8,"NM",18,0) PRCSUT2^^0^B58831488 "BLD",7273,"KRN",9.8,"NM",19,0) PRCSEB0^^0^B23160815 "BLD",7273,"KRN",9.8,"NM",20,0) PRCHJR03^^0^B10192642 "BLD",7273,"KRN",9.8,"NM",21,0) PRCSAPP1^^0^B16255463 "BLD",7273,"KRN",9.8,"NM",22,0) PRCSECP^^0^B39428501 "BLD",7273,"KRN",9.8,"NM",23,0) PRCSCK^^0^B65643316 "BLD",7273,"KRN",9.8,"NM",24,0) PRCSP13^^0^B22261437 "BLD",7273,"KRN",9.8,"NM",25,0) PRCHJTA^^0^B46759830 "BLD",7273,"KRN",9.8,"NM",26,0) PRCHJRP5^^0^B131946291 "BLD",7273,"KRN",9.8,"NM",27,0) PRCHJRP6^^0^B82490228 "BLD",7273,"KRN",9.8,"NM",28,0) PRCHJRP1^^1^ "BLD",7273,"KRN",9.8,"NM",29,0) PRCHJRP2^^1^ "BLD",7273,"KRN",9.8,"NM",30,0) PRCHJS02^^0^B161312507 "BLD",7273,"KRN",9.8,"NM","B","PRCHG",1) "BLD",7273,"KRN",9.8,"NM","B","PRCHJMSG",15) "BLD",7273,"KRN",9.8,"NM","B","PRCHJR01",10) "BLD",7273,"KRN",9.8,"NM","B","PRCHJR03",20) "BLD",7273,"KRN",9.8,"NM","B","PRCHJRP1",28) "BLD",7273,"KRN",9.8,"NM","B","PRCHJRP2",29) "BLD",7273,"KRN",9.8,"NM","B","PRCHJRP5",26) "BLD",7273,"KRN",9.8,"NM","B","PRCHJRP6",27) "BLD",7273,"KRN",9.8,"NM","B","PRCHJS01",5) "BLD",7273,"KRN",9.8,"NM","B","PRCHJS02",30) "BLD",7273,"KRN",9.8,"NM","B","PRCHJS05",7) "BLD",7273,"KRN",9.8,"NM","B","PRCHJS07",6) "BLD",7273,"KRN",9.8,"NM","B","PRCHJTA",25) "BLD",7273,"KRN",9.8,"NM","B","PRCHJUTL",11) "BLD",7273,"KRN",9.8,"NM","B","PRCSAPP1",21) "BLD",7273,"KRN",9.8,"NM","B","PRCSCK",23) "BLD",7273,"KRN",9.8,"NM","B","PRCSD12",8) "BLD",7273,"KRN",9.8,"NM","B","PRCSEA",16) "BLD",7273,"KRN",9.8,"NM","B","PRCSEB",12) "BLD",7273,"KRN",9.8,"NM","B","PRCSEB0",19) "BLD",7273,"KRN",9.8,"NM","B","PRCSECP",22) "BLD",7273,"KRN",9.8,"NM","B","PRCSP12",9) "BLD",7273,"KRN",9.8,"NM","B","PRCSP13",24) "BLD",7273,"KRN",9.8,"NM","B","PRCSUT2",18) "BLD",7273,"KRN",19,0) 19 "BLD",7273,"KRN",19,"NM",0) ^9.68A^7^7 "BLD",7273,"KRN",19,"NM",1,0) PRCHJ RETRANS 2237^^0 "BLD",7273,"KRN",19,"NM",2,0) PRCHOUT OUTST 2237/PA^^0 "BLD",7273,"KRN",19,"NM",3,0) PRCHJ TRANS REPORT^^0 "BLD",7273,"KRN",19,"NM",4,0) PRCHJ TRANS REPORT2^^0 "BLD",7273,"KRN",19,"NM",5,0) PRCHJ TRANS REPORT3^^0 "BLD",7273,"KRN",19,"NM",6,0) PRCFA UTILITY^^2 "BLD",7273,"KRN",19,"NM",7,0) PRCB UTILITIES^^2 "BLD",7273,"KRN",19,"NM","B","PRCB UTILITIES",7) "BLD",7273,"KRN",19,"NM","B","PRCFA UTILITY",6) "BLD",7273,"KRN",19,"NM","B","PRCHJ RETRANS 2237",1) "BLD",7273,"KRN",19,"NM","B","PRCHJ TRANS REPORT",3) "BLD",7273,"KRN",19,"NM","B","PRCHJ TRANS REPORT2",4) "BLD",7273,"KRN",19,"NM","B","PRCHJ TRANS REPORT3",5) "BLD",7273,"KRN",19,"NM","B","PRCHOUT OUTST 2237/PA",2) "BLD",7273,"KRN",19.1,0) 19.1 "BLD",7273,"KRN",19.1,"NM",0) ^9.68A^1^1 "BLD",7273,"KRN",19.1,"NM",1,0) PRCHJFIS^^0 "BLD",7273,"KRN",19.1,"NM","B","PRCHJFIS",1) "BLD",7273,"KRN",101,0) 101 "BLD",7273,"KRN",409.61,0) 409.61 "BLD",7273,"KRN",771,0) 771 "BLD",7273,"KRN",779.2,0) 779.2 "BLD",7273,"KRN",779.2,"NM",0) ^9.68A^^0 "BLD",7273,"KRN",870,0) 870 "BLD",7273,"KRN",870,"NM",0) ^9.68A^^0 "BLD",7273,"KRN",8989.51,0) 8989.51 "BLD",7273,"KRN",8989.51,"NM",0) ^9.68A^^0 "BLD",7273,"KRN",8989.52,0) 8989.52 "BLD",7273,"KRN",8994,0) 8994 "BLD",7273,"KRN","B",.4,.4) "BLD",7273,"KRN","B",.401,.401) "BLD",7273,"KRN","B",.402,.402) "BLD",7273,"KRN","B",.403,.403) "BLD",7273,"KRN","B",.5,.5) "BLD",7273,"KRN","B",.84,.84) "BLD",7273,"KRN","B",3.6,3.6) "BLD",7273,"KRN","B",3.8,3.8) "BLD",7273,"KRN","B",9.2,9.2) "BLD",7273,"KRN","B",9.8,9.8) "BLD",7273,"KRN","B",19,19) "BLD",7273,"KRN","B",19.1,19.1) "BLD",7273,"KRN","B",101,101) "BLD",7273,"KRN","B",409.61,409.61) "BLD",7273,"KRN","B",771,771) "BLD",7273,"KRN","B",779.2,779.2) "BLD",7273,"KRN","B",870,870) "BLD",7273,"KRN","B",8989.51,8989.51) "BLD",7273,"KRN","B",8989.52,8989.52) "BLD",7273,"KRN","B",8994,8994) "BLD",7273,"PRE") PRC174P "BLD",7273,"QUES",0) ^9.62^^ "BLD",7273,"REQB",0) ^9.611^3^3 "BLD",7273,"REQB",1,0) PRC*5.1*167^2 "BLD",7273,"REQB",2,0) HL*1.6*158^2 "BLD",7273,"REQB",3,0) PRC*5.1*150^2 "BLD",7273,"REQB","B","HL*1.6*158",2) "BLD",7273,"REQB","B","PRC*5.1*150",3) "BLD",7273,"REQB","B","PRC*5.1*167",1) "DATA",414.07,1,0) 2237 SENT^^2237 has been sent to eCMS, but has yet to be acknowledged. "DATA",414.07,2,0) 2237 ACKNOWLEDGED^^2237 has been acknowledged by eCMS. Transmission handshaking complete. "DATA",414.07,3,0) 2237 APPLICATION ERROR^^eCMS has reported an error associated with this 2237. The error needs to be investigated. "DATA",414.07,4,0) 2237 RESENT^^2237 has been resent to eCMS due to an error that caused missing eCMS Identifiers in IFCAP. "DATA",414.07,6,0) RETURN TO ACCOUNTABLE OFFICER^^2237 has been returned by eCMS to the Accountable Officer's attention. "DATA",414.07,7,0) RETURN TO AO ACK^^IFCAP has sent an Application Acknowledgement for the RETURN TO AO. "DATA",414.07,8,0) RETURN TO CONTROL POINT^^2237 has been returned by eCMS to the Control Point official's attention. "DATA",414.07,9,0) RETURN TO CP ACK^^IFCAP has sent an Application Acknowledgement for the RETURN TO CP. "DATA",414.07,10,0) 2237 CANCELLED BY ECMS^^2237 Cancelled by eCMS. "DATA",414.07,11,0) 2237 CANCEL ACK TO ECMS^^IFCAP has sent an Application Acknowledgement for the CANCEL. "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,6.3) "FIA",410,410,104) "FIA",410,410,105) "FIA",414.06) IFCAP/ECMS TRANSACTION "FIA",414.06,0) ^PRCV(414.06, "FIA",414.06,0,0) 414.06 "FIA",414.06,0,1) y^y^p^^^^n^^n "FIA",414.06,0,10) "FIA",414.06,0,11) "FIA",414.06,0,"RLRO") "FIA",414.06,0,"VR") 5.1^PRC "FIA",414.06,414.06) 1 "FIA",414.06,414.06,.01) "FIA",414.06,414.061) 1 "FIA",414.06,414.061,.02) "FIA",414.06,414.061,6) "FIA",414.07) IFCAP/ECMS EVENT TYPE "FIA",414.07,0) ^PRCV(414.07, "FIA",414.07,0,0) 414.07 "FIA",414.07,0,1) y^y^f^^n^^y^o^n "FIA",414.07,0,10) "FIA",414.07,0,11) I Y<12 "FIA",414.07,0,"RLRO") "FIA",414.07,0,"VR") 5.1^PRC "FIA",414.07,414.07) 0 "INIT") POST^PRC174P "IX",414.06,414.06,"ACONTACT",0) 414.06^ACONTACT^ECMS CONTACT^R^^F^IR^W^414.061^^^^^S "IX",414.06,414.06,"ACONTACT",.1,0) ^^1^1^3120808^^ "IX",414.06,414.06,"ACONTACT",.1,1,0) File wide to assist with the sorting of eCMS Contact information. "IX",414.06,414.06,"ACONTACT",1) S ^PRCV(414.06,"ACONTACT",$E(X,1,60),DA(1),DA)="" "IX",414.06,414.06,"ACONTACT",2) K ^PRCV(414.06,"ACONTACT",$E(X,1,60),DA(1),DA) "IX",414.06,414.06,"ACONTACT",2.5) K ^PRCV(414.06,"ACONTACT") "IX",414.06,414.06,"ACONTACT",11.1,0) ^.114IA^1^1 "IX",414.06,414.06,"ACONTACT",11.1,1,0) 1^F^414.061^6^60^1^F "IX",414.06,414.06,"ACONTACT",11.1,1,2) S X=$$CONTACT^PRCHJTA(X) "IX",414.06,414.06,"ACONTACT",11.1,1,3) "IX",414.06,414.06,"ACP",0) 414.06^ACP^Fund control point^R^^F^IR^I^414.06^^^^^S "IX",414.06,414.06,"ACP",.1,0) ^^1^1^3120726^ "IX",414.06,414.06,"ACP",.1,1,0) Index uses only the fund control point portion of the reference number. "IX",414.06,414.06,"ACP",1) S ^PRCV(414.06,"ACP",$E(X,1,30),DA)="" "IX",414.06,414.06,"ACP",2) K ^PRCV(414.06,"ACP",$E(X,1,30),DA) "IX",414.06,414.06,"ACP",2.5) K ^PRCV(414.06,"ACP") "IX",414.06,414.06,"ACP",11.1,0) ^.114IA^1^1 "IX",414.06,414.06,"ACP",11.1,1,0) 1^F^414.06^.01^30^1^F "IX",414.06,414.06,"ACP",11.1,1,2) S X=$P(X,"-",4) "IX",414.06,414.06,"ACP",11.1,1,3) "IX",414.06,414.06,"AUNQEC",0) 414.06^AUNQEC^Unique eCMS Contact^R^^F^IR^W^414.061^^^^^S "IX",414.06,414.06,"AUNQEC",.1,0) ^^6^6^3130620^^^^ "IX",414.06,414.06,"AUNQEC",.1,1,0) This index provides a list of unique eCMS email addresses in "IX",414.06,414.06,"AUNQEC",.1,2,0) a format compatible with end user selection. "IX",414.06,414.06,"AUNQEC",.1,3,0) The Set Condition ensures that only one instance of any ECMS EMAIL is "IX",414.06,414.06,"AUNQEC",.1,4,0) in the index. "IX",414.06,414.06,"AUNQEC",.1,5,0) The Storage Transform converts the email address into a format that "IX",414.06,414.06,"AUNQEC",.1,6,0) parses it into a form more suitable for sorting. "IX",414.06,414.06,"AUNQEC",1) S ^PRCV(414.06,"AUNQEC",$E(X,1,90),DA(1),DA)="" "IX",414.06,414.06,"AUNQEC",1.4) S X=$D(^PRCV(414.06,"AUNQEC",X))'=10 "IX",414.06,414.06,"AUNQEC",2) K ^PRCV(414.06,"AUNQEC",$E(X,1,90),DA(1),DA) "IX",414.06,414.06,"AUNQEC",2.5) K ^PRCV(414.06,"AUNQEC") "IX",414.06,414.06,"AUNQEC",11.1,0) ^.114IA^1^1 "IX",414.06,414.06,"AUNQEC",11.1,1,0) 1^F^414.061^6^90^1^F "IX",414.06,414.06,"AUNQEC",11.1,1,2) S X=$$CONTACT^PRCHJTA(X)_" "_X "IX",414.06,414.06,"AUNQEC",11.1,1,4) "IX",414.06,414.06,"AUNQFCP",0) 414.06^AUNQFCP^List of all unique FCPs.^R^^F^IR^I^414.06^^^^^S "IX",414.06,414.06,"AUNQFCP",.1,0) ^^3^3^3130620^^ "IX",414.06,414.06,"AUNQFCP",.1,1,0) Index uses only the fund control point portion of the reference number. "IX",414.06,414.06,"AUNQFCP",.1,2,0) The Set Condition ensures that only one instance of any fund control point "IX",414.06,414.06,"AUNQFCP",.1,3,0) is in the index. "IX",414.06,414.06,"AUNQFCP",1) S ^PRCV(414.06,"AUNQFCP",$E(X,1,30),DA)="" "IX",414.06,414.06,"AUNQFCP",1.4) S X=$D(^PRCV(414.06,"AUNQFCP",X))'=10 "IX",414.06,414.06,"AUNQFCP",2) K ^PRCV(414.06,"AUNQFCP",$E(X,1,30),DA) "IX",414.06,414.06,"AUNQFCP",2.5) K ^PRCV(414.06,"AUNQFCP") "IX",414.06,414.06,"AUNQFCP",11.1,0) ^.114IA^1^1 "IX",414.06,414.06,"AUNQFCP",11.1,1,0) 1^F^414.06^.01^30^1^F "IX",414.06,414.06,"AUNQFCP",11.1,1,2) S X=$P(X,"-",4) "KRN",.401,1753,-1) 0^1 "KRN",.401,1753,0) PRCH OUTSTANDING REQUEST/PA^3130306.1545^^443^^^3130626 "KRN",.401,1753,2,0) ^.4014^4^4 "KRN",.401,1753,2,1,0) 443^^INTERNAL(#1.5)^'"^^^^^^4 "KRN",.401,1753,2,1,"CM") S Y(1)=$S($D(^PRC(443,D0,0)):^(0),1:"") S X=$P(Y(1),U,7),X=X I D0>0 S DISX(1)=X "KRN",.401,1753,2,1,"F") 68.999999^69 "KRN",.401,1753,2,1,"GET") S Y(1)=$S($D(^PRC(443,D0,0)):^(0),1:"") S X=$P(Y(1),U,7),X=X I D0>0 S DISX(1)=X "KRN",.401,1753,2,1,"QCON") I (DISX(1)]]68.999999)&(DISX(1)']]80) "KRN",.401,1753,2,1,"T") 80^80 "KRN",.401,1753,2,1,"TXT") INTERNAL(#1.5) from 69 to 80 "KRN",.401,1753,2,2,0) 443^^PURCHASING AGENT^+"6^;S2;C17^^^^^4 "KRN",.401,1753,2,2,"CM") S Y(1)=$S($D(^PRC(443,D0,0)):^(0),1:"") S X=$P($G(^VA(200,+$P(Y(1),U,5),0)),U) I D0>0 S DISX(2)=X "KRN",.401,1753,2,2,"F") ?z^@ "KRN",.401,1753,2,2,"GET") S Y(1)=$S($D(^PRC(443,D0,0)):^(0),1:"") S X=$P($G(^VA(200,+$P(Y(1),U,5),0)),U) I D0>0 S DISX(2)=X "KRN",.401,1753,2,2,"QCON") I 1 "KRN",.401,1753,2,2,"T") z^ "KRN",.401,1753,2,2,"TXT") All PURCHASING AGENT (includes nulls) "KRN",.401,1753,2,3,0) 443^^.01:DATE REQUIRED^"^;"DATE REQUIRED: ";C5;S1^^D^^^1 "KRN",.401,1753,2,3,"CM") S I(0,0)=$G(D0),Y(1)=$S($D(^PRC(443,D0,0)):^(0),1:""),D0=$P(Y(1),U,1) S:'D0!'$D(^PRCS(410,+D0,0)) D0=-1 S Y(101)=$S($D(^PRCS(410,D0,1)):^(1),1:"") S X=$P(Y(101),U,4) S D0=I(0,0) I D0>0 S DISX(3)=X "KRN",.401,1753,2,3,"GET") S I(0,0)=$G(D0),Y(1)=$S($D(^PRC(443,D0,0)):^(0),1:""),D0=$P(Y(1),U,1) S:'D0!'$D(^PRCS(410,+D0,0)) D0=-1 S Y(101)=$S($D(^PRCS(410,D0,1)):^(1),1:"") S X=$P(Y(101),U,4) S D0=I(0,0) I D0>0 S DISX(3)=X "KRN",.401,1753,2,3,"QCON") I DISX(3)'="" "KRN",.401,1753,2,3,"TXT") .01:DATE REQUIRED not null "KRN",.401,1753,2,4,0) 443^^2237 TRANSACTION NUMBER^".01^^^^^^4 "KRN",.401,1753,2,4,"CM") S Y(1)=$S($D(^PRC(443,D0,0)):^(0),1:"") S X=$P($G(^PRCS(410,+$P(Y(1),U,1),0)),U) I D0>0 S DISX(4)=X "KRN",.401,1753,2,4,"GET") S Y(1)=$S($D(^PRC(443,D0,0)):^(0),1:"") S X=$P($G(^PRCS(410,+$P(Y(1),U,1),0)),U) I D0>0 S DISX(4)=X "KRN",.401,1753,2,4,"IX") ^PRC(443,"B",^PRC(443,^2 "KRN",.401,1753,2,4,"PTRIX") ^PRCS(410,"B", "KRN",.401,1753,2,4,"QCON") I DISX(4)'="" "KRN",.401,1753,2,4,"SER") 0.0000^0.0000 "KRN",.401,1753,2,4,"TXT") 2237 TRANSACTION NUMBER not null "KRN",.401,1753,2,"B",443,1) "KRN",.401,1753,2,"B",443,2) "KRN",.401,1753,2,"B",443,3) "KRN",.401,1753,2,"B",443,4) "KRN",.401,1753,"%D",0) ^^2^2^3130306^ "KRN",.401,1753,"%D",1,0) This template helps select 2237s to display, as well as, provide "KRN",.401,1753,"%D",2,0) sort parameters for display of outstanding 2237s. "KRN",.402,2468,-1) 0^1 "KRN",.402,2468,0) PRCSEN2237B^3130528.1517^^410^^^3130725 "KRN",.402,2468,"DIAB",1,2,410.212,1) 1: "KRN",.402,2468,"DIAB",4,0,410,3) DATE SIGNED (APPROVED)//TODAY "KRN",.402,2468,"DIAB",6,0,410,0) DATE OF REQUEST//TODAY "KRN",.402,2468,"DIAB",7,0,410,0) REQUESTING SERVICE;REQ "KRN",.402,2468,"DIAB",8,0,410,2) DATE COMMITTED//TODAY "KRN",.402,2468,"DR",1,410) I $D(PRCSERR),PRCSERR S Y="@1";1///O;8;49;Q;5//^N %I,%H,% D NOW^%DTC;6.3R~;7;S PRCSTDT=X;7.5//ST;9;S X=$$GETCCCNT^PRCSECP(PRC("SITE"),PRC("CP")) I (+X=1) S $P(^PRCS(410,DA,3),U,3)=$P(X,U,2),Y="@33" W !,"COST CENTER: ",$P(X,U,2); "KRN",.402,2468,"DR",1,410,1) 15.5;@33;I $D(^PRCS(410,T1,3)),$P(^(3),U,4)]"" S $P(^PRCS(410,DA,3),U,4)=$P(^PRCS(410,T1,3),U,4);11;I $D(Z(1))!('$D(Z("Z"))) S Y="@1";11;11.1;I X="" S Y=11.5;11.2;I X="" S Y=11.5;11.3;I X="" S Y=11.5;11.4;11.5;11.6;11.7;11.8;11.9; "KRN",.402,2468,"DR",1,410,2) @1;10;D CHKITDES^PRCSCK(DA);D EX1^PRCSCK,^PRCSCK;I $D(PRCSERR),PRCSERR S Y="@1" K PRCSERR,PRCSF,PRCSI;20;Q;21//^N %I,%H,% D NOW^%DTC;I $D(PRCSJP) S Y=48.1;D RB^PRCSCK;16;48.1;46;45;40; "KRN",.402,2468,"DR",1,410,3) I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),"^",11)="Y" S Y=68;42;Q;44//^N %I,%H,% D NOW^%DTC;68;K PRCSJP,PRCSTDT;60; "KRN",.402,2468,"DR",2,410.02) I '$D(PRCSTDT) S PRCSTDT=$S($D(^PRCS(410,DA(1),1)):$P(^(0),U,4),1:"");@1;.01//1;1;I X="^" S Y="@1";I '$$ITDES^PRCHJUTL(DA(1),DA) W !," Item DESCRIPTION is required!",*7 S Y=1;2;3;6;7; "KRN",.402,2468,"DR",2,410.02,1) S X=$P($G(^PRCS(410,DA(1),3)),U,3) I X]"" S X=$$GETBOCNT^PRCSECP(PRC("SITE"),+PRC("CP"),+X) I (+X=1) S $P(^PRCS(410,DA(1),"IT",DA,0),U,4)=$P(X,U,2),Y="@44" W !,"BOC: ",$P(X,U,2);4//^S X="" S:$D(PRCS("SUB")) X=PRCS("SUB");@44; "KRN",.402,2468,"DR",2,410.02,2) I $D(^PRC(411,PRC("SITE"),0)),$P(^(0),U,18)'="Y" S Y="@3";10;@3;D 2^PRCSCK;I $D(PRCSERR),PRCSERR S Y=PRCSERR K PRCSERR;D QRB^PRCSCK;12;K PRCSMDP; "KRN",.402,2468,"DR",2,410.04) .01;1;D RB1^PRCSCK; "KRN",.402,2468,"DR",3,410.212) .01;S PRCSMDP=$P(^PRCS(410,DA(2),0),U)_"-"_DA(1)_"-"_$P(^PRCS(410,DA(2),"IT",DA(1),2,DA,0),U);1///^S X=PRCSMDP;D QRB1^PRCSCK; "KRN",.402,2468,"DR",3,410.212,1) ^410.6^PRCS(410.6,^^S I(2,0)=D2 S I(1,0)=D1 S I(0,0)=D0 S Y(1)=$S($D(^PRCS(410,D0,"IT",D1,"2",D2,0)):^(0),1:"") S X=$P(Y(1),U,2),X=X S D(0)=+X S X=$S(D(0)>0:D(0),1:""); "KRN",.402,2468,"DR",4,410.6) 1;I X0:D(0),1:""); "KRN",.402,2471,"DR",4,410.6) 1;I X0:D(0),1:""); "KRN",.402,2473,"DR",4,410.6) 1;I X>> Check programmer variables..." "RTN","PRC174P",19,0) D PROGCHK(.XPDABORT) "RTN","PRC174P",20,0) Q:XPDABORT=2 "RTN","PRC174P",21,0) W "Successful" "RTN","PRC174P",22,0) ; "RTN","PRC174P",23,0) ;success "RTN","PRC174P",24,0) I XPDABORT="" K XPDABORT "RTN","PRC174P",25,0) Q "RTN","PRC174P",26,0) ; "RTN","PRC174P",27,0) ; "RTN","PRC174P",28,0) PRE ;Main entry point for Pre-init items "RTN","PRC174P",29,0) Q "RTN","PRC174P",30,0) ; "RTN","PRC174P",31,0) ; "RTN","PRC174P",32,0) POST ;Main entry point for Post-init items "RTN","PRC174P",33,0) ; "RTN","PRC174P",34,0) ; Supported ICRs: "RTN","PRC174P",35,0) ; #10141 - Allows use of supported Kernel call BMES^XPDUTL "RTN","PRC174P",36,0) ; #5819 - Allows setting of ID nodes within a file DD. "RTN","PRC174P",37,0) ; "RTN","PRC174P",38,0) ; "RTN","PRC174P",39,0) ;Item 1 - kill extraneous temp global node being set in patch PRC*5.1*167 "RTN","PRC174P",40,0) D BMES^XPDUTL(">>> Cleaning up extraneous temporary global node...") "RTN","PRC174P",41,0) K ^TMP("KCLTST","AOESIG") "RTN","PRC174P",42,0) D MES^XPDUTL(" Cleanup completed.") "RTN","PRC174P",43,0) ; "RTN","PRC174P",44,0) ;Item 2 - set ID node for Control Point Activity (#410) file. Change covered by ICR #5819 "RTN","PRC174P",45,0) D BMES^XPDUTL(">>> Setting ID node for Control Point Activity file #410...") "RTN","PRC174P",46,0) S ^DD(410,0,"ID","Z3")="D:$P($G(^(1)),U,8)]"""" EN^DDIOL(""Accepted by eCMS"",,""?0""),EN^DDIOL("" "",,""!?2"")" "RTN","PRC174P",47,0) D MES^XPDUTL(" Setting ID node completed.") "RTN","PRC174P",48,0) ; "RTN","PRC174P",49,0) ;Item 3 - data clean-up - store Station and Sub-station as appropriate for OUTBOUND events in file 414.06 "RTN","PRC174P",50,0) D BMES^XPDUTL(">>> Storing IFCAP/ECMS TRANSACTION #414.06 missing station/sub-station data...") "RTN","PRC174P",51,0) ; Loop on the file-wide AED index to check every event in the file "RTN","PRC174P",52,0) S PRCHEVDT=0 "RTN","PRC174P",53,0) F S PRCHEVDT=$O(^PRCV(414.06,"AED",PRCHEVDT)) Q:+PRCHEVDT'>0 D "RTN","PRC174P",54,0) . S PRCHIEN=0 "RTN","PRC174P",55,0) . F S PRCHIEN=$O(^PRCV(414.06,"AED",PRCHEVDT,PRCHIEN)) Q:+PRCHIEN'>0 D "RTN","PRC174P",56,0) .. S PRCHEIEN=0 "RTN","PRC174P",57,0) .. F S PRCHEIEN=$O(^PRCV(414.06,"AED",PRCHEVDT,PRCHIEN,PRCHEIEN)) Q:+PRCHEIEN'>0 S PRCH410=$P(^PRCV(414.06,PRCHIEN,0),"^",3),PRCHTYPE=$P(^PRCV(414.06,PRCHIEN,1,PRCHEIEN,0),"^",2) D "RTN","PRC174P",58,0) ... K PRC41406 S PRCHGO=0 "RTN","PRC174P",59,0) ... I (PRCHTYPE=1)!(PRCHTYPE=4) D GETSTN^PRCHJTA(PRCH410) D "RTN","PRC174P",60,0) .... S:PRCVSTN'="" PRC41406(414.061,PRCHEIEN_","_PRCHIEN_",",1)=PRCVSTN,PRCHGO=1 "RTN","PRC174P",61,0) .... S:PRCVSUB'="" PRC41406(414.061,PRCHEIEN_","_PRCHIEN_",",2)=PRCVSUB,PRCHGO=1 "RTN","PRC174P",62,0) .... D:PRCHGO FILE^DIE("","PRC41406") "RTN","PRC174P",63,0) ....Q "RTN","PRC174P",64,0) ...Q "RTN","PRC174P",65,0) ..Q "RTN","PRC174P",66,0) .Q "RTN","PRC174P",67,0) K PRCHEVDT,PRCHIEN,PRCHEIEN,PRCH410,PRCHTYPE,PRCVSTN,PRCVSUB,PRCH41406,PRCHGO "RTN","PRC174P",68,0) D MES^XPDUTL(" Storing missing data completed.") "RTN","PRC174P",69,0) ; "RTN","PRC174P",70,0) ;Item 4 - data clean-up - store Station and Sub-station as appropriate for OUTBOUND events in file 414.06 "RTN","PRC174P",71,0) D BMES^XPDUTL(">>> Building new cross-references ""AUNQFCP"" and ""AUNQEC"" in IFCAP/ECMS TRANSACTION #414.06...") "RTN","PRC174P",72,0) ; Build AUNQFCP "RTN","PRC174P",73,0) S DIK="^PRCV(414.06,",DIK(1)=".01^AUNQFCP" "RTN","PRC174P",74,0) D ENALL^DIK K DIK "RTN","PRC174P",75,0) ; Build AUNQEC "RTN","PRC174P",76,0) N DA S PRCHIEN=0 "RTN","PRC174P",77,0) F S PRCHIEN=$O(^PRCV(414.06,PRCHIEN)) Q:+PRCHIEN'>0 S DA(1)=PRCHIEN,DIK(1)="6^AUNQEC",DIK="^PRCV(414.06,"_DA(1)_",1," D ENALL^DIK K DIK "RTN","PRC174P",78,0) K PRCHIEN "RTN","PRC174P",79,0) D MES^XPDUTL(" Cross-references ""AUNQFCP"" and ""AUNQEC"" have been built.") "RTN","PRC174P",80,0) Q "RTN","PRC174P",81,0) ; "RTN","PRC174P",82,0) PROGCHK(XPDABORT) ;Check for required programmer variables "RTN","PRC174P",83,0) ;This procedure will determine if the installers programmer variables are set up. "RTN","PRC174P",84,0) ;Per KIDS documentation: During the environment check routine, use of direct "RTN","PRC174P",85,0) ;WRITEs must be used for output messages. "RTN","PRC174P",86,0) ; "RTN","PRC174P",87,0) ; Input: "RTN","PRC174P",88,0) ; XPDABORT - KIDS var to indicate if install should "RTN","PRC174P",89,0) ; abort, passed by reference "RTN","PRC174P",90,0) ; "RTN","PRC174P",91,0) ; Output: "RTN","PRC174P",92,0) ; XPDABORT - if = 2, then abort entire installation "RTN","PRC174P",93,0) ; "RTN","PRC174P",94,0) I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") D "RTN","PRC174P",95,0) . W !!," **********" "RTN","PRC174P",96,0) . W !," ERROR: Environment check failed!" "RTN","PRC174P",97,0) . W !," Your programming variables are not set up properly. Once" "RTN","PRC174P",98,0) . W !," your programming variables are set up correctly, re-install" "RTN","PRC174P",99,0) . W !," this patch PRC*5.1*174." "RTN","PRC174P",100,0) . W !," **********" "RTN","PRC174P",101,0) . ;tell KIDS to abort the entire installation of the distribution "RTN","PRC174P",102,0) . S XPDABORT=2 "RTN","PRC174P",103,0) Q "RTN","PRCHG") 0^1^B46345680^B45716254 "RTN","PRCHG",1,0) PRCHG ;ID/RSD,SF-ISC/TKW/DAP-PROCESS 2237 ;5/8/13 15:39 "RTN","PRCHG",2,0) V ;;5.1;IFCAP;**81,167,174**;Oct 20, 2000;Build 23 "RTN","PRCHG",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCHG",4,0) ; "RTN","PRCHG",5,0) ES ;SIGN 2237 IN PPM "RTN","PRCHG",6,0) G Q:'$D(PRC("PER"))!('$D(PRC("SITE"))) I $S('$D(^VA(200,+PRC("PER"),400)):1,$P(^(400),U,1)=4:0,$P(^(400),U,1)=2:0,1:1) W !!,"You are not a Supply Accountable Officer !",$C(7) G Q "RTN","PRCHG",7,0) S P=+PRC("PER"),DA=1,PRCSIG="" D ESIG^PRCUESIG(DUZ,.PRCSIG) S ROUTINE="PRCUESIG" G:PRCSIG'=1 QQ S PRCHNM=$P(^VA(200,P,20),U,2) "RTN","PRCHG",8,0) Q "RTN","PRCHG",9,0) ; "RTN","PRCHG",10,0) ES1 ;S PRCHG=$S($D(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)):$P(^(0),U,2),1:""),$P(^PRC(443,DA,0),"^",3)="",P=+PRC("PER") "RTN","PRCHG",11,0) S PRCHG=$P($G(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)),U,2),$P(^PRC(443,DA,0),"^",3)="",P=+PRC("PER") "RTN","PRCHG",12,0) I PRCHG=63 S PRCFA("WHO")=3 D RET "RTN","PRCHG",13,0) N DA2237 S DA2237=DA "RTN","PRCHG",14,0) ; "RTN","PRCHG",15,0) ;if PO is not for PPM Clerk stop processing and exit "RTN","PRCHG",16,0) I PRCHG<65 K PRCHG Q "RTN","PRCHG",17,0) S PRCSIG="" D ENCODE^PRCHES11(DA,DUZ,.PRCSIG) S ROUTINE=$T(+0) G:PRCSIG<1 QQ "RTN","PRCHG",18,0) ;set AO name, signature date on 2237 record "RTN","PRCHG",19,0) I $D(DA2237) L +^PRCS(410,DA2237):15 Q:'$T D NOW^%DTC S $P(^PRCS(410,DA2237,7),"^",11)=P,$P(^PRCS(410,DA2237,7),"^",12)=% L -^PRCS(410,DA2237) "RTN","PRCHG",20,0) ; "RTN","PRCHG",21,0) ;if 2237 status is 'Sent to eCMS(P&C)', transmit to eCMS via HL7 msg OMN^O07 (PRC*5.1*167) "RTN","PRCHG",22,0) N PRCER ;transmission error msg "RTN","PRCHG",23,0) N PRCEVNT ;event array for LOG^PRCHJTA "RTN","PRCHG",24,0) I PRCHG=69 D "RTN","PRCHG",25,0) . N PRCLOGER ;error returned from LOG^PRCHJTA "RTN","PRCHG",26,0) . N PRCMSGID ;ien of msg in HLO MESSAGES (#778) "RTN","PRCHG",27,0) . W !!,"Transmitting 2237 transaction to eCMS..." "RTN","PRCHG",28,0) . S PRCMSGID=$$SEND2237^PRCHJS01($G(DA2237),.PRCER) "RTN","PRCHG",29,0) . ; "RTN","PRCHG",30,0) . ;was the transmission successful, ELSE did it fail? "RTN","PRCHG",31,0) . I $G(PRCMSGID)>0 D "RTN","PRCHG",32,0) . . W !?3,">>> 2237 transaction has been successfully transmitted to eCMS." "RTN","PRCHG",33,0) . . W !?7,"Transaction Number: "_$G(PRCTRANS) "RTN","PRCHG",34,0) . . W !?11,"HLO Message ID: "_$G(PRCMSGID) "RTN","PRCHG",35,0) . . W !!?3,">>> Updating transmission in IFCAP/ECMS Transaction file..." "RTN","PRCHG",36,0) . . S PRCEVNT("MSGID")=$G(PRCMSGID) "RTN","PRCHG",37,0) . . S PRCEVNT("IEN410")=$G(DA2237) "RTN","PRCHG",38,0) . . S PRCEVNT("IFCAPU")=$G(DUZ) "RTN","PRCHG",39,0) . . D LOG^PRCHJTA($G(PRCTRANS),,1,.PRCEVNT,.PRCLOGER) "RTN","PRCHG",40,0) . . I +$G(PRCLOGER) W !?7,"Error: "_$P($G(PRCLOGER),U,2) "RTN","PRCHG",41,0) . E D "RTN","PRCHG",42,0) . . W !?3,">>> ERROR: 2237 was not transmitted to eCMS!" "RTN","PRCHG",43,0) . . W !?7,"Transaction Number: "_$G(PRCTRANS) "RTN","PRCHG",44,0) . . ;setup PRCEVNT array for call to LOG^PRCHJTA and output error(s) "RTN","PRCHG",45,0) . . S PRCEVNT("MSGID")="" "RTN","PRCHG",46,0) . . S PRCEVNT("IEN410")=$G(DA2237) "RTN","PRCHG",47,0) . . S PRCEVNT("IFCAPU")=$G(DUZ) "RTN","PRCHG",48,0) . . S PRCEVNT("ERROR",1)="An error occurred when transmitting the 2237 transaction to eCMS." "RTN","PRCHG",49,0) . . S PRCEVNT("ERROR",2)="Option: "_$S($P($G(XQY0),"^",2)]"":$P($G(XQY0),"^",2),1:"UNKNOWN") "RTN","PRCHG",50,0) . . N PRCIDX1,PRCIDX2 "RTN","PRCHG",51,0) . . S PRCIDX1=0,PRCIDX2=2 "RTN","PRCHG",52,0) . . ;output error(s) "RTN","PRCHG",53,0) . . F S PRCIDX1=$O(PRCER(PRCIDX1)) Q:PRCIDX1="" D "RTN","PRCHG",54,0) . . . W !?7,"Error #"_$G(PRCIDX1)_": "_$G(PRCER(PRCIDX1)) "RTN","PRCHG",55,0) . . . S PRCIDX2=PRCIDX2+1 S PRCEVNT("ERROR",PRCIDX2)="Error #"_$G(PRCIDX1)_": "_$G(PRCER(PRCIDX1)) "RTN","PRCHG",56,0) . . W !!?3,">>> Updating transmission error in IFCAP/ECMS Transaction file..." "RTN","PRCHG",57,0) . . D LOG^PRCHJTA($G(PRCTRANS),,1,.PRCEVNT,.PRCLOGER) "RTN","PRCHG",58,0) . . I +$G(PRCLOGER) W !?7,"Error: "_$P($G(PRCLOGER),U,2) "RTN","PRCHG",59,0) . . ;send error(s) to AO "RTN","PRCHG",60,0) . . W !!?3,">>> Sending error notification mail message to Accountable Officer..." "RTN","PRCHG",61,0) . . N PRCMSG1,PRCMSG2 ;input arrays for PHMSG^PRCHJMSG, pass by ref "RTN","PRCHG",62,0) . . S PRCMSG1(1)=$G(PRCTRANS) ;2237 transaction # "RTN","PRCHG",63,0) . . S PRCMSG1(2)=5 ;return to AO since failed transmission to eCMS "RTN","PRCHG",64,0) . . S PRCMSG1(3)=$$NOW^XLFDT ;action date/time "RTN","PRCHG",65,0) . . S PRCMSG1(7)="Please forward this message to appropriate OIT staff!" "RTN","PRCHG",66,0) . . M PRCMSG2=PRCEVNT("ERROR") ;merge error array into PRCMSG2 array "RTN","PRCHG",67,0) . . D PHMSG^PRCHJMSG(.PRCMSG1,.PRCMSG2) ;send msg "RTN","PRCHG",68,0) ; "RTN","PRCHG",69,0) Q "RTN","PRCHG",70,0) ; "RTN","PRCHG",71,0) QQ S:'$D(ROUTINE) ROUTINE=$T(+0) W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!",$C(7) S DIR(0)="EAO",DIR("A")="Press to continue" D ^DIR "RTN","PRCHG",72,0) ; "RTN","PRCHG",73,0) Q K %,DA,DIC,DIE,DR,P,PRCHNM,PRCHTDA,PRCHG,PRCHPO,PRCHS,PRCHSIT,PRCHSX,PRCHSY,PRCHSZ,PRCHX,PRCTRANS,ROUTINE "RTN","PRCHG",74,0) Q "RTN","PRCHG",75,0) ; "RTN","PRCHG",76,0) RET ;RETURN TO SERVICE--UPDATE CP BALANCES, ERASE CP OFFICIAL SIGNATURE, SEND BULLETIN BACK TO SERVICE "RTN","PRCHG",77,0) S PRCHDA=DA,X=$P(^PRCS(410,DA,4),"^",8) D TRANK^PRCSES S $P(^PRCS(410,DA,7),"^",5,7)="^^",$P(^PRCS(410,DA,10),U,4)=$P(^PRC(443,DA,0),U,7),DIE="^PRCS(410,",DR=61 D ^DIE K DIE "RTN","PRCHG",78,0) S DA=PRCHDA D REMOVE^PRCSC1(DA),REMOVE^PRCSC3(DA) "RTN","PRCHG",79,0) ;remove AO name, signature date from 2237 record "RTN","PRCHG",80,0) N PPMNODE F PPMNODE=11,12 S $P(^PRCS(410,DA,7),"^",PPMNODE)="" "RTN","PRCHG",81,0) S (DA,PRCFA("TRDA"))=PRCHDA D RETURN^PRCEFIS1 S DA=PRCHDA D EN3^PRCPWI "RTN","PRCHG",82,0) Q "RTN","PRCHG",83,0) ; "RTN","PRCHG",84,0) SIT S PRCF("X")="SP" D ^PRCFSITE K PRCHNM "RTN","PRCHG",85,0) Q "RTN","PRCHG",86,0) ; "RTN","PRCHG",87,0) TR S DIC("S")="I $P(^(0),U,3)="""",$D(^PRCS(410,Y,7)),$P(^(7),U,6)]"""",+^(0)=PRC(""SITE"")" "RTN","PRCHG",88,0) S DIC("S")=$S('$D(PRCFDICS):DIC("S")_" S Z=$O(^PRCD(442.3,""C"",+$P(^PRC(443,Y,0),U,7),0)) I Z'=10&(Z'=85)",1:DIC("S")_PRCFDICS) "RTN","PRCHG",89,0) ; "RTN","PRCHG",90,0) DIC W !! K DA S DIC="^PRC(443,",DIC(0)="QEAMZ",DIC("A")="2237 TRANSACTION NUMBER: " D ^DIC S DIE=DIC K DIC S:Y>0 DA=+Y,PRCTRANS=$G(Y(0,0)) "RTN","PRCHG",91,0) Q "RTN","PRCHG",92,0) ; "RTN","PRCHG",93,0) ST S DIC("S")="I $P(^(0),U,3)]"""",$O(^PRCD(442.3,""C"",+$P(^(0),U,7),0))'=65,$D(^PRCS(410,+Y,0)),+^(0)=PRC(""SITE"")" D DIC "RTN","PRCHG",94,0) Q "RTN","PRCHG",95,0) ; "RTN","PRCHG",96,0) PPM S DR="[PRCHPPM]",DIE("NO^")="" D ^DIE K DIE,PRCHPPM D ES1 "RTN","PRCHG",97,0) Q "RTN","PRCHG",98,0) ; "RTN","PRCHG",99,0) EN ;SIGN 2237 IN PPM "RTN","PRCHG",100,0) D SIT Q:'$D(PRC("SITE")) D:'$D(PRCHNM) ES G:'$D(PRCHNM) Q "RTN","PRCHG",101,0) ;*81 Check site parameter to see if issue books should be allowed "RTN","PRCHG",102,0) I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 D EN^PRCHG1 "RTN","PRCHG",103,0) ; "RTN","PRCHG",104,0) EN0 D:'$D(PRCHNM) ES G:'$D(PRCHNM) Q D TR G:'$D(DA) Q D PPM "RTN","PRCHG",105,0) G EN0 "RTN","PRCHG",106,0) ; "RTN","PRCHG",107,0) EN1 ;SIGN 2237 IN PC "RTN","PRCHG",108,0) D SIT Q:'$D(PRC("SITE")) "RTN","PRCHG",109,0) EN10 D ST G:'$D(DA) Q S DR="[PRCHPC]",DIE("NO^")="" D ^DIE K DIE "RTN","PRCHG",110,0) G EN10 "RTN","PRCHG",111,0) ; "RTN","PRCHG",112,0) EN2 ;RETURN 2237 IN PC "RTN","PRCHG",113,0) D SIT Q:'$D(PRC("SITE")) "RTN","PRCHG",114,0) EN20 ;D ST G:'$D(DA) Q S DR="[PRCHPCR]" D ^DIE K PRCHPCR S Z=$S($D(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)):$P(^(0),U,2),1:"") G:Z'=76 EN20 "RTN","PRCHG",115,0) D ST G:'$D(DA) Q S DR="[PRCHPCR]" D ^DIE K PRCHPCR S Z=$P($G(^PRCD(442.3,+$P(^PRC(443,DA,0),U,7),0)),U,2) G:Z'=76 EN20 "RTN","PRCHG",116,0) S $P(^PRC(443,DA,0),"^",2,4)="^^" "RTN","PRCHG",117,0) S PRCFA("WHO")=2 D RET "RTN","PRCHG",118,0) G EN20 "RTN","PRCHG",119,0) ; "RTN","PRCHG",120,0) EN3 ;SPLIT 2237 IN PPM "RTN","PRCHG",121,0) D SIT Q:'$D(PRC("SITE")) "RTN","PRCHG",122,0) EN30 D TR G:'$D(DA) Q S PRCHSY(0)=Y(0),(PRCHPO,PRCHSY)=DA,(PRCHG,PRCHSZ)=1 D N^PRCHNPO3 G Q:'$D(PRCHSY)!('$O(^TMP($J,"PRCHS",0))),W1:+^TMP($J,"PRCHS",0)=+^PRCS(410,DA,10) "RTN","PRCHG",123,0) S PRCHSIT=+^TMP($J,"PRCHS",0),PRCHS=PRCHSY D WAIT^DICD,^PRCHSP I PRCHSY=-1 D ERR^PRCHNPO3,Q G EN30 "RTN","PRCHG",124,0) W !!,"The new 2237, ",PRCHSX,", will now be printed with the old one." F DA=PRCHS,PRCHSY S PRCSF=1 D PRF1^PRCSP1 "RTN","PRCHG",125,0) K PRCSF D Q "RTN","PRCHG",126,0) G EN30 "RTN","PRCHG",127,0) ; "RTN","PRCHG",128,0) EN4 ;EDIT A SIGNED 2237 IN PPM "RTN","PRCHG",129,0) D SIT Q:'$D(PRC("SITE")) "RTN","PRCHG",130,0) EN40 D:'$D(PRCHNM) ES G:'$D(PRCHNM) Q S DIC("S")="I $P(^(0),U,3)]""""" D DIC G:'$D(DA) Q D PPM "RTN","PRCHG",131,0) G EN40 "RTN","PRCHG",132,0) ; "RTN","PRCHG",133,0) EN5 ;DISPLAY NO.OF REQUESTS TO BE PROCESSED BY PPM "RTN","PRCHG",134,0) S X=0 F I=0:0 S I=$O(^PRC(443,"AC",60,I)) Q:'I S X=X+1 "RTN","PRCHG",135,0) W $C(7),!!!,?3,"There are "_X_" Requests ready to process." K X,I "RTN","PRCHG",136,0) Q "RTN","PRCHG",137,0) ; "RTN","PRCHG",138,0) W1 W !!,"You have selected all Line Items, NO action taken.",$C(7) D Q "RTN","PRCHG",139,0) G EN3 "RTN","PRCHG",140,0) ; "RTN","PRCHG",141,0) STAT I $D(PRCFGPF) S DIC("S")="S Z=$P(^(0),U,2) I Z=10!(Z=60)!(Z=85)" Q "RTN","PRCHG",142,0) I $D(PRCHPCR) D Q "RTN","PRCHG",143,0) . S DIC("S")="I $P(^(0),U,2)=75!($P(^(0),U,2)=76)" "RTN","PRCHG",144,0) . I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D Q "RTN","PRCHG",145,0) . . N PRC2237 "RTN","PRCHG",146,0) . . S PRC2237=$P(^PRCS(410,DA,0),"^",1) "RTN","PRCHG",147,0) . . I '$$CHKDM^PRCVLIC(PRC2237) Q "RTN","PRCHG",148,0) . . I $O(^PRCS(410,"AG",PRC2237,""))]"" S DIC("S")="I $P(^(0),U,2)=75" "RTN","PRCHG",149,0) I '$D(PRCHPPM) S DIC("S")="I $P(^(0),U,2)>69" Q "RTN","PRCHG",150,0) K Z0 S (Z0(60),Z0(62),Z0(63),Z0(65),Z0(74))="" S:$P(^PRC(443,DA,0),U,10)=4 Z0(70)="",Z0(69)="" "RTN","PRCHG",151,0) S DIC("S")="I $D(Z0(+$P(^(0),U,2)))" "RTN","PRCHG",152,0) S:$$ECMS2237^PRCHJUTL(DA) DIC("S")="I "";60;63;69;""[("";""_$P(^(0),U,2)_"";"")" "RTN","PRCHG",153,0) Q "RTN","PRCHJMSG") 0^15^B13099425^B10009804 "RTN","PRCHJMSG",1,0) PRCHJMSG ;BP/VAC - SEND A MAILMAN MESSAGE ;5/13/13 13:29 "RTN","PRCHJMSG",2,0) ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23 "RTN","PRCHJMSG",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCHJMSG",4,0) ;Send a MailMan message "RTN","PRCHJMSG",5,0) ;XMDUZ=SENDER OF THE MESSAGE "RTN","PRCHJMSG",6,0) ;XMSUB=SUBJECT LINE "RTN","PRCHJMSG",7,0) ;XMTEXT="MSG(" - ARRAY OF MESSAGE LINES "RTN","PRCHJMSG",8,0) ;XMY(DUZ)="" - Receivers of the message "RTN","PRCHJMSG",9,0) ;TO BE PASSED IN "RTN","PRCHJMSG",10,0) ; 2237 NUMBER "RTN","PRCHJMSG",11,0) ; TYPE OF MESSAGE "RTN","PRCHJMSG",12,0) ; ACTION DATE AND TIME AS FILEMAN DATE TIME "RTN","PRCHJMSG",13,0) ; COMMENTS - MULTIPLE ARRAY "RTN","PRCHJMSG",14,0) ; eCMS USER NAME "RTN","PRCHJMSG",15,0) ; eCMS USER EMAIL ADDRESS "RTN","PRCHJMSG",16,0) ; eCMS USER PHONE NUMBER "RTN","PRCHJMSG",17,0) ;TO BE RETRIEVED FROM 2237 OR PASSED IN "RTN","PRCHJMSG",18,0) ; STATION NUMBER 410 .5 "RTN","PRCHJMSG",19,0) ; SUB STATION NUMBER 410 448 POINTER TO 411 "RTN","PRCHJMSG",20,0) ; ACCOUNTABLE OFFICER 410 39 "RTN","PRCHJMSG",21,0) ; CONTROL POINT OFFICIAL(APPROVING OFFICIAL) 410 42 POINTER TO 200 "RTN","PRCHJMSG",22,0) ; REQUESTOR 410 40 POINTER TO 200 "RTN","PRCHJMSG",23,0) ; "RTN","PRCHJMSG",24,0) PHMSG(MSG1,MSG2) ;START OF MESSAGE BUILDING "RTN","PRCHJMSG",25,0) ;MSG1 array contains (1)-2237 number;(2)msg type;(3)date and time "RTN","PRCHJMSG",26,0) ; (4) eCMS User Name; (5) eCMS User email "RTN","PRCHJMSG",27,0) ; (6) eCMS User phone number (7) Special message to send to OIT "RTN","PRCHJMSG",28,0) ;MSG2 array contains error comments from ACK or comments from Cancel/return "RTN","PRCHJMSG",29,0) ; "RTN","PRCHJMSG",30,0) N XMTEXT,XMSUB,XMY,XMDUZ,OUT,I,J,ZZ "RTN","PRCHJMSG",31,0) N PRCHJ22,PRCHJTY,PRCHJDT,PRCHJRR,PRCHJUN,PRCHJEM,PRCHJPH,PRCHJSP "RTN","PRCHJMSG",32,0) S PRCHJ22=$G(MSG1(1)) ; 2237 NUMBER "RTN","PRCHJMSG",33,0) S PRCHJTY=$G(MSG1(2)) ; MESSAGE TYPE "RTN","PRCHJMSG",34,0) S PRCHJDT=$$FMTE^XLFDT($G(MSG1(3))) ; DATE AND TIME WHEN ACTION TOOK PLACE "RTN","PRCHJMSG",35,0) K MSG1(3) "RTN","PRCHJMSG",36,0) S PRCHJUN=$G(MSG1(4)) ; ECMS USER NAME "RTN","PRCHJMSG",37,0) S PRCHJEM=$G(MSG1(5)) ; ECMS USER EMAIL "RTN","PRCHJMSG",38,0) S PRCHJPH=$G(MSG1(6)) ; ECMS USER PHONE "RTN","PRCHJMSG",39,0) S PRCHJSP=$G(MSG1(7)) ; Special OIT message "RTN","PRCHJMSG",40,0) ;I PRCHJTY=1 MESAGE IS AN ACK REJECT "RTN","PRCHJMSG",41,0) ;I PRCHJTY=2 MESSAGE IS A MESSAGE CANCEL "RTN","PRCHJMSG",42,0) ;I PRCHJTY=3 MESAGE IS A RETURN TO ACCOUNTABLE OFFICER "RTN","PRCHJMSG",43,0) ;I PRCHJTY=4 MESSAGE IS A RETURN TO CONTROL POINT "RTN","PRCHJMSG",44,0) ;I PRCHJTY=5 MESSAGE IS RETURN TO AO BECAUSE IT DIDN'T GO TO ECMS "RTN","PRCHJMSG",45,0) ; "RTN","PRCHJMSG",46,0) ;Put errors/text into MSG1 from MSG2 "RTN","PRCHJMSG",47,0) S ZZ=0 "RTN","PRCHJMSG",48,0) F I=1:1 S ZZ=$O(MSG2(ZZ)) Q:ZZ="" S MSG1(I+6)=MSG2(ZZ) "RTN","PRCHJMSG",49,0) S XMTEXT="MSG1(" "RTN","PRCHJMSG",50,0) ;Get information from 2237 "RTN","PRCHJMSG",51,0) D FIND^DIC(410,"","@;.5;39I;40I;42I;448","B",PRCHJ22,,,,,"OUT","ERR") "RTN","PRCHJMSG",52,0) ;Validate that a good 2237 number was sent in "RTN","PRCHJMSG",53,0) ;OUT array contains data from 2237 "RTN","PRCHJMSG",54,0) ;OUT("DILIST","ID",1,.3))=SPECIAL OIT MESSAGE "RTN","PRCHJMSG",55,0) ;OUT("DILIST","ID",1,.5))=STATION NUMBER "RTN","PRCHJMSG",56,0) ;OUT('DILIST","ID",1,39)=ACCOUNTABLE OFFICER "RTN","PRCHJMSG",57,0) ;OUT("DILIST","ID",1,40)=REQUESTOR "RTN","PRCHJMSG",58,0) ;OUT("DILIST","ID",1,42))=CONTROL POINT OFFICIAL "RTN","PRCHJMSG",59,0) ;OUT("DILIST","ID",1,448)=SUB STATION "RTN","PRCHJMSG",60,0) ; "RTN","PRCHJMSG",61,0) BLD ;BUILD MESSAGE "RTN","PRCHJMSG",62,0) ; "RTN","PRCHJMSG",63,0) ;S MSG1(.6)="DATE AND TIME OF ACTION "_PRCHJDT "RTN","PRCHJMSG",64,0) K MSG1(2) "RTN","PRCHJMSG",65,0) S MSG1(.3)=" "_PRCHJSP "RTN","PRCHJMSG",66,0) S MSG1(.4)=" " "RTN","PRCHJMSG",67,0) S MSG1(.5)="STATION "_OUT("DILIST","ID",1,.5) "RTN","PRCHJMSG",68,0) I $G(OUT("DILIST","ID",1,448))'="" S MSG1(.5)=MSG1(.5)_" SUBSTATION "_OUT("DILIST","ID",1,448) "RTN","PRCHJMSG",69,0) I PRCHJTY=1 S XMY(OUT("DILIST","ID",1,39))="",XMSUB="MESSAGE REJECTION FOR 2237 "_PRCHJ22,MSG1(.6)="IFCAP Date/Time received eCMS Rejection of 2237 "_PRCHJDT K MSG1(4) "RTN","PRCHJMSG",70,0) I PRCHJTY=2 D "RTN","PRCHJMSG",71,0) . N PRCX "RTN","PRCHJMSG",72,0) .F J=39,40,42 S:$G(OUT("DILIST","ID",1,J))>0 XMY(OUT("DILIST","ID",1,J))="" "RTN","PRCHJMSG",73,0) . S PRCX=$O(^PRCS(410,"B",PRCHJ22,"")) I PRCX>0,$D(^PRC(443,PRCX)) S PRCX=$$GET1^DIQ(443,PRCX_",",2,"I") S:PRCX>0 XMY(PRCX)="" "RTN","PRCHJMSG",74,0) .S XMSUB="2237 CANCEL FROM eCMS FOR 2237 "_PRCHJ22 "RTN","PRCHJMSG",75,0) .S MSG1(.6)="eCMS Date/Time Canceled "_PRCHJDT "RTN","PRCHJMSG",76,0) I PRCHJTY=3 D "RTN","PRCHJMSG",77,0) .F J=39,40 S:$G(OUT("DILIST","ID",1,J))>0 XMY(OUT("DILIST","ID",1,J))="" "RTN","PRCHJMSG",78,0) .S XMSUB="2237 RETURNED TO ACCOUNTABLE OFFICER "_PRCHJ22 "RTN","PRCHJMSG",79,0) .S MSG1(.6)="eCMS Date/Time Returned to AO "_PRCHJDT "RTN","PRCHJMSG",80,0) I PRCHJTY=4 D "RTN","PRCHJMSG",81,0) . N PRCX "RTN","PRCHJMSG",82,0) .F J=39,40,42 S:$G(OUT("DILIST","ID",1,J))>0 XMY(OUT("DILIST","ID",1,J))="" "RTN","PRCHJMSG",83,0) . S PRCX=$O(^PRCS(410,"B",PRCHJ22,"")) I PRCX>0,$D(^PRC(443,PRCX)) S PRCX=$$GET1^DIQ(443,PRCX_",",2,"I") S:PRCX>0 XMY(PRCX)="" "RTN","PRCHJMSG",84,0) .S XMSUB="2237 RETURNED TO CONTROL POINT FOR "_PRCHJ22 "RTN","PRCHJMSG",85,0) .S MSG1(.6)="eCMS Date/Time Returned to CP "_PRCHJDT "RTN","PRCHJMSG",86,0) I PRCHJTY=5 D "RTN","PRCHJMSG",87,0) .F J=39 S XMY(OUT("DILIST","ID",1,J))="" "RTN","PRCHJMSG",88,0) .S XMSUB="TRANSMISSION FAILURE FOR 2237 "_PRCHJ22 "RTN","PRCHJMSG",89,0) .S MSG1(.6)="2237 Transmission to eCMS failed "_PRCHJDT "RTN","PRCHJMSG",90,0) S XMDUZ="IFCAP/eCMS INTERFACE" "RTN","PRCHJMSG",91,0) D ^XMD "RTN","PRCHJMSG",92,0) Q "RTN","PRCHJR01") 0^10^B172209901^B143518446 "RTN","PRCHJR01",1,0) PRCHJR01 ;OI&T/LKG - PROCESS 2237 RETURN OR CANCEL FROM ECMS ;7/15/13 16:48 "RTN","PRCHJR01",2,0) ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23 "RTN","PRCHJR01",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCHJR01",4,0) PARSE ;This module contains logic to parse the incoming OMN^O07 HL7 message "RTN","PRCHJR01",5,0) N PRCHJMSG,PRCHJHDR,PRCHJSEG,PRCHJIND,PRCHJMID,PRCHJSTN,PRCHJTD,PRCHJVAL,PRCVALID,PRCHJMDT,PRCHJNOW,PRCHJCTR,PRCHJERR,PRCX "RTN","PRCHJR01",6,0) ; HLMSGIEN is an HLO variable that will be defined when PARSE^PRCHJR01 is invoked. "RTN","PRCHJR01",7,0) I '$$STARTMSG^HLOPRS(.PRCHJMSG,HLMSGIEN,.PRCHJHDR) Q "RTN","PRCHJR01",8,0) I PRCHJMSG("BATCH") Q "RTN","PRCHJR01",9,0) I PRCHJHDR("MESSAGE TYPE")'="OMN"!(PRCHJHDR("EVENT")'="O07") Q "RTN","PRCHJR01",10,0) S PRCHJSTN=$G(PRCHJHDR("RECEIVING FACILITY",1)) "RTN","PRCHJR01",11,0) S PRCHJMID=PRCHJHDR("MESSAGE CONTROL ID"),PRCHJMDT=PRCHJHDR("DT/TM OF MESSAGE") "RTN","PRCHJR01",12,0) S PRCHJIND="PRCHJR01"_PRCHJMID K ^XTMP(PRCHJIND) S PRCHJTD=$$DT^XLFDT,^XTMP(PRCHJIND,0)=$$FMADD^XLFDT(PRCHJTD,7)_"^"_PRCHJTD_"^2237 RETURN/CANCEL" "RTN","PRCHJR01",13,0) F Q:'$$NEXTSEG^HLOPRS(.PRCHJMSG,.PRCHJSEG) D "RTN","PRCHJR01",14,0) . I PRCHJSEG("SEGMENT TYPE")="ORC" D ORC(.PRCHJSEG) "RTN","PRCHJR01",15,0) . I PRCHJSEG("SEGMENT TYPE")="RQD" D RQD(.PRCHJSEG) "RTN","PRCHJR01",16,0) . ;If not ORC or RQD ignore "RTN","PRCHJR01",17,0) ; "RTN","PRCHJR01",18,0) D LOGOMN^PRCHJR03 "RTN","PRCHJR01",19,0) ; "RTN","PRCHJR01",20,0) S PRCVALID=$$VALIDATE() "RTN","PRCHJR01",21,0) ; "RTN","PRCHJR01",22,0) D:PRCVALID EMAIL "RTN","PRCHJR01",23,0) I PRCVALID D "RTN","PRCHJR01",24,0) . N PRCIEN,PRC2237,PRCSTAT,PRCERR S PRC2237=^XTMP(PRCHJIND,"2237 TXN"),PRCIEN=$$FIND1^DIC(410,"","X",PRC2237,"B","","PRCERR") "RTN","PRCHJR01",25,0) . S PRCSTAT=$$GET1^DIQ(410,PRCIEN_",",54,"","","PRCERR") K PRCERR "RTN","PRCHJR01",26,0) . I ";RETURNED TO SERVICE BY PPM;RETURNED TO SERVICE BY P&C;"[(";"_$$UP^XLFSTR(PRCSTAT)_";"),^XTMP(PRCHJIND,"ORDER STATUS")="HD" D Q "RTN","PRCHJR01",27,0) . . N PRCX S PRCX=$$ECMSRETN^PRCHJR03(PRCIEN) "RTN","PRCHJR01",28,0) . . S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="14^Return to Control Point is incomplete." "RTN","PRCHJR01",29,0) . I ";RETURNED TO SERVICE BY PPM;RETURNED TO SERVICE BY P&C;"[(";"_$$UP^XLFSTR(PRCSTAT)_";"),^XTMP(PRCHJIND,"ORDER CONTROL")="CA" D Q "RTN","PRCHJR01",30,0) . . N PRCX S PRCX=$$ECMSRETN^PRCHJR03(PRCIEN) "RTN","PRCHJR01",31,0) . . S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="14^Return to Control Point is incomplete." "RTN","PRCHJR01",32,0) . . S PRCX=$$CANCEL(PRCIEN) "RTN","PRCHJR01",33,0) . . S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="15^Cancelation of 2237 is incomplete." "RTN","PRCHJR01",34,0) . I ^XTMP(PRCHJIND,"ORDER CONTROL")="UA",^XTMP(PRCHJIND,"ORDER STATUS")="IP" D Q "RTN","PRCHJR01",35,0) . . S PRCX=$$RET2AO(PRCIEN) S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="13^Return to Accountable Officer is incomplete." "RTN","PRCHJR01",36,0) . I ^XTMP(PRCHJIND,"ORDER CONTROL")="UA",^XTMP(PRCHJIND,"ORDER STATUS")="HD" D Q "RTN","PRCHJR01",37,0) . . S PRCX=$$RET2AO(PRCIEN) S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="13^Return to Accountable Officer is incomplete." "RTN","PRCHJR01",38,0) . . S PRCX=$$RET2CP(PRCIEN) S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="14^Return to Control Point is incomplete." "RTN","PRCHJR01",39,0) . I ^XTMP(PRCHJIND,"ORDER CONTROL")="CA" D Q "RTN","PRCHJR01",40,0) . . S PRCX=$$RET2AO(PRCIEN) S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="13^Return to Accountable Officer is incomplete." "RTN","PRCHJR01",41,0) . . S PRCX=$$RET2CP(PRCIEN) S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="14^Return to Control Point is incomplete." "RTN","PRCHJR01",42,0) . . S PRCX=$$CANCEL(PRCIEN) S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="15^Cancelation of 2237 is incomplete." "RTN","PRCHJR01",43,0) ; "RTN","PRCHJR01",44,0) I PRCHJHDR("APP ACK TYPE")="AL" D BUILDACK "RTN","PRCHJR01",45,0) Q "RTN","PRCHJR01",46,0) ; "RTN","PRCHJR01",47,0) EMAIL ;Send message to users attached to 2237 being returned/canceled "RTN","PRCHJR01",48,0) N PRCHJM1,PRCHJM2 "RTN","PRCHJR01",49,0) S PRCHJM1(1)=^XTMP(PRCHJIND,"2237 TXN") "RTN","PRCHJR01",50,0) S PRCHJM1(2)=$S(^XTMP(PRCHJIND,"ORDER CONTROL")="CA":2,^XTMP(PRCHJIND,"ORDER STATUS")="IP":3,^XTMP(PRCHJIND,"ORDER STATUS")="HD":4,1:"") "RTN","PRCHJR01",51,0) S PRCHJM1(3)=^XTMP(PRCHJIND,"ACTION CREATED DATE") "RTN","PRCHJR01",52,0) S PRCHJM1(4)=^XTMP(PRCHJIND,"USER","FIRSTNAME")_$S(^XTMP(PRCHJIND,"USER","MIDDLENAME")'="":(" "_^("MIDDLENAME")),1:"")_" "_^XTMP(PRCHJIND,"USER","LASTNAME") "RTN","PRCHJR01",53,0) S PRCHJM1(5)=^XTMP(PRCHJIND,"EMAIL"),PRCHJM1(6)=^XTMP(PRCHJIND,"PHONE") "RTN","PRCHJR01",54,0) S PRCHJM2(1)=^XTMP(PRCHJIND,"RETURN REASON"),PRCHJM2(2)=^XTMP(PRCHJIND,"RETURN COMMENT") "RTN","PRCHJR01",55,0) D PHMSG^PRCHJMSG(.PRCHJM1,.PRCHJM2) "RTN","PRCHJR01",56,0) Q "RTN","PRCHJR01",57,0) ORC(PRCHJSEG) ;Parse ORC segment "RTN","PRCHJR01",58,0) S ^XTMP(PRCHJIND,"ORDER CONTROL")=$$GET^HLOPRS(.PRCHJSEG,1) "RTN","PRCHJR01",59,0) S ^XTMP(PRCHJIND,"2237 TXN")=$$GET^HLOPRS(.PRCHJSEG,2,1) "RTN","PRCHJR01",60,0) S ^XTMP(PRCHJIND,"STATION")=$$GET^HLOPRS(.PRCHJSEG,2,2) "RTN","PRCHJR01",61,0) S ^XTMP(PRCHJIND,"SUBSTATION")=$$GET^HLOPRS(.PRCHJSEG,2,3) "RTN","PRCHJR01",62,0) S ^XTMP(PRCHJIND,"ECMS ACTIONUID")=$$GET^HLOPRS(.PRCHJSEG,3,1) "RTN","PRCHJR01",63,0) S ^XTMP(PRCHJIND,"ORDER STATUS")=$$GET^HLOPRS(.PRCHJSEG,5) "RTN","PRCHJR01",64,0) D GETTS^HLOPRS2(.PRCHJSEG,.PRCHJVAL,9,1) S ^XTMP(PRCHJIND,"ACTION CREATED DATE")=PRCHJVAL "RTN","PRCHJR01",65,0) S ^XTMP(PRCHJIND,"USER","LASTNAME")=$$GET^HLOPRS(.PRCHJSEG,10,2,1) "RTN","PRCHJR01",66,0) S ^XTMP(PRCHJIND,"USER","FIRSTNAME")=$$GET^HLOPRS(.PRCHJSEG,10,3) "RTN","PRCHJR01",67,0) S ^XTMP(PRCHJIND,"USER","MIDDLENAME")=$$GET^HLOPRS(.PRCHJSEG,10,4) "RTN","PRCHJR01",68,0) S ^XTMP(PRCHJIND,"USER","SUFFIX")=$$GET^HLOPRS(.PRCHJSEG,10,5) "RTN","PRCHJR01",69,0) S ^XTMP(PRCHJIND,"PHONE")=$$GET^HLOPRS(.PRCHJSEG,14,1) "RTN","PRCHJR01",70,0) S ^XTMP(PRCHJIND,"EMAIL")=$$GET^HLOPRS(.PRCHJSEG,14,4) "RTN","PRCHJR01",71,0) S ^XTMP(PRCHJIND,"RETURN REASON")=$$GET^HLOPRS(.PRCHJSEG,16,2) "RTN","PRCHJR01",72,0) S ^XTMP(PRCHJIND,"RETURN COMMENT")=$$GET^HLOPRS(.PRCHJSEG,16,5) "RTN","PRCHJR01",73,0) Q "RTN","PRCHJR01",74,0) RQD(PRCHJSEG) ;Process RQD segment "RTN","PRCHJR01",75,0) S ^XTMP(PRCHJIND,"REQUISITION LINE NBR")=$$GET^HLOPRS(.PRCHJSEG,1) "RTN","PRCHJR01",76,0) Q "RTN","PRCHJR01",77,0) RET2AO(DA) ;This module contains logic to remove the AO signature and change status to Pending Accountable Officer Sig. "RTN","PRCHJR01",78,0) N PRCDATA,PRCERR,PRCHPCR,PRCHJDA,PRCERROR S PRCHPCR=1,PRCHJDA=DA_",",PRCERROR=0 "RTN","PRCHJR01",79,0) S PRCDATA(443,PRCHJDA,1.5)=60 D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR01",80,0) S PRCDATA(443,PRCHJDA,2)="@",PRCDATA(443,PRCHJDA,3)="@",PRCDATA(443,PRCHJDA,4)="@" "RTN","PRCHJR01",81,0) D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR01",82,0) S PRCDATA(410,PRCHJDA,39)="@",PRCDATA(410,PRCHJDA,69)="@" "RTN","PRCHJR01",83,0) D FILE^DIE("EK","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR01",84,0) S PRCDATA(1)=^XTMP(PRCHJIND,"RETURN REASON"),PRCDATA(2)=^XTMP(PRCHJIND,"RETURN COMMENT") "RTN","PRCHJR01",85,0) D WP^DIE(410,PRCHJDA,61,"K","PRCDATA","PRCERR") "RTN","PRCHJR01",86,0) S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR01",87,0) I ^XTMP(PRCHJIND,"ORDER STATUS")="IP" D "RTN","PRCHJR01",88,0) . S:$$XECMSIDS^PRCHJR03($P(PRCHJDA,",")) PRCERROR=1 "RTN","PRCHJR01",89,0) . S PRCDATA(443,PRCHJDA,6)="@" "RTN","PRCHJR01",90,0) . D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 "RTN","PRCHJR01",91,0) . K PRCDATA,PRCERR "RTN","PRCHJR01",92,0) Q $S(PRCERROR:0,1:1) "RTN","PRCHJR01",93,0) RET2CP(DA) ;This module contains logic to remove the Control Point Official's signature, de-commit the funds and adjust due-ins as necessary. "RTN","PRCHJR01",94,0) N PRCHDA,PRCDATA,PRCERR,PRCHJDA,PRCERROR,PRCHJCPR,X S PRCHDA=DA,PRCERROR=0 "RTN","PRCHJR01",95,0) S X=$P(^PRCS(410,DA,4),"^",8) D TRANK^PRCSES "RTN","PRCHJR01",96,0) S PRCHJDA=DA_",",PRCDATA(410,PRCHJDA,44)="@",PRCDATA(410,PRCHJDA,44.5)="@",PRCDATA(410,PRCHJDA,44.6)="@" "RTN","PRCHJR01",97,0) D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR01",98,0) S PRCDATA(410,PRCHJDA,56)=77 D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR01",99,0) S PRCHJCPR=1,PRCDATA(443,PRCHJDA,1.5)=77 D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR01",100,0) S PRCDATA(1)=^XTMP(PRCHJIND,"RETURN REASON"),PRCDATA(2)=^XTMP(PRCHJIND,"RETURN COMMENT") "RTN","PRCHJR01",101,0) D WP^DIE(410,PRCHJDA,61,"K","PRCDATA","PRCERR") "RTN","PRCHJR01",102,0) S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR01",103,0) S DA=PRCHDA D REMOVE^PRCSC1(DA),REMOVE^PRCSC3(DA) "RTN","PRCHJR01",104,0) S DA=PRCHDA D ADJDUEIN(DA) ;D EN3^PRCPWI "RTN","PRCHJR01",105,0) Q $S(PRCERROR:0,1:1) "RTN","PRCHJR01",106,0) ; "RTN","PRCHJR01",107,0) CANCEL(DA) ;This module contains logic to cancel the 2237 "RTN","PRCHJR01",108,0) N PRCDATA,PRCERR,PRCHJDA,PRCERROR,I,N,X,Y S PRCHJDA=DA_",",PRCERROR=0 "RTN","PRCHJR01",109,0) S PRCDATA(410,PRCHJDA,55)="@",PRCDATA(410,PRCHJDA,1)="CA" "RTN","PRCHJR01",110,0) D FILE^DIE("EK","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR01",111,0) S:$$XECMSIDS^PRCHJR03(DA) PRCERROR=1 "RTN","PRCHJR01",112,0) S $P(^PRCS(410,DA,5),U)=0,$P(^(6),U)=0,$P(^(4),U)=0,$P(^(4),U,3)=0,$P(^(4),U,6)=0,$P(^(4),U,8)=0 "RTN","PRCHJR01",113,0) I $D(^PRCS(410,DA,12,0)) S N=0 F I=0:0 S N=$O(^PRCS(410,DA,12,N)) Q:N'>0 S X=$P(^(N,0),"^",2) I X S DA(1)=DA,DA=N D TRANK^PRCSEZZ S DA=DA(1) "RTN","PRCHJR01",114,0) K DA(1) "RTN","PRCHJR01",115,0) D ERS410^PRC0G(DA_"^C") "RTN","PRCHJR01",116,0) S PRCDATA(1)=^XTMP(PRCHJIND,"RETURN REASON") D WP^DIE(410,PRCHJDA,61,"K","PRCDATA","PRCERR") "RTN","PRCHJR01",117,0) S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR01",118,0) S PRCDATA(1)=^XTMP(PRCHJIND,"RETURN COMMENT") "RTN","PRCHJR01",119,0) S PRCDATA(2)="eCMS User Who Canceled 2237: " "RTN","PRCHJR01",120,0) S PRCDATA(3)=^XTMP(PRCHJIND,"USER","LASTNAME")_","_^XTMP(PRCHJIND,"USER","FIRSTNAME") "RTN","PRCHJR01",121,0) S:^XTMP(PRCHJIND,"USER","MIDDLENAME")'="" PRCDATA(3)=PRCDATA(3)_" "_^("MIDDLENAME") "RTN","PRCHJR01",122,0) S PRCDATA(3)=$$UP^XLFSTR(PRCDATA(3)) "RTN","PRCHJR01",123,0) D WP^DIE(410,PRCHJDA,60,"AK","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR01",124,0) ;If a DynaMed txn, update audit file and send message to DynaMed "RTN","PRCHJR01",125,0) D EN^PRCVTCA(DA) "RTN","PRCHJR01",126,0) I $D(^PRC(443,DA,0)) S DIK="^PRC(443," D ^DIK K DIK "RTN","PRCHJR01",127,0) Q $S(PRCERROR:0,1:1) "RTN","PRCHJR01",128,0) BUILDACK ;This module contains logic to build the ORN^O08 application acknowledgment "RTN","PRCHJR01",129,0) N PRCHJPAR,PRCHJACK,PRCERR "RTN","PRCHJR01",130,0) S PRCHJPAR("ACK CODE")=$S('$D(PRCHJERR):"AA",1:"AR") "RTN","PRCHJR01",131,0) S PRCHJPAR("ACCEPT ACK TYPE")="AL",PRCHJPAR("MESSAGE TYPE")="ORN",PRCHJPAR("EVENT")="O08" "RTN","PRCHJR01",132,0) S PRCHJPAR("FIELD SEPARATOR")="|",PRCHJPAR("ENCODING CHARACTERS")="^~\&" "RTN","PRCHJR01",133,0) S PRCHJPAR("MESSAGE STRUCTURE CODE")="ORN_O08",PRCHJPAR("VERSION")=2.5 "RTN","PRCHJR01",134,0) I '$$ACK^HLOAPI2(.PRCHJMSG,.PRCHJPAR,.PRCHJACK,.PRCERR) Q "RTN","PRCHJR01",135,0) I '$D(PRCHJERR) D "RTN","PRCHJR01",136,0) . D SET^HLOAPI(.PRCSEG,"ORC",0),SET^HLOAPI(.PRCSEG,"XR",1) "RTN","PRCHJR01",137,0) . D SET^HLOAPI(.PRCSEG,^XTMP(PRCHJIND,"2237 TXN"),2,1) "RTN","PRCHJR01",138,0) . D SET^HLOAPI(.PRCSEG,^XTMP(PRCHJIND,"STATION"),2,2) "RTN","PRCHJR01",139,0) . D SET^HLOAPI(.PRCSEG,^XTMP(PRCHJIND,"SUBSTATION"),2,3) "RTN","PRCHJR01",140,0) . D SET^HLOAPI(.PRCSEG,^XTMP(PRCHJIND,"ECMS ACTIONUID"),3,1) "RTN","PRCHJR01",141,0) . S PRCX=$$ADDSEG^HLOAPI(.PRCHJACK,.PRCSEG,.PRCERR,.PRCARR) "RTN","PRCHJR01",142,0) . K PRCSEG D SET^HLOAPI(.PRCSEG,"RQD",0),SET^HLOAPI(.PRCSEG,9999,1) "RTN","PRCHJR01",143,0) . S PRCX=$$ADDSEG^HLOAPI(.PRCHJACK,.PRCSEG,.PRCERR,.PRCARR) "RTN","PRCHJR01",144,0) I $D(PRCHJERR) D "RTN","PRCHJR01",145,0) . N PRCI S PRCI=0 "RTN","PRCHJR01",146,0) . F S PRCI=$O(PRCHJERR(PRCI)) Q:PRCI="" D "RTN","PRCHJR01",147,0) . . N PRCX,PRCY,PRCE,PRCSEG,PRCERR,PRCARR "RTN","PRCHJR01",148,0) . . S PRCX=PRCHJERR(PRCI),PRCE=$P(PRCX,U) D SET^HLOAPI(.PRCSEG,"ERR",0) "RTN","PRCHJR01",149,0) . . S PRCY=$P($T(ERRTABLE+PRCE),";;",2,99) "RTN","PRCHJR01",150,0) . . D SET^HLOAPI(.PRCSEG,$P(PRCY,U,2),2,1),SET^HLOAPI(.PRCSEG,1,2,2),SET^HLOAPI(.PRCSEG,$P(PRCY,U,3),2,3) "RTN","PRCHJR01",151,0) . . D:$P(PRCY,U,4) SET^HLOAPI(.PRCSEG,$P(PRCY,U,4),2,5) "RTN","PRCHJR01",152,0) . . D:$P(PRCY,U,5) SET^HLOAPI(.PRCSEG,$P(PRCY,U,5),2,6) "RTN","PRCHJR01",153,0) . . D SET^HLOAPI(.PRCSEG,$P(PRCY,U,6),3,1),SET^HLOAPI(.PRCSEG,$P(PRCY,U,7),3,2),SET^HLOAPI(.PRCSEG,"HL70357",3,3) "RTN","PRCHJR01",154,0) . . D SET^HLOAPI(.PRCSEG,$P(PRCY,U,8),4),SET^HLOAPI(.PRCSEG,$P(PRCY,U),5,1),SET^HLOAPI(.PRCSEG,$P(PRCY,U,9),5,2) "RTN","PRCHJR01",155,0) . . D SET^HLOAPI(.PRCSEG,$P(PRCX,U,2),8) "RTN","PRCHJR01",156,0) . . S PRCX=$$ADDSEG^HLOAPI(.PRCHJACK,.PRCSEG,.PRCERR,.PRCARR) "RTN","PRCHJR01",157,0) K PRCERR "RTN","PRCHJR01",158,0) I '$$SENDACK^HLOAPI2(.PRCHJACK,.PRCERR) S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="The sending of Application Acknowledgment to eCMS failed." "RTN","PRCHJR01",159,0) S PRCHJNOW=$$NOW^XLFDT D LOGORN^PRCHJR03 "RTN","PRCHJR01",160,0) Q "RTN","PRCHJR01",161,0) VALIDATE() ;Validate the data and existence of the 2237 and return "RTN","PRCHJR01",162,0) ; 1 if valid and 0 if there are errors "RTN","PRCHJR01",163,0) N PRC2237,PRCIEN,PRCSIEN,PRCSTAT,PRCSTN "RTN","PRCHJR01",164,0) S PRCHJCTR=0 K PRCHJERR "RTN","PRCHJR01",165,0) I '$D(^XTMP(PRCHJIND,"ORDER CONTROL")) S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="19^HL7 message is malformed as there is no ORC segment." Q 0 "RTN","PRCHJR01",166,0) I ^XTMP(PRCHJIND,"USER","LASTNAME")=""!(^XTMP(PRCHJIND,"USER","FIRSTNAME")="") D "RTN","PRCHJR01",167,0) . S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="1^eCMS User Name lacks first or last name." "RTN","PRCHJR01",168,0) I ^XTMP(PRCHJIND,"2237 TXN")="" D "RTN","PRCHJR01",169,0) . S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="11^2237 transaction number is not populated." "RTN","PRCHJR01",170,0) I ^XTMP(PRCHJIND,"RETURN REASON")="" D "RTN","PRCHJR01",171,0) . S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="2^Reason for Return is not populated." "RTN","PRCHJR01",172,0) I ^XTMP(PRCHJIND,"RETURN COMMENT")="" D "RTN","PRCHJR01",173,0) . S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="3^Comments is not populated." "RTN","PRCHJR01",174,0) I ";CA;UA;"'[(";"_^XTMP(PRCHJIND,"ORDER CONTROL")_";") D "RTN","PRCHJR01",175,0) . S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="8^Order Control field contains '"_^XTMP(PRCHJIND,"ORDER CONTROL")_"' which is invalid." "RTN","PRCHJR01",176,0) I ";CA;HD;IP;"'[(";"_^XTMP(PRCHJIND,"ORDER STATUS")_";") D "RTN","PRCHJR01",177,0) . S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="9^Order Status field contains '"_^XTMP(PRCHJIND,"ORDER STATUS")_"' which is invalid." "RTN","PRCHJR01",178,0) S PRC2237=$G(^XTMP(PRCHJIND,"2237 TXN")) S PRCIEN=$$FIND1^DIC(410,"","X",PRC2237,"B","","PRCERR") "RTN","PRCHJR01",179,0) I PRCIEN'>0 S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="6^"_PRC2237_" does not exist." "RTN","PRCHJR01",180,0) I PRCIEN D "RTN","PRCHJR01",181,0) . K PRCERR "RTN","PRCHJR01",182,0) . S PRCSTAT=$$GET1^DIQ(410,PRCIEN_",",54,"","","PRCERR") K PRCERR "RTN","PRCHJR01",183,0) . I PRCSTAT="",$$GET1^DIQ(410,PRCIEN_",",1,"","","PRCERR")="CANCELLED" S PRCSTAT="Cancelled" "RTN","PRCHJR01",184,0) . K PRCERR "RTN","PRCHJR01",185,0) . I ";SENT TO ECMS (P&C);ASSIGNED TO PURCHASING AGENT;RETURNED TO SERVICE BY P&C;RETURNED TO SERVICE BY PPM;"'[(";"_$$UP^XLFSTR(PRCSTAT)_";") D "RTN","PRCHJR01",186,0) . . S PRCHJCTR=PRCHJCTR+1 "RTN","PRCHJR01",187,0) . . S PRCHJERR(PRCHJCTR)="7^2237 status is '"_$S(PRCSTAT'="":PRCSTAT,1:"null")_"' and not 'Sent to eCMS (P&C)', 'Assigned to Purchasing Agent', 'Returned To Service by P&C' or 'Returned to Service by PPM'." "RTN","PRCHJR01",188,0) . I ";RETURNED TO SERVICE BY PPM;RETURNED TO SERVICE BY P&C;"[(";"_$$UP^XLFSTR(PRCSTAT)_";"),^XTMP(PRCHJIND,"ORDER STATUS")="IP" D "RTN","PRCHJR01",189,0) . . S PRCHJCTR=PRCHJCTR+1 "RTN","PRCHJR01",190,0) . . S PRCHJERR(PRCHJCTR)="21^2237 status is '"_PRCSTAT_"'. Thus 2237 cannot be returned to Accountable Officer as it is not CPO signed." "RTN","PRCHJR01",191,0) . K PRCERR N PRCACTID S PRCACTID=$$GET1^DIQ(410,PRCIEN_",",103,"","","PRCERR") K PRCERR "RTN","PRCHJR01",192,0) . I PRCACTID'=^XTMP(PRCHJIND,"ECMS ACTIONUID") D "RTN","PRCHJR01",193,0) . . S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="18^eCMS ActionUID on 2237 is "_$S(PRCACTID'="":PRCACTID,1:"null")_" but "_$S(^XTMP(PRCHJIND,"ECMS ACTIONUID")'="":^XTMP(PRCHJIND,"ECMS ACTIONUID"),1:"null")_" in HL7 message." "RTN","PRCHJR01",194,0) S PRCSTN=$G(^XTMP(PRCHJIND,"STATION")) S PRCSIEN=$$FIND1^DIC(411,"","X",PRCSTN,"B","","PRCERR") K PRCERR "RTN","PRCHJR01",195,0) I PRCSIEN'>0 S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="10^Station "_PRCSTN_" is not on this VistA instance." "RTN","PRCHJR01",196,0) I ^XTMP(PRCHJIND,"ACTION CREATED DATE")="" D "RTN","PRCHJR01",197,0) . S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="16^Date/Time of action is not populated." "RTN","PRCHJR01",198,0) I ^XTMP(PRCHJIND,"ECMS ACTIONUID")="" D "RTN","PRCHJR01",199,0) . S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="17^eCMS internal PR identifier ActionUID is missing." "RTN","PRCHJR01",200,0) I $G(^XTMP(PRCHJIND,"REQUISITION LINE NBR"))'=9999 S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="12^RQD segment is not correctly populated." "RTN","PRCHJR01",201,0) I ^XTMP(PRCHJIND,"ORDER CONTROL")="UA",";HD;IP;"'[(";"_^XTMP(PRCHJIND,"ORDER STATUS")_";") D "RTN","PRCHJR01",202,0) . S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="20^Order Status '"_^XTMP(PRCHJIND,"ORDER STATUS")_"' is inappropriate for Order Control UA." "RTN","PRCHJR01",203,0) Q $S(PRCHJCTR:0,1:1) "RTN","PRCHJR01",204,0) ; "RTN","PRCHJR01",205,0) ; "RTN","PRCHJR01",206,0) ADJDUEIN(PRCDA) ;Decrement due-ins "RTN","PRCHJR01",207,0) N PRCHJINV,PRCHJITM,PRCHJIMF,PRCHJQTY "RTN","PRCHJR01",208,0) S PRCHJINV=$P($G(^PRCS(410,PRCDA,0)),U,6) "RTN","PRCHJR01",209,0) Q:PRCHJINV'>0 Q:'$D(^PRCP(445,PRCHJINV,0)) "RTN","PRCHJR01",210,0) S PRCHJITM=0 "RTN","PRCHJR01",211,0) F S PRCHJITM=$O(^PRCS(410,PRCDA,"IT",PRCHJITM)) Q:+PRCHJITM'=PRCHJITM D "RTN","PRCHJR01",212,0) . S PRCHJIMF=$P($G(^PRCS(410,PRCDA,"IT",PRCHJITM,0)),U,5),PRCHJQTY=$P($G(^(0)),U,2) "RTN","PRCHJR01",213,0) . Q:PRCHJIMF'>0 Q:PRCHJQTY'>0 "RTN","PRCHJR01",214,0) . D KILLTRAN^PRCPUTRA(PRCHJINV,PRCHJIMF,PRCDA) "RTN","PRCHJR01",215,0) Q "RTN","PRCHJR01",216,0) ; "RTN","PRCHJR01",217,0) ERRTABLE ;Table of Error data "RTN","PRCHJR01",218,0) ;;1^ORC^10^^^101^Required field missing^E^eCMS user name not populated "RTN","PRCHJR01",219,0) ;;2^ORC^16^2^^101^Required field missing^E^Reason for Return not populated "RTN","PRCHJR01",220,0) ;;3^ORC^16^5^^101^Required field missing^E^Comments not populated "RTN","PRCHJR01",221,0) ;;4^ORC^14^4^^101^Required field missing^W^User's e-mail not populated "RTN","PRCHJR01",222,0) ;;5^ORC^14^1^^101^Required field missing^W^User's telephone# not populated "RTN","PRCHJR01",223,0) ;;6^ORC^2^1^^204^Unknown key identifier^E^2237 transaction not found "RTN","PRCHJR01",224,0) ;;7^ORC^2^1^^207^Application internal error^E^Status wrong for return or cancel "RTN","PRCHJR01",225,0) ;;8^ORC^1^^^103^Table value not found^E^Order Control value is wrong "RTN","PRCHJR01",226,0) ;;9^ORC^5^^^103^Table value not found^E^Order Status value is wrong "RTN","PRCHJR01",227,0) ;;10^ORC^2^2^^103^Table value not found^E^Site not on VistA instance "RTN","PRCHJR01",228,0) ;;11^ORC^2^1^^101^Required field missing^E^2237 txn# not populated "RTN","PRCHJR01",229,0) ;;12^RQD^1^^^207^Application internal error^E^Requisition line# wrong "RTN","PRCHJR01",230,0) ;;13^ORC^1^^^207^Application internal error^E^Return to AO incomplete "RTN","PRCHJR01",231,0) ;;14^ORC^1^^^207^Application internal error^E^Return to CP incomplete "RTN","PRCHJR01",232,0) ;;15^ORC^1^^^207^Application internal error^E^2237 cancelation incomplete "RTN","PRCHJR01",233,0) ;;16^ORC^9^1^^101^Required field missing^E^Action Date/Time missing "RTN","PRCHJR01",234,0) ;;17^ORC^3^1^^101^Required field missing^E^eCMS ActionUID missing "RTN","PRCHJR01",235,0) ;;18^ORC^3^1^^207^Application internal error^E^eCMS ActionUID mismatch "RTN","PRCHJR01",236,0) ;;19^ORC^1^^^100^Segment sequence error^E^ORC segment missing "RTN","PRCHJR01",237,0) ;;20^ORC^5^^^207^Application internal error^E^Mismatch Order Control/Status "RTN","PRCHJR01",238,0) ;;21^ORC^5^^^207^Application internal error^E^Cannot return to later status "RTN","PRCHJR03") 0^20^B10192642^B7485505 "RTN","PRCHJR03",1,0) PRCHJR03 ;OI&T/LKG - PROCESS 2237 RETURN OR CANCEL FROM ECMS CONT. ;7/10/13 12:07 "RTN","PRCHJR03",2,0) ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23 "RTN","PRCHJR03",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCHJR03",4,0) LOGOMN ;Log incoming OMN^O07 message "RTN","PRCHJR03",5,0) N PRCVAR1,PRCVAR2,PRCVAR3,PRCVAR4,PRCVAR5,X,Y "RTN","PRCHJR03",6,0) S PRCVAR1=$G(^XTMP(PRCHJIND,"2237 TXN")),PRCVAR2=$G(^XTMP(PRCHJIND,"ECMS ACTIONUID")) "RTN","PRCHJR03",7,0) S PRCVAR3=$S($G(^XTMP(PRCHJIND,"ORDER CONTROL"))="CA":10,$G(^XTMP(PRCHJIND,"ORDER STATUS"))="IP":6,1:8) "RTN","PRCHJR03",8,0) S PRCVAR4("MSGDT")=PRCHJMDT,PRCVAR4("MSGID")=PRCHJMID "RTN","PRCHJR03",9,0) S PRCVAR4("STN")=$G(^XTMP(PRCHJIND,"STATION")),PRCVAR4("SUBSTN")=$G(^XTMP(PRCHJIND,"SUBSTATION")) "RTN","PRCHJR03",10,0) S PRCVAR4("ECMSU")=$G(^XTMP(PRCHJIND,"USER","LASTNAME"))_", "_$G(^XTMP(PRCHJIND,"USER","FIRSTNAME"))_$S($G(^XTMP(PRCHJIND,"USER","MIDDLENAME"))'="":(" "_^("MIDDLENAME")),1:"") "RTN","PRCHJR03",11,0) S PRCVAR4("ECMSU")=$$UP^XLFSTR(PRCVAR4("ECMSU")) "RTN","PRCHJR03",12,0) S PRCVAR4("ECMSPH")=$G(^XTMP(PRCHJIND,"PHONE")),PRCVAR4("ECMSEM")=$G(^XTMP(PRCHJIND,"EMAIL")) "RTN","PRCHJR03",13,0) S PRCVAR4("ECMSDT")=$G(^XTMP(PRCHJIND,"ACTION CREATED DATE")) "RTN","PRCHJR03",14,0) S PRCVAR4("ECMSRN")=$G(^XTMP(PRCHJIND,"RETURN REASON")) "RTN","PRCHJR03",15,0) S PRCVAR4("ECMSCM")=$G(^XTMP(PRCHJIND,"RETURN COMMENT")) "RTN","PRCHJR03",16,0) D LOG^PRCHJTA(PRCVAR1,PRCVAR2,PRCVAR3,.PRCVAR4,.PRCVAR5) "RTN","PRCHJR03",17,0) Q "RTN","PRCHJR03",18,0) ; "RTN","PRCHJR03",19,0) LOGORN ;Log Ack ORN^O08 "RTN","PRCHJR03",20,0) N PRCVAR1,PRCVAR2,PRCVAR3,PRCVAR4,PRCVAR5 "RTN","PRCHJR03",21,0) S PRCVAR1=$G(^XTMP(PRCHJIND,"2237 TXN")),PRCVAR2=$G(^XTMP(PRCHJIND,"ECMS ACTIONUID")) "RTN","PRCHJR03",22,0) S PRCVAR3=$S($G(^XTMP(PRCHJIND,"ORDER CONTROL"))="CA":11,$G(^XTMP(PRCHJIND,"ORDER STATUS"))="IP":7,1:9) "RTN","PRCHJR03",23,0) S PRCVAR4("MSGDT")=PRCHJNOW,PRCVAR4("STN")=$G(^XTMP(PRCHJIND,"STATION")) "RTN","PRCHJR03",24,0) S PRCVAR4("SUBSTN")=$G(^XTMP(PRCHJIND,"SUBSTATION")) "RTN","PRCHJR03",25,0) I $D(PRCHJERR) D "RTN","PRCHJR03",26,0) . N PRCI,PRCCNT S PRCI=0,PRCCNT=0 "RTN","PRCHJR03",27,0) . F S PRCI=$O(PRCHJERR(PRCI)) Q:PRCI="" D "RTN","PRCHJR03",28,0) . . S PRCCNT=PRCCNT+1,PRCVAR4("ERROR",PRCCNT)=$TR(PRCHJERR(PRCI),"^",":") "RTN","PRCHJR03",29,0) D LOG^PRCHJTA(PRCVAR1,PRCVAR2,PRCVAR3,.PRCVAR4,.PRCVAR5) "RTN","PRCHJR03",30,0) Q "RTN","PRCHJR03",31,0) ; "RTN","PRCHJR03",32,0) XECMSIDS(PRCIEN) ;Removes eCMS identifiers "RTN","PRCHJR03",33,0) ;Removes eCMS ActionUID at header and ItemUIDs at item line of 2237 "RTN","PRCHJR03",34,0) ;Input PRCIEN should be IEN of the 2237 in file #410 "RTN","PRCHJR03",35,0) ; Returns '0' if successful and '1' if unsuccessful "RTN","PRCHJR03",36,0) Q:PRCIEN'>0 1 "RTN","PRCHJR03",37,0) N DA,PRCDATA,PRCERR,PRCHJDA,PRCI,PRCERROR "RTN","PRCHJR03",38,0) S PRCERROR=0,PRCHJDA=PRCIEN_",",PRCDATA(410,PRCHJDA,103)="@" "RTN","PRCHJR03",39,0) D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR03",40,0) S PRCI=0 "RTN","PRCHJR03",41,0) F S PRCI=$O(^PRCS(410,PRCIEN,"IT",PRCI)) Q:+PRCI'=PRCI D "RTN","PRCHJR03",42,0) . S PRCDATA(410.02,PRCI_","_PRCHJDA,100)="@" "RTN","PRCHJR03",43,0) . D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 "RTN","PRCHJR03",44,0) . K PRCDATA,PRCERR "RTN","PRCHJR03",45,0) Q PRCERROR "RTN","PRCHJR03",46,0) ; "RTN","PRCHJR03",47,0) ECMSRETN(PRCDA) ;Processes eCMS return of 2237 already returned by IFCAP "RTN","PRCHJR03",48,0) ; Ordering Officer or PPM Accountable Officer "RTN","PRCHJR03",49,0) ; Input parameter PRCDA contains the IEN of the 2237 entry in "RTN","PRCHJR03",50,0) ; file #410. "RTN","PRCHJR03",51,0) ; This extrinsic function returns '0' if error or '1' if successful. "RTN","PRCHJR03",52,0) ; As the 2237 was already returned, e-signatures were already stripped, "RTN","PRCHJR03",53,0) ; dollars were already uncommitted and due-ins were already reversed. "RTN","PRCHJR03",54,0) Q:$G(PRCDA)'>0 0 "RTN","PRCHJR03",55,0) N PRCDATA,PRCERR,PRCERROR,PRCIEN S PRCERROR=0,PRCIEN=PRCDA_"," "RTN","PRCHJR03",56,0) S PRCDATA(410,PRCIEN,56)=77 D FILE^DIE("K","PRCDATA","PRCERR") "RTN","PRCHJR03",57,0) S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR03",58,0) S PRCDATA(443,PRCIEN,1.5)=77 D FILE^DIE("K","PRCDATA","PRCERR") "RTN","PRCHJR03",59,0) S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR03",60,0) S PRCDATA(1)=^XTMP(PRCHJIND,"RETURN REASON") "RTN","PRCHJR03",61,0) S PRCDATA(2)=^XTMP(PRCHJIND,"RETURN COMMENT") "RTN","PRCHJR03",62,0) D WP^DIE(410,PRCIEN,61,"K","PRCDATA","PRCERR") "RTN","PRCHJR03",63,0) S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR "RTN","PRCHJR03",64,0) Q $S(PRCERROR:0,1:1) "RTN","PRCHJRP1") 1^28^^B201702299 "RTN","PRCHJRP2") 1^29^^B35489110 "RTN","PRCHJRP5") 0^26^B131946291^n/a "RTN","PRCHJRP5",1,0) PRCHJRP5 ;OI&T/DDA - Transaction Report from 414.06 ;3/22/13 13:48 "RTN","PRCHJRP5",2,0) ;;5.1;IFCAP;**174**;Oct 20,2000;Build 23 "RTN","PRCHJRP5",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCHJRP5",4,0) ; "RTN","PRCHJRP5",5,0) Q "RTN","PRCHJRP5",6,0) EN ;Revised Transaction Report "RTN","PRCHJRP5",7,0) ;setup user data "RTN","PRCHJRP5",8,0) K XQORNOD D OP^XQCHK "RTN","PRCHJRP5",9,0) S PRCHOPT=$S($P(XQOPT,"^")="PRCHJ TRANS REPORT":1,$P(XQOPT,"^")="PRCHJ TRANS REPORT2":2,$P(XQOPT,"^")="PRCHJ TRANS REPORT3":3,1:0) "RTN","PRCHJRP5",10,0) I PRCHOPT=0 W !!,"REPORT MUST BE RUN FROM APPROPRIATE MENU OPTIONS." Q "RTN","PRCHJRP5",11,0) S:$G(PRCHEMP)="" PRCHEMP=$$GET1^DIQ(200,DUZ_",",400,"I") "RTN","PRCHJRP5",12,0) I PRCHOPT=1 I '((PRCHEMP=2)!(PRCHEMP=4)) W !!,"You are not a PPM Accountable Officer or Manager!" Q "RTN","PRCHJRP5",13,0) EN2 ; "RTN","PRCHJRP5",14,0) D USERFCP "RTN","PRCHJRP5",15,0) I PRCHURSN=0 W !!,"You do not have access to any Fund Control Points!" Q "RTN","PRCHJRP5",16,0) ENSING ;prompt for a single 2237 "RTN","PRCHJRP5",17,0) K DIR "RTN","PRCHJRP5",18,0) S PRCH2237=0 "RTN","PRCHJRP5",19,0) S DIR("A")="Select a single 2237 TRANSACTION NUMBER" "RTN","PRCHJRP5",20,0) S DIR(0)="Y",DIR("B")="NO" D ^DIR "RTN","PRCHJRP5",21,0) ;If YES go to lookup and display for a single 2237. "RTN","PRCHJRP5",22,0) I Y=1 K DIR D SINGLE I PRCH2237=0 G ENSING "RTN","PRCHJRP5",23,0) I PRCH2237'=0 G FAUXPR "RTN","PRCHJRP5",24,0) S PRCH2237="ALL" "RTN","PRCHJRP5",25,0) I $G(DUOUT)!$G(DTOUT) G EXIT "RTN","PRCHJRP5",26,0) K DIR "RTN","PRCHJRP5",27,0) ENECMS ;prompt for a unique eCMS contact. PRCHECMS equals ALL or selection from ACONTACT cross-reference. "RTN","PRCHJRP5",28,0) S DIR("A")="Select a single eCMS Contact" "RTN","PRCHJRP5",29,0) S DIR(0)="Y",DIR("B")="NO" D ^DIR "RTN","PRCHJRP5",30,0) ;If NO, set PRCHECMS="ALL". If YES lookup eCMS contact then return. "RTN","PRCHJRP5",31,0) I Y=0 S (PRCHEML,PRCHECMS)="ALL" "RTN","PRCHJRP5",32,0) I Y=1 D ECMS I PRCHECMS=0 G ENECMS "RTN","PRCHJRP5",33,0) I $G(DUOUT)!$G(DTOUT) G EXIT "RTN","PRCHJRP5",34,0) K DIR "RTN","PRCHJRP5",35,0) DATE ;prompt for a date range. "RTN","PRCHJRP5",36,0) ;get default start and end dates "RTN","PRCHJRP5",37,0) S PRCHDATE=$P($O(^PRCV(414.06,"AED","")),".") "RTN","PRCHJRP5",38,0) S (PRCHSTDT,Y)=$P(PRCHDATE,".") D DD^%DT S PRCHSTAR=Y "RTN","PRCHJRP5",39,0) D NOW^%DTC S (PRCHENDT,Y)=X D DD^%DT S PRCHEND=Y "RTN","PRCHJRP5",40,0) K Y "RTN","PRCHJRP5",41,0) S DIR("A")="Select ALL DATES: ("_PRCHSTAR_" - "_PRCHEND_")" "RTN","PRCHJRP5",42,0) S DIR(0)="Y",DIR("B")="NO" D ^DIR "RTN","PRCHJRP5",43,0) ;If YES, set PRCHDATE="ALL" for "ALL DATES". If NO prompt for START and END dates. "RTN","PRCHJRP5",44,0) I Y=1 S PRCHDATE="ALL" "RTN","PRCHJRP5",45,0) I Y=0 D I PRCHSTDT=0 G DATE "RTN","PRCHJRP5",46,0) .K DIR,Y "RTN","PRCHJRP5",47,0) .; get start date "RTN","PRCHJRP5",48,0) .S PRCHSTDT=0 "RTN","PRCHJRP5",49,0) .S DIR("A")=" Starting date: " "RTN","PRCHJRP5",50,0) .S DIR(0)="DA^"_PRCHDATE_":NOW:EX",DIR("B")="TODAY" D ^DIR "RTN","PRCHJRP5",51,0) .S:Y'="^" PRCHSTDT=Y "RTN","PRCHJRP5",52,0) .Q:Y="^" "RTN","PRCHJRP5",53,0) .; get end date "RTN","PRCHJRP5",54,0) .K DIR,Y "RTN","PRCHJRP5",55,0) .S PRCHENDT=0 "RTN","PRCHJRP5",56,0) .S DIR("A")=" Ending date: " "RTN","PRCHJRP5",57,0) .S DIR(0)="DA^"_PRCHSTDT_":NOW:EX",DIR("B")="TODAY" D ^DIR "RTN","PRCHJRP5",58,0) .S:Y'="^" PRCHENDT=Y "RTN","PRCHJRP5",59,0) .S:Y="^" PRCHSTDT=0 "RTN","PRCHJRP5",60,0) .Q "RTN","PRCHJRP5",61,0) I $G(DUOUT)!$G(DTOUT) G EXIT "RTN","PRCHJRP5",62,0) K DIR "RTN","PRCHJRP5",63,0) ENSTN ;prompt for a unique station or substation. PRCHSTN equals ALL or selection from ASN cross-reference. "RTN","PRCHJRP5",64,0) ;If user has access to only one station, set the variable to that station and skip the prompt. "RTN","PRCHJRP5",65,0) ; And if the station selected does not have substations be sure to skip asking for them. "RTN","PRCHJRP5",66,0) S PRCSUBF=0 "RTN","PRCHJRP5",67,0) I PRCH411=1 S PRCHSTN=$O(PRCH411(0)) S PRCSUBF=1 D:+$G(PRCH411(PRCHSTN)) SUBSTN S:$G(PRCHSUB)="" PRCHSUB="ALL" G ENFCP "RTN","PRCHJRP5",68,0) I (PRCHOPT=2)&(PRCHURSN=1) S PRCHSTN=$O(PRCHURSN(0)) D:+$G(PRCH411(PRCHSTN)) SUBSTN S:$G(PRCHSUB)="" PRCHSUB="ALL" G ENFCP "RTN","PRCHJRP5",69,0) S DIR("A")="Select a single STATION NUMBER" "RTN","PRCHJRP5",70,0) S DIR(0)="Y",DIR("B")="NO" D ^DIR "RTN","PRCHJRP5",71,0) ;If NO, set PRCHSTN="ALL". If YES lookup station contact then return. "RTN","PRCHJRP5",72,0) I Y=0 S PRCHSTN="ALL",PRCHSUB="ALL" "RTN","PRCHJRP5",73,0) I Y=1 D STN I PRCHSTN=0 G ENSTN "RTN","PRCHJRP5",74,0) I $G(DUOUT)!$G(DTOUT) G EXIT "RTN","PRCHJRP5",75,0) K DIR "RTN","PRCHJRP5",76,0) ENFCP ;prompt for a unique Fund Control Point. PRCHFUND equals ALL or selection from ACP cross-reference. "RTN","PRCHJRP5",77,0) ;gather FCP accessable to this end-user "RTN","PRCHJRP5",78,0) S DIR("A")="Select a single FUND CONTROL POINT" "RTN","PRCHJRP5",79,0) S DIR(0)="Y",DIR("B")="NO" D ^DIR "RTN","PRCHJRP5",80,0) ;If NO, set PRCHFUND="ALL". If YES lookup control point. "RTN","PRCHJRP5",81,0) I Y=0 S PRCHFUND="ALL" "RTN","PRCHJRP5",82,0) I Y=1 D FCP I PRCHFUND=0 G ENFCP "RTN","PRCHJRP5",83,0) I $G(DUOUT)!$G(DTOUT) G EXIT "RTN","PRCHJRP5",84,0) K DIR "RTN","PRCHJRP5",85,0) ENTYPE ; "RTN","PRCHJRP5",86,0) S DIR(0)="LA^1:4",DIR("B")="1-4" "RTN","PRCHJRP5",87,0) S DIR("?")="This response must be a list or range, e.g., 1,3 or 1-2,4." "RTN","PRCHJRP5",88,0) S DIR("A",1)="TRANSACTION EVENTS:" "RTN","PRCHJRP5",89,0) S DIR("A",2)="" "RTN","PRCHJRP5",90,0) S DIR("A",3)=" 1 Sent to eCMS (includes resent 2237s)" "RTN","PRCHJRP5",91,0) S DIR("A",4)=" 2 Returned to Accountable Officer" "RTN","PRCHJRP5",92,0) S DIR("A",5)=" 3 Returned to Control Point" "RTN","PRCHJRP5",93,0) S DIR("A",6)=" 4 Cancelled within eCMS" "RTN","PRCHJRP5",94,0) S DIR("A",7)="" "RTN","PRCHJRP5",95,0) S DIR("A")="Select one or more of the above events: " "RTN","PRCHJRP5",96,0) D ^DIR "RTN","PRCHJRP5",97,0) S PRCHTYPE=Y,PRCHTT=0,PRCHTYTX="" "RTN","PRCHJRP5",98,0) F I=1:1 S PRCHTT=$P(PRCHTYPE,",",I) Q:PRCHTT="" S:PRCHTYTX'="" PRCHTYTX=PRCHTYTX_", " S PRCHTYTX=PRCHTYTX_$S(PRCHTT=1:"Sent to eCMS",PRCHTT=2:"Returned to AO",PRCHTT=3:"Returned to CP",PRCHTT=4:"Cancelled within eCMS",1:"") "RTN","PRCHJRP5",99,0) I $G(DUOUT)!$G(DTOUT) G EXIT "RTN","PRCHJRP5",100,0) K DIR "RTN","PRCHJRP5",101,0) ENERROR ;prompt for inclusion of ERROR text. Default = NO, do not include error text. "RTN","PRCHJRP5",102,0) S DIR("A")="Display event ERROR TEXT" "RTN","PRCHJRP5",103,0) S DIR(0)="Y",DIR("B")="NO" D ^DIR "RTN","PRCHJRP5",104,0) ;If NO, set PRCHERTX=0. "RTN","PRCHJRP5",105,0) I Y=0 S PRCHERTX=0 "RTN","PRCHJRP5",106,0) I Y=1 S PRCHERTX=1 "RTN","PRCHJRP5",107,0) I $G(DUOUT)!$G(DTOUT) G EXIT "RTN","PRCHJRP5",108,0) K DIR "RTN","PRCHJRP5",109,0) ; This is the end of the sort selection. Send to display/print. "RTN","PRCHJRP5",110,0) D FAUXPR "RTN","PRCHJRP5",111,0) Q "RTN","PRCHJRP5",112,0) ; "RTN","PRCHJRP5",113,0) SINGLE ; "RTN","PRCHJRP5",114,0) K DIC "RTN","PRCHJRP5",115,0) S DIC=414.06,DIC(0)="AEQZ",D="B" "RTN","PRCHJRP5",116,0) S DIC("A")="Select a 2237: " "RTN","PRCHJRP5",117,0) S:PRCHOPT=2 DIC("S")="S PRCH=$P(^(0),U) I $D(PRCHURCP($S($P(PRCH,""-"",4)'="""":$P(PRCH,""-"",4),1:PRCH),+$G(PRCHURSN($P(PRCH,""-"")))))=1" "RTN","PRCHJRP5",118,0) D IX^DIC "RTN","PRCHJRP5",119,0) K DIC,PRCH,RESULTS "RTN","PRCHJRP5",120,0) Q:Y=-1 "RTN","PRCHJRP5",121,0) S PRCH2237=Y(0,0),PRCHERTX=1 "RTN","PRCHJRP5",122,0) K DIR "RTN","PRCHJRP5",123,0) Q "RTN","PRCHJRP5",124,0) ; "RTN","PRCHJRP5",125,0) ECMS ;Returns with PRCHECMS set. Failure code = 0 "RTN","PRCHJRP5",126,0) S PRCHECMS=0 "RTN","PRCHJRP5",127,0) K DIR "RTN","PRCHJRP5",128,0) W ! "RTN","PRCHJRP5",129,0) ; Populate DIR(0) for a SET of CODES DIR call "RTN","PRCHJRP5",130,0) S DIR("L",1)="Select one of the following eCMS Contacts:" "RTN","PRCHJRP5",131,0) S DIR("L",2)="" "RTN","PRCHJRP5",132,0) S DIR(0)="SO^",PRCRIL=2,PRCRI=0,PRCETMP0="" "RTN","PRCHJRP5",133,0) F S PRCETMP0=$O(^PRCV(414.06,"AUNQEC",PRCETMP0)) Q:PRCETMP0="" D "RTN","PRCHJRP5",134,0) . S PRCRI=PRCRI+1,PRCRIL=PRCRIL+1,PRCETMP1=$P(PRCETMP0," "),PRCETMP3=$P(PRCETMP0," ",2) "RTN","PRCHJRP5",135,0) . S:PRCRI>1 DIR(0)=DIR(0)_";" "RTN","PRCHJRP5",136,0) . S DIR(0)=DIR(0)_PRCRI_":"_PRCETMP1 "RTN","PRCHJRP5",137,0) . S:PRCRI<10 DIR("L",PRCRIL)=" " "RTN","PRCHJRP5",138,0) . S DIR("L",PRCRIL)=$G(DIR("L",PRCRIL))_" "_PRCRI_" "_PRCETMP0 "RTN","PRCHJRP5",139,0) .Q "RTN","PRCHJRP5",140,0) S DIR("L")="" "RTN","PRCHJRP5",141,0) D ^DIR "RTN","PRCHJRP5",142,0) Q:$G(DUOUT)!$G(DTOUT)!$D(DIRUT) "RTN","PRCHJRP5",143,0) S PRCRIL=Y+2 "RTN","PRCHJRP5",144,0) S PRCHECMS=$P(DIR("L",PRCRIL),Y_" ",2) "RTN","PRCHJRP5",145,0) S PRCHEML=$P(PRCHECMS," ",2) "RTN","PRCHJRP5",146,0) K DIR,PRCRIL "RTN","PRCHJRP5",147,0) Q "RTN","PRCHJRP5",148,0) ; "RTN","PRCHJRP5",149,0) STN ;Returns with PRCHSTN set. Failure = 0 "RTN","PRCHJRP5",150,0) ; EXCLUDE SUBSTATIONS from inital lookup. "RTN","PRCHJRP5",151,0) S PRCHSTN=0 "RTN","PRCHJRP5",152,0) K DIR "RTN","PRCHJRP5",153,0) S DIR(0)="PO^411:AEQ" "RTN","PRCHJRP5",154,0) S DIR("A")="Select Station" "RTN","PRCHJRP5",155,0) S DIR("S")="I (+$P(^(0),U)=$P(^(0),U))&($D(PRCHJSN($P(^(0),U)))=1)" "RTN","PRCHJRP5",156,0) S:PRCHOPT=2 DIR("S")="I ($D(PRCHURSN(+($P(^(0),U))))=1)&(+$P(^(0),U)=$P(^(0),U))&($D(PRCHJSN($P(^(0),U)))=1)" "RTN","PRCHJRP5",157,0) D ^DIR "RTN","PRCHJRP5",158,0) K PRCRI ; Variable left over from DD; file 411 lookup post action code. "RTN","PRCHJRP5",159,0) Q:$G(DUOUT)!$G(DTOUT)!$D(DIRUT) "RTN","PRCHJRP5",160,0) S PRCHSTN=$P(Y,"^",2) "RTN","PRCHJRP5",161,0) SUBSTN ;Returns PRCHSUB = ALL if the user does not want to select a substation. "RTN","PRCHJRP5",162,0) S PRCHSUB="" "RTN","PRCHJRP5",163,0) I +$G(PRCH411(PRCHSTN))=0 S PRCHSUB="ALL" Q "RTN","PRCHJRP5",164,0) S DIR("A")=" Do you want to see the records for ALL the substations of "_PRCHSTN "RTN","PRCHJRP5",165,0) S DIR(0)="Y",DIR("B")="YES" D ^DIR "RTN","PRCHJRP5",166,0) I Y=1 S PRCHSUB="ALL" Q "RTN","PRCHJRP5",167,0) I $G(DUOUT)!$G(DTOUT)!$D(DIRUT) G:'PRCSUBF STN Q "RTN","PRCHJRP5",168,0) K DIR "RTN","PRCHJRP5",169,0) S DIR(0)="SO^1:"_PRCHSTN_" "_PRCH411(PRCHSTN,PRCHSTN) "RTN","PRCHJRP5",170,0) S PRCRI=1,PRCHSUB=PRCHSTN "RTN","PRCHJRP5",171,0) F S PRCHSUB=$O(PRCH411(PRCHSTN,PRCHSUB)) Q:+PRCHSUB'>0 S:$D(PRCHJSB(PRCHSUB))=1 PRCRI=PRCRI+1,DIR(0)=DIR(0)_";"_PRCRI_":"_PRCHSUB_" "_PRCH411(PRCHSTN,PRCHSUB) "RTN","PRCHJRP5",172,0) S DIR("A")="SUBSTATION" D ^DIR "RTN","PRCHJRP5",173,0) ;Returns PRCHSUB = "NONE" if user selects the PRIMARY station number, "RTN","PRCHJRP5",174,0) ; otherwise PRCHSUB is the substation number and PRCHSTN = "SUB". "RTN","PRCHJRP5",175,0) I $G(DUOUT)!$G(DTOUT)!$D(DIRUT) G SUBSTN "RTN","PRCHJRP5",176,0) S PRCHSUB=$P(Y(0)," ") "RTN","PRCHJRP5",177,0) I PRCHSUB'=PRCHSTN S PRCHSTN="SUB" Q "RTN","PRCHJRP5",178,0) S:PRCHSUB=PRCHSTN PRCHSUB="NONE" "RTN","PRCHJRP5",179,0) Q "RTN","PRCHJRP5",180,0) ; "RTN","PRCHJRP5",181,0) FCP ; Allow selection of a FCP. "RTN","PRCHJRP5",182,0) ; All FCP accessible to this user are stored in the following array which can be used for AO screening. "RTN","PRCHJRP5",183,0) ; PRCHURCP(fcp with any leading zeros,station)=full fcp text "RTN","PRCHJRP5",184,0) S PRCHFUND=0 "RTN","PRCHJRP5",185,0) S DIC=414.06,DIC(0)="AEQSZ",D="AUNQFCP" "RTN","PRCHJRP5",186,0) S DIC("A")="Fund Control Point: " "RTN","PRCHJRP5",187,0) S DIC("W")="" "RTN","PRCHJRP5",188,0) ; No screen if AO and ALL stations "RTN","PRCHJRP5",189,0) ; Screens "RTN","PRCHJRP5",190,0) ; AO/Manager/Fiscal and a station "RTN","PRCHJRP5",191,0) S:(PRCHOPT=1)&(+PRCHSTN'=0) DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSTN,1,3)))=1" "RTN","PRCHJRP5",192,0) S:(PRCHOPT=1)&(PRCHSTN="SUB") DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSUB,1,3)))=1" "RTN","PRCHJRP5",193,0) S:(PRCHOPT=3)&(+PRCHSTN'=0) DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSTN,1,3)))=1" "RTN","PRCHJRP5",194,0) S:(PRCHOPT=3)&(PRCHSTN="SUB") DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSUB,1,3)))=1" "RTN","PRCHJRP5",195,0) ; CP and ALL stations "RTN","PRCHJRP5",196,0) S:(PRCHOPT=2)&(PRCHSTN="ALL") DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X)))=10" "RTN","PRCHJRP5",197,0) ; CP and a station/substation "RTN","PRCHJRP5",198,0) S:(PRCHOPT=2)&(+PRCHSTN'=0) DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSTN,1,3)))=1" "RTN","PRCHJRP5",199,0) S:(PRCHOPT=2)&(PRCHSTN="SUB") DIC("S")="I $D(PRCHURCP($S($P(X,""-"",4)'="""":$P(X,""-"",4),1:X),$E(PRCHSUB,1,3)))=1" "RTN","PRCHJRP5",200,0) D IX^DIC "RTN","PRCHJRP5",201,0) Q:Y=-1 "RTN","PRCHJRP5",202,0) S PRCHFUND=$P(Y(0,0),"-",4) "RTN","PRCHJRP5",203,0) W " "_PRCHFUND "RTN","PRCHJRP5",204,0) K DIC,D "RTN","PRCHJRP5",205,0) Q "RTN","PRCHJRP5",206,0) ; "RTN","PRCHJRP5",207,0) USERFCP ; Build the arrays of the FCPs and Stations the user has access to. "RTN","PRCHJRP5",208,0) K PRCHURCP,PRCHURSN "RTN","PRCHJRP5",209,0) ; Build array for Stations and Substations that exist in 414.06 "RTN","PRCHJRP5",210,0) S PRCHI=0 "RTN","PRCHJRP5",211,0) F S PRCHI=$O(^PRCV(414.06,"ASN",PRCHI)) Q:+PRCHI'>0 S PRCHJSN(PRCHI)="" "RTN","PRCHJRP5",212,0) S PRCHI="" "RTN","PRCHJRP5",213,0) F S PRCHI=$O(^PRCV(414.06,"ASB",PRCHI)) Q:PRCHI="" S PRCHJSB(PRCHI)="" "RTN","PRCHJRP5",214,0) S PRCHURLV="OTHER" "RTN","PRCHJRP5",215,0) ; Set PPM Accountable Officers and Managers to the same access level (PRCHURLV) "RTN","PRCHJRP5",216,0) S:(PRCHEMP=2)!(PRCHEMP=4) PRCHURLV="AO" "RTN","PRCHJRP5",217,0) S (PRCH420,PRCHURSN)=0 "RTN","PRCHJRP5",218,0) ; Allow access to all FCP if using AO option AND file 200 SUPPLY EMPLOYEE access level is AO or Manager OR if entered on REPORT3. "RTN","PRCHJRP5",219,0) I ((PRCHOPT=1)&(PRCHURLV="AO"))!(PRCHOPT=3) F S PRCH420=$O(^PRC(420,PRCH420)) Q:+PRCH420'>0 D "RTN","PRCHJRP5",220,0) .S PRCH4206=0 "RTN","PRCHJRP5",221,0) .F S PRCH4206=$O(^PRC(420,PRCH420,1,PRCH4206)) Q:+PRCH4206'>0 D "RTN","PRCHJRP5",222,0) ..S PRCH6=$P($G(^PRC(420,PRCH420,1,PRCH4206,0)),"^") "RTN","PRCHJRP5",223,0) ..Q:PRCH6="" "RTN","PRCHJRP5",224,0) ..Q:$P($G(^PRC(420,PRCH420,1,PRCH4206,0)),"^",11)'="Y" "RTN","PRCHJRP5",225,0) ..S:'$D(PRCHURSN(PRCH420)) PRCHURSN(PRCH420)=PRCH420,PRCHURSN=PRCHURSN+1 "RTN","PRCHJRP5",226,0) ..S PRCHURCP($P(PRCH6," "),PRCH420)=PRCH6 "RTN","PRCHJRP5",227,0) ..Q "RTN","PRCHJRP5",228,0) .Q "RTN","PRCHJRP5",229,0) ; If entring on REPORT2, check for individual's assigned FCP regardless of file 200 SUPPLY EMPLOYEE access level. "RTN","PRCHJRP5",230,0) ; This is also restriced within 420 to disallow REQUESTER acccess (only allow CP Clerk or CP Official) "RTN","PRCHJRP5",231,0) I PRCHOPT=2 S PRCHURSN=0 F S PRCH420=$O(^PRC(420,PRCH420)) Q:+PRCH420'>0 D "RTN","PRCHJRP5",232,0) .S PRCH4206=0 "RTN","PRCHJRP5",233,0) .F S PRCH4206=$O(^PRC(420,PRCH420,1,PRCH4206)) Q:+PRCH4206'>0 D "RTN","PRCHJRP5",234,0) ..S PRCH6=$P($G(^PRC(420,PRCH420,1,PRCH4206,0)),"^") "RTN","PRCHJRP5",235,0) ..Q:PRCH6="" "RTN","PRCHJRP5",236,0) ..Q:$P($G(^PRC(420,PRCH420,1,PRCH4206,0)),"^",11)'="Y" "RTN","PRCHJRP5",237,0) ..Q:'+$G(^PRC(420,PRCH420,1,PRCH4206,1,DUZ,0)) "RTN","PRCHJRP5",238,0) ..Q:(+$P($G(^PRC(420,PRCH420,1,PRCH4206,1,DUZ,0)),"^",2)=3)!(+$P($G(^PRC(420,PRCH420,1,PRCH4206,1,DUZ,0)),"^",2)=0) "RTN","PRCHJRP5",239,0) ..S:'$D(PRCHURSN(PRCH420)) PRCHURSN(PRCH420)=PRCH420,PRCHURSN=PRCHURSN+1 "RTN","PRCHJRP5",240,0) ..S PRCHURCP($P(PRCH6," "),PRCH420)=PRCH6 "RTN","PRCHJRP5",241,0) ..Q "RTN","PRCHJRP5",242,0) .Q "RTN","PRCHJRP5",243,0) ; Set count for IFCAP instance number of stations, and each station's number of substations. "RTN","PRCHJRP5",244,0) ;$D(^DIC(4,+$P(^(0),U,10),0)) S PRCHSITE=$P(^(0),U,1) "RTN","PRCHJRP5",245,0) S (PRCH411,PRCHINSN)=0 F S PRCHINSN=$O(^PRC(411,"B",PRCHINSN)) Q:+PRCHINSN'>0 D "RTN","PRCHJRP5",246,0) .S PRCHINIC=0 S PRCHINIC=$O(^PRC(411,"B",PRCHINSN,PRCHINIC)) Q:+PRCHINIC'>0 D "RTN","PRCHJRP5",247,0) ..I PRCHINIC<1000000 S PRCH411=PRCH411+1,PRCH411(+PRCHINSN,$P(^PRC(411,PRCHINIC,0),"^"))=$P(^DIC(4,$P(^PRC(411,PRCHINIC,0),"^",10),0),"^") "RTN","PRCHJRP5",248,0) ..I PRCHINIC>999999 S PRCH411(+PRCHINSN)=$G(PRCH411(+PRCHINSN))+1,PRCH411(+PRCHINSN,$P(^PRC(411,PRCHINIC,0),"^"))=$P(^DIC(4,$P(^PRC(411,PRCHINIC,0),"^",10),0),"^") "RTN","PRCHJRP5",249,0) ..Q "RTN","PRCHJRP5",250,0) .Q "RTN","PRCHJRP5",251,0) Q "RTN","PRCHJRP5",252,0) ; "RTN","PRCHJRP5",253,0) EXITZT ; "RTN","PRCHJRP5",254,0) W ! D ^%ZISC,HOME^%ZIS K IO("Q") "RTN","PRCHJRP5",255,0) EXIT ; "RTN","PRCHJRP5",256,0) K %ZIS,D,DIC,DIR,DIROUT,DIRUT,PRCH420,PRCH4206,PRCH6,PRCRI,PRCSUBF,X,Y,ZTDESC,ZTRTN,ZTSAVE,ZTSK "RTN","PRCHJRP5",257,0) K PRCH2237,PRCHDATE,PRCHECMS,PRCHEMP,PRCHENDT,PRCHFUND,PRCHJSB,PRCHJSN,PRCHLAST,PRCHOPT,PRCHSTDT,PRCHSTN,PRCHSUB,PRCHTYPE,PRCHURCP,PRCHURSN,PRCHURLV "RTN","PRCHJRP5",258,0) Q "RTN","PRCHJRP5",259,0) ; "RTN","PRCHJRP5",260,0) FAUXPR ; DISPLAY OF THE SELECTIONS "RTN","PRCHJRP5",261,0) ;SINGLE 2237 "RTN","PRCHJRP5",262,0) I $G(PRCH2237)'="ALL" W !!,"The single 2237, "_PRCH2237_", has been selected for printing. " G FX "RTN","PRCHJRP5",263,0) ;EVERYTHING ELSE "RTN","PRCHJRP5",264,0) W !!,"All eCMS 2237s matching your selections below will be displayed:" "RTN","PRCHJRP5",265,0) ;ECMS CONTACT "RTN","PRCHJRP5",266,0) W !," ",$S(PRCHECMS="ALL":"All eCMS Contacts",1:"eCMS Contact: "_PRCHEML) "RTN","PRCHJRP5",267,0) ;DATE RANGE "RTN","PRCHJRP5",268,0) I PRCHDATE'="ALL" S Y=PRCHSTDT D DD^%DT S PRCHSTAR=Y S Y=PRCHENDT D DD^%DT S PRCHEND=Y K Y "RTN","PRCHJRP5",269,0) W !," ",$S(PRCHDATE="ALL":"All dates: ("_PRCHSTAR_" - "_PRCHEND_")",1:"Dates: ("_PRCHSTAR_" - "_PRCHEND_")") "RTN","PRCHJRP5",270,0) ;STATION/SUBSTATION "RTN","PRCHJRP5",271,0) W !," ",$S(PRCHSTN="ALL":"All Stations and Substations",1:"Station: "_$S(+PRCHSTN:PRCHSTN,PRCHSTN="SUB":+PRCHSUB,1:"")) "RTN","PRCHJRP5",272,0) W $S($G(PRCHSUB)="NONE":", records for substation "_+PRCHSTN,((+PRCHSTN)&($D(PRCH411(+PRCHSTN))'=11)):"",((+PRCHSTN)&(PRCHSUB="ALL")):", records for each substation",((PRCHSTN="ALL")&(PRCHSUB="ALL")):"",1:", records for substation "_PRCHSUB) "RTN","PRCHJRP5",273,0) ;FCP "RTN","PRCHJRP5",274,0) W !," ",$S(PRCHFUND="ALL":"All Fund Control Points",1:"Fund Control Point: "_PRCHFUND) "RTN","PRCHJRP5",275,0) ;EVENT TYPE "RTN","PRCHJRP5",276,0) W !," Event Types selected are:" "RTN","PRCHJRP5",277,0) S PRCHI=1,PRCHSLTY=PRCHTYPE "RTN","PRCHJRP5",278,0) S PRCHTYPE="," "RTN","PRCHJRP5",279,0) F S PRCHJ=$P(PRCHSLTY,",",PRCHI) Q:+PRCHJ'>0 S PRCHI=PRCHI+1 D "RTN","PRCHJRP5",280,0) .I PRCHJ=1 W !," 1 = Sent to eCMS (includes resent 2237s)" S PRCHTYPE=PRCHTYPE_"1," "RTN","PRCHJRP5",281,0) .I PRCHJ=2 W !," 2 = Returned to Accountable Officer" S PRCHTYPE=PRCHTYPE_"6," "RTN","PRCHJRP5",282,0) .I PRCHJ=3 W !," 3 = Returned to Control Point" S PRCHTYPE=PRCHTYPE_"8," "RTN","PRCHJRP5",283,0) .I PRCHJ=4 W !," 4 = Cancelled within eCMS" S PRCHTYPE=PRCHTYPE_"10," "RTN","PRCHJRP5",284,0) .Q "RTN","PRCHJRP5",285,0) ;FULL ERROR TEXT "RTN","PRCHJRP5",286,0) W !," ",$S(PRCHERTX:"The full text of any errors will be displayed.",1:"A note will display for any errors, but not the full text.") "RTN","PRCHJRP5",287,0) FX ; Get Device "RTN","PRCHJRP5",288,0) K IOP,%ZIS "RTN","PRCHJRP5",289,0) W ! S %ZIS="MQ" D ^%ZIS W ! "RTN","PRCHJRP5",290,0) G:POP EXIT "RTN","PRCHJRP5",291,0) I $D(IO("Q")) S ZTRTN="GATHER^PRCHJRP6",ZTDESC="Transaction Report - eCMS/IFCAP",ZTSAVE("PRCH*")="" D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Cancelled!"),! G EXITZT "RTN","PRCHJRP5",292,0) D GATHER^PRCHJRP6 "RTN","PRCHJRP5",293,0) D EXIT "RTN","PRCHJRP5",294,0) Q "RTN","PRCHJRP6") 0^27^B82490228^n/a "RTN","PRCHJRP6",1,0) PRCHJRP6 ;OI&T/DDA - Transaction Report from 414.06 [CONT.] ;5/21/13 13:48 "RTN","PRCHJRP6",2,0) V ;;5.1;IFCAP;**174**;Oct 20,2000;Build 23 "RTN","PRCHJRP6",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCHJRP6",4,0) ; "RTN","PRCHJRP6",5,0) Q "RTN","PRCHJRP6",6,0) GATHER ; "RTN","PRCHJRP6",7,0) K ^TMP("PRCHJRP6",$J) "RTN","PRCHJRP6",8,0) N CHECKED,NODE0,NODE1,NODE2,NODEHALF,DIR,Y "RTN","PRCHJRP6",9,0) N PRC2237,PRCACKER,PRCEDT,PRCEDTX,PRCEVENT,PRCEVTX,PRCEXIT,PRCI,PRCPAGE,PRCRUNDT,PRCSTN "RTN","PRCHJRP6",10,0) N PRCH37,PRCHAND,PRCHCNT,PRCHCTYP,PRCHEDT,PRCHEIEN,PRCHERCT,PRCHERR,PRCHESTN,PRCHEVNT,PRCHEVT,PRCHIEN,PRCHKFCP,PRCHKSTN,PRCHLPDT,PRCHSDT,PRCHSDTX,PRCHSHKE,PRCHSEI,PRCHSI,PRCHSNGL "RTN","PRCHJRP6",11,0) S PRCHSNGL=0,PRCH37=PRCH2237 "RTN","PRCHJRP6",12,0) ; Build the handshake events for those primary events selected. "RTN","PRCHJRP6",13,0) I PRCH2237="ALL" D "RTN","PRCHJRP6",14,0) . I $G(PRCHTYPE)'="ALL" D "RTN","PRCHJRP6",15,0) ..; Include RESENT (4) to be equal to SEND (1) event "RTN","PRCHJRP6",16,0) .. S PRCHAND=",",PRCHTYPE=","_PRCHTYPE "RTN","PRCHJRP6",17,0) .. S:PRCHTYPE[",1," PRCHAND=PRCHAND_"2,",PRCHTYPE=",1,4,"_$P(PRCHTYPE,",1,",2) "RTN","PRCHJRP6",18,0) .. S:PRCHTYPE[",6," PRCHAND=PRCHAND_"7," "RTN","PRCHJRP6",19,0) .. S:PRCHTYPE[",8," PRCHAND=PRCHAND_"9," "RTN","PRCHJRP6",20,0) .. S:PRCHTYPE[",10," PRCHAND=PRCHAND_"11," "RTN","PRCHJRP6",21,0) ..Q "RTN","PRCHJRP6",22,0) . I PRCHTYPE="ALL" S PRCHTYPE=",1,4,6,8,10,",PRCHAND=",2,7,9,11," "RTN","PRCHJRP6",23,0) ; if single GRABIT, SORTIT and DISPLAY it; then exit. "RTN","PRCHJRP6",24,0) I +PRCH2237 D G EXITD "RTN","PRCHJRP6",25,0) . S PRCHIEN="" "RTN","PRCHJRP6",26,0) . S PRCHTYPE=",1,4,6,8,10,",PRCHAND=",2,7,9,11,",PRCHSNGL=1 "RTN","PRCHJRP6",27,0) . S PRCHIEN=$O(^PRCV(414.06,"B",PRCH2237,PRCHIEN)) "RTN","PRCHJRP6",28,0) . S (PRCHCNT,PRCHEIEN)=0 "RTN","PRCHJRP6",29,0) . F S PRCHEIEN=$O(^PRCV(414.06,PRCHIEN,1,PRCHEIEN)) Q:+PRCHEIEN'>0 D GRABIT D "RTN","PRCHJRP6",30,0) .. I PRCHDATA=0 K PRCHDATA Q "RTN","PRCHJRP6",31,0) .. S PRCHEDT=$P(PRCHDATA(PRCHEIEN,0),"^"),PRCHEVNT=$P(PRCHDATA(PRCHEIEN,0),"^",2),PRCHESTN=$P(PRCH2237,"-") "RTN","PRCHJRP6",32,0) .. D SORTIT "RTN","PRCHJRP6",33,0) .. K PRCHDATA "RTN","PRCHJRP6",34,0) ..Q "RTN","PRCHJRP6",35,0) . D DISPLAY "RTN","PRCHJRP6",36,0) .Q "RTN","PRCHJRP6",37,0) ; loop on event date; GRABIT, CHECKS, SORTIT, new loop to add ACK Handshake data outside the date range, DISPLAY. "RTN","PRCHJRP6",38,0) S PRCHLPDT=PRCHSTDT "RTN","PRCHJRP6",39,0) F S PRCHLPDT=$O(^PRCV(414.06,"AED",PRCHLPDT)) Q:(+PRCHLPDT'>0)!($P(PRCHLPDT,".")>PRCHENDT) S PRCHAKLP=PRCHLPDT D "RTN","PRCHJRP6",40,0) . S PRCHIEN=0 "RTN","PRCHJRP6",41,0) . F S PRCHIEN=$O(^PRCV(414.06,"AED",PRCHLPDT,PRCHIEN)) Q:+PRCHIEN'>0 D "RTN","PRCHJRP6",42,0) .. S PRCHEIEN=0 "RTN","PRCHJRP6",43,0) .. F S PRCHEIEN=$O(^PRCV(414.06,"AED",PRCHLPDT,PRCHIEN,PRCHEIEN)) Q:+PRCHEIEN'>0 S PRCH2237=$P(^PRCV(414.06,PRCHIEN,0),"^") D GRABIT D "RTN","PRCHJRP6",44,0) ... I PRCHDATA=0 K PRCHDATA Q "RTN","PRCHJRP6",45,0) ... D CHECKS "RTN","PRCHJRP6",46,0) ... S PRCHEDT=$P(PRCHDATA(PRCHEIEN,0),"^"),PRCHEVNT=$P(PRCHDATA(PRCHEIEN,0),"^",2),PRCHESTN=$P(PRCH2237,"-") "RTN","PRCHJRP6",47,0) ... S:+PRCHEVNT=0 CHECKED=0 "RTN","PRCHJRP6",48,0) ... D:CHECKED SORTIT "RTN","PRCHJRP6",49,0) ... K PRCH2237,PRCHDATA "RTN","PRCHJRP6",50,0) ...Q "RTN","PRCHJRP6",51,0) ..Q "RTN","PRCHJRP6",52,0) .Q "RTN","PRCHJRP6",53,0) ; Grab any remaining ACK Handshake data, if any. By skipping CHECKS and SORTIT, only ACK handshake data is selected via GRABIT. "RTN","PRCHJRP6",54,0) G:PRCHLPDT'>0 D1 "RTN","PRCHJRP6",55,0) S PRCHLPDT=PRCHAKLP "RTN","PRCHJRP6",56,0) F S PRCHLPDT=$O(^PRCV(414.06,"AED",PRCHLPDT)) Q:(+PRCHLPDT'>0) D "RTN","PRCHJRP6",57,0) . S PRCHIEN=0 "RTN","PRCHJRP6",58,0) . F S PRCHIEN=$O(^PRCV(414.06,"AED",PRCHLPDT,PRCHIEN)) Q:+PRCHIEN'>0 D "RTN","PRCHJRP6",59,0) .. S PRCHEIEN=0 "RTN","PRCHJRP6",60,0) .. F S PRCHEIEN=$O(^PRCV(414.06,"AED",PRCHLPDT,PRCHIEN,PRCHEIEN)) Q:+PRCHEIEN'>0 S PRCH2237=$P(^PRCV(414.06,PRCHIEN,0),"^") D GRABIT D "RTN","PRCHJRP6",61,0) ... I PRCHDATA=0 K PRCHDATA Q "RTN","PRCHJRP6",62,0) ... K PRCH2237,PRCHDATA "RTN","PRCHJRP6",63,0) ...Q "RTN","PRCHJRP6",64,0) ..Q "RTN","PRCHJRP6",65,0) .Q "RTN","PRCHJRP6",66,0) D1 D DISPLAY "RTN","PRCHJRP6",67,0) D EXITD "RTN","PRCHJRP6",68,0) Q "RTN","PRCHJRP6",69,0) CHECKS ; SCREENS - DATE RANGE AND TYPE HAVE ALREADY BEEN SCREENED "RTN","PRCHJRP6",70,0) S CHECKED=0 "RTN","PRCHJRP6",71,0) S PRCHEDT=PRCHLPDT "RTN","PRCHJRP6",72,0) S PRCH2237=$P(PRCHDATA(PRCHIEN,"IEN",0),"^") "RTN","PRCHJRP6",73,0) ; exit if FCP does not pass USER screen "RTN","PRCHJRP6",74,0) S PRCHKSTN=$P(PRCH2237,"-"),PRCHKFCP=$P(PRCH2237,"-",4) "RTN","PRCHJRP6",75,0) Q:$D(PRCHURCP(PRCHKFCP,PRCHKSTN))'=1 "RTN","PRCHJRP6",76,0) G:PRCHFUND="ALL" CHKECMS "RTN","PRCHJRP6",77,0) ; exit if FCP does not pass SELECTION screen "RTN","PRCHJRP6",78,0) Q:PRCHKFCP'=PRCHFUND "RTN","PRCHJRP6",79,0) CHKECMS ; if ecms contact = ALL continue, else exit if it does not pass the SELECTION screen "RTN","PRCHJRP6",80,0) G:PRCHECMS="ALL" CHKSTN "RTN","PRCHJRP6",81,0) Q:$P($G(PRCHDATA(PRCHEIEN,1)),"^",6)'=PRCHEML "RTN","PRCHJRP6",82,0) CHKSTN ; screen station and substation "RTN","PRCHJRP6",83,0) ; if station = ALL and substation = ALL, continue "RTN","PRCHJRP6",84,0) G:(PRCHSTN="ALL")&(PRCHSUB="ALL") CHKDONE "RTN","PRCHJRP6",85,0) ; if substation selected; i.e. - station = SUB and substation = substation ID, screen to continue "RTN","PRCHJRP6",86,0) I PRCHSTN="SUB" Q:$P($G(PRCHDATA(PRCHEIEN,1)),"^",2)'=PRCHSUB "RTN","PRCHJRP6",87,0) ; if station selected and substation = ALL; screen to continue "RTN","PRCHJRP6",88,0) I (+PRCHSTN)&(PRCHSUB="ALL") Q:+PRCHSTN'=PRCHKSTN "RTN","PRCHJRP6",89,0) ; if station selected and substation = NONE, screen to continue "RTN","PRCHJRP6",90,0) I (+PRCHSTN)&(PRCHSUB="NONE") Q:+PRCHSTN'=PRCHKSTN G:($P($G(PRCHDATA(PRCHEIEN,1)),"^",2)="")!($P($G(PRCHDATA(PRCHEIEN,1)),"^",2)=PRCHKSTN) CHKDONE Q "RTN","PRCHJRP6",91,0) CHKDONE ; still with me? set the flag! all checks successfull! "RTN","PRCHJRP6",92,0) S CHECKED=1 "RTN","PRCHJRP6",93,0) Q "RTN","PRCHJRP6",94,0) GRABIT ; pull data from global "RTN","PRCHJRP6",95,0) S PRCHDATA=0 "RTN","PRCHJRP6",96,0) S PRCHDATA(PRCHIEN,"IEN",0)=^PRCV(414.06,PRCHIEN,0) "RTN","PRCHJRP6",97,0) S PRCHDATA(PRCHEIEN,0)=^PRCV(414.06,PRCHIEN,1,PRCHEIEN,0) "RTN","PRCHJRP6",98,0) ;Build a list of handshake events. Needed to display "ack dates", etc. "RTN","PRCHJRP6",99,0) S PRCHCTYP=","_$P(PRCHDATA(PRCHEIEN,0),"^",2)_"," "RTN","PRCHJRP6",100,0) I PRCHAND[PRCHCTYP S ^TMP("PRCHJRP6",$J,"PRCHAND",PRCH2237,$P(PRCHDATA(PRCHEIEN,0),"^",2),$P(^PRCV(414.06,PRCHIEN,1,PRCHEIEN,0),"^"),.5)=PRCHIEN_"^"_PRCHEIEN Q "RTN","PRCHJRP6",101,0) Q:PRCHTYPE'[PRCHCTYP "RTN","PRCHJRP6",102,0) S PRCHDATA(PRCHEIEN,1)=$G(^PRCV(414.06,PRCHIEN,1,PRCHEIEN,1)) "RTN","PRCHJRP6",103,0) S PRCHDATA(PRCHEIEN,2)=$G(^PRCV(414.06,PRCHIEN,1,PRCHEIEN,2)) "RTN","PRCHJRP6",104,0) S PRCHERR=0 "RTN","PRCHJRP6",105,0) F S PRCHERR=$O(^PRCV(414.06,PRCHIEN,1,PRCHEIEN,3,PRCHERR)) Q:+PRCHERR'>0 S PRCHDATA(PRCHEIEN,3,PRCHERR)=^PRCV(414.06,PRCHIEN,1,PRCHEIEN,3,PRCHERR,0) "RTN","PRCHJRP6",106,0) S PRCHDATA=1 "RTN","PRCHJRP6",107,0) Q "RTN","PRCHJRP6",108,0) SORTIT ; Drop data into TMP to sort it. "RTN","PRCHJRP6",109,0) S ^TMP("PRCHJRP6",$J,PRCH2237,PRCHEDT,PRCHESTN,PRCHEVNT,.5)=PRCHDATA(PRCHIEN,"IEN",0)_"^"_PRCHIEN_"^"_PRCHEIEN "RTN","PRCHJRP6",110,0) S ^TMP("PRCHJRP6",$J,PRCH2237,PRCHEDT,PRCHESTN,PRCHEVNT,0)=PRCHDATA(PRCHEIEN,0) "RTN","PRCHJRP6",111,0) S ^TMP("PRCHJRP6",$J,PRCH2237,PRCHEDT,PRCHESTN,PRCHEVNT,1)=$G(PRCHDATA(PRCHEIEN,1)) "RTN","PRCHJRP6",112,0) S ^TMP("PRCHJRP6",$J,PRCH2237,PRCHEDT,PRCHESTN,PRCHEVNT,2)=$G(PRCHDATA(PRCHEIEN,2)) "RTN","PRCHJRP6",113,0) S ^TMP("PRCHJRP6",$J,PRCH2237,PRCHEDT,PRCHESTN,PRCHEVNT,3)=0 "RTN","PRCHJRP6",114,0) I $D(PRCHDATA(PRCHEIEN,3))=10 D "RTN","PRCHJRP6",115,0) . S (PRCHERCT,PRCHERR)=0 "RTN","PRCHJRP6",116,0) . F S PRCHERR=$O(PRCHDATA(PRCHEIEN,3,PRCHERR)) Q:+PRCHERR'>0 S ^TMP("PRCHJRP6",$J,PRCH2237,PRCHEDT,PRCHESTN,PRCHEVNT,3,PRCHERR)=PRCHDATA(PRCHEIEN,3,PRCHERR),PRCHERCT=PRCHERCT+1 "RTN","PRCHJRP6",117,0) . S ^TMP("PRCHJRP6",$J,PRCH2237,PRCHEDT,PRCHESTN,PRCHEVNT,3)=PRCHERCT "RTN","PRCHJRP6",118,0) .Q "RTN","PRCHJRP6",119,0) Q "RTN","PRCHJRP6",120,0) DISPLAY ; Selection and sort criteria have already been obtained. "RTN","PRCHJRP6",121,0) U IO "RTN","PRCHJRP6",122,0) D NOW^%DTC S Y=$J(%,7,4) D DD^%DT S PRCRUNDT=Y "RTN","PRCHJRP6",123,0) S (PRCEXIT,PRCPAGE)=0,PRCHSHKE="2^^^2^^7^^9^^11" "RTN","PRCHJRP6",124,0) D HEADER "RTN","PRCHJRP6",125,0) S PRC2237="",PRCHNO=0 "RTN","PRCHJRP6",126,0) G:$D(^TMP("PRCHJRP6",$J))=0 DX "RTN","PRCHJRP6",127,0) F S PRC2237=$O(^TMP("PRCHJRP6",$J,PRC2237)) Q:(PRC2237="PRCHAND")!(PRCEXIT)!(PRC2237="") D "RTN","PRCHJRP6",128,0) . S PRCEDT=0,PRCHNO=1 "RTN","PRCHJRP6",129,0) . F S PRCEDT=$O(^TMP("PRCHJRP6",$J,PRC2237,PRCEDT)) Q:(+PRCEDT'>0)!(PRCEXIT) D "RTN","PRCHJRP6",130,0) .. S PRCSTN=0 "RTN","PRCHJRP6",131,0) .. F PRCSTN=$O(^TMP("PRCHJRP6",$J,PRC2237,PRCEDT,PRCSTN)) Q:(+PRCSTN'>0)!(PRCEXIT) D "RTN","PRCHJRP6",132,0) ... S PRCEVENT=0 "RTN","PRCHJRP6",133,0) ... F PRCEVENT=$O(^TMP("PRCHJRP6",$J,PRC2237,PRCEDT,PRCSTN,PRCEVENT)) Q:(+PRCEVENT'>0)!(PRCEXIT) D "RTN","PRCHJRP6",134,0) ... S NODEHALF=^TMP("PRCHJRP6",$J,PRC2237,PRCEDT,PRCSTN,PRCEVENT,.5) "RTN","PRCHJRP6",135,0) ... S NODE0=^TMP("PRCHJRP6",$J,PRC2237,PRCEDT,PRCSTN,PRCEVENT,0) "RTN","PRCHJRP6",136,0) ... S NODE1=^TMP("PRCHJRP6",$J,PRC2237,PRCEDT,PRCSTN,PRCEVENT,1) "RTN","PRCHJRP6",137,0) ... S NODE2=^TMP("PRCHJRP6",$J,PRC2237,PRCEDT,PRCSTN,PRCEVENT,2) "RTN","PRCHJRP6",138,0) ... S PRCACKER=^TMP("PRCHJRP6",$J,PRC2237,PRCEDT,PRCSTN,PRCEVENT,3) "RTN","PRCHJRP6",139,0) ... ; PRC2237 - EVENT TEXT - EVENT DATE "RTN","PRCHJRP6",140,0) ... S PRCEVTX=$P(^PRCV(414.07,PRCEVENT,0),"^") "RTN","PRCHJRP6",141,0) ... S Y=PRCEDT D DD^%DT S PRCEDTX=Y "RTN","PRCHJRP6",142,0) ... W !,PRC2237,?21,PRCEVTX,?58,PRCEDTX "RTN","PRCHJRP6",143,0) ... ; SUBSTATION (PRIMARY) - HANDSHAKE EVENT DATE - (set handshake event iens for future use) "RTN","PRCHJRP6",144,0) ... S PRCHSDT=PRCEDT,PRCHEVT=$P(PRCHSHKE,"^",PRCEVENT) "RTN","PRCHJRP6",145,0) ... F S PRCHSDT=$O(^TMP("PRCHJRP6",$J,"PRCHAND",PRC2237,PRCHEVT,PRCHSDT)) S:PRCHSDT'="" PRCHSI=$P(^TMP("PRCHJRP6",$J,"PRCHAND",PRC2237,PRCHEVT,PRCHSDT,.5),"^"),PRCHSEI=$P(^TMP("PRCHJRP6",$J,"PRCHAND",PRC2237,PRCHEVT,PRCHSDT,.5),"^",2) Q "RTN","PRCHJRP6",146,0) ... S:PRCHSDT'="" Y=PRCHSDT D DD^%DT S PRCHSDTX=Y "RTN","PRCHJRP6",147,0) ... S:PRCHSDT="" PRCHSDTX="(Pending)" "RTN","PRCHJRP6",148,0) ... W ! "RTN","PRCHJRP6",149,0) ... W:$P(NODE1,"^",2)'="" "SUBSTATION: "_$P(NODE1,"^",2) "RTN","PRCHJRP6",150,0) ... W ?44,"ACKNOWLEDGED: "_PRCHSDTX "RTN","PRCHJRP6",151,0) ... ; eCMS CONTACT - eCMS PHONE "RTN","PRCHJRP6",152,0) ... W:(PRCEVENT'=1)&(PRCEVENT'=4) !,"eCMS CONTACT: "_$P(NODE1,"^",6),?44,"PHONE: "_$P(NODE1,"^",5) "RTN","PRCHJRP6",153,0) ... ; RETURN/CANCEL DATE and COMMENT or REASON TEXT "RTN","PRCHJRP6",154,0) ... I $P(NODE1,"^",7)'="" S Y=$P(NODE1,"^",7) D DD^%DT W !,"RETURN/CANCEL DATE: "_Y "RTN","PRCHJRP6",155,0) ... W:(NODE2'="")&(NODE2'="^")&(PRCEVENT'=1) !,"REASON/COMMENT: "_$S($P(NODE2,"^",2)'="":$P(NODE2,"^",2),1:$P(NODE2,"^")) "RTN","PRCHJRP6",156,0) ... ; ERROR TEXT IF ANY, BOTH MAIN AND HANDSHAKE "RTN","PRCHJRP6",157,0) ... I PRCACKER>0 D "RTN","PRCHJRP6",158,0) .... I 'PRCHERTX W !,"This "_PRCEVTX_" has ERROR TEXT." Q "RTN","PRCHJRP6",159,0) .... W !,"ERROR TEXT FOR "_PRCEVTX_":" "RTN","PRCHJRP6",160,0) .... S PRCI=0 "RTN","PRCHJRP6",161,0) .... F S PRCI=$O(^TMP("PRCHJRP6",$J,PRC2237,PRCEDT,PRCSTN,PRCEVENT,3,PRCI)) Q:(+PRCI'>0)!(PRCEXIT) D:(IOSL-$Y)<4 HEADER Q:PRCEXIT W !," ",^TMP("PRCHJRP6",$J,PRC2237,PRCEDT,PRCSTN,PRCEVENT,3,PRCI) "RTN","PRCHJRP6",162,0) ....Q "RTN","PRCHJRP6",163,0) ... I PRCHSDT'="" D "RTN","PRCHJRP6",164,0) .... I $D(^PRCV(414.06,PRCHSI,1,PRCHSEI,3))>0 D "RTN","PRCHJRP6",165,0) ..... I 'PRCHERTX W !,"This "_PRCEVTX_" has ACKNOWLEDGMENT ERROR TEXT." Q "RTN","PRCHJRP6",166,0) ..... W !,"ACKNOWLEDGMENT ERROR TEXT FOR "_PRCEVTX_":" "RTN","PRCHJRP6",167,0) ..... S PRCI=0 "RTN","PRCHJRP6",168,0) ..... F S PRCI=$O(^PRCV(414.06,PRCHSI,1,PRCHSEI,3,PRCI)) Q:(+PRCI'>0)!(PRCEXIT) D:(IOSL-$Y)<4 HEADER Q:PRCEXIT W !," ",^PRCV(414.06,PRCHSI,1,PRCHSEI,3,PRCI,0) "RTN","PRCHJRP6",169,0) .....Q "RTN","PRCHJRP6",170,0) ....Q "RTN","PRCHJRP6",171,0) ... W ! "RTN","PRCHJRP6",172,0) ... ; PAGE BREAK CHECK "RTN","PRCHJRP6",173,0) ... D:((IOSL-$Y)<4)&(PRCEXIT'=1) HEADER "RTN","PRCHJRP6",174,0) ... Q:PRCEXIT "RTN","PRCHJRP6",175,0) ...Q "RTN","PRCHJRP6",176,0) ..Q "RTN","PRCHJRP6",177,0) .Q "RTN","PRCHJRP6",178,0) DX W !,?25,$S(PRCEXIT:"USER ABORTED REPORT",PRCHNO=1:"END OF REPORT",PRCHNO=0:"NO DATA TO REPORT!",1:""),! "RTN","PRCHJRP6",179,0) G:PRCEXIT EXITD "RTN","PRCHJRP6",180,0) I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR "RTN","PRCHJRP6",181,0) S:$D(ZTQUEUED) ZTREQ="@" "RTN","PRCHJRP6",182,0) D EXITZT^PRCHJRP5 "RTN","PRCHJRP6",183,0) D EXITD "RTN","PRCHJRP6",184,0) Q "RTN","PRCHJRP6",185,0) HEADER ; Page header, etc. "RTN","PRCHJRP6",186,0) I PRCPAGE>0 W ! I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR S:+$G(DUOUT)!$G(DTOUT) PRCEXIT=1 "RTN","PRCHJRP6",187,0) Q:PRCEXIT "RTN","PRCHJRP6",188,0) S PRCPAGE=PRCPAGE+1 "RTN","PRCHJRP6",189,0) W:PRCPAGE>1 @IOF "RTN","PRCHJRP6",190,0) W !,PRCRUNDT,?25,"eCMS/IFCAP TRANSACTION LOG REPORT",?74,"p. "_PRCPAGE "RTN","PRCHJRP6",191,0) I PRCHSNGL W !!,"eCMS 2237: ",PRCH2237 G TABLE "RTN","PRCHJRP6",192,0) W !!,"eCMS 2237: ",PRCH37,?17,"eCMS Contact: ",PRCHEML,?65,"Station: ",$S(PRCHSTN="SUB":+PRCHSUB,1:PRCHSTN) "RTN","PRCHJRP6",193,0) W !,"Report Date Range: "_PRCHSTAR_" - "_PRCHEND,?59,"Control Point: ",PRCHFUND "RTN","PRCHJRP6",194,0) W !,"Events: ",PRCHTYTX "RTN","PRCHJRP6",195,0) TABLE W !!,"IFCAP Reference",?21,"Message Event",?58,"Event Date" "RTN","PRCHJRP6",196,0) W ! S L="",$P(L,"_",IOM)="_" W L S L="" "RTN","PRCHJRP6",197,0) Q "RTN","PRCHJRP6",198,0) EXITD ; Exit display portion "RTN","PRCHJRP6",199,0) K ^TMP("PRCHJRP6",$J) "RTN","PRCHJRP6",200,0) K %,DTOUT,DUOUT,I,L,POP,PRCETMP0,PRCETMP1,PRCETMP3,PRCH411,PRCHAKLP,PRCHI,PRCHINIC,PRCHINSN,PRCHJ,PRCHNO,PRCHSLTY,PRCHTT,XQOPT,ZTQUEUED,ZTREQ "RTN","PRCHJRP6",201,0) K PRCH2237,PRCHDATA,PRCHECMS,PRCHEML,PRCHEND,PRCHENDT,PRCHERTX,PRCHFUND,PRCHSNGL,PRCHSTAR,PRCHSTDT,PRCHSTN,PRCHSUB,PRCHTYPE,PRCHTYTX,PRCHURCP "RTN","PRCHJRP6",202,0) Q "RTN","PRCHJS01") 0^5^B34864195^B32931088 "RTN","PRCHJS01",1,0) PRCHJS01 ;OI&T/KCL - IFCAP/ECMS INTERFACE TRANSMIT 2237 TO ECMS;6/12/12 "RTN","PRCHJS01",2,0) ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23 "RTN","PRCHJS01",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCHJS01",4,0) ; "RTN","PRCHJS01",5,0) SEND2237(PRC410R,PRCERR) ;Send 2237 to eCMS via HL7 messaging "RTN","PRCHJS01",6,0) ;This function is the primary driver for retrieving and sending "RTN","PRCHJS01",7,0) ;a 2237 transaction to eCMS in single HL7 message (OMN^O07). "RTN","PRCHJS01",8,0) ; "RTN","PRCHJS01",9,0) ;This function will: "RTN","PRCHJS01",10,0) ; - Retrieve 2237 data elements and place them into a work global "RTN","PRCHJS01",11,0) ; - Perform 2237 pre-validation checks on 2237 data elements "RTN","PRCHJS01",12,0) ; - Build and transmit 2237 data via OMN^O07 message "RTN","PRCHJS01",13,0) ; "RTN","PRCHJS01",14,0) ; Input: "RTN","PRCHJS01",15,0) ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file "RTN","PRCHJS01",16,0) ; "RTN","PRCHJS01",17,0) ; Output: "RTN","PRCHJS01",18,0) ; Function value - ien of msg in HLO MESSAGES (#778) file on success, 0 on failure "RTN","PRCHJS01",19,0) ; PRCERR - (optional) on failure, an error msg array is returned, pass by ref "RTN","PRCHJS01",20,0) ; Error msg array format: "RTN","PRCHJS01",21,0) ; PRCERR(1) "RTN","PRCHJS01",22,0) ; PRCERR(2) "RTN","PRCHJS01",23,0) ; PRCERR(3), etc. "RTN","PRCHJS01",24,0) ; "RTN","PRCHJS01",25,0) N PRCWORK ;name of work global containing the 2237 data elements "RTN","PRCHJS01",26,0) N PRCRSLT ;function result "RTN","PRCHJS01",27,0) ; "RTN","PRCHJS01",28,0) ;init temp work global "RTN","PRCHJS01",29,0) S PRCWORK=$NA(^TMP("PRCHJ2237",$J)) "RTN","PRCHJS01",30,0) K @PRCWORK "RTN","PRCHJS01",31,0) ; "RTN","PRCHJS01",32,0) S PRCRSLT=0 "RTN","PRCHJS01",33,0) ; "RTN","PRCHJS01",34,0) D ;drops out of DO block on failure "RTN","PRCHJS01",35,0) . ; "RTN","PRCHJS01",36,0) . ;get 2237 data elements and place into work global "RTN","PRCHJS01",37,0) . I '$$GET2237(PRC410R,PRCWORK,.PRCERR) S PRCERR(1)=$G(PRCERR) Q "RTN","PRCHJS01",38,0) . ; "RTN","PRCHJS01",39,0) . ;perform 2237 pre-validation checks on 2237 data elements "RTN","PRCHJS01",40,0) . I '$$PRE2237(PRCWORK,.PRCERR) Q "RTN","PRCHJS01",41,0) . ; "RTN","PRCHJS01",42,0) . ;build and transmit 2237 data via OMN^O07 message "RTN","PRCHJS01",43,0) . S PRCRSLT=$$OMNO07^PRCHJS04(PRCWORK,.PRCERR) "RTN","PRCHJS01",44,0) . I $G(PRCERR)]"" S PRCERR(1)=$G(PRCERR) "RTN","PRCHJS01",45,0) ; "RTN","PRCHJS01",46,0) ;cleanup work global "RTN","PRCHJS01",47,0) K @PRCWORK "RTN","PRCHJS01",48,0) ; "RTN","PRCHJS01",49,0) Q PRCRSLT "RTN","PRCHJS01",50,0) ; "RTN","PRCHJS01",51,0) ; "RTN","PRCHJS01",52,0) GET2237(PRC410R,PRCWRK,PRCERR) ;Retrieve 2237 data elements "RTN","PRCHJS01",53,0) ;This function is responsible for retrieving the 2237 data "RTN","PRCHJS01",54,0) ;elements from the IFCAP database that will be transmitted "RTN","PRCHJS01",55,0) ;to eCMS. The 2237 data elements will be placed into a temp "RTN","PRCHJS01",56,0) ;work global. "RTN","PRCHJS01",57,0) ; "RTN","PRCHJS01",58,0) ; Input: "RTN","PRCHJS01",59,0) ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file "RTN","PRCHJS01",60,0) ; PRCWRK - (required) name of work global used to hold 2237 data elements "RTN","PRCHJS01",61,0) ; Ex) S PRCWORK=$NA(^TMP("PRCHJ2237",$J)) "RTN","PRCHJS01",62,0) ; "RTN","PRCHJS01",63,0) ; Output: "RTN","PRCHJS01",64,0) ; Function value - 1 on success, 0 on failure "RTN","PRCHJS01",65,0) ; PRCERR - (optional) on failure, an error message is returned, pass by ref "RTN","PRCHJS01",66,0) ; "RTN","PRCHJS01",67,0) N PRCRSLT ;function result "RTN","PRCHJS01",68,0) ; "RTN","PRCHJS01",69,0) S PRCRSLT=0 "RTN","PRCHJS01",70,0) ; "RTN","PRCHJS01",71,0) D ;drops out of DO block on failure "RTN","PRCHJS01",72,0) . ; "RTN","PRCHJS01",73,0) . ;get CONTROL POINT ACTIVITY (#410) data "RTN","PRCHJS01",74,0) . I '$$GET410^PRCHJS02(PRC410R,PRCWRK,.PRCERR) Q "RTN","PRCHJS01",75,0) . ; "RTN","PRCHJS01",76,0) . ;get 2237 line item data "RTN","PRCHJS01",77,0) . I '$$GETITEMS^PRCHJS02(PRC410R,PRCWRK,.PRCERR) Q "RTN","PRCHJS01",78,0) . ; "RTN","PRCHJS01",79,0) . ;get REQUEST WORKSHEET (#443) data "RTN","PRCHJS01",80,0) . I '$$GET443^PRCHJS03($P($G(@PRCWRK@("TRANUM")),U),PRCWRK,.PRCERR) Q "RTN","PRCHJS01",81,0) . ; "RTN","PRCHJS01",82,0) . ;if INVENTORY DISTRIBUTION POINT, then get GENERIC INVENTORY (#445) data "RTN","PRCHJS01",83,0) . I +$G(@PRCWRK@("INVDIS"))>0 D Q:$G(PRCERR) "RTN","PRCHJS01",84,0) . . I '$$GET445^PRCHJS03(+$G(@PRCWRK@("INVDIS")),PRCWRK,.PRCERR) Q "RTN","PRCHJS01",85,0) . ; "RTN","PRCHJS01",86,0) . ;if VENDOR POINTER, then get VENDOR (#440) data "RTN","PRCHJS01",87,0) . I +$G(@PRCWRK@("VENDPT"))>0 D Q:$G(PRCERR) "RTN","PRCHJS01",88,0) . . I '$$GET440^PRCHJS03(+$G(@PRCWRK@("VENDPT")),PRCWRK,.PRCERR) Q "RTN","PRCHJS01",89,0) . ; "RTN","PRCHJS01",90,0) . ;success "RTN","PRCHJS01",91,0) . S PRCRSLT=1 "RTN","PRCHJS01",92,0) ; "RTN","PRCHJS01",93,0) Q PRCRSLT "RTN","PRCHJS01",94,0) ; "RTN","PRCHJS01",95,0) ; "RTN","PRCHJS01",96,0) PRE2237(PRCWRK,PRCER) ;Pre-validate 2237 data elements "RTN","PRCHJS01",97,0) ;This function performs pre-validation checks on specified "RTN","PRCHJS01",98,0) ;2237 data elements being transmitted to eCMS. "RTN","PRCHJS01",99,0) ; "RTN","PRCHJS01",100,0) ; Input: "RTN","PRCHJS01",101,0) ; PRCWRK - (required) name of work global containing 2237 data elements "RTN","PRCHJS01",102,0) ; "RTN","PRCHJS01",103,0) ; Output: "RTN","PRCHJS01",104,0) ; Function value - returns 1 if all validation checks passed, 0 otherwise "RTN","PRCHJS01",105,0) ; PRCER - (optional) on failure, an error msg array is returned, pass by ref "RTN","PRCHJS01",106,0) ; Error msg array format: "RTN","PRCHJS01",107,0) ; PRCER(1) "RTN","PRCHJS01",108,0) ; PRCER(2) "RTN","PRCHJS01",109,0) ; PRCER(3), etc. "RTN","PRCHJS01",110,0) ; "RTN","PRCHJS01",111,0) N PRCSUB ;array subscript "RTN","PRCHJS01",112,0) N PRCLINE ;array subscript for items "RTN","PRCHJS01",113,0) N PRCITEML ;Line Item # "RTN","PRCHJS01",114,0) N PRCNUM ;array subscript for item description "RTN","PRCHJS01",115,0) N PRCIDX ;error array index "RTN","PRCHJS01",116,0) N PRCRSLT ;function result "RTN","PRCHJS01",117,0) ; "RTN","PRCHJS01",118,0) S (PRCIDX,PRCRSLT)=0 "RTN","PRCHJS01",119,0) ; "RTN","PRCHJS01",120,0) D "RTN","PRCHJS01",121,0) . ;make sure this is a 2237 "RTN","PRCHJS01",122,0) . I ($P($G(@PRCWRK@("FRMTYP")),U)<2)!($P($G(@PRCWRK@("FRMTYP")),U)>4) S PRCER(PRCIDX+1)="This is not a 2237 transaction" Q "RTN","PRCHJS01",123,0) . ; "RTN","PRCHJS01",124,0) . ;check for 2237 null field values (eCMS required fields) "RTN","PRCHJS01",125,0) . F PRCSUB="TRANUM","STANUM","RQSTDT","REQ","DTREQ","APOF","RQSRV","CTRLPT","COMMIT","ACTDATA" D "RTN","PRCHJS01",126,0) . . I $P($G(@PRCWRK@(PRCSUB)),U)="" D "RTN","PRCHJS01",127,0) . . . S PRCIDX=PRCIDX+1 "RTN","PRCHJS01",128,0) . . . S PRCER(PRCIDX)="Field "_$$GET1^DID(410,$$FIELD(PRCSUB),"","LABEL")_" is missing" "RTN","PRCHJS01",129,0) . ; "RTN","PRCHJS01",130,0) . ;loop thru Line Items on 2237 and check for null field values (eCMS required fields) "RTN","PRCHJS01",131,0) . S PRCLINE=0 "RTN","PRCHJS01",132,0) . F S PRCLINE=$O(@PRCWRK@(PRCLINE)) Q:'PRCLINE D "RTN","PRCHJS01",133,0) . . S PRCITEML=+$G(@PRCWRK@(PRCLINE,"ITLINE")) ;line item # "RTN","PRCHJS01",134,0) . . ;check for null fields "RTN","PRCHJS01",135,0) . . F PRCSUB="ITLINE","ITQTY","ITUOP","ITBOC","ITCOST" D "RTN","PRCHJS01",136,0) . . . I $P($G(@PRCWRK@(PRCLINE,PRCSUB)),U)="" D "RTN","PRCHJS01",137,0) . . . . S PRCIDX=PRCIDX+1 "RTN","PRCHJS01",138,0) . . . . S PRCER(PRCIDX)="Line item ("_PRCITEML_") field "_$$GET1^DID(410.02,$$FIELD(PRCSUB),"","LABEL")_" is missing." "RTN","PRCHJS01",139,0) . . ; "RTN","PRCHJS01",140,0) . . ;check for line item description "RTN","PRCHJS01",141,0) . . I +$G(@PRCWRK@(PRCLINE,"ITDESC"))'>0 D "RTN","PRCHJS01",142,0) . . . S PRCIDX=PRCIDX+1 "RTN","PRCHJS01",143,0) . . . S PRCER(PRCIDX)="Line item ("_PRCITEML_") field "_$$GET1^DID(410.02,$$FIELD("ITDESC"),"","LABEL")_" is missing." "RTN","PRCHJS01",144,0) . ; "RTN","PRCHJS01",145,0) . ;quit if error(s) "RTN","PRCHJS01",146,0) . Q:$G(PRCIDX) "RTN","PRCHJS01",147,0) . ; "RTN","PRCHJS01",148,0) . ;otherwise success "RTN","PRCHJS01",149,0) . S PRCRSLT=1 "RTN","PRCHJS01",150,0) ; "RTN","PRCHJS01",151,0) Q PRCRSLT "RTN","PRCHJS01",152,0) ; "RTN","PRCHJS01",153,0) ; "RTN","PRCHJS01",154,0) FIELD(PRCSUB) ;Return field number for subscript "RTN","PRCHJS01",155,0) ;This function takes a given subscript in the 2237 work "RTN","PRCHJS01",156,0) ;global and returns the corresponding field number. "RTN","PRCHJS01",157,0) ; "RTN","PRCHJS01",158,0) ; Input: "RTN","PRCHJS01",159,0) ; PRCSUB - (required) subscript of 2237 work global "RTN","PRCHJS01",160,0) ; "RTN","PRCHJS01",161,0) ; Output: "RTN","PRCHJS01",162,0) ; Function value - returns corresponding field number for subscript, "RTN","PRCHJS01",163,0) ; null otherwise "RTN","PRCHJS01",164,0) ; "RTN","PRCHJS01",165,0) N PRCFLD ;function result "RTN","PRCHJS01",166,0) S PRCFLD="" "RTN","PRCHJS01",167,0) ; "RTN","PRCHJS01",168,0) D ;drops out of DO block once field # is determined "RTN","PRCHJS01",169,0) . ; "RTN","PRCHJS01",170,0) . ;CONTROL POINT ACTIVITY (#410) fields "RTN","PRCHJS01",171,0) . I PRCSUB="TRANUM" S PRCFLD=.01 Q "RTN","PRCHJS01",172,0) . I PRCSUB="STANUM" S PRCFLD=.5 Q "RTN","PRCHJS01",173,0) . I PRCSUB="RQSTDT" S PRCFLD=5 Q "RTN","PRCHJS01",174,0) . I PRCSUB="REQ" S PRCFLD=40 Q "RTN","PRCHJS01",175,0) . I PRCSUB="DTREQ" S PRCFLD=7 Q "RTN","PRCHJS01",176,0) . I PRCSUB="APOF" S PRCFLD=42 Q "RTN","PRCHJS01",177,0) . I PRCSUB="RQSRV" S PRCFLD=6.3 Q "RTN","PRCHJS01",178,0) . I PRCSUB="CTRLPT" S PRCFLD=15 Q "RTN","PRCHJS01",179,0) . I PRCSUB="COMMIT" S PRCFLD=20 Q "RTN","PRCHJS01",180,0) . I PRCSUB="ACTDATA" S PRCFLD=28 Q "RTN","PRCHJS01",181,0) . ; "RTN","PRCHJS01",182,0) . ;ITEM (#410.02) multiple fields "RTN","PRCHJS01",183,0) . I PRCSUB="ITLINE" S PRCFLD=.01 Q "RTN","PRCHJS01",184,0) . I PRCSUB="ITDESC" S PRCFLD=1 Q "RTN","PRCHJS01",185,0) . I PRCSUB="ITQTY" S PRCFLD=2 Q "RTN","PRCHJS01",186,0) . I PRCSUB="ITUOP" S PRCFLD=3 Q "RTN","PRCHJS01",187,0) . I PRCSUB="ITBOC" S PRCFLD=4 Q "RTN","PRCHJS01",188,0) . I PRCSUB="ITCOST" S PRCFLD=7 Q "RTN","PRCHJS01",189,0) ; "RTN","PRCHJS01",190,0) Q PRCFLD "RTN","PRCHJS02") 0^30^B161312507^B160738440 "RTN","PRCHJS02",1,0) PRCHJS02 ;OI&T/KCL - IFCAP/ECMS INTERFACE RETRIEVE 2237 DATA;6/12/12 "RTN","PRCHJS02",2,0) ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23 "RTN","PRCHJS02",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCHJS02",4,0) ; "RTN","PRCHJS02",5,0) GET410(PRC410R,PRCWRK,PRCER) ;Get CONTROL POINT ACTIVITY (#410) data "RTN","PRCHJS02",6,0) ;This function retrieves 2237 data elements from the CONTROL POINT "RTN","PRCHJS02",7,0) ;ACTIVITY (#410) file and places them into a ^TMP work global. Data "RTN","PRCHJS02",8,0) ;is placed into the work global in both internal and external format. "RTN","PRCHJS02",9,0) ; "RTN","PRCHJS02",10,0) ; Input: "RTN","PRCHJS02",11,0) ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file "RTN","PRCHJS02",12,0) ; PRCWRK - (required) name of work global containing data elements "RTN","PRCHJS02",13,0) ; "RTN","PRCHJS02",14,0) ; Output: "RTN","PRCHJS02",15,0) ; Function value - 1 on success, 0 on failure "RTN","PRCHJS02",16,0) ; PRCER - (optional) on failure, an error message is returned, "RTN","PRCHJS02",17,0) ; pass by reference "RTN","PRCHJS02",18,0) ; PRCWRK - work global containing the #410 data elements: "RTN","PRCHJS02",19,0) ; "RTN","PRCHJS02",20,0) ; Subscript Field# Data Element "RTN","PRCHJS02",21,0) ; --------- ------ ------------------- "RTN","PRCHJS02",22,0) ; TRANUM .01 TRANSACTION NUMBER "RTN","PRCHJS02",23,0) ; STANUM .5 STATION NUMBER "RTN","PRCHJS02",24,0) ; FRMTYP 3 FORM TYPE "RTN","PRCHJS02",25,0) ; INVDIS 4 INVENTORY DISTRIBUTION POINT "RTN","PRCHJS02",26,0) ; RQSTDT 5 DATE OF REQUEST "RTN","PRCHJS02",27,0) ; RQSRV 6.3 REQUESTING SERVICE "RTN","PRCHJS02",28,0) ; DTREQ 7 DATE REQUIRED "RTN","PRCHJS02",29,0) ; PRI 7.5 PRIORITY OF REQUEST "RTN","PRCHJS02",30,0) ; REMARKS 9 SPECIAL REMARKS "RTN","PRCHJS02",31,0) ; VENDNM 11 VENDOR "RTN","PRCHJS02",32,0) ; VENDAD1 11.1 VENDOR ADDRESS1 "RTN","PRCHJS02",33,0) ; VENDAD2 11.2 VENDOR ADDRESS2 "RTN","PRCHJS02",34,0) ; VENDAD3 11.3 VENDOR ADDRESS3 "RTN","PRCHJS02",35,0) ; VENDAD4 11.4 VENDOR ADDRESS4 "RTN","PRCHJS02",36,0) ; VENDCTY 11.5 VENDOR CITY "RTN","PRCHJS02",37,0) ; VENDST 11.6 VENDOR STATE "RTN","PRCHJS02",38,0) ; VENDZIP 11.7 VENDOR ZIP "RTN","PRCHJS02",39,0) ; VENDCON 11.8 VENDOR CONTACT "RTN","PRCHJS02",40,0) ; VENDPH 11.9 VENDOR PHONE NUMBER "RTN","PRCHJS02",41,0) ; VENDPT 12 VENDOR POINTER "RTN","PRCHJS02",42,0) ; CTRLPT 15 CONTROL POINT "RTN","PRCHJS02",43,0) ; COSTCTR 15.5 COST CENTER "RTN","PRCHJS02",44,0) ; COMMIT 20 COMMITTED (ESTIMATED) COST "RTN","PRCHJS02",45,0) ; COMMITDT 21 DATE COMMITTED "RTN","PRCHJS02",46,0) ; TRANSAMT 27 TRANSACTION $ AMOUNT "RTN","PRCHJS02",47,0) ; ACTDATA 28 ACCOUNTING DATA "RTN","PRCHJS02",48,0) ; FCPPRJ 28.1 FCP/PRJ "RTN","PRCHJS02",49,0) ; BBFY 28.5 BBFY "RTN","PRCHJS02",50,0) ; REQ 40 REQUESTOR "RTN","PRCHJS02",51,0) ; REQTITLE 41 REQUESTOR TITLE "RTN","PRCHJS02",52,0) ; APOF 42 APPROVING OFFICIAL "RTN","PRCHJS02",53,0) ; APOFTIT 43 APPROVING OFFICIAL TITLE "RTN","PRCHJS02",54,0) ; ESIGDT 44.6 ES CODE DATE/TIME "RTN","PRCHJS02",55,0) ; JUSTIF 45 JUSTIFICATION "RTN","PRCHJS02",56,0) ; DELIVTO 46 DELIVER TO/LOCATION "RTN","PRCHJS02",57,0) ; ESTSHIP 48.1 EST. SHIPPING "RTN","PRCHJS02",58,0) ; COMMENT 60 COMMENTS "RTN","PRCHJS02",59,0) ; SUBSTA 448 SUBSTATION "RTN","PRCHJS02",60,0) ; "RTN","PRCHJS02",61,0) N PRCIENS ;iens string for GETS^DIQ "RTN","PRCHJS02",62,0) N PRCFLDS ;results array for GETS^DIQ "RTN","PRCHJS02",63,0) N PRCERR ;error array for GETS^DIQ "RTN","PRCHJS02",64,0) N PRCRSLT ;function result "RTN","PRCHJS02",65,0) ; "RTN","PRCHJS02",66,0) S PRCRSLT=0 "RTN","PRCHJS02",67,0) S PRCER="Control Point Activity record not found" "RTN","PRCHJS02",68,0) ; "RTN","PRCHJS02",69,0) I $G(PRC410R)>0,$D(^PRCS(410,PRC410R)) D "RTN","PRCHJS02",70,0) . ;retrieve data from #410 top level fields "RTN","PRCHJS02",71,0) . S PRCIENS=PRC410R_"," "RTN","PRCHJS02",72,0) . D GETS^DIQ(410,PRCIENS,"*","IE","PRCFLDS","PRCERR") "RTN","PRCHJS02",73,0) . I $D(PRCERR) S PRCER="Unable to retrieve Control Point Activity record" Q "RTN","PRCHJS02",74,0) . ; "RTN","PRCHJS02",75,0) . ;place top level (#410) fields into work global "RTN","PRCHJS02",76,0) . S @PRCWRK@("TRANUM")=$G(PRCFLDS(410,PRCIENS,.01,"I"))_U_$G(PRCFLDS(410,PRCIENS,.01,"E")) "RTN","PRCHJS02",77,0) . S @PRCWRK@("STANUM")=$G(PRCFLDS(410,PRCIENS,.5,"I"))_U_$G(PRCFLDS(410,PRCIENS,.5,"E")) "RTN","PRCHJS02",78,0) . S @PRCWRK@("FRMTYP")=$G(PRCFLDS(410,PRCIENS,3,"I"))_U_$G(PRCFLDS(410,PRCIENS,3,"E")) "RTN","PRCHJS02",79,0) . S @PRCWRK@("INVDIS")=$G(PRCFLDS(410,PRCIENS,4,"I"))_U_$G(PRCFLDS(410,PRCIENS,4,"E")) "RTN","PRCHJS02",80,0) . S @PRCWRK@("RQSTDT")=$G(PRCFLDS(410,PRCIENS,5,"I"))_U_$G(PRCFLDS(410,PRCIENS,5,"E")) "RTN","PRCHJS02",81,0) . S @PRCWRK@("RQSRV")=$G(PRCFLDS(410,PRCIENS,6.3,"I"))_U_$G(PRCFLDS(410,PRCIENS,6.3,"E")) "RTN","PRCHJS02",82,0) . S @PRCWRK@("DTREQ")=$G(PRCFLDS(410,PRCIENS,7,"I"))_U_$G(PRCFLDS(410,PRCIENS,7,"E")) "RTN","PRCHJS02",83,0) . S @PRCWRK@("PRI")=$G(PRCFLDS(410,PRCIENS,7.5,"I"))_U_$G(PRCFLDS(410,PRCIENS,7.5,"E")) "RTN","PRCHJS02",84,0) . S @PRCWRK@("VENDNM")=$G(PRCFLDS(410,PRCIENS,11,"I"))_U_$G(PRCFLDS(410,PRCIENS,11,"E")) "RTN","PRCHJS02",85,0) . S @PRCWRK@("VENDAD1")=$G(PRCFLDS(410,PRCIENS,11.1,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.1,"E")) "RTN","PRCHJS02",86,0) . S @PRCWRK@("VENDAD2")=$G(PRCFLDS(410,PRCIENS,11.2,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.2,"E")) "RTN","PRCHJS02",87,0) . S @PRCWRK@("VENDAD3")=$G(PRCFLDS(410,PRCIENS,11.3,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.3,"E")) "RTN","PRCHJS02",88,0) . S @PRCWRK@("VENDAD4")=$G(PRCFLDS(410,PRCIENS,11.4,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.4,"E")) "RTN","PRCHJS02",89,0) . S @PRCWRK@("VENDCTY")=$G(PRCFLDS(410,PRCIENS,11.5,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.5,"E")) "RTN","PRCHJS02",90,0) . S @PRCWRK@("VENDST")=$G(PRCFLDS(410,PRCIENS,11.6,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.6,"E")) "RTN","PRCHJS02",91,0) . S @PRCWRK@("VENDZIP")=$G(PRCFLDS(410,PRCIENS,11.7,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.7,"E")) "RTN","PRCHJS02",92,0) . S @PRCWRK@("VENDCON")=$G(PRCFLDS(410,PRCIENS,11.8,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.8,"E")) "RTN","PRCHJS02",93,0) . S @PRCWRK@("VENDPH")=$G(PRCFLDS(410,PRCIENS,11.9,"I"))_U_$G(PRCFLDS(410,PRCIENS,11.9,"E")) "RTN","PRCHJS02",94,0) . S @PRCWRK@("VENDPT")=$G(PRCFLDS(410,PRCIENS,12,"I"))_U_$G(PRCFLDS(410,PRCIENS,12,"E")) "RTN","PRCHJS02",95,0) . S @PRCWRK@("CTRLPT")=$G(PRCFLDS(410,PRCIENS,15,"I"))_U_$G(PRCFLDS(410,PRCIENS,15,"E")) "RTN","PRCHJS02",96,0) . S @PRCWRK@("COSTCTR")=$G(PRCFLDS(410,PRCIENS,15.5,"I"))_U_$G(PRCFLDS(410,PRCIENS,15.5,"E")) "RTN","PRCHJS02",97,0) . S @PRCWRK@("COMMIT")=$G(PRCFLDS(410,PRCIENS,20,"I"))_U_$G(PRCFLDS(410,PRCIENS,20,"E")) "RTN","PRCHJS02",98,0) . S @PRCWRK@("COMMITDT")=$G(PRCFLDS(410,PRCIENS,21,"I"))_U_$G(PRCFLDS(410,PRCIENS,21,"E")) "RTN","PRCHJS02",99,0) . S @PRCWRK@("TRANSAMT")=$G(PRCFLDS(410,PRCIENS,27,"I"))_U_$G(PRCFLDS(410,PRCIENS,27,"E")) "RTN","PRCHJS02",100,0) . S @PRCWRK@("ACTDATA")=$G(PRCFLDS(410,PRCIENS,28,"I"))_U_$G(PRCFLDS(410,PRCIENS,28,"E")) "RTN","PRCHJS02",101,0) . S @PRCWRK@("FCPPRJ")=$G(PRCFLDS(410,PRCIENS,28.1,"I"))_U_$G(PRCFLDS(410,PRCIENS,28.1,"E")) "RTN","PRCHJS02",102,0) . S @PRCWRK@("BBFY")=$G(PRCFLDS(410,PRCIENS,28.5,"I"))_U_$G(PRCFLDS(410,PRCIENS,28.5,"E")) "RTN","PRCHJS02",103,0) . S @PRCWRK@("REQ")=$G(PRCFLDS(410,PRCIENS,40,"I"))_U_$G(PRCFLDS(410,PRCIENS,40,"E")) "RTN","PRCHJS02",104,0) . S @PRCWRK@("REQTITLE")=$G(PRCFLDS(410,PRCIENS,41,"I"))_U_$G(PRCFLDS(410,PRCIENS,41,"E")) "RTN","PRCHJS02",105,0) . S @PRCWRK@("APOF")=$G(PRCFLDS(410,PRCIENS,42,"I"))_U_$G(PRCFLDS(410,PRCIENS,42,"E")) "RTN","PRCHJS02",106,0) . S @PRCWRK@("APOFTIT")=$G(PRCFLDS(410,PRCIENS,43,"I"))_U_$G(PRCFLDS(410,PRCIENS,43,"E")) "RTN","PRCHJS02",107,0) . S @PRCWRK@("ESIGDT")=$G(PRCFLDS(410,PRCIENS,44.6,"I"))_U_$G(PRCFLDS(410,PRCIENS,44.6,"E")) "RTN","PRCHJS02",108,0) . S @PRCWRK@("DELIVTO")=$G(PRCFLDS(410,PRCIENS,46,"I"))_U_$G(PRCFLDS(410,PRCIENS,46,"E")) "RTN","PRCHJS02",109,0) . S @PRCWRK@("ESTSHIP")=$G(PRCFLDS(410,PRCIENS,48.1,"I"))_U_$G(PRCFLDS(410,PRCIENS,48.1,"E")) "RTN","PRCHJS02",110,0) . S @PRCWRK@("SUBSTA")=$G(PRCFLDS(410,PRCIENS,448,"I"))_U_$G(PRCFLDS(410,PRCIENS,448,"E")) "RTN","PRCHJS02",111,0) . ; "RTN","PRCHJS02",112,0) . ;retrieve Special Remarks WP field and place into work global "RTN","PRCHJS02",113,0) . D FORMTXT($G(PRC410R),PRCWRK,"REMARKS","RM") "RTN","PRCHJS02",114,0) . ; "RTN","PRCHJS02",115,0) . ;retrieve Justification WP field and place into work global "RTN","PRCHJS02",116,0) . D FORMTXT($G(PRC410R),PRCWRK,"JUSTIF",8) "RTN","PRCHJS02",117,0) . ; "RTN","PRCHJS02",118,0) . ;retrieve Comments WP field and place into work global "RTN","PRCHJS02",119,0) . D FORMTXT($G(PRC410R),PRCWRK,"COMMENT","CO") "RTN","PRCHJS02",120,0) . ; "RTN","PRCHJS02",121,0) . ;success "RTN","PRCHJS02",122,0) . S PRCRSLT=1 K PRCER "RTN","PRCHJS02",123,0) ; "RTN","PRCHJS02",124,0) Q PRCRSLT "RTN","PRCHJS02",125,0) ; "RTN","PRCHJS02",126,0) ; "RTN","PRCHJS02",127,0) FORMTXT(PRC410R,PRCWRK,PRCSUB,PRCNODE,PRCWL,PRCWR) ;Format WP Text Utility "RTN","PRCHJS02",128,0) ;This procedure is used to format Word Processing fields "RTN","PRCHJS02",129,0) ;retrieved from the CONTROL POINT ACTIVITY (#410) file and "RTN","PRCHJS02",130,0) ;place them into the ^TMP work global containing 2237 data elements. "RTN","PRCHJS02",131,0) ; "RTN","PRCHJS02",132,0) ; Input: "RTN","PRCHJS02",133,0) ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file "RTN","PRCHJS02",134,0) ; PRCWRK - (required) name of work global containing 2237 data elements "RTN","PRCHJS02",135,0) ; PRCSUB - (required) work global subscript where text will be placed "RTN","PRCHJS02",136,0) ; PRCNODE - (required) node where WP fields reside in (#410) file "RTN","PRCHJS02",137,0) ; PRCWL - (optional) left margin for WP text, default=1 "RTN","PRCHJS02",138,0) ; PRCWR - (optional) right margin for WP text, default=200 "RTN","PRCHJS02",139,0) ; "RTN","PRCHJS02",140,0) ; Output: None "RTN","PRCHJS02",141,0) ; "RTN","PRCHJS02",142,0) N X ;string of text to be added as input to the formatter "RTN","PRCHJS02",143,0) N DIWL ;left margin for text "RTN","PRCHJS02",144,0) N DIWR ;right margin for text "RTN","PRCHJS02",145,0) N DIWF ;string of format control parameters "RTN","PRCHJS02",146,0) N PRCI ;WP nodes subscript "RTN","PRCHJS02",147,0) ; "RTN","PRCHJS02",148,0) ;input params for ^DIWP "RTN","PRCHJS02",149,0) S DIWL=$S($G(PRCWL)>0:PRCWL,1:1) "RTN","PRCHJS02",150,0) S DIWR=$S($G(PRCWR)>0:PRCWR,1:200) "RTN","PRCHJS02",151,0) S (DIWF,X)="" "RTN","PRCHJS02",152,0) K ^UTILITY($J,"W") ;must kill before calling ^DIWP "RTN","PRCHJS02",153,0) ; "RTN","PRCHJS02",154,0) ;retrieve WP text and place formatted text into ^UTILITY($J,"W") "RTN","PRCHJS02",155,0) S PRCI=0 "RTN","PRCHJS02",156,0) F S PRCI=$O(^PRCS(410,$G(PRC410R),PRCNODE,PRCI)) Q:PRCI="" D "RTN","PRCHJS02",157,0) . S X=$G(^PRCS(410,$G(PRC410R),PRCNODE,PRCI,0)) "RTN","PRCHJS02",158,0) . D ^DIWP "RTN","PRCHJS02",159,0) ; "RTN","PRCHJS02",160,0) ;merge formatted text into work global "RTN","PRCHJS02",161,0) I $D(^UTILITY($J,"W")) M @PRCWRK@(PRCSUB)=^UTILITY($J,"W",1) "RTN","PRCHJS02",162,0) ; "RTN","PRCHJS02",163,0) ;cleanup "RTN","PRCHJS02",164,0) K ^UTILITY($J,"W") "RTN","PRCHJS02",165,0) Q "RTN","PRCHJS02",166,0) ; "RTN","PRCHJS02",167,0) ; "RTN","PRCHJS02",168,0) GETITEMS(PRC410R,PRCWRK,PRCER) ;Get 2237 line items "RTN","PRCHJS02",169,0) ;This function retrieves 2237 line item data elements "RTN","PRCHJS02",170,0) ;and places them into a ^TMP work global. Data is placed "RTN","PRCHJS02",171,0) ;into the work global in both internal and external format. "RTN","PRCHJS02",172,0) ; "RTN","PRCHJS02",173,0) ; Input: "RTN","PRCHJS02",174,0) ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file "RTN","PRCHJS02",175,0) ; PRCWRK - (required) name of work global containing data elements "RTN","PRCHJS02",176,0) ; "RTN","PRCHJS02",177,0) ; Output: "RTN","PRCHJS02",178,0) ; Function value - 1 on success, 0 on failure "RTN","PRCHJS02",179,0) ; PRCER - (optional) on failure, an error message is returned, "RTN","PRCHJS02",180,0) ; pass by reference "RTN","PRCHJS02",181,0) ; PRCWRK - work global containing the line item data elements: "RTN","PRCHJS02",182,0) ; "RTN","PRCHJS02",183,0) ; Subscript Field# Data Element "RTN","PRCHJS02",184,0) ; --------- ------ ------------------- "RTN","PRCHJS02",185,0) ; ITEM (#410.02) multiple: "RTN","PRCHJS02",186,0) ; line_item#,ITLINE .01 LINE ITEM NUMBER "RTN","PRCHJS02",187,0) ; line_item#,ITDESC 1 DESCRIPTION "RTN","PRCHJS02",188,0) ; line_item#,ITQTY 2 QUANTITY "RTN","PRCHJS02",189,0) ; line_item#,ITUOP 3 UNIT OF PURCHASE "RTN","PRCHJS02",190,0) ; line_item#,ITBOC 4 BOC "RTN","PRCHJS02",191,0) ; line_item#,ITMFN 5 ITEM MASTER FILE NO. "RTN","PRCHJS02",192,0) ; line_item#,ITSTOCK 6 STOCK NUMBER "RTN","PRCHJS02",193,0) ; line_item#,ITCOST 7 EST. ITEM (UNIT) COST "RTN","PRCHJS02",194,0) ; line_item#,ITDMID 17 DM DOC ID "RTN","PRCHJS02",195,0) ; "RTN","PRCHJS02",196,0) ; DELIVERY SCHEDULE (#410.6) file: "RTN","PRCHJS02",197,0) ; (Note: An item may have multiple delivery schedules) "RTN","PRCHJS02",198,0) ; line_item#,delivery_schedule#,DELREF .01 REFERENCE "RTN","PRCHJS02",199,0) ; line_item#,delivery_schedule#,DELDT 1 DELIVERY DATE "RTN","PRCHJS02",200,0) ; line_item#,delivery_schedule#,DELLOC 2 LOCATION "RTN","PRCHJS02",201,0) ; line_item#,delivery_schedule#,DELQTY 3 QTY TO BE DELIVERED "RTN","PRCHJS02",202,0) ; "RTN","PRCHJS02",203,0) ; UNIT OF ISSUE (#420.5): "RTN","PRCHJS02",204,0) ; line_item#,UNITNM .01 NAME "RTN","PRCHJS02",205,0) ; line_item#,UNITFNM 1 FULL NAME "RTN","PRCHJS02",206,0) ; "RTN","PRCHJS02",207,0) ; ITEM MASTER (#441) file: "RTN","PRCHJS02",208,0) ; line_item#,IMNSN 5 NSN "RTN","PRCHJS02",209,0) ; line_item#,IMFSC 2 FSC "RTN","PRCHJS02",210,0) ; line_item#,IMMFG 19 MFG PART NO. "RTN","PRCHJS02",211,0) ; line_item#,IMFOOD 20 FOOD GROUP "RTN","PRCHJS02",212,0) ; line_item#,IMNIF 51 NIF ITEM NUMBER "RTN","PRCHJS02",213,0) ; "RTN","PRCHJS02",214,0) ; VENDOR (#441.01) multiple: "RTN","PRCHJS02",215,0) ; line_item#,IMPKGM 1.6 PACKAGING MULTIPLE "RTN","PRCHJS02",216,0) ; line_item#,IMCTRCT 2 CONTRACT "RTN","PRCHJS02",217,0) ; line_item#,IMEXPDT 2.2 CONTRACT EXP. DATE "RTN","PRCHJS02",218,0) ; line_item#,IMNDC 4 NDC "RTN","PRCHJS02",219,0) ; line_item#,IMMIN 8 MINIMUM ORDER QTY "RTN","PRCHJS02",220,0) ; line_item#,IMMAX 8.5 MAXIMUM ORDER QTY "RTN","PRCHJS02",221,0) ; line_item#,IMREQ 9 REQUIRED ORDER MULTIPLE "RTN","PRCHJS02",222,0) ; line_item#,IMUCF 10 UNIT CONVERSION FACTOR "RTN","PRCHJS02",223,0) ; "RTN","PRCHJS02",224,0) N PRCIENS,PRC4106,PRC4205,PRC441 ;iens string for GETS^DIQ "RTN","PRCHJS02",225,0) N PRCFLDS,PRCDS,PRCUNIT,PRCIMF ;results array for GETS^DIQ "RTN","PRCHJS02",226,0) N PRCERR ;error array for GETS^DIQ "RTN","PRCHJS02",227,0) N PRCLINE ;line item # "RTN","PRCHJS02",228,0) N PRCITIEN ;ien of record in Item subfile "RTN","PRCHJS02",229,0) N PRCI ;item Description node subscript "RTN","PRCHJS02",230,0) N PRCITM ;item multiple subscript "RTN","PRCHJS02",231,0) N PRCSUB1,PRCSUB2 ;file #410 global subscripts "RTN","PRCHJS02",232,0) N PRCRSLT ;function result "RTN","PRCHJS02",233,0) ; "RTN","PRCHJS02",234,0) S PRCRSLT=0 "RTN","PRCHJS02",235,0) S PRCER="Control Point Activity record not found" "RTN","PRCHJS02",236,0) ; "RTN","PRCHJS02",237,0) I $G(PRC410R)'>0 Q PRCRSLT "RTN","PRCHJS02",238,0) I '$D(^PRCS(410,PRC410R)) Q PRCRSLT "RTN","PRCHJS02",239,0) ; "RTN","PRCHJS02",240,0) ;retrieve all fields and records in #410.02,10 multiple and place in ^TMP global "RTN","PRCHJS02",241,0) S PRCIENS=PRC410R_"," "RTN","PRCHJS02",242,0) S PRCFLDS=$NA(^TMP("PRCHJITEM",$J)) K @PRCFLDS "RTN","PRCHJS02",243,0) D GETS^DIQ(410,PRCIENS,"10*","IE",PRCFLDS,"PRCERR") "RTN","PRCHJS02",244,0) I $D(PRCERR) S PRCER="Unable to retrieve line item data" Q PRCRSLT "RTN","PRCHJS02",245,0) ; "RTN","PRCHJS02",246,0) ;place line item fields into work global "RTN","PRCHJS02",247,0) S PRCITM="" "RTN","PRCHJS02",248,0) F S PRCITM=$O(@PRCFLDS@(410.02,PRCITM)) Q:PRCITM="" D "RTN","PRCHJS02",249,0) . S PRCLINE=+$G(@PRCFLDS@(410.02,PRCITM,.01,"I")) "RTN","PRCHJS02",250,0) . S @PRCWRK@(PRCLINE,"ITLINE")=$G(@PRCFLDS@(410.02,PRCITM,.01,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,.01,"E")) "RTN","PRCHJS02",251,0) . S @PRCWRK@(PRCLINE,"ITQTY")=$G(@PRCFLDS@(410.02,PRCITM,2,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,2,"E")) "RTN","PRCHJS02",252,0) . S @PRCWRK@(PRCLINE,"ITUOP")=$G(@PRCFLDS@(410.02,PRCITM,3,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,3,"E")) "RTN","PRCHJS02",253,0) . S @PRCWRK@(PRCLINE,"ITBOC")=$G(@PRCFLDS@(410.02,PRCITM,4,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,4,"E")) "RTN","PRCHJS02",254,0) . S @PRCWRK@(PRCLINE,"ITMFN")=$G(@PRCFLDS@(410.02,PRCITM,5,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,5,"E")) "RTN","PRCHJS02",255,0) . S @PRCWRK@(PRCLINE,"ITSTOCK")=$G(@PRCFLDS@(410.02,PRCITM,6,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,6,"E")) "RTN","PRCHJS02",256,0) . S @PRCWRK@(PRCLINE,"ITCOST")=$G(@PRCFLDS@(410.02,PRCITM,7,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,7,"E")) "RTN","PRCHJS02",257,0) . S @PRCWRK@(PRCLINE,"ITDMID")=$G(@PRCFLDS@(410.02,PRCITM,17,"I"))_U_$G(@PRCFLDS@(410.02,PRCITM,17,"E")) "RTN","PRCHJS02",258,0) . ; "RTN","PRCHJS02",259,0) . ;resolve Line Item Number to Item entry's ien "RTN","PRCHJS02",260,0) . S PRCITIEN=+$O(^PRCS(410,PRC410R,"IT","B",PRCLINE,0)) "RTN","PRCHJS02",261,0) . ; "RTN","PRCHJS02",262,0) . ;place Item Description WP field into work global "RTN","PRCHJS02",263,0) . N DIWL,DIWR,DIWF,X ;^DIWP input params "RTN","PRCHJS02",264,0) . S DIWL=1,DIWR=200,DIWF="",PRCI=0 "RTN","PRCHJS02",265,0) . K ^UTILITY($J,"W") ;must kill before calling ^DIWP "RTN","PRCHJS02",266,0) . ;loop thru Item Description nodes and place formatted text into ^UTILITY($J,"W") "RTN","PRCHJS02",267,0) . F S PRCI=$O(^PRCS(410,$G(PRC410R),"IT",PRCITIEN,1,PRCI)) Q:PRCI="" D "RTN","PRCHJS02",268,0) . . S X=$G(^PRCS(410,$G(PRC410R),"IT",PRCITIEN,1,PRCI,0)) D ^DIWP "RTN","PRCHJS02",269,0) . ;merge formatted text into work global "RTN","PRCHJS02",270,0) . I $D(^UTILITY($J,"W")) M @PRCWRK@(PRCLINE,"ITDESC")=^UTILITY($J,"W",1) "RTN","PRCHJS02",271,0) . K ^UTILITY($J,"W") "RTN","PRCHJS02",272,0) . ; "RTN","PRCHJS02",273,0) . ;for each item, place DELIVERY SCHEDULE (#410.6) fields into work global "RTN","PRCHJS02",274,0) . S (PRCSUB1,PRCSUB2)="" "RTN","PRCHJS02",275,0) . F S PRCSUB1=$O(^PRCS(410,PRC410R,"IT",+PRCITM,2,"B",PRCSUB1)) Q:PRCSUB1="" D "RTN","PRCHJS02",276,0) . . S PRCSUB2=$O(^PRCS(410,PRC410R,"IT",+PRCITM,2,"B",PRCSUB1,PRCSUB2)) "RTN","PRCHJS02",277,0) . . Q:$G(PRCSUB2)'>0 "RTN","PRCHJS02",278,0) . . S PRC4106=$P($G(^PRCS(410,+$G(PRC410R),"IT",+PRCITM,2,PRCSUB2,0)),U,2)_"," ;ptr to #410.6 "RTN","PRCHJS02",279,0) . . K PRCDS "RTN","PRCHJS02",280,0) . . I +PRC4106>0 D GETS^DIQ(410.6,PRC4106,"*","IE","PRCDS","PRCERR") "RTN","PRCHJS02",281,0) . . Q:$D(PRCERR) "RTN","PRCHJS02",282,0) . . S @PRCWRK@(PRCLINE,PRCSUB1,"DELREF")=$G(PRCDS(410.6,PRC4106,.01,"I"))_U_$G(PRCDS(410.6,PRC4106,.01,"E")) "RTN","PRCHJS02",283,0) . . S @PRCWRK@(PRCLINE,PRCSUB1,"DELDT")=$G(PRCDS(410.6,PRC4106,1,"I"))_U_$G(PRCDS(410.6,PRC4106,1,"E")) "RTN","PRCHJS02",284,0) . . S @PRCWRK@(PRCLINE,PRCSUB1,"DELLOC")=$G(PRCDS(410.6,PRC4106,2,"I"))_U_$G(PRCDS(410.6,PRC4106,2,"E")) "RTN","PRCHJS02",285,0) . . S @PRCWRK@(PRCLINE,PRCSUB1,"DELQTY")=$G(PRCDS(410.6,PRC4106,3,"I"))_U_$G(PRCDS(410.6,PRC4106,3,"E")) "RTN","PRCHJS02",286,0) . ; "RTN","PRCHJS02",287,0) . ;quit if error encountered "RTN","PRCHJS02",288,0) . Q:$D(PRCERR) "RTN","PRCHJS02",289,0) . ; "RTN","PRCHJS02",290,0) . ;for each item, place UNIT OF ISSUE (#420.5) fields into work global "RTN","PRCHJS02",291,0) . S PRC4205=+$G(@PRCWRK@(PRCLINE,"ITUOP"))_"," "RTN","PRCHJS02",292,0) . K PRCUNIT "RTN","PRCHJS02",293,0) . I +PRC4205>0 D GETS^DIQ(420.5,PRC4205,"*","IE","PRCUNIT","PRCERR") "RTN","PRCHJS02",294,0) . I $D(PRCERR) S PRCER="Unable to retrieve Unit Of Issue record" Q "RTN","PRCHJS02",295,0) . S @PRCWRK@(PRCLINE,"UNITNM")=$G(PRCUNIT(420.5,PRC4205,.01,"I"))_U_$G(PRCUNIT(420.5,PRC4205,.01,"E")) "RTN","PRCHJS02",296,0) . S @PRCWRK@(PRCLINE,"UNITFNM")=$G(PRCUNIT(420.5,PRC4205,1,"I"))_U_$G(PRCUNIT(420.5,PRC4205,1,"E")) "RTN","PRCHJS02",297,0) . ; "RTN","PRCHJS02",298,0) . ;for each item, place ITEM MASTER (#441) fields into work global "RTN","PRCHJS02",299,0) . S PRC441=+$G(@PRCWRK@(PRCLINE,"ITMFN"))_"," "RTN","PRCHJS02",300,0) . K PRCIMF "RTN","PRCHJS02",301,0) . I +PRC441>0 D GETS^DIQ(441,PRC441,"**","IE","PRCIMF","PRCERR") "RTN","PRCHJS02",302,0) . I $D(PRCERR) S PRCER="Unable to retrieve Item Master record" Q "RTN","PRCHJS02",303,0) . S @PRCWRK@(PRCLINE,"IMFSC")=$G(PRCIMF(441,PRC441,2,"I"))_U_$G(PRCIMF(441,PRC441,2,"E")) "RTN","PRCHJS02",304,0) . S @PRCWRK@(PRCLINE,"IMNSN")=$G(PRCIMF(441,PRC441,5,"I"))_U_$G(PRCIMF(441,PRC441,5,"E")) "RTN","PRCHJS02",305,0) . S @PRCWRK@(PRCLINE,"IMMFG")=$G(PRCIMF(441,PRC441,19,"I"))_U_$G(PRCIMF(441,PRC441,19,"E")) "RTN","PRCHJS02",306,0) . S @PRCWRK@(PRCLINE,"IMFOOD")=$G(PRCIMF(441,PRC441,20,"I"))_U_$G(PRCIMF(441,PRC441,20,"E")) "RTN","PRCHJS02",307,0) . S @PRCWRK@(PRCLINE,"IMNIF")=$G(PRCIMF(441,PRC441,51,"I"))_U_$G(PRCIMF(441,PRC441,51,"E")) "RTN","PRCHJS02",308,0) . ; "RTN","PRCHJS02",309,0) . ;use Vendor ptr (#12) field of (#410) file to obtain the associated "RTN","PRCHJS02",310,0) . ;VENDOR (#441.01) sub-file record and place field into work global "RTN","PRCHJS02",311,0) . S PRC441=$$GET1^DIQ(410,PRC410R_",",12,"I")_","_PRC441 "RTN","PRCHJS02",312,0) . S @PRCWRK@(PRCLINE,"IMPKGM")=$G(PRCIMF(441.01,PRC441,1.6,"I"))_U_$G(PRCIMF(441.01,PRC441,1.6,"E")) "RTN","PRCHJS02",313,0) . S @PRCWRK@(PRCLINE,"IMCTRCT")=$G(PRCIMF(441.01,PRC441,2,"I"))_U_$G(PRCIMF(441.01,PRC441,2,"E")) "RTN","PRCHJS02",314,0) . S @PRCWRK@(PRCLINE,"IMEXPDT")=$G(PRCIMF(441.01,PRC441,2.2,"I"))_U_$G(PRCIMF(441.01,PRC441,2.2,"E")) "RTN","PRCHJS02",315,0) . ;need to convert computed field CONTRACT EXP. DATE to internal FM date format "RTN","PRCHJS02",316,0) . I $P(@PRCWRK@(PRCLINE,"IMEXPDT"),U)]"" D "RTN","PRCHJS02",317,0) . . N X,Y ;input/output vars for ^%DT "RTN","PRCHJS02",318,0) . . S X=$P(@PRCWRK@(PRCLINE,"IMEXPDT"),U) "RTN","PRCHJS02",319,0) . . D ^%DT "RTN","PRCHJS02",320,0) . . S $P(@PRCWRK@(PRCLINE,"IMEXPDT"),U)=$S(Y>0:Y,1:"") "RTN","PRCHJS02",321,0) . S @PRCWRK@(PRCLINE,"IMNDC")=$G(PRCIMF(441.01,PRC441,4,"I"))_U_$G(PRCIMF(441.01,PRC441,4,"E")) "RTN","PRCHJS02",322,0) . S @PRCWRK@(PRCLINE,"IMMIN")=$G(PRCIMF(441.01,PRC441,8,"I"))_U_$G(PRCIMF(441.01,PRC441,8,"E")) "RTN","PRCHJS02",323,0) . S @PRCWRK@(PRCLINE,"IMMAX")=$G(PRCIMF(441.01,PRC441,8.5,"I"))_U_$G(PRCIMF(441.01,PRC441,8.5,"E")) "RTN","PRCHJS02",324,0) . S @PRCWRK@(PRCLINE,"IMREQ")=$G(PRCIMF(441.01,PRC441,9,"I"))_U_$G(PRCIMF(441.01,PRC441,9,"E")) "RTN","PRCHJS02",325,0) . S @PRCWRK@(PRCLINE,"IMUCF")=$G(PRCIMF(441.01,PRC441,10,"I"))_U_$G(PRCIMF(441.01,PRC441,10,"E")) "RTN","PRCHJS02",326,0) ; "RTN","PRCHJS02",327,0) ;cleanup ^TMP global "RTN","PRCHJS02",328,0) K @PRCFLDS "RTN","PRCHJS02",329,0) ; "RTN","PRCHJS02",330,0) ;success "RTN","PRCHJS02",331,0) S PRCRSLT=1 K PRCER "RTN","PRCHJS02",332,0) ; "RTN","PRCHJS02",333,0) Q PRCRSLT "RTN","PRCHJS05") 0^7^B105148815^B105876352 "RTN","PRCHJS05",1,0) PRCHJS05 ;OI&T/KCL - IFCAP/ECMS INTERFACE 2237 SEND SEG BUILDERS;6/12/12 "RTN","PRCHJS05",2,0) ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23 "RTN","PRCHJS05",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCHJS05",4,0) ; "RTN","PRCHJS05",5,0) ORC(PRCWRK,PRCHLO,PRCER,PRCTOARY) ;Build ORC segment "RTN","PRCHJS05",6,0) ;This function builds the ORC segment and adds it "RTN","PRCHJS05",7,0) ;to the msg being built using HLO APIs. Any data "RTN","PRCHJS05",8,0) ;manipulation or conversions are performed as needed. "RTN","PRCHJS05",9,0) ; "RTN","PRCHJS05",10,0) ; Supported ICR: "RTN","PRCHJS05",11,0) ; #10060: Allows retrieval of NAME (#.01) field from "RTN","PRCHJS05",12,0) ; NEW PERSON (#200) file using FM read. "RTN","PRCHJS05",13,0) ; "RTN","PRCHJS05",14,0) ; Input: "RTN","PRCHJS05",15,0) ; PRCWRK - (required) name of work global containing 2237 data elements "RTN","PRCHJS05",16,0) ; PRCHLO - (required) HLO workspace used to build message, pass by ref "RTN","PRCHJS05",17,0) ; "RTN","PRCHJS05",18,0) ; Output: "RTN","PRCHJS05",19,0) ; Function value - returns 1 on success, 0 on failure "RTN","PRCHJS05",20,0) ; PRCER - (optional) on failure, an error message is returned, pass by ref "RTN","PRCHJS05",21,0) ; PRCTOARY - (optional, pass by ref) returns the built segment in this format: "RTN","PRCHJS05",22,0) ; PRCTOARY(1) "RTN","PRCHJS05",23,0) ; "RTN","PRCHJS05",24,0) N PRCSEG ;contains the segment's data "RTN","PRCHJS05",25,0) N PRCNAME ;input array for $$HLNAME^XLFNAME "RTN","PRCHJS05",26,0) N PRCNCOMP ;name components in HL7 format "RTN","PRCHJS05",27,0) N PRCRSLT ;function result "RTN","PRCHJS05",28,0) ; "RTN","PRCHJS05",29,0) ;init vars "RTN","PRCHJS05",30,0) K PRCSEG S PRCSEG="" ;the segment should start off blank "RTN","PRCHJS05",31,0) S PRCNAME("FIELD")=.01 "RTN","PRCHJS05",32,0) S PRCNAME("FILE")=200 "RTN","PRCHJS05",33,0) S PRCRSLT=1 "RTN","PRCHJS05",34,0) ; "RTN","PRCHJS05",35,0) D SET^HLOAPI(.PRCSEG,"ORC",0) "RTN","PRCHJS05",36,0) D SET^HLOAPI(.PRCSEG,"NW",1) ;new order/service "RTN","PRCHJS05",37,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("TRANUM")),U,2),2,1) "RTN","PRCHJS05",38,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("PRI")),U,1),5) "RTN","PRCHJS05",39,0) D SET^HLOAPI(.PRCSEG,$$FMTHL7^XLFDT($P($G(@PRCWRK@("RQSTDT")),U,1)),9,1) "RTN","PRCHJS05",40,0) ; "RTN","PRCHJS05",41,0) ;get Accountable Officer name components "RTN","PRCHJS05",42,0) S PRCNAME("IENS")=$P($G(@PRCWRK@("AO")),U,1)_"," "RTN","PRCHJS05",43,0) S PRCNCOMP=$$HLNAME^XLFNAME(.PRCNAME) "RTN","PRCHJS05",44,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("AO")),U,1),11,1) ;duz "RTN","PRCHJS05",45,0) D SET^HLOAPI(.PRCSEG,$P($G(PRCNCOMP),U,1),11,2,1) ;last "RTN","PRCHJS05",46,0) D SET^HLOAPI(.PRCSEG,$P($G(PRCNCOMP),U,2),11,3) ;first "RTN","PRCHJS05",47,0) D SET^HLOAPI(.PRCSEG,$P($G(PRCNCOMP),U,3),11,4) ;middle "RTN","PRCHJS05",48,0) D SET^HLOAPI(.PRCSEG,$P($G(PRCNCOMP),U,4),11,5) ;suffix "RTN","PRCHJS05",49,0) ; "RTN","PRCHJS05",50,0) D SET^HLOAPI(.PRCSEG,$$FMTHL7^XLFDT($P($G(@PRCWRK@("AOESIG")),U,1)),11,19,1) "RTN","PRCHJS05",51,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("AOTITLE")),U,2),11,21) "RTN","PRCHJS05",52,0) ; "RTN","PRCHJS05",53,0) ;get Requestor name components "RTN","PRCHJS05",54,0) S PRCNAME("IENS")=$P($G(@PRCWRK@("REQ")),U,1)_"," "RTN","PRCHJS05",55,0) S PRCNCOMP=$$HLNAME^XLFNAME(.PRCNAME) "RTN","PRCHJS05",56,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("REQ")),U,1),12,1) ;duz "RTN","PRCHJS05",57,0) D SET^HLOAPI(.PRCSEG,$P($G(PRCNCOMP),U,1),12,2,1) ;last "RTN","PRCHJS05",58,0) D SET^HLOAPI(.PRCSEG,$P($G(PRCNCOMP),U,2),12,3) ;first "RTN","PRCHJS05",59,0) D SET^HLOAPI(.PRCSEG,$P($G(PRCNCOMP),U,3),12,4) ;middle "RTN","PRCHJS05",60,0) D SET^HLOAPI(.PRCSEG,$P($G(PRCNCOMP),U,4),12,5) ;suffix "RTN","PRCHJS05",61,0) ; "RTN","PRCHJS05",62,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("REQTITLE")),U,2),12,21) "RTN","PRCHJS05",63,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("INVPT")),U,2),17,1) "RTN","PRCHJS05",64,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("INVABREV")),U,2),17,2) "RTN","PRCHJS05",65,0) ; "RTN","PRCHJS05",66,0) ;get Approving Official name components "RTN","PRCHJS05",67,0) S PRCNAME("IENS")=$P($G(@PRCWRK@("APOF")),U,1)_"," "RTN","PRCHJS05",68,0) S PRCNCOMP=$$HLNAME^XLFNAME(.PRCNAME) "RTN","PRCHJS05",69,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("APOF")),U,1),19,1) ;duz "RTN","PRCHJS05",70,0) D SET^HLOAPI(.PRCSEG,$P($G(PRCNCOMP),U,1),19,2,1) ;last "RTN","PRCHJS05",71,0) D SET^HLOAPI(.PRCSEG,$P($G(PRCNCOMP),U,2),19,3) ;first "RTN","PRCHJS05",72,0) D SET^HLOAPI(.PRCSEG,$P($G(PRCNCOMP),U,3),19,4) ;middle "RTN","PRCHJS05",73,0) D SET^HLOAPI(.PRCSEG,$P($G(PRCNCOMP),U,4),19,5) ;suffix "RTN","PRCHJS05",74,0) ; "RTN","PRCHJS05",75,0) D SET^HLOAPI(.PRCSEG,$$FMTHL7^XLFDT($P($G(@PRCWRK@("ESIGDT")),U,1)),19,19,1) "RTN","PRCHJS05",76,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("APOFTIT")),U,2),19,21) "RTN","PRCHJS05",77,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("RQSRV")),U,2),21,1) "RTN","PRCHJS05",78,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("STANUM")),U,2),21,3) "RTN","PRCHJS05",79,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("SUBSTA")),U,2),21,8,2) "RTN","PRCHJS05",80,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("DELIVTO")),U,2),22,1,1) "RTN","PRCHJS05",81,0) D SET^HLOAPI(.PRCSEG,$$FMTHL7^XLFDT($P($G(@PRCWRK@("DTREQ")),U,1)),27,1) "RTN","PRCHJS05",82,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("FRMTYP")),U,1),29,1) "RTN","PRCHJS05",83,0) ; "RTN","PRCHJS05",84,0) ;add segment to message being built "RTN","PRCHJS05",85,0) I '$$ADDSEG^HLOAPI(.PRCHLO,.PRCSEG,.PRCER,.PRCTOARY) D "RTN","PRCHJS05",86,0) . S PRCRSLT=0 "RTN","PRCHJS05",87,0) . S PRCER="ORC segment not built" "RTN","PRCHJS05",88,0) ; "RTN","PRCHJS05",89,0) Q PRCRSLT "RTN","PRCHJS05",90,0) ; "RTN","PRCHJS05",91,0) ; "RTN","PRCHJS05",92,0) TQ1(PRCWRK,PRCHLO,PRCLINE,PRCER) ;Build TQ1 segment "RTN","PRCHJS05",93,0) ;This function builds a TQ1 segment for each delivery "RTN","PRCHJS05",94,0) ;schedule associated with a line item and adds it to "RTN","PRCHJS05",95,0) ;the msg being built using HLO APIs. Any data manipulation "RTN","PRCHJS05",96,0) ;or conversions are performed as needed. "RTN","PRCHJS05",97,0) ; "RTN","PRCHJS05",98,0) ; Input: "RTN","PRCHJS05",99,0) ; PRCWRK - (required) name of work global containing 2237 data elements "RTN","PRCHJS05",100,0) ; PRCHLO - (required) HLO workspace used to build message, pass by ref "RTN","PRCHJS05",101,0) ; PRCLINE - (required) line item number "RTN","PRCHJS05",102,0) ; "RTN","PRCHJS05",103,0) ; Output: "RTN","PRCHJS05",104,0) ; Function value - returns 1 on success, 0 on failure "RTN","PRCHJS05",105,0) ; PRCER - (optional) on failure, an error message is returned, pass by ref "RTN","PRCHJS05",106,0) ; "RTN","PRCHJS05",107,0) N PRCSEG ;contains the segment's data "RTN","PRCHJS05",108,0) N PRCSUB ;array subscript "RTN","PRCHJS05",109,0) N PRCRSLT ;function result "RTN","PRCHJS05",110,0) ; "RTN","PRCHJS05",111,0) ;init vars "RTN","PRCHJS05",112,0) K PRCSEG S PRCSEG="" ;the segment should start off blank "RTN","PRCHJS05",113,0) S PRCLINE=+$G(PRCLINE) "RTN","PRCHJS05",114,0) S PRCSUB=0 "RTN","PRCHJS05",115,0) S PRCRSLT=0 "RTN","PRCHJS05",116,0) ; "RTN","PRCHJS05",117,0) I PRCLINE'>0 S PRCER="TQ1 segment not built - no line item passed" Q PRCRSLT "RTN","PRCHJS05",118,0) I '$O(@PRCWRK@(PRCLINE,PRCSUB)) S PRCER="TQ1 segment not built - no delivery schedule for item" Q PRCRSLT "RTN","PRCHJS05",119,0) ; "RTN","PRCHJS05",120,0) S PRCRSLT=1 "RTN","PRCHJS05",121,0) ; "RTN","PRCHJS05",122,0) ;loop thru delivery schedules for the line item "RTN","PRCHJS05",123,0) F S PRCSUB=$O(@PRCWRK@(PRCLINE,PRCSUB)) Q:('$G(PRCSUB)!('PRCRSLT)) D "RTN","PRCHJS05",124,0) . D SET^HLOAPI(.PRCSEG,"TQ1",0) "RTN","PRCHJS05",125,0) . D SET^HLOAPI(.PRCSEG,PRCSUB,1) ;Delivery Schedule # "RTN","PRCHJS05",126,0) . D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,PRCSUB,"DELQTY")),U,2),2,1) "RTN","PRCHJS05",127,0) . D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"UNITNM")),U,2),2,2,1) "RTN","PRCHJS05",128,0) . D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"UNITFNM")),U,2),2,2,2) "RTN","PRCHJS05",129,0) . D SET^HLOAPI(.PRCSEG,$$FMTHL7^XLFDT($P($G(@PRCWRK@(PRCLINE,PRCSUB,"DELDT")),U)),7,1) "RTN","PRCHJS05",130,0) . D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,PRCSUB,"DELLOC")),U,2),10) "RTN","PRCHJS05",131,0) . D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,PRCSUB,"DELREF")),U,2),11) "RTN","PRCHJS05",132,0) . ; "RTN","PRCHJS05",133,0) . ;add segment to message being built "RTN","PRCHJS05",134,0) . I '$$ADDSEG^HLOAPI(.PRCHLO,.PRCSEG,.PRCER) D "RTN","PRCHJS05",135,0) . . S PRCRSLT=0 "RTN","PRCHJS05",136,0) . . S PRCER="TQ1 segment not built" "RTN","PRCHJS05",137,0) ; "RTN","PRCHJS05",138,0) Q PRCRSLT "RTN","PRCHJS05",139,0) ; "RTN","PRCHJS05",140,0) ; "RTN","PRCHJS05",141,0) RQD(PRCWRK,PRCHLO,PRCLINE,PRCER,PRCTOARY) ;Build RQD segment "RTN","PRCHJS05",142,0) ;This function builds the RQD segment and adds it to the "RTN","PRCHJS05",143,0) ;msg being built using HLO APIs. Any data manipulation "RTN","PRCHJS05",144,0) ;or conversions are performed as needed. "RTN","PRCHJS05",145,0) ; "RTN","PRCHJS05",146,0) ; Input: "RTN","PRCHJS05",147,0) ; PRCWRK - (required) name of work global containing 2237 data elements "RTN","PRCHJS05",148,0) ; PRCHLO - (required) HLO workspace used to build message, pass by ref "RTN","PRCHJS05",149,0) ; PRCLINE - (required) line item number "RTN","PRCHJS05",150,0) ; "RTN","PRCHJS05",151,0) ; Output: "RTN","PRCHJS05",152,0) ; Function value - returns 1 on success, 0 on failure "RTN","PRCHJS05",153,0) ; PRCER - (optional) on failure, an error message is returned, pass by ref "RTN","PRCHJS05",154,0) ; PRCTOARY - (optional, pass by ref) returns the built segment in this format: "RTN","PRCHJS05",155,0) ; PRCTOARY(1) "RTN","PRCHJS05",156,0) ; "RTN","PRCHJS05",157,0) N PRCSEG ;contains the segment's data "RTN","PRCHJS05",158,0) N PRCRSLT ;function result "RTN","PRCHJS05",159,0) ; "RTN","PRCHJS05",160,0) ;init vars "RTN","PRCHJS05",161,0) K PRCSEG S PRCSEG="" ;the segment should start off blank "RTN","PRCHJS05",162,0) S PRCLINE=+$G(PRCLINE) "RTN","PRCHJS05",163,0) S PRCRSLT=0 "RTN","PRCHJS05",164,0) ; "RTN","PRCHJS05",165,0) I PRCLINE'>0 S PRCER="RQD segment not built - no line item passed" Q PRCRSLT "RTN","PRCHJS05",166,0) I +$G(@PRCWRK@(PRCLINE,"ITLINE"))'>0 S PRCER="RQD segment not built - line item not found" Q PRCRSLT "RTN","PRCHJS05",167,0) ; "RTN","PRCHJS05",168,0) S PRCRSLT=1 "RTN","PRCHJS05",169,0) ; "RTN","PRCHJS05",170,0) D SET^HLOAPI(.PRCSEG,"RQD",0) "RTN","PRCHJS05",171,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"ITLINE")),U,2),1) "RTN","PRCHJS05",172,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"ITMFN")),U,2),2,1) "RTN","PRCHJS05",173,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"IMNSN")),U,2),2,4) "RTN","PRCHJS05",174,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"IMFSC")),U,2),2,5) "RTN","PRCHJS05",175,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"ITSTOCK")),U,2),3,1) "RTN","PRCHJS05",176,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"ITQTY")),U,2),5) "RTN","PRCHJS05",177,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"UNITNM")),U,2),6,1) "RTN","PRCHJS05",178,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"UNITFNM")),U,2),6,2) "RTN","PRCHJS05",179,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"IMPKGM")),U,2),6,4) "RTN","PRCHJS05",180,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("COSTCTR")),U,2),7) "RTN","PRCHJS05",181,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"ITBOC")),U,2),8) "RTN","PRCHJS05",182,0) ; "RTN","PRCHJS05",183,0) ;add segment to message being built "RTN","PRCHJS05",184,0) I '$$ADDSEG^HLOAPI(.PRCHLO,.PRCSEG,.PRCER,.PRCTOARY) D "RTN","PRCHJS05",185,0) . S PRCRSLT=0 "RTN","PRCHJS05",186,0) . S PRCER="RQD segment not built" "RTN","PRCHJS05",187,0) ; "RTN","PRCHJS05",188,0) Q PRCRSLT "RTN","PRCHJS05",189,0) ; "RTN","PRCHJS05",190,0) ; "RTN","PRCHJS05",191,0) RQ1(PRCWRK,PRCHLO,PRCLINE,PRCER,PRCTOARY) ;Build RQ1 segment "RTN","PRCHJS05",192,0) ;This function builds the RQ1 segment and adds it to the "RTN","PRCHJS05",193,0) ;msg being built using HLO APIs. Any data manipulation "RTN","PRCHJS05",194,0) ;or conversions are performed as needed. "RTN","PRCHJS05",195,0) ; "RTN","PRCHJS05",196,0) ; Input: "RTN","PRCHJS05",197,0) ; PRCWRK - (required) name of work global containing 2237 data elements "RTN","PRCHJS05",198,0) ; PRCHLO - (required) HLO workspace used to build message, pass by ref "RTN","PRCHJS05",199,0) ; PRCLINE - (required) line item number "RTN","PRCHJS05",200,0) ; "RTN","PRCHJS05",201,0) ; Output: "RTN","PRCHJS05",202,0) ; Function value - returns 1 on success, 0 on failure "RTN","PRCHJS05",203,0) ; PRCER - (optional) on failure, an error message is returned, pass by ref "RTN","PRCHJS05",204,0) ; PRCTOARY - (optional, pass by ref) returns the built segment in this format: "RTN","PRCHJS05",205,0) ; PRCTOARY(1) "RTN","PRCHJS05",206,0) ; "RTN","PRCHJS05",207,0) N PRCSEG ;contains the segment's data "RTN","PRCHJS05",208,0) N PRCRSLT ;function result "RTN","PRCHJS05",209,0) ; "RTN","PRCHJS05",210,0) ;init vars "RTN","PRCHJS05",211,0) K PRCSEG S PRCSEG="" ;the segment should start off blank "RTN","PRCHJS05",212,0) S PRCLINE=+$G(PRCLINE) "RTN","PRCHJS05",213,0) S PRCRSLT=0 "RTN","PRCHJS05",214,0) ; "RTN","PRCHJS05",215,0) I PRCLINE'>0 S PRCER="RQ1 segment not built - no line item passed" Q PRCRSLT "RTN","PRCHJS05",216,0) I +$G(@PRCWRK@(PRCLINE,"ITLINE"))'>0 S PRCER="RQ1 segment not built - line item not found" Q PRCRSLT "RTN","PRCHJS05",217,0) ; "RTN","PRCHJS05",218,0) S PRCRSLT=1 "RTN","PRCHJS05",219,0) ; "RTN","PRCHJS05",220,0) D SET^HLOAPI(.PRCSEG,"RQ1",0) "RTN","PRCHJS05",221,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"ITCOST")),U,2),1) "RTN","PRCHJS05",222,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"IMMFG")),U,2),2,1) "RTN","PRCHJS05",223,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("VENDPT")),U),4,1) "RTN","PRCHJS05",224,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@("VENDNM")),U,2),4,2) "RTN","PRCHJS05",225,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"IMCTRCT")),U,2),4,4) "RTN","PRCHJS05",226,0) D SET^HLOAPI(.PRCSEG,$$FMTHL7^XLFDT($P($G(@PRCWRK@(PRCLINE,"IMEXPDT")),U,1)),4,5) "RTN","PRCHJS05",227,0) ; "RTN","PRCHJS05",228,0) ;add segment to message being built "RTN","PRCHJS05",229,0) I '$$ADDSEG^HLOAPI(.PRCHLO,.PRCSEG,.PRCER,.PRCTOARY) D "RTN","PRCHJS05",230,0) . S PRCRSLT=0 "RTN","PRCHJS05",231,0) . S PRCER="RQ1 segment not built" "RTN","PRCHJS05",232,0) ; "RTN","PRCHJS05",233,0) Q PRCRSLT "RTN","PRCHJS05",234,0) ; "RTN","PRCHJS05",235,0) ; "RTN","PRCHJS05",236,0) ZA1(PRCWRK,PRCHLO,PRCLINE,PRCER,PRCTOARY) ;Build ZA1 segment "RTN","PRCHJS05",237,0) ;This function builds the ZA1 segment and adds it to the "RTN","PRCHJS05",238,0) ;msg being built using HLO APIs. Any data manipulation "RTN","PRCHJS05",239,0) ;or conversions are performed as needed. "RTN","PRCHJS05",240,0) ; "RTN","PRCHJS05",241,0) ; Input: "RTN","PRCHJS05",242,0) ; PRCWRK - (required) name of work global containing 2237 data elements "RTN","PRCHJS05",243,0) ; PRCHLO - (required) HLO workspace used to build message, pass by ref "RTN","PRCHJS05",244,0) ; PRCLINE - (required) line item number "RTN","PRCHJS05",245,0) ; "RTN","PRCHJS05",246,0) ; Output: "RTN","PRCHJS05",247,0) ; Function value - returns 1 on success, 0 on failure "RTN","PRCHJS05",248,0) ; PRCER - (optional) on failure, an error message is returned, pass by ref "RTN","PRCHJS05",249,0) ; PRCTOARY - (optional, pass by ref) returns the built segment in this format: "RTN","PRCHJS05",250,0) ; PRCTOARY(1) "RTN","PRCHJS05",251,0) ; "RTN","PRCHJS05",252,0) N PRCSEG ;contains the segment's data "RTN","PRCHJS05",253,0) N PRCRSLT ;function result "RTN","PRCHJS05",254,0) ; "RTN","PRCHJS05",255,0) K PRCSEG S PRCSEG="" ;the segment should start off blank "RTN","PRCHJS05",256,0) S PRCLINE=+$G(PRCLINE) "RTN","PRCHJS05",257,0) S PRCRSLT=0 "RTN","PRCHJS05",258,0) ; "RTN","PRCHJS05",259,0) I PRCLINE'>0 S PRCER="ZA1 segment not built - no line item passed" Q PRCRSLT "RTN","PRCHJS05",260,0) I +$G(@PRCWRK@(PRCLINE,"ITLINE"))'>0 S PRCER="ZA1 segment not built - line item not found" Q PRCRSLT "RTN","PRCHJS05",261,0) ; "RTN","PRCHJS05",262,0) S PRCRSLT=1 "RTN","PRCHJS05",263,0) ; "RTN","PRCHJS05",264,0) D SET^HLOAPI(.PRCSEG,"ZA1",0) "RTN","PRCHJS05",265,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"IMNDC")),U,2),1) "RTN","PRCHJS05",266,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"IMFOOD")),U,1),2) "RTN","PRCHJS05",267,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"IMNIF")),U,2),3) "RTN","PRCHJS05",268,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"IMMIN")),U,2),4) "RTN","PRCHJS05",269,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"IMMAX")),U,2),5) "RTN","PRCHJS05",270,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"IMREQ")),U,2),6) "RTN","PRCHJS05",271,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"IMUCF")),U,2),7) "RTN","PRCHJS05",272,0) D SET^HLOAPI(.PRCSEG,$P($G(@PRCWRK@(PRCLINE,"ITDMID")),U,2),8) "RTN","PRCHJS05",273,0) ; "RTN","PRCHJS05",274,0) ;add segment to message being built "RTN","PRCHJS05",275,0) I '$$ADDSEG^HLOAPI(.PRCHLO,.PRCSEG,.PRCER,.PRCTOARY) D "RTN","PRCHJS05",276,0) . S PRCRSLT=0 "RTN","PRCHJS05",277,0) . S PRCER="ZA1 segment not built" "RTN","PRCHJS05",278,0) ; "RTN","PRCHJS05",279,0) Q PRCRSLT "RTN","PRCHJS05",280,0) ; "RTN","PRCHJS05",281,0) ; "RTN","PRCHJS05",282,0) NTEITEM(PRCWRK,PRCHLO,PRCLINE,PRCER) ;Build NTE segments for item description "RTN","PRCHJS05",283,0) ;This function builds repeating NTE segments for the "RTN","PRCHJS05",284,0) ;description of the item being ordered and adds it "RTN","PRCHJS05",285,0) ;to the msg being built using HLO APIs. "RTN","PRCHJS05",286,0) ; "RTN","PRCHJS05",287,0) ; Input: "RTN","PRCHJS05",288,0) ; PRCWRK - (required) name of work global containing 2237 data elements "RTN","PRCHJS05",289,0) ; PRCHLO - (required) HLO workspace used to build message, pass by ref "RTN","PRCHJS05",290,0) ; PRCLINE - (required) line item number "RTN","PRCHJS05",291,0) ; "RTN","PRCHJS05",292,0) ; Output: "RTN","PRCHJS05",293,0) ; Function value - returns 1 on success, 0 on failure "RTN","PRCHJS05",294,0) ; PRCER - (optional) on failure, an error message is returned, pass by ref "RTN","PRCHJS05",295,0) ; "RTN","PRCHJS05",296,0) N PRCSETID ;segment set id "RTN","PRCHJS05",297,0) N PRCSUB ;array subscript "RTN","PRCHJS05",298,0) N PRCSEG ;contains the segment's data "RTN","PRCHJS05",299,0) N PRCRSLT ;function result "RTN","PRCHJS05",300,0) ; "RTN","PRCHJS05",301,0) ;init vars "RTN","PRCHJS05",302,0) K PRCSEG S PRCSEG="" ;the segment should start off blank "RTN","PRCHJS05",303,0) S PRCLINE=+$G(PRCLINE) "RTN","PRCHJS05",304,0) S PRCRSLT=0 "RTN","PRCHJS05",305,0) ; "RTN","PRCHJS05",306,0) I PRCLINE'>0 S PRCER="NTE item segment not built - no line item passed" Q PRCRSLT "RTN","PRCHJS05",307,0) I +$G(@PRCWRK@(PRCLINE,"ITLINE"))'>0 S PRCER="NTE item segment not built - line item not found" Q PRCRSLT "RTN","PRCHJS05",308,0) ; "RTN","PRCHJS05",309,0) S PRCRSLT=1 "RTN","PRCHJS05",310,0) ; "RTN","PRCHJS05",311,0) ;loop thru Description nodes for the Line Item "RTN","PRCHJS05",312,0) S (PRCSUB,PRCSETID)=0 "RTN","PRCHJS05",313,0) F S PRCSUB=$O(@PRCWRK@(PRCLINE,"ITDESC",PRCSUB)) Q:'$G(PRCSUB)!('PRCRSLT) D "RTN","PRCHJS05",314,0) . S PRCSETID=PRCSETID+1 "RTN","PRCHJS05",315,0) . D SET^HLOAPI(.PRCSEG,"NTE",0) "RTN","PRCHJS05",316,0) . D SET^HLOAPI(.PRCSEG,PRCSETID,1) "RTN","PRCHJS05",317,0) . D SET^HLOAPI(.PRCSEG,"P",2) ;P for Placer (Orderer) "RTN","PRCHJS05",318,0) . D SET^HLOAPI(.PRCSEG,$G(@PRCWRK@(PRCLINE,"ITDESC",PRCSUB,0)),3) "RTN","PRCHJS05",319,0) . D SET^HLOAPI(.PRCSEG,"LD",4,1) ;LD for Line Item Description "RTN","PRCHJS05",320,0) . ; "RTN","PRCHJS05",321,0) . ;add segment to message being built "RTN","PRCHJS05",322,0) . I '$$ADDSEG^HLOAPI(.PRCHLO,.PRCSEG,.PRCER) D "RTN","PRCHJS05",323,0) . . S PRCRSLT=0 "RTN","PRCHJS05",324,0) . . S PRCER="NTE segment not built" "RTN","PRCHJS05",325,0) ; "RTN","PRCHJS05",326,0) Q PRCRSLT "RTN","PRCHJS07") 0^6^B50659801^B47804786 "RTN","PRCHJS07",1,0) PRCHJS07 ;OI&T/KCL - IFCAP/ECMS INTERFACE RETRANSMIT 2237;6/6/12 "RTN","PRCHJS07",2,0) ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23 "RTN","PRCHJS07",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCHJS07",4,0) ; "RTN","PRCHJS07",5,0) ENTACT(PRCDUZ) ;Option [PRCHJ RETRANS 2237] entry action "RTN","PRCHJS07",6,0) ;This function is called from the entry action of the "RTN","PRCHJS07",7,0) ;option. If the user is not assigned as the PPM ACCOUNTABLE "RTN","PRCHJS07",8,0) ;OFFICER or MANAGER, access will be denied. "RTN","PRCHJS07",9,0) ; "RTN","PRCHJS07",10,0) ; Input: "RTN","PRCHJS07",11,0) ; PRCDUZ - (required) IEN of user in the NEW PERSON (#200) file "RTN","PRCHJS07",12,0) ; "RTN","PRCHJS07",13,0) ; Output: "RTN","PRCHJS07",14,0) ; Function value - 1 on success, 0 on failure (access denied) "RTN","PRCHJS07",15,0) ; "RTN","PRCHJS07",16,0) N PRCIENS ;iens string for GETS^DIQ "RTN","PRCHJS07",17,0) N PRCFLDS ;results array for GETS^DIQ "RTN","PRCHJS07",18,0) N PRCERR ;error array for GETS^DIQ "RTN","PRCHJS07",19,0) N PRCRSLT ;function result "RTN","PRCHJS07",20,0) ; "RTN","PRCHJS07",21,0) S PRCRSLT=0 "RTN","PRCHJS07",22,0) ; "RTN","PRCHJS07",23,0) I +$G(DUZ)>0 D "RTN","PRCHJS07",24,0) . ;is user assigned as PPM ACCOUNTABLE OFFICER or MANAGER? "RTN","PRCHJS07",25,0) . S PRCIENS=+$G(DUZ)_"," "RTN","PRCHJS07",26,0) . D GETS^DIQ(200,PRCIENS,"400","I","PRCFLDS","PRCERR") "RTN","PRCHJS07",27,0) . Q:$D(PRCERR) "RTN","PRCHJS07",28,0) . I $G(PRCFLDS(200,PRCIENS,400,"I"))=2!($G(PRCFLDS(200,PRCIENS,400,"I"))=4) S PRCRSLT=1 "RTN","PRCHJS07",29,0) ; "RTN","PRCHJS07",30,0) I 'PRCRSLT D "RTN","PRCHJS07",31,0) . W !!,">>> You are not authorized to use this option!" "RTN","PRCHJS07",32,0) . W !?4,"User is not setup as Manager or Accountable Officer." "RTN","PRCHJS07",33,0) ; "RTN","PRCHJS07",34,0) Q PRCRSLT "RTN","PRCHJS07",35,0) ; "RTN","PRCHJS07",36,0) ; "RTN","PRCHJS07",37,0) RETRANS ;Option [PRCHJ RETRANS 2237] run routine "RTN","PRCHJS07",38,0) ;This procedure is the run routine for the [PRCHJ RETRANS 2237] "RTN","PRCHJS07",39,0) ;option and allows retransmission of a 2237 to the Electronic "RTN","PRCHJS07",40,0) ;Contract Management System (eCMS) via HL7 messaging. "RTN","PRCHJS07",41,0) ; "RTN","PRCHJS07",42,0) ; Input: None "RTN","PRCHJS07",43,0) ; Output: None "RTN","PRCHJS07",44,0) ; "RTN","PRCHJS07",45,0) N PRCESIG ;output from call to ESIG^PRCUESIG "RTN","PRCHJS07",46,0) N PRCABORT ;flag to abort user prompting "RTN","PRCHJS07",47,0) ; "RTN","PRCHJS07",48,0) ;prompt - electronic signature to validate user "RTN","PRCHJS07",49,0) W ! "RTN","PRCHJS07",50,0) S PRCESIG="" "RTN","PRCHJS07",51,0) D ESIG^PRCUESIG($G(DUZ),.PRCESIG) "RTN","PRCHJS07",52,0) Q:$G(PRCESIG)'=1 "RTN","PRCHJS07",53,0) ; "RTN","PRCHJS07",54,0) ;prompt user to retransmit 2237 transactions until PRCABORT=1 "RTN","PRCHJS07",55,0) S PRCABORT=0 "RTN","PRCHJS07",56,0) F D Q:PRCABORT "RTN","PRCHJS07",57,0) . N PRCER ;transmission error text "RTN","PRCHJS07",58,0) . N PRCLOGER ;error returned from LOG^PRCHJTA "RTN","PRCHJS07",59,0) . ;prompt - select 2237 transaction in REQUEST WORKSHEET (#443) file "RTN","PRCHJS07",60,0) . N DIC,DTOUT,DUOUT,X,Y ;^DIC variables "RTN","PRCHJS07",61,0) . N PRCSELCT ;selected entry: ien^transaction # "RTN","PRCHJS07",62,0) . W ! "RTN","PRCHJS07",63,0) . S DIC="^PRC(443," "RTN","PRCHJS07",64,0) . S DIC(0)="AEMQZ" "RTN","PRCHJS07",65,0) . S DIC("A")="Select 2237 TRANSACTION NUMBER: " "RTN","PRCHJS07",66,0) . ;(screen) only allow selection of 2237s with status of 'Sent to eCMS (P&C)' and "RTN","PRCHJS07",67,0) . ;have not been processed by eCMS (no ECMS ACTIONUID) "RTN","PRCHJS07",68,0) . S DIC("S")="I $P(^PRC(443,+$G(Y),0),U,7)=69,'$$ECMS2237^PRCHJUTL(Y)" "RTN","PRCHJS07",69,0) . D ^DIC K DIC "RTN","PRCHJS07",70,0) . S:$G(Y)>0 PRCSELCT=+$G(Y)_U_$G(Y(0,0)) "RTN","PRCHJS07",71,0) . ;abort if no 2237 transaction selected, or user enters up-arrow, or timed out "RTN","PRCHJS07",72,0) . I (Y=-1)!($D(DTOUT))!($D(DUOUT)) S PRCABORT=1 Q "RTN","PRCHJS07",73,0) . ; "RTN","PRCHJS07",74,0) . ;prompt - review 2237 prior to retransmission? "RTN","PRCHJS07",75,0) . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ;^DIR variables "RTN","PRCHJS07",76,0) . W ! "RTN","PRCHJS07",77,0) . S DIR(0)="YA" "RTN","PRCHJS07",78,0) . S DIR("B")="NO" "RTN","PRCHJS07",79,0) . S DIR("A")="Would you like to review this 2237 transaction? " "RTN","PRCHJS07",80,0) . S DIR("?")="'Yes' to review the 2237 prior to retransmitting, 'No' to not review." "RTN","PRCHJS07",81,0) . D ^DIR K DIR "RTN","PRCHJS07",82,0) . ;abort if user enters up-arrow, pressed Enter key, or timed out "RTN","PRCHJS07",83,0) . I $D(DIRUT) S PRCABORT=1 Q "RTN","PRCHJS07",84,0) . ;if Yes, display 2237 for review "RTN","PRCHJS07",85,0) . I Y=1 D DISP2237(+$G(PRCSELCT)) "RTN","PRCHJS07",86,0) . ; "RTN","PRCHJS07",87,0) . ;prompt - 2237 retransmit? "RTN","PRCHJS07",88,0) . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ;^DIR variables "RTN","PRCHJS07",89,0) . W ! "RTN","PRCHJS07",90,0) . S DIR(0)="YA" "RTN","PRCHJS07",91,0) . S DIR("B")="NO" "RTN","PRCHJS07",92,0) . S DIR("A")="Do you want to retransmit this 2237 transaction to eCMS? " "RTN","PRCHJS07",93,0) . S DIR("?")="'Yes' to retransmit the 2237 to eCMS, 'No' to not retransmit." "RTN","PRCHJS07",94,0) . D ^DIR K DIR "RTN","PRCHJS07",95,0) . ;abort if user enters up-arrow, pressed Enter key, or timed out "RTN","PRCHJS07",96,0) . I $D(DIRUT) S PRCABORT=1 Q "RTN","PRCHJS07",97,0) . ;if No selected, quit and ask user for another 2237 transaction "RTN","PRCHJS07",98,0) . I (Y=0) Q "RTN","PRCHJS07",99,0) . ; "RTN","PRCHJS07",100,0) . ;if Yes selected, retransmit 2237 to eCMS "RTN","PRCHJS07",101,0) . W !!,"Retransmitting 2237 transaction to eCMS..." "RTN","PRCHJS07",102,0) . N PRCMSGID ;ien of msg in HLO MESSAGES (#778) file "RTN","PRCHJS07",103,0) . S PRCMSGID=$$SEND2237^PRCHJS01(+$G(PRCSELCT),.PRCER) "RTN","PRCHJS07",104,0) . ; "RTN","PRCHJS07",105,0) . ;was the transmission successful, ELSE did it fail? "RTN","PRCHJS07",106,0) . I $G(PRCMSGID)>0 D "RTN","PRCHJS07",107,0) . . W !?3,">>> 2237 transaction has been successfully retransmitted to eCMS." "RTN","PRCHJS07",108,0) . . W !?7,"Transaction Number: "_$P($G(PRCSELCT),U,2) "RTN","PRCHJS07",109,0) . . W !?11,"HLO Message ID: "_$G(PRCMSGID) "RTN","PRCHJS07",110,0) . . ;log transmission in IFCAP/ECMS TRANSACTION (#414.06) file "RTN","PRCHJS07",111,0) . . W !!?3,">>> Updating retransmission in IFCAP/ECMS Transaction file..." "RTN","PRCHJS07",112,0) . . N PRCEVNT ;event array for LOG^PRCHJTA "RTN","PRCHJS07",113,0) . . S PRCEVNT("MSGID")=$G(PRCMSGID) "RTN","PRCHJS07",114,0) . . S PRCEVNT("IEN410")=+$G(PRCSELCT) "RTN","PRCHJS07",115,0) . . S PRCEVNT("IFCAPU")=$G(DUZ) "RTN","PRCHJS07",116,0) . . D LOG^PRCHJTA($P($G(PRCSELCT),U,2),,4,.PRCEVNT,.PRCLOGER) "RTN","PRCHJS07",117,0) . . I +$G(PRCLOGER) W !?7,"Error: "_$P($G(PRCLOGER),U,2) "RTN","PRCHJS07",118,0) . E D "RTN","PRCHJS07",119,0) . . W !?3,">>> ERROR: 2237 was not retransmitted to eCMS!" "RTN","PRCHJS07",120,0) . . W !?7,"Transaction Number: "_$P($G(PRCSELCT),U,2) "RTN","PRCHJS07",121,0) . . ;setup PRCEVNT array for call to LOG^PRCHJTA and output error(s) "RTN","PRCHJS07",122,0) . . N PRCEVNT "RTN","PRCHJS07",123,0) . . S PRCEVNT("MSGID")="" "RTN","PRCHJS07",124,0) . . S PRCEVNT("IEN410")=+$G(PRCSELCT) "RTN","PRCHJS07",125,0) . . S PRCEVNT("IFCAPU")=$G(DUZ) "RTN","PRCHJS07",126,0) . . S PRCEVNT("ERROR",1)="An error occurred when retransmitting the 2237 transaction to eCMS." "RTN","PRCHJS07",127,0) . . S PRCEVNT("ERROR",2)="Option: "_$S($P($G(XQY0),"^",2)]"":$P($G(XQY0),"^",2),1:"UNKNOWN") "RTN","PRCHJS07",128,0) . . N PRCIDX1,PRCIDX2 "RTN","PRCHJS07",129,0) . . S PRCIDX1=0,PRCIDX2=2 "RTN","PRCHJS07",130,0) . . ;output error(s) "RTN","PRCHJS07",131,0) . . F S PRCIDX1=$O(PRCER(PRCIDX1)) Q:PRCIDX1="" D "RTN","PRCHJS07",132,0) . . . W !?7,"Error #"_$G(PRCIDX1)_": "_$G(PRCER(PRCIDX1)) "RTN","PRCHJS07",133,0) . . . S PRCIDX2=PRCIDX2+1 S PRCEVNT("ERROR",PRCIDX2)="Error #"_$G(PRCIDX1)_": "_$G(PRCER(PRCIDX1)) "RTN","PRCHJS07",134,0) . . W !!?3,">>> Updating transmission error in IFCAP/ECMS Transaction file..." "RTN","PRCHJS07",135,0) . . D LOG^PRCHJTA($P($G(PRCSELCT),U,2),,4,.PRCEVNT,.PRCLOGER) "RTN","PRCHJS07",136,0) . . I +$G(PRCLOGER) W !?7,"Error: "_$P($G(PRCLOGER),U,2) "RTN","PRCHJS07",137,0) . . ;send error(s) to AO "RTN","PRCHJS07",138,0) . . W !!?3,">>> Sending error notification mail message to Accountable Officer..." "RTN","PRCHJS07",139,0) . . N PRCMSG1,PRCMSG2 ;input arrays for PHMSG^PRCHJMSG, pass by ref "RTN","PRCHJS07",140,0) . . S PRCMSG1(1)=$P($G(PRCSELCT),U,2) "RTN","PRCHJS07",141,0) . . S PRCMSG1(2)=5 ;return to AO since failed transmission to eCMS "RTN","PRCHJS07",142,0) . . S PRCMSG1(3)=$$NOW^XLFDT ;action date/time "RTN","PRCHJS07",143,0) . . S PRCMSG1(7)="Please forward this message to appropriate OIT staff!" "RTN","PRCHJS07",144,0) . . M PRCMSG2=PRCEVNT("ERROR") ;merge error array into PRCMSG2 array "RTN","PRCHJS07",145,0) . . D PHMSG^PRCHJMSG(.PRCMSG1,.PRCMSG2) ;send msg "RTN","PRCHJS07",146,0) . ; "RTN","PRCHJS07",147,0) . ;prompt - retransmit another 2237 transaction? "RTN","PRCHJS07",148,0) . N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ;^DIR variables "RTN","PRCHJS07",149,0) . S DIR(0)="YA" "RTN","PRCHJS07",150,0) . S DIR("B")="NO" "RTN","PRCHJS07",151,0) . S DIR("A")="Do you want to retransmit another 2237 transaction to eCMS? " "RTN","PRCHJS07",152,0) . S DIR("?")="'Yes' to retransmit another 2237 to eCMS, 'No' to exit." "RTN","PRCHJS07",153,0) . W ! "RTN","PRCHJS07",154,0) . D ^DIR K DIR "RTN","PRCHJS07",155,0) . ;abort if user enters No, up-arrow, pressed Enter key, or timed out "RTN","PRCHJS07",156,0) . I $D(DIRUT)!(Y=0) S PRCABORT=1 Q "RTN","PRCHJS07",157,0) ; "RTN","PRCHJS07",158,0) Q "RTN","PRCHJS07",159,0) ; "RTN","PRCHJS07",160,0) ; "RTN","PRCHJS07",161,0) DISP2237(DA) ;Display 2237 Utility "RTN","PRCHJS07",162,0) ;This procedure calls ^PRCSD12 to display a 2237 to the screen. "RTN","PRCHJS07",163,0) ; "RTN","PRCHJS07",164,0) ; Input: "RTN","PRCHJS07",165,0) ; DA - (required var for ^PRCSD12) IEN of record in CONTROL POINT ACTIVITY (#410) file "RTN","PRCHJS07",166,0) ; "RTN","PRCHJS07",167,0) ; Output: None "RTN","PRCHJS07",168,0) ; "RTN","PRCHJS07",169,0) N PRCS,PRCPRIB,TRNODE "RTN","PRCHJS07",170,0) S (PRCS,PRCPRIB)=$G(DA) "RTN","PRCHJS07",171,0) S TRNODE(0)=0 "RTN","PRCHJS07",172,0) D ^PRCSD12 "RTN","PRCHJS07",173,0) Q "RTN","PRCHJS07",174,0) ; "RTN","PRCHJS07",175,0) ; "RTN","PRCHJS07",176,0) CONTINUE() ;Pause display utility "RTN","PRCHJS07",177,0) ;This function is used to pause the display and prompt the "RTN","PRCHJS07",178,0) ;user to --> Enter RETURN to continue or '^' to exit "RTN","PRCHJS07",179,0) ; "RTN","PRCHJS07",180,0) ; Input: None "RTN","PRCHJS07",181,0) ; "RTN","PRCHJS07",182,0) ; Output: 1 - continue "RTN","PRCHJS07",183,0) ; 0 - quit/exit "RTN","PRCHJS07",184,0) ; "RTN","PRCHJS07",185,0) N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y ;^DIR variables "RTN","PRCHJS07",186,0) S DIR(0)="E" "RTN","PRCHJS07",187,0) D ^DIR K DIR "RTN","PRCHJS07",188,0) Q $S(Y'=1:0,1:1) "RTN","PRCHJTA") 0^25^B46759830^B48621585 "RTN","PRCHJTA",1,0) PRCHJTA ;OI&T/DDA - MANAGES DATA FROM MESSAGING EVENTS INTO 414.06 ;5/25/12 8:53am "RTN","PRCHJTA",2,0) ;;5.1;IFCAP;**167,174**;Oct 20,2000;Build 23 "RTN","PRCHJTA",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCHJTA",4,0) ; "RTN","PRCHJTA",5,0) Q "RTN","PRCHJTA",6,0) ;FOR ENTRY POINT "LOG": "RTN","PRCHJTA",7,0) ;API CALLED AS: LOG^PRCHJTA(var1,var2,var3,.array,.return) "RTN","PRCHJTA",8,0) ; Globals are locked within the API "RTN","PRCHJTA",9,0) ;INPUT "RTN","PRCHJTA",10,0) ; var1 PRCHJID - FREE TEXT - EXTERNAL OF '410;.01' AS SHARED WITH ECMS (required for all) "RTN","PRCHJTA",11,0) ; var2 ECMSID - FREE TEXT - AS SENT FROM ECMS [ActionID] (for inbound types if available) "RTN","PRCHJTA",12,0) ; var3 TYPE - FREE TEXT or CODE of MESSAGE TYPE as defined in 'EVENT TYPE' '414.06;10;.02' (required for all) "RTN","PRCHJTA",13,0) ; array EVENT - ARRAY THAT HOLDS THE EVENT SPECIFIC DATA TO BE STORED IN THE FILE (required, elements vary) "RTN","PRCHJTA",14,0) ; EVENT("MSGID")= FREE TEXT STRING OF HLO MESSAGE ID (if available) "RTN","PRCHJTA",15,0) ; EVENT("IEN410")= FM INTERNAL OF THE 410 RECORD (required for outbound, non-acknowledgement, types only) "RTN","PRCHJTA",16,0) ; EVENT("IFCAPU")= FM INTERNAL/DUZ OF IFCAP USER(required for outbound, non-acknowledgement, types only) "RTN","PRCHJTA",17,0) ; EVENT("STN")= FREE TEXT STRING OF THE STATION AS PASSED FROM ECMS (always store if available) "RTN","PRCHJTA",18,0) ; EVENT("SUBSTN")= FREE TEXT STRING OF THE SUB-STATION AS PASSED FROM ECMS (always store if available) "RTN","PRCHJTA",19,0) ; EVENT("ECMSU")= FREE TEXT OF ECMS USER AS PASSED FROM ECMS (always store if available) "RTN","PRCHJTA",20,0) ; EVENT("ECMSPH")= FREE TEXT OF THE ECMS CONTACT PHONE (always store if available) "RTN","PRCHJTA",21,0) ; EVENT("ECMSEM")= FREE TEXT OF THE ECMS CONTACT EMAIL (always store if available) "RTN","PRCHJTA",22,0) ; EVENT("ECMSDT")= DATE OF THE USER ACTION, RETURN/CANCEL, ON ECMS (always store if available) "RTN","PRCHJTA",23,0) ; EVENT("ECMSRN")= FREE TEXT OF THE RETURN/CANCEL REASON FROM ECMS (always store if available) "RTN","PRCHJTA",24,0) ; EVENT("ECMSCM")= FREE TEXT OF COMMENTS FROM ECMS (always store if available) "RTN","PRCHJTA",25,0) ; EVENT("ERROR",n)= FREE TEXT, INDIVIDUAL ERROR LINE TO BE STORED. n= non-zero, non-repeating integer "RTN","PRCHJTA",26,0) ;OUTPUT "RTN","PRCHJTA",27,0) ; .return ERR - 1^"error text"= ERROR STORING DATA, 0= NO ERROR "RTN","PRCHJTA",28,0) ; "RTN","PRCHJTA",29,0) LOG(PRCHJID,ECMSID,TYPE,EVENT,ERR) ; params defined above "RTN","PRCHJTA",30,0) N LINE,PRCERR,PRCIEN,PRCTIEN,PRCVIEN,PRCVSTN,PRCVSUB,TYPETXT "RTN","PRCHJTA",31,0) S ERR=0 "RTN","PRCHJTA",32,0) D TYPE "RTN","PRCHJTA",33,0) S:(+TYPE<1)!(+TYPE>11)!(+TYPE=5) ERR="1^Unknown TYPE "_TYPE "RTN","PRCHJTA",34,0) I +$G(PRCHJID)=0 S ERR="2^Missing Transaction Number" Q "RTN","PRCHJTA",35,0) I '((TYPE=1)!(TYPE=4)) G OTHER "RTN","PRCHJTA",36,0) ; TYPE 1 or TYPE 4 CREATE A NEW ENTRY IN 414.06 unless a record already exists for this Transaction ID "RTN","PRCHJTA",37,0) S PRCTIEN=0 "RTN","PRCHJTA",38,0) S PRCTIEN=$O(^PRCV(414.06,"B",PRCHJID,PRCTIEN)) "RTN","PRCHJTA",39,0) G:+PRCTIEN>0 OTHER "RTN","PRCHJTA",40,0) ;lock the file to get IEN for new TRANSACTION record "RTN","PRCHJTA",41,0) S PRCVIEN=0 "RTN","PRCHJTA",42,0) L +^PRCV(414.06,PRCVIEN):$S($G(DILOCKTM)>60:DILOCKTM,1:60) E S ERR="3^Unable to lock record" K PRCVIEN Q "RTN","PRCHJTA",43,0) ; Create parent record "RTN","PRCHJTA",44,0) I +$G(EVENT("IEN410"))=0 S ERR="4^Missing CONTROL POINT ACTIVITY, IEN" S PRCTIEN=0 G XLOG "RTN","PRCHJTA",45,0) S PRC41406(414.06,"+1,",.01)=PRCHJID "RTN","PRCHJTA",46,0) S PRC41406(414.06,"+1,",.03)=TYPETXT "RTN","PRCHJTA",47,0) S PRC41406(414.06,"+1,",1)=EVENT("IEN410") "RTN","PRCHJTA",48,0) S PRCIEN="" "RTN","PRCHJTA",49,0) D UPDATE^DIE("","PRC41406","PRCIEN","PRCERR") "RTN","PRCHJTA",50,0) L -^PRCV(414.06,PRCVIEN) "RTN","PRCHJTA",51,0) I $D(PRCERR) D "RTN","PRCHJTA",52,0) .S ERR="5^Error creating TRANSACTION record: "_$G(PRCERR("DIERR","1","TEXT",1)) "RTN","PRCHJTA",53,0) G:+ERR XLOG "RTN","PRCHJTA",54,0) S PRCTIEN=PRCIEN(1) "RTN","PRCHJTA",55,0) L +^PRCV(414.06,PRCTIEN):$S($G(DILOCKTM)>60:DILOCKTM,1:60) E S ERR="3.1^Unable to lock record" K PRCTIEN Q "RTN","PRCHJTA",56,0) K PRC41406,PRCIEN,PRCERR "RTN","PRCHJTA",57,0) ; Create EVENT sub-record "RTN","PRCHJTA",58,0) S PRC41406(414.061,"+2,"_PRCTIEN_",",.01)=$$NOW^XLFDT "RTN","PRCHJTA",59,0) S PRC41406(414.061,"+2,"_PRCTIEN_",",.02)=TYPE "RTN","PRCHJTA",60,0) S:$G(EVENT("MSGID"))'="" PRC41406(414.061,"+2,"_PRCTIEN_",",.03)=EVENT("MSGID") "RTN","PRCHJTA",61,0) S PRC41406(414.061,"+2,"_PRCTIEN_",",3)=EVENT("IFCAPU") "RTN","PRCHJTA",62,0) ; STORE STN AND SUBSTN FOR OUTBOUND EVENTS "RTN","PRCHJTA",63,0) I (TYPE=1)!(TYPE=4) D GETSTN(EVENT("IEN410")) D "RTN","PRCHJTA",64,0) . S:PRCVSTN'="" PRC41406(414.061,"+2,"_PRCTIEN_",",1)=PRCVSTN "RTN","PRCHJTA",65,0) . S:PRCVSUB'="" PRC41406(414.061,"+2,"_PRCTIEN_",",2)=PRCVSUB "RTN","PRCHJTA",66,0) .Q "RTN","PRCHJTA",67,0) D UPDATE^DIE("","PRC41406","PRCIEN","PRCERR") "RTN","PRCHJTA",68,0) I $D(PRCERR) D "RTN","PRCHJTA",69,0) .S ERR="6^Error creating TRANSACTION record: "_$G(PRCERR("DIERR","1","TEXT",1)) "RTN","PRCHJTA",70,0) ; Store Transaction ERROR text if any "RTN","PRCHJTA",71,0) K PRCERR,PRC41406 "RTN","PRCHJTA",72,0) S PRCIEN(1)=PRCTIEN "RTN","PRCHJTA",73,0) S PRCVIEN="" "RTN","PRCHJTA",74,0) S LINE=0 "RTN","PRCHJTA",75,0) I $D(EVENT("ERROR")) F S LINE=$O(EVENT("ERROR",LINE)) Q:LINE="" D Q:+ERR "RTN","PRCHJTA",76,0) .K PRC41406 "RTN","PRCHJTA",77,0) .S PRCVIEN(3)=LINE "RTN","PRCHJTA",78,0) .S:$G(EVENT("ERROR",LINE))'="" PRC41406(414.0613,"+3,"_PRCIEN(2)_","_PRCIEN(1)_",",.01)=EVENT("ERROR",LINE) "RTN","PRCHJTA",79,0) .D UPDATE^DIE("","PRC41406","PRCVIEN","PRCERR") "RTN","PRCHJTA",80,0) .I $D(PRCERR) D "RTN","PRCHJTA",81,0) ..S ERR="10.1^Error updating TRANSACTION word-processing field ERROR: "_$G(PRCERR("DIERR","1","TEXT",1)) "RTN","PRCHJTA",82,0) ..Q "RTN","PRCHJTA",83,0) .K PRC41406 "RTN","PRCHJTA",84,0) .Q "RTN","PRCHJTA",85,0) G XLOG "RTN","PRCHJTA",86,0) OTHER ; LOG ALL OTHER TYPES "RTN","PRCHJTA",87,0) ; Find the TRANSACTION record "RTN","PRCHJTA",88,0) S PRCTIEN=0 "RTN","PRCHJTA",89,0) S PRCTIEN=$O(^PRCV(414.06,"B",PRCHJID,PRCTIEN)) "RTN","PRCHJTA",90,0) I PRCTIEN="" S ERR="7^"_PRCHJID_" does not exist in the Transaction file." K PRCTIEN Q "RTN","PRCHJTA",91,0) L +^PRCV(414.06,PRCTIEN):$S($G(DILOCKTM)>60:DILOCKTM,1:60) E S ERR="8^Unable to lock record" K PRCTIEN Q "RTN","PRCHJTA",92,0) ; Store header data "RTN","PRCHJTA",93,0) S:$G(ECMSID)'="" PRC41406(414.06,PRCTIEN_",",.02)=ECMSID "RTN","PRCHJTA",94,0) S PRC41406(414.06,PRCTIEN_",",.03)=TYPETXT "RTN","PRCHJTA",95,0) S:+$G(EVENT("IEN410")) PRC41406(414.06,PRCTIEN_",",1)=EVENT("IEN410") "RTN","PRCHJTA",96,0) D FILE^DIE("","PRC41406","PRCERR") "RTN","PRCHJTA",97,0) ; Store Transaction data "RTN","PRCHJTA",98,0) K PRC41406 "RTN","PRCHJTA",99,0) S PRC41406(414.061,"+2,"_PRCTIEN_",",.01)=$$NOW^XLFDT "RTN","PRCHJTA",100,0) S PRC41406(414.061,"+2,"_PRCTIEN_",",.02)=TYPE "RTN","PRCHJTA",101,0) S:$G(EVENT("MSGID"))'="" PRC41406(414.061,"+2,"_PRCTIEN_",",.03)=EVENT("MSGID") "RTN","PRCHJTA",102,0) S:$G(EVENT("STN"))'="" PRC41406(414.061,"+2,"_PRCTIEN_",",1)=EVENT("STN") "RTN","PRCHJTA",103,0) S:$G(EVENT("SUBSTN"))'="" PRC41406(414.061,"+2,"_PRCTIEN_",",2)=EVENT("SUBSTN") "RTN","PRCHJTA",104,0) ; CHECK IF OUTBOUND EVENTS THEN SET STN AND SUBSTN FOR STORAGE "RTN","PRCHJTA",105,0) I (TYPE=1)!(TYPE=4) D GETSTN(EVENT("IEN410")) D "RTN","PRCHJTA",106,0) . S:PRCVSTN'="" PRC41406(414.061,"+2,"_PRCTIEN_",",1)=PRCVSTN "RTN","PRCHJTA",107,0) . S:PRCVSUB'="" PRC41406(414.061,"+2,"_PRCTIEN_",",2)=PRCVSUB "RTN","PRCHJTA",108,0) .Q "RTN","PRCHJTA",109,0) S:$G(EVENT("IFCAPU"))'="" PRC41406(414.061,"+2,"_PRCTIEN_",",3)=EVENT("IFCAPU") "RTN","PRCHJTA",110,0) S:$G(EVENT("ECMSPH"))'="" PRC41406(414.061,"+2,"_PRCTIEN_",",5)=EVENT("ECMSPH") "RTN","PRCHJTA",111,0) S:$G(EVENT("ECMSEM"))'="" PRC41406(414.061,"+2,"_PRCTIEN_",",6)=EVENT("ECMSEM") "RTN","PRCHJTA",112,0) S:$G(EVENT("ECMSDT"))'="" PRC41406(414.061,"+2,"_PRCTIEN_",",7)=EVENT("ECMSDT") "RTN","PRCHJTA",113,0) S:$G(EVENT("ECMSRN"))'="" PRC41406(414.061,"+2,"_PRCTIEN_",",10)=EVENT("ECMSRN") "RTN","PRCHJTA",114,0) S PRC41406(414.061,"+2,"_PRCTIEN_",",11)=$S($G(EVENT("ECMSCM"))'="":EVENT("ECMSCM")_" ",1:"")_$S($G(EVENT("ECMSU"))'="":"{"_EVENT("ECMSU")_"}",1:"") "RTN","PRCHJTA",115,0) S PRC41406(414.061,"+2,"_PRCTIEN_",",11)=$E(PRC41406(414.061,"+2,"_PRCTIEN_",",11),1,100) "RTN","PRCHJTA",116,0) D UPDATE^DIE("","PRC41406","PRCVIEN","PRCERR") "RTN","PRCHJTA",117,0) I $D(PRCERR) D "RTN","PRCHJTA",118,0) .S ERR="9^Error updating TRANSACTION record: "_$G(PRCERR("DIERR","1","TEXT",1)) "RTN","PRCHJTA",119,0) K PRC41406 "RTN","PRCHJTA",120,0) G:+ERR XLOG "RTN","PRCHJTA",121,0) ; Store Transaction ERROR text if any "RTN","PRCHJTA",122,0) K PRCERR "RTN","PRCHJTA",123,0) S PRCVIEN(1)=PRCTIEN "RTN","PRCHJTA",124,0) S PRCVIEN="" "RTN","PRCHJTA",125,0) S LINE=0 "RTN","PRCHJTA",126,0) I $D(EVENT("ERROR")) F S LINE=$O(EVENT("ERROR",LINE)) Q:LINE="" D Q:+ERR "RTN","PRCHJTA",127,0) .K PRC41406 "RTN","PRCHJTA",128,0) .S PRCVIEN(3)=LINE "RTN","PRCHJTA",129,0) .S:$G(EVENT("ERROR",LINE))'="" PRC41406(414.0613,"+3,"_PRCVIEN(2)_","_PRCVIEN(1)_",",.01)=EVENT("ERROR",LINE) "RTN","PRCHJTA",130,0) .D UPDATE^DIE("","PRC41406","PRCVIEN","PRCERR") "RTN","PRCHJTA",131,0) .I $D(PRCERR) D "RTN","PRCHJTA",132,0) ..S ERR="10^Error updating TRANSACTION word-processing field ERROR: "_$G(PRCERR("DIERR","1","TEXT",1)) "RTN","PRCHJTA",133,0) ..Q "RTN","PRCHJTA",134,0) .K PRC41406 "RTN","PRCHJTA",135,0) .Q "RTN","PRCHJTA",136,0) XLOG ;EXIT "RTN","PRCHJTA",137,0) L -^PRCV(414.06,PRCTIEN) "RTN","PRCHJTA",138,0) ; A Hang command is needed because multiple calls to this API in succession may lead to an attempt to overwrite. "RTN","PRCHJTA",139,0) H 1 "RTN","PRCHJTA",140,0) ; No kills needed, variables were Newed. "RTN","PRCHJTA",141,0) Q "RTN","PRCHJTA",142,0) GETSTN(IEN) ;API TO GRAB STATION AND SUBSTATION DATA OUT OF 410 FOR STORAGE IN 414.06 OUTBOUND EVENTS. "RTN","PRCHJTA",143,0) ; Passes in IEN of 410 "RTN","PRCHJTA",144,0) ; Output is PRCVSTN and PRCVSUB "RTN","PRCHJTA",145,0) S PRCVSTN=$P($G(^PRCS(410,IEN,0)),"^",5) "RTN","PRCHJTA",146,0) S PRCVSUB=$P($G(^PRCS(410,IEN,0)),"^",10) "RTN","PRCHJTA",147,0) I PRCVSUB'="" S PRCVSUB=$P(^PRC(411,PRCVSUB,0),"^") "RTN","PRCHJTA",148,0) Q "RTN","PRCHJTA",149,0) TYPE ; set TYPE and TYPETXT "RTN","PRCHJTA",150,0) I $G(TYPE)'="" D "RTN","PRCHJTA",151,0) . S:(TYPE="2237 SENT")!(TYPE=1) TYPE=1,TYPETXT="2237 SENT" "RTN","PRCHJTA",152,0) . S:(TYPE="2237 ACKNOWLEDGED")!(TYPE=2) TYPE=2,TYPETXT="2237 ACKNOWLEDGED" "RTN","PRCHJTA",153,0) . S:(TYPE="2237 APPLICATION ERROR")!(TYPE=3) TYPE=3,TYPETXT="2237 APPLICATION ERROR" "RTN","PRCHJTA",154,0) . S:(TYPE="2237 RESENT")!(TYPE=4) TYPE=4,TYPETXT="2237 RESENT" "RTN","PRCHJTA",155,0) . S:(TYPE="RETURN TO ACCOUNTABLE OFFICER")!(TYPE=6) TYPE=6,TYPETXT="RETURN TO ACCOUNTABLE OFFICER" "RTN","PRCHJTA",156,0) . S:(TYPE="RETURN TO AO ACK")!(TYPE=7) TYPE=7,TYPETXT="RETURN TO AO ACK" "RTN","PRCHJTA",157,0) . S:(TYPE="RETURN TO CONTROL POINT")!(TYPE=8) TYPE=8,TYPETXT="RETURN TO CONTROL POINT" "RTN","PRCHJTA",158,0) . S:(TYPE="RETURN TO CP ACK")!(TYPE=9) TYPE=9,TYPETXT="RETURN TO CP ACK" "RTN","PRCHJTA",159,0) . S:(TYPE="2237 CANCELED")!(TYPE=10) TYPE=10,TYPETXT="2237 CANCELED" "RTN","PRCHJTA",160,0) . S:(TYPE="2237 CANCEL ACK")!(TYPE=11) TYPE=11,TYPETXT="2237 CANCEL ACK" "RTN","PRCHJTA",161,0) . Q "RTN","PRCHJTA",162,0) Q "RTN","PRCHJTA",163,0) CONTACT(NAME) ; Call to transform the data for use within the "ACONTACT" and "AUNQEC" xrefs for 414.06;10;6 ECMS EMAIL field "RTN","PRCHJTA",164,0) N PRCC,PRCL,PRCF,PRCR,PRCN "RTN","PRCHJTA",165,0) S PRCC=$P(NAME,"@",1),PRCL=$L(PRCC,".") "RTN","PRCHJTA",166,0) S PRCF=$P(PRCC,".",PRCL) "RTN","PRCHJTA",167,0) S PRCR="" "RTN","PRCHJTA",168,0) F PRCN=1:1:(PRCL-1) S PRCR=PRCR_" "_$P(PRCC,".",PRCN) "RTN","PRCHJTA",169,0) S PRCC=PRCF_PRCR "RTN","PRCHJTA",170,0) S PRCC=$$UP^XLFSTR(PRCC) "RTN","PRCHJTA",171,0) Q PRCC "RTN","PRCHJUTL") 0^11^B45318911^B5808246 "RTN","PRCHJUTL",1,0) PRCHJUTL ;OI&T/LKG,KCL-UTILITY FUNCTIONS IFCAP/ECMS INTERFACE ;5/10/13 15:46 "RTN","PRCHJUTL",2,0) ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23 "RTN","PRCHJUTL",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCHJUTL",4,0) ; "RTN","PRCHJUTL",5,0) ; "RTN","PRCHJUTL",6,0) ECMS2237(PRCHJDA) ;Checks 2237 to see if processed in eCMS - Returns 1 if "RTN","PRCHJUTL",7,0) ;processed in eCMS and 0 if not. Check on basis of whether the ECMS "RTN","PRCHJUTL",8,0) ;ACTIONUID field is populated. "RTN","PRCHJUTL",9,0) N X S X=($P($G(^PRCS(410,PRCHJDA,1)),U,8)'="") "RTN","PRCHJUTL",10,0) Q X "RTN","PRCHJUTL",11,0) ; "RTN","PRCHJUTL",12,0) UPD443(PRC443R,PRCERR) ;Update file #443 record "RTN","PRCHJUTL",13,0) ;This function is used to update the following fields in "RTN","PRCHJUTL",14,0) ;a REQUEST WORKSHEET (#443) record: "RTN","PRCHJUTL",15,0) ; "RTN","PRCHJUTL",16,0) ; Field Name Field # "RTN","PRCHJUTL",17,0) ; ------------------- ------- "RTN","PRCHJUTL",18,0) ; CURRENT STATUS 1.5 "RTN","PRCHJUTL",19,0) ; ACCOUNTABLE OFFICER 2 "RTN","PRCHJUTL",20,0) ; VALIDATION CODE 3 "RTN","PRCHJUTL",21,0) ; ESIG DATE/TIME 4 "RTN","PRCHJUTL",22,0) ; "RTN","PRCHJUTL",23,0) ; Input: "RTN","PRCHJUTL",24,0) ; PRC443R - (required) IEN of record in REQUEST WORKSHEET (#443) file "RTN","PRCHJUTL",25,0) ; "RTN","PRCHJUTL",26,0) ; Output: "RTN","PRCHJUTL",27,0) ; Function Value - returns 1 on success, 0 on failure "RTN","PRCHJUTL",28,0) ; PRCERR - (optional) on failure, an error message is returned, "RTN","PRCHJUTL",29,0) ; pass by ref "RTN","PRCHJUTL",30,0) ; "RTN","PRCHJUTL",31,0) N PRCRSLT ;function result "RTN","PRCHJUTL",32,0) N PRCIENS ;iens string for FM data array "RTN","PRCHJUTL",33,0) N PRCFDA ;FM data array "RTN","PRCHJUTL",34,0) ; "RTN","PRCHJUTL",35,0) S PRC443R=+$G(PRC443R) "RTN","PRCHJUTL",36,0) S PRCRSLT=0 "RTN","PRCHJUTL",37,0) S PRCERR="Invalid input parameter" "RTN","PRCHJUTL",38,0) ; "RTN","PRCHJUTL",39,0) I PRC443R>0 D "RTN","PRCHJUTL",40,0) . K PRCERR "RTN","PRCHJUTL",41,0) . S PRCIENS=PRC443R_"," "RTN","PRCHJUTL",42,0) . S PRCFDA(443,PRCIENS,1.5)=60 ;Pending Accountable Officer Sig. "RTN","PRCHJUTL",43,0) . S PRCFDA(443,PRCIENS,2)="@" ;delete "RTN","PRCHJUTL",44,0) . S PRCFDA(443,PRCIENS,3)="@" ;delete "RTN","PRCHJUTL",45,0) . S PRCFDA(443,PRCIENS,4)="@" ;delete "RTN","PRCHJUTL",46,0) . D FILE^DIE("K","PRCFDA","PRCERR") "RTN","PRCHJUTL",47,0) . ;quit if filing error "RTN","PRCHJUTL",48,0) . I $D(PRCERR) S PRCERR=$G(PRCERR("DIERR","1","TEXT",1)) Q "RTN","PRCHJUTL",49,0) . ; "RTN","PRCHJUTL",50,0) . ;success "RTN","PRCHJUTL",51,0) . S PRCRSLT=1 "RTN","PRCHJUTL",52,0) ; "RTN","PRCHJUTL",53,0) Q PRCRSLT "RTN","PRCHJUTL",54,0) ; "RTN","PRCHJUTL",55,0) ; "RTN","PRCHJUTL",56,0) UPD410(PRC410R,PRCERR) ;Update file #410 record "RTN","PRCHJUTL",57,0) ;This function is used to update the following fields in "RTN","PRCHJUTL",58,0) ;a CONTROL POINT ACTIVITY (#410) record: "RTN","PRCHJUTL",59,0) ; "RTN","PRCHJUTL",60,0) ; Field Name Field # "RTN","PRCHJUTL",61,0) ; ------------------- ------- "RTN","PRCHJUTL",62,0) ; ACCOUNTABLE OFFICER 39 "RTN","PRCHJUTL",63,0) ; AO SIGNATURE DATE 69 "RTN","PRCHJUTL",64,0) ; "RTN","PRCHJUTL",65,0) ; Input: "RTN","PRCHJUTL",66,0) ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file "RTN","PRCHJUTL",67,0) ; "RTN","PRCHJUTL",68,0) ; Output: "RTN","PRCHJUTL",69,0) ; Function Value - returns 1 on success, 0 on failure "RTN","PRCHJUTL",70,0) ; PRCERR - (optional) on failure, an error message is returned, "RTN","PRCHJUTL",71,0) ; pass by ref "RTN","PRCHJUTL",72,0) ; "RTN","PRCHJUTL",73,0) N PRCRSLT ;function result "RTN","PRCHJUTL",74,0) N PRCIENS ;iens string for FM data array "RTN","PRCHJUTL",75,0) N PRCFDA ;FM data array "RTN","PRCHJUTL",76,0) ; "RTN","PRCHJUTL",77,0) S PRC410R=+$G(PRC410R) "RTN","PRCHJUTL",78,0) S PRCRSLT=0 "RTN","PRCHJUTL",79,0) S PRCERR="Invalid input parameter" "RTN","PRCHJUTL",80,0) ; "RTN","PRCHJUTL",81,0) I PRC410R>0 D "RTN","PRCHJUTL",82,0) . K PRCERR "RTN","PRCHJUTL",83,0) . S PRCIENS=PRC410R_"," "RTN","PRCHJUTL",84,0) . S PRCFDA(410,PRCIENS,39)="@" ;delete "RTN","PRCHJUTL",85,0) . S PRCFDA(410,PRCIENS,69)="@" ;delete "RTN","PRCHJUTL",86,0) . D FILE^DIE("K","PRCFDA","PRCERR") "RTN","PRCHJUTL",87,0) . ;quit if filing error "RTN","PRCHJUTL",88,0) . I $D(PRCERR) S PRCERR=$G(PRCERR("DIERR","1","TEXT",1)) Q "RTN","PRCHJUTL",89,0) . ; "RTN","PRCHJUTL",90,0) . ;success "RTN","PRCHJUTL",91,0) . S PRCRSLT=1 "RTN","PRCHJUTL",92,0) ; "RTN","PRCHJUTL",93,0) Q PRCRSLT "RTN","PRCHJUTL",94,0) ; "RTN","PRCHJUTL",95,0) ; "RTN","PRCHJUTL",96,0) ITDES(PRC410R,PRCITIEN) ;Check single line item for a description "RTN","PRCHJUTL",97,0) ;This function checks a single line item on a 2237 to make sure it has a description. "RTN","PRCHJUTL",98,0) ; "RTN","PRCHJUTL",99,0) ; Input: "RTN","PRCHJUTL",100,0) ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file "RTN","PRCHJUTL",101,0) ; PRCITIEN - (required) IEN of record in ITEM (#410.02) sub-file "RTN","PRCHJUTL",102,0) ; "RTN","PRCHJUTL",103,0) ; Output: "RTN","PRCHJUTL",104,0) ; Function value - 1 on success, 0 on failure (no line item description) "RTN","PRCHJUTL",105,0) ; "RTN","PRCHJUTL",106,0) N PRCIENS ;iens string for GET1^DIQ "RTN","PRCHJUTL",107,0) N PRCDESC ;word processing field target array "RTN","PRCHJUTL",108,0) N PRCRSLT ;function result "RTN","PRCHJUTL",109,0) ; "RTN","PRCHJUTL",110,0) ; "RTN","PRCHJUTL",111,0) S PRC410R=+$G(PRC410R) "RTN","PRCHJUTL",112,0) S PRCITIEN=+$G(PRCITIEN) "RTN","PRCHJUTL",113,0) S PRCRSLT=1 "RTN","PRCHJUTL",114,0) ; "RTN","PRCHJUTL",115,0) ;failure if 2237 record not found in #410 file "RTN","PRCHJUTL",116,0) I (PRC410R'>0)!('$D(^PRCS(410,PRC410R))) S PRCRSLT=0 "RTN","PRCHJUTL",117,0) ; "RTN","PRCHJUTL",118,0) ;failure if record not found in ITEM (#410.02) sub-file "RTN","PRCHJUTL",119,0) I (PRCITIEN'>0)!('$D(^PRCS(410,PRC410R,"IT",PRCITIEN,0))) S PRCRSLT=0 "RTN","PRCHJUTL",120,0) ; "RTN","PRCHJUTL",121,0) I PRCRSLT D ;drop out of DO block on failure "RTN","PRCHJUTL",122,0) . ; "RTN","PRCHJUTL",123,0) . ;attempt to retrieve the contents of word processing Item "RTN","PRCHJUTL",124,0) . ;Description field and store text in the target array "RTN","PRCHJUTL",125,0) . K PRCDESC "RTN","PRCHJUTL",126,0) . S PRCIENS=PRCITIEN_","_PRC410R_"," "RTN","PRCHJUTL",127,0) . S PRCDESC=$$GET1^DIQ(410.02,PRCIENS,1,"Z","PRCDESC") "RTN","PRCHJUTL",128,0) . ;if no data exists, quit and function result=failure "RTN","PRCHJUTL",129,0) . I PRCDESC="" S PRCRSLT=0 Q "RTN","PRCHJUTL",130,0) . ; "RTN","PRCHJUTL",131,0) . ;strip WP nodes of spaces and tabs; if node still contains data then ok "RTN","PRCHJUTL",132,0) . N PRCWP,PRCNODE,PRCOK "RTN","PRCHJUTL",133,0) . S (PRCWP,PRCOK)=0 "RTN","PRCHJUTL",134,0) . F S PRCWP=$O(PRCDESC(PRCWP)) Q:'PRCWP!(PRCOK) D "RTN","PRCHJUTL",135,0) . . S PRCNODE=$G(PRCDESC(PRCWP,0)) "RTN","PRCHJUTL",136,0) . . S PRCNODE=$TR(PRCNODE," ","") ;strip spaces "RTN","PRCHJUTL",137,0) . . S PRCNODE=$TR(PRCNODE,$C(9),"") ;strip tabs "RTN","PRCHJUTL",138,0) . . ;ok, data in the WP node "RTN","PRCHJUTL",139,0) . . I $L(PRCNODE)>0 S PRCOK=1 "RTN","PRCHJUTL",140,0) . I 'PRCOK S PRCRSLT=0 "RTN","PRCHJUTL",141,0) ; "RTN","PRCHJUTL",142,0) Q PRCRSLT "RTN","PRCHJUTL",143,0) ; "RTN","PRCHJUTL",144,0) ; "RTN","PRCHJUTL",145,0) ITDESALL(PRC410R,PRCERR) ;Check all line items for description "RTN","PRCHJUTL",146,0) ;This function checks all line items on a document to make sure they have a description. "RTN","PRCHJUTL",147,0) ; "RTN","PRCHJUTL",148,0) ; Input: "RTN","PRCHJUTL",149,0) ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file "RTN","PRCHJUTL",150,0) ; "RTN","PRCHJUTL",151,0) ; Output: "RTN","PRCHJUTL",152,0) ; Function value - 1 on success, 0 on failure (one or more line items don't have description) "RTN","PRCHJUTL",153,0) ; PRCERR - (optional) on failure, an error message array is returned, pass by ref "RTN","PRCHJUTL",154,0) ; Array format: "RTN","PRCHJUTL",155,0) ; PRCERR(1)="Line Item #3 Description is missing." "RTN","PRCHJUTL",156,0) ; PRCERR(2)="Line Item #5 Description is missing." "RTN","PRCHJUTL",157,0) ; PRCERR(3), etc. "RTN","PRCHJUTL",158,0) ; "RTN","PRCHJUTL",159,0) N PRCLINE ;line items "RTN","PRCHJUTL",160,0) N PRCITIEN ;line item IEN "RTN","PRCHJUTL",161,0) N PRCLNUM ;Line Item Number "RTN","PRCHJUTL",162,0) N PRCIDX ;error array subscript "RTN","PRCHJUTL",163,0) N PRCRSLT ;function result "RTN","PRCHJUTL",164,0) ; "RTN","PRCHJUTL",165,0) S PRC410R=+$G(PRC410R) "RTN","PRCHJUTL",166,0) S PRCRSLT=1 "RTN","PRCHJUTL",167,0) ; "RTN","PRCHJUTL",168,0) ;quit if 2237 record not found in #410 file "RTN","PRCHJUTL",169,0) I (PRC410R'>0)!('$D(^PRCS(410,PRC410R))) D Q PRCRSLT "RTN","PRCHJUTL",170,0) . S PRCRSLT=0 "RTN","PRCHJUTL",171,0) . S PRCERR(1)="Control Point Activity record not found." "RTN","PRCHJUTL",172,0) ; "RTN","PRCHJUTL",173,0) S (PRCLINE,PRCITIEN,PRCIDX)=0 "RTN","PRCHJUTL",174,0) ;loop thru "B" index of ITEM multiple "RTN","PRCHJUTL",175,0) F S PRCLINE=+$O(^PRCS(410,PRC410R,"IT","B",PRCLINE)) Q:'PRCLINE D "RTN","PRCHJUTL",176,0) . ; "RTN","PRCHJUTL",177,0) . ;get IEN of record in ITEM (#410.02) sub-file "RTN","PRCHJUTL",178,0) . S PRCITIEN=0 "RTN","PRCHJUTL",179,0) . S PRCITIEN=+$O(^PRCS(410,PRC410R,"IT","B",$G(PRCLINE),PRCITIEN)) "RTN","PRCHJUTL",180,0) . I 'PRCITIEN D Q "RTN","PRCHJUTL",181,0) . . S PRCRSLT=0 "RTN","PRCHJUTL",182,0) . . S PRCIDX=PRCIDX+1 "RTN","PRCHJUTL",183,0) . . S PRCERR(PRCIDX)="Item not found in Control Point Activity record." "RTN","PRCHJUTL",184,0) . ; "RTN","PRCHJUTL",185,0) . ;does line item have a description? "RTN","PRCHJUTL",186,0) . I '$$ITDES(PRC410R,$G(PRCITIEN)) D "RTN","PRCHJUTL",187,0) . . S PRCRSLT=0 "RTN","PRCHJUTL",188,0) . . S PRCLNUM="" "RTN","PRCHJUTL",189,0) . . S PRCLNUM=$P($G(^PRCS(410,PRC410R,"IT",$G(PRCITIEN),0)),U,1) "RTN","PRCHJUTL",190,0) . . S PRCIDX=PRCIDX+1 "RTN","PRCHJUTL",191,0) . . S PRCERR(PRCIDX)="Line Item #"_$G(PRCLNUM)_" Description is missing." "RTN","PRCHJUTL",192,0) ; "RTN","PRCHJUTL",193,0) Q PRCRSLT "RTN","PRCHJUTL",194,0) ; "RTN","PRCHJUTL",195,0) ; "RTN","PRCHJUTL",196,0) REQCHECK(PRC410R,PRCWARN,PRCQUIET) ;2237 required field checks "RTN","PRCHJUTL",197,0) ;This function is used to check a document and determine if the following fields "RTN","PRCHJUTL",198,0) ;are populated: "RTN","PRCHJUTL",199,0) ; - Requesting Service "RTN","PRCHJUTL",200,0) ; - Description field for all line items "RTN","PRCHJUTL",201,0) ; "RTN","PRCHJUTL",202,0) ; Input: "RTN","PRCHJUTL",203,0) ; PRC410R - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file "RTN","PRCHJUTL",204,0) ; PRCQUIET - (optional) 0=silent call, 1=output warning msgs "RTN","PRCHJUTL",205,0) ; "RTN","PRCHJUTL",206,0) ; Output: "RTN","PRCHJUTL",207,0) ; Function value - 1 on success, 0 on failure-field(s) not populated "RTN","PRCHJUTL",208,0) ; PRCWARN - (optional) on failure, an warning msg array is returned, pass by ref "RTN","PRCHJUTL",209,0) ; Array format: "RTN","PRCHJUTL",210,0) ; PRCWARN(1)="Requesting Service is missing." "RTN","PRCHJUTL",211,0) ; PRCWARN(2)="Line Item #3 Description is missing." "RTN","PRCHJUTL",212,0) ; PRCWARN(3), etc. "RTN","PRCHJUTL",213,0) ; "RTN","PRCHJUTL",214,0) N PRCRSLT ;function result "RTN","PRCHJUTL",215,0) N PRCERR ;error msg array returned by $$ITDESALL^PRCHJUTL "RTN","PRCHJUTL",216,0) N PRCI ;error msg array index "RTN","PRCHJUTL",217,0) N PRCIDX ;warning msg array index "RTN","PRCHJUTL",218,0) ; "RTN","PRCHJUTL",219,0) S PRC410R=+$G(PRC410R) "RTN","PRCHJUTL",220,0) S PRCIDX=0 "RTN","PRCHJUTL",221,0) S PRCRSLT=1 "RTN","PRCHJUTL",222,0) ; "RTN","PRCHJUTL",223,0) ;check for Requesting Service "RTN","PRCHJUTL",224,0) I $$GET1^DIQ(410,PRC410R,6.3)']"" D "RTN","PRCHJUTL",225,0) . S PRCRSLT=0 "RTN","PRCHJUTL",226,0) . S PRCIDX=PRCIDX+1 "RTN","PRCHJUTL",227,0) . S PRCWARN(PRCIDX)="Requesting Service is missing." "RTN","PRCHJUTL",228,0) ; "RTN","PRCHJUTL",229,0) ;check all line items for missing description "RTN","PRCHJUTL",230,0) I '$$ITDESALL^PRCHJUTL(PRC410R,.PRCERR) D "RTN","PRCHJUTL",231,0) . S PRCRSLT=0 "RTN","PRCHJUTL",232,0) . S PRCI=0 "RTN","PRCHJUTL",233,0) . F S PRCI=$O(PRCERR(PRCI)) Q:'PRCI D "RTN","PRCHJUTL",234,0) . . S PRCIDX=PRCIDX+1 "RTN","PRCHJUTL",235,0) . . S PRCWARN(PRCIDX)=$G(PRCERR(PRCI)) "RTN","PRCHJUTL",236,0) ; "RTN","PRCHJUTL",237,0) ;on failure and not silent, output warning "RTN","PRCHJUTL",238,0) I 'PRCRSLT,$G(PRCQUIET) D "RTN","PRCHJUTL",239,0) . W !!,"WARNING - Transaction "_$$GET1^DIQ(410,PRC410R,.01)_" is missing required data!",*7 "RTN","PRCHJUTL",240,0) . S PRCIDX=0 "RTN","PRCHJUTL",241,0) . F S PRCIDX=$O(PRCWARN(PRCIDX)) Q:'PRCIDX D "RTN","PRCHJUTL",242,0) . . W !?2,">>> "_$G(PRCWARN(PRCIDX)) "RTN","PRCHJUTL",243,0) . W !,"The request needs to be edited prior to approval.",! "RTN","PRCHJUTL",244,0) ; "RTN","PRCHJUTL",245,0) Q PRCRSLT "RTN","PRCSAPP1") 0^21^B16255463^B12057361 "RTN","PRCSAPP1",1,0) PRCSAPP1 ;WISC/KMB-CHECK 2237 BEFORE APPROVAL ;12/17/93 "RTN","PRCSAPP1",2,0) ;;5.1;IFCAP;**148,174**;Oct 20, 2000;Build 23 "RTN","PRCSAPP1",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCSAPP1",4,0) CHEC ; "RTN","PRCSAPP1",5,0) I +$P(^PRCS(410,DA,0),"-")'=PRC("SITE") S SPENDCP=1 G EVAL "RTN","PRCSAPP1",6,0) I +$P(^PRCS(410,DA,0),"-",4)'=PRC("CP") S SPENDCP=2 G EVAL "RTN","PRCSAPP1",7,0) S D0=DA,DIC="^PRCS(410," L +^PRCS(410,DA):5 W @IOF D ^PRCST5 H 1 "RTN","PRCSAPP1",8,0) L -^PRCS(410,DA) "RTN","PRCSAPP1",9,0) I $D(^PRCS(410,DA,7)),$P(^(7),U,6)'="" S SPENDCP=3 D EVAL Q "RTN","PRCSAPP1",10,0) S:'$D(^PRCS(410,DA,11)) ^(11)="" I '$P(^(11),U,3) S SPENDCP=4 D EVAL Q "RTN","PRCSAPP1",11,0) ; PRC*5.1*148 "RTN","PRCSAPP1",12,0) I $P(^PRCS(410,DA,0),"^",11)="" D ERS410^PRC0G(DA) "RTN","PRCSAPP1",13,0) S PRCSN=^PRCS(410,DA,0),PRCHQ=$P(PRCSN,"^",4),PRC("FY")=$P(PRCSN,"-",2),PRC("QTR")=$P(PRCSN,"-",3) "RTN","PRCSAPP1",14,0) T1 ; this is the 'jump' entry point for the CP official "RTN","PRCSAPP1",15,0) ; to approve a request just after s/he creates it "RTN","PRCSAPP1",16,0) I '$D(ALL) N JUMP,ALL S JUMP=1,ALL=0 "RTN","PRCSAPP1",17,0) N ESTSHP,CST S ESTSHP=$P($G(^PRCS(410,DA,9)),"^",4),CST=$P($G(^PRCS(410,DA,4)),"^",8) "RTN","PRCSAPP1",18,0) S PRC("RBDT")=$P(^PRCS(410,DA,0),"^",11),PRCST1=$$DATE^PRC0C(PRC("RBDT"),"I") "RTN","PRCSAPP1",19,0) S PRCST1=$S($D(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,$E($P(PRCST1,"^"),3,4),0)):$P(^(0),U,$P(PRCST1,"^",2)+1),1:0),PRCST=$S($D(^PRCS(410,DA,4)):$P(^(4),U,8),1:0) "RTN","PRCSAPP1",20,0) S PRCST=ESTSHP+CST I PRCST<0,$P(^PRCS(410,DA,0),"^",4)'=1 S SPENDCP=9 D EVAL Q "RTN","PRCSAPP1",21,0) ;Check for different costs "RTN","PRCSAPP1",22,0) N PRCCOMCT,PRCBOCCT "RTN","PRCSAPP1",23,0) S PRCCOMCT=$S($D(^PRCS(410,DA,4)):$P(^(4),"^"),1:0) "RTN","PRCSAPP1",24,0) S PRCBOCCT=$S($D(^PRCS(410,DA,3)):$P(^(3),"^",7),1:0) "RTN","PRCSAPP1",25,0) I $P(^PRCS(410,DA,0),"^",2)="O",$P(^(0),"^",4)=1,$J(PRCCOMCT,0,2)'=$J(PRCBOCCT,0,2) S SPENDCP=10 D EVAL Q "RTN","PRCSAPP1",26,0) ; "RTN","PRCSAPP1",27,0) W !,"Current Control Point balance: $",$J(PRCST1,0,2),!,"Estimated cost of this request: $",$J(PRCST,0,2) H 1 "RTN","PRCSAPP1",28,0) T2 ; "RTN","PRCSAPP1",29,0) ;N ALLTOT,MINUS S ALLTOT=0 F Z=2:1:PRC("QTR")+1 S ALLTOT=ALLTOT+$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),4,PRC("FY"),0)),"^",Z) "RTN","PRCSAPP1",30,0) ;S MINUS="" I ALLTOT<0 S ALLTOT=-ALLTOT,MINUS="-" "RTN","PRCSAPP1",31,0) ;W !,"Total uncommitted balance from current and prior quarters: ",MINUS,"$",$J(ALLTOT,0,2),! "RTN","PRCSAPP1",32,0) Q:$D(REPORT2) "RTN","PRCSAPP1",33,0) ;S STRING=PRC("SITE")_"^"_PRC("CP")_"^"_PRC("FY")_"^"_PRC("QTR") "RTN","PRCSAPP1",34,0) ;S TEST=$$YEAR^PRC0C(PRC("FY"))'<$$DATE^PRC0C("N","E") "RTN","PRCSAPP1",35,0) ;I TEST S TEST=$$OVCOM^PRCS0A(STRING,PRCST,2) I TEST'=0 S SPENDCP=5 D EVAL Q "RTN","PRCSAPP1",36,0) I $$OVCOM^PRCS0A(PRC("SITE")_"^"_PRC("CP")_"^"_$P($$DATE^PRC0C(PRC("RBDT"),"I"),"^",1,2),PRCST,2)'=0 S SPENDCP=5 D EVAL Q "RTN","PRCSAPP1",37,0) I $P(PRCSN,"^",4)="" S SPENDCP=6 D EVAL Q "RTN","PRCSAPP1",38,0) I $P(PRCSN,"^",4)>1,'$D(^PRCS(410,DA,"IT",0)) S SPENDCP=7 D EVAL Q "RTN","PRCSAPP1",39,0) I +$P(^PRCS(410,DA,3),"^",3)=0 S SPENDCP=8 D EVAL Q "RTN","PRCSAPP1",40,0) I '$$CHECK^PRCEN(DA) S SPENDCP=11 D EVAL Q "RTN","PRCSAPP1",41,0) ;*****PRC*5.1*174 start***** "RTN","PRCSAPP1",42,0) N PRCHJFT,PRCFAIL "RTN","PRCSAPP1",43,0) S PRCHJFT=$P(^PRCS(410,DA,0),"^",4) ;Form Type "RTN","PRCSAPP1",44,0) ;if 2237 transaction (Form Type IEN 2,3, or 4) DO block "RTN","PRCSAPP1",45,0) I $G(PRCHJFT)>1&($G(PRCHJFT)<5) D "RTN","PRCSAPP1",46,0) . ;if 2237 required fields are missing DO block "RTN","PRCSAPP1",47,0) . N PRCWARN "RTN","PRCSAPP1",48,0) . I '$$REQCHECK^PRCHJUTL(DA,.PRCWARN) D "RTN","PRCSAPP1",49,0) . . S PRCFAIL=1 "RTN","PRCSAPP1",50,0) . . N PRCIDX S PRCIDX=0 "RTN","PRCSAPP1",51,0) . . W !!,"WARNING - Transaction "_$$GET1^DIQ(410,DA,.01)_" is missing required data!",*7 "RTN","PRCSAPP1",52,0) . . F S PRCIDX=$O(PRCWARN(PRCIDX)) Q:'PRCIDX D "RTN","PRCSAPP1",53,0) . . . W !?2,">>> "_$G(PRCWARN(PRCIDX)) "RTN","PRCSAPP1",54,0) ;if 2237 missing data, output msg to user and quit (don't allow approval) "RTN","PRCSAPP1",55,0) I $G(PRCFAIL) S SPENDCP=12 D EVAL Q "RTN","PRCSAPP1",56,0) ;*****PRC*5.1*174 end***** "RTN","PRCSAPP1",57,0) S OK=1 QUIT "RTN","PRCSAPP1",58,0) EVAL ; "RTN","PRCSAPP1",59,0) I SPENDCP'=0 W !,$P($T(MESSAGE+SPENDCP),";;",2) H 2 Q:$D(JUMP) R !!,"Press return to continue: ",X:DTIME I X["^" D "RTN","PRCSAPP1",60,0) .I ALL=0 S STOP1=-1 Q "RTN","PRCSAPP1",61,0) .S %=1 W !,"Continue looping through your control points" D YN^DICN I %=2 S STOP1=-1 Q "RTN","PRCSAPP1",62,0) .I %=0 W !,"Enter yes or no. Continue" S %=1 D YN^DICN S:%<2 STOP1=-1 "RTN","PRCSAPP1",63,0) Q "RTN","PRCSAPP1",64,0) MESSAGE ; "RTN","PRCSAPP1",65,0) ;;This transaction was not entered for your site "RTN","PRCSAPP1",66,0) ;;This transaction was not entered for your control point "RTN","PRCSAPP1",67,0) ;;This transaction has already been approved! "RTN","PRCSAPP1",68,0) ;;This transaction is not ready for approval "RTN","PRCSAPP1",69,0) ;;You do not have the funds to approve this request "RTN","PRCSAPP1",70,0) ;;This request does not have a form type "RTN","PRCSAPP1",71,0) ;;Requests without items cannot be approved "RTN","PRCSAPP1",72,0) ;;This transaction does not have a cost center "RTN","PRCSAPP1",73,0) ;;This request has a negative dollar amount "RTN","PRCSAPP1",74,0) ;;Committed Cost does not equal BOC $ Amount - Please re-edit. "RTN","PRCSAPP1",75,0) ;;Missing required data, request needs to be edited. "RTN","PRCSAPP1",76,0) ;;Missing required data, 2237 request needs to be edited prior to approval. "RTN","PRCSCK") 0^23^B65643316^B58904514 "RTN","PRCSCK",1,0) PRCSCK ;SF-ISC/KSS/TKW/SC-CP INPUT TEMPLATE CHECK RTN ;7/9/13 16:00 "RTN","PRCSCK",2,0) V ;;5.1;IFCAP;**81,174**;Oct 20, 2000;Build 23 "RTN","PRCSCK",3,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","PRCSCK",4,0) ; "RTN","PRCSCK",5,0) ;PRC*5.1*81-SC-Adding a display of DM date needed by data, only if "RTN","PRCSCK",6,0) ;the trx. originated from DynaMed. "RTN","PRCSCK",7,0) ; "RTN","PRCSCK",8,0) ;PRCSF-(FLAG) SET IF ENTERING AT TOP OF ROUTINE "RTN","PRCSCK",9,0) ; "RTN","PRCSCK",10,0) S (PRCSF,PRCSERR)=0 F PRCSI=0:0 S PRCSI=$O(^PRCS(410,DA,"IT",PRCSI)) Q:'PRCSI D 2 Q:PRCSERR S PRCSERR=0 D 1 Q:PRCSERR D ^PRCSCK1 "RTN","PRCSCK",11,0) I $D(PRCSERR),PRCSERR G EX "RTN","PRCSCK",12,0) D SCP0^PRCSCK1 "RTN","PRCSCK",13,0) EX K PRCSI,PRCSF,PRCSQT,PRCSDA,PRCSDA1,PRCSDA2,PRCS Q "RTN","PRCSCK",14,0) 1 I $D(PRCSF) S PRCSDA2=DA,PRCSDA1=PRCSI,PRCSQT=$S($D(^PRCS(410,PRCSDA2,"IT",PRCSDA1,0)):$P(^(0),U,2),1:"") I PRCSQT D QRB2 "RTN","PRCSCK",15,0) Q "RTN","PRCSCK",16,0) 2 ;ENTRY POINT WITHIN SUB-FIELD - (DA & DA(1)) DEFINED, OR "RTN","PRCSCK",17,0) ;SUBROUTINE OF ABOVE (PRCSI AND DA) DEFINED.PRCSF (FLAG) SET "RTN","PRCSCK",18,0) Q:'$D(DA) I '$D(PRCSF) Q:'$D(DA(1)) "RTN","PRCSCK",19,0) N SPEC,PRCSIDA,PRCSBOC S SPEC=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),"^",12) "RTN","PRCSCK",20,0) S PRCSERR=0,PRCSJ=DA S:'$D(PRCSF) PRCSI=DA,PRCSJ=DA(1) "RTN","PRCSCK",21,0) S:$D(^PRCS(410,PRCSJ,"IT",PRCSI,0)) PRCSVAR=^(0) "RTN","PRCSCK",22,0) ;if a NON-REPETITIVE (2237) ORDER or REPETITIVE AND NON-REP ORDER check for missing line item description (PRC*5.1*174) "RTN","PRCSCK",23,0) I (PRCSDR="[PRCSEN2237B]")!(PRCSDR="[PRCSENR&NR]") D "RTN","PRCSCK",24,0) . I $D(PRCSVAR)&('$$ITDES^PRCHJUTL($G(PRCSJ),$G(PRCSI))) S PRCSERR=11 "RTN","PRCSCK",25,0) I 'PRCSERR D @$S(PRCSDR["2237":9,PRCSDR["IB":8,PRCSDR["NPR":8,1:7) "RTN","PRCSCK",26,0) I PRCSERR S PRCSL=$S(PRCSERR=2:"QUANTITY",PRCSERR=3:"UNIT OF PURCHASE",PRCSERR=4:"BOC",PRCSERR=5:"ITEM MASTER FILE NO.",PRCSERR=10:"INTERMEDIATE PRODUCT CODE",PRCSERR=11:"DESCRIPTION",1:"ESTIMATED ITEM UNIT COST") "RTN","PRCSCK",27,0) I PRCSERR W !,?3,$C(7),"ITEM # "_$P(^PRCS(410,PRCSJ,"IT",PRCSI,0),U,1)_" "_PRCSL_" MISSING!" S Y="@1" "RTN","PRCSCK",28,0) K PRCSJ,PRCSL,PRCSVAR K:'$D(PRCSF) PRCSI Q "RTN","PRCSCK",29,0) 3 I $D(PRCSVAR) S PRCSERR=$S($P(PRCSVAR,U,2)="":2,$P(PRCSVAR,U,3)="":3,$P(PRCSVAR,U,7)="":7,1:0) "RTN","PRCSCK",30,0) Q "RTN","PRCSCK",31,0) 4 I $D(PRCSVAR),$P(PRCSVAR,U,4)="",($D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)))&($P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,12)'>1)!'$D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S PRCSERR=4 "RTN","PRCSCK",32,0) S PRCSIDA=+$P(^PRCS(410,PRCSJ,"IT",PRCSI,0),"^",5) "RTN","PRCSCK",33,0) Q "RTN","PRCSCK",34,0) 5 I $D(PRCSVAR),$P(PRCSVAR,U,2)="" S PRCSERR=2 "RTN","PRCSCK",35,0) Q "RTN","PRCSCK",36,0) 6 I $D(PRCSVAR),$P(PRCSVAR,U,11)="",$D(^PRC(411,PRC("SITE"),0)),$P(^(0),U,18)="Y" S PRCSERR=10 "RTN","PRCSCK",37,0) Q "RTN","PRCSCK",38,0) 7 I $D(^PRCS(410,PRCSJ,3)),$P(^(3),U,4),$D(^(2)),$P(^(2),U,1)'="",$D(PRCSVAR)&($P(PRCSVAR,U,5)'="") D 5 Q:PRCSERR D 4 "RTN","PRCSCK",39,0) E D 3 Q:PRCSERR D 4 "RTN","PRCSCK",40,0) Q:PRCSERR D:PRCSDR["NR]" 6 "RTN","PRCSCK",41,0) Q "RTN","PRCSCK",42,0) 8 I $D(^PRCS(410,PRCSJ,3)),$P(^(3),U,4),$D(^(2)),$P(^(2),U,1)'="",$D(PRCSVAR) S PRCSERR=$S($P(PRCSVAR,U,5)="":5,$P(PRCSVAR,U,2)="":2,1:0) Q:PRCSERR D 4 Q:PRCSERR I PRCSDR["IB]"!(PRCSDR["NPR]") D 6 "RTN","PRCSCK",43,0) Q "RTN","PRCSCK",44,0) 9 D 3 Q:PRCSERR D 4 Q:PRCSERR D:PRCSDR["B" 6 "RTN","PRCSCK",45,0) Q "RTN","PRCSCK",46,0) RB S PRCST=$S($D(^PRCS(410,DA,4)):$P(^(4),U,8),1:"") "RTN","PRCSCK",47,0) W !,?50,"TRANSACTION BEG BAL: ",$S(PRCST:$J(PRCST,0,2),1:"0.00") G EXIT "RTN","PRCSCK",48,0) RB1 S (PRCS,PRCS(1))=0 F PRCSII=0:0 S PRCS=$O(^PRCS(410,DA(1),12,PRCS)) Q:PRCS'>0 S PRCS(1)=PRCS(1)+$P(^(PRCS,0),U,2) "RTN","PRCSCK",49,0) D RB3 "RTN","PRCSCK",50,0) I PRCS(2)>PRCST(1) S PRCS(3)=PRCS(2)-PRCST(1) W $C(7),!,"This is $ ",$J(PRCS(3),0,2)," more than the total available.",!,"Please re-edit your entries!" S Y=".01" "RTN","PRCSCK",51,0) E D RB4 "RTN","PRCSCK",52,0) G EXIT "RTN","PRCSCK",53,0) RB3 S (PRCST(1),PRCS(2))=0,PRCST=$S($D(^PRCS(410,DA(1),4)):$P(^(4),U,8),1:""),PRCS(2)=PRCS(1),PRCST(1)=PRCST S:PRCS(1)["-"&(PRCST(1)["-") PRCS(2)=-PRCS(1),PRCST(1)=-PRCST Q "RTN","PRCSCK",54,0) RB4 W ?29,"RUNNING TOTAL: ",$S(PRCS(2):$J(PRCS(2),0,2),1:"0.00"),?64,"BAL: ",$S(PRCST(1)-PRCS(2):$J(PRCST(1)-PRCS(2),0,2),1:"0.00") Q "RTN","PRCSCK",55,0) EX1 K PRCSQT,PRCSDA,PRCSDA1,PRCSDA2 Q "RTN","PRCSCK",56,0) EXIT K PRCSII,PRCSJJ,PRCS,PRCST Q "RTN","PRCSCK",57,0) QRB S PRCSQT=$S($D(^PRCS(410,DA(1),"IT",DA,0)):$P(^(0),U,2),1:""),PRCSCST=$S($D(^PRCS(410,DA(1),"IT",DA,0)):$P(^(0),U,7),1:"") "RTN","PRCSCK",58,0) W !?50,"QTY BEG BAL: ",PRCSQT "RTN","PRCSCK",59,0) ;******************************************************************** "RTN","PRCSCK",60,0) ;if DM system param. is set & Item Mult node 4 exists then display "RTN","PRCSCK",61,0) ;Date Needed By for DM trxs only - Patch PRC*5.1*81 "RTN","PRCSCK",62,0) ;******************************************************************** "RTN","PRCSCK",63,0) N PRCVDT,PRCVDN "RTN","PRCSCK",64,0) I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1,$D(^PRCS(410,DA(1),"IT",DA,4)) S PRCVDT=$P($G(^(4)),"^",2) S PRCVDN=$$FMTE^XLFDT(PRCVDT,1) W !?37,"DynaMed's DATE NEEDED BY: "_PRCVDN "RTN","PRCSCK",65,0) G EXIT "RTN","PRCSCK",66,0) QRB1 S PRCSDA=DA,PRCSDA1=DA(1),PRCSDA2=DA(2) Q "RTN","PRCSCK",67,0) QRB2 Q:'$D(PRCSQT) Q:'PRCSQT S PRCS=0,PRCS(1)=PRCSQT F PRCSJJ=1:1 S PRCS=$O(^PRCS(410,PRCSDA2,"IT",PRCSDA1,2,PRCS)) Q:PRCS'>0 S PRCS(2)=$S($D(^PRCS(410.6,+$P(^(PRCS,0),U,2),0)):$P(^(0),U,4),1:""),PRCS(1)=PRCS(1)-PRCS(2) "RTN","PRCSCK",68,0) I '$D(PRCSF) W ?55,"QTY RUN BAL: ",PRCS(1) "RTN","PRCSCK",69,0) S:PRCS(1)=0 PRCSERR="" I PRCS(1)<0 W !,$C(7),?15,"Total delivery schedule quantity exceeds item quantity by "_-(PRCS(1))_"." S PRCSERR=12 I '$D(PRCSF) S Y=3 "RTN","PRCSCK",70,0) Q "RTN","PRCSCK",71,0) ISSUPFCP(STA,FCP) ;RETURN 1 IF THIS IS A SUPPLY FUND FCP, 0 IF IT ISN'T "RTN","PRCSCK",72,0) Q ($P($G(^PRC(420,+STA,1,+FCP,0)),"^",12)=2) "RTN","PRCSCK",73,0) ; "RTN","PRCSCK",74,0) SUPPLYCC() ;RETURN DEFAULT CC FOR SUPPLY FUND FCPS "RTN","PRCSCK",75,0) Q "615300 Inventory and Di" "RTN","PRCSCK",76,0) ; "RTN","PRCSCK",77,0) SUPPLBOC() ;RETURN DEFAULT BOC FOR SUPPLY FUND FCPS "RTN","PRCSCK",78,0) Q 2696 "RTN","PRCSCK",79,0) ; "RTN","PRCSCK",80,0) SETY ;SETS BRANCHING LOGIC FOR INPUT TEMPLATE 'PRCPIB' AND 'PRCSENIB' (INPUT TEMPLATES FOR ISSUE BOOK REQUESTS) "RTN","PRCSCK",81,0) Q:'$D(PRCSERR) "RTN","PRCSCK",82,0) S Y=$S(PRCSERR=2:2,PRCSERR=4:4,PRCSERR=5:5,1:".01") "RTN","PRCSCK",83,0) Q "RTN","PRCSCK",84,0) ; "RTN","PRCSCK",85,0) CHGCCBOC(CXLTXN,RPLTXN,OFCP,MUSTCHG) ; "RTN","PRCSCK",86,0) ;cxltxn = transaction # of cancelled transaction "RTN","PRCSCK",87,0) ;rpltxn = transaction# of replacement transaction "RTN","PRCSCK",88,0) ;ofcp =old fund control point if this was a temp transaction "RTN","PRCSCK",89,0) ;mustchg=user must change (currently not ever called with this set) "RTN","PRCSCK",90,0) ;returns 0 if no change required, 1 if change made,-1 if user must edit "RTN","PRCSCK",91,0) ;First get FCPs. If unchanged, quit "RTN","PRCSCK",92,0) N CXLCC,CXLFCP,CXLDA,CXLSTA,RPLCC,RPLFCP,RPLDA,RPLSTA,CCCNT,DONE,RV "RTN","PRCSCK",93,0) N RPLBOC,I,J,DA,DR,DIE,RPLFTYPE "RTN","PRCSCK",94,0) S CXLFCP=$$GETTXNCP(CXLTXN,.CXLDA,.CXLSTA) "RTN","PRCSCK",95,0) S RPLFCP=$$GETTXNCP(RPLTXN,.RPLDA,.RPLSTA) "RTN","PRCSCK",96,0) I (+CXLFCP'=+OFCP) S CXLFCP=OFCP "RTN","PRCSCK",97,0) I +CXLFCP=+RPLFCP Q 0 "RTN","PRCSCK",98,0) S RPLFTYPE=$P($G(^PRCS(410,RPLDA,0)),U,4) "RTN","PRCSCK",99,0) ;Set CC. Stuff if there's only one good one. Otherwise ask. "RTN","PRCSCK",100,0) S CCCNT=$$GETCCCNT^PRCSECP(RPLSTA,RPLFCP) "RTN","PRCSCK",101,0) I (+CCCNT=1) S RPLCC=$P(CCCNT,U,2),$P(^PRCS(410,RPLDA,3),U,3)=RPLCC W !!,"Cost Center updated to ",RPLCC,! "RTN","PRCSCK",102,0) E D "RTN","PRCSCK",103,0) . S DA=RPLDA,DIE=410,DR="15.5R~Enter a Valid Cost Center" "RTN","PRCSCK",104,0) . S DIC("S")="S PRCSCC=$P(^(3),U,3) I $$VALIDCC^PRCSECP(RPLSTA,RPLFCP,+PRCSCC)" "RTN","PRCSCK",105,0) . D ^DIE "RTN","PRCSCK",106,0) . S RPLCC=$P(^PRCS(410,RPLDA,3),U,3) "RTN","PRCSCK",107,0) ; "RTN","PRCSCK",108,0) ;OK--time to deal with the BOCs now. Is there only one good one? "RTN","PRCSCK",109,0) S RV=1,NEWBOC=$$GETBOCNT^PRCSECP(RPLSTA,RPLFCP,+RPLCC) "RTN","PRCSCK",110,0) I +NEWBOC=1 S RPLBOC=$P(NEWBOC,U,2),DONE=1,RV=0 D "RTN","PRCSCK",111,0) . W !!,"BOC updated to ",RPLBOC," for the new document.",!! "RTN","PRCSCK",112,0) . I RPLFTYPE>1 D "RTN","PRCSCK",113,0) .. S I=0 F S I=$O(^PRCS(410,RPLDA,"IT",I)) Q:I="" D "RTN","PRCSCK",114,0) ... S $P(^PRCS(410,RPLDA,"IT",I,0),U,4)=RPLBOC "RTN","PRCSCK",115,0) . I RPLFTYPE=1 S $P(^PRCS(410,RPLDA,3),U,6)=RPLBOC "RTN","PRCSCK",116,0) I '$G(DONE) D "RTN","PRCSCK",117,0) . I RPLFTYPE>1 D "RTN","PRCSCK",118,0) .. S I=0 F S I=$O(^PRCS(410,RPLDA,"IT",I)) Q:'(I?1N.N) D "RTN","PRCSCK",119,0) ... S RPLBOC=$P(^PRCS(410,RPLDA,"IT",I,0),U,4) "RTN","PRCSCK",120,0) ... I RPLBOC]"" S RPLBOC(RPLBOC)=$G(RPLBOC(RPLBOC))_I_";" "RTN","PRCSCK",121,0) .. S I="" "RTN","PRCSCK",122,0) .. W !!," This document refers to the following BOC(s):",! "RTN","PRCSCK",123,0) .. I $O(RPLBOC(""))="" W " [NONE]",!! "RTN","PRCSCK",124,0) .. F S I=$O(RPLBOC(I)) Q:I="" D "RTN","PRCSCK",125,0) ... W " BOC: ",I,":" "RTN","PRCSCK",126,0) ... I '$$VALIDBOC^PRCSECP(RPLSTA,RPLFCP,RPLCC,I) W " ** INVALID **" S RV=-1 "RTN","PRCSCK",127,0) ... W !," BOC ",+I," ITEM(S): ",$E(RPLBOC(I),1,$L(RPLBOC(I))-1) "RTN","PRCSCK",128,0) ... W !! "RTN","PRCSCK",129,0) . I RPLFTYPE=1 D "RTN","PRCSCK",130,0) .. S RPLBOC=$P($G(^PRCS(410,RPLDA,3)),U,6) "RTN","PRCSCK",131,0) .. W !!,"This document uses BOC ",RPLBOC "RTN","PRCSCK",132,0) .. I '$$VALIDBOC^PRCSECP(RPLSTA,RPLFCP,RPLCC,RPLBOC) W " ** INVALID **" S RV=-1 "RTN","PRCSCK",133,0) . I RV<0,MUSTCHG W !,"You must edit this document to correct the BOC entries now.",! "RTN","PRCSCK",134,0) Q RV "RTN","PRCSCK",135,0) ; "RTN","PRCSCK",136,0) OKCCBOC(TRANSXN) ;TRANSXN = transaction# of transaction to check "RTN","PRCSCK",137,0) ;returns 1 if no change required, 0 if user must edit "RTN","PRCSCK",138,0) ;First get FCP, Form type, Station, IEN and CC "RTN","PRCSCK",139,0) N A,CC,FCP,DA,STA,CCCNT,DONE,RV,GOODCC "RTN","PRCSCK",140,0) N BOC,BOCC,I,J,DR,DIE,FTYPE "RTN","PRCSCK",141,0) S FCP=$$GETTXNCP(TRANSXN,.DA,.STA) "RTN","PRCSCK",142,0) I 'DA!'STA Q 0 "RTN","PRCSCK",143,0) S FTYPE=$P($G(^PRCS(410,DA,0)),U,4) "RTN","PRCSCK",144,0) S CC=+$P($G(^PRCS(410,DA,3)),U,3) I 'CC Q 0 "RTN","PRCSCK",145,0) S GOODCC=$$VALIDCC^PRCSECP(STA,FCP,CC) "RTN","PRCSCK",146,0) I 'GOODCC D Q 0 "RTN","PRCSCK",147,0) . S A(1,"F")="!!?10",A(1)="An invalid Cost Center ("_+CC_") was entered." "RTN","PRCSCK",148,0) . S A(2,"F")="!?10",A(2)="You must re-edit this document before it can be approved." "RTN","PRCSCK",149,0) . S A(3)=$C(7) "RTN","PRCSCK",150,0) . D EN^DDIOL(.A) "RTN","PRCSCK",151,0) ; "RTN","PRCSCK",152,0) ;OK--time to deal with the BOCs now. For 1358s, check the single BOC "RTN","PRCSCK",153,0) ; "RTN","PRCSCK",154,0) S BOCC=$$GETBOCNT^PRCSECP(STA,FCP,CC) "RTN","PRCSCK",155,0) S RV=1 "RTN","PRCSCK",156,0) I FTYPE=1 D Q RV "RTN","PRCSCK",157,0) . S BOC=$P($G(^PRCS(410,DA,3)),U,6) "RTN","PRCSCK",158,0) . I '$$VALIDBOC^PRCSECP(STA,FCP,CC,BOC) D Q "RTN","PRCSCK",159,0) .. S A(1,"F")="!!?10",A(1)="An invalid BOC ("_+BOC_") was entered." "RTN","PRCSCK",160,0) .. I (+BOCC=1) S $P(PRCS(410,DA,3),U,6)=$P(BOCC,U,2),A(2)="It has been changed to "_+$P(BOCC,U,2) "RTN","PRCSCK",161,0) .. I (+BOCC'=1) S A(2)="You must re-edit this document before it can be approved." "RTN","PRCSCK",162,0) .. S A(2,"F")="!?10" "RTN","PRCSCK",163,0) .. S A(3)=$C(7) "RTN","PRCSCK",164,0) .. D EN^DDIOL(.A) "RTN","PRCSCK",165,0) .. S RV=0 "RTN","PRCSCK",166,0) ; "RTN","PRCSCK",167,0) ;For the other form types, check all BOCs "RTN","PRCSCK",168,0) ; "RTN","PRCSCK",169,0) S (I,J)=0 "RTN","PRCSCK",170,0) F S I=$O(^PRCS(410,DA,"IT",I)) Q:'(I?1N.N) D "RTN","PRCSCK",171,0) . S BOC=$P(^PRCS(410,DA,"IT",I,0),U,4) "RTN","PRCSCK",172,0) . I '$$VALIDBOC^PRCSECP(STA,FCP,CC,BOC) D "RTN","PRCSCK",173,0) .. S J=J+1,A(J)="An invalid BOC ("_+BOC_") was entered for item "_I_"." "RTN","PRCSCK",174,0) .. S A(J,"F")="!?10" I J=1 S A(J,"F")="!"_A(J,"F") "RTN","PRCSCK",175,0) .. I (+BOCC=1) S $P(^PRCS(410,DA,"IT",I,0),U,4)=$P(BOCC,U,2) "RTN","PRCSCK",176,0) I J S RV=0,J=J+1,A(J,"F")="!?10",A(J)=$S((+BOCC'=1):"You must re-edit this document before it can be approved.",1:"BOC(s) replaced with "_+$P(BOCC,U,2)),A(J+1)=$C(7) D EN^DDIOL(.A) "RTN","PRCSCK",177,0) Q RV "RTN","PRCSCK",178,0) GETTXNCP(TRANSID,OUTIEN,OUTSTA) ;GET IEN AND CONTROL POINT # FOR TRANSACTION "RTN","PRCSCK",179,0) S OUTIEN=+$O(^PRCS(410,"B",TRANSID,"")) "RTN","PRCSCK",180,0) S OUTSTA=$P($G(^PRCS(410,OUTIEN,0)),U,5) "RTN","PRCSCK",181,0) Q $P($G(^PRCS(410,OUTIEN,3)),U,1) "RTN","PRCSCK",182,0) ; "RTN","PRCSCK",183,0) ; "RTN","PRCSCK",184,0) CHKITDES(PRCDA) ;2237 input template - check all line items for a description "RTN","PRCSCK",185,0) ;This procedure checks all line items on a 2237 to make sure they have a "RTN","PRCSCK",186,0) ;description. Sets branching logic for input template if any line item "RTN","PRCSCK",187,0) ;descriptions are not populated. "RTN","PRCSCK",188,0) ; "RTN","PRCSCK",189,0) ; Called from input templates: "RTN","PRCSCK",190,0) ; - PRCSEN2237B "RTN","PRCSCK",191,0) ; - PRCSENR&NR "RTN","PRCSCK",192,0) ; "RTN","PRCSCK",193,0) ; Input: "RTN","PRCSCK",194,0) ; PRCDA - (required) IEN of record in CONTROL POINT ACTIVITY (#410) file "RTN","PRCSCK",195,0) ; "RTN","PRCSCK",196,0) ; Output: None (sets branching logic for input template) "RTN","PRCSCK",197,0) ; "RTN","PRCSCK",198,0) S PRCDA=+$G(PRCDA) "RTN","PRCSCK",199,0) Q:'$G(PRCDA) "RTN","PRCSCK",200,0) N PRCHJFT S PRCHJFT=$P(^PRCS(410,PRCDA,0),"^",4) ;Form Type "RTN","PRCSCK",201,0) ;quit if not a 2237 transaction (Form Type IEN 2,3,or 4) "RTN","PRCSCK",202,0) Q:$G(PRCHJFT)<2!($G(PRCHJFT)>4) "RTN","PRCSCK",203,0) ;check if 2237 has any line items missing a description "RTN","PRCSCK",204,0) N PRCWARN "RTN","PRCSCK",205,0) I '$$ITDESALL^PRCHJUTL(PRCDA,.PRCWARN) D "RTN","PRCSCK",206,0) . N PRCIDX S PRCIDX=0 "RTN","PRCSCK",207,0) . F S PRCIDX=$O(PRCWARN(PRCIDX)) Q:'PRCIDX D "RTN","PRCSCK",208,0) . . W !?3,$$UP^XLFSTR($G(PRCWARN(PRCIDX))) "RTN","PRCSCK",209,0) ; "RTN","PRCSCK",210,0) ;if any line items missing a description set input template branch "RTN","PRCSCK",211,0) I $D(PRCWARN) S Y="@1" "RTN","PRCSCK",212,0) ; "RTN","PRCSCK",213,0) Q "RTN","PRCSD12") 0^8^B5349838^B5330398 "RTN","PRCSD12",1,0) PRCSD12 ;WISC/SAW-CONTROL POINT ACT. 2237 TERMINAL DISPLAY ;2/13/13 12:59 "RTN","PRCSD12",2,0) V ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23 "RTN","PRCSD12",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCSD12",4,0) S U="^",P(1)=0,Z1="" D NOW^%DTC S Y=% D DD^%DT W @IOF S L="",$P(L,"-",IOM)="-" "RTN","PRCSD12",5,0) S P=$S($D(^PRCS(410,DA,1)):$P(^(1),U,3),1:""),P=$S(P="EM":"***EMERGENCY***",P="SP":"*SPECIAL*",1:"STANDARD") W ?26,"PRIORITY: ",P "RTN","PRCSD12",6,0) W:$$ECMS2237^PRCHJUTL(DA) ?55,"Accepted by eCMS" "RTN","PRCSD12",7,0) W !,Y,?31,$P(^PRCS(410,DA,0),U) W !,L "RTN","PRCSD12",8,0) W !,?16,"REQUEST, TURN-IN, AND RECEIPT FOR PROPERTY OR SERVICES" W !,L "RTN","PRCSD12",9,0) W !,"TO: A&MM Officer",?24,"Requesting Office" "RTN","PRCSD12",10,0) W !,?24 S P=$P(^PRCS(410,DA,0),U,5),P1=$S($D(^(3)):+$P(^(3),U),1:"") I P,P1 S P=$S($D(^PRC(420,P,1,P1,0)):$P(^(0),U,10),1:"") I P,$D(^DIC(49,P,0)) W $P(^(0),U) W:$P(^(0),U,8)]"" " ("_$P(^(0),U,8)_")" "RTN","PRCSD12",11,0) W !,$E(L,1,23) "RTN","PRCSD12",12,0) W " ",$E(L,25,IOM) "RTN","PRCSD12",13,0) W !,"Action Requested",?24,"Date Prepared",?46,"Date Required" "RTN","PRCSD12",14,0) W !,?4,"Delivery",?24 I $D(^PRCS(410,DA,1)),$P(^(1),U)'="" S Y=$P(^(1),U) D DD^%DT W Y "RTN","PRCSD12",15,0) W ?46 I $D(^PRCS(410,DA,1)),$P(^(1),U,4)'="" S Y=$P(^(1),U,4) D DD^%DT W Y "RTN","PRCSD12",16,0) W !,$E(L,1,23) "RTN","PRCSD12",17,0) W " ",$E(L,25,45) "RTN","PRCSD12",18,0) W " ",$E(L,47,IOM) "RTN","PRCSD12",19,0) W !,?2,"ITEM NO. ",?23,"DESCRIPTION",?52," QUANTITY UNIT ESTIMATED" "RTN","PRCSD12",20,0) W !,"OR STOCK NO. ",?68,"UNIT COST",!,L "RTN","PRCSD12",21,0) D ^PRCSD121 G EXIT:Z1=U D ^PRCSD122 G EXIT:Z1=U D ^PRCSD123 G EXIT:Z1=U W !,"Press return to continue: " R Z1:DTIME "RTN","PRCSD12",22,0) EXIT K FPROJ,%DT,P,P1,PRCS("SUB"),X,X1,Y,Z,Z1,DIWL,DIWR,DIWF,I,J,K,^UTILITY($J,"W"),PRCSIN,PRCSQTY,PRCSDES,PRCSDS,PRCSDSD,PRCSILP,PRCSLNT,PRCSLN,N,PRCSPG Q "RTN","PRCSD12",23,0) Q "RTN","PRCSEA") 0^16^B77709239^B76984063 "RTN","PRCSEA",1,0) PRCSEA ;WISC/SAW/DXH/BM/SC/DAP - CONTROL POINT ACTIVITY EDITS ;5/8/13 15:31 "RTN","PRCSEA",2,0) V ;;5.1;IFCAP;**81,147,150,174**;Oct 20, 2000;Build 23 "RTN","PRCSEA",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCSEA",4,0) ; "RTN","PRCSEA",5,0) ;PRC*5.1*81 BMM 3/23/05 when a 2237 is canceled, in CT1, add code "RTN","PRCSEA",6,0) ;to update Audit file (#414.02), and send update message to "RTN","PRCSEA",7,0) ;DynaMed thru a call to rtn PRCVTCA. "RTN","PRCSEA",8,0) ; "RTN","PRCSEA",9,0) ;PRC*5.1*150 RGB 4/23/12 DO NOT allow the same temporary tx "RTN","PRCSEA",10,0) ;number to be used at all. Previously, the same temp tx # "RTN","PRCSEA",11,0) ;could be used by different users, not same user. "RTN","PRCSEA",12,0) ;Also, Control the node 0 counter for file 410 kill (DIK) "RTN","PRCSEA",13,0) ;since DIK call does not handle descending file logic "RTN","PRCSEA",14,0) ; "RTN","PRCSEA",15,0) ENRS ;ENTER REQ "RTN","PRCSEA",16,0) S PRCSK=1,X3="H" "RTN","PRCSEA",17,0) D EN1F^PRCSUT(1) ; ask site,FY,QRTR,CP & set up PRC array, PRCSIP variable ; prc*5*197 "RTN","PRCSEA",18,0) G W2:'$D(PRC("SITE")),EXIT:Y<0 ; unauthorized user or '^' entered "RTN","PRCSEA",19,0) D W6 ; display help on transaction# format "RTN","PRCSEA",20,0) ENRS0 S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="ABELQX",D="H" ;PRC*5.1*150 "RTN","PRCSEA",21,0) S DIC("A")="Select TRANSACTION: " "RTN","PRCSEA",22,0) S DIC("S")="I '^(0),$P(^(0),U)'="""",$D(^PRCS(410,""B"",$P(^(0),U),+Y))" ; only temp tx number not defined will be allowed ;PRC*5.1*150 "RTN","PRCSEA",23,0) D ^PRCSDIC ; lookup & preliminary validity checking "RTN","PRCSEA",24,0) K DLAYGO,DIC("A"),DIC("S") "RTN","PRCSEA",25,0) G:Y<0 EXIT "RTN","PRCSEA",26,0) I $P(Y,U,3)'=1 W $C(7)," Must be a new (unique) entry." G ENRS0 ;PRC*5.1*150 "RTN","PRCSEA",27,0) ;*81 Check site parameter to see if issue books are allowed "RTN","PRCSEA",28,0) D CKPRM^PRCSEB "RTN","PRCSEA",29,0) W !!,PRCVY,! "RTN","PRCSEA",30,0) S (PDA,T1,DA)=+Y "RTN","PRCSEA",31,0) L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...try a different transaction number or try later" G ENRS0 "RTN","PRCSEA",32,0) S T(2)=$P(Y,U,2) "RTN","PRCSEA",33,0) D EN2A^PRCSUT3 ; saves CP,sta,substa,txn name,user,BBFY,RB stat,acct data in new txn (nodes 0,3,6,11 of file 410) "RTN","PRCSEA",34,0) S $P(^PRCS(410,DA,14),"^")=DUZ ; originator (entered by) "RTN","PRCSEA",35,0) S $P(^PRCS(410,DA,7),"^")=DUZ,$P(^PRCS(410,DA,7),"^",2)=$P($G(^VA(200,DUZ,20)),"^",3) ; requestor default "RTN","PRCSEA",36,0) I $G(PRCSIP) S $P(^PRCS(410,DA,0),"^",6)=PRCSIP,^PRCS(410,"AO",PRCSIP,DA)="" ; PRCSIP was set up in PRCSUT & is inventory distribution point "RTN","PRCSEA",37,0) S PRCS="" ; set PRCS=1 if CP is automated, i.e. it uses IFCAP to send requests to A&MM "RTN","PRCSEA",38,0) I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS=1 "RTN","PRCSEA",39,0) TYPE ; "RTN","PRCSEA",40,0) W !!,"This transaction is assigned temporary transaction number: ",T(2) "RTN","PRCSEA",41,0) S DIC("A")="FORM TYPE: ",DIC="^PRCS(410.5,",DIC(0)="AEQZ" "RTN","PRCSEA",42,0) S DIC("S")=PRCVX ; only allow selection of 2237's "RTN","PRCSEA",43,0) D ^DIC "RTN","PRCSEA",44,0) S DA=PDA "RTN","PRCSEA",45,0) ;if user didn't enter a form type, go ask whether to backout and act "RTN","PRCSEA",46,0) ;accordingly: go let them re-enter a form type or exit "RTN","PRCSEA",47,0) I Y<0 G:'$$BACKOUT(T(2),DA) TYPE L -^PRCS(420,DA) G EXIT "RTN","PRCSEA",48,0) ; "RTN","PRCSEA",49,0) I Y<2 W "??" G TYPE "RTN","PRCSEA",50,0) K PRCVX,PRCVY "RTN","PRCSEA",51,0) S $P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y ; form type "RTN","PRCSEA",52,0) ; if CP is not automated (file 420), user's response will be overwritten with non-recuring (type 2). Although user's selection is changed 'behind the scenes', "RTN","PRCSEA",53,0) ; the scenario is unlikely to occur because full implementation of IFCAP was made mandatory and sites are now automated. "RTN","PRCSEA",54,0) S:'PRCS&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2 "RTN","PRCSEA",55,0) K PRCSERR ; flag denoting item info is missing "RTN","PRCSEA",56,0) S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410," "RTN","PRCSEA",57,0) S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]" "RTN","PRCSEA",58,0) EN1 K DTOUT,DUOUT,Y "RTN","PRCSEA",59,0) D ^DIE "RTN","PRCSEA",60,0) S DA=PDA "RTN","PRCSEA",61,0) I $D(Y)!($D(DTOUT)) D DOR L -^PRCS(410,DA) G EXIT "RTN","PRCSEA",62,0) D RL^PRCSUT1 ; sets up 'IT' & '10' nodes "RTN","PRCSEA",63,0) D ^PRCSCK I $D(PRCSERR),PRCSERR G EN1 ; missing required field ('item') "RTN","PRCSEA",64,0) D DOR ; populate date of request field if it is nil "RTN","PRCSEA",65,0) L -^PRCS(410,DA) "RTN","PRCSEA",66,0) S T="enter" D W5 G EXIT:%'=1 "RTN","PRCSEA",67,0) W !! K PRCS("SUB") "RTN","PRCSEA",68,0) G ENRS "RTN","PRCSEA",69,0) ; "RTN","PRCSEA",70,0) EDRS ;EDIT REQ "RTN","PRCSEA",71,0) ; following line commented out by PRC*5*140 - user responses not used to limit selection of txn and sometimes resulted in bad info being set into the selected txn "RTN","PRCSEA",72,0) ; S PRCSK=1 D EN1F^PRCSUT(1) G W2:'$D(PRC("SITE")),EXIT:Y<0 ; ask sta,FY,QRTR,CP ; prc*5*197 "RTN","PRCSEA",73,0) ; if the above line is reactivated, programmer should note that the transaction selected may not be of the same FY,QRTR,sta, subst, and CP specified by the user "RTN","PRCSEA",74,0) D W6 ; format doc for txn# "RTN","PRCSEA",75,0) S X3="H" S DIC="^PRCS(410,",DIC(0)="AEQ",D="H" "RTN","PRCSEA",76,0) S DIC("A")="Select TRANSACTION: " "RTN","PRCSEA",77,0) S DIC("S")="I '^(0),$P(^(0),U,3)'="""",$P(^(0),U,4)'=1,^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")" ; request must be authored by user or unauthored & cannot be a 1358 "RTN","PRCSEA",78,0) D ^PRCSDIC G EXIT:Y<0 K DIC("A"),DIC("S") "RTN","PRCSEA",79,0) S (PDA,DA,T1)=+Y "RTN","PRCSEA",80,0) L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G EDRS "RTN","PRCSEA",81,0) ; following line commented out in PRC*5*140 - PRCSUT3 needs PRC("SST") or MYY to do something, neither exists in this option "RTN","PRCSEA",82,0) ; D EN2B^PRCSUT3 "RTN","PRCSEA",83,0) S PRC("SITE")=+$P(^PRCS(410,PDA,0),"^",5) "RTN","PRCSEA",84,0) S PRC("CP")=$P(^PRCS(410,PDA,3),"^") "RTN","PRCSEA",85,0) I $P(^PRCS(410,PDA,0),"^",6)="" D ; prc*5*197 "RTN","PRCSEA",86,0) . N PRCSIP D IP^PRCSUT "RTN","PRCSEA",87,0) . I $D(PRCSIP) S $P(^PRCS(410,DA,0),U,6)=PRCSIP ;PRC*5.1*147 modified file set from ^PRC(410 to ^PRCS(410 "RTN","PRCSEA",88,0) S X=+$P(^PRCS(410,DA,0),"^",4) I X<1 D FORM "RTN","PRCSEA",89,0) ;*81 Check site parameter to see if Issue Books are allowed "RTN","PRCSEA",90,0) D CKPRM "RTN","PRCSEA",91,0) I PRCVD=1 S PRCVZ=1 "RTN","PRCSEA",92,0) I PRCVD'=1 S PRCVZ=0 "RTN","PRCSEA",93,0) W !,"The form type for this transaction is ",$P($G(^PRCS(410.5,X,0)),"^"),! "RTN","PRCSEA",94,0) I PRCVZ=1,X=5 W !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP issue book order." S T="edit" D W5 G:%'=1 EXIT W !! K PRCS("SUB") G EDRS "RTN","PRCSEA",95,0) ; "RTN","PRCSEA",96,0) S DIC(0)="AEMQ",(DIC,DIE)="^PRCS(410," "RTN","PRCSEA",97,0) ;P182--Modified next 3 lines to use new templates if supply fund FCP "RTN","PRCSEA",98,0) S (DR,PRCSDR)="["_$S(X=1:"PRCE NEW 1358S",X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",1:"PRCSENIBS")_"]" "RTN","PRCSEA",99,0) ED1 K DTOUT,DUOUT,Y "RTN","PRCSEA",100,0) D ^DIE "RTN","PRCSEA",101,0) S DA=PDA "RTN","PRCSEA",102,0) I $D(Y)!($D(DTOUT)) L -^PRCS(410,DA) G EXIT "RTN","PRCSEA",103,0) D RL^PRCSUT1 "RTN","PRCSEA",104,0) D ^PRCSCK I $D(PRCSERR),PRCSERR G ED1 "RTN","PRCSEA",105,0) K PRCSERR S $P(^PRCS(410,DA,14),"^")=DUZ "RTN","PRCSEA",106,0) L -^PRCS(410,DA) "RTN","PRCSEA",107,0) S T="edit" D W5 G EXIT:%'=1 "RTN","PRCSEA",108,0) W !! K PRCS("SUB") "RTN","PRCSEA",109,0) G EDRS "RTN","PRCSEA",110,0) ; "RTN","PRCSEA",111,0) CT ;CANCEL A (PERMANENT) TRANS "RTN","PRCSEA",112,0) D EN3^PRCSUT "RTN","PRCSEA",113,0) G W2:'$D(PRC("SITE")),EXIT:Y<0 "RTN","PRCSEA",114,0) S DIC="^PRCS(410,",DIC(0)="AEMQ" "RTN","PRCSEA",115,0) ;S DIC("S")="I $P(^(0),""^"",4)=.5!($S('$D(^(7)):1,1:$P(^(7),""^"",6)="""")) I +^(0)>0,$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))" "RTN","PRCSEA",116,0) S DIC("S")="I $P(^(0),U,2)=""O""!($P(^(0),U,2)=""A""&($P(^(0),U,4)=1)),$S('$D(^(7)):1,1:$P(^(7),""^"",6)=""""),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))" "RTN","PRCSEA",117,0) S DIC("A")="Select TRANSACTION: " "RTN","PRCSEA",118,0) D ^PRCSDIC G EXIT:Y<0 K DIC("S"),DIC("A") "RTN","PRCSEA",119,0) CT1 W !,"Cancel this transaction" S %=2 D YN^DICN G CT1:%=0,EXIT:%'=1 "RTN","PRCSEA",120,0) S DA=+Y "RTN","PRCSEA",121,0) L +^PRCS(410,DA):1 I $T=0 W !,"File is being accessed...please try later" G CT "RTN","PRCSEA",122,0) S DIE="^PRCS(410,",DR="104////^S X=DUZ" D ^DIE K DIE,DR "RTN","PRCSEA",123,0) S T=$P(^PRCS(410,DA,0),"^") "RTN","PRCSEA",124,0) I T?1A.E D G EXIT:%'=1 W !! G CT ;PRC*5.1*150 Will DELETE entry if temporary transaction "RTN","PRCSEA",125,0) . S DIK="^PRCS(410,",PRCIENCT=$P(^PRCS(410,0),"^",3)+1 "RTN","PRCSEA",126,0) . D ^DIK "RTN","PRCSEA",127,0) . S $P(^PRCS(410,0),"^",3)=PRCIENCT K PRCIENCT,DIK "RTN","PRCSEA",128,0) . S T="cancel" D W4 "RTN","PRCSEA",129,0) S $P(^PRCS(410,DA,11),"^",3)="",$P(^PRCS(410,DA,0),"^",2)="CA",$P(^PRCS(410,DA,5),"^")=0,$P(^PRCS(410,DA,6),"^")=0 "RTN","PRCSEA",130,0) K ^PRCS(410,"F",+T_"-"_+PRC("CP")_"-"_$P(T,"-",5),DA),^PRCS(410,"F1",$P(T,"-",5)_"-"_+T_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA) "RTN","PRCSEA",131,0) K ZX "RTN","PRCSEA",132,0) I $D(^PRCS(410,DA,4)) S ZX=^(4),X=$P(ZX,"^",8) F I=1,3,6,8 S $P(ZX,"^",I)=0 "RTN","PRCSEA",133,0) I $D(ZX) S ^PRCS(410,DA,4)=ZX K ZX "RTN","PRCSEA",134,0) I $D(^PRCS(410,DA,12,0)) S N=0 F I=0:0 S N=$O(^PRCS(410,DA,12,N)) Q:N'>0 S X=$P(^(N,0),"^",2) I X S DA(1)=DA,DA=N D TRANK^PRCSEZZ S DA=DA(1) "RTN","PRCSEA",135,0) D ERS410^PRC0G(DA_"^C") "RTN","PRCSEA",136,0) W !,"Enter comments for this cancellation",! "RTN","PRCSEA",137,0) S DIE=DIC,DR=60 "RTN","PRCSEA",138,0) D ^DIE "RTN","PRCSEA",139,0) ;PRC*5.1*81 if DM trx, update Audit file and send msg to DM "RTN","PRCSEA",140,0) D EN^PRCVTCA(DA) "RTN","PRCSEA",141,0) L -^PRCS(410,DA) "RTN","PRCSEA",142,0) I $D(^PRC(443,DA,0)) S DIK="^PRC(443," D ^DIK K DIK "RTN","PRCSEA",143,0) S T="cancel" D W4 G EXIT:%'=1 "RTN","PRCSEA",144,0) W !! G CT "RTN","PRCSEA",145,0) ; "RTN","PRCSEA",146,0) DT ;DELETE A (TEMPORARY) TRANS "RTN","PRCSEA",147,0) S X3="H" "RTN","PRCSEA",148,0) D W6 ; format doc for txn# "RTN","PRCSEA",149,0) S DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select TRANSACTION: ",D="H" "RTN","PRCSEA",150,0) S DIC("S")="S W=$P(^(0),""^"",5),W(1)=+^(3) I '^(0),$P(^(0),""^"",3)'="""",^PRCS(410,""H"",$P(^(0),""^"",3),+Y)=DUZ!(^(+Y)="""")!($D(^PRC(420,""A"",DUZ,W,W(1),1)))!($D(^(2)))" "RTN","PRCSEA",151,0) D ^PRCSDIC G EXIT:Y<0 "RTN","PRCSEA",152,0) K DIC("S"),DIC("A") "RTN","PRCSEA",153,0) S DA=+Y "RTN","PRCSEA",154,0) L +^PRCS(410,DA):5 I $T=0 W !,"File is being accessed...please try later" G DT "RTN","PRCSEA",155,0) DT1 W !,"Delete this transaction" S %=2 D YN^DICN G DT1:%=0,EXIT:%'=1 "RTN","PRCSEA",156,0) ;The following line was commented out in patch 182; should NOT manually "RTN","PRCSEA",157,0) ;change or reset last assigned IEN # in node zero. "RTN","PRCSEA",158,0) ;S PRCSDA=$P(^PRCS(410,0),U,3),DIK=DIC "RTN","PRCSEA",159,0) S PRCIENCT=$P(^PRCS(410,0),"^",3)+1 ;PRC*5.1*150 "RTN","PRCSEA",160,0) S DIK=DIC "RTN","PRCSEA",161,0) W !,"Okay....." "RTN","PRCSEA",162,0) D ^DIK K DIK "RTN","PRCSEA",163,0) S $P(^PRCS(410,0),"^",3)=PRCIENCT K PRCIENCT ;PRC*5.1*150 "RTN","PRCSEA",164,0) L -^PRCS(410,DA) "RTN","PRCSEA",165,0) ;The following line was commented out in patch 182; should NOT manually "RTN","PRCSEA",166,0) ;change or reset last assigned IEN # in node zero. "RTN","PRCSEA",167,0) ;S $P(^PRCS(410,0),U,3)=PRCSDA "RTN","PRCSEA",168,0) K PRCSDA "RTN","PRCSEA",169,0) W "It's deleted" "RTN","PRCSEA",170,0) S T="delete" D W4 G EXIT:%'=1 "RTN","PRCSEA",171,0) W !! G DT "RTN","PRCSEA",172,0) ; "RTN","PRCSEA",173,0) ; "RTN","PRCSEA",174,0) DOR ; Date of Request "RTN","PRCSEA",175,0) I $D(^PRCS(410,DA,1)),$P(^PRCS(410,DA,1),"^")'="" Q "RTN","PRCSEA",176,0) S %DT="X",X="T" D ^%DT S $P(^PRCS(410,DA,1),"^")=Y "RTN","PRCSEA",177,0) Q "RTN","PRCSEA",178,0) FORM ;*81 Allow user to change txn to a valid form and check site parameter to see if issue books are allowed "RTN","PRCSEA",179,0) D CKPRM "RTN","PRCSEA",180,0) I PRCVD=1 S PRCVX1="I Y>1&(Y<5)",PRCVY1="The Issue Book and NO FORM type are not valid in this option." "RTN","PRCSEA",181,0) I PRCVD'=1 S PRCVX1="I Y>1",PRCVY1="The NO FORM type is not valid in this option." "RTN","PRCSEA",182,0) W !,PRCVY1,! "RTN","PRCSEA",183,0) W !,"Please enter another form type",! "RTN","PRCSEA",184,0) S PRCSDAA=DA,DIC="^PRCS(410.5,",DIC("A")="FORM TYPE: ",DIC(0)="AEQZ" "RTN","PRCSEA",185,0) S DIC("S")=PRCVX1 "RTN","PRCSEA",186,0) D ^DIC "RTN","PRCSEA",187,0) S:Y=-1 Y=2 "RTN","PRCSEA",188,0) S DA=PRCSDAA,$P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y "RTN","PRCSEA",189,0) K DIC,PRCVX1,PRCVY1,PRCVD "RTN","PRCSEA",190,0) Q "RTN","PRCSEA",191,0) ; "RTN","PRCSEA",192,0) ;Allow user the option of re entering a form type. If they decline, "RTN","PRCSEA",193,0) ;kill off the transaction and return 1; else return 0 "RTN","PRCSEA",194,0) BACKOUT(TRNNAME,TRNDA) ; "RTN","PRCSEA",195,0) N DIK,Y,%,DA "RTN","PRCSEA",196,0) W !!,"WARNING: WITHOUT A FORM TYPE, TRANSACTION """,TRNNAME,""" WILL BE DELETED!",$C(7) "RTN","PRCSEA",197,0) W !,"Are you sure you want to delete this transaction" S %=2 D YN^DICN "RTN","PRCSEA",198,0) I %=0 G BACKOUT "RTN","PRCSEA",199,0) I %=2 Q 0 "RTN","PRCSEA",200,0) S DIK="^PRCS(410,",DA=TRNDA "RTN","PRCSEA",201,0) S PRCIENCT=$P(^PRCS(410,0),"^",3)+1 ;PRC*5.1*150 "RTN","PRCSEA",202,0) D ^DIK "RTN","PRCSEA",203,0) S $P(^PRCS(410,0),"^",3)=PRCIENCT K PRCIENCT ;PRC*5.1*150 "RTN","PRCSEA",204,0) Q 1 "RTN","PRCSEA",205,0) ; "RTN","PRCSEA",206,0) W2 W !!,"You are not an authorized control point user.",!,"Contact control point official" R X:5 G EXIT "RTN","PRCSEA",207,0) W3 Q ; can this subroutine be deleted? commented out in patch PRC*5*140 "RTN","PRCSEA",208,0) W !!,"This transaction is assigned temporary transaction number: ",X Q "RTN","PRCSEA",209,0) W4 W !!,"Would you like to ",T," another transaction" S %=2 D YN^DICN G W4:%=0 Q "RTN","PRCSEA",210,0) W5 W !!,"Would you like to ",T," another request" S %=1 D YN^DICN G W5:%=0 Q "RTN","PRCSEA",211,0) W6 W !!,"For the transaction number, use an uppercase alpha as the first character,",!," and then 2-15 alphanumerics, as in 'ADP1'.",! Q "RTN","PRCSEA",212,0) ;*81 Site parameter pull "RTN","PRCSEA",213,0) CKPRM S PRCVD=$$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q") "RTN","PRCSEA",214,0) Q "RTN","PRCSEA",215,0) ; "RTN","PRCSEA",216,0) EXIT K %,C,D,DA,DIC,DIE,DR,PRCS,PDA,PRCSL,T,X,Y,Z,T1,X3,TYPE,PRCVZ "RTN","PRCSEA",217,0) I $D(PRCSERR) K PRCSERR "RTN","PRCSEA",218,0) Q "RTN","PRCSEB") 0^12^B19745869^B17751549 "RTN","PRCSEB",1,0) PRCSEB ;SF-ISC/LJP/SAW/DXH/DAP - CPA EDITS CON'T ;7.26.99 "RTN","PRCSEB",2,0) V ;;5.1;IFCAP;**81,174**;Oct 20, 2000;Build 23 "RTN","PRCSEB",3,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","PRCSEB",4,0) ENRB ;ENTER CP CLERK REQUEST FROM OPTION PRCSENRB "RTN","PRCSEB",5,0) D ENF^PRCSUT(1) G W2:'$D(PRC("SITE")) G EXIT:'$D(PRC("QTR"))!(Y<0) "RTN","PRCSEB",6,0) D EN1^PRCSUT3 Q:'X S PRCSX1=X D EN2^PRCSUT3 Q:'$D(PRCSX1) S X=PRCSX1,T1=DA D W L +^PRCS(410,DA):15 G ENRB:$T=0 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),"^",11)="Y" PRCS2=1 "RTN","PRCSEB",7,0) ; "RTN","PRCSEB",8,0) ;*81 Check site parameter to see if issue books should be allowed "RTN","PRCSEB",9,0) D CKPRM "RTN","PRCSEB",10,0) W !!,PRCVY,!! "RTN","PRCSEB",11,0) TYPE ; "RTN","PRCSEB",12,0) S PRCDAA=DA,DIC="^PRCS(410.5,",DIC(0)="AEQZ",DIC("A")="FORM TYPE: ",DIC("S")=PRCVX D ^DIC S TYPE=+Y,DA=PRCDAA "RTN","PRCSEB",13,0) I TYPE<2 W "?? EXIT NOT ALLOWED" G TYPE "RTN","PRCSEB",14,0) K PRCVX,PRCVY "RTN","PRCSEB",15,0) S $P(^PRCS(410,DA,0),"^",4)=TYPE S:$G(PRCSIP) $P(^PRCS(410,DA,0),"^",6)=PRCSIP S (DIE,DIC)="^PRCS(410,",X=TYPE "RTN","PRCSEB",16,0) ;NOTE THAT THE FOLLOWING LINE OVERWRITES THE USER'S SELECTION OF FORM "RTN","PRCSEB",17,0) ;TYPE IF THE FUND CONTROL POINT IS NOT 'AUTOMATED' "RTN","PRCSEB",18,0) S:'$D(PRCS2)&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2 "RTN","PRCSEB",19,0) S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237B",X=3:"PRCSENPR",X=4:"PRCSENR&NR",1:"PRCSENIB")_"]" "RTN","PRCSEB",20,0) EN1 K DTOUT,DUOUT,Y S PRCSDAA=DA D ^DIE I $D(Y)!($D(DTOUT)) S DA=PRCSDAA L -^PRCS(410,DA) G EXIT "RTN","PRCSEB",21,0) S DA=PRCSDAA D RL^PRCSUT1 "RTN","PRCSEB",22,0) D ^PRCSCK I $D(PRCSERR),PRCSERR G EN1 "RTN","PRCSEB",23,0) K PRCSERR "RTN","PRCSEB",24,0) I PRCSDR="[PRCSENCOD]" D W7^PRCSEB0 D:$D(PRCSOB) ENOD1^PRCSEB1 K PRCSOB "RTN","PRCSEB",25,0) S:$P($G(^PRCS(410,DA,7)),"^")="" $P(^PRCS(410,DA,7),"^")=DUZ "RTN","PRCSEB",26,0) D:PRCSDR'="[PRCSENCOD]" W1 I $D(PRCS2),+^PRCS(410,DA,0) D W6 "RTN","PRCSEB",27,0) S DA=PRCSDAA L -^PRCS(410,DA) D W3 G EXIT:%'=1 W !! K PRCS,PRCS2 "RTN","PRCSEB",28,0) G ENRB "RTN","PRCSEB",29,0) W W !!,"This transaction is assigned transaction number: ",X Q "RTN","PRCSEB",30,0) W1 W !!,"Would you like to review this request" S %=2 D YN^DICN G W1:%=0 Q:%'=1 S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=PRCSZ K X,PRCSF,PRCSZ Q "RTN","PRCSEB",31,0) W2 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT "RTN","PRCSEB",32,0) W3 W !!,"Would you like to enter another request" S %=1 D YN^DICN G W3:%=0 Q "RTN","PRCSEB",33,0) W5 S:'$D(^PRCS(410,DA,11)) ^(11)="" S $P(^(11),U,3)="" K ^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$P($P(^PRCS(410,DA,0),U),"-",5),DA),^PRCS(410,"F1",$P($P(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA) Q "RTN","PRCSEB",34,0) W51 S:'$D(^PRCS(410,DA,11)) ^(11)="" S $P(^(11),U,3)=1,(^PRCS(410,"F",PRC("SITE")_"-"_+PRC("CP")_"-"_$P($P(^PRCS(410,DA,0),U),"-",5),DA),^PRCS(410,"F1",$P($P(^PRCS(410,DA,0),U),"-",5)_"-"_PRC("SITE")_"-"_+PRC("CP"),DA),^PRCS(410,"AQ",1,DA))="" Q "RTN","PRCSEB",35,0) W6 N JUMP,SKIPRNT,OK,TEST,TEST1,CURQTR,CURQTR1 "RTN","PRCSEB",36,0) W61 ; "RTN","PRCSEB",37,0) N REPORT2 I $P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),1,DUZ,0)),"^",2)'=1 S REPORT2=1 D T1^PRCSAPP1 "RTN","PRCSEB",38,0) ;*****PRC*5.1*174 start***** "RTN","PRCSEB",39,0) ;if Level of Access is not Control Point Official DO block "RTN","PRCSEB",40,0) I $P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),1,DUZ,0)),"^",2)'=1 D Q "RTN","PRCSEB",41,0) . N PRCFTYPE S PRCFTYPE=+$$GET1^DIQ(410,$G(DA)_",",3,"I") ;Form Type "RTN","PRCSEB",42,0) . S %=1 "RTN","PRCSEB",43,0) . ;if request is a 2237 (Form Type IEN 2,3, or 4) "RTN","PRCSEB",44,0) . I $G(PRCFTYPE)>1&($G(PRCFTYPE)<5) D "RTN","PRCSEB",45,0) . . ;don't allow approval of 2237 if Requesting Service OR any line item description is missing "RTN","PRCSEB",46,0) . . I '$$REQCHECK^PRCHJUTL($G(DA),,1) S %=2 "RTN","PRCSEB",47,0) . I $G(%)'=2 S %=1 W !,"Is this request ready for approval" D YN^DICN "RTN","PRCSEB",48,0) . D:%=1 W51 "RTN","PRCSEB",49,0) . D:%=0 W61 "RTN","PRCSEB",50,0) . D:%=2 W5 "RTN","PRCSEB",51,0) ;*****PRC*5.1*174 end****** "RTN","PRCSEB",52,0) S PRCSN=^PRCS(410,DA,0),PRCHQ=$P(PRCSN,"^",4),PRC("FY")=$P(PRCSN,"-",2),PRC("QTR")=$P(PRCSN,"-",3) "RTN","PRCSEB",53,0) S (CURQTR,CURQTR1)=PRC("QTR"),(JUMP,TEST,TEST1,OK)=0 "RTN","PRCSEB",54,0) D T1^PRCSAPP1 I OK=1 S SKIPRNT=1 D FINAL^PRCSAPP2 "RTN","PRCSEB",55,0) Q "RTN","PRCSEB",56,0) ;*81 Site Parameter Check "RTN","PRCSEB",57,0) CKPRM I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVX="I Y>1&(Y<5)",PRCVY="The form types 1358, Issue Book, and NO FORM are no longer used within this option." "RTN","PRCSEB",58,0) I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVX="I Y>1",PRCVY="The form types 1358 and NO FORM are no longer used within this option" "RTN","PRCSEB",59,0) Q "RTN","PRCSEB",60,0) ; "RTN","PRCSEB",61,0) EXIT K %,C,D,DA,DIC,DIE,DQ,DR,PRCS,PRCS2,PRCSDAA,PRCSDR,PRCSERR,PRCSL,PRCSTT,I,N,T,T1,T2,X,X1,PRCSX3,Y,Z Q "RTN","PRCSEB0") 0^19^B23160815^B22631602 "RTN","PRCSEB0",1,0) PRCSEB0 ;SF-ISC/LJP/SAW/DGL/DAP-CPA EDITS CON'T ;7/9/13 16:01 "RTN","PRCSEB0",2,0) V ;;5.1;IFCAP;**81,174**;Oct 20, 2000;Build 23 "RTN","PRCSEB0",3,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","PRCSEB0",4,0) EDTD ;EDIT TRANSACTION DATA "RTN","PRCSEB0",5,0) N TYPE,TYPE1,CHECK,JUMP S JUMP=1 "RTN","PRCSEB0",6,0) D EN3F^PRCSUT(1) G W2:'$D(PRC("SITE")),EXIT:Y<0 "RTN","PRCSEB0",7,0) S DIC="^PRCS(410,",DIE=DIC,DIC(0)="AEQM" S DIC("S")="I $P(^(0),U,4)'=1" S:$D(PRCSFT) DIC("S")="I $P(^(0),U,4)=1" "RTN","PRCSEB0",8,0) S DIC("S")=DIC("S")_",$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))" "RTN","PRCSEB0",9,0) D ^PRCSDIC G EXIT:Y<0 K DIC("S") S (DA,PRCSDAA,PRCSY,T1)=+Y L +^PRCS(410,DA):15 G EDTD:$T=0 "RTN","PRCSEB0",10,0) S TYPE=$P(^PRCS(410,DA,0),"^",4) "RTN","PRCSEB0",11,0) EDTD1 S X=^PRCS(410,DA,0) S:+X PRC("FY")=$P(X,"-",2),PRC("QTR")=+$P(X,"-",3) S PRCSX3=$P(X,"^",2) G ASK:PRCSX3="" I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),"^",11)="Y" S PRCS2=1 "RTN","PRCSEB0",12,0) EDTD3 I $D(^PRCS(410,DA,7)),$P(^(7),U,6)]"" G EDTD4 "RTN","PRCSEB0",13,0) I $D(PRCSEM) S DIE=DIC,DR="[PRCSENMDR]" D ^DIE S DA=T1 L -^PRCS(410,DA) G EXIT "RTN","PRCSEB0",14,0) I PRCSX3'="O" S DR=$S(PRCSX3="C"&('$D(PRCS2)):"[PRCSENC]",PRCSX3="C"&($D(PRCS2)):"[PRCSENCI]",PRCSX3="A":"[PRCSENA]",1:"[PRCSENCT]") S:PRCSX3="A"&($P(^PRCS(410,PRCSY,0),U,4)=1) DR="[PRCSENA 1358]" S DIE=DIC D ^DIE S DA=PRCSY "RTN","PRCSEB0",15,0) D:PRCSX3="A"&($O(^PRCS(410,PRCSY,12,0))) SCPC0^PRCSED "RTN","PRCSEB0",16,0) I PRCSX3="A",$P(^PRCS(410,DA,0),U,4)=1 S X=$P(^(4),U,6),X1=$P(^(3),U,7) I $J(X,0,2)'=$J(X1,0,2)!('X)!('X1) W $C(7),!,"Adj $ Amt does not equal the total of BOC $ Amts.",!,"Please correct the error.",! K DR G EDTD3 "RTN","PRCSEB0",17,0) I PRCSX3="A",$P(^PRCS(410,DA,0),"^",4)=1 D W6^PRCSEB "RTN","PRCSEB0",18,0) I PRCSX3'="O" G EDTD2 "RTN","PRCSEB0",19,0) EDTD4 I $D(^PRCS(410,DA,7)),$P(^(7),"^",6)'="" S DR="[PRCSEDS]" D ^DIE D W1 G EDTD2 "RTN","PRCSEB0",20,0) EDTD5 ;*81 Loop now checks site parameter to see if Issue Books should be allowed "RTN","PRCSEB0",21,0) S X=+$P(^PRCS(410,DA,0),"^",4) I X<2 D "RTN","PRCSEB0",22,0) .I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVX="I Y>1&(Y<5)",PRCVY="The 1358, Issue Book, and NO FORM types are not valid for use in this option." "RTN","PRCSEB0",23,0) .I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVX="I Y>1",PRCVY="The 1358 and NO FORM types are not valid for use in this option." "RTN","PRCSEB0",24,0) .W !,PRCVY,! "RTN","PRCSEB0",25,0) .W !,"Please enter another form type.",! "RTN","PRCSEB0",26,0) .S PRCDAA=DA,DIC="^PRCS(410.5,",DIC("A")="FORM TYPE: ",DIC(0)="AEQZ",DIC("S")=PRCVX,DIC("B")=4 D ^DIC S:Y=-1 Y=4 S DA=PRCDAA K DIC "RTN","PRCSEB0",27,0) .K PRCVX,PRCVY "RTN","PRCSEB0",28,0) .S $P(^PRCS(410,DA,0),"^",4)=+Y,X=+Y "RTN","PRCSEB0",29,0) I $G(PRCSIP) S $P(^PRCS(410,DA,0),"^",6)=PRCSIP "RTN","PRCSEB0",30,0) I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVZ=1 "RTN","PRCSEB0",31,0) I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVZ=0 "RTN","PRCSEB0",32,0) W !,"The form type for this transaction is ",$P($G(^PRCS(410.5,X,0)),"^"),! "RTN","PRCSEB0",33,0) I PRCVZ=1,X=5 W !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP Issue Book order." D W3 G:%'=1 EXIT W !! K PRCS,PRCS2 G EDTD "RTN","PRCSEB0",34,0) ;P182--Removed reference to TEMPREQ in following line: no longer used. "RTN","PRCSEB0",35,0) ;Q:$D(TEMPREQ) S (DIC,DIE)="^PRCS(410," "RTN","PRCSEB0",36,0) K PRCVZ "RTN","PRCSEB0",37,0) S (DIC,DIE)="^PRCS(410," "RTN","PRCSEB0",38,0) G EDTD2:X="" "RTN","PRCSEB0",39,0) S (PRCSDR,DR)="["_$S(X=2:"PRCSEN2237B",X=3:"PRCSENPR",X=4:"PRCSENR&NR",1:"PRCSENIB")_"]" "RTN","PRCSEB0",40,0) ED1 K DTOUT,DUOUT,Y S PRCSDAA=DA D ^DIE I $D(DTOUT) S DA=PRCSDAA G EXIT "RTN","PRCSEB0",41,0) S DA=PRCSDAA D RL^PRCSUT1 "RTN","PRCSEB0",42,0) D ^PRCSCK I $D(PRCSERR),PRCSERR G ED1 "RTN","PRCSEB0",43,0) K PRCSERR "RTN","PRCSEB0",44,0) I PRCSDR="[PRCSENCOD]" D W7 D:$D(PRCSOB) ENOD1^PRCSEB1 K PRCSOB "RTN","PRCSEB0",45,0) S:$P($G(^PRCS(410,DA,7)),U)="" $P(^PRCS(410,DA,7),U)=DUZ,$P(^PRCS(410,DA,7),U,2)=$P($G(^VA(200,DUZ,20)),U,3) "RTN","PRCSEB0",46,0) ; "RTN","PRCSEB0",47,0) ;if 2237 required field checks fail, warn user (PRC*5.1*174) "RTN","PRCSEB0",48,0) I PRCSDR'="[PRCSENCOD]",'$$REQCHECK^PRCHJUTL($G(DA),,1) "RTN","PRCSEB0",49,0) ; "RTN","PRCSEB0",50,0) D:PRCSDR'="[PRCSENCOD]" W1 I $D(PRCS2),+^PRCS(410,DA,0) D W6^PRCSEB "RTN","PRCSEB0",51,0) EDTD2 S DA=PRCSDAA L -^PRCS(410,DA) G EXIT:$D(PRCSQ) D W3 G EXIT:%'=1 W !! K PRCS,PRCS2 G EDTD "RTN","PRCSEB0",52,0) ASK W !!,"This transaction does not have a valid transaction type (e.g.,O for Obligation, A for Adjustment, C for Ceiling). Please enter one now.",! S DR="1" D ^DIE K DR G EDTD1 "RTN","PRCSEB0",53,0) W1 W !!,"Would you like to review this request" S %=2 D YN^DICN G W1:%=0 Q:%'=1 S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=PRCSZ K X,PRCSF,PRCSZ Q "RTN","PRCSEB0",54,0) W2 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 G EXIT "RTN","PRCSEB0",55,0) W3 W !!,"Would you like to edit another request" S %=1 D YN^DICN G W3:%=0 Q "RTN","PRCSEB0",56,0) W7 W !,"Do you wish to enter obligation data" S %=1 D YN^DICN Q:%=-1!(%=2) G W7:%=0 S:%=1 PRCSOB=1 Q "RTN","PRCSEB0",57,0) EXIT K %,C,D,DA,DIC,DIE,DQ,DR,PRCS,PRCS2,PRCSDAA,PRCSDR,PRCSL,PRCSTT,I,N,T,T1,T2,X,X1,PRCSX3,Y,Z,Z7,PRCVZ Q "RTN","PRCSECP") 0^22^B39428501^B28930970 "RTN","PRCSECP",1,0) PRCSECP ;SFISC/KSS,LJP/DAP - COPY A TRANSACTION ;7/9/13 16:02 "RTN","PRCSECP",2,0) V ;;5.1;IFCAP;**81,148,174**;Oct 20, 2000;Build 23 "RTN","PRCSECP",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCSECP",4,0) A I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y "RTN","PRCSECP",5,0) W @IOF,!! "RTN","PRCSECP",6,0) B D EN3^PRCSUT ;GO GET STATION AND CONTROL POINT "RTN","PRCSECP",7,0) I '$D(PRC("SITE"))!('$D(PRC("CP")))!(Y<0)!('$D(X))!($G(X)[U) D END Q "RTN","PRCSECP",8,0) N GET,GET1 S DIC="^PRCS(410,",DIC(0)="AEQM" "RTN","PRCSECP",9,0) S DIC("S")="S PRCST=$P(^(0),U,2) I $D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2))) I PRCST=""O""!(PRCST=""CA"")" "RTN","PRCSECP",10,0) S DIC("A")="Select the Transaction to be copied: " "RTN","PRCSECP",11,0) C W ! D ^PRCSDIC K PRCST "RTN","PRCSECP",12,0) I (X[U)!(Y<0) D END Q "RTN","PRCSECP",13,0) S DA=+Y "RTN","PRCSECP",14,0) S PRCVFT=$P(^PRCS(410,DA,0),"^",4) "RTN","PRCSECP",15,0) ;if 2237 transaction (Form Type IEN 2,3, or 4), do required field checks (PRC*5.1*174) "RTN","PRCSECP",16,0) I $G(PRCVFT)>1&($G(PRCVFT)<5) D "RTN","PRCSECP",17,0) . N PRCWARN "RTN","PRCSECP",18,0) . ;warn user if required fields are missing from transaction that is going to be copied "RTN","PRCSECP",19,0) . I '$$REQCHECK^PRCHJUTL($G(DA),.PRCWARN) D "RTN","PRCSECP",20,0) . . W !?15,"********** WARNING **********",*7,! "RTN","PRCSECP",21,0) . . W !,"Transaction to be copied ("_$$GET1^DIQ(410,$G(DA),.01)_") is missing required data!" "RTN","PRCSECP",22,0) . . N PRCIDX S PRCIDX=0 "RTN","PRCSECP",23,0) . . F S PRCIDX=$O(PRCWARN(PRCIDX)) Q:'PRCIDX D "RTN","PRCSECP",24,0) . . . W !?2,">>> "_$G(PRCWARN(PRCIDX)) "RTN","PRCSECP",25,0) . . W !,"This data will be required when entering information for the" "RTN","PRCSECP",26,0) . . W !,"new transaction number.",! "RTN","PRCSECP",27,0) ; "RTN","PRCSECP",28,0) ;prompt user to review this request "RTN","PRCSECP",29,0) D W1 "RTN","PRCSECP",30,0) ; "RTN","PRCSECP",31,0) ;*81 Check site parameter to see if Issue Books are allowed "RTN","PRCSECP",32,0) I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVZ=1 "RTN","PRCSECP",33,0) I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVZ=0 "RTN","PRCSECP",34,0) I PRCVZ=1,PRCVFT=5 W !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP issue book order." D W3 G:%'=1 END W !! K PRCS,PRCS2 G B "RTN","PRCSECP",35,0) ; "RTN","PRCSECP",36,0) PROCEED ;modified prompt and added help (PRC*5.1*174) "RTN","PRCSECP",37,0) W !!,"Would you like to proceed with copying this request" "RTN","PRCSECP",38,0) S %=1 D YN^DICN "RTN","PRCSECP",39,0) I %=0 D G PROCEED "RTN","PRCSECP",40,0) . W !?2,"Enter 'Yes' to proceed with copying transaction "_$$GET1^DIQ(410,$G(DA),.01)_"." "RTN","PRCSECP",41,0) . W !?2,"Enter 'No' or '^' to abort copying this transaction." "RTN","PRCSECP",42,0) I %'=1 D G C "RTN","PRCSECP",43,0) . W !!?2,">>> Transaction "_$$GET1^DIQ(410,$G(DA),.01)_" data was not copied.",! "RTN","PRCSECP",44,0) ; "RTN","PRCSECP",45,0) S DIC="^PRCS(410," L +^PRCS(410,DA):15 G END:$T=0 "RTN","PRCSECP",46,0) S T1=DA,T2=^PRCS(410,DA,0),T5=$P(T2,U,4),T4=$P(T2,U,2),T2=$P(T2,U),T3=$P(^(3),U) "RTN","PRCSECP",47,0) K ^TMP($J) "RTN","PRCSECP",48,0) S ^TMP($J,"OLDDA")=DA,^("OLDTXN")=$P(T2,U,1),^("OLDFCP")=PRC("CP") "RTN","PRCSECP",49,0) W !!,"Now enter the information for the new transaction number.",! "RTN","PRCSECP",50,0) ;L -^PRCS(410,DA) "RTN","PRCSECP",51,0) K DA,DIC,Y D EN1^PRCSUT K DA,DIC "RTN","PRCSECP",52,0) I ('$D(PRC("SITE")))!('$D(PRC("QTR")))!('$D(PRC("CP"))) G UNLKEND "RTN","PRCSECP",53,0) I $P($G(^PRCS(410,T1,0)),"^",4)=1,$$Q1358^PRCEN(PRC("SITE"),PRC("CP")) G UNLKEND "RTN","PRCSECP",54,0) S X1=X,PRCSAPP=$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,3) "RTN","PRCSECP",55,0) I PRC("CP")'=T3,PRCSAPP["_" D PRCFY^PRCSUT2 I (PRCSAPP["_") G UNLKEND "RTN","PRCSECP",56,0) S X=X1 D EN1^PRCSUT3 I 'X G UNLKEND "RTN","PRCSECP",57,0) S X1=X D EN2^PRCSUT3 I ('$D(X1)) G UNLKEND "RTN","PRCSECP",58,0) S (X,^TMP($J,"NEWTXN"))=X1 "RTN","PRCSECP",59,0) W !!,"This transaction is assigned transaction number: ",X "RTN","PRCSECP",60,0) ;L +^PRCS(410,DA):15 G B:$T=0 "RTN","PRCSECP",61,0) I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),U,11)="Y" PRCS2=1 "RTN","PRCSECP",62,0) TYPE ; "RTN","PRCSECP",63,0) S PRCSX=$P(^PRCS(410,T1,0),"^",4) "RTN","PRCSECP",64,0) ;*81 Check site parameter to see if issue books should be allowed "RTN","PRCSECP",65,0) I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVX="I Y>(.5)&(Y<5)",PRCVY="The Issue Book and NO FORM types are no longer used." "RTN","PRCSECP",66,0) I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVX="I Y>(.5)",PRCVY="The NO FORM type is no longer used." "RTN","PRCSECP",67,0) I PRCSX<1 W !,PRCVY,!,"Please enter another form type.",! S PRCDAA=DA,DIC="^PRCS(410.5,",DIC("S")=PRCVX,DIC("A")="FORM TYPE: ",DIC(0)="AEQZ" D ^DIC S:Y=-1 Y=2 S DA=PRCDAA,PRCSX=+Y "RTN","PRCSECP",68,0) S (DIE,DIC)="^PRCS(410," "RTN","PRCSECP",69,0) K PRCVX,PRCVY "RTN","PRCSECP",70,0) S $P(^PRCS(410,DA,0),"^",4)=PRCSX "RTN","PRCSECP",71,0) W !,"The form type for this request is: ",$P($G(^PRCS(410.5,PRCSX,0)),"^"),! "RTN","PRCSECP",72,0) W !,?10,"Transaction data is being copied...",! "RTN","PRCSECP",73,0) D @$S(PRCSX=1:"S1^PRCSECP1",1:"S2^PRCSECP1") S DIK="^PRCS(410," D IX^DIK "RTN","PRCSECP",74,0) S (DIC,DIE)="^PRCS(410," "RTN","PRCSECP",75,0) ;P182--removed warning about changed CC/BOC;replaced w/following call "RTN","PRCSECP",76,0) S X=$$CHGCCBOC^PRCSCK(^TMP($J,"OLDTXN"),^TMP($J,"NEWTXN"),^TMP($J,"OLDFCP"),0) "RTN","PRCSECP",77,0) S X=PRCSX S:'$D(PRCS2)&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2 "RTN","PRCSECP",78,0) S (PRCSDR,DR)="["_$S(X=1:"PRCE NEW 1358",X=2:"PRCSEN2237B",X=3:"PRCSENPR",X=4:"PRCSENR&NR",X=5:"PRCSENIB",1:"PRCSENCOD")_"]" "RTN","PRCSECP",79,0) D K DTOUT,DUOUT,Y S COPYDA=DA D ^DIE I $D(Y)!($D(DTOUT)) S DA=COPYDA G END "RTN","PRCSECP",80,0) S DA=COPYDA D RL^PRCSUT1 "RTN","PRCSECP",81,0) D ^PRCSCK I $D(PRCSERR),PRCSERR G D "RTN","PRCSECP",82,0) K PRCSERR "RTN","PRCSECP",83,0) I PRCSDR="[PRCSENCOD]" D W7^PRCSEB0 D:$D(PRCSOB) ENOD1^PRCSEB1 K PRCSOB "RTN","PRCSECP",84,0) D:PRCSDR'="[PRCSENCOD]" W1 I PRCSDR'="[PRCSENCOD]",$D(PRCS2),+^PRCS(410,DA,0) D W6^PRCSEB "RTN","PRCSECP",85,0) S DA=COPYDA L -^PRCS(410,DA) D W3 G END:%'=1 W !! K PRCS,PRCS2 "RTN","PRCSECP",86,0) G B "RTN","PRCSECP",87,0) ; "RTN","PRCSECP",88,0) UNLKEND S DA=^TMP($J,"OLDDA") L -^PRCS(410,DA) "RTN","PRCSECP",89,0) END K %,D0,DA,DIC,DIE,DIK,DR,N,P,PRCSAPP,COPYDA,PRCSDR,PRCSERR,PRCSI,PRCSIP,PRCSJ,PRCSJ,PRCSL,PRCST1,PRCSTMP,PRCSTT,PRCSX,PRCSZ,T1,T2,T3,T4,T5,X,X1,Y,PRCVZ,PRCVFT "RTN","PRCSECP",90,0) K ^TMP($J) "RTN","PRCSECP",91,0) Q "RTN","PRCSECP",92,0) W1 W !!,"Would you like to review this request" S %=2 D YN^DICN G W1:%=0 Q:%'=1 S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=PRCSZ K X,PRCSF,PRCSZ Q "RTN","PRCSECP",93,0) W3 W !!,"Would you like to copy another request" S %=1 D YN^DICN G W3:%=0 Q "RTN","PRCSECP",94,0) ; "RTN","PRCSECP",95,0) GETCCCNT(STA,FCP) ;How many valid Cost Centers for this Control Point "RTN","PRCSECP",96,0) ;return count and first CC "RTN","PRCSECP",97,0) N GOODCC,CC,FIRSTCC "RTN","PRCSECP",98,0) S GOODCC=0,(CC,FIRSTCC)="" "RTN","PRCSECP",99,0) F S CC=$O(^PRC(420,+STA,1,+FCP,2,CC)) Q:CC="" D "RTN","PRCSECP",100,0) . I $$VALIDCC(STA,FCP,CC) S GOODCC=GOODCC+1 I FIRSTCC="" S FIRSTCC=$E($P(^PRCD(420.1,+CC,0),U,1),1,23) "RTN","PRCSECP",101,0) Q GOODCC_"^"_FIRSTCC "RTN","PRCSECP",102,0) ; "RTN","PRCSECP",103,0) VALIDCC(STA,FCP,CC) ;Is this STATION,FCP,COST CENTER combination valid? "RTN","PRCSECP",104,0) ;To be valid, station/FCP must point to CC, CC must be active,CC must "RTN","PRCSECP",105,0) ;point to some active BOC "RTN","PRCSECP",106,0) N X,VALID,BOC,GOODBOC "RTN","PRCSECP",107,0) S BOC="",GOODBOC=0 "RTN","PRCSECP",108,0) S X=$G(^PRC(420,+STA,1,+FCP,2,+CC,0)) I (+X=+CC) D ;FCP => CC "RTN","PRCSECP",109,0) . S X=$G(^PRCD(420.1,CC,0)) I X]"",'$P(X,U,2) D ; CC IS ACTIVE "RTN","PRCSECP",110,0) .. F S BOC=$O(^PRCD(420.1,+CC,1,BOC)) Q:BOC=""!GOODBOC D "RTN","PRCSECP",111,0) ... S X=$G(^PRCD(420.2,+BOC,0)) I X]"",'$P(X,U,2) S GOODBOC=1 "RTN","PRCSECP",112,0) Q GOODBOC "RTN","PRCSECP",113,0) ; "RTN","PRCSECP",114,0) GETBOCNT(STA,FCP,CC) ;How many valid BOCs for this STATION,FCP,COST CENTER "RTN","PRCSECP",115,0) ;To be valid, station/FCP must point to CC, CC must be active,CC must "RTN","PRCSECP",116,0) ;point to some active BOC "RTN","PRCSECP",117,0) N X,VALID,BOC,GOODBOC,TOTBOCS,FIRSTBOC "RTN","PRCSECP",118,0) S BOC="",GOODBOC=0,TOTBOCS=0,FIRSTBOC="" "RTN","PRCSECP",119,0) S X=$G(^PRC(420,+STA,1,+FCP,2,+CC,0)) I (+X=+CC) D ;FCP => CC "RTN","PRCSECP",120,0) . S X=$G(^PRCD(420.1,CC,0)) I X]"",'$P(X,U,2) D ; CC IS ACTIVE "RTN","PRCSECP",121,0) .. F S BOC=$O(^PRCD(420.1,+CC,1,BOC)) Q:BOC="" D "RTN","PRCSECP",122,0) ... S X=$G(^PRCD(420.2,+BOC,0)) I X]"",'$P(X,U,2) D "RTN","PRCSECP",123,0) .... S TOTBOCS=TOTBOCS+1 I FIRSTBOC="" S FIRSTBOC=$E($P(^PRCD(420.2,+BOC,0),U,1),1,23) "RTN","PRCSECP",124,0) Q TOTBOCS_"^"_FIRSTBOC "RTN","PRCSECP",125,0) ; "RTN","PRCSECP",126,0) VALIDBOC(STA,FCP,CC,BOC) ;Is this STATION,FCP,COST CENTER,BOC VALID? "RTN","PRCSECP",127,0) ;To be valid, station/FCP must point to CC, CC must be active,CC must "RTN","PRCSECP",128,0) ;point to BOC,and BOC must be active "RTN","PRCSECP",129,0) N X,VALID,GOODBOC "RTN","PRCSECP",130,0) S GOODBOC=0 "RTN","PRCSECP",131,0) S X=$G(^PRC(420,+STA,1,+FCP,2,+CC,0)) "RTN","PRCSECP",132,0) I (+X=+CC) S X=$G(^PRCD(420.1,+CC,0)) I X]"",'$P(X,U,2) D "RTN","PRCSECP",133,0) . S X=$G(^PRCD(420.1,+CC,1,+BOC,0)) "RTN","PRCSECP",134,0) . I X]"" S X=$G(^PRCD(420.2,+BOC,0)) I X]"",'$P(X,U,2) S GOODBOC=1 "RTN","PRCSECP",135,0) Q GOODBOC "RTN","PRCSECP",136,0) ; "RTN","PRCSP12") 0^9^B8060908^B8040343 "RTN","PRCSP12",1,0) PRCSP12 ;WISC/SAW-CONTROL POINT ACTIVITY 2237 PRINTOUT (FREE FORM) ;2/13/13 13:04 "RTN","PRCSP12",2,0) V ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23 "RTN","PRCSP12",3,0) ;Per VHA Directive 2004-38, this routine should not be modified. "RTN","PRCSP12",4,0) H 2 G P "RTN","PRCSP12",5,0) QUE I $D(ZTQUEUED) S DA=D0 "RTN","PRCSP12",6,0) S DA=D0 "RTN","PRCSP12",7,0) P U IO W:$Y>0 @IOF S U="^",P(1)=0,PRCS("P")=1,L="",$P(L,"_",90)="_" D NOW^%DTC S Y=% D DD^%DT "RTN","PRCSP12",8,0) S P=$S($D(^PRCS(410,DA,1)):$P(^(1),U,3),1:""),P=$S(P="EM":"***EMERGENCY***",P="SP":"*SPECIAL*",1:"STANDARD") W ?36,"PRIORITY: ",P "RTN","PRCSP12",9,0) W:$$ECMS2237^PRCHJUTL(DA) ?64,"Accepted by eCMS" "RTN","PRCSP12",10,0) W !,Y,?36,$P(^PRCS(410,DA,0),U),?83,"PAGE ",PRCS("P"),!,L "RTN","PRCSP12",11,0) W !,?16,"REQUEST, TURN-IN, AND RECEIPT FOR PROPERTY OR SERVICES",! I $D(ZTSAVE("NOPRINT")) W ?37,"**REPRINT**",! "RTN","PRCSP12",12,0) W !,L "RTN","PRCSP12",13,0) W !,"TO: A&MM Officer",?23,"|Requesting Office",?63,"|TO BE COMPLETED BY" "RTN","PRCSP12",14,0) W !,?23,"|" S P=$P(^PRCS(410,DA,0),U,5),P1=$S($D(^(3)):+$P(^(3),U),1:"") I P,P1 S P=$S($D(^PRC(420,P,1,P1,0)):$P(^(0),U,10),1:"") I P,$D(^DIC(49,P,0)) W $P(^(0),U) W:$P(^(0),U,8)]"" " ("_$P(^(0),U,8)_")" "RTN","PRCSP12",15,0) W ?63,"|SUPPLY PERSONNEL",!,$E(L,1,23) "RTN","PRCSP12",16,0) W "|",$E(L,1,39) "RTN","PRCSP12",17,0) W "|(NOTE - Alterations in" "RTN","PRCSP12",18,0) W !,"Action Requested",?23,"|Date Prepared",?45,"|Date Required",?63,"|""Action"" column will be" "RTN","PRCSP12",19,0) W !,?4,"Delivery",?23,"|" I $D(^PRCS(410,DA,1)),$P(^(1),U)'="" S Y=$P(^(1),U) D DD^%DT W Y "RTN","PRCSP12",20,0) W ?45,"|" I $D(^PRCS(410,DA,1)),$P(^(1),U,4)'="" S Y=$P(^(1),U,4) D DD^%DT W Y "RTN","PRCSP12",21,0) W ?63,"|initialed and dated)",!,$E(L,1,23) "RTN","PRCSP12",22,0) W "|",$E(L,1,21) "RTN","PRCSP12",23,0) W "|",$E(L,1,17) "RTN","PRCSP12",24,0) W "|",$E(L,1,26) "RTN","PRCSP12",25,0) W !,?2,"ITEM NO. |",?23,"DESCRIPTION",?38,"|QUANTITY |UNIT|ESTIMATED|UNIT COST|TOTAL COST|ACT." "RTN","PRCSP12",26,0) W !,"OR STOCK NO.|",?38,"|",?48,"|",?53,"|UNIT COST|",?73,"|",?84,"|NOTE1",!,$E(L,1,12),"|",$E(L,1,25),"|",$E(L,1,9),"|",$E(L,1,4),"|",$E(L,1,9),"|",$E(L,1,9),"|",$E(L,1,10),"|",$E(L,1,5) "RTN","PRCSP12",27,0) S:'$D(PRNTALL) PRNTALL=1 "RTN","PRCSP12",28,0) D ^PRCSP121,^PRCSP122 W:PRNTALL=0 !,"VA FORM 90-2237-ADP MAR 1985",! D:PRNTALL=1 ^PRCSP123 I '$D(PRCHQ("DEST")) D ^PRCSP124 G EXIT "RTN","PRCSP12",29,0) I $D(PRCHQ("DEST")),PRCHQ("DEST")'="F" D ^PRCSP124 "RTN","PRCSP12",30,0) EXIT K FPROJ,%DT,P,PRNTALL,X,X1,Y,Z,Z1,DA,DIWL,DIWR,DIWF,I,J,K,L,PRCS,^UTILITY($J,"W") D:$D(ZTSK) KILL^%ZTLOAD Q "RTN","PRCSP13") 0^24^B22261437^B20364908 "RTN","PRCSP13",1,0) PRCSP13 ;BOISE/TKE,WISC/SAW-CPA PRINTS CON'T-TRANSACTION STATUS REPORT ;7/26/13 15:22 "RTN","PRCSP13",2,0) V ;;5.1;IFCAP;**174**;Oct 20, 2000;Build 23 "RTN","PRCSP13",3,0) ;Per VHA Directive 10-93-142, this routine should not be modified. "RTN","PRCSP13",4,0) U IO S U="^",PRCS0=$S($D(^PRCS(410,DA,0)):^(0),1:""),PRCSS=IOSL-2 "RTN","PRCSP13",5,0) S PRCSTC=$P(PRCS0,"^",2),PRCSTP="" I PRCSTC'="" S X=$P(^DD(410,1,0),U,3) F I=1:1 S Y=$P(X,";",I) Q:Y="" I $P(Y,":")=PRCSTC S PRCSTP=$P(Y,":",2) Q "RTN","PRCSP13",6,0) S PRCSEX="" D HDR "RTN","PRCSP13",7,0) CA I PRCSTC="CA" D G EX "RTN","PRCSP13",8,0) . I $P($G(^PRCS(410,DA,1)),U,9)>0 D "RTN","PRCSP13",9,0) . . N PRCDATA,PRCIEN S PRCIEN=DA_"," D GETS^DIQ(410,PRCIEN,"104;105","E","PRCDATA") "RTN","PRCSP13",10,0) . . W !,"Cancel By: ",PRCDATA(410,PRCIEN,104,"E"),?49,"Cancel Dt: ",$TR($P(PRCDATA(410,PRCIEN,105,"E"),":",1,2),"@"," ") "RTN","PRCSP13",11,0) . . S PRCSDY=PRCSDY+1 "RTN","PRCSP13",12,0) . W ! S PRCSDY=PRCSDY+1 D COM^PRCSP131 "RTN","PRCSP13",13,0) C G A:PRCSTC="A",O:PRCSTC="O" S PRCS6=$S($D(^PRCS(410,DA,6)):^(6),1:"") "RTN","PRCSP13",14,0) W !,"Ceiling $ Amount: $",$J(+$P(PRCS6,U),0,2),?41,"Date Allocated: " S Y=$P(PRCS6,U,2) X:Y ^DD("DD") W Y "RTN","PRCSP13",15,0) W !,"Fund Control Point Dist. No.: ",$P(PRCS6,U,3) S PRCS6=$S($D(^PRCS(410,DA,4)):^(4),1:"") W !,"Reference Number: ",$P(PRCS6,U,5) K PRCS6 D ACC S PRCSDY=8 D COM^PRCSP131 G EX "RTN","PRCSP13",16,0) A D VND "RTN","PRCSP13",17,0) S PRCS4=$S($D(^PRCS(410,DA,4)):^(4),1:"") W !,"Purchase Order/Obligation No.: ",$P(PRCS4,U,5),?41,"Adjustment $ Amount: $",$J($P(PRCS4,U,6),0,2) "RTN","PRCSP13",18,0) S Y=$P(PRCS4,U,7) X:Y ^DD("DD") W !,"Date Obl.Adjusted: ",Y K PRCS4 "RTN","PRCSP13",19,0) D ACC S X=$S($D(^PRCS(410,DA,11)):$P(^(11),U),1:"") S:$P(X,";") X=$P(X,";",2)_$P(X,";"),X="^"_X_",0)",X=$S($D(@X):$P(^(0),U),1:"") W !,"Sort Group: ",X "RTN","PRCSP13",20,0) S PRCS1=$S($D(^PRCS(410,DA,1)):^(1),1:"") W ?41,"Classification of Request: " S X=$S($D(^PRCS(410.2,+$P(PRCS1,U,5),0)):$E($P(^(0),U),1,22),1:"") W X K PRCS1 "RTN","PRCSP13",21,0) S PRCSDY=4 D SUBC^PRCSP132 G EX:PRCSEX[U D:PRCSDY>(PRCSS-4) S G EX:PRCSEX[U "RTN","PRCSP13",22,0) S PRCSDY=PRCSDY+5 D:PRCSDY>(PRCSS-1) S G EX:PRCSEX[U D COM^PRCSP131 G EX "RTN","PRCSP13",23,0) O ; "RTN","PRCSP13",24,0) S D0=DA D STATUS^PRCSES W !,"A&MM Status: ",X I $D(^PRCS(410,DA,10)),$D(^PRC(442,+$P(^(10),U,3),1)),$D(^VA(200,+$P(^(1),U,10),20)) W ?41,"PA/PPM: ",$P(^(20),U,2) "RTN","PRCSP13",25,0) W !,"Temporary Trans. Number: ",$P(PRCS0,U,3) W:'PRCS0 ?41,"Control Point: ",$E($P(^PRCS(410,DA,3),U),1,24) "RTN","PRCSP13",26,0) W !,"Form Type: ",$S($D(^PRCS(410.5,+$P(PRCS0,U,4),0)):$P(^(0),U),1:"") I $P(PRCS0,U,4)=1,$P(PRCS0,U,8) W ?41,"Month of 1358: ",$P("JAN^FEB^MAR^APR^MAY^JUN^JUL^AUG^SEP^OCT^NOV^DEC",U,$P(PRCS0,U,8)) "RTN","PRCSP13",27,0) S PRCS1=$S($D(^PRCS(410,DA,1)):^(1),1:"") W !,"Date of Request: " S Y=$P(PRCS1,U) X:Y ^DD("DD") W Y W ?41,"Date Required: " S Y=$P(PRCS1,U,4) X:Y ^DD("DD") W Y "RTN","PRCSP13",28,0) S PRCS9=$S($D(^PRCS(410,DA,9)):^(9),1:"") W !,"Est. Delivery Date: " S Y=$P(PRCS9,U,2) X:Y ^DD("DD") W Y W ?41,"Date Received: " S Y=$P(PRCS9,U,3) X:Y ^DD("DD") W Y "RTN","PRCSP13",29,0) D VND S PRCS4=$S($D(^PRCS(410,DA,4)):^(4),1:"") "RTN","PRCSP13",30,0) W !,"Committed (Estimated) Cost: $",$J($P(PRCS4,U),0,2),?41,"Date Committed: " S Y=$P(PRCS4,U,2) X:Y ^DD("DD") W Y "RTN","PRCSP13",31,0) W !,"Obligated (Actual) Cost: $",$J($P(PRCS4,U,3),0,2),?41,"Date Obligated: " S Y=$P(PRCS4,U,4) X:Y ^DD("DD") W Y "RTN","PRCSP13",32,0) W !,"Purchase Order/Obligation No.: ",$P(PRCS4,U,5) K PRCS4 "RTN","PRCSP13",33,0) D ACC W !,"Return to Service Comments:" W:$D(^PRCS(410,DA,13,1,0)) $E(^(0),1,80),! W !,"Comments:" W:$D(^PRCS(410,DA,"CO",1,0)) $E(^(0),1,80),! S PRCSDY=20 D ^PRCSP131,^PRCSP133 G EX "RTN","PRCSP13",34,0) VND W !,"Vendor: ",$S($D(^PRCS(410,DA,2)):$E($P(^(2),U),1,30),1:"") "RTN","PRCSP13",35,0) S PRCSVND=$S($D(^PRC(442,+$S($D(^PRCS(410,DA,10)):$P(^(10),U,3),1:""),1)):$P(^(1),U),1:"") I $D(^PRCS(410,DA,3)),$P(^(3),U,4)'=PRCSVND W ?41,"P.O. Vendor: ",$S($D(^PRC(440,+PRCSVND,0)):$E($P(^(0),U),1,20),1:"") "RTN","PRCSP13",36,0) Q "RTN","PRCSP13",37,0) ACC W ?41,"Accounting Data: ",$S($D(^PRCS(410,DA,3)):$P(^(3),U,2),1:"") "RTN","PRCSP13",38,0) S PRCS5=$S($D(^PRCS(410,DA,5)):^(5),1:"") W !,"FMS $ Amount: $",$J($P(PRCS5,U),0,2) S Y=$P(PRCS5,U,2) X:Y ^DD("DD") W ?41,"FMS Date: ",Y W !,"FMS Transaction Code: ",$P(PRCS5,U,3) K PRCS5 Q "RTN","PRCSP13",39,0) HDR W @IOF D NOW^%DTC S Y=% X:Y ^DD("DD") W ?10,PRCSTP," TRANSACTION STATUS DISPLAY ",Y,!! "RTN","PRCSP13",40,0) W "Transaction Number: ",$P(PRCS0,U),?41,"Transaction Type: ",PRCSTP S X="",PRCSDY=3 Q "RTN","PRCSP13",41,0) S Q:$D(ZTQUEUED) G S2:$E(IOST)'="C" F L=PRCSDY:1:PRCSS W ! "RTN","PRCSP13",42,0) W !,"Press return to continue or ""^"" to escape" R X:DTIME S:'$T X="^" S PRCSEX=X Q:X[U "RTN","PRCSP13",43,0) S2 D HDR Q "RTN","PRCSP13",44,0) EX D:$D(ZTSK) KILL^%ZTLOAD K ZTSK "RTN","PRCSP13",45,0) EXIT K PRCS0,PRCSTC,PRCSTP,PRCSI,PRCSJ,PRCSEX,DA,PRCSS,PRCSDY,DIWL,DIWR,DIWF,I,J,L,X,Y,Z,^TMP($J) D ^%ZISC Q "RTN","PRCSUT2") 0^18^B58831488^B52607046 "RTN","PRCSUT2",1,0) PRCSUT2 ;WISC/SAW/CTB/DXH - TRANSACTION UTILITY ;5/20/13 16:22 "RTN","PRCSUT2",2,0) V ;;5.1;IFCAP;**13,135,148,150,174**;Oct 20, 2000;Build 23 "RTN","PRCSUT2",3,0) ;;Per VHA Directive 2004-038, this routine should not be modified. "RTN","PRCSUT2",4,0) ; assigns a permanent transaction number to an existing transaction "RTN","PRCSUT2",5,0) ; if the existing transaction is temporary, it is converted to "RTN","PRCSUT2",6,0) ; permanent. "RTN","PRCSUT2",7,0) ; if the existing transaction is permanent, a new ien is created and "RTN","PRCSUT2",8,0) ; populated with info from the existing transaction, then canceled. "RTN","PRCSUT2",9,0) ; The original transaction is updated with the new transaction number. "RTN","PRCSUT2",10,0) ANTN ; "RTN","PRCSUT2",11,0) N ODA,PNW,TX1,T1,T2,T3,T4,T5,PRCSY,PRCSDIC,PRCSAPP,PRCECMS,PRCOLDI "RTN","PRCSUT2",12,0) ANTN1 D EN3^PRCSUT ; ask site, CP "RTN","PRCSUT2",13,0) G W5:'$D(PRC("SITE")) "RTN","PRCSUT2",14,0) G EXIT:Y<0 "RTN","PRCSUT2",15,0) W !!,"Select the existing transaction number to be replaced",! "RTN","PRCSUT2",16,0) S DIC="^PRCS(410,",DIC(0)="AEFMQ" "RTN","PRCSUT2",17,0) S DIC("S")="I $P(^(0),U,2)=""O""!($P(^(0),U,2)=""A""&($P(^(0),U,4)=1)),$S('$D(^(7)):1,1:$P(^(7),""^"",6)=""""),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))" "RTN","PRCSUT2",18,0) D ^PRCSDIC G:Y<0 EXIT "RTN","PRCSUT2",19,0) S (ODA,DA,T1)=+Y,PRCSDIC=DIC "RTN","PRCSUT2",20,0) L +^PRCS(410,DA):$S($D(DILOCKTM):DILOCKTM,1:3) "RTN","PRCSUT2",21,0) I $T=0 W !,"File being accessed...please try later" G ANTN1 "RTN","PRCSUT2",22,0) D REVIEW "RTN","PRCSUT2",23,0) S T2=^PRCS(410,DA,0) ; node 0 string of txn to be replaced "RTN","PRCSUT2",24,0) S T5=$P(T2,"^",10) ; substation "RTN","PRCSUT2",25,0) S T4=$P(T2,"^",2) ; txn type of transaction to be replaced "RTN","PRCSUT2",26,0) S T2=$P(T2,"^") ; txn number to be replaced "RTN","PRCSUT2",27,0) S T3=$P(^PRCS(410,DA,3),"^") ; control point of txn to be replaced "RTN","PRCSUT2",28,0) S PRCECMS=$P($G(^PRCS(410,DA,1)),U,8),PRCOLDI=DA "RTN","PRCSUT2",29,0) K DA,DIC,Y "RTN","PRCSUT2",30,0) W !!,"Enter the information for the new transaction number",! "RTN","PRCSUT2",31,0) D EN^PRCSUT3 ; ask SITE, FY, QRTR, CP for new txn "RTN","PRCSUT2",32,0) G:'$D(PRC("QTR"))!('$D(PRC("CP"))) EXIT "RTN","PRCSUT2",33,0) S TX1=X "RTN","PRCSUT2",34,0) I $P($G(^PRCS(410,T1,0)),"^",4)=1,$$Q1358^PRCEN(PRC("SITE"),PRC("CP"),T4,T1) G EXIT "RTN","PRCSUT2",35,0) D IP^PRCSUT ; set up prcsip "RTN","PRCSUT2",36,0) S PRCSAPP=$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^",3) "RTN","PRCSUT2",37,0) I PRC("CP")'=T3,PRCSAPP["_" D PRCFY G EXIT:PRCSAPP["_" "RTN","PRCSUT2",38,0) S X=TX1 "RTN","PRCSUT2",39,0) D EN1^PRCSUT3 ; generate new name for txn and put in X "RTN","PRCSUT2",40,0) G:'X EXIT "RTN","PRCSUT2",41,0) S TX1=X,(DIC,DIE)="^PRCS(410," "RTN","PRCSUT2",42,0) CK G:'+T2 CK1 ; don't set up new ien for temp txns (txns with non-numeric names) "RTN","PRCSUT2",43,0) K DA "RTN","PRCSUT2",44,0) S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="LXZ" "RTN","PRCSUT2",45,0) D ^DIC "RTN","PRCSUT2",46,0) K DLAYGO "RTN","PRCSUT2",47,0) G:Y'>0 EXIT "RTN","PRCSUT2",48,0) S DA=+Y "RTN","PRCSUT2",49,0) L +^PRCS(410,DA):$S($D(DILOCKTM):DILOCKTM,1:3) ; Lock new ien "RTN","PRCSUT2",50,0) I $T=0 W !," Cannot create new number now...please try again later" G EXIT "RTN","PRCSUT2",51,0) ; clean up txn x-refs for old & new ien's (nodes 'B','B2','B3','AE') "RTN","PRCSUT2",52,0) K ^PRCS(410,"B",TX1,DA),^PRCS(410,"B2",$P(TX1,"-",5),DA),^PRCS(410,"B3",$P(TX1,"-",2)_"-"_$P(TX1,"-",5),DA),^PRCS(410,"AE",$P(TX1,"-",1,4),DA) "RTN","PRCSUT2",53,0) ; kill x-refs to old ien "RTN","PRCSUT2",54,0) N RBQTDT,DSH,RBOLD "RTN","PRCSUT2",55,0) S RBQTDT=$P($G(^PRCS(410,T1,0)),"^",11),DSH="-" D:RBQTDT>0 "RTN","PRCSUT2",56,0) . S RBOLD=RBQTDT_DSH_$P(T2,"-")_DSH_$P(T2,"-",4)_DSH_$P(T2,"-",2)_DSH_$P(T2,"-",5) "RTN","PRCSUT2",57,0) . K ^PRCS(410,"RB",RBOLD,T1) "RTN","PRCSUT2",58,0) K RBQTDT,DSH,RBOLD "RTN","PRCSUT2",59,0) K ^PRCS(410,"B",T2,T1),^PRCS(410,"B2",$P(T2,"-",5),T1),^PRCS(410,"B3",$P(T2,"-",2)_"-"_$P(T2,"-",5),T1),^PRCS(410,"AE",$P(T2,"-",1,4),T1) "RTN","PRCSUT2",60,0) ; set old txn name into new ien "RTN","PRCSUT2",61,0) S $P(^PRCS(410,DA,0),"^")=T2 "RTN","PRCSUT2",62,0) ; set x-refs of old txn values to new ien "RTN","PRCSUT2",63,0) S (^PRCS(410,"B",T2,DA),^PRCS(410,"B2",$P(T2,"-",5),DA),^PRCS(410,"B3",$P(T2,"-",2)_"-"_$P(T2,"-",5),DA),^PRCS(410,"AE",$P(T2,"-",1,4),DA))="" "RTN","PRCSUT2",64,0) CK1 ; set new txn name into old (original) ien "RTN","PRCSUT2",65,0) S $P(^PRCS(410,T1,0),"^")=TX1 "RTN","PRCSUT2",66,0) ; set x-refs of new txn values to old ien "RTN","PRCSUT2",67,0) S (^PRCS(410,"B",TX1,T1),^PRCS(410,"B2",$P(TX1,"-",5),T1),^PRCS(410,"B3",$P(TX1,"-",2)_"-"_$P(TX1,"-",5),T1),^PRCS(410,"AE",$P(TX1,"-",1,4),T1))="" "RTN","PRCSUT2",68,0) ; delete old txn from temp txn x-ref & remove temp txn flag "RTN","PRCSUT2",69,0) K ^PRCS(410,"K",+T3,ODA) S $P(^PRCS(410,ODA,6),"^",4)="" "RTN","PRCSUT2",70,0) S PRC("OCP")=$P(^PRCS(410,ODA,3),U) "RTN","PRCSUT2",71,0) ; If the old transaction had eCMS identifiers, remove them from the old "RTN","PRCSUT2",72,0) ; entry which has been assigned the new transaction number. "RTN","PRCSUT2",73,0) I PRCECMS>0 D "RTN","PRCSUT2",74,0) . N PRCX S PRCX=$$XECMSIDS^PRCHJR03(PRCOLDI) "RTN","PRCSUT2",75,0) ; if old txn name is non-numeric (temp txn), force new site & CP into record at old ien "RTN","PRCSUT2",76,0) ;PRC*5.1*150 add x-ref kill for old txn non-numeric name "RTN","PRCSUT2",77,0) I '+T2 S DA=ODA,DIE="^PRCS(410,",DR=".5///"_PRC("SITE")_";S X=X;15///"_PRC("CP") D ^DIE D G EN "RTN","PRCSUT2",78,0) . K ^PRCS(410,"B",T2,ODA) "RTN","PRCSUT2",79,0) ; else: cancel txn at old ien; force old site & CP info into new ien "RTN","PRCSUT2",80,0) ;(Shortened comment and added cancel flag with patch 182 "RTN","PRCSUT2",81,0) S DIE="^PRCS(410,",DR=".5///"_+T2_";S X=X;15///"_T3 "RTN","PRCSUT2",82,0) S DR=DR_";60///Transaction "_T2_" replaced by trans. "_TX1 "RTN","PRCSUT2",83,0) S DR=DR_";450///C" ;put cancel flag in Running Bal status "RTN","PRCSUT2",84,0) D ^DIE "RTN","PRCSUT2",85,0) S DR="104////^S X=DUZ" D ^DIE K DR "RTN","PRCSUT2",86,0) I T5'="" S $P(^PRCS(410,DA,0),U,10)=T5 ; save substation in new ien "RTN","PRCSUT2",87,0) S $P(^PRCS(410,DA,0),U,2)="CA" ; cancel txn at new ien "RTN","PRCSUT2",88,0) D ERS410^PRC0G(DA_"^C") "RTN","PRCSUT2",89,0) D W5^PRCSEB ; kill flags & x-refs indicating cancel txn is ready to approve "RTN","PRCSUT2",90,0) L -^PRCS(410,DA) ; release new ien "RTN","PRCSUT2",91,0) W !,"Old transaction "_T2_" is now cancelled.",! "RTN","PRCSUT2",92,0) I $D(^PRC(443,ODA,0)) S DA=ODA,DIK="^PRC(443," D ^DIK K DA,DIK "RTN","PRCSUT2",93,0) EN W !!,"Transaction '"_T2_"' has been replaced by "_TX1,! "RTN","PRCSUT2",94,0) S PNW=ODA,PNW(1)=TX1 "RTN","PRCSUT2",95,0) N A,B "RTN","PRCSUT2",96,0) S A=TX1 D RBQTR ; returns B for DR string (RB Qrtr date) "RTN","PRCSUT2",97,0) I $E(B,$L(B))=";" S B=$E(B,1,$L(B)-1) ; remove trailing semi-colon "RTN","PRCSUT2",98,0) S DA=PNW,DR=B_$S(+T2:";1///"_T4,1:"")_$S(PRC("SITE")'=+T2:";S X=X;.5///"_PRC("SITE"),1:"")_$S(PRC("CP")'=T3:";S X=X;15///"_PRC("CP"),1:"")_$S($D(PRCSIP):";4////"_PRCSIP,1:"") "RTN","PRCSUT2",99,0) S DR=DR_$S($P($G(^PRCS(410,DA,0)),"^",4)=1:";40////^S X=DUZ",1:"") "RTN","PRCSUT2",100,0) D ^DIE "RTN","PRCSUT2",101,0) S PRC("ACC")=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY")) "RTN","PRCSUT2",102,0) S PRCSAPP=$P(PRC("ACC"),"^",11) "RTN","PRCSUT2",103,0) S $P(^PRCS(410,DA,3),"^")=PRC("CP") "RTN","PRCSUT2",104,0) S $P(^PRCS(410,DA,3),"^",2)=PRCSAPP "RTN","PRCSUT2",105,0) S $P(^PRCS(410,DA,3),"^",12)=$P(PRC("ACC"),"^",3) "RTN","PRCSUT2",106,0) S $P(^PRCS(410,DA,3),"^",11)=$P($$DATE^PRC0C(PRC("BBFY"),"E"),"^",7) "RTN","PRCSUT2",107,0) N MYY S MYY="" D EN2B^PRCSUT3 ; save substation & process with status of entered "RTN","PRCSUT2",108,0) D K^PRCSUT1 ; kill 'F', 'F1', x-refs "RTN","PRCSUT2",109,0) K T1(1) "RTN","PRCSUT2",110,0) S (DA,PRCS,PRCSY)=PNW "RTN","PRCSUT2",111,0) I $P(^PRCS(410,DA,0),"^",4)=1 D G ANTN:%=1,EXIT "RTN","PRCSUT2",112,0) . S AA=$$CHGCCBOC^PRCSCK(T2,TX1,PRC("OCP"),0) "RTN","PRCSUT2",113,0) . W !,"Use the 1358 edit option ",$S(AA<0:"",1:"if you wish "),"to edit this request.",!! D EXIT,W3 "RTN","PRCSUT2",114,0) ; restore values associated with new txn (use new name) "RTN","PRCSUT2",115,0) S PRC("SITE")=$P(PNW(1),"-"),PRC("FY")=$P(PNW(1),"-",2),PRC("QTR")=$P(PNW(1),"-",3),PRC("CP")=$P(PNW(1),"-",4),PRCSQ=1 "RTN","PRCSUT2",116,0) S AA=$$CHGCCBOC^PRCSCK(T2,TX1,PRC("OCP"),0) "RTN","PRCSUT2",117,0) I AA<0 W !,"Use the Edit a 2237 option to edit this request.",!! D EXIT,W3 G ANTN:%=1,EXIT "RTN","PRCSUT2",118,0) E D W1 ; ask 'edit this request?' "RTN","PRCSUT2",119,0) I %=2 D W6^PRCSEB G EN1 ; if no, may ask if ready for authorization "RTN","PRCSUT2",120,0) D:%=1 EDTD1^PRCSEB0 D:'$D(PRCSQ)&(T4="O") W6^PRCSEB "RTN","PRCSUT2",121,0) EN1 K PRCSQ "RTN","PRCSUT2",122,0) L -^PRCS(410,ODA) "RTN","PRCSUT2",123,0) D W3 I %=1 D EXIT W !! G ANTN1 "RTN","PRCSUT2",124,0) G EXIT "RTN","PRCSUT2",125,0) ; "RTN","PRCSUT2",126,0) PRCFY S A=PRCSAPP I A["_/_" D FY2 G KILL "RTN","PRCSUT2",127,0) I A["_" S PRCSAPP=$P(A,"_",1)_$E(PRC("FY"),$L(PRC("FY")))_$P(A,"_",2) "RTN","PRCSUT2",128,0) KILL K %DT,A,B,RES,X "RTN","PRCSUT2",129,0) Q "RTN","PRCSUT2",130,0) ; "RTN","PRCSUT2",131,0) FY2 ;TWO YR APP "RTN","PRCSUT2",132,0) I '$D(PRC("FY")) D NOW^%DTC S PRC("FY")=$E(100+$E(X,4)+$E(X,2,3),2,3) "RTN","PRCSUT2",133,0) W !!,"Enter first year of this two year appropriation: ",PRC("FY")," // " R RES:DTIME G:RES["^" FY21 "RTN","PRCSUT2",134,0) I RES["?"!(RES'?.4N) W !,"Enter fiscal year in format '1' '81' or '1981'",!! G FY2 "RTN","PRCSUT2",135,0) FY21 S:'RES RES=PRC("FY") "RTN","PRCSUT2",136,0) S RES=$E(RES,$L(RES)),PRCSAPP=$P(A,"_",1)_RES_"/"_(RES+1#10)_$P(A,"_",3) "RTN","PRCSUT2",137,0) Q "RTN","PRCSUT2",138,0) ; "RTN","PRCSUT2",139,0) REVIEW W !!,"Would you like to review this request" "RTN","PRCSUT2",140,0) S %=2 D YN^DICN G REVIEW:%=0 "RTN","PRCSUT2",141,0) Q:%'=1 "RTN","PRCSUT2",142,0) S (N,PRCSZ)=DA,PRCSF=1 "RTN","PRCSUT2",143,0) D PRF1^PRCSP1 ; print 2237 "RTN","PRCSUT2",144,0) S DA=PRCSZ "RTN","PRCSUT2",145,0) K X,PRCSF,PRCSZ "RTN","PRCSUT2",146,0) Q "RTN","PRCSUT2",147,0) ; "RTN","PRCSUT2",148,0) W1 S %=2 Q:T4'="O" "RTN","PRCSUT2",149,0) ;*****PRC*5.1*174 start***** "RTN","PRCSUT2",150,0) N PRCFTYPE,PRCFAIL "RTN","PRCSUT2",151,0) S PRCFTYPE=+$$GET1^DIQ(410,$G(DA)_",",3,"I") "RTN","PRCSUT2",152,0) ;if a 2237 transaction (Form Type IEN 2,3, or 4) "RTN","PRCSUT2",153,0) I $G(PRCFTYPE)>1&($G(PRCFTYPE)<5) D "RTN","PRCSUT2",154,0) . ;if 2237 required field check fails, output warning "RTN","PRCSUT2",155,0) . ;and force user to edit (S %=1) "RTN","PRCSUT2",156,0) . I '$$REQCHECK^PRCHJUTL($G(DA),,1) S (PRCFAIL,%)=1 "RTN","PRCSUT2",157,0) ;if 2237 required field checks fail, force edit and don't prompt user "RTN","PRCSUT2",158,0) Q:$G(PRCFAIL) "RTN","PRCSUT2",159,0) ;*****PRC*5.1*174 end***** "RTN","PRCSUT2",160,0) W !!,"Would you like to edit this request" "RTN","PRCSUT2",161,0) D YN^DICN G W1:%=0 "RTN","PRCSUT2",162,0) Q "RTN","PRCSUT2",163,0) ; "RTN","PRCSUT2",164,0) W3 W !!,"Would you like to replace another transaction number" "RTN","PRCSUT2",165,0) S %=2 D YN^DICN G W3:%=0 "RTN","PRCSUT2",166,0) Q "RTN","PRCSUT2",167,0) ; "RTN","PRCSUT2",168,0) W5 W !!,"You are not an authorized control point user.",!,"Contact your control point official." R X:5 "RTN","PRCSUT2",169,0) EXIT I $D(ODA) L -^PRCS(410,ODA) "RTN","PRCSUT2",170,0) D EXIT^PRCSUT31 "RTN","PRCSUT2",171,0) Q "RTN","PRCSUT2",172,0) ; "RTN","PRCSUT2",173,0) MO ;MO QRTR "RTN","PRCSUT2",174,0) I DA,$D(^PRCS(410,DA,0)) S PRCSQT=$P(^(0),"-",3) I PRCSQT="" K PRCSQT Q "RTN","PRCSUT2",175,0) I PRCSQT=1 W !?3,"10 OCT",!?3,"11 NOV",!?3,"12 DEC" Q "RTN","PRCSUT2",176,0) I PRCSQT=2 W !?3," 1 JAN",!?3," 2 FEB",!?3," 3 MAR" Q "RTN","PRCSUT2",177,0) I PRCSQT=3 W !?3," 4 APR",!?3," 5 MAY",!?3," 6 JUN" Q "RTN","PRCSUT2",178,0) I PRCSQT=4 W !?3," 7 JUL",!?3," 8 AUG",!?3," 9 SEP" Q "RTN","PRCSUT2",179,0) Q "RTN","PRCSUT2",180,0) ; "RTN","PRCSUT2",181,0) MO1 I DA,$D(^PRCS(410,DA,0)) S PRCSQT=$P(^(0),"-",3) I PRCSQT="" K PRCSQT Q "RTN","PRCSUT2",182,0) S PRCSMO=$S(X<4:2,X>9:1,X>3&(X<7):3,X>6&(X<10):4,1:"") "RTN","PRCSUT2",183,0) I PRCSMO="" K PRCSMO "RTN","PRCSUT2",184,0) Q "RTN","PRCSUT2",185,0) ; "RTN","PRCSUT2",186,0) RBQTR N C,D S B="",B=$S(B="":$P(A,"-",2)_"^F",1:+$$DATE^PRC0C(B,"I")) "RTN","PRCSUT2",187,0) S C=$$QTRDT^PRC0G($P(A,"-",1)_"^"_$P(A,"-",4)_"^"_B) "RTN","PRCSUT2",188,0) S D=$$QTRDATE^PRC0D($P(A,"-",2),$P(A,"-",3)),D=$P(D,"^",7) "RTN","PRCSUT2",189,0) S B=$S(D<$P(C,"^",3):$P(C,"^",3),$P(C,"^",2)30!($L(X)<3)!'(X'?1P.E) X "^DD",414.06,414.06,.01,1,0) ^.1^^-1 "^DD",414.06,414.06,.01,1,1,0) 414.06^B "^DD",414.06,414.06,.01,1,1,1) S ^PRCV(414.06,"B",$E(X,1,30),DA)="" "^DD",414.06,414.06,.01,1,1,2) K ^PRCV(414.06,"B",$E(X,1,30),DA) "^DD",414.06,414.06,.01,3) Answer must be 3-30 characters in length. "^DD",414.06,414.06,.01,21,0) ^.001^4^4^3130620^^^^ "^DD",414.06,414.06,.01,21,1,0) The unique IFCAP reference number for this transaction. "^DD",414.06,414.06,.01,21,2,0) For transactions involving purchase requests (2237) this will be the "^DD",414.06,414.06,.01,21,3,0) text value of the Control Point Activity Transaction Number needed "^DD",414.06,414.06,.01,21,4,0) by the Electronic Contract Management System (eCMS). "^DD",414.06,414.06,.01,"DT") 3130620 "^DD",414.06,414.061,.02,0) EVENT TYPE^RP414.07'^PRCV(414.07,^0;2^Q "^DD",414.06,414.061,.02,1,0) ^.1 "^DD",414.06,414.061,.02,1,1,0) 414.06^ATY "^DD",414.06,414.061,.02,1,1,1) S ^PRCV(414.06,"ATY",$E(X,1,30),DA(1),DA)="" "^DD",414.06,414.061,.02,1,1,2) K ^PRCV(414.06,"ATY",$E(X,1,30),DA(1),DA) "^DD",414.06,414.061,.02,1,1,"%D",0) ^^1^1^3120615^ "^DD",414.06,414.061,.02,1,1,"%D",1,0) File wide to assist with sorting event types. "^DD",414.06,414.061,.02,1,1,"DT") 3120615 "^DD",414.06,414.061,.02,3) Select the event type. "^DD",414.06,414.061,.02,21,0) ^.001^1^1^3130621^^^^ "^DD",414.06,414.061,.02,21,1,0) The type of message associated with this transaction event. "^DD",414.06,414.061,.02,"DT") 3130220 "^DD",414.06,414.061,6,0) ECMS EMAIL^F^^1;6^K:$L(X)>60!($L(X)<2) X "^DD",414.06,414.061,6,3) Answer must be 2-60 characters in length. "^DD",414.06,414.061,6,21,0) ^^1^1^3120613^ "^DD",414.06,414.061,6,21,1,0) The email address for the eCMS user associated with this transaction event. "^DD",414.06,414.061,6,"DT") 3130409 "^DD",414.07,414.07,0) FIELD^^.001^3 "^DD",414.07,414.07,0,"DDA") N "^DD",414.07,414.07,0,"DT") 3130619 "^DD",414.07,414.07,0,"IX","B",414.07,.01) "^DD",414.07,414.07,0,"NM","IFCAP/ECMS EVENT TYPE") "^DD",414.07,414.07,0,"PT",414.061,.02) "^DD",414.07,414.07,.001,0) CODE^NJ4,0^^ ^K:+X'=X!(X>9999)!(X<1)!(X?.E1"."1N.N) X "^DD",414.07,414.07,.001,3) Type a number between 1 and 9999, 0 decimal digits. "^DD",414.07,414.07,.001,21,0) ^.001^1^1^3130620^^^ "^DD",414.07,414.07,.001,21,1,0) The internal code for the event. The code is identical to the IEN. "^DD",414.07,414.07,.001,"DT") 3130619 "^DD",414.07,414.07,.01,0) NAME^RF^^0;1^K:$L(X)>45!($L(X)<3)!'(X'?1P.E) X "^DD",414.07,414.07,.01,1,0) ^.1 "^DD",414.07,414.07,.01,1,1,0) 414.07^B "^DD",414.07,414.07,.01,1,1,1) S ^PRCV(414.07,"B",$E(X,1,30),DA)="" "^DD",414.07,414.07,.01,1,1,2) K ^PRCV(414.07,"B",$E(X,1,30),DA) "^DD",414.07,414.07,.01,3) Answer must be 3-45 characters in length. "^DD",414.07,414.07,.01,21,0) ^.001^2^2^3130620^^^ "^DD",414.07,414.07,.01,21,1,0) The name of the event as it relates to the IFCAP perspective "^DD",414.07,414.07,.01,21,2,0) of message transactions with eCMS. "^DD",414.07,414.07,.01,"DT") 3130220 "^DD",414.07,414.07,1,0) DESCRIPTION^RF^^0;3^K:$L(X)>120!($L(X)<3) X "^DD",414.07,414.07,1,3) Answer must be 3-120 characters in length. "^DD",414.07,414.07,1,21,0) ^.001^1^1^3130315^^^^ "^DD",414.07,414.07,1,21,1,0) A description of this 2237 event from the IFCAP perspective. "^DD",414.07,414.07,1,"DT") 3130315 "^DIC",414.07,414.07,0) IFCAP/ECMS EVENT TYPE^414.07 "^DIC",414.07,414.07,0,"GL") ^PRCV(414.07, "^DIC",414.07,414.07,"%",0) ^1.005^^ "^DIC",414.07,414.07,"%D",0) ^^3^3^3130315^^^ "^DIC",414.07,414.07,"%D",1,0) This file contains the list of event types that describe the various "^DIC",414.07,414.07,"%D",2,0) transactions between IFCAP and the Electronic Contract Management System "^DIC",414.07,414.07,"%D",3,0) (eCMS). The event types describe the messages from the IFCAP perspective. "^DIC",414.07,"B","IFCAP/ECMS EVENT TYPE",414.07) "BLD",7273,6) ^154 **END** **END**