- 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 Feb 18, 2025@23:34:34 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)