iSharkFly-Open
/
VistA-ePrescribing
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
VistA-ePrescribing/p/C0PWS1.m

453 lines
18 KiB
Mathematica
Raw Permalink Blame History

C0PWS1 ; ERX/GPL - Web Service utilities; 8/31/09 ; 5/9/12 12:14am
;;1.0;C0P;;Apr 25, 2012;Build 103
;Copyright 2009 George Lilly. Licensed under the terms of the GNU
;General Public License See attached copy of the License.
;
;This program is free software; you can redistribute it and/or modify
;it under the terms of the GNU General Public License as published by
;the Free Software Foundation; either version 2 of the License, or
;(at your option) any later version.
;
;This program is distributed in the hope that it will be useful,
;but WITHOUT ANY WARRANTY; without even the implied warranty of
;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;GNU General Public License for more details.
;
;You should have received a copy of the GNU General Public License along
;with this program; if not, write to the Free Software Foundation, Inc.,
;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
;
Q
;
; TEST Lines below not intended for End Users. Programmers only.
; BEWARE ZWRITE SYNTAX. It may not work in other M Implementations.
TEST(C0PDUZ,C0PDFN) ; TEST RETRIEVAL OF PATIENT1 MEDS
;S DEBUG=1 ;
D SOAP("C0POUT",6,C0PDUZ,C0PDFN)
ZWRITE C0POUT
Q
;
ACCOUNTF() Q 113059002 ; file number for account file
XMLFN() Q 113059001 ; XML TEMPLATE FILE NUMBER
BINDFN() Q 113059001.04 ; FILE NUMBER FOR BINDING SUBFILE
;
GETTID(C0PWS,C0PTNAME) ; EXTRINSIC WHICH RETURNS THE TEMPLATE ID FOR
; TEMPLATE NAMED C0PTNAME BELONGING TO WEB SERVICE NAMED C0PWS
; ALSO WORKS IF THE ACCOUNT NUMBER IS PASSED IN C0PWS
S C0PXF=113059001 ; FILE NUMBER FOR THE C0P XML TEMPLATE FILE
S C0PAF=113059002 ; FILE NUMBER FOR THE C0P WS ACCT FILE
N C0PA,C0PT ; C0P ACCOUNT AND C0P TEMPLATE
I C0PWS>0 S C0PA=C0PWS
E D ; NAME NOT RECORD NUMBER IS PASSED FOR ACCOUNT
. S C0PA=$O(^C0PS("B",C0PWS,"")) ; RECORD NUMBER OF ACCOUNT
. I C0PA="" D Q ; OOPS ACCOUNT NOT FOUND
. . W "ACCOUNT "_C0PWS_" NOT FOUND",!
S C0PT=$O(^C0PX("C",C0PA,C0PTNAME,"")) ; RECORD NUMBER OF TEMPLATE
; WE USE THE C INDEX TO INSURE THAT THE TEMPLATE BELONGS TO THE WEB SERVICE
Q C0PT
;
RESTID(C0PDUZ,C0PTID) ; RESOLVE TEMPLATE ID FROM SUBSCRIPTION
;
N C0PAIEN S C0PAIEN=$$SUBINIT^C0PSUB(C0PDUZ) ;IEN OF SUBSCRIPTION
N C0PACCT S C0PACCT=$$GET1^DIQ(C0PSUBF,C0PAIEN_","_C0PDUZ_",",1,"I") ;ACCT
N C0PWBS S C0PWBS=$$GET1^DIQ(C0PAF,C0PACCT_",",4,"I") ;WEB SERVICE IEN
N C0PUTID S C0PUTID=$$GETTID(C0PWBS,C0PTID) ;TEMPLATE ID
Q C0PUTID
;
SOAP(C0PRTN,C0PTID,C0PDUZ,C0PDFN,C0PVOR) ; MAKES A SOAP CALL FOR
; TEMPLATE ID C0PTID
; RETURNS THE XML RESULT IN C0PRTN, PASSED BY NAME
; C0PVOR IS THE NAME OF A VARIABLE OVERRIDE ARRAY, WHICH IS APPLIED
; BEFORE MAPPING
;
; ARTIFACTS SECTION
; THE FOLLOWING WILL SET UP DEBUGGING ARTIFACTS FOR A POSSIBLE FUTURE
; ONLINE DEBUGGER. IF DEBUG=1, VARIABLES CONTAINING INTERMEDIATE RESULTS
; WILL NOT BE NEWED.
I $G(DEBUG)="" N C0PV ; CATALOG OF ARTIFACT VARIABLES AND ARRAYS
S C0PV(100,"C0PXF","XML TEMPLATE FILE NUMBER")=""
S C0PV(200,"C0PHEAD","SOAP HEADER VARIABLE NAME")=""
S C0PV(300,"header","SOAP HEADER")=""
S C0PV(400,"C0PMIME","MIME TYPE")=""
S C0PV(500,"C0PURL","WS URL")=""
S C0PV(550,"C0PPURL","PROXY URL")=""
S C0PV(600,"C0PXML","XML VARIABLE NAME")=""
S C0PV(700,"xml","OUTBOUND XML")=""
S C0PV(800,"C0PRSLT","RAW XML RESULT RETURNED FROM WEB SERVICE")=""
S C0PV(900,"C0PRHDR","RETURNED HEADER")=""
S C0PV(1000,"C0PRXML","XML RESULT NORMALIZED")=""
S C0PV(1100,"C0PR","REPLY TEMPLATE")=""
S C0PV(1200,"C0PREDUX","REDUX STRING")=""
S C0PV(1300,"C0PIDX","RESULT XPATH INDEX")=""
S C0PV(1400,"C0PARY","RESULT XPATH ARRAY")=""
S C0PV(1500,"C0PNOM","RESULT DOM DOCUMENT NAME")=""
S C0PV(1600,"C0PID","RESULT DOM ID")=""
I $G(DEBUG)'="" G NOTNEW ; SKIP NEWING THE VARIABLES IF IN DEBUG
N ZI,ZJ S ZI=""
NEW ; new the variables
S ZI=$O(C0PV(ZI))
S ZJ=$O(C0PV(ZI,"")) ; SET UP NEW COMMAND
;W ZJ,!
N @ZJ ; NEW THE VARIABLE
I $O(C0PV(ZI))'="" G NEW ;LOOP TO GET NEW IN CONTEXT
NOTNEW ; (goto label) don't new the variables... skip that
; END ARTIFACTS
;
D INITXPF("C0PF") ; SET FILE NUMBER AND PARAMATERS
S C0PXF=C0PF("XML FILE NUMBER") ; FILE NUMBER FOR THE C0P XML TEMPLATE FILE
I +C0PTID=0 D ; A STRING WAS PASSED FOR THE TEMPLATE NAME
. S C0PUTID=$$RESTID(C0PDUZ,C0PTID) ;RESOLVE TEMPLATE IEN FROM NAME
E S C0PUTID=C0PTID ; AN IEN WAS PASSED
N xml,template,header
S C0PHEAD=$$GET1^DIQ(C0PXF,C0PUTID_",",2.2,,"header")
S C0PMIME=$$GET1^DIQ(C0PXF,C0PUTID_",","MIME TYPE")
S C0PPURL=$$GET1^DIQ(C0PXF,C0PUTID_",","PROXY SERVER")
;S C0PURL=$$GET1^DIQ(C0PXF,C0PUTID_",","URL") ;GPL CHANGE TO USE PROD FLAG
D SETUP^C0PMAIN() ; INITIALIZE C0PACCT IEN OF WS ACCOUNT
S C0PURL=$$WSURL^C0PMAIN(C0PACCT) ; RESOLVES PRODUCTION VS TEST
S C0PXML=$$GET1^DIQ(C0PXF,C0PUTID_",",2.1,,"xml")
S C0PTMPL=$$GET1^DIQ(C0PXF,C0PUTID_",",3,,"template")
I C0PTMPL="template" D ; there is a template to process
. K xml ; going to replace the xml array
. D EN^C0PMAIN("xml","url",C0PDUZ,C0PDFN,C0PUTID,$G(C0PVOR))
. ;N ZZG M ZZG(1)=xml
. ;S ZDIR=^TMP("C0CCCR","ODIR")
. ;ZWR ZZG(1)
. ;W $$OUTPUT^C0CXPATH("xml(1)","GPLTEST-"_ZDFN_".xml",ZDIR)
I $G(C0PPROXY) S C0PURL=C0PPURL
I '$D(C0PERROR) S C0PERROR="0^NO ERRORS" ; to do: start using this gpl
K C0PRSLT,C0PRHDR
;
; token to catch runaway linux jobs - gpl 4/12/2012
; But not ready for release b/c depends on code that is not available --smh 5/9/12
; D LOG^C0PTRAK($J,"PULLBACK")
;
S ok=$$httpPOST^%zewdGTM(C0PURL,.xml,C0PMIME,.C0PRSLT,.header,"",.gpl5,.C0PRHDR)
;
; kill token after return from EWD
;
;D UNLOG^C0PTRAK($J) ; success, remove the token ; smh commented out 5/9/12
;K ^TMP("C0PERX",$J)
K C0PRXML
;I DUZ=135 B ; patch so others can use the pullback while i debug - gpl
;. ;I $D(C0PRSLT(1)) D NORMAL("C0PRXML","C0PRSLT(1)") ;RETURN XML IN AN ARRAY
;. I $D(C0PRSLT(1)) D CHUNK("C0PRXML","C0PRSLT",2000) ;RETURN IN AN ARRAY
;. ; SWITCHED TO CHUNK TO HANDLE ARRAYS OF XML
;E I $D(C0PRSLT(1)) D NORMAL("C0PRXML","C0PRSLT(1)") ;RETURN XML IN AN ARRAY
; The following is a temporary fix to keep eRx working while a better
; solution is developed. Template ID 6 is GETMEDS for eRx and it needs
; to handle xml files that are too big for NORMAL to handle. So, I wrote
; CHUNK which will allow us to handle any size xml file bound for the
; EWD parser.
; However, all the other templates in eRx need NORMAL to find the
; embedded XML file in their web service responses. So, we will use
; CHUNK for template 6 and continue to use NORMAL for all other templates
; we can handle big med lists, but not big web service calls.
; What is needed is a better NORMAL (see NORMAL2) or another routine
; to detect, extract, and decode embeded XML files of any size. gpl 10/8/10
I C0PUTID=6 D ;
. I $D(C0PRSLT(1)) D CHUNK("C0PRXML","C0PRSLT",2000) ;RETURN IN AN ARRAY
E I $D(C0PRSLT(1)) D NORMAL("C0PRXML","C0PRSLT(1)") ;RETURN XML IN AN ARRAY
S C0PR=$$GET1^DIQ(C0PXF,C0PUTID_",",.03,"I") ; REPLY TEMPLATE
; reply templates are optional and are specified by populating a
; template pointer in field 2.5 of the request template
; if specified, the reply template is the source of the REDUX string
; used for XPath on the reply, and for UNBIND processing
; if no reply template is specified, REDUX is obtained from the request
; template and no UNBIND processing is performed. The XPath array is
; returned without variable bindings
I C0PR'="" D ; REPLY TEMPLATE EXISTS
. I +$G(DEBUG)'=0 W "REPLY TEMPLATE:",C0PR,!
. S C0PTID=C0PR ;
S C0PREDUX=$$GET1^DIQ(C0PXF,C0PUTID_",",2.5) ;XPATH REDUCTION STRING
K C0PIDX,C0PARY ; XPATH INDEX AND ARRAY VARS
S C0PNOM="C0PMEDS"_$J ; DOCUMENT NAME FOR THE DOM
N ZBIG S ZBIG=0
I C0PUTID'=6 D ;
. S ZBIG=$$TOOBIG("C0PRXML") ; PATCH BY GPL WHICH ASSUMES ONLY
. ; TEMPLATE 1 IS A REGULAR XML FILE.. EVERYTHING ELSE HAS EMBEDDED XML
I ZBIG>0 D ; PROBABLY AN EMBEDDED XML DOCUMENT
. S C0PID=$$UNWRAP("C0PRXML",ZBIG,C0PNOM) ; DECODE AND PARSE THE EMBEDED XML
E S C0PID=$$PARSE^C0PXEWD("C0PRXML",C0PNOM) ;CALL THE PARSER
;S C0PID=$$PARSE^C0PXEWD("C0PRXML",C0PNOM) ;CALL THE PARSER
S C0PID=$$FIRST^C0PXEWD($$ID^C0PXEWD(C0PNOM)) ;ID OF FIRST NODE
D XPATH^C0PXEWD(C0PID,"/","C0PIDX","C0PARY","",C0PREDUX) ;XPATH GENERATOR
S OK=$$DELETE^C0PXEWD(C0PNOM) ; REMOVE PARSED XML FROM THE EWD DOM
; Next, call UNBIND to map the reply XPath array to variables
; This is only done if a Reply Template is provided
D DEMUXARY(C0PRTN,"C0PARY")
; M @C0PRTN=C0PARY
Q
;
TOOBIG(ZXML) ; EXTRINSIC WHICH RETURNS TRUE IF ANY NODE IS OVER 2000 CHARS
; RETURNS THE INDEX OF THE LARGE NODE . IF NO LARGE NODE, RETURNS ZERO
N ZI,ZR
S ZI=""
S ZR=0 ; DEFAULT FALSE
F S ZI=$O(@ZXML@(ZI)) Q:ZI="" D ;
. I $L(@ZXML@(ZI))>1000 S ZR=ZI
Q ZR
;
NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML
; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
;
N ZI,ZN,ZTMP
S ZN=1
S @OUTXML@(ZN)=$P(@INXML,"><",ZN)_">"
S ZN=ZN+1
F S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)="" D ;
. S @OUTXML@(ZN)=@OUTXML@(ZN)_">"
. S ZN=ZN+1
Q
;
CHUNK(OUTXML,INXML,ZSIZE) ; BREAKS INXML INTO ZSIZE BLOCKS
; INXML IS AN ARRAY PASSED BY NAME OF STRINGS
; OUTXML IS ALSO PASSED BY NAME
; IF ZSIZE IS NOT PASSED, 1000 IS USED
I '$D(ZSIZE) S ZSIZE=1000 ; DEFAULT BLOCK SIZE
N ZB,ZI,ZJ,ZK,ZL,ZN
S ZB=ZSIZE-1
S ZN=1
S ZI=0 ; BEGINNING OF INDEX TO INXML
F S ZI=$O(@INXML@(ZI)) Q:+ZI=0 D ; FOR EACH STRING IN INXML
. S ZL=$L(@INXML@(ZI)) ; LENGTH OF THE STRING
. F ZJ=1:ZSIZE:ZL D ;
. . S ZK=$S(ZJ+ZB<ZL:ZJ+ZB,1:ZL) ; END FOR EXTRACT
. . S @OUTXML@(ZN)=$E(@INXML@(ZI),ZJ,ZK) ; PULL OUT THE PIECE
. . S ZN=ZN+1 ; INCREMENT OUT ARRAY INDEX
Q
;
NORMAL2(OUTXML,INXML) ;NORMALIZES AN ARRAY OF XML STRINGS PASSED BY NAME INXML
; AS @INXML@(1) TO @INXML@(x) ALL NUMERIC
; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME
; this routine doesn't work unless the blocks are on xml tag boundaries - gpl
; which is hard to do... this routine is left here awaiting future development
N ZI,ZN,ZJ
S ZJ=0
S ZN=1
F S ZJ=$O(@INXML@(ZJ)) Q:+ZJ=0 D ; FOR EACH XML STRING IN ARRAY
. S @OUTXML@(ZN)=$P(@INXML@(ZJ),"><",ZN)_">"
. S ZN=ZN+1
. F S @OUTXML@(ZN)="<"_$P(@INXML@(ZJ),"><",ZN) Q:$P(@INXML@(ZJ),"><",ZN+1)="" D ;
. . S @OUTXML@(ZN)=@OUTXML@(ZN)_">"
. . S ZN=ZN+1
Q
;
UNWRAP(ZXML,ZI,ZNOM) ; EXTRINSIC TO LOCATE, DECODE AND PARSE AN EMBEDED XML DOC
; RETURNS THE DOCID OF THE DOM
N ZS,ZX
S ZS=$P($P(@ZXML@(ZI),">",2),"<",1) ; PULL OUT THE ENCODED STRING
S ZX=$$DECODE^RGUTUU(ZS)
N ZZ
N ZY S ZY="<?xml version=""1.0"" encoding=""utf-8""?>"
I $E(ZX,1,5)'="<?xml" S ZZ(1)=ZY_ZX
E S ZZ(1)=ZX
N ZI
;F ZI=1:1 Q:$$REDUCE(.ZZ,ZI) ; CHOP THE STRING INTO 4000 CHAR ARRAY
S ZI=$$REDUCRCR(.ZZ,1) ; RECURSIVE VERSION OF REDUCE
S G=$$PARSE^C0PXEWD("ZZ",C0PNOM)
I G=0 D ERROR^C0PMAIN(",U113059005,",$ST($ST,"PLACE"),"ERX-XML-PRS","XML Parsing Error") QUIT ;ZWR ^TMP("MXMLERR",$J,*) B
Q G
;
REDUCE(ZARY,ZN) ; WILL REDUCE ZARY(ZN) BY CHOPPING IT TO 4000 CHARS
; AND PUTTING THE REST IN ZARY(ZN+1)
; ZARY IS PASSED BY REFERENCE
; EXTRINSIC WHICH RETURNS FALSE IF THERE IS NOTHING TO REDUCE
I $L(ZARY(ZN))<4001 Q 0 ;NOTHING TO REDUCE
S ZARY(ZN+1)=$E(ZARY(ZN),4001,$L(ZZ(ZN))) ;BREAK IT UP
S ZARY(ZN)=$E(ZARY(ZN),1,4000) ;
Q 1 ;ACTUALLY REDUCED
;
REDUCRCR(ZARY,ZN) ; RECURSIVE VERSION OF REDUCE ABOVE
; WILL REDUCE ZARY(ZN) BY CHOPPING IT TO 4000 CHARS
; AND PUTTING THE REST IN ZARY(ZN+1)
; ZARY IS PASSED BY REFERENCE
; EXTRINSIC WHICH RETURNS FALSE IF THERE IS NOTHING TO REDUCE
I $L(ZARY(ZN))<4001 Q 0 ;NOTHING TO REDUCE
S ZARY(ZN+1)=$E(ZARY(ZN),4001,$L(ZZ(ZN))) ;BREAK IT UP
S ZARY(ZN)=$E(ZARY(ZN),1,4000) ;
I '$$REDUCRCR(.ZARY,ZN+1) Q 1 ; CALL RECURSIVELY
Q 1 ;ACTUALLY REDUCED
;
DEMUXARY(OARY,IARY) ;CONVERT AN XPATH ARRAY PASSED AS IARY TO
; FORMAT @OARY@(x,xpath) where x is the first multiple
N ZI,ZJ,ZK,ZL S ZI=""
F S ZI=$O(@IARY@(ZI)) Q:ZI="" D ;
. D DEMUX^C0CMXP("ZJ",ZI)
. S ZK=$P(ZJ,"^",3)
. S ZK=$RE($P($RE(ZK),"/",1))
. S ZL=$P(ZJ,"^",1)
. I ZL="" S ZL=1
. S @OARY@(ZL,ZK)=@IARY@(ZI)
Q
;
; BEGIN OLD CODE - REMOVE AFTER A WHILE WHEN "SOAP" SETTLES DOWN - GPL
;s URL="http://preproduction.newcropaccounts.com/InterfaceV7/Doctor.xml"
;D GETPOST1(URL) ;
;N I,J
;S J=$O(gpl(""),-1) ; count of things in gpl
;F I=1:1:J S gpl(I)=$$CLEAN^C0PEWDU(gpl(I))
;I $$GET1^DIQ(113059001,"3,",2.1,,"gpl")'="gpl" D Q ; ERR GETTING TEMPLATE
;. W "ERROR RETRIEVING TEMPLATE",!
;S gpl(1)="RxInput="_gpl(1)
S url="https://preproduction.newcropaccounts.com/InterfaceV7/RxEntry.aspx"
S url="https://secure.newcropaccounts.com/V7/WebServices/Doctor.asmx"
S url="http://76.110.202.22/v7/WebServices/Doctor.asmx" ;RICHARD'S SOAP PROXY SERVER
;S url="http://76.110.202.22/" ;RICHARD'S SOAP PROXY SERVER
N header
S ZH=$$GET1^DIQ(113059001,"3,",2.2,,"header")
;W $$OUTPUT^C0CXPATH("gpl(1)","NewCropV7-DOCTOR2.xml","/home/dev/CCR/"),!
S ok=$$httpPOST^%zewdGTM(url,.gpl,"text/xml; charset=utf-8",.gpl6,.header,"",.gpl5,.gpl7)
;S ok=$$httpPOST2(.RTN,url,.gpl,"text/xml; charset=utf-8",.gpl6,.header,"",.gpl5,.gpl7)
;S ok=$$httpPOST2(.RTN,"https://preproduction.newcropaccounts.com/InterfaceV7/RxEntry.aspx",.gpl,"application/x-www-form-urlencoded",.gpl6,"","",.gpl5,.gpl7)
ZWRITE gpl6 ; smh: this zwrite is never reached.
Q
PARSE(INXML,INDOC) ;CALL THE EWD PARSER ON INXML, PASSED BY NAME
; INDOC IS PASSED AS THE DOCUMENT NAME TO EWD
; EXTRINSIC WHICH RETURNS THE DOCID ASSIGNED BY EWD
N ZR
M ^CacheTempEWD($j)=@INXML ;
S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
K ^CacheTempEWD($j) ;clean up after
Q ZR
;
ADDWS(WSNAME,WSTNAM,WSURL) ; ADD A WEB SERVICE TEMPLATE GIVEN A WSDL URL
; WSNAME IS THE NAME OF THE WEB SERVICE.. WILL BE LAYGO
; WSTNAM IS THE TEMPLATE NAME TO BE ADDED TO BE CREATED AND IMPORTED
; WSURL IS THE URL TO THE WSDL DEFINITION OF THE TEMPLATE
; WILL FIRST TRY AND FETCH THE XML FROM THE INTERNET USING THE URL
; IF SUCCESSFUL, AND THE RETURN XML IS VALID, AN ENTRY IN THE XML TEMPLATE
; FILE WILL BE CREATED, WITH THE RAW XML AND DERIVED TEMPLATE XML.
; THEN ENTRIES IN THE BINDING SUBFILE WILL BE CREATED FOR EACH XPATH
; FINALLY, THE TEMPLATE WILL BE POINTED TO IN THE WEB SERVICE FILE TEMPLATE
; MULTIPLE
N C0PWSF S C0PWSF=113059003 ; WEB SERVICE FILE
N C0PXTF S C0PXTF=113059001 ; XML TEMPLATE FILE
; NEVER MIND... WRONG APPROACH
Q
;
TBLD(INT) ; TEMPLATE BUILD OF TEMPLATE INT
; want to break this up into pieces - gpl
; THE TEMPLATE NEEDS TO EXIST AND THE DEFINING XML URL MUST BE POPULATED
; THEN THE DEFINING XML WILL BE RETRIVED AND STORED INTO THE RAW XML FIELD
; IT WILL BE TRANSFORMED INTO A TEMPLATE AND STORED IN THE TEMPLATE FIELD
; ALL THE XPATHs WILL BE EXTRACTED AND A BINDING MULTIPLE CREATED FOR EACH
; ALL IN ONE SIMPLE ROUTINE
; WHAT REMAINS IS FOR MANUAL ENTRY OF THE OTHER FIELDS IN THE BINDINGS
N C0PXTF S C0PXTF=113059001 ; XML TEMPLATE FILE
N C0PURL ; URL TO RETRIEVE THE DEFINING XML FOR THE TEMPLATE
S C0PURL=$$GET1^DIQ(C0PXTF,INT,2)
D GET1URL^C0PEWD2(C0PURL)
D CLEAN^DILF
; D WP^DIE(ZF,ZIEN_",",1,,$NA(@ZOR@(ZD,ZI,"TX"))) ; WP OF ORDER TXT
D WP^DIE(C0PXTF,INT_",",2.1,,$NA(gpl))
D WP^DIE(C0PXTF,INT_",",3,,$NA(gplTEMP))
;N C0PFDA ; DON'T NEW FOR TESTING
D ADDXP("gpl2",INT)
Q
;
COMPILE(INTID) ;COMPILE A XML TEMPLATE IN RECORD INTID
;
D INITXPF("C0PF") ;FILE ARRAY TO POINT TO C0P FILES
D COMPILE^C0CMXP(INTID,"C0PF") ;COMPILE THE TEMPLATE
Q
;
CPBIND(INID,OUTID,FORCE) ; COPIES XPATH BINDINGS FROM TEMPLATE INID
; TO TEMPLATE OUTID - ONLY BINDINGS FOR MATCHING XPATHS ARE COPIED
; NOTE - REDO THIS TO USE FILEMAN CALLS GPL
; WILL NOT OVERWRITE UNLESS FORCE=1
N FARY S FARY="C0PF"
D INITXPF("C0PF")
I +OUTID=0 S OUTID=$$RESTID^C0CSOAP(OUTID,FARY) ;RESOLVE TEMPLATE NAME
I +INID=0 S INID=$$RESTID^C0CSOAP(INID,FARY) ;RESOLVE TEMPLATE NAME
N ZI
S ZI=0
F S ZI=$O(^C0PX(OUTID,5,ZI)) Q:+ZI=0 D ; FOR EACH XPATH IN OUTID
. W !,ZI," ",^C0PX(OUTID,5,ZI,0)
. S ZN=^C0PX(OUTID,5,ZI,0)
. I $D(^C0PX(OUTID,5,ZI,1)) D ;Q ;
. . W !,"ERROR XPATH BINDING EXISTS ",ZI
. D ; LOOK FOR MATCHING XPATH IN SOURCE
. . S ZJ=$O(^C0PX(INID,5,"B",ZN,""))
. . ;W " FOUND:",ZJ
. . I ZJ'="" D ;
. . . ;W !,"SETTING ",$G(^C0PX(INID,5,ZJ,1))
. . . S ^C0PX(OUTID,5,ZI,0)=^C0PX(INID,5,ZJ,0) ;GET BOTH FIELDS
. . . S ^C0PX(OUTID,5,ZI,1)=$G(^C0PX(INID,5,ZJ,1))
Q
;
INITXPF(ARY) ;INITIAL XML/XPATH FILE ARRAY
;
S @ARY@("XML FILE NUMBER")=113059001
S @ARY@("BINDING SUBFILE NUMBER")=113059001.04
S @ARY@("MIME TYPE")="2.3"
S @ARY@("PROXY SERVER")="2.4"
S @ARY@("REPLY TEMPLATE")=".03"
S @ARY@("TEMPLATE NAME")=".01"
S @ARY@("TEMPLATE XML")="3"
S @ARY@("URL")="1"
S @ARY@("WSDL URL")="2"
S @ARY@("XML")="2.1"
S @ARY@("XML HEADER")="2.2"
S @ARY@("XPATH REDUCTION STRING")="2.5"
S @ARY@("CCR VARIABLE")="4"
S @ARY@("FILEMAN FIELD NAME")="1"
S @ARY@("FILEMAN FIELD NUMBER")="1.2"
S @ARY@("FILEMAN FILE POINTER")="1.1"
S @ARY@("INDEXED BY")=".05"
S @ARY@("SQLI FIELD NAME")="3"
S @ARY@("VARIABLE NAME")="2"
Q
;
ADDXP(INARY,TID) ;ADD XPATH .01 FIELD TO BINDING SUBFILE OF TEMPLATE TID
N FARY S FARY="C0PFILES"
D INITXPF(FARY)
D ADDXP^C0CMXP(INARY,TID,FARY) ;
Q
;
ADDXML(INXML,TEMPID) ;ADD XML TO A TEMPLATE ID TEMPID
; INXML IS PASSED BY NAME
N FARY S FARY="C0PFILES"
D INITXPF(FARY)
D ADDXML^C0CMXP(INXML,TEMPID,FARY) ;CALL C0C ROUTINE TO ADD TO THE FILE
Q
;
ADDTEMP(INXML,TEMPID,FARY) ;ADD XML TEMPLATE TO TEMPLATE RECORD TEMPID FIELD 3
;
N FARY S FARY="C0PFILES"
D INITXPF(FARY)
D ADDTEMP^C0CMXP(INXML,TEMPID,FARY)
Q
;
GETXML(OUTXML,TEMPID,FARY) ;GET THE XML FROM TEMPLATE TEMPID
;
N FARY S FARY="C0PFILES"
D INITXPF(FARY)
N C0PUTID ; TEMPLATE IEN TO USE
D GETXML^C0CMXP(OUTXML,TEMPID,FARY)
Q
;
GETTEMP(OUTXML,TEMPID,FARY) ;GET THE TEMPLATE XML FROM TEMPLATE TEMPID
;
N FARY S FARY="C0PFILES"
D INITXPF(FARY)
N C0PUTID ; TEMPLATE IEN TO USE
D GETTEMP^C0CMXP(OUTXML,TEMPID,FARY)
Q
;
COPYHDR(ZS,ZD) ; COPY XML HEADER FROM RECORD ZS TO ZD
; ASSUMES C0P XML TEMPLATE FILE
N FARY
D INITXPF("FARY")
D COPYWP^C0CMXP("XML HEADER",ZS,ZD,"FARY")
Q
;
UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
K ZERR
D CLEAN^DILF
D UPDATE^DIE("","C0PFDA","","ZERR")
I $D(ZERR) D ERROR^C0PMAIN(",U113059008,",$ST($ST,"PLACE"),"ERX-UPDIE-FAIL","Fileman Data Update Failure") QUIT
K C0PFDA
Q
;
Reference in New Issue View Git Blame Copy Permalink