source: ePrescribing/trunk/p/C0PALGY3.m@ 1779

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

initial release of ePrescribing

File size: 3.9 KB
Line 
1C0PALGY3 ; ERX/GPL - eRx Allergy utilities ; 5/8/12 9:11pm
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 ;
22ADDALGY(RTNXML,ZDUZ,ZDFN,ZFILE) ; ADDS PATIENT ALLERGIES TO NCSCRIPT
23 ; CLICK-THROUGH HTLM FILE FOR
24 ; MAPPING ALLERGIES , XML IS RETURNED IN RTN,PASSED BY NAME
25 ; IF ZFILE IS 1, THE FILE IS WRITTEN TO AN XML FILE
26 ;D EN^C0PMAIN("G1","G2",ZDUZ,ZDFN) ; GET THE NCSCRIPT
27 ;S @RTNURL=G2
28 ;D GETXML^C0PWS1("G3",14) ; GET BEGINNING OF FILE
29 ;D GETXML^C0PWS1("G4",15) ; GET END OF FILE
30 N G1,G2,G3,G4,G5,G6,GBLD
31 D GETALGY("G6",ZDFN) ;GET ALLERGIES
32 ;D QUEUE^C0CXPATH("GBLD","G3",1,$O(G3(""),-1)) ;BUILD LIST BEGINNING OF FILE
33 ;;D QUEUE^C0CXPATH("GBLD","G1",1,$O(G1(""),-1)) ; NCSCRIPT
34 M G1=@RTNXML
35 S GEND=$O(G1(""),-1)-2
36 D QUEUE^C0CXPATH("GBLD","G1",1,GEND) ; NCSCRIPT.. UP TO </Patient>
37 D QUEUE^C0CXPATH("GBLD","G6",1,$O(G6(""),-1)) ; ADD THE ALLERGIES
38 D QUEUE^C0CXPATH("GBLD","G1",GEND+1,$O(G1(""),-1)) ;END OF NCSCRIPT
39 D QUEUE^C0CXPATH("GBLD","G4",1,$O(G4(""),-1)) ; END OF FILE
40 D BUILD^C0CXPATH("GBLD","G5") ; BUILD THE CONTENTS FROM THE BUILD LIST
41 K @RTNXML
42 M @RTNXML=G5 ;
43 I $G(ZFILE)=1 W $$OUTPUT^C0CXPATH("G5(1)","ALLERGY-"_ZDFN_".html","/home/dev/CCR/")
44 Q
45 ;
46GENTEST(RTNXML,RTNURL,ZDUZ,ZDFN,ZFILE) ; GENERATE A TEST
47 ; CLICK-THROUGH HTLM FILE FOR
48 ; MAPPING ALLERGIES , XML IS RETURNED IN RTN,PASSED BY NAME
49 ; IF ZFILE IS 1, THE FILE IS WRITTEN TO HOST FILE
50 D EN^C0PMAIN("G1","G2",ZDUZ,ZDFN) ; GET THE NCSCRIPT
51 ;S @RTNURL=G2
52 D GETXML^C0PWS1("G3",14) ; GET BEGINNING OF FILE
53 D GETXML^C0PWS1("G4",15) ; GET END OF FILE
54 D GETALGY("G6",ZDFN) ;GET ALLERGIES
55 D QUEUE^C0CXPATH("GBLD","G3",1,$O(G3(""),-1)) ;BUILD LIST BEGINNING OF FILE
56 ;D QUEUE^C0CXPATH("GBLD","G1",1,$O(G1(""),-1)) ; NCSCRIPT
57 D QUEUE^C0CXPATH("GBLD","G1",1,76) ; NCSCRIPT.. UP TO </Patient>
58 D QUEUE^C0CXPATH("GBLD","G6",1,$O(G6(""),-1)) ; ADD THE ALLERGIES
59 D QUEUE^C0CXPATH("GBLD","G1",77,$O(G1(""),-1)) ;END OF NCSCRIPT
60 D QUEUE^C0CXPATH("GBLD","G4",1,$O(G4(""),-1)) ; END OF FILE
61 D BUILD^C0CXPATH("GBLD","G5") ; BUILD THE CONTENTS FROM THE BUILD LIST
62 M @RTNXML=G5 ;
63 I $G(ZFILE)=1 W $$OUTPUT^C0CXPATH("G5(1)","ALLERGY-"_ZDFN_".html","/home/dev/CCR/")
64 Q
65 ;
66GETALGY(OUTARY,ZDFN) ;
67 ;
68 N ZG,ZG2,ZB,ZN
69 S DEBUG=0
70 D GETTEMP^C0PWS1("ZG",16) ;GET THE ALLERGY TEMPLATE
71 D EXTRACT^C0CALERT("ZG",ZDFN,"ZG2","ALGYCBK^C0PALGY3(ALTVMAP,A1)")
72 S ZN=$O(ZG2(""),-1) ;NUMBER OF LINES IN OUTPUT
73 D QUEUE^C0CXPATH("ZB","ZG2",2,ZN-1)
74 D BUILD^C0CXPATH("ZB",OUTARY)
75 Q
76 ;
77ALGYCBK(ZRTN,ZIN) ;CALLBACK ROUTINE FOR C0CALERT USED TO SET FDB CONCEPT
78 ; ID IF FOUND. ZIN IS PASSED BY NAME AND IS ONE ALLERGY
79 N ZI,ZJ
80 S ZI=$P(ZIN,"^",9) ;THIS IS THE VARIABLE POINTER OF THE GMR ALLERGY
81 I ZI="" Q
82 S ZJ=$O(^C0PALGY("VA",ZI,""))
83 I ZJ'="" D ; CONCEPT WAS FOUND
84 . S ZK=$$GET1^DIQ(113059005,ZJ_",",.05) ;COMPOSIT ALLERGY ID (NOT CONCEPT)
85 . S @ZRTN@("ALERTFDBCONCEPTID")=ZK
86 . S @ZRTN@("ALERTFDB")="FDB"
87 E D ;
88 . S @ZRTN@("ALERTFDBCONCEPTID")=""
89 . S @ZRTN@("ALERTFDB")=""
90 Q
91 ;
92UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
93 K ZERR
94 D CLEAN^DILF
95 D UPDATE^DIE("","C0PFDA","","ZERR")
96 I $D(ZERR) D ERROR^C0PMAIN(",U113059008,",$ST($ST,"PLACE"),"ERX-UPDIE-FAIL","Fileman Data Update Failure") QUIT
97 K C0PFDA
98 Q
Note: See TracBrowser for help on using the repository browser.