PRCHJR01 ;OI&T/LKG - PROCESS 2237 RETURN OR CANCEL FROM ECMS ;7/15/13 16:48
;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23
;Per VHA Directive 2004-38, this routine should not be modified.
PARSE ;This module contains logic to parse the incoming OMN^O07 HL7 message
N PRCHJMSG,PRCHJHDR,PRCHJSEG,PRCHJIND,PRCHJMID,PRCHJSTN,PRCHJTD,PRCHJVAL,PRCVALID,PRCHJMDT,PRCHJNOW,PRCHJCTR,PRCHJERR,PRCX
; HLMSGIEN is an HLO variable that will be defined when PARSE^PRCHJR01 is invoked.
I '$$STARTMSG^HLOPRS(.PRCHJMSG,HLMSGIEN,.PRCHJHDR) Q
I PRCHJMSG("BATCH") Q
I PRCHJHDR("MESSAGE TYPE")'="OMN"!(PRCHJHDR("EVENT")'="O07") Q
S PRCHJSTN=$G(PRCHJHDR("RECEIVING FACILITY",1))
S PRCHJMID=PRCHJHDR("MESSAGE CONTROL ID"),PRCHJMDT=PRCHJHDR("DT/TM OF MESSAGE")
S PRCHJIND="PRCHJR01"_PRCHJMID K ^XTMP(PRCHJIND) S PRCHJTD=$$DT^XLFDT,^XTMP(PRCHJIND,0)=$$FMADD^XLFDT(PRCHJTD,7)_"^"_PRCHJTD_"^2237 RETURN/CANCEL"
F Q:'$$NEXTSEG^HLOPRS(.PRCHJMSG,.PRCHJSEG) D
. I PRCHJSEG("SEGMENT TYPE")="ORC" D ORC(.PRCHJSEG)
. I PRCHJSEG("SEGMENT TYPE")="RQD" D RQD(.PRCHJSEG)
. ;If not ORC or RQD ignore
;
D LOGOMN^PRCHJR03
;
S PRCVALID=$$VALIDATE()
;
D:PRCVALID EMAIL
I PRCVALID D
. N PRCIEN,PRC2237,PRCSTAT,PRCERR S PRC2237=^XTMP(PRCHJIND,"2237 TXN"),PRCIEN=$$FIND1^DIC(410,"","X",PRC2237,"B","","PRCERR")
. S PRCSTAT=$$GET1^DIQ(410,PRCIEN_",",54,"","","PRCERR") K PRCERR
. I ";RETURNED TO SERVICE BY PPM;RETURNED TO SERVICE BY P&C;"[(";"_$$UP^XLFSTR(PRCSTAT)_";"),^XTMP(PRCHJIND,"ORDER STATUS")="HD" D Q
. . N PRCX S PRCX=$$ECMSRETN^PRCHJR03(PRCIEN)
. . S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="14^Return to Control Point is incomplete."
. I ";RETURNED TO SERVICE BY PPM;RETURNED TO SERVICE BY P&C;"[(";"_$$UP^XLFSTR(PRCSTAT)_";"),^XTMP(PRCHJIND,"ORDER CONTROL")="CA" D Q
. . N PRCX S PRCX=$$ECMSRETN^PRCHJR03(PRCIEN)
. . S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="14^Return to Control Point is incomplete."
. . S PRCX=$$CANCEL(PRCIEN)
. . S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="15^Cancelation of 2237 is incomplete."
. I ^XTMP(PRCHJIND,"ORDER CONTROL")="UA",^XTMP(PRCHJIND,"ORDER STATUS")="IP" D Q
. . S PRCX=$$RET2AO(PRCIEN) S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="13^Return to Accountable Officer is incomplete."
. I ^XTMP(PRCHJIND,"ORDER CONTROL")="UA",^XTMP(PRCHJIND,"ORDER STATUS")="HD" D Q
. . S PRCX=$$RET2AO(PRCIEN) S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="13^Return to Accountable Officer is incomplete."
. . S PRCX=$$RET2CP(PRCIEN) S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="14^Return to Control Point is incomplete."
. I ^XTMP(PRCHJIND,"ORDER CONTROL")="CA" D Q
. . S PRCX=$$RET2AO(PRCIEN) S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="13^Return to Accountable Officer is incomplete."
. . S PRCX=$$RET2CP(PRCIEN) S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="14^Return to Control Point is incomplete."
. . S PRCX=$$CANCEL(PRCIEN) S:'PRCX PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="15^Cancelation of 2237 is incomplete."
;
I PRCHJHDR("APP ACK TYPE")="AL" D BUILDACK
Q
;
EMAIL ;Send message to users attached to 2237 being returned/canceled
N PRCHJM1,PRCHJM2
S PRCHJM1(1)=^XTMP(PRCHJIND,"2237 TXN")
S PRCHJM1(2)=$S(^XTMP(PRCHJIND,"ORDER CONTROL")="CA":2,^XTMP(PRCHJIND,"ORDER STATUS")="IP":3,^XTMP(PRCHJIND,"ORDER STATUS")="HD":4,1:"")
S PRCHJM1(3)=^XTMP(PRCHJIND,"ACTION CREATED DATE")
S PRCHJM1(4)=^XTMP(PRCHJIND,"USER","FIRSTNAME")_$S(^XTMP(PRCHJIND,"USER","MIDDLENAME")'="":(" "_^("MIDDLENAME")),1:"")_" "_^XTMP(PRCHJIND,"USER","LASTNAME")
S PRCHJM1(5)=^XTMP(PRCHJIND,"EMAIL"),PRCHJM1(6)=^XTMP(PRCHJIND,"PHONE")
S PRCHJM2(1)=^XTMP(PRCHJIND,"RETURN REASON"),PRCHJM2(2)=^XTMP(PRCHJIND,"RETURN COMMENT")
D PHMSG^PRCHJMSG(.PRCHJM1,.PRCHJM2)
Q
ORC(PRCHJSEG) ;Parse ORC segment
S ^XTMP(PRCHJIND,"ORDER CONTROL")=$$GET^HLOPRS(.PRCHJSEG,1)
S ^XTMP(PRCHJIND,"2237 TXN")=$$GET^HLOPRS(.PRCHJSEG,2,1)
S ^XTMP(PRCHJIND,"STATION")=$$GET^HLOPRS(.PRCHJSEG,2,2)
S ^XTMP(PRCHJIND,"SUBSTATION")=$$GET^HLOPRS(.PRCHJSEG,2,3)
S ^XTMP(PRCHJIND,"ECMS ACTIONUID")=$$GET^HLOPRS(.PRCHJSEG,3,1)
S ^XTMP(PRCHJIND,"ORDER STATUS")=$$GET^HLOPRS(.PRCHJSEG,5)
D GETTS^HLOPRS2(.PRCHJSEG,.PRCHJVAL,9,1) S ^XTMP(PRCHJIND,"ACTION CREATED DATE")=PRCHJVAL
S ^XTMP(PRCHJIND,"USER","LASTNAME")=$$GET^HLOPRS(.PRCHJSEG,10,2,1)
S ^XTMP(PRCHJIND,"USER","FIRSTNAME")=$$GET^HLOPRS(.PRCHJSEG,10,3)
S ^XTMP(PRCHJIND,"USER","MIDDLENAME")=$$GET^HLOPRS(.PRCHJSEG,10,4)
S ^XTMP(PRCHJIND,"USER","SUFFIX")=$$GET^HLOPRS(.PRCHJSEG,10,5)
S ^XTMP(PRCHJIND,"PHONE")=$$GET^HLOPRS(.PRCHJSEG,14,1)
S ^XTMP(PRCHJIND,"EMAIL")=$$GET^HLOPRS(.PRCHJSEG,14,4)
S ^XTMP(PRCHJIND,"RETURN REASON")=$$GET^HLOPRS(.PRCHJSEG,16,2)
S ^XTMP(PRCHJIND,"RETURN COMMENT")=$$GET^HLOPRS(.PRCHJSEG,16,5)
Q
RQD(PRCHJSEG) ;Process RQD segment
S ^XTMP(PRCHJIND,"REQUISITION LINE NBR")=$$GET^HLOPRS(.PRCHJSEG,1)
Q
RET2AO(DA) ;This module contains logic to remove the AO signature and change status to Pending Accountable Officer Sig.
N PRCDATA,PRCERR,PRCHPCR,PRCHJDA,PRCERROR S PRCHPCR=1,PRCHJDA=DA_",",PRCERROR=0
S PRCDATA(443,PRCHJDA,1.5)=60 D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
S PRCDATA(443,PRCHJDA,2)="@",PRCDATA(443,PRCHJDA,3)="@",PRCDATA(443,PRCHJDA,4)="@"
D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
S PRCDATA(410,PRCHJDA,39)="@",PRCDATA(410,PRCHJDA,69)="@"
D FILE^DIE("EK","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
S PRCDATA(1)=^XTMP(PRCHJIND,"RETURN REASON"),PRCDATA(2)=^XTMP(PRCHJIND,"RETURN COMMENT")
D WP^DIE(410,PRCHJDA,61,"K","PRCDATA","PRCERR")
S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
I ^XTMP(PRCHJIND,"ORDER STATUS")="IP" D
. S:$$XECMSIDS^PRCHJR03($P(PRCHJDA,",")) PRCERROR=1
. S PRCDATA(443,PRCHJDA,6)="@"
. D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1
. K PRCDATA,PRCERR
Q $S(PRCERROR:0,1:1)
RET2CP(DA) ;This module contains logic to remove the Control Point Official's signature, de-commit the funds and adjust due-ins as necessary.
N PRCHDA,PRCDATA,PRCERR,PRCHJDA,PRCERROR,PRCHJCPR,X S PRCHDA=DA,PRCERROR=0
S X=$P(^PRCS(410,DA,4),"^",8) D TRANK^PRCSES
S PRCHJDA=DA_",",PRCDATA(410,PRCHJDA,44)="@",PRCDATA(410,PRCHJDA,44.5)="@",PRCDATA(410,PRCHJDA,44.6)="@"
D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
S PRCDATA(410,PRCHJDA,56)=77 D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
S PRCHJCPR=1,PRCDATA(443,PRCHJDA,1.5)=77 D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
S PRCDATA(1)=^XTMP(PRCHJIND,"RETURN REASON"),PRCDATA(2)=^XTMP(PRCHJIND,"RETURN COMMENT")
D WP^DIE(410,PRCHJDA,61,"K","PRCDATA","PRCERR")
S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
S DA=PRCHDA D REMOVE^PRCSC1(DA),REMOVE^PRCSC3(DA)
S DA=PRCHDA D ADJDUEIN(DA) ;D EN3^PRCPWI
Q $S(PRCERROR:0,1:1)
;
CANCEL(DA) ;This module contains logic to cancel the 2237
N PRCDATA,PRCERR,PRCHJDA,PRCERROR,I,N,X,Y S PRCHJDA=DA_",",PRCERROR=0
S PRCDATA(410,PRCHJDA,55)="@",PRCDATA(410,PRCHJDA,1)="CA"
D FILE^DIE("EK","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
S:$$XECMSIDS^PRCHJR03(DA) PRCERROR=1
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
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)
K DA(1)
D ERS410^PRC0G(DA_"^C")
S PRCDATA(1)=^XTMP(PRCHJIND,"RETURN REASON") D WP^DIE(410,PRCHJDA,61,"K","PRCDATA","PRCERR")
S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
S PRCDATA(1)=^XTMP(PRCHJIND,"RETURN COMMENT")
S PRCDATA(2)="eCMS User Who Canceled 2237: "
S PRCDATA(3)=^XTMP(PRCHJIND,"USER","LASTNAME")_","_^XTMP(PRCHJIND,"USER","FIRSTNAME")
S:^XTMP(PRCHJIND,"USER","MIDDLENAME")'="" PRCDATA(3)=PRCDATA(3)_" "_^("MIDDLENAME")
S PRCDATA(3)=$$UP^XLFSTR(PRCDATA(3))
D WP^DIE(410,PRCHJDA,60,"AK","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
;If a DynaMed txn, update audit file and send message to DynaMed
D EN^PRCVTCA(DA)
I $D(^PRC(443,DA,0)) S DIK="^PRC(443," D ^DIK K DIK
Q $S(PRCERROR:0,1:1)
BUILDACK ;This module contains logic to build the ORN^O08 application acknowledgment
N PRCHJPAR,PRCHJACK,PRCERR
S PRCHJPAR("ACK CODE")=$S('$D(PRCHJERR):"AA",1:"AR")
S PRCHJPAR("ACCEPT ACK TYPE")="AL",PRCHJPAR("MESSAGE TYPE")="ORN",PRCHJPAR("EVENT")="O08"
S PRCHJPAR("FIELD SEPARATOR")="|",PRCHJPAR("ENCODING CHARACTERS")="^~\&"
S PRCHJPAR("MESSAGE STRUCTURE CODE")="ORN_O08",PRCHJPAR("VERSION")=2.5
I '$$ACK^HLOAPI2(.PRCHJMSG,.PRCHJPAR,.PRCHJACK,.PRCERR) Q
I '$D(PRCHJERR) D
. D SET^HLOAPI(.PRCSEG,"ORC",0),SET^HLOAPI(.PRCSEG,"XR",1)
. D SET^HLOAPI(.PRCSEG,^XTMP(PRCHJIND,"2237 TXN"),2,1)
. D SET^HLOAPI(.PRCSEG,^XTMP(PRCHJIND,"STATION"),2,2)
. D SET^HLOAPI(.PRCSEG,^XTMP(PRCHJIND,"SUBSTATION"),2,3)
. D SET^HLOAPI(.PRCSEG,^XTMP(PRCHJIND,"ECMS ACTIONUID"),3,1)
. S PRCX=$$ADDSEG^HLOAPI(.PRCHJACK,.PRCSEG,.PRCERR,.PRCARR)
. K PRCSEG D SET^HLOAPI(.PRCSEG,"RQD",0),SET^HLOAPI(.PRCSEG,9999,1)
. S PRCX=$$ADDSEG^HLOAPI(.PRCHJACK,.PRCSEG,.PRCERR,.PRCARR)
I $D(PRCHJERR) D
. N PRCI S PRCI=0
. F S PRCI=$O(PRCHJERR(PRCI)) Q:PRCI="" D
. . N PRCX,PRCY,PRCE,PRCSEG,PRCERR,PRCARR
. . S PRCX=PRCHJERR(PRCI),PRCE=$P(PRCX,U) D SET^HLOAPI(.PRCSEG,"ERR",0)
. . S PRCY=$P($T(ERRTABLE+PRCE),";;",2,99)
. . 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)
. . D:$P(PRCY,U,4) SET^HLOAPI(.PRCSEG,$P(PRCY,U,4),2,5)
. . D:$P(PRCY,U,5) SET^HLOAPI(.PRCSEG,$P(PRCY,U,5),2,6)
. . 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)
. . 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)
. . D SET^HLOAPI(.PRCSEG,$P(PRCX,U,2),8)
. . S PRCX=$$ADDSEG^HLOAPI(.PRCHJACK,.PRCSEG,.PRCERR,.PRCARR)
K PRCERR
I '$$SENDACK^HLOAPI2(.PRCHJACK,.PRCERR) S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="The sending of Application Acknowledgment to eCMS failed."
S PRCHJNOW=$$NOW^XLFDT D LOGORN^PRCHJR03
Q
VALIDATE() ;Validate the data and existence of the 2237 and return
; 1 if valid and 0 if there are errors
N PRC2237,PRCIEN,PRCSIEN,PRCSTAT,PRCSTN
S PRCHJCTR=0 K PRCHJERR
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
I ^XTMP(PRCHJIND,"USER","LASTNAME")=""!(^XTMP(PRCHJIND,"USER","FIRSTNAME")="") D
. S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="1^eCMS User Name lacks first or last name."
I ^XTMP(PRCHJIND,"2237 TXN")="" D
. S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="11^2237 transaction number is not populated."
I ^XTMP(PRCHJIND,"RETURN REASON")="" D
. S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="2^Reason for Return is not populated."
I ^XTMP(PRCHJIND,"RETURN COMMENT")="" D
. S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="3^Comments is not populated."
I ";CA;UA;"'[(";"_^XTMP(PRCHJIND,"ORDER CONTROL")_";") D
. S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="8^Order Control field contains '"_^XTMP(PRCHJIND,"ORDER CONTROL")_"' which is invalid."
I ";CA;HD;IP;"'[(";"_^XTMP(PRCHJIND,"ORDER STATUS")_";") D
. S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="9^Order Status field contains '"_^XTMP(PRCHJIND,"ORDER STATUS")_"' which is invalid."
S PRC2237=$G(^XTMP(PRCHJIND,"2237 TXN")) S PRCIEN=$$FIND1^DIC(410,"","X",PRC2237,"B","","PRCERR")
I PRCIEN'>0 S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="6^"_PRC2237_" does not exist."
I PRCIEN D
. K PRCERR
. S PRCSTAT=$$GET1^DIQ(410,PRCIEN_",",54,"","","PRCERR") K PRCERR
. I PRCSTAT="",$$GET1^DIQ(410,PRCIEN_",",1,"","","PRCERR")="CANCELLED" S PRCSTAT="Cancelled"
. K PRCERR
. 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
. . S PRCHJCTR=PRCHJCTR+1
. . 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'."
. I ";RETURNED TO SERVICE BY PPM;RETURNED TO SERVICE BY P&C;"[(";"_$$UP^XLFSTR(PRCSTAT)_";"),^XTMP(PRCHJIND,"ORDER STATUS")="IP" D
. . S PRCHJCTR=PRCHJCTR+1
. . S PRCHJERR(PRCHJCTR)="21^2237 status is '"_PRCSTAT_"'. Thus 2237 cannot be returned to Accountable Officer as it is not CPO signed."
. K PRCERR N PRCACTID S PRCACTID=$$GET1^DIQ(410,PRCIEN_",",103,"","","PRCERR") K PRCERR
. I PRCACTID'=^XTMP(PRCHJIND,"ECMS ACTIONUID") D
. . 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."
S PRCSTN=$G(^XTMP(PRCHJIND,"STATION")) S PRCSIEN=$$FIND1^DIC(411,"","X",PRCSTN,"B","","PRCERR") K PRCERR
I PRCSIEN'>0 S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="10^Station "_PRCSTN_" is not on this VistA instance."
I ^XTMP(PRCHJIND,"ACTION CREATED DATE")="" D
. S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="16^Date/Time of action is not populated."
I ^XTMP(PRCHJIND,"ECMS ACTIONUID")="" D
. S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="17^eCMS internal PR identifier ActionUID is missing."
I $G(^XTMP(PRCHJIND,"REQUISITION LINE NBR"))'=9999 S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="12^RQD segment is not correctly populated."
I ^XTMP(PRCHJIND,"ORDER CONTROL")="UA",";HD;IP;"'[(";"_^XTMP(PRCHJIND,"ORDER STATUS")_";") D
. S PRCHJCTR=PRCHJCTR+1,PRCHJERR(PRCHJCTR)="20^Order Status '"_^XTMP(PRCHJIND,"ORDER STATUS")_"' is inappropriate for Order Control UA."
Q $S(PRCHJCTR:0,1:1)
;
;
ADJDUEIN(PRCDA) ;Decrement due-ins
N PRCHJINV,PRCHJITM,PRCHJIMF,PRCHJQTY
S PRCHJINV=$P($G(^PRCS(410,PRCDA,0)),U,6)
Q:PRCHJINV'>0 Q:'$D(^PRCP(445,PRCHJINV,0))
S PRCHJITM=0
F S PRCHJITM=$O(^PRCS(410,PRCDA,"IT",PRCHJITM)) Q:+PRCHJITM'=PRCHJITM D
. S PRCHJIMF=$P($G(^PRCS(410,PRCDA,"IT",PRCHJITM,0)),U,5),PRCHJQTY=$P($G(^(0)),U,2)
. Q:PRCHJIMF'>0 Q:PRCHJQTY'>0
. D KILLTRAN^PRCPUTRA(PRCHJINV,PRCHJIMF,PRCDA)
Q
;
ERRTABLE ;Table of Error data
;;1^ORC^10^^^101^Required field missing^E^eCMS user name not populated
;;2^ORC^16^2^^101^Required field missing^E^Reason for Return not populated
;;3^ORC^16^5^^101^Required field missing^E^Comments not populated
;;4^ORC^14^4^^101^Required field missing^W^User's e-mail not populated
;;5^ORC^14^1^^101^Required field missing^W^User's telephone# not populated
;;6^ORC^2^1^^204^Unknown key identifier^E^2237 transaction not found
;;7^ORC^2^1^^207^Application internal error^E^Status wrong for return or cancel
;;8^ORC^1^^^103^Table value not found^E^Order Control value is wrong
;;9^ORC^5^^^103^Table value not found^E^Order Status value is wrong
;;10^ORC^2^2^^103^Table value not found^E^Site not on VistA instance
;;11^ORC^2^1^^101^Required field missing^E^2237 txn# not populated
;;12^RQD^1^^^207^Application internal error^E^Requisition line# wrong
;;13^ORC^1^^^207^Application internal error^E^Return to AO incomplete
;;14^ORC^1^^^207^Application internal error^E^Return to CP incomplete
;;15^ORC^1^^^207^Application internal error^E^2237 cancelation incomplete
;;16^ORC^9^1^^101^Required field missing^E^Action Date/Time missing
;;17^ORC^3^1^^101^Required field missing^E^eCMS ActionUID missing
;;18^ORC^3^1^^207^Application internal error^E^eCMS ActionUID mismatch
;;19^ORC^1^^^100^Segment sequence error^E^ORC segment missing
;;20^ORC^5^^^207^Application internal error^E^Mismatch Order Control/Status
;;21^ORC^5^^^207^Application internal error^E^Cannot return to later status
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHJR01 15767 printed Apr 09, 2024@21:09:44 Page 2
PRCHJR01 ;OI&T/LKG - PROCESS 2237 RETURN OR CANCEL FROM ECMS ;7/15/13 16:48
+1 ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23
+2 ;Per VHA Directive 2004-38, this routine should not be modified.
PARSE ;This module contains logic to parse the incoming OMN^O07 HL7 message
+1 NEW PRCHJMSG,PRCHJHDR,PRCHJSEG,PRCHJIND,PRCHJMID,PRCHJSTN,PRCHJTD,PRCHJVAL,PRCVALID,PRCHJMDT,PRCHJNOW,PRCHJCTR,PRCHJERR,PRCX
+2 ; HLMSGIEN is an HLO variable that will be defined when PARSE^PRCHJR01 is invoked.
+3 IF '$$STARTMSG^HLOPRS(.PRCHJMSG,HLMSGIEN,.PRCHJHDR)
QUIT
+4 IF PRCHJMSG("BATCH")
QUIT
+5 IF PRCHJHDR("MESSAGE TYPE")'="OMN"!(PRCHJHDR("EVENT")'="O07")
QUIT
+6 SET PRCHJSTN=$GET(PRCHJHDR("RECEIVING FACILITY",1))
+7 SET PRCHJMID=PRCHJHDR("MESSAGE CONTROL ID")
SET PRCHJMDT=PRCHJHDR("DT/TM OF MESSAGE")
+8 SET PRCHJIND="PRCHJR01"_PRCHJMID
KILL ^XTMP(PRCHJIND)
SET PRCHJTD=$$DT^XLFDT
SET ^XTMP(PRCHJIND,0)=$$FMADD^XLFDT(PRCHJTD,7)_"^"_PRCHJTD_"^2237 RETURN/CANCEL"
+9 FOR
if '$$NEXTSEG^HLOPRS(.PRCHJMSG,.PRCHJSEG)
QUIT
Begin DoDot:1
+10 IF PRCHJSEG("SEGMENT TYPE")="ORC"
DO ORC(.PRCHJSEG)
+11 IF PRCHJSEG("SEGMENT TYPE")="RQD"
DO RQD(.PRCHJSEG)
+12 ;If not ORC or RQD ignore
End DoDot:1
+13 ;
+14 DO LOGOMN^PRCHJR03
+15 ;
+16 SET PRCVALID=$$VALIDATE()
+17 ;
+18 if PRCVALID
DO EMAIL
+19 IF PRCVALID
Begin DoDot:1
+20 NEW PRCIEN,PRC2237,PRCSTAT,PRCERR
SET PRC2237=^XTMP(PRCHJIND,"2237 TXN")
SET PRCIEN=$$FIND1^DIC(410,"","X",PRC2237,"B","","PRCERR")
+21 SET PRCSTAT=$$GET1^DIQ(410,PRCIEN_",",54,"","","PRCERR")
KILL PRCERR
+22 IF ";RETURNED TO SERVICE BY PPM;RETURNED TO SERVICE BY P&C;"[(";"_$$UP^XLFSTR(PRCSTAT)_";")
IF ^XTMP(PRCHJIND,"ORDER STATUS")="HD"
Begin DoDot:2
+23 NEW PRCX
SET PRCX=$$ECMSRETN^PRCHJR03(PRCIEN)
+24 if 'PRCX
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="14^Return to Control Point is incomplete."
End DoDot:2
QUIT
+25 IF ";RETURNED TO SERVICE BY PPM;RETURNED TO SERVICE BY P&C;"[(";"_$$UP^XLFSTR(PRCSTAT)_";")
IF ^XTMP(PRCHJIND,"ORDER CONTROL")="CA"
Begin DoDot:2
+26 NEW PRCX
SET PRCX=$$ECMSRETN^PRCHJR03(PRCIEN)
+27 if 'PRCX
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="14^Return to Control Point is incomplete."
+28 SET PRCX=$$CANCEL(PRCIEN)
+29 if 'PRCX
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="15^Cancelation of 2237 is incomplete."
End DoDot:2
QUIT
+30 IF ^XTMP(PRCHJIND,"ORDER CONTROL")="UA"
IF ^XTMP(PRCHJIND,"ORDER STATUS")="IP"
Begin DoDot:2
+31 SET PRCX=$$RET2AO(PRCIEN)
if 'PRCX
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="13^Return to Accountable Officer is incomplete."
End DoDot:2
QUIT
+32 IF ^XTMP(PRCHJIND,"ORDER CONTROL")="UA"
IF ^XTMP(PRCHJIND,"ORDER STATUS")="HD"
Begin DoDot:2
+33 SET PRCX=$$RET2AO(PRCIEN)
if 'PRCX
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="13^Return to Accountable Officer is incomplete."
+34 SET PRCX=$$RET2CP(PRCIEN)
if 'PRCX
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="14^Return to Control Point is incomplete."
End DoDot:2
QUIT
+35 IF ^XTMP(PRCHJIND,"ORDER CONTROL")="CA"
Begin DoDot:2
+36 SET PRCX=$$RET2AO(PRCIEN)
if 'PRCX
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="13^Return to Accountable Officer is incomplete."
+37 SET PRCX=$$RET2CP(PRCIEN)
if 'PRCX
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="14^Return to Control Point is incomplete."
+38 SET PRCX=$$CANCEL(PRCIEN)
if 'PRCX
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="15^Cancelation of 2237 is incomplete."
End DoDot:2
QUIT
End DoDot:1
+39 ;
+40 IF PRCHJHDR("APP ACK TYPE")="AL"
DO BUILDACK
+41 QUIT
+42 ;
EMAIL ;Send message to users attached to 2237 being returned/canceled
+1 NEW PRCHJM1,PRCHJM2
+2 SET PRCHJM1(1)=^XTMP(PRCHJIND,"2237 TXN")
+3 SET PRCHJM1(2)=$SELECT(^XTMP(PRCHJIND,"ORDER CONTROL")="CA":2,^XTMP(PRCHJIND,"ORDER STATUS")="IP":3,^XTMP(PRCHJIND,"ORDER STATUS")="HD":4,1:"")
+4 SET PRCHJM1(3)=^XTMP(PRCHJIND,"ACTION CREATED DATE")
+5 SET PRCHJM1(4)=^XTMP(PRCHJIND,"USER","FIRSTNAME")_$SELECT(^XTMP(PRCHJIND,"USER","MIDDLENAME")'="":(" "_^("MIDDLENAME")),1:"")_" "_^XTMP(PRCHJIND,"USER","LASTNAME")
+6 SET PRCHJM1(5)=^XTMP(PRCHJIND,"EMAIL")
SET PRCHJM1(6)=^XTMP(PRCHJIND,"PHONE")
+7 SET PRCHJM2(1)=^XTMP(PRCHJIND,"RETURN REASON")
SET PRCHJM2(2)=^XTMP(PRCHJIND,"RETURN COMMENT")
+8 DO PHMSG^PRCHJMSG(.PRCHJM1,.PRCHJM2)
+9 QUIT
ORC(PRCHJSEG) ;Parse ORC segment
+1 SET ^XTMP(PRCHJIND,"ORDER CONTROL")=$$GET^HLOPRS(.PRCHJSEG,1)
+2 SET ^XTMP(PRCHJIND,"2237 TXN")=$$GET^HLOPRS(.PRCHJSEG,2,1)
+3 SET ^XTMP(PRCHJIND,"STATION")=$$GET^HLOPRS(.PRCHJSEG,2,2)
+4 SET ^XTMP(PRCHJIND,"SUBSTATION")=$$GET^HLOPRS(.PRCHJSEG,2,3)
+5 SET ^XTMP(PRCHJIND,"ECMS ACTIONUID")=$$GET^HLOPRS(.PRCHJSEG,3,1)
+6 SET ^XTMP(PRCHJIND,"ORDER STATUS")=$$GET^HLOPRS(.PRCHJSEG,5)
+7 DO GETTS^HLOPRS2(.PRCHJSEG,.PRCHJVAL,9,1)
SET ^XTMP(PRCHJIND,"ACTION CREATED DATE")=PRCHJVAL
+8 SET ^XTMP(PRCHJIND,"USER","LASTNAME")=$$GET^HLOPRS(.PRCHJSEG,10,2,1)
+9 SET ^XTMP(PRCHJIND,"USER","FIRSTNAME")=$$GET^HLOPRS(.PRCHJSEG,10,3)
+10 SET ^XTMP(PRCHJIND,"USER","MIDDLENAME")=$$GET^HLOPRS(.PRCHJSEG,10,4)
+11 SET ^XTMP(PRCHJIND,"USER","SUFFIX")=$$GET^HLOPRS(.PRCHJSEG,10,5)
+12 SET ^XTMP(PRCHJIND,"PHONE")=$$GET^HLOPRS(.PRCHJSEG,14,1)
+13 SET ^XTMP(PRCHJIND,"EMAIL")=$$GET^HLOPRS(.PRCHJSEG,14,4)
+14 SET ^XTMP(PRCHJIND,"RETURN REASON")=$$GET^HLOPRS(.PRCHJSEG,16,2)
+15 SET ^XTMP(PRCHJIND,"RETURN COMMENT")=$$GET^HLOPRS(.PRCHJSEG,16,5)
+16 QUIT
RQD(PRCHJSEG) ;Process RQD segment
+1 SET ^XTMP(PRCHJIND,"REQUISITION LINE NBR")=$$GET^HLOPRS(.PRCHJSEG,1)
+2 QUIT
RET2AO(DA) ;This module contains logic to remove the AO signature and change status to Pending Accountable Officer Sig.
+1 NEW PRCDATA,PRCERR,PRCHPCR,PRCHJDA,PRCERROR
SET PRCHPCR=1
SET PRCHJDA=DA_","
SET PRCERROR=0
+2 SET PRCDATA(443,PRCHJDA,1.5)=60
DO FILE^DIE("K","PRCDATA","PRCERR")
if $DATA(PRCERR)
SET PRCERROR=1
KILL PRCDATA,PRCERR
+3 SET PRCDATA(443,PRCHJDA,2)="@"
SET PRCDATA(443,PRCHJDA,3)="@"
SET PRCDATA(443,PRCHJDA,4)="@"
+4 DO FILE^DIE("K","PRCDATA","PRCERR")
if $DATA(PRCERR)
SET PRCERROR=1
KILL PRCDATA,PRCERR
+5 SET PRCDATA(410,PRCHJDA,39)="@"
SET PRCDATA(410,PRCHJDA,69)="@"
+6 DO FILE^DIE("EK","PRCDATA","PRCERR")
if $DATA(PRCERR)
SET PRCERROR=1
KILL PRCDATA,PRCERR
+7 SET PRCDATA(1)=^XTMP(PRCHJIND,"RETURN REASON")
SET PRCDATA(2)=^XTMP(PRCHJIND,"RETURN COMMENT")
+8 DO WP^DIE(410,PRCHJDA,61,"K","PRCDATA","PRCERR")
+9 if $DATA(PRCERR)
SET PRCERROR=1
KILL PRCDATA,PRCERR
+10 IF ^XTMP(PRCHJIND,"ORDER STATUS")="IP"
Begin DoDot:1
+11 if $$XECMSIDS^PRCHJR03($PIECE(PRCHJDA,","))
SET PRCERROR=1
+12 SET PRCDATA(443,PRCHJDA,6)="@"
+13 DO FILE^DIE("K","PRCDATA","PRCERR")
if $DATA(PRCERR)
SET PRCERROR=1
+14 KILL PRCDATA,PRCERR
End DoDot:1
+15 QUIT $SELECT(PRCERROR:0,1:1)
RET2CP(DA) ;This module contains logic to remove the Control Point Official's signature, de-commit the funds and adjust due-ins as necessary.
+1 NEW PRCHDA,PRCDATA,PRCERR,PRCHJDA,PRCERROR,PRCHJCPR,X
SET PRCHDA=DA
SET PRCERROR=0
+2 SET X=$PIECE(^PRCS(410,DA,4),"^",8)
DO TRANK^PRCSES
+3 SET PRCHJDA=DA_","
SET PRCDATA(410,PRCHJDA,44)="@"
SET PRCDATA(410,PRCHJDA,44.5)="@"
SET PRCDATA(410,PRCHJDA,44.6)="@"
+4 DO FILE^DIE("K","PRCDATA","PRCERR")
if $DATA(PRCERR)
SET PRCERROR=1
KILL PRCDATA,PRCERR
+5 SET PRCDATA(410,PRCHJDA,56)=77
DO FILE^DIE("K","PRCDATA","PRCERR")
if $DATA(PRCERR)
SET PRCERROR=1
KILL PRCDATA,PRCERR
+6 SET PRCHJCPR=1
SET PRCDATA(443,PRCHJDA,1.5)=77
DO FILE^DIE("K","PRCDATA","PRCERR")
if $DATA(PRCERR)
SET PRCERROR=1
KILL PRCDATA,PRCERR
+7 SET PRCDATA(1)=^XTMP(PRCHJIND,"RETURN REASON")
SET PRCDATA(2)=^XTMP(PRCHJIND,"RETURN COMMENT")
+8 DO WP^DIE(410,PRCHJDA,61,"K","PRCDATA","PRCERR")
+9 if $DATA(PRCERR)
SET PRCERROR=1
KILL PRCDATA,PRCERR
+10 SET DA=PRCHDA
DO REMOVE^PRCSC1(DA)
DO REMOVE^PRCSC3(DA)
+11 ;D EN3^PRCPWI
SET DA=PRCHDA
DO ADJDUEIN(DA)
+12 QUIT $SELECT(PRCERROR:0,1:1)
+13 ;
CANCEL(DA) ;This module contains logic to cancel the 2237
+1 NEW PRCDATA,PRCERR,PRCHJDA,PRCERROR,I,N,X,Y
SET PRCHJDA=DA_","
SET PRCERROR=0
+2 SET PRCDATA(410,PRCHJDA,55)="@"
SET PRCDATA(410,PRCHJDA,1)="CA"
+3 DO FILE^DIE("EK","PRCDATA","PRCERR")
if $DATA(PRCERR)
SET PRCERROR=1
KILL PRCDATA,PRCERR
+4 if $$XECMSIDS^PRCHJR03(DA)
SET PRCERROR=1
+5 SET $PIECE(^PRCS(410,DA,5),U)=0
SET $PIECE(^(6),U)=0
SET $PIECE(^(4),U)=0
SET $PIECE(^(4),U,3)=0
SET $PIECE(^(4),U,6)=0
SET $PIECE(^(4),U,8)=0
+6 IF $DATA(^PRCS(410,DA,12,0))
SET N=0
FOR I=0:0
SET N=$ORDER(^PRCS(410,DA,12,N))
if N'>0
QUIT
SET X=$PIECE(^(N,0),"^",2)
IF X
SET DA(1)=DA
SET DA=N
DO TRANK^PRCSEZZ
SET DA=DA(1)
+7 KILL DA(1)
+8 DO ERS410^PRC0G(DA_"^C")
+9 SET PRCDATA(1)=^XTMP(PRCHJIND,"RETURN REASON")
DO WP^DIE(410,PRCHJDA,61,"K","PRCDATA","PRCERR")
+10 if $DATA(PRCERR)
SET PRCERROR=1
KILL PRCDATA,PRCERR
+11 SET PRCDATA(1)=^XTMP(PRCHJIND,"RETURN COMMENT")
+12 SET PRCDATA(2)="eCMS User Who Canceled 2237: "
+13 SET PRCDATA(3)=^XTMP(PRCHJIND,"USER","LASTNAME")_","_^XTMP(PRCHJIND,"USER","FIRSTNAME")
+14 if ^XTMP(PRCHJIND,"USER","MIDDLENAME")'=""
SET PRCDATA(3)=PRCDATA(3)_" "_^("MIDDLENAME")
+15 SET PRCDATA(3)=$$UP^XLFSTR(PRCDATA(3))
+16 DO WP^DIE(410,PRCHJDA,60,"AK","PRCDATA","PRCERR")
if $DATA(PRCERR)
SET PRCERROR=1
KILL PRCDATA,PRCERR
+17 ;If a DynaMed txn, update audit file and send message to DynaMed
+18 DO EN^PRCVTCA(DA)
+19 IF $DATA(^PRC(443,DA,0))
SET DIK="^PRC(443,"
DO ^DIK
KILL DIK
+20 QUIT $SELECT(PRCERROR:0,1:1)
BUILDACK ;This module contains logic to build the ORN^O08 application acknowledgment
+1 NEW PRCHJPAR,PRCHJACK,PRCERR
+2 SET PRCHJPAR("ACK CODE")=$SELECT('$DATA(PRCHJERR):"AA",1:"AR")
+3 SET PRCHJPAR("ACCEPT ACK TYPE")="AL"
SET PRCHJPAR("MESSAGE TYPE")="ORN"
SET PRCHJPAR("EVENT")="O08"
+4 SET PRCHJPAR("FIELD SEPARATOR")="|"
SET PRCHJPAR("ENCODING CHARACTERS")="^~\&"
+5 SET PRCHJPAR("MESSAGE STRUCTURE CODE")="ORN_O08"
SET PRCHJPAR("VERSION")=2.5
+6 IF '$$ACK^HLOAPI2(.PRCHJMSG,.PRCHJPAR,.PRCHJACK,.PRCERR)
QUIT
+7 IF '$DATA(PRCHJERR)
Begin DoDot:1
+8 DO SET^HLOAPI(.PRCSEG,"ORC",0)
DO SET^HLOAPI(.PRCSEG,"XR",1)
+9 DO SET^HLOAPI(.PRCSEG,^XTMP(PRCHJIND,"2237 TXN"),2,1)
+10 DO SET^HLOAPI(.PRCSEG,^XTMP(PRCHJIND,"STATION"),2,2)
+11 DO SET^HLOAPI(.PRCSEG,^XTMP(PRCHJIND,"SUBSTATION"),2,3)
+12 DO SET^HLOAPI(.PRCSEG,^XTMP(PRCHJIND,"ECMS ACTIONUID"),3,1)
+13 SET PRCX=$$ADDSEG^HLOAPI(.PRCHJACK,.PRCSEG,.PRCERR,.PRCARR)
+14 KILL PRCSEG
DO SET^HLOAPI(.PRCSEG,"RQD",0)
DO SET^HLOAPI(.PRCSEG,9999,1)
+15 SET PRCX=$$ADDSEG^HLOAPI(.PRCHJACK,.PRCSEG,.PRCERR,.PRCARR)
End DoDot:1
+16 IF $DATA(PRCHJERR)
Begin DoDot:1
+17 NEW PRCI
SET PRCI=0
+18 FOR
SET PRCI=$ORDER(PRCHJERR(PRCI))
if PRCI=""
QUIT
Begin DoDot:2
+19 NEW PRCX,PRCY,PRCE,PRCSEG,PRCERR,PRCARR
+20 SET PRCX=PRCHJERR(PRCI)
SET PRCE=$PIECE(PRCX,U)
DO SET^HLOAPI(.PRCSEG,"ERR",0)
+21 SET PRCY=$PIECE($TEXT(ERRTABLE+PRCE),";;",2,99)
+22 DO SET^HLOAPI(.PRCSEG,$PIECE(PRCY,U,2),2,1)
DO SET^HLOAPI(.PRCSEG,1,2,2)
DO SET^HLOAPI(.PRCSEG,$PIECE(PRCY,U,3),2,3)
+23 if $PIECE(PRCY,U,4)
DO SET^HLOAPI(.PRCSEG,$PIECE(PRCY,U,4),2,5)
+24 if $PIECE(PRCY,U,5)
DO SET^HLOAPI(.PRCSEG,$PIECE(PRCY,U,5),2,6)
+25 DO SET^HLOAPI(.PRCSEG,$PIECE(PRCY,U,6),3,1)
DO SET^HLOAPI(.PRCSEG,$PIECE(PRCY,U,7),3,2)
DO SET^HLOAPI(.PRCSEG,"HL70357",3,3)
+26 DO SET^HLOAPI(.PRCSEG,$PIECE(PRCY,U,8),4)
DO SET^HLOAPI(.PRCSEG,$PIECE(PRCY,U),5,1)
DO SET^HLOAPI(.PRCSEG,$PIECE(PRCY,U,9),5,2)
+27 DO SET^HLOAPI(.PRCSEG,$PIECE(PRCX,U,2),8)
+28 SET PRCX=$$ADDSEG^HLOAPI(.PRCHJACK,.PRCSEG,.PRCERR,.PRCARR)
End DoDot:2
End DoDot:1
+29 KILL PRCERR
+30 IF '$$SENDACK^HLOAPI2(.PRCHJACK,.PRCERR)
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="The sending of Application Acknowledgment to eCMS failed."
+31 SET PRCHJNOW=$$NOW^XLFDT
DO LOGORN^PRCHJR03
+32 QUIT
VALIDATE() ;Validate the data and existence of the 2237 and return
+1 ; 1 if valid and 0 if there are errors
+2 NEW PRC2237,PRCIEN,PRCSIEN,PRCSTAT,PRCSTN
+3 SET PRCHJCTR=0
KILL PRCHJERR
+4 IF '$DATA(^XTMP(PRCHJIND,"ORDER CONTROL"))
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="19^HL7 message is malformed as there is no ORC segment."
QUIT 0
+5 IF ^XTMP(PRCHJIND,"USER","LASTNAME")=""!(^XTMP(PRCHJIND,"USER","FIRSTNAME")="")
Begin DoDot:1
+6 SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="1^eCMS User Name lacks first or last name."
End DoDot:1
+7 IF ^XTMP(PRCHJIND,"2237 TXN")=""
Begin DoDot:1
+8 SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="11^2237 transaction number is not populated."
End DoDot:1
+9 IF ^XTMP(PRCHJIND,"RETURN REASON")=""
Begin DoDot:1
+10 SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="2^Reason for Return is not populated."
End DoDot:1
+11 IF ^XTMP(PRCHJIND,"RETURN COMMENT")=""
Begin DoDot:1
+12 SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="3^Comments is not populated."
End DoDot:1
+13 IF ";CA;UA;"'[(";"_^XTMP(PRCHJIND,"ORDER CONTROL")_";")
Begin DoDot:1
+14 SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="8^Order Control field contains '"_^XTMP(PRCHJIND,"ORDER CONTROL")_"' which is invalid."
End DoDot:1
+15 IF ";CA;HD;IP;"'[(";"_^XTMP(PRCHJIND,"ORDER STATUS")_";")
Begin DoDot:1
+16 SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="9^Order Status field contains '"_^XTMP(PRCHJIND,"ORDER STATUS")_"' which is invalid."
End DoDot:1
+17 SET PRC2237=$GET(^XTMP(PRCHJIND,"2237 TXN"))
SET PRCIEN=$$FIND1^DIC(410,"","X",PRC2237,"B","","PRCERR")
+18 IF PRCIEN'>0
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="6^"_PRC2237_" does not exist."
+19 IF PRCIEN
Begin DoDot:1
+20 KILL PRCERR
+21 SET PRCSTAT=$$GET1^DIQ(410,PRCIEN_",",54,"","","PRCERR")
KILL PRCERR
+22 IF PRCSTAT=""
IF $$GET1^DIQ(410,PRCIEN_",",1,"","","PRCERR")="CANCELLED"
SET PRCSTAT="Cancelled"
+23 KILL PRCERR
+24 IF ";SENT TO ECMS (P&C);ASSIGNED TO PURCHASING AGENT;RETURNED TO SERVICE BY P&C;RETURNED TO SERVICE BY PPM;"'[(";"_$$UP^XLFSTR(PRCSTAT)_";")
Begin DoDot:2
+25 SET PRCHJCTR=PRCHJCTR+1
+26 SET PRCHJERR(PRCHJCTR)="7^2237 status is '"_$SELECT(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'."
End DoDot:2
+27 IF ";RETURNED TO SERVICE BY PPM;RETURNED TO SERVICE BY P&C;"[(";"_$$UP^XLFSTR(PRCSTAT)_";")
IF ^XTMP(PRCHJIND,"ORDER STATUS")="IP"
Begin DoDot:2
+28 SET PRCHJCTR=PRCHJCTR+1
+29 SET PRCHJERR(PRCHJCTR)="21^2237 status is '"_PRCSTAT_"'. Thus 2237 cannot be returned to Accountable Officer as it is not CPO signed."
End DoDot:2
+30 KILL PRCERR
NEW PRCACTID
SET PRCACTID=$$GET1^DIQ(410,PRCIEN_",",103,"","","PRCERR")
KILL PRCERR
+31 IF PRCACTID'=^XTMP(PRCHJIND,"ECMS ACTIONUID")
Begin DoDot:2
+32 SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="18^eCMS ActionUID on 2237 is "_$SELECT(PRCACTID'="":PRCACTID,1:"null")_" but "_$SELECT(^XTMP(PRCHJIND,"ECMS ACTIONUID")'="":^XTMP(PRCHJIND,"ECMS ACTIONUID"),1:"null")_" in HL7 message."
End DoDot:2
End DoDot:1
+33 SET PRCSTN=$GET(^XTMP(PRCHJIND,"STATION"))
SET PRCSIEN=$$FIND1^DIC(411,"","X",PRCSTN,"B","","PRCERR")
KILL PRCERR
+34 IF PRCSIEN'>0
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="10^Station "_PRCSTN_" is not on this VistA instance."
+35 IF ^XTMP(PRCHJIND,"ACTION CREATED DATE")=""
Begin DoDot:1
+36 SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="16^Date/Time of action is not populated."
End DoDot:1
+37 IF ^XTMP(PRCHJIND,"ECMS ACTIONUID")=""
Begin DoDot:1
+38 SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="17^eCMS internal PR identifier ActionUID is missing."
End DoDot:1
+39 IF $GET(^XTMP(PRCHJIND,"REQUISITION LINE NBR"))'=9999
SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="12^RQD segment is not correctly populated."
+40 IF ^XTMP(PRCHJIND,"ORDER CONTROL")="UA"
IF ";HD;IP;"'[(";"_^XTMP(PRCHJIND,"ORDER STATUS")_";")
Begin DoDot:1
+41 SET PRCHJCTR=PRCHJCTR+1
SET PRCHJERR(PRCHJCTR)="20^Order Status '"_^XTMP(PRCHJIND,"ORDER STATUS")_"' is inappropriate for Order Control UA."
End DoDot:1
+42 QUIT $SELECT(PRCHJCTR:0,1:1)
+43 ;
+44 ;
ADJDUEIN(PRCDA) ;Decrement due-ins
+1 NEW PRCHJINV,PRCHJITM,PRCHJIMF,PRCHJQTY
+2 SET PRCHJINV=$PIECE($GET(^PRCS(410,PRCDA,0)),U,6)
+3 if PRCHJINV'>0
QUIT
if '$DATA(^PRCP(445,PRCHJINV,0))
QUIT
+4 SET PRCHJITM=0
+5 FOR
SET PRCHJITM=$ORDER(^PRCS(410,PRCDA,"IT",PRCHJITM))
if +PRCHJITM'=PRCHJITM
QUIT
Begin DoDot:1
+6 SET PRCHJIMF=$PIECE($GET(^PRCS(410,PRCDA,"IT",PRCHJITM,0)),U,5)
SET PRCHJQTY=$PIECE($GET(^(0)),U,2)
+7 if PRCHJIMF'>0
QUIT
if PRCHJQTY'>0
QUIT
+8 DO KILLTRAN^PRCPUTRA(PRCHJINV,PRCHJIMF,PRCDA)
End DoDot:1
+9 QUIT
+10 ;
ERRTABLE ;Table of Error data
+1 ;;1^ORC^10^^^101^Required field missing^E^eCMS user name not populated
+2 ;;2^ORC^16^2^^101^Required field missing^E^Reason for Return not populated
+3 ;;3^ORC^16^5^^101^Required field missing^E^Comments not populated
+4 ;;4^ORC^14^4^^101^Required field missing^W^User's e-mail not populated
+5 ;;5^ORC^14^1^^101^Required field missing^W^User's telephone# not populated
+6 ;;6^ORC^2^1^^204^Unknown key identifier^E^2237 transaction not found
+7 ;;7^ORC^2^1^^207^Application internal error^E^Status wrong for return or cancel
+8 ;;8^ORC^1^^^103^Table value not found^E^Order Control value is wrong
+9 ;;9^ORC^5^^^103^Table value not found^E^Order Status value is wrong
+10 ;;10^ORC^2^2^^103^Table value not found^E^Site not on VistA instance
+11 ;;11^ORC^2^1^^101^Required field missing^E^2237 txn# not populated
+12 ;;12^RQD^1^^^207^Application internal error^E^Requisition line# wrong
+13 ;;13^ORC^1^^^207^Application internal error^E^Return to AO incomplete
+14 ;;14^ORC^1^^^207^Application internal error^E^Return to CP incomplete
+15 ;;15^ORC^1^^^207^Application internal error^E^2237 cancelation incomplete
+16 ;;16^ORC^9^1^^101^Required field missing^E^Action Date/Time missing
+17 ;;17^ORC^3^1^^101^Required field missing^E^eCMS ActionUID missing
+18 ;;18^ORC^3^1^^207^Application internal error^E^eCMS ActionUID mismatch
+19 ;;19^ORC^1^^^100^Segment sequence error^E^ORC segment missing
+20 ;;20^ORC^5^^^207^Application internal error^E^Mismatch Order Control/Status
+21 ;;21^ORC^5^^^207^Application internal error^E^Cannot return to later status
