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

PRCHJR03.m

Go to the documentation of this file.
  1. PRCHJR03 ;OI&T/LKG - PROCESS 2237 RETURN OR CANCEL FROM ECMS CONT. ;7/10/13 12:07
  1. ;;5.1;IFCAP;**167,174**;Oct 20, 2000;Build 23
  1. ;Per VHA Directive 2004-38, this routine should not be modified.
  1. LOGOMN ;Log incoming OMN^O07 message
  1. N PRCVAR1,PRCVAR2,PRCVAR3,PRCVAR4,PRCVAR5,X,Y
  1. S PRCVAR1=$G(^XTMP(PRCHJIND,"2237 TXN")),PRCVAR2=$G(^XTMP(PRCHJIND,"ECMS ACTIONUID"))
  1. S PRCVAR3=$S($G(^XTMP(PRCHJIND,"ORDER CONTROL"))="CA":10,$G(^XTMP(PRCHJIND,"ORDER STATUS"))="IP":6,1:8)
  1. S PRCVAR4("MSGDT")=PRCHJMDT,PRCVAR4("MSGID")=PRCHJMID
  1. S PRCVAR4("STN")=$G(^XTMP(PRCHJIND,"STATION")),PRCVAR4("SUBSTN")=$G(^XTMP(PRCHJIND,"SUBSTATION"))
  1. S PRCVAR4("ECMSU")=$G(^XTMP(PRCHJIND,"USER","LASTNAME"))_", "_$G(^XTMP(PRCHJIND,"USER","FIRSTNAME"))_$S($G(^XTMP(PRCHJIND,"USER","MIDDLENAME"))'="":(" "_^("MIDDLENAME")),1:"")
  1. S PRCVAR4("ECMSU")=$$UP^XLFSTR(PRCVAR4("ECMSU"))
  1. S PRCVAR4("ECMSPH")=$G(^XTMP(PRCHJIND,"PHONE")),PRCVAR4("ECMSEM")=$G(^XTMP(PRCHJIND,"EMAIL"))
  1. S PRCVAR4("ECMSDT")=$G(^XTMP(PRCHJIND,"ACTION CREATED DATE"))
  1. S PRCVAR4("ECMSRN")=$G(^XTMP(PRCHJIND,"RETURN REASON"))
  1. S PRCVAR4("ECMSCM")=$G(^XTMP(PRCHJIND,"RETURN COMMENT"))
  1. D LOG^PRCHJTA(PRCVAR1,PRCVAR2,PRCVAR3,.PRCVAR4,.PRCVAR5)
  1. Q
  1. ;
  1. LOGORN ;Log Ack ORN^O08
  1. N PRCVAR1,PRCVAR2,PRCVAR3,PRCVAR4,PRCVAR5
  1. S PRCVAR1=$G(^XTMP(PRCHJIND,"2237 TXN")),PRCVAR2=$G(^XTMP(PRCHJIND,"ECMS ACTIONUID"))
  1. S PRCVAR3=$S($G(^XTMP(PRCHJIND,"ORDER CONTROL"))="CA":11,$G(^XTMP(PRCHJIND,"ORDER STATUS"))="IP":7,1:9)
  1. S PRCVAR4("MSGDT")=PRCHJNOW,PRCVAR4("STN")=$G(^XTMP(PRCHJIND,"STATION"))
  1. S PRCVAR4("SUBSTN")=$G(^XTMP(PRCHJIND,"SUBSTATION"))
  1. I $D(PRCHJERR) D
  1. . N PRCI,PRCCNT S PRCI=0,PRCCNT=0
  1. . F S PRCI=$O(PRCHJERR(PRCI)) Q:PRCI="" D
  1. . . S PRCCNT=PRCCNT+1,PRCVAR4("ERROR",PRCCNT)=$TR(PRCHJERR(PRCI),"^",":")
  1. D LOG^PRCHJTA(PRCVAR1,PRCVAR2,PRCVAR3,.PRCVAR4,.PRCVAR5)
  1. Q
  1. ;
  1. XECMSIDS(PRCIEN) ;Removes eCMS identifiers
  1. ;Removes eCMS ActionUID at header and ItemUIDs at item line of 2237
  1. ;Input PRCIEN should be IEN of the 2237 in file #410
  1. ; Returns '0' if successful and '1' if unsuccessful
  1. Q:PRCIEN'>0 1
  1. N DA,PRCDATA,PRCERR,PRCHJDA,PRCI,PRCERROR
  1. S PRCERROR=0,PRCHJDA=PRCIEN_",",PRCDATA(410,PRCHJDA,103)="@"
  1. D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
  1. S PRCI=0
  1. F S PRCI=$O(^PRCS(410,PRCIEN,"IT",PRCI)) Q:+PRCI'=PRCI D
  1. . S PRCDATA(410.02,PRCI_","_PRCHJDA,100)="@"
  1. . D FILE^DIE("K","PRCDATA","PRCERR") S:$D(PRCERR) PRCERROR=1
  1. . K PRCDATA,PRCERR
  1. Q PRCERROR
  1. ;
  1. ECMSRETN(PRCDA) ;Processes eCMS return of 2237 already returned by IFCAP
  1. ; Ordering Officer or PPM Accountable Officer
  1. ; Input parameter PRCDA contains the IEN of the 2237 entry in
  1. ; file #410.
  1. ; This extrinsic function returns '0' if error or '1' if successful.
  1. ; As the 2237 was already returned, e-signatures were already stripped,
  1. ; dollars were already uncommitted and due-ins were already reversed.
  1. Q:$G(PRCDA)'>0 0
  1. N PRCDATA,PRCERR,PRCERROR,PRCIEN S PRCERROR=0,PRCIEN=PRCDA_","
  1. S PRCDATA(410,PRCIEN,56)=77 D FILE^DIE("K","PRCDATA","PRCERR")
  1. S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
  1. S PRCDATA(443,PRCIEN,1.5)=77 D FILE^DIE("K","PRCDATA","PRCERR")
  1. S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
  1. S PRCDATA(1)=^XTMP(PRCHJIND,"RETURN REASON")
  1. S PRCDATA(2)=^XTMP(PRCHJIND,"RETURN COMMENT")
  1. D WP^DIE(410,PRCIEN,61,"K","PRCDATA","PRCERR")
  1. S:$D(PRCERR) PRCERROR=1 K PRCDATA,PRCERR
  1. Q $S(PRCERROR:0,1:1)