| 1 | C0PMAIN ; 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
|
|---|
| 21 | ACCOUNTF() Q 113059002 ; file number for account file
|
|---|
| 22 | F200C0P() Q 200.113059 ; Subfile number of C0P Subscription Multiple
|
|---|
| 23 | WSFILE() Q 113059003 ; file number for web service file
|
|---|
| 24 | WSROLEF() Q 113059003.04 ; Subfile for web service role map
|
|---|
| 25 | ;
|
|---|
| 26 | EN(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 | ;
|
|---|
| 95 | SETUP() ;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 | ;
|
|---|
| 110 | PRIMARY() ; 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 | ;
|
|---|
| 116 | WSURL(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 | ;
|
|---|
| 130 | CTURL(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 | ;
|
|---|
| 144 | MAP(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 | ;
|
|---|
| 155 | BIND(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 | ;
|
|---|
| 185 | 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
|
|---|
| 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 | ;
|
|---|
| 191 | UPDIE ; 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 | ;
|
|---|
| 199 | ERROR(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
|
|---|
