Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHJR01

PRCHJR01.m

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