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

PSOERXO1.m

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