source: ePrescribing/trunk/p/C0PMAIN.m@ 1699

Last change on this file since 1699 was 1595, checked in by George Lilly, 12 years ago

initial release of ePrescribing
File size: 9.6 KB
Line 
1C0PMAIN ; ERX/GPL - Web Service main entry points; 9/24/09 ; 5/8/12 10:28pm
2 ;;1.0;C0P;;Apr 25, 2012;Build 103
3 ;Copyright 2009 George Lilly. Licensed under the terms of the GNU
4 ;General Public License See attached copy of the License.
5 ;
6 ;This program is free software; you can redistribute it and/or modify
7 ;it under the terms of the GNU General Public License as published by
8 ;the Free Software Foundation; either version 2 of the License, or
9 ;(at your option) any later version.
10 ;
11 ;This program is distributed in the hope that it will be useful,
12 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;GNU General Public License for more details.
15 ;
16 ;You should have received a copy of the GNU General Public License along
17 ;with this program; if not, write to the Free Software Foundation, Inc.,
18 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19 ;
20 Q
21ACCOUNTF() Q 113059002 ; file number for account file
22F200C0P() Q 200.113059 ; Subfile number of C0P Subscription Multiple
23WSFILE() Q 113059003 ; file number for web service file
24WSROLEF() Q 113059003.04 ; Subfile for web service role map
25 ;
26EN(RTNXML,RTNURL,C0PDUZ,C0PDFN,TID,C0PVOR,WALGY) ; ERX Entry PEP ; Public
27 ; IF WALGY=1, FREE FORM ALLERGIES WILL BE ADDED
28 ; RETURNS THE XML PORTION OF THE RPC RESPONSE
29 ; IN RTNXML, PASSED BY NAME
30 ; TODO: What's RTNURL used for? it's not referenced in the rest of the routine.
31 ; C0PVOR IS A VARIABLE OVERRIDE ARRAY WITH IS APPLIED BEFORE MAPPING
32 ;
33 ; ERXSERVIEN is ERX Service IEN in Subfile C0P in file 200
34 D SETACCT^C0PSUB("C0PVARS",C0PDUZ) ; INITIALIZE SUBSCRIBER VARIABLES
35 I ERXSERVIEN="" Q ; PERSON NOT SUBSCRIBED
36 ;D SETUP() ; INITIALIZE SERVICE AND ACCOUNT VARIABLES
37 ;S C0PROLE=$$GET1^DIQ($$F200C0P(),ERXSERVIEN_","_C0PDUZ_",",4,"I")
38 ;I C0PROLE="" S C0PROLE="P" ; DEFAULT TO PRESCRIBER ROLE
39 ; ROLE MAPPING TO TEMPLATE ID IS FOUND IN THE WEB SERVICE FILE
40 ;N ROLEIEN S ROLEIEN=$O(^C0PW(C0PWS,5,"B",C0PROLE,"")) ; IEN OF ROLE MAP
41 ;I '$D(TID) S TID=$$GET1^DIQ($$WSROLEF(),ROLEIEN_","_C0PWS_",",1,"I") ;
42 I '$D(TID) D ; SET TEMPLATE ACCORDING TO USER TYPE
43 . I C0PROLE="D" S TID="ORDER" ; DEFAULT FOR PRESCRIBER
44 . I C0PROLE="M" S TID="STAFF" ; DEFAULT FOR MANAGER
45 . I C0PROLE="A" S TID="STAFF" ; DEFAULT FOR ADMIN
46 . I C0PROLE="N" S TID="NURSE" ; DEFAULT FOR MIDLEVEL
47 . I C0PTYPE="M" S TID="MIDLEVEL" ; DEFAULT FOR MIDLEVEL
48 . I C0PTYPE="P" S TID="ORDER" ; OVERRIDE FOR PRESCRIBERS
49 . I '$D(TID) S TID="ORDER" ; ALL OTHERS
50 I TID="STAFF" S WALGY=0 ; DON'T SEND ALLERGIES WITH STAFF TEMPLATE
51 N UTID ;TID TO USE
52 I +TID=0 D ; IF A TEMPLATE NAME WAS PASSED INSTEAD OF AN IEN
53 . S UTID=$$RESTID^C0PWS1(C0PDUZ,TID) ;RESOLVE TEMPLATE IEN FROM NAME
54 E S UTID=TID ;
55 D EN^C0PSUB("C0PVARS",C0PDUZ) ;INITIALIZE SUBSCRIBER VARIABLES
56 I TID="MIDLEVEL" D ; FOR MIDLEVELS
57 . I $G(C0PRMODE)="" Q ; NOT RENEWAL MODE
58 . ; IN RENEWAL MODE, THE SUPERVISING DOCTOR IS FOUND IN C0PSUPERV
59 . ;N G
60 . I $G(C0PSPRV)="" S C0PSPRV=$G(C0PVARS("SUPERVISING-DOCTOR-DUZ"))
61 . I C0PSPRV="" Q ; SUPERVISING DOCTOR IS NOT SET FOR THIS MIDLEVEL
62 . D EN^C0PSUB("G",$G(C0PSPRV)) ; GET VARS FOR SUPERVISOR
63 . S C0PVARS("SUPERVISING-NPI")=$G(G("SUBSCRIBER-NPI"))
64 . S C0PVARS("SUPERVISING-DEA")=$G(G("SUBSCRIBER-DEA"))
65 . S C0PVARS("SUPERVISING-SID")=$G(G("SUBSCRIBER-SID"))
66 . S C0PVARS("SUPERVISING-FAMILY-NAME")=$G(G("SUBCRIBER-FAMILY-NAME"))
67 . S C0PVARS("SUPERVISING-GIVEN-NAME")=$G(G("SUBCRIBER-GIVEN-NAME"))
68 . S C0PVARS("SUPERVISING-LICENSE")=$G(G("SUBSCRIBER-LICENSE"))
69 . S C0PVARS("SUPERVISING-LICENSE-STATE")=$G(G("SUBSCRIBER-LICENSE-STATE"))
70 . ;K G
71 I $D(C0PDFN) D EN^C0PPAT("C0PVARS",C0PDFN) ;INITIALIZE PATIENT VARIABLES
72 I $G(C0PVOR)'="" M C0PVARS=@C0PVOR ; VARIABLE OVERRIDES APPLIED HERE
73 N C0PXP ; NEW XPATH ARRAY
74 D BIND("C0PXP","C0PVARS",UTID) ; BIND TO VARIABLES
75 N ZZZXML S ZZZXML=RTNXML ; SYMBOL TABLE PROBLEMS
76 K @RTNXML ; MAKE SURE WE HAVE A CLEAN SLATE
77 D MAP(ZZZXML,"C0PXP",UTID) ; MAP VARIABLE TO TEMPLATE
78 I TID="MIDLEVEL" D ; FOR MIDLEVELS
79 . I $G(C0PRMODE)=1 Q ; IN RENEWAL MODE
80 . D DELETE^C0CXPATH(ZZZXML,"//NCScript/SupervisingDoctor") ;only for rew
81 . ;D REPLACE^C0CXPATH(ZZZXML,"","//NCScript/SupervisingDoctor") ;only for rew
82 I $G(WALGY)=1 D ; ADD ALLERGIES AND SENDMEDS FOR CLICKTHROUGH
83 . D ADDALGY^C0PALGY3(ZZZXML,C0PDUZ,C0PDFN) ;ADD ALLERGIES
84 . N ZSMEDS ; SEND MEDS
85 . D FREETXT^C0PSMEDS("ZSMEDS",C0PDUZ,C0PDFN) ; GET MEDS TO SEND
86 . I +$D(ZSMEDS)'=0 D ADD^C0PSMEDS(ZZZXML,"ZSMEDS") ; ADD TO NCSCRIPT
87 N TRIMI,J,DONE S DONE=0
88 F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE
89 . S J=$$TRIM^C0CXPATH(RTNXML) ; DELETE EMPTY ELEMENTS
90 . I DEBUG W "TRIMMED",J,!
91 . I J=0 S DONE=1 ; DONE WHEN TRIM RETURNS FALSE
92 K @RTNXML@(0) ;GET RID OF LINE COUNT
93 Q
94 ;
95SETUP() ;INITIALIZE SERVICE AND ACCOUNT VARIABLE
96 ;I '$D(C0PDUZ) S C0PDUZ=$O(^VA(200,"B","BATCH,ERX","")) ; DUZ OF BATCH USER
97 I '$D(C0PDUZ) S C0PDUZ=DUZ ; smh per gpl on 5/3/2012
98 ;N ERXSERVIEN
99 S ERXSERVIEN=$$SUBINIT^C0PSUB(C0PDUZ)
100 I ERXSERVIEN="" D ERROR(",U113059001,",$ST($ST,"PLACE"),"ERX-NOSUB","Provider Not Subscribed") Q ;
101 ; . ;W "ERROR, PROVIDER NOT SUBSCRIBED",! ;
102 ; . ;S $EC=",U C0P ERROR - PROVIDER NOT SUBSCRIBED,"
103 ; . ;S $EC=",U840201001," ;
104 ; N C0PVARS ; ARRAY TO HOLD CONTEXT VARIABLES FOR BINDING
105 S C0PACCT=$$GET1^DIQ($$F200C0P(),ERXSERVIEN_","_C0PDUZ_",",1,"I")
106 S C0PLOC=$$GET1^DIQ($$F200C0P(),ERXSERVIEN_","_C0PDUZ_",",2,"I")
107 S C0PWS=$$GET1^DIQ($$ACCOUNTF(),C0PACCT_",",4,"I") ; WEB SERVICE POINTER
108 Q
109 ;
110PRIMARY() ; EXTRINSIC WHICH RETURNS PRIMARY ERX SUBSCRIBER DUZ
111 D SETUP() ; SET ACCOUNT VARIABLES
112 N C0PPRI
113 S C0PPRI=$$GET1^DIQ($$ACCOUNTF(),C0PACCT_",",6,"I") ; DUZ OF PRIMARY
114 Q C0PPRI ; RETURN DUZ
115 ;
116WSURL(ZACCT) ; EXTRINSIC TO RETURN THE URL TO USE FOR WEB SERVICES
117 ; IT WILL DETERMINE WHETHER THE PRODUCTION SWITCH IS ON IN THE
118 ; ACCOUNT FILE AND IF YES RETURN THE PRODUCTION URL
119 ; IF NOT RETURN THE PREPRODUCTION TEST URL
120 N ZR,ZP,ZT
121 S ZP=$$GET1^DIQ(113059002,ZACCT_",",7,"I") ; PRODUCTION FLAG
122 I ZP="P" D ; PRODUCTION FLAG SET
123 . S ZT=$O(^C0PX("B","PRODUCTION WS URL","")) ; PRODUCION TEMPLATE
124 . S ZR=$$GET1^DIQ(113059001,ZT_",",1) ; URL FIELD
125 E D ; PRODUCTION FLAG NOT SET
126 . S ZT=$O(^C0PX("B","TEST WS URL","")) ; TEST TEMPLATE
127 . S ZR=$$GET1^DIQ(113059001,ZT_",",1) ; URL FIELD
128 Q ZR
129 ;
130CTURL(ZACCT) ; EXTRINSIC TO RETURN THE URL TO USE FOR CLICKTHROUGH
131 ; IT WILL DETERMINE WHETHER THE PRODUCTION SWITCH IS ON IN THE
132 ; ACCOUNT FILE AND IF YES RETURN THE PRODUCTION URL
133 ; IF NOT RETURN THE PREPRODUCTION TEST URL
134 N ZR,ZP,ZT
135 S ZP=$$GET1^DIQ(113059002,ZACCT_",",7,"I") ; PRODUCTION FLAG
136 I ZP="P" D ; PRODUCTION FLAG SET
137 . S ZT=$O(^C0PX("B","PRODUCTION CLICKTHROUGH URL","")) ; PRODUCION TEMPLATE
138 . S ZR=$$GET1^DIQ(113059001,ZT_",",1) ; URL FIELD
139 E D ; PRODUCTION FLAG NOT SET
140 . S ZT=$O(^C0PX("B","TEST CLICKTHROUGH URL","")) ; TEST TEMPLATE
141 . S ZR=$$GET1^DIQ(113059001,ZT_",",1) ; URL FIELD
142 Q ZR
143 ;
144MAP(RARY,IVARS,TPTR) ;RETURNS MAPPED XML IN RARY PASSED BY NAME
145 ; IVARS IS AN XPATH ARRAY PASSED BY NAME
146 ; TPTR IS A POINT TO THE C0P XML TEMPLATE FILE USED TO RETRIEVE THE TEMPLATE
147 ;
148 N ZT ;THE TEMPLATE
149 K ZT,@RARY
150 I $$GET1^DIQ(113059001,TPTR_",",3,,"ZT")'="ZT" D Q ; ERROR GETTING TEMPLATE
151 . W "ERROR RETRIEVING TEMPLATE",!
152 D MAP^C0CXPATH("ZT",IVARS,RARY) ;DO THE MAPPING
153 Q
154 ;
155BIND(RARY,IVARS,TPTR) ;RETURNS AN XPATH ARRAY IN RARY FOR USE WITH MAP
156 ; TO BUILD AN INSTANTIATED TEMPLATE
157 ; TPTR IS THE IEN OF THE XML TEMPATE IN THE C0P XML TEMPLATE FILE
158 ; LOOPS THROUGHT THE BINDING SUBFILE TO PULL OUT XPATHS AND
159 ; EITHER ASSIGNS VARIABLES OR DOES A FILEMAN CALL TO GET VALUES
160 ; VARIABLES ARE IN IVARS WHICH IS PASSED BY NAME
161 S C0PBF=113059001.04 ; BINDING SUBFILE NUMBER
162 N ZI
163 S ZI=""
164 F S ZI=$O(^C0PX(TPTR,5,"B",ZI)) Q:ZI="" D ; FOR EACH XPATH
165 . N ZIEN,ZFILE,ZFIELD,ZVAR,ZIDX,ZINDEX ;
166 . S ZIEN=$O(^C0PX(TPTR,5,"B",ZI,"")) ;IEN OF THE BINDING RECORD
167 . S ZFILE=$$GET1^DIQ(C0PBF,ZIEN_","_TPTR_",",1.1,"I")
168 . S ZFIELD=$$GET1^DIQ(C0PBF,ZIEN_","_TPTR_",",1.2,"I")
169 . S ZVAR=$$GET1^DIQ(C0PBF,ZIEN_","_TPTR_",",2,"E")
170 . S ZIDX=$$GET1^DIQ(C0PBF,ZIEN_","_TPTR_",",.05,"I")
171 . S ZINDEX=""
172 . I ZIDX="DUZ" S ZINDEX=C0PDUZ ; FILE IS INDEXED BY DUZ
173 . I ZIDX="DFN" S ZINDEX=C0PDFN ; BY DFN
174 . I ZIDX="ACCT" S ZINDEX=C0PACCT ; BY ACCOUNT RECORD POINT TO C0P WS ACCT
175 . I ZIDX="LOC" S ZINDEX=C0PLOC ; BY LOCATION
176 . I ZVAR'="" D ; VARIABLES TAKE PRESCIDENCE OVER FILEMAN FIELDS
177 . . S @RARY@(ZI)=$G(@IVARS@(ZVAR)) ;
178 . E D ; IF NO VARIABLE, TRY ACCESSING FROM FILEMAN
179 . . I (ZFILE="")!(ZFIELD="") Q ;QUIT IF FILE OR FIELD NOT THERE
180 . . D CLEAN^DILF
181 . . S @RARY@(ZI)=$$GET1^DIQ(ZFILE,ZINDEX_",",ZFIELD) ;GET THE VALUE
182 . . I $D(^TMP("DIERR",$J,1)) D ERROR^C0PMAIN(",U113059006,",$ST($ST,"PLACE"),"ERX-DATA-NOTFOUND","Data Not Found.") QUIT
183 Q
184 ;
185BLDXML(ARTN,AWS,TNAME) ; RETURNS AN XML ARRAY IN ARTN PASSED BY NAME ; AWS IS AN ENTRY IN THE C0P WEB SERVICE FILE, EXTERNAL FORMAT
186 ; TNAME IS AN ENTRY IN THE C0P XML TEMPLATE FILE WHICH BELONG TO THE AWS
187 ; IT IS ASSUMED THAT THE WS CONTEXT IS ESTABLISHED AND ALL VARIABLES
188 ; NEEDED BY THE BINDINGS IN THE XML TEMPLATE ARE INITIALIZED
189 Q
190 ;
191UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
192 K ZERR
193 D CLEAN^DILF
194 D UPDATE^DIE("","C0PFDA","","ZERR")
195 I $D(ZERR) D ERROR^C0PMAIN(",U113059008,",$ST($ST,"PLACE"),"ERX-UPDIE-FAIL","Fileman Data Update Failure") QUIT
196 K C0PFDA
197 Q
198 ;
199ERROR(EC,PLACE,ID,MSG) ; Private Proc - Set $EC for an error condition;
200 ; Errors the process and rolls back the stack by Invoking current error trap by setting $ECODE.
201 ;Params:
202 ; EC - Error Code in ,Uxxx, syntax
203 ; PLACE - Place where the error happened
204 ; ID - Error ID
205 ; MSG - Human understandable message
206 S %ZTERR=EC
207 S %ZTERR("PLACE")=PLACE
208 S %ZTERR("ID")=ID
209 S %ZTERR("MSG")=MSG
210 S $EC=EC
211 QUIT
Note: See TracBrowser for help on using the repository browser.