PSOERXO1 ;ALB/BWF - eRx Outbound Error messages ; 8/3/2016 5:14pm
;;7.0;OUTPATIENT PHARMACY;**467,520,508,581,617,715,746**;DEC 1997;Build 106
;
Q
;
MSGERR() ;check errors from XML return
; note - not currently in use
;returns empty string "" if there was no error
;returns empty string "" if the only error was "ALL_PATIENT_IDS_EXCLUDED"
;otherwise returns the exceptionMessage string from the errorSection
N ORRET S ORRET=""
I $D(^TMP($J,"ORRDI","ClinicalData",0,"errorSection")) D
.N I F I="fatalErrors","errors","warnings" D
..N J S J="" F S J=$O(^TMP($J,"ORRDI","ClinicalData",0,"errorSection",0,I,J)) Q:J="" D
...N ORSTR S ORSTR=$G(^TMP($J,"ORRDI","ClinicalData",0,"errorSection",0,I,J,"errorCode",0))
...I ORSTR'="ALL_PATIENT_IDS_EXCLUDED" S ORRET=ORSTR
Q ORRET
ERRHNDL(DFN) ;handle any errors that may get thrown in call to GET^ORRDI1
K ^TMP($J,"ORRDI"),^XTMP("ORRDI","PSOO",DFN),^XTMP("ORRDI","ART",DFN)
D UNWIND^%ZTER
Q
; RXVERIFY - if this is set to 1, then this is an rxVerify message.
; - 0 or null, this is an error message
; - 2 cancel request/response
; OVRESP - override response if the response was built elsewhere
POST(ERXIEN,PSSOUT,ECODE,DESCODE,DESC,RXVERIFY,INST,OVRESP) ;
N PSS,PSSERR,PSSFDBRT,PSREQ,GBL,C,PON,RXREFN,VAR,NEWRXIEN,FFILL,TOTREFL,REFL
N TOQUAL,FRQUAL,TO,FROM,MID,RTMID,ERXIENS,F,PSODAT,RXIEN,LRDATE,NERXIEN,ERRSEQ,S2017
S F=52.49,C=0
S PSSFDBRT=1
S INST=$G(INST,"")
S GBL=$NA(^TMP("POST^PSOERXO1",$J)) K @GBL
Q:'$G(ERXIEN)
S ERXIENS=ERXIEN_","
S NEWRXIEN=$$RESOLV^PSOERXU2(ERXIEN)
D GETS^DIQ(F,ERXIENS,".01;.02;.09;.1;.13;22.1:22.4;24.1;25","IE","PSODAT")
I 'INST S INST=$G(PSODAT(F,ERXIENS,24.1,"I")) I 'INST S PSSOUT(0)=-1_U_"Unable to identify institution. Cannot send message." Q
; message ID needs to be unique from vista - Site#.DUZ.erxIEN.date.time??
S MID=INST_"."_ERXIEN_"."_$$NOW^XLFDT
; relates to message ID is the incoming message id from CH for outbound messages.
S RTMID=$G(PSODAT(F,ERXIENS,25,"E"))
; from is TO from the erx.
S FROM=$G(PSODAT(F,ERXIENS,22.3,"E"))
S FRQUAL=$G(PSODAT(F,ERXIENS,22.4,"I"))
; to is FROM from the erx
S TO=$G(PSODAT(F,ERXIENS,22.1,"E"))
S TOQUAL=$G(PSODAT(F,ERXIENS,22.2,"I"))
; /BLB/ - BEGIN CHANGE PSO*7*520 - adding prescriber order number and rxReferencenumber (.01 in the case of verify and error)
S PON=$G(PSODAT(F,ERXIENS,.09,"E"))
S RXREFN=$G(PSODAT(F,ERXIENS,.01,"E"))
; encode XML sensitive characters
F VAR="TOQUAL","TO","FRQUAL","FROM","RTMID","RXREFN","PON","MID","ECODE","DESCODE","DESC" D
.S @VAR=$$SYMENC^MXMLUTL($G(@VAR))
;/JSG/ POS*7.0*581 - BEGIN CHANGE
S S2017=$$GET1^DIQ(52.49,ERXIEN,312.1,"I")
I 1 D ; Always use new header format
.D MSG2017(.GBL,.C)
.D HDR2017(.GBL,.C,.PSODAT,ERXIEN,TOQUAL,TO,FRQUAL,FROM,MID,RTMID,RXREFN,PON,INST)
I 0 D ; Deprecated
.D C S @GBL@(C,0)="<?xml version = '1.0' encoding = 'UTF-8'?><Message version=""010"" release=""006"" xmlns=""http://www.ncpdp.org/schema/SCRIPT"">"
.D C S @GBL@(C,0)="<Header><To Qualifier="""_TOQUAL_""">"_TO_"</To><From Qualifier="""_FRQUAL_""">"_FROM_"</From><MessageID>"_MID_"</MessageID>"
.D C S @GBL@(C,0)="<RelatesToMessageID>"_RTMID_"</RelatesToMessageID><SentTime>"_$$EXTIME()_"</SentTime>"
.I $L(RXREFN) D C S @GBL@(C,0)="<RxReferenceNumber>"_RXREFN_"</RxReferenceNumber>"
.I $L(PON) D C S @GBL@(C,0)="<PrescriberOrderNumber>"_PON_"</PrescriberOrderNumber>"
.D C S @GBL@(C,0)="</Header>"
; /JSG/ - END CHANGE
; PSO*7*520 - /BLB/ - END CHANGE add handling of rxVerify Messages
; rxVerify
I $G(RXVERIFY)=1 D Q
.D C S @GBL@(C,0)="<Body><Verify><VerifyStatus><Code>010</Code><Description>Accepted By Pharmacy.</Description></VerifyStatus></Verify></Body></Message>"
.D RESTPOST(.PSSOUT,.GBL)
.K @GBL,C
; PSO*7*520 - end
; cancel response - denied type
I $G(RXVERIFY)>1 D Q
.N RESPONSE,RESTYP,RESTAG
.S RESPONSE=$S(RXVERIFY=2:"Rx not canceled - Rx not found in pharmacy system.",RXVERIFY=3:"Rx was never dispensed. Canceled at Pharmacy",1:"Response Unknown")
.I $D(OVRESP) S RESPONSE=OVRESP
.I $D(RXIEN),'$D(OVRESP) D
..S FFILL=$$GET1^DIQ(52,RXIEN,22,"I") I FFILL]"" S FFILL=$$FMTE^XLFDT(FFILL,"2D")
..S TOTREFL=$$GET1^DIQ(52,RXIEN,9,"I")
..S REFL=TOTREFL,I=0 F S I=$O(^PSRX(RXIEN,1,I)) Q:'I S REFL=REFL-1
..; p715 Use last release date instead of last dispense date
..S LRDATE=$$RXRLDT^PSOBPSUT(RXIEN),LRDATE=$$FMTE^XLFDT(LRDATE,"2D")
..S RESPONSE="First Fill:"_FFILL_", Last fill:"_$S(LRDATE:LRDATE,1:" ")_", Refills remaining:"_REFL
.S RESTYP=$S(RXVERIFY=2:"D",RXVERIFY=3:"A",1:"")
.S RESTAG=$S(RXVERIFY=2:"Denied",RXVERIFY=3:"Approved",1:"") Q:RESTAG=""
.D C S @GBL@(C,0)="<Body><CancelRxResponse><Response><"_RESTAG_">"
.I RESTYP="D" D C S @GBL@(C,0)="<DenialReason>"_RESPONSE_"</DenialReason>"
.I RESTYP="A" D C S @GBL@(C,0)="<Note>"_RESPONSE_"</Note>"
.D C S @GBL@(C,0)="</"_RESTAG_"></Response></CancelRxResponse></Body></Message>"
.D RESTPOST(.PSSOUT,.GBL)
.; if the post was unsuccessful, inform the user and quit.
.I $P(PSSOUT(0),U)<1 S PSSOUT("errorMessage")=$P(PSSOUT(0),U,2)
.S HUBID=$G(PSSOUT("outboundMsgId")) I 'HUBID S PSSOUT("errorMessage")="The eRx Processing hub did not return a Hub identification number."
.I $$PROD^XUPROD(),$D(PSSOUT("errorMessage")) D Q
..D UPDSTAT^PSOERXU1(ERXIEN,"CAX")
..S ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN) Q:'ERRSEQ
..D FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$G(PSSOUT("errorMessage")))
.; vista generated message will be V12345 (V concatenated to the hubId)
.S HUBID="V"_HUBID
.;file the cancel response in the holding queue.
.D CMFILE(HUBID,MID,RTMID,TOQUAL,TO,FRQUAL,FROM,RXREFN,PON,RESPONSE,RESTYP,"CN",INST)
.K @GBL,C
; outbound error
D C S @GBL@(C,0)="<Body><Error><Code>"_$G(ECODE)_"</Code>"
I $L(DESCODE) D C S @GBL@(C,0)="<DescriptionCode>"_$G(DESCODE)_"</DescriptionCode>"
D C S @GBL@(C,0)="<Description>"_$G(DESC)_"</Description>"
D C S @GBL@(C,0)="</Error></Body></Message>"
D RESTPOST(.PSSOUT,.GBL)
K @GBL,C
Q
C ;
S C=C+1
Q
RESTPOST(PSSOUT,GBL) ;
N $ETRAP,$ESTACK,PSREQ
N PSREQ,PSS,PSSERR,GLOOP,GDAT
; Set error trap
SET $ETRAP="DO ERROR^PSSHTTP"
K ^TMP($J,"OUT") ; if exists from previous runs, posting would not execute.
SET PSS("server")="PSO WEB SERVER"
SET PSS("webserviceName")="PSO ERX WEB SERVICE"
SET PSS("path")="services/rest/vistaoutboundMsg/processXMLMessage"
SET PSS("parameterName")="xmlRequest"
;
; get instance of client REST request object
SET PSS("restObject")=$$GETREST^XOBWLIB(PSS("webserviceName"),PSS("server"))
IF $DATA(^TMP($JOB,"OUT","EXCEPTION"))>0 S PSSOUT(0)="-1^"_^TMP($JOB,"OUT","EXCEPTION") K ^TMP($JOB,"OUT","EXCEPTION") Q PSSOUT
;
; insert XML as parameter
S PSS("restObject").ContentType="application/xml"
S GLOOP=0 F S GLOOP=$O(@GBL@(GLOOP)) Q:'GLOOP D
.S GDAT=$G(@GBL@(GLOOP,0))
.DO PSS("restObject").EntityBody.Write(GDAT)
IF $DATA(^TMP($JOB,"OUT","EXCEPTION"))>0 S PSSOUT(0)="-1^"_^TMP($JOB,"OUT","EXCEPTION") K ^TMP($JOB,"OUT","EXCEPTION") QUIT PSSOUT
;
; execute HTTP Post method
SET PSS("postResult")=$$POST^XOBWLIB(PSS("restObject"),PSS("path"),.PSSERR)
;
; *** TEST ACCOUNT EXECUTION ONLY *** - Returns success for eRx Simulation Testing when there is no connection
I '$$PROD^XUPROD(),$G(^TMP($J,"OUT","EXCEPTION"))["Unable to open TCP/IP socket" D
. S PSS("postResult")=1 F S PSSOUT("outboundMsgId")="999"_$R(1000000) I '$D(^PS(52.49,"B",PSSOUT("outboundMsgId"))) Q
. K ^TMP($J,"OUT","EXCEPTION")
;
IF $DATA(^TMP($JOB,"OUT","EXCEPTION"))>0 S PSSOUT(0)="-1^"_^TMP($JOB,"OUT","EXCEPTION") K ^TMP($JOB,"OUT","EXCEPTION") QUIT PSSOUT
;
; response coming back
;<vistaOutboundResponse><success>true</success></vistaOutboundResponse>
; error handling
DO:'PSS("postResult")
. SET PSSOUT(0)=-1_U_"Unable to make http request."
. SET PSS("result")=0
. QUIT
;
; if everything is ok parse the returned xml result
I PSS("postResult") S PSS("result")=1 D PRSSTRM(PSS("restObject"),.PSSOUT) S PSSOUT(0)=1
; for now we do not pass back the message ID for storage into 52.49
Q PSS("result")
;
; input: RESTOBJ--a rest object
; output: PSSOUT - array containing the list of route names for the given drug.
;
; parse the XML into tokens. the first part of the token is the type of node being read.
; the second part is the data--either the name of the node, or data. these fields are delimited using "<>".
; if the node is type attribute, each attribute is separated by a caret ("^").
;
N AREADER
S AREADER=$$GETREADR(RESTOBJ)
D PARSXML(AREADER,.PSSOUT)
Q
;
PARSXML(AREADER,PSSOUT) ; extract the list of routes from XML results
; input: AREADER-%XML.TextReader object.
; output: PSSOUT - array containing the list of route names for the given drug.
;
N ATOKEN,NODETYPE
F D Q:AREADER.EOF
.S ATOKEN=$$GETTOKEN(AREADER)
.I '$L(ATOKEN) Q
.S NODETYPE=$P(ATOKEN,"<>"),ATOKEN=$P(ATOKEN,"<>",2)
.I ATOKEN="errorMessage" D POSTERR(AREADER,.PSSOUT)
.I ATOKEN="success" D POSTRES(AREADER,.PSSOUT,ATOKEN)
.I ATOKEN="outboundMsgId" D POSTRES(AREADER,.PSSOUT,ATOKEN)
Q
;
POSTRES(AREADER,PSSOUT,ATOKEN) ; get value of success/failure
N TOKEN,TYPE,QPARAM
S QPARAM="/"_ATOKEN
F D Q:TOKEN=QPARAM
.S TOKEN=$$GETTOKEN(AREADER)
.S TYPE=$P(TOKEN,"<>"),TOKEN=$P(TOKEN,"<>",2)
.Q:'$L(TOKEN)!(TOKEN=QPARAM)
.S PSSOUT(ATOKEN)=TOKEN
Q
POSTERR(AREADER,PSSOUT) ; get error message
N TOKEN,TYPE
F D Q:TOKEN="/errorMessage"
.S TOKEN=$$GETTOKEN(AREADER)
.S TYPE=$P(TOKEN,"<>"),TOKEN=$P(TOKEN,"<>",2)
.Q:'$L(TOKEN)!(TOKEN="/errorMessage")
.S PSSOUT("errorMessage")=$TR(TOKEN,$C(10)," ")
Q
;
GETREADR(RESTOBJ) ; set up and return a Textreader object to be used to parse the XML stream
; input: RESTOBJ- REST object
; output: returns a %XML.TextReader object.
;
N AREADER
S AREADER=##class(%XML.TextReader).%New("%XML.TextReader")
D ##class(%XML.TextReader).ParseStream(RESTOBJ.HttpResponse.Data,.AREADER)
Q AREADER
;
GETTOKEN(READER) ; get a token at a time
; input: AREADER-%XML.TextReader object
; Output: returns a token
;
; this is the key to the parsing of the XML stream.
; each element is parsed with its associated data (if any)
; the nodetype is concatenated with "<>" with the Token
; which can be the tag or the data.
; for example each time is called return one of the following:
; . . .
; . . .
; drug(attributes)<>gcnSeqNo=17240
; element<>routes
; element<>route
; element<>id
; chars<>006
; endelement<>/id
; element<>name
; chars<>CONTINUOUS INFUSION
; endelement<>/name
; endelement<>/route
; . . .
; . . .
;
N TOKEN,NODETYPE,SUBTOKEN,ALLTOKEN
S TOKEN="",SUBTOKEN="",NODETYPE="",ALLTOKEN=""
D
.Q:READER.EOF
.D READER.Read() ; go to first node
.Q:READER.EOF ; try before and after read
.I READER.HasAttributes D
..S NODETYPE=READER.Name_"(attributes)"
..S TOKEN=$$GETATTS(READER)
.I '$L(TOKEN) S NODETYPE=READER.NodeTypeGet() D
..I NODETYPE="element" S TOKEN=READER.Name Q
..I NODETYPE="chars" S TOKEN=READER.Value Q
..I NODETYPE="endelement" S TOKEN="/"_READER.Name Q
..I NODETYPE="comment" S TOKEN="^"
..I NODETYPE="processinginstruction" S TOKEN=READER.Value Q
..I NODETYPE="ignorablewhitespace" S TOKEN="^" Q
..I NODETYPE="startprefixmapping" S TOKEN=READER.Value Q
..I NODETYPE="warning" S TOKEN=READER.Value Q
..I '$L(TOKEN) S TOKEN="^"
..;
.I $L(NODETYPE) S ALLTOKEN=NODETYPE_"<>"_TOKEN
Q ALLTOKEN
;
GETATTS(AREADER) ; get attributes
; input: AREADER-%XML.TextReader object
; Output: returns the attributes
;
N I,INDEX,TOKEN,SUBTOKEN,ATTRB
S (TOKEN,SUBTOKEN)=""
S INDEX=AREADER.AttributeCountGet()
FOR I=1:1:INDEX D
.S ATTRB=AREADER.MoveToAttributeIndex(I) D
.S SUBTOKEN=AREADER.Name_"="_AREADER.Value
.I '$L(TOKEN) S TOKEN=SUBTOKEN Q
.S TOKEN=TOKEN_"^"_SUBTOKEN
Q TOKEN
EXTIME(IDTTM) ;
N YY,MM,DD,TIME,EXDT,TLEN,I,TZONE,DTTM
S IDTTM=$G(IDTTM,"")
S DTTM=$S($L(IDTTM):$$FMTHL7^XLFDT(IDTTM),1:$$FMTHL7^XLFDT($$NOW^XLFDT()))
S TZONE=$P(DTTM,"-",2)
I 'TZONE S TZONE=$P($$FMTHL7^XLFDT($$NOW^XLFDT()),"-",2)
S DTTM=$P(DTTM,"-"),TZONE=$E(TZONE,1,2)_":"_$E(TZONE,3,4)
S YY=$E(DTTM,1,4),MM=$E(DTTM,5,6),DD=$E(DTTM,7,8),TIME=$E(DTTM,9,$L(DTTM))
I $L(TIME)<6 D
.S TLEN=$L(TIME)
.F I=TLEN:1:6 D
..S TIME=TIME_0
; now construct the date
S EXDT=YY_"-"_MM_"-"_DD_"T"_$E(TIME,1,2)_":"_$E(TIME,3,4)_":"_$E(TIME,5,6)_$S($L(TZONE):"-"_TZONE,1:"")
Q EXDT
;
; HUBID - hub identification number returned upon successful transmission
; MID - message id
; RTMID - relates to message ID
; TOQUAL - to qualifier
; TO - to value (the 'from' value from the original message)
; FRQUAL - from qualifier
; FROM - who the message was from the 'to' value from the original message
; RXREFN - rx reference number
; PON - prescriber order number
; RESPONSE - response text in the response XML
; RESTYPE - 'A' = approved, 'D' = denied
; RELIEN - related message ien
; RESTAT - response status
; MTYPE - CANCEL REQUEST/CANCEL RESPONSE
CMFILE(HUBID,MID,RTMID,TOQUAL,TO,FRQUAL,FROM,RXREFN,PON,RESPONSE,RESTYPE,MTYPE,INST) ;
N FDA,F,NRXIEN,CREQ,NEWRX
S F=52.49
; if there is no related message id, use the division passed by the hub for the cancelRx
S FDA(F,"+1,",.01)=HUBID
S FDA(F,"+1,",.02)=RTMID
S FDA(F,"+1,",.03)=$$NOW^XLFDT
S FDA(F,"+1,",.06)=$G(INST)
S FDA(F,"+1,",.08)=MTYPE
S FDA(F,"+1,",1)=$$PRESOLV^PSOERXA1("CNP","ERX")
S FDA(F,"+1,",.14)=$G(RXREFN)
S FDA(F,"+1,",22.1)=FROM
S FDA(F,"+1,",22.2)=FRQUAL
S FDA(F,"+1,",22.3)=TO
S FDA(F,"+1,",22.4)=TOQUAL
S FDA(F,"+1,",24.1)=$G(INST)
S FDA(F,"+1,",25)=MID
S FDA(F,"+1,",51.1)=$G(DUZ)
S FDA(F,"+1,",52.1)=RESTYPE
S FDA(F,"+1,",52.2)=RESPONSE
S FDA(F,"+1,",312.1)=1
D UPDATE^DIE(,"FDA","NRXIEN","ERR") K FDA
S NERXIEN=$O(NRXIEN(0)),NERXIEN=$G(NRXIEN(NERXIEN)) Q:'NERXIEN
S CREQ=$$GETREQ^PSOERXU2(NERXIEN)
S NEWRX=$$FINDNRX^PSOERXU6(CREQ)
; If there is no new Rx, link this to the cancel request
I 'NEWRX S NEWRX=CREQ
; link both records
I '$D(^PS(52.49,NEWRX,201,"B",NERXIEN)) D
.S FDA(52.49201,"+1,"_NEWRX_",",.01)=NERXIEN D UPDATE^DIE(,"FDA") K FDA
I '$D(^PS(52.49,NERXIEN,201,"B",NEWRX)) D
.S FDA(52.49201,"+1,"_NERXIEN_",",.01)=NEWRX D UPDATE^DIE(,"FDA") K FDA
Q
;
MSG2017(GBL,CNT) ; ADAPTED FROM PSOERXX2
;/JSG/ POS*7.0*581 - BEGIN CHANGE
N X
S X="<?xml version=""1.0"" encoding=""UTF-8""?>"
S X=X_"<Message TransportVersion=""20170715"" DatatypesVersion=""20170715"""
S X=X_" TransactionDomain=""SCRIPT"" TransactionVersion=""20170715"""
S X=X_" StructuresVersion=""20170715"" ECLVersion=""20170715"""
S X=X_" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"">"
D C S @GBL@(CNT,0)=X
;/JSG/ - END CHANGE
Q
;
HDR2017(GLB,CNT,PSDAT,IEN,TOQUAL,TOVAL,FRQUAL,FRVAL,MID,RTMID,ERXHID,PON,INST) ; ADAPTED FROM PSOERXX2
N F,STIME,STERTID,RTERTID,RETREC,REQREF,PSDAT,SSECID,RSECID,IENS
S F=52.49
S IENS=IEN_","
D CONVXML^PSOERXX1("PSDAT")
; return receipt and request reference # currently not stored. Do we need to add a field in 52.49?
S RETREC=$G(PSDAT(F,IENS,1,"E"))
S REQREF=$G(PSDAT(F,IENS,1,"E"))
S RETREC="ACA",REQREF=""
S SSECID=$G(PSDAT(F,IENS,24.5,"E"))
; leaving this in place for now CH wanted the tertiary ID to be TECHNATOMY. I suspect this will
; need to be something different in the long run
;S STERTID=$G(PSDAT(F,IENS,24.6,"E"))
S STERTID="TECHNATOMY"
S RSECID=$G(PSDAT(F,IENS,24.3,"E"))
;S RTERTID=$G(PSDAT(F,IENS,24.4,"E"))
S RTERTID="ERXPAD"
D C S @GBL@(CNT,0)="<Header><To Qualifier="""_TOQUAL_""">"_TOVAL_"</To>"
D C S @GBL@(CNT,0)="<From Qualifier="""_FRQUAL_""">"_FRVAL_"</From>"
D C S @GBL@(CNT,0)="<MessageID>"_MID_"</MessageID>"
; relatesToMessageID is the CH messageID - FIELD 25
I $L(RTMID) D C S @GBL@(CNT,0)="<RelatesToMessageID>"_RTMID_"</RelatesToMessageID>"
D C S @GBL@(CNT,0)="<SentTime>"_$$EXTIME^PSOERXO1()_"</SentTime>"
; bwf - LOOK AT THE SECURITY SECTION AGAIN
D C S @GBL@(CNT,0)="<Security>"
; bwf - missing UsernameToken - consider as part of v3
D C S @GBL@(CNT,0)="<Sender>"
; for now we are not using secondary identifications, this will stay in place for future activation.
;I $L(SSECID) D C S @GBL@(CNT,0)="<SecondaryIdentification>"_SSECID_"</SecondaryIdentification>"
I $L(STERTID) D C S @GBL@(CNT,0)="<TertiaryIdentification>"_STERTID_"</TertiaryIdentification>"
D C S @GBL@(CNT,0)="</Sender>"
D C S @GBL@(CNT,0)="<Receiver>"
;I $L(RSECID) D C S @GBL@(CNT,0)="<SecondaryIdentification>"_RSECID_"</SecondaryIdentification>"
I $L(RTERTID) D C S @GBL@(CNT,0)="<TertiaryIdentification>"_RTERTID_"</TertiaryIdentification>"
D C S @GBL@(CNT,0)="</Receiver>"
D C S @GBL@(CNT,0)="</Security>"
;/JSG/ POS*7.0*581 - BEGIN CHANGE
D C S @GBL@(CNT,0)="<SenderSoftware>"
D C S @GBL@(CNT,0)="<SenderSoftwareDeveloper>VA</SenderSoftwareDeveloper>"
D C S @GBL@(CNT,0)="<SenderSoftwareProduct>VA-Inbound eRx</SenderSoftwareProduct>"
D C S @GBL@(CNT,0)="<SenderSoftwareVersionRelease>V5.0</SenderSoftwareVersionRelease>"
D C S @GBL@(CNT,0)="</SenderSoftware>"
;/JSG/ - END CHANGE
; missing 'Mailbox' - note for future enhancement. Was not needed for CH certification.
D C S @GBL@(CNT,0)="<RxReferenceNumber>"_ERXHID_"</RxReferenceNumber>"
I $L(PON) D C S @GBL@(CNT,0)="<PrescriberOrderNumber>"_PON_"</PrescriberOrderNumber>"
D C S @GBL@(CNT,0)="</Header>"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERXO1 17700 printed Dec 13, 2024@02:28:45 Page 2
PSOERXO1 ;ALB/BWF - eRx Outbound Error messages ; 8/3/2016 5:14pm
+1 ;;7.0;OUTPATIENT PHARMACY;**467,520,508,581,617,715,746**;DEC 1997;Build 106
+2 ;
+3 QUIT
+4 ;
MSGERR() ;check errors from XML return
+1 ; note - not currently in use
+2 ;returns empty string "" if there was no error
+3 ;returns empty string "" if the only error was "ALL_PATIENT_IDS_EXCLUDED"
+4 ;otherwise returns the exceptionMessage string from the errorSection
+5 NEW ORRET
SET ORRET=""
+6 IF $DATA(^TMP($JOB,"ORRDI","ClinicalData",0,"errorSection"))
Begin DoDot:1
+7 NEW I
FOR I="fatalErrors","errors","warnings"
Begin DoDot:2
+8 NEW J
SET J=""
FOR
SET J=$ORDER(^TMP($JOB,"ORRDI","ClinicalData",0,"errorSection",0,I,J))
if J=""
QUIT
Begin DoDot:3
+9 NEW ORSTR
SET ORSTR=$GET(^TMP($JOB,"ORRDI","ClinicalData",0,"errorSection",0,I,J,"errorCode",0))
+10 IF ORSTR'="ALL_PATIENT_IDS_EXCLUDED"
SET ORRET=ORSTR
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT ORRET
ERRHNDL(DFN) ;handle any errors that may get thrown in call to GET^ORRDI1
+1 KILL ^TMP($JOB,"ORRDI"),^XTMP("ORRDI","PSOO",DFN),^XTMP("ORRDI","ART",DFN)
+2 DO UNWIND^%ZTER
+3 QUIT
+4 ; RXVERIFY - if this is set to 1, then this is an rxVerify message.
+5 ; - 0 or null, this is an error message
+6 ; - 2 cancel request/response
+7 ; OVRESP - override response if the response was built elsewhere
POST(ERXIEN,PSSOUT,ECODE,DESCODE,DESC,RXVERIFY,INST,OVRESP) ;
+1 NEW PSS,PSSERR,PSSFDBRT,PSREQ,GBL,C,PON,RXREFN,VAR,NEWRXIEN,FFILL,TOTREFL,REFL
+2 NEW TOQUAL,FRQUAL,TO,FROM,MID,RTMID,ERXIENS,F,PSODAT,RXIEN,LRDATE,NERXIEN,ERRSEQ,S2017
+3 SET F=52.49
SET C=0
+4 SET PSSFDBRT=1
+5 SET INST=$GET(INST,"")
+6 SET GBL=$NAME(^TMP("POST^PSOERXO1",$JOB))
KILL @GBL
+7 if '$GET(ERXIEN)
QUIT
+8 SET ERXIENS=ERXIEN_","
+9 SET NEWRXIEN=$$RESOLV^PSOERXU2(ERXIEN)
+10 DO GETS^DIQ(F,ERXIENS,".01;.02;.09;.1;.13;22.1:22.4;24.1;25","IE","PSODAT")
+11 IF 'INST
SET INST=$GET(PSODAT(F,ERXIENS,24.1,"I"))
IF 'INST
SET PSSOUT(0)=-1_U_"Unable to identify institution. Cannot send message."
QUIT
+12 ; message ID needs to be unique from vista - Site#.DUZ.erxIEN.date.time??
+13 SET MID=INST_"."_ERXIEN_"."_$$NOW^XLFDT
+14 ; relates to message ID is the incoming message id from CH for outbound messages.
+15 SET RTMID=$GET(PSODAT(F,ERXIENS,25,"E"))
+16 ; from is TO from the erx.
+17 SET FROM=$GET(PSODAT(F,ERXIENS,22.3,"E"))
+18 SET FRQUAL=$GET(PSODAT(F,ERXIENS,22.4,"I"))
+19 ; to is FROM from the erx
+20 SET TO=$GET(PSODAT(F,ERXIENS,22.1,"E"))
+21 SET TOQUAL=$GET(PSODAT(F,ERXIENS,22.2,"I"))
+22 ; /BLB/ - BEGIN CHANGE PSO*7*520 - adding prescriber order number and rxReferencenumber (.01 in the case of verify and error)
+23 SET PON=$GET(PSODAT(F,ERXIENS,.09,"E"))
+24 SET RXREFN=$GET(PSODAT(F,ERXIENS,.01,"E"))
+25 ; encode XML sensitive characters
+26 FOR VAR="TOQUAL","TO","FRQUAL","FROM","RTMID","RXREFN","PON","MID","ECODE","DESCODE","DESC"
Begin DoDot:1
+27 SET @VAR=$$SYMENC^MXMLUTL($GET(@VAR))
End DoDot:1
+28 ;/JSG/ POS*7.0*581 - BEGIN CHANGE
+29 SET S2017=$$GET1^DIQ(52.49,ERXIEN,312.1,"I")
+30 ; Always use new header format
IF 1
Begin DoDot:1
+31 DO MSG2017(.GBL,.C)
+32 DO HDR2017(.GBL,.C,.PSODAT,ERXIEN,TOQUAL,TO,FRQUAL,FROM,MID,RTMID,RXREFN,PON,INST)
End DoDot:1
+33 ; Deprecated
IF 0
Begin DoDot:1
+34 DO C
SET @GBL@(C,0)="<?xml version = '1.0' encoding = 'UTF-8'?><Message version=""010"" release=""006"" xmlns=""http://www.ncpdp.org/schema/SCRIPT"">"
+35 DO C
SET @GBL@(C,0)="<Header><To Qualifier="""_TOQUAL_""">"_TO_"</To><From Qualifier="""_FRQUAL_""">"_FROM_"</From><MessageID>"_MID_"</MessageID>"
+36 DO C
SET @GBL@(C,0)="<RelatesToMessageID>"_RTMID_"</RelatesToMessageID><SentTime>"_$$EXTIME()_"</SentTime>"
+37 IF $LENGTH(RXREFN)
DO C
SET @GBL@(C,0)="<RxReferenceNumber>"_RXREFN_"</RxReferenceNumber>"
+38 IF $LENGTH(PON)
DO C
SET @GBL@(C,0)="<PrescriberOrderNumber>"_PON_"</PrescriberOrderNumber>"
+39 DO C
SET @GBL@(C,0)="</Header>"
End DoDot:1
+40 ; /JSG/ - END CHANGE
+41 ; PSO*7*520 - /BLB/ - END CHANGE add handling of rxVerify Messages
+42 ; rxVerify
+43 IF $GET(RXVERIFY)=1
Begin DoDot:1
+44 DO C
SET @GBL@(C,0)="<Body><Verify><VerifyStatus><Code>010</Code><Description>Accepted By Pharmacy.</Description></VerifyStatus></Verify></Body></Message>"
+45 DO RESTPOST(.PSSOUT,.GBL)
+46 KILL @GBL,C
End DoDot:1
QUIT
+47 ; PSO*7*520 - end
+48 ; cancel response - denied type
+49 IF $GET(RXVERIFY)>1
Begin DoDot:1
+50 NEW RESPONSE,RESTYP,RESTAG
+51 SET RESPONSE=$SELECT(RXVERIFY=2:"Rx not canceled - Rx not found in pharmacy system.",RXVERIFY=3:"Rx was never dispensed. Canceled at Pharmacy",1:"Response Unknown")
+52 IF $DATA(OVRESP)
SET RESPONSE=OVRESP
+53 IF $DATA(RXIEN)
IF '$DATA(OVRESP)
Begin DoDot:2
+54 SET FFILL=$$GET1^DIQ(52,RXIEN,22,"I")
IF FFILL]""
SET FFILL=$$FMTE^XLFDT(FFILL,"2D")
+55 SET TOTREFL=$$GET1^DIQ(52,RXIEN,9,"I")
+56 SET REFL=TOTREFL
SET I=0
FOR
SET I=$ORDER(^PSRX(RXIEN,1,I))
if 'I
QUIT
SET REFL=REFL-1
+57 ; p715 Use last release date instead of last dispense date
+58 SET LRDATE=$$RXRLDT^PSOBPSUT(RXIEN)
SET LRDATE=$$FMTE^XLFDT(LRDATE,"2D")
+59 SET RESPONSE="First Fill:"_FFILL_", Last fill:"_$SELECT(LRDATE:LRDATE,1:" ")_", Refills remaining:"_REFL
End DoDot:2
+60 SET RESTYP=$SELECT(RXVERIFY=2:"D",RXVERIFY=3:"A",1:"")
+61 SET RESTAG=$SELECT(RXVERIFY=2:"Denied",RXVERIFY=3:"Approved",1:"")
if RESTAG=""
QUIT
+62 DO C
SET @GBL@(C,0)="<Body><CancelRxResponse><Response><"_RESTAG_">"
+63 IF RESTYP="D"
DO C
SET @GBL@(C,0)="<DenialReason>"_RESPONSE_"</DenialReason>"
+64 IF RESTYP="A"
DO C
SET @GBL@(C,0)="<Note>"_RESPONSE_"</Note>"
+65 DO C
SET @GBL@(C,0)="</"_RESTAG_"></Response></CancelRxResponse></Body></Message>"
+66 DO RESTPOST(.PSSOUT,.GBL)
+67 ; if the post was unsuccessful, inform the user and quit.
+68 IF $PIECE(PSSOUT(0),U)<1
SET PSSOUT("errorMessage")=$PIECE(PSSOUT(0),U,2)
+69 SET HUBID=$GET(PSSOUT("outboundMsgId"))
IF 'HUBID
SET PSSOUT("errorMessage")="The eRx Processing hub did not return a Hub identification number."
+70 IF $$PROD^XUPROD()
IF $DATA(PSSOUT("errorMessage"))
Begin DoDot:2
+71 DO UPDSTAT^PSOERXU1(ERXIEN,"CAX")
+72 SET ERRSEQ=$$ERRSEQ^PSOERXU1(ERXIEN)
if 'ERRSEQ
QUIT
+73 DO FILERR^PSOERXU1(ERXIENS,ERRSEQ,"PX","V",$GET(PSSOUT("errorMessage")))
End DoDot:2
QUIT
+74 ; vista generated message will be V12345 (V concatenated to the hubId)
+75 SET HUBID="V"_HUBID
+76 ;file the cancel response in the holding queue.
+77 DO CMFILE(HUBID,MID,RTMID,TOQUAL,TO,FRQUAL,FROM,RXREFN,PON,RESPONSE,RESTYP,"CN",INST)
+78 KILL @GBL,C
End DoDot:1
QUIT
+79 ; outbound error
+80 DO C
SET @GBL@(C,0)="<Body><Error><Code>"_$GET(ECODE)_"</Code>"
+81 IF $LENGTH(DESCODE)
DO C
SET @GBL@(C,0)="<DescriptionCode>"_$GET(DESCODE)_"</DescriptionCode>"
+82 DO C
SET @GBL@(C,0)="<Description>"_$GET(DESC)_"</Description>"
+83 DO C
SET @GBL@(C,0)="</Error></Body></Message>"
+84 DO RESTPOST(.PSSOUT,.GBL)
+85 KILL @GBL,C
+86 QUIT
C ;
+1 SET C=C+1
+2 QUIT
RESTPOST(PSSOUT,GBL) ;
+1 NEW $ETRAP,$ESTACK,PSREQ
+2 NEW PSREQ,PSS,PSSERR,GLOOP,GDAT
+3 ; Set error trap
+4 SET $ETRAP="DO ERROR^PSSHTTP"
+5 ; if exists from previous runs, posting would not execute.
KILL ^TMP($JOB,"OUT")
+6 SET PSS("server")="PSO WEB SERVER"
+7 SET PSS("webserviceName")="PSO ERX WEB SERVICE"
+8 SET PSS("path")="services/rest/vistaoutboundMsg/processXMLMessage"
+9 SET PSS("parameterName")="xmlRequest"
+10 ;
+11 ; get instance of client REST request object
+12 SET PSS("restObject")=$$GETREST^XOBWLIB(PSS("webserviceName"),PSS("server"))
+13 IF $DATA(^TMP($JOB,"OUT","EXCEPTION"))>0
SET PSSOUT(0)="-1^"_^TMP($JOB,"OUT","EXCEPTION")
KILL ^TMP($JOB,"OUT","EXCEPTION")
QUIT PSSOUT
+14 ;
+15 ; insert XML as parameter
+16 SET PSS("restObject").ContentType="application/xml"
+17 SET GLOOP=0
FOR
SET GLOOP=$ORDER(@GBL@(GLOOP))
if 'GLOOP
QUIT
Begin DoDot:1
+18 SET GDAT=$GET(@GBL@(GLOOP,0))
+19 DO PSS("restObject").EntityBody.Write(GDAT)
End DoDot:1
+20 IF $DATA(^TMP($JOB,"OUT","EXCEPTION"))>0
SET PSSOUT(0)="-1^"_^TMP($JOB,"OUT","EXCEPTION")
KILL ^TMP($JOB,"OUT","EXCEPTION")
QUIT PSSOUT
+21 ;
+22 ; execute HTTP Post method
+23 SET PSS("postResult")=$$POST^XOBWLIB(PSS("restObject"),PSS("path"),.PSSERR)
+24 ;
+25 ; *** TEST ACCOUNT EXECUTION ONLY *** - Returns success for eRx Simulation Testing when there is no connection
+26 IF '$$PROD^XUPROD()
IF $GET(^TMP($JOB,"OUT","EXCEPTION"))["Unable to open TCP/IP socket"
Begin DoDot:1
+27 SET PSS("postResult")=1
FOR
SET PSSOUT("outboundMsgId")="999"_$RANDOM(1000000)
IF '$DATA(^PS(52.49,"B",PSSOUT("outboundMsgId")))
QUIT
+28 KILL ^TMP($JOB,"OUT","EXCEPTION")
End DoDot:1
+29 ;
+30 IF $DATA(^TMP($JOB,"OUT","EXCEPTION"))>0
SET PSSOUT(0)="-1^"_^TMP($JOB,"OUT","EXCEPTION")
KILL ^TMP($JOB,"OUT","EXCEPTION")
QUIT PSSOUT
+31 ;
+32 ; response coming back
+33 ;<vistaOutboundResponse><success>true</success></vistaOutboundResponse>
+34 ; error handling
+35 if 'PSS("postResult")
Begin DoDot:1
+36 SET PSSOUT(0)=-1_U_"Unable to make http request."
+37 SET PSS("result")=0
+38 QUIT
End DoDot:1
+39 ;
+40 ; if everything is ok parse the returned xml result
+41 IF PSS("postResult")
SET PSS("result")=1
DO PRSSTRM(PSS("restObject"),.PSSOUT)
SET PSSOUT(0)=1
+42 ; for now we do not pass back the message ID for storage into 52.49
+43 QUIT PSS("result")
+44 ;
+1 ; input: RESTOBJ--a rest object
+2 ; output: PSSOUT - array containing the list of route names for the given drug.
+3 ;
+4 ; parse the XML into tokens. the first part of the token is the type of node being read.
+5 ; the second part is the data--either the name of the node, or data. these fields are delimited using "<>".
+6 ; if the node is type attribute, each attribute is separated by a caret ("^").
+7 ;
+8 NEW AREADER
+9 SET AREADER=$$GETREADR(RESTOBJ)
+10 DO PARSXML(AREADER,.PSSOUT)
+11 QUIT
+12 ;
PARSXML(AREADER,PSSOUT) ; extract the list of routes from XML results
+1 ; input: AREADER-%XML.TextReader object.
+2 ; output: PSSOUT - array containing the list of route names for the given drug.
+3 ;
+4 NEW ATOKEN,NODETYPE
+5 FOR
Begin DoDot:1
+6 SET ATOKEN=$$GETTOKEN(AREADER)
+7 IF '$LENGTH(ATOKEN)
QUIT
+8 SET NODETYPE=$PIECE(ATOKEN,"<>")
SET ATOKEN=$PIECE(ATOKEN,"<>",2)
+9 IF ATOKEN="errorMessage"
DO POSTERR(AREADER,.PSSOUT)
+10 IF ATOKEN="success"
DO POSTRES(AREADER,.PSSOUT,ATOKEN)
+11 IF ATOKEN="outboundMsgId"
DO POSTRES(AREADER,.PSSOUT,ATOKEN)
End DoDot:1
if AREADER.EOF
QUIT
+12 QUIT
+13 ;
POSTRES(AREADER,PSSOUT,ATOKEN) ; get value of success/failure
+1 NEW TOKEN,TYPE,QPARAM
+2 SET QPARAM="/"_ATOKEN
+3 FOR
Begin DoDot:1
+4 SET TOKEN=$$GETTOKEN(AREADER)
+5 SET TYPE=$PIECE(TOKEN,"<>")
SET TOKEN=$PIECE(TOKEN,"<>",2)
+6 if '$LENGTH(TOKEN)!(TOKEN=QPARAM)
QUIT
+7 SET PSSOUT(ATOKEN)=TOKEN
End DoDot:1
if TOKEN=QPARAM
QUIT
+8 QUIT
POSTERR(AREADER,PSSOUT) ; get error message
+1 NEW TOKEN,TYPE
+2 FOR
Begin DoDot:1
+3 SET TOKEN=$$GETTOKEN(AREADER)
+4 SET TYPE=$PIECE(TOKEN,"<>")
SET TOKEN=$PIECE(TOKEN,"<>",2)
+5 if '$LENGTH(TOKEN)!(TOKEN="/errorMessage")
QUIT
+6 SET PSSOUT("errorMessage")=$TRANSLATE(TOKEN,$CHAR(10)," ")
End DoDot:1
if TOKEN="/errorMessage"
QUIT
+7 QUIT
+8 ;
GETREADR(RESTOBJ) ; set up and return a Textreader object to be used to parse the XML stream
+1 ; input: RESTOBJ- REST object
+2 ; output: returns a %XML.TextReader object.
+3 ;
+4 NEW AREADER
+5 SET AREADER=##class(%XML.TextReader).%New("%XML.TextReader")
+6 DO ##class(%XML.TextReader).ParseStream(RESTOBJ.HttpResponse.Data,.AREADER)
+7 QUIT AREADER
+8 ;
GETTOKEN(READER) ; get a token at a time
+1 ; input: AREADER-%XML.TextReader object
+2 ; Output: returns a token
+3 ;
+4 ; this is the key to the parsing of the XML stream.
+5 ; each element is parsed with its associated data (if any)
+6 ; the nodetype is concatenated with "<>" with the Token
+7 ; which can be the tag or the data.
+8 ; for example each time is called return one of the following:
+9 ; . . .
+10 ; . . .
+11 ; drug(attributes)<>gcnSeqNo=17240
+12 ; element<>routes
+13 ; element<>route
+14 ; element<>id
+15 ; chars<>006
+16 ; endelement<>/id
+17 ; element<>name
+18 ; chars<>CONTINUOUS INFUSION
+19 ; endelement<>/name
+20 ; endelement<>/route
+21 ; . . .
+22 ; . . .
+23 ;
+24 NEW TOKEN,NODETYPE,SUBTOKEN,ALLTOKEN
+25 SET TOKEN=""
SET SUBTOKEN=""
SET NODETYPE=""
SET ALLTOKEN=""
+26 Begin DoDot:1
+27 if READER.EOF
QUIT
+28 ; go to first node
DO READER.Read()
+29 ; try before and after read
if READER.EOF
QUIT
+30 IF READER.HasAttributes
Begin DoDot:2
+31 SET NODETYPE=READER.Name_"(attributes)"
+32 SET TOKEN=$$GETATTS(READER)
End DoDot:2
+33 IF '$LENGTH(TOKEN)
SET NODETYPE=READER.NodeTypeGet()
Begin DoDot:2
+34 IF NODETYPE="element"
SET TOKEN=READER.Name
QUIT
+35 IF NODETYPE="chars"
SET TOKEN=READER.Value
QUIT
+36 IF NODETYPE="endelement"
SET TOKEN="/"_READER.Name
QUIT
+37 IF NODETYPE="comment"
SET TOKEN="^"
+38 IF NODETYPE="processinginstruction"
SET TOKEN=READER.Value
QUIT
+39 IF NODETYPE="ignorablewhitespace"
SET TOKEN="^"
QUIT
+40 IF NODETYPE="startprefixmapping"
SET TOKEN=READER.Value
QUIT
+41 IF NODETYPE="warning"
SET TOKEN=READER.Value
QUIT
+42 IF '$LENGTH(TOKEN)
SET TOKEN="^"
+43 ;
End DoDot:2
+44 IF $LENGTH(NODETYPE)
SET ALLTOKEN=NODETYPE_"<>"_TOKEN
End DoDot:1
+45 QUIT ALLTOKEN
+46 ;
GETATTS(AREADER) ; get attributes
+1 ; input: AREADER-%XML.TextReader object
+2 ; Output: returns the attributes
+3 ;
+4 NEW I,INDEX,TOKEN,SUBTOKEN,ATTRB
+5 SET (TOKEN,SUBTOKEN)=""
+6 SET INDEX=AREADER.AttributeCountGet()
+7 FOR I=1:1:INDEX
Begin DoDot:1
+8 SET ATTRB=AREADER.MoveToAttributeIndex(I)
Begin DoDot:2
End DoDot:2
+9 SET SUBTOKEN=AREADER.Name_"="_AREADER.Value
+10 IF '$LENGTH(TOKEN)
SET TOKEN=SUBTOKEN
QUIT
+11 SET TOKEN=TOKEN_"^"_SUBTOKEN
End DoDot:1
+12 QUIT TOKEN
EXTIME(IDTTM) ;
+1 NEW YY,MM,DD,TIME,EXDT,TLEN,I,TZONE,DTTM
+2 SET IDTTM=$GET(IDTTM,"")
+3 SET DTTM=$SELECT($LENGTH(IDTTM):$$FMTHL7^XLFDT(IDTTM),1:$$FMTHL7^XLFDT($$NOW^XLFDT()))
+4 SET TZONE=$PIECE(DTTM,"-",2)
+5 IF 'TZONE
SET TZONE=$PIECE($$FMTHL7^XLFDT($$NOW^XLFDT()),"-",2)
+6 SET DTTM=$PIECE(DTTM,"-")
SET TZONE=$EXTRACT(TZONE,1,2)_":"_$EXTRACT(TZONE,3,4)
+7 SET YY=$EXTRACT(DTTM,1,4)
SET MM=$EXTRACT(DTTM,5,6)
SET DD=$EXTRACT(DTTM,7,8)
SET TIME=$EXTRACT(DTTM,9,$LENGTH(DTTM))
+8 IF $LENGTH(TIME)<6
Begin DoDot:1
+9 SET TLEN=$LENGTH(TIME)
+10 FOR I=TLEN:1:6
Begin DoDot:2
+11 SET TIME=TIME_0
End DoDot:2
End DoDot:1
+12 ; now construct the date
+13 SET EXDT=YY_"-"_MM_"-"_DD_"T"_$EXTRACT(TIME,1,2)_":"_$EXTRACT(TIME,3,4)_":"_$EXTRACT(TIME,5,6)_$SELECT($LENGTH(TZONE):"-"_TZONE,1:"")
+14 QUIT EXDT
+15 ;
+16 ; HUBID - hub identification number returned upon successful transmission
+17 ; MID - message id
+18 ; RTMID - relates to message ID
+19 ; TOQUAL - to qualifier
+20 ; TO - to value (the 'from' value from the original message)
+21 ; FRQUAL - from qualifier
+22 ; FROM - who the message was from the 'to' value from the original message
+23 ; RXREFN - rx reference number
+24 ; PON - prescriber order number
+25 ; RESPONSE - response text in the response XML
+26 ; RESTYPE - 'A' = approved, 'D' = denied
+27 ; RELIEN - related message ien
+28 ; RESTAT - response status
+29 ; MTYPE - CANCEL REQUEST/CANCEL RESPONSE
CMFILE(HUBID,MID,RTMID,TOQUAL,TO,FRQUAL,FROM,RXREFN,PON,RESPONSE,RESTYPE,MTYPE,INST) ;
+1 NEW FDA,F,NRXIEN,CREQ,NEWRX
+2 SET F=52.49
+3 ; if there is no related message id, use the division passed by the hub for the cancelRx
+4 SET FDA(F,"+1,",.01)=HUBID
+5 SET FDA(F,"+1,",.02)=RTMID
+6 SET FDA(F,"+1,",.03)=$$NOW^XLFDT
+7 SET FDA(F,"+1,",.06)=$GET(INST)
+8 SET FDA(F,"+1,",.08)=MTYPE
+9 SET FDA(F,"+1,",1)=$$PRESOLV^PSOERXA1("CNP","ERX")
+10 SET FDA(F,"+1,",.14)=$GET(RXREFN)
+11 SET FDA(F,"+1,",22.1)=FROM
+12 SET FDA(F,"+1,",22.2)=FRQUAL
+13 SET FDA(F,"+1,",22.3)=TO
+14 SET FDA(F,"+1,",22.4)=TOQUAL
+15 SET FDA(F,"+1,",24.1)=$GET(INST)
+16 SET FDA(F,"+1,",25)=MID
+17 SET FDA(F,"+1,",51.1)=$GET(DUZ)
+18 SET FDA(F,"+1,",52.1)=RESTYPE
+19 SET FDA(F,"+1,",52.2)=RESPONSE
+20 SET FDA(F,"+1,",312.1)=1
+21 DO UPDATE^DIE(,"FDA","NRXIEN","ERR")
KILL FDA
+22 SET NERXIEN=$ORDER(NRXIEN(0))
SET NERXIEN=$GET(NRXIEN(NERXIEN))
if 'NERXIEN
QUIT
+23 SET CREQ=$$GETREQ^PSOERXU2(NERXIEN)
+24 SET NEWRX=$$FINDNRX^PSOERXU6(CREQ)
+25 ; If there is no new Rx, link this to the cancel request
+26 IF 'NEWRX
SET NEWRX=CREQ
+27 ; link both records
+28 IF '$DATA(^PS(52.49,NEWRX,201,"B",NERXIEN))
Begin DoDot:1
+29 SET FDA(52.49201,"+1,"_NEWRX_",",.01)=NERXIEN
DO UPDATE^DIE(,"FDA")
KILL FDA
End DoDot:1
+30 IF '$DATA(^PS(52.49,NERXIEN,201,"B",NEWRX))
Begin DoDot:1
+31 SET FDA(52.49201,"+1,"_NERXIEN_",",.01)=NEWRX
DO UPDATE^DIE(,"FDA")
KILL FDA
End DoDot:1
+32 QUIT
+33 ;
MSG2017(GBL,CNT) ; ADAPTED FROM PSOERXX2
+1 ;/JSG/ POS*7.0*581 - BEGIN CHANGE
+2 NEW X
+3 SET X="<?xml version=""1.0"" encoding=""UTF-8""?>"
+4 SET X=X_"<Message TransportVersion=""20170715"" DatatypesVersion=""20170715"""
+5 SET X=X_" TransactionDomain=""SCRIPT"" TransactionVersion=""20170715"""
+6 SET X=X_" StructuresVersion=""20170715"" ECLVersion=""20170715"""
+7 SET X=X_" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"">"
+8 DO C
SET @GBL@(CNT,0)=X
+9 ;/JSG/ - END CHANGE
+10 QUIT
+11 ;
HDR2017(GLB,CNT,PSDAT,IEN,TOQUAL,TOVAL,FRQUAL,FRVAL,MID,RTMID,ERXHID,PON,INST) ; ADAPTED FROM PSOERXX2
+1 NEW F,STIME,STERTID,RTERTID,RETREC,REQREF,PSDAT,SSECID,RSECID,IENS
+2 SET F=52.49
+3 SET IENS=IEN_","
+4 DO CONVXML^PSOERXX1("PSDAT")
+5 ; return receipt and request reference # currently not stored. Do we need to add a field in 52.49?
+6 SET RETREC=$GET(PSDAT(F,IENS,1,"E"))
+7 SET REQREF=$GET(PSDAT(F,IENS,1,"E"))
+8 SET RETREC="ACA"
SET REQREF=""
+9 SET SSECID=$GET(PSDAT(F,IENS,24.5,"E"))
+10 ; leaving this in place for now CH wanted the tertiary ID to be TECHNATOMY. I suspect this will
+11 ; need to be something different in the long run
+12 ;S STERTID=$G(PSDAT(F,IENS,24.6,"E"))
+13 SET STERTID="TECHNATOMY"
+14 SET RSECID=$GET(PSDAT(F,IENS,24.3,"E"))
+15 ;S RTERTID=$G(PSDAT(F,IENS,24.4,"E"))
+16 SET RTERTID="ERXPAD"
+17 DO C
SET @GBL@(CNT,0)="<Header><To Qualifier="""_TOQUAL_""">"_TOVAL_"</To>"
+18 DO C
SET @GBL@(CNT,0)="<From Qualifier="""_FRQUAL_""">"_FRVAL_"</From>"
+19 DO C
SET @GBL@(CNT,0)="<MessageID>"_MID_"</MessageID>"
+20 ; relatesToMessageID is the CH messageID - FIELD 25
+21 IF $LENGTH(RTMID)
DO C
SET @GBL@(CNT,0)="<RelatesToMessageID>"_RTMID_"</RelatesToMessageID>"
+22 DO C
SET @GBL@(CNT,0)="<SentTime>"_$$EXTIME^PSOERXO1()_"</SentTime>"
+23 ; bwf - LOOK AT THE SECURITY SECTION AGAIN
+24 DO C
SET @GBL@(CNT,0)="<Security>"
+25 ; bwf - missing UsernameToken - consider as part of v3
+26 DO C
SET @GBL@(CNT,0)="<Sender>"
+27 ; for now we are not using secondary identifications, this will stay in place for future activation.
+28 ;I $L(SSECID) D C S @GBL@(CNT,0)="<SecondaryIdentification>"_SSECID_"</SecondaryIdentification>"
+29 IF $LENGTH(STERTID)
DO C
SET @GBL@(CNT,0)="<TertiaryIdentification>"_STERTID_"</TertiaryIdentification>"
+30 DO C
SET @GBL@(CNT,0)="</Sender>"
+31 DO C
SET @GBL@(CNT,0)="<Receiver>"
+32 ;I $L(RSECID) D C S @GBL@(CNT,0)="<SecondaryIdentification>"_RSECID_"</SecondaryIdentification>"
+33 IF $LENGTH(RTERTID)
DO C
SET @GBL@(CNT,0)="<TertiaryIdentification>"_RTERTID_"</TertiaryIdentification>"
+34 DO C
SET @GBL@(CNT,0)="</Receiver>"
+35 DO C
SET @GBL@(CNT,0)="</Security>"
+36 ;/JSG/ POS*7.0*581 - BEGIN CHANGE
+37 DO C
SET @GBL@(CNT,0)="<SenderSoftware>"
+38 DO C
SET @GBL@(CNT,0)="<SenderSoftwareDeveloper>VA</SenderSoftwareDeveloper>"
+39 DO C
SET @GBL@(CNT,0)="<SenderSoftwareProduct>VA-Inbound eRx</SenderSoftwareProduct>"
+40 DO C
SET @GBL@(CNT,0)="<SenderSoftwareVersionRelease>V5.0</SenderSoftwareVersionRelease>"
+41 DO C
SET @GBL@(CNT,0)="</SenderSoftware>"
+42 ;/JSG/ - END CHANGE
+43 ; missing 'Mailbox' - note for future enhancement. Was not needed for CH certification.
+44 DO C
SET @GBL@(CNT,0)="<RxReferenceNumber>"_ERXHID_"</RxReferenceNumber>"
+45 IF $LENGTH(PON)
DO C
SET @GBL@(CNT,0)="<PrescriberOrderNumber>"_PON_"</PrescriberOrderNumber>"
+46 DO C
SET @GBL@(CNT,0)="</Header>"
+47 QUIT
