212 lines
9.6 KiB
Mathematica
212 lines
9.6 KiB
Mathematica
C0PMAIN ; ERX/GPL - Web Service main entry points; 9/24/09 ; 5/8/12 10:28pm
|
|
;;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
|
|
ACCOUNTF() Q 113059002 ; file number for account file
|
|
F200C0P() Q 200.113059 ; Subfile number of C0P Subscription Multiple
|
|
WSFILE() Q 113059003 ; file number for web service file
|
|
WSROLEF() Q 113059003.04 ; Subfile for web service role map
|
|
;
|
|
EN(RTNXML,RTNURL,C0PDUZ,C0PDFN,TID,C0PVOR,WALGY) ; ERX Entry PEP ; Public
|
|
; IF WALGY=1, FREE FORM ALLERGIES WILL BE ADDED
|
|
; RETURNS THE XML PORTION OF THE RPC RESPONSE
|
|
; IN RTNXML, PASSED BY NAME
|
|
; TODO: What's RTNURL used for? it's not referenced in the rest of the routine.
|
|
; C0PVOR IS A VARIABLE OVERRIDE ARRAY WITH IS APPLIED BEFORE MAPPING
|
|
;
|
|
; ERXSERVIEN is ERX Service IEN in Subfile C0P in file 200
|
|
D SETACCT^C0PSUB("C0PVARS",C0PDUZ) ; INITIALIZE SUBSCRIBER VARIABLES
|
|
I ERXSERVIEN="" Q ; PERSON NOT SUBSCRIBED
|
|
;D SETUP() ; INITIALIZE SERVICE AND ACCOUNT VARIABLES
|
|
;S C0PROLE=$$GET1^DIQ($$F200C0P(),ERXSERVIEN_","_C0PDUZ_",",4,"I")
|
|
;I C0PROLE="" S C0PROLE="P" ; DEFAULT TO PRESCRIBER ROLE
|
|
; ROLE MAPPING TO TEMPLATE ID IS FOUND IN THE WEB SERVICE FILE
|
|
;N ROLEIEN S ROLEIEN=$O(^C0PW(C0PWS,5,"B",C0PROLE,"")) ; IEN OF ROLE MAP
|
|
;I '$D(TID) S TID=$$GET1^DIQ($$WSROLEF(),ROLEIEN_","_C0PWS_",",1,"I") ;
|
|
I '$D(TID) D ; SET TEMPLATE ACCORDING TO USER TYPE
|
|
. I C0PROLE="D" S TID="ORDER" ; DEFAULT FOR PRESCRIBER
|
|
. I C0PROLE="M" S TID="STAFF" ; DEFAULT FOR MANAGER
|
|
. I C0PROLE="A" S TID="STAFF" ; DEFAULT FOR ADMIN
|
|
. I C0PROLE="N" S TID="NURSE" ; DEFAULT FOR MIDLEVEL
|
|
. I C0PTYPE="M" S TID="MIDLEVEL" ; DEFAULT FOR MIDLEVEL
|
|
. I C0PTYPE="P" S TID="ORDER" ; OVERRIDE FOR PRESCRIBERS
|
|
. I '$D(TID) S TID="ORDER" ; ALL OTHERS
|
|
I TID="STAFF" S WALGY=0 ; DON'T SEND ALLERGIES WITH STAFF TEMPLATE
|
|
N UTID ;TID TO USE
|
|
I +TID=0 D ; IF A TEMPLATE NAME WAS PASSED INSTEAD OF AN IEN
|
|
. S UTID=$$RESTID^C0PWS1(C0PDUZ,TID) ;RESOLVE TEMPLATE IEN FROM NAME
|
|
E S UTID=TID ;
|
|
D EN^C0PSUB("C0PVARS",C0PDUZ) ;INITIALIZE SUBSCRIBER VARIABLES
|
|
I TID="MIDLEVEL" D ; FOR MIDLEVELS
|
|
. I $G(C0PRMODE)="" Q ; NOT RENEWAL MODE
|
|
. ; IN RENEWAL MODE, THE SUPERVISING DOCTOR IS FOUND IN C0PSUPERV
|
|
. ;N G
|
|
. I $G(C0PSPRV)="" S C0PSPRV=$G(C0PVARS("SUPERVISING-DOCTOR-DUZ"))
|
|
. I C0PSPRV="" Q ; SUPERVISING DOCTOR IS NOT SET FOR THIS MIDLEVEL
|
|
. D EN^C0PSUB("G",$G(C0PSPRV)) ; GET VARS FOR SUPERVISOR
|
|
. S C0PVARS("SUPERVISING-NPI")=$G(G("SUBSCRIBER-NPI"))
|
|
. S C0PVARS("SUPERVISING-DEA")=$G(G("SUBSCRIBER-DEA"))
|
|
. S C0PVARS("SUPERVISING-SID")=$G(G("SUBSCRIBER-SID"))
|
|
. S C0PVARS("SUPERVISING-FAMILY-NAME")=$G(G("SUBCRIBER-FAMILY-NAME"))
|
|
. S C0PVARS("SUPERVISING-GIVEN-NAME")=$G(G("SUBCRIBER-GIVEN-NAME"))
|
|
. S C0PVARS("SUPERVISING-LICENSE")=$G(G("SUBSCRIBER-LICENSE"))
|
|
. S C0PVARS("SUPERVISING-LICENSE-STATE")=$G(G("SUBSCRIBER-LICENSE-STATE"))
|
|
. ;K G
|
|
I $D(C0PDFN) D EN^C0PPAT("C0PVARS",C0PDFN) ;INITIALIZE PATIENT VARIABLES
|
|
I $G(C0PVOR)'="" M C0PVARS=@C0PVOR ; VARIABLE OVERRIDES APPLIED HERE
|
|
N C0PXP ; NEW XPATH ARRAY
|
|
D BIND("C0PXP","C0PVARS",UTID) ; BIND TO VARIABLES
|
|
N ZZZXML S ZZZXML=RTNXML ; SYMBOL TABLE PROBLEMS
|
|
K @RTNXML ; MAKE SURE WE HAVE A CLEAN SLATE
|
|
D MAP(ZZZXML,"C0PXP",UTID) ; MAP VARIABLE TO TEMPLATE
|
|
I TID="MIDLEVEL" D ; FOR MIDLEVELS
|
|
. I $G(C0PRMODE)=1 Q ; IN RENEWAL MODE
|
|
. D DELETE^C0CXPATH(ZZZXML,"//NCScript/SupervisingDoctor") ;only for rew
|
|
. ;D REPLACE^C0CXPATH(ZZZXML,"","//NCScript/SupervisingDoctor") ;only for rew
|
|
I $G(WALGY)=1 D ; ADD ALLERGIES AND SENDMEDS FOR CLICKTHROUGH
|
|
. D ADDALGY^C0PALGY3(ZZZXML,C0PDUZ,C0PDFN) ;ADD ALLERGIES
|
|
. N ZSMEDS ; SEND MEDS
|
|
. D FREETXT^C0PSMEDS("ZSMEDS",C0PDUZ,C0PDFN) ; GET MEDS TO SEND
|
|
. I +$D(ZSMEDS)'=0 D ADD^C0PSMEDS(ZZZXML,"ZSMEDS") ; ADD TO NCSCRIPT
|
|
N TRIMI,J,DONE S DONE=0
|
|
F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE
|
|
. S J=$$TRIM^C0CXPATH(RTNXML) ; DELETE EMPTY ELEMENTS
|
|
. I DEBUG W "TRIMMED",J,!
|
|
. I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE
|
|
K @RTNXML@(0) ;GET RID OF LINE COUNT
|
|
Q
|
|
;
|
|
SETUP() ;INITIALIZE SERVICE AND ACCOUNT VARIABLE
|
|
;I '$D(C0PDUZ) S C0PDUZ=$O(^VA(200,"B","BATCH,ERX","")) ; DUZ OF BATCH USER
|
|
I '$D(C0PDUZ) S C0PDUZ=DUZ ; smh per gpl on 5/3/2012
|
|
;N ERXSERVIEN
|
|
S ERXSERVIEN=$$SUBINIT^C0PSUB(C0PDUZ)
|
|
I ERXSERVIEN="" D ERROR(",U113059001,",$ST($ST,"PLACE"),"ERX-NOSUB","Provider Not Subscribed") Q ;
|
|
; . ;W "ERROR, PROVIDER NOT SUBSCRIBED",! ;
|
|
; . ;S $EC=",U C0P ERROR - PROVIDER NOT SUBSCRIBED,"
|
|
; . ;S $EC=",U840201001," ;
|
|
; N C0PVARS ; ARRAY TO HOLD CONTEXT VARIABLES FOR BINDING
|
|
S C0PACCT=$$GET1^DIQ($$F200C0P(),ERXSERVIEN_","_C0PDUZ_",",1,"I")
|
|
S C0PLOC=$$GET1^DIQ($$F200C0P(),ERXSERVIEN_","_C0PDUZ_",",2,"I")
|
|
S C0PWS=$$GET1^DIQ($$ACCOUNTF(),C0PACCT_",",4,"I") ; WEB SERVICE POINTER
|
|
Q
|
|
;
|
|
PRIMARY() ; EXTRINSIC WHICH RETURNS PRIMARY ERX SUBSCRIBER DUZ
|
|
D SETUP() ; SET ACCOUNT VARIABLES
|
|
N C0PPRI
|
|
S C0PPRI=$$GET1^DIQ($$ACCOUNTF(),C0PACCT_",",6,"I") ; DUZ OF PRIMARY
|
|
Q C0PPRI ; RETURN DUZ
|
|
;
|
|
WSURL(ZACCT) ; EXTRINSIC TO RETURN THE URL TO USE FOR WEB SERVICES
|
|
; IT WILL DETERMINE WHETHER THE PRODUCTION SWITCH IS ON IN THE
|
|
; ACCOUNT FILE AND IF YES RETURN THE PRODUCTION URL
|
|
; IF NOT RETURN THE PREPRODUCTION TEST URL
|
|
N ZR,ZP,ZT
|
|
S ZP=$$GET1^DIQ(113059002,ZACCT_",",7,"I") ; PRODUCTION FLAG
|
|
I ZP="P" D ; PRODUCTION FLAG SET
|
|
. S ZT=$O(^C0PX("B","PRODUCTION WS URL","")) ; PRODUCION TEMPLATE
|
|
. S ZR=$$GET1^DIQ(113059001,ZT_",",1) ; URL FIELD
|
|
E D ; PRODUCTION FLAG NOT SET
|
|
. S ZT=$O(^C0PX("B","TEST WS URL","")) ; TEST TEMPLATE
|
|
. S ZR=$$GET1^DIQ(113059001,ZT_",",1) ; URL FIELD
|
|
Q ZR
|
|
;
|
|
CTURL(ZACCT) ; EXTRINSIC TO RETURN THE URL TO USE FOR CLICKTHROUGH
|
|
; IT WILL DETERMINE WHETHER THE PRODUCTION SWITCH IS ON IN THE
|
|
; ACCOUNT FILE AND IF YES RETURN THE PRODUCTION URL
|
|
; IF NOT RETURN THE PREPRODUCTION TEST URL
|
|
N ZR,ZP,ZT
|
|
S ZP=$$GET1^DIQ(113059002,ZACCT_",",7,"I") ; PRODUCTION FLAG
|
|
I ZP="P" D ; PRODUCTION FLAG SET
|
|
. S ZT=$O(^C0PX("B","PRODUCTION CLICKTHROUGH URL","")) ; PRODUCION TEMPLATE
|
|
. S ZR=$$GET1^DIQ(113059001,ZT_",",1) ; URL FIELD
|
|
E D ; PRODUCTION FLAG NOT SET
|
|
. S ZT=$O(^C0PX("B","TEST CLICKTHROUGH URL","")) ; TEST TEMPLATE
|
|
. S ZR=$$GET1^DIQ(113059001,ZT_",",1) ; URL FIELD
|
|
Q ZR
|
|
;
|
|
MAP(RARY,IVARS,TPTR) ;RETURNS MAPPED XML IN RARY PASSED BY NAME
|
|
; IVARS IS AN XPATH ARRAY PASSED BY NAME
|
|
; TPTR IS A POINT TO THE C0P XML TEMPLATE FILE USED TO RETRIEVE THE TEMPLATE
|
|
;
|
|
N ZT ;THE TEMPLATE
|
|
K ZT,@RARY
|
|
I $$GET1^DIQ(113059001,TPTR_",",3,,"ZT")'="ZT" D Q ; ERROR GETTING TEMPLATE
|
|
. W "ERROR RETRIEVING TEMPLATE",!
|
|
D MAP^C0CXPATH("ZT",IVARS,RARY) ;DO THE MAPPING
|
|
Q
|
|
;
|
|
BIND(RARY,IVARS,TPTR) ;RETURNS AN XPATH ARRAY IN RARY FOR USE WITH MAP
|
|
; TO BUILD AN INSTANTIATED TEMPLATE
|
|
; TPTR IS THE IEN OF THE XML TEMPATE IN THE C0P XML TEMPLATE FILE
|
|
; LOOPS THROUGHT THE BINDING SUBFILE TO PULL OUT XPATHS AND
|
|
; EITHER ASSIGNS VARIABLES OR DOES A FILEMAN CALL TO GET VALUES
|
|
; VARIABLES ARE IN IVARS WHICH IS PASSED BY NAME
|
|
S C0PBF=113059001.04 ; BINDING SUBFILE NUMBER
|
|
N ZI
|
|
S ZI=""
|
|
F S ZI=$O(^C0PX(TPTR,5,"B",ZI)) Q:ZI="" D ; FOR EACH XPATH
|
|
. N ZIEN,ZFILE,ZFIELD,ZVAR,ZIDX,ZINDEX ;
|
|
. S ZIEN=$O(^C0PX(TPTR,5,"B",ZI,"")) ;IEN OF THE BINDING RECORD
|
|
. S ZFILE=$$GET1^DIQ(C0PBF,ZIEN_","_TPTR_",",1.1,"I")
|
|
. S ZFIELD=$$GET1^DIQ(C0PBF,ZIEN_","_TPTR_",",1.2,"I")
|
|
. S ZVAR=$$GET1^DIQ(C0PBF,ZIEN_","_TPTR_",",2,"E")
|
|
. S ZIDX=$$GET1^DIQ(C0PBF,ZIEN_","_TPTR_",",.05,"I")
|
|
. S ZINDEX=""
|
|
. I ZIDX="DUZ" S ZINDEX=C0PDUZ ; FILE IS INDEXED BY DUZ
|
|
. I ZIDX="DFN" S ZINDEX=C0PDFN ; BY DFN
|
|
. I ZIDX="ACCT" S ZINDEX=C0PACCT ; BY ACCOUNT RECORD POINT TO C0P WS ACCT
|
|
. I ZIDX="LOC" S ZINDEX=C0PLOC ; BY LOCATION
|
|
. I ZVAR'="" D ; VARIABLES TAKE PRESCIDENCE OVER FILEMAN FIELDS
|
|
. . S @RARY@(ZI)=$G(@IVARS@(ZVAR)) ;
|
|
. E D ; IF NO VARIABLE, TRY ACCESSING FROM FILEMAN
|
|
. . I (ZFILE="")!(ZFIELD="") Q ;QUIT IF FILE OR FIELD NOT THERE
|
|
. . D CLEAN^DILF
|
|
. . S @RARY@(ZI)=$$GET1^DIQ(ZFILE,ZINDEX_",",ZFIELD) ;GET THE VALUE
|
|
. . I $D(^TMP("DIERR",$J,1)) D ERROR^C0PMAIN(",U113059006,",$ST($ST,"PLACE"),"ERX-DATA-NOTFOUND","Data Not Found.") QUIT
|
|
Q
|
|
;
|
|
BLDXML(ARTN,AWS,TNAME) ; RETURNS AN XML ARRAY IN ARTN PASSED BY NAME ; AWS IS AN ENTRY IN THE C0P WEB SERVICE FILE, EXTERNAL FORMAT
|
|
; TNAME IS AN ENTRY IN THE C0P XML TEMPLATE FILE WHICH BELONG TO THE AWS
|
|
; IT IS ASSUMED THAT THE WS CONTEXT IS ESTABLISHED AND ALL VARIABLES
|
|
; NEEDED BY THE BINDINGS IN THE XML TEMPLATE ARE INITIALIZED
|
|
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
|
|
;
|
|
ERROR(EC,PLACE,ID,MSG) ; Private Proc - Set $EC for an error condition;
|
|
; Errors the process and rolls back the stack by Invoking current error trap by setting $ECODE.
|
|
;Params:
|
|
; EC - Error Code in ,Uxxx, syntax
|
|
; PLACE - Place where the error happened
|
|
; ID - Error ID
|
|
; MSG - Human understandable message
|
|
S %ZTERR=EC
|
|
S %ZTERR("PLACE")=PLACE
|
|
S %ZTERR("ID")=ID
|
|
S %ZTERR("MSG")=MSG
|
|
S $EC=EC
|
|
QUIT
|