Const WSURL As String = "http://darmanws.tamin.ir/paraclinicwebservice.asmx"
Const SVCJSON As String = "{""TAREFCODE"":""@TC"", ""Num"":""@NUM""}"
'--------------------------
Public Type Request_Response
R_Code As Integer
ERROR_MESSAGE As String
REQUEST_ID As Long
End Type
Public Function WS_TE( _
ByVal sBletSerial As String, _
ByVal sPrescDate As String, _
ByVal sDOCID As String, _
ByVal sDOC_SPEC As String, _
ByVal sParType As String, _
ByVal sCust_Service_type As String, _
ByVal TCs As String, _
ByVal NUMs As String) As Request_Response
On Error GoTo ERR_HNDLR
Dim RR As Request_Response
RR.ERROR_MESSAGE = ""
RR.REQUEST_ID = -1
'RR.Request_Result = 4
RR.R_Code = 4
Dim XM As String
XM = "<?xml version=""1.0"" encoding=""utf-8""?>"
XM = XM + "<soap12:Envelope xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"" xmlns:xsd=""http://www.w3.org/2001/XMLSchema"" xmlns:soap12=""http://www.w3.org/2003/05/soap-envelope"">"
XM = XM + "<soap12:Body>"
XM = XM + "<Save_Request xmlns=""http://tempuri.org/"">"
XM = XM + "<ParaUInfo>"
XM = XM + "<UserID>0140000025020</UserID>"
XM = XM + "<Password>k2728220K</Password>"
XM = XM + "</ParaUInfo>"
XM = XM + "<DocInfo>"
XM = XM + "<DOCID>" + sDOCID + "</DOCID>"
XM = XM + "<DOC_SPEC>" + sDOC_SPEC + "</DOC_SPEC>"
XM = XM + "<DOC_FNAME></DOC_FNAME>"
XM = XM + "<DOC_LNAME></DOC_LNAME>"
XM = XM + "<DOC_TYPE></DOC_TYPE>"
XM = XM + "</DocInfo>"
XM = XM + "<PrcInfo>"
XM = XM + "<BletSerial>" + sBletSerial + "</BletSerial>"
XM = XM + "<Mobile>091405785092</Mobile>"
XM = XM + "<PrescDate>" + sPrescDate + "</PrescDate>"
XM = XM + "<ParType>" + sParType + "</ParType>"
XM = XM + "<Cust_Service_type>" + sCust_Service_type + "</Cust_Service_type>"
XM = XM + "<Bastari>0</Bastari>"
XM = XM + "<FirstDiagnoseCode></FirstDiagnoseCode>"
XM = XM + "<Is2K>0</Is2K>"
XM = XM + "<DocFani_ID></DocFani_ID>"
XM = XM + "</PrcInfo>"
XM = XM + "<LabPrscInfo>"
XM = XM + "<LabDiagnoseCode></LabDiagnoseCode>"
XM = XM + "<LabDiagnoseComment></LabDiagnoseComment>"
XM = XM + "<LabGrpCode></LabGrpCode>"
XM = XM + "</LabPrscInfo>"
XM = XM + "<PhyPrscInfo>"
XM = XM + "<TotalSession></TotalSession>"
XM = XM + "<OrganNo></OrganNo>"
XM = XM + "<PhysioDiagnoseCode></PhysioDiagnoseCode>"
XM = XM + "<PhysioDiagnoseComment></PhysioDiagnoseComment>"
XM = XM + "<DarmanPhysio></DarmanPhysio>"
XM = XM + "<DarmanDoc></DarmanDoc>"
XM = XM + "</PhyPrscInfo>"
XM = XM + "<PrescDInfo>"
XM = XM + "<PrescDInfo>"
XM = XM + "<TAREFCODE>701715</TAREFCODE>"
XM = XM + "<Num>1</Num>"
XM = XM + "</PrescDInfo>"
XM = XM + "<PrescDInfo>"
XM = XM + "<TAREFCODE></TAREFCODE>"
XM = XM + "<Num></Num>"
XM = XM + "</PrescDInfo>"
XM = XM + "</PrescDInfo>"
XM = XM + "</Save_Request>"
XM = XM + "</soap12:Body>"
XM = XM + "</soap12:Envelope>"
'XM = XM + "<sParListJson>" + PARLIST_JSON(TCs, NUMs) + "</sParListJson>"
Dim XML_HTTP As New MSXML2.XMLHTTP60
XML_HTTP.Open "POST", WSURL, False
XML_HTTP.setRequestHeader "HOST", "DARMANWS.TAMIN.IR"
XML_HTTP.setRequestHeader "CONTENT-TYPE", "application/soap+xml; charset=utf-8"
XML_HTTP.setRequestHeader "SOAPACTION", "http://tempuri.org/Save_Request"
XML_HTTP.send XM
Dim XML_DOC As New MSXML2.DOMDocument60
Dim XNL As MSXML2.IXMLDOMNodeList
Dim I As Integer
'Forms!paziresh!ADDRESS = "ÊÓÊ"
If XML_HTTP.Status = 200 Then
XML_DOC.loadXML XML_HTTP.responseText
Set XNL = XML_DOC.getElementsByTagName("*")
For I = 0 To XNL.length - 1
Select Case XNL(I).nodeName
Case "RequestId"
RR.REQUEST_ID = XNL(I).Text
Case "ErrorMessage"
RR.ERROR_MESSAGE = XNL(I).Text
Case "RCode"
RR.R_Code = XNL(I).Text
End Select
Next
Else
RR.ERROR_MESSAGE = CStr(XML_HTTP.Status) + XML_HTTP.StatusText
End If
WS_TE = RR
Set XML_HTTP = Nothing
Exit Function
ERR_HNDLR:
RR.ERROR_MESSAGE = "ERROR " + CStr(Err.number) + vbCrLf + Err.Description
WS_TE = RR
End Function
Function PARLIST_JSON(ByVal TCs As String, NUMs As String) As String
Dim JSON() As String
Dim T() As String
Dim N() As String
T = Split(TCs, ",")
N = Split(NUMs, ",")
Dim I, K As Integer
K = UBound(T)
ReDim Preserve JSON(K)
For I = 0 To K
JSON(I) = Replace(SVCJSON, "@TC", T(I))
JSON(I) = Replace(JSON(I), "@NUM", N(I))
Next
PARLIST_JSON = "[" + Join(JSON, ",") + "]"
End Function
Sub TEST()
Dim X As Request_Response
X = WS_TE(Forms!SENDWEB!NUM_D, Forms!SENDWEB!DATE_D, Forms!SENDWEB!N_DOCTER, "", Forms!SENDWEB!Text146, Forms!SENDWEB!Text142, Forms!SENDWEB!Text171, Forms!SENDWEB!Text173)
'X = WS_TE("149028680227802602", "1396/01/30", "43571", "", "04", "4020", "701715,701655", "1,2")
'MsgBox ("˜Ï ÑåíÑí=" + Trim(X.REQUEST_ID) + vbCrLf + "RCode=" + Trim(X.RCode) + vbCrLf + "ERROR_MESSAGE=" + X.ERROR_MESSAGE)
Forms!SENDWEB!Label175.Caption = Trim(X.ERROR_MESSAGE) & " ; " & Trim(X.R_Code)
If Val(Forms!SENDWEB!Tracking_number) = 0 Then
If Trim(X.REQUEST_ID) > 0 Then
Forms!SENDWEB!Tracking_number = Trim(X.REQUEST_ID)
Forms!SENDWEB!DATE_INSERT = Today_persian_Date$()
Forms!SENDWEB!User = Forms!Main!Text26
Forms!SENDWEB!TIM = Time()
Forms!SENDWEB!Label175.Caption = Trim(X.ERROR_MESSAGE) & "!!!ÚãáíÇÊ ÈÇ ãæÝÞíÊ ÇäÌÇã ÑÏíÏ!!!"
End If
End If
End Sub
نوشته شده توسط mazoolagh
پاسخ با نقل قول