- 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 Jan 18, 2025@03:29:54 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