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