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

initial release of ePrescribing

This commit is contained in:
george 2012-11-11 16:20:01 +00:00
parent 727c4de6c0
commit 274fdc1ff5
34 changed files with 6297 additions and 5554 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

116
p/C0PALGY1.m Normal file
View File

@ -0,0 +1,116 @@
C0PALGY1 ; ERX/GPL/SMH - eRx Allergy utilities ; 5/8/12 11:52pm
;;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
GETRXNS(C0PDUZ,C0PDFN,ZRTN) ; Public Procedure
; Retrieve allergies from WebService, and store in VistA
; ART APIs will automatically not file an allergy if it is a duplicate
; Also, marking pt as NKA won't work if pt already has allergy in VistA
; That's why there is no check for duplicates in this code
; Input:
; - C0PDUZ: DUZ, By Value
; - C0PDFN: DFN, By Value
;
N C0PWSRXNS
D SOAP^C0PWS1("C0PWSRXNS","GETALLERGIES",C0PDUZ,C0PDFN)
N C0PI
F C0PI=1:1:C0PWSRXNS(1,"RowCount") DO
. N RXN M RXN=C0PWSRXNS(C0PI)
. ; For certain food allergies, CompositeID is not returned
. I '$D(RXN("CompositeID")) S RXN("CompositeID")="" ; prevent undef crash
. I RXN("CompositeID")=11623 QUIT ; Code for 'No Allergy Information'
. I (RXN("CompositeID")=231)!(RXN("CompositeID")=232)!(RXN("CompositeID")=14278)!(RXN("CompositeID")=14279) D QUIT
. . N ORDFN S ORDFN=C0PDFN ; Apparently the 'API' uses CPRS variables
. . D NKA^GMRAGUI1 ; Codes for NKA
. D FILE(.RXN,C0PDUZ,C0PDFN)
QUIT ; /GETRXNS
;
FILE(RXN,C0PDUZ,C0PDFN) ; Private Proc - File Drug Reaction
; Input:
; - RXN: Merged WS ADR, by Reference
; - C0PDUZ: DUZ, By Value
; - C0PDFN: DFN, By Value
; ConceptTypeIDs: 6 = Generic Name; 2 = Brand Name; 1 = Drug Class
N C0PRXN
S:RXN("ConceptTypeID")=6 C0PRXN("GMRAGNT")=$$BASE(RXN("ConceptID"))
S:RXN("ConceptTypeID")=2 C0PRXN("GMRAGNT")=$$NAME($$UP^XLFSTR(RXN("Name")))
S:RXN("ConceptTypeID")=1 C0PRXN("GMRAGNT")=$$GROUP(RXN("ConceptID"))
; Try a free text match on 120.82 (GMRA ALLERGIES) to see if there is a
; match on a food allergy (ConceptTypeID 9 [free txt] or 10 [other allergies])
IF $G(C0PRXN("GMRAGNT"))="" D ; need to handle type 9 or 10 .. gpl
. S C0PRXN("GMRAGNT")=$$GMRA($$UP^XLFSTR(RXN("Name")))
IF C0PRXN("GMRAGNT")="" DO QUIT ; Agent not found in VistA; TODO mail msg
. N ZT ; TEXT TO DISPLAY AS ERROR MESSAGE
. S ZT="Error Mapping Allergy ConceptID: "_$G(RXN("ConceptID"))
. D MAPERR^C0PRECON(.ZRTN,"Allergy",ZT) ;DISPLAY ERROR
S C0PRXN("GMRATYPE")=$$TYPE(C0PRXN("GMRAGNT"))
S C0PRXN("GMRANATR")="U^Unknown"
S C0PRXN("GMRAORIG")=C0PDUZ
S C0PRXN("GMRACHT",0)=1
S C0PRXN("GMRACHT",1)=$$NOW^XLFDT
S C0PRXN("GMRAORDT")=$$NOW^XLFDT
S C0PRXN("GMRAOBHX")="h^HISTORICAL"
I $D(RXN("Notes")) D
. S C0PRXN("GMRACMTS",0)=1
. S C0PRXN("GMRACMTS",1)=RXN("Notes")
D UPDATE^GMRAGUI1("",C0PDFN,"C0PRXN")
I $G(^TMP("C0PDEBUG"))="" Q ; ONLY SHOW ALLERGY MESSAGES IN DEBUG
I $P(ORY,U,1)<0 D MAPERR^C0PRECON(.ZRTN,"Allergies",ORY) ;ERROR MESSAGE
QUIT
;
BASE(ID) ; $$ Private - Retrieve GMRAGNT for Generic Name ConceptID
; Input: ID, By Value
; Output: Ingreident Name^IEN;File Root for IEN
; First, match drug to VistA, Look in VA GENERIC first
N VAGEN S VAGEN=$$VAGEN2^C0PLKUP(ID)
; if no match, look in DRUG INGREDIENT
N DRUGING S DRUGING=""
I '+VAGEN S DRUGING=$$DRUGING2^C0PLKUP(ID)
Q:+VAGEN $P(VAGEN,U,2)_U_$P(VAGEN,U)_";PSNDF(50.6,"
Q:+DRUGING $P(DRUGING,U,2)_U_$P(DRUGING,U)_";PS(50.416,"
QUIT "" ; TODO: Notify somebody that no match found
;
NAME(BRAND) ; $$ Private - Retrieve GMRAGNT for Brand Name
; Input: Brand Name, By Value
; Output: Ingreident Name^IEN;File Root for IEN
N C0POUT,C0PMATCH ; output variable, # of matches
S C0PMATCH=$$TGTOG2^PSNAPIS(BRAND,.C0POUT)
; Output for C0POUT:
; C0POUT(24)="24^VANCOMYCIN"
; 24 is IEN of drug in VA GENERIC file
Q:C0PMATCH $P(@$Q(C0POUT),U,2)_U_$P(@$Q(C0POUT),U)_";PSNDF(50.6,"
Q "" ; otherwise quit with nothing
;
GROUP(ID) ; Private Proc - Store drug class allergy
QUIT "" ; not implemented
GMRA(NAME) ; $$ Private - Retrieve GMRAGNT for food allergy from 120.82
; Input: Brand Name, By Value
; Output: Entry Name^IEN;File Root for IEN
N C0PIEN S C0PIEN=$$FIND1^DIC(120.82,"","O",NAME,"B")
Q:C0PIEN $$GET1^DIQ(120.82,C0PIEN,.01)_"^"_C0PIEN_";GMRD(120.82,"
QUIT "" ; no match otherwise
TYPE(GMRAGNT) ; $$ Private - Get allergy Type (Drug, food, or other)
; Input: Allergen, formatted as Allergen^IEN;File Root
; Output: Type (internal)^Type (external) e.g. D^Drug
N C0PIEN S C0PIEN=+$P(GMRAGNT,U,2)
I GMRAGNT["GMRD(120.82," Q $$GET1^DIQ(120.82,C0PIEN,"ALLERGY TYPE","I")_U_$$GET1^DIQ(120.82,C0PIEN,"ALLERGY TYPE","E")
Q "D^Drug" ; otherwise, it's a drug
ACCOUNTF() Q 113059002 ; file number for account file
F200C0P() Q 200.113059 ; Subfile number of C0P Subscription Multiple
;

299
p/C0PALGY2.m Normal file
View File

@ -0,0 +1,299 @@
C0PALGY2 ; ERX/GPL/SMH - eRx Allergy utilities ; 5/8/12 11:52pm
;;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
;
; THESE ROUTINES ARE USED TO TEST AND VALIDATE THE USE OF THE RXNORM
; DATABASE FOR LOOKING UP IDS AND MATCHING FIRST DATA BANK IDS TO
; RXNORM CONCEPT IDS AND THEN FROM RXNORM CONCEPT IDS TO VISTA VUIDS
; THE PARTICULAR INTEREST HERE IS FOR MATCHING ALLERGIES TO A MEDICATION
; IN ADDITION THERE ARE ROUTINES HERE TO POPULATE THE C0P FDB ALLERGIES
; FILE.
; NONE OF THESE ROUTINES ARE USED IN REGULAR ERX ACTIVITIES. THEY
; ARE BROUGHT FORWARD AS PART OF THE ERX PACKAGE FOR DEBUGGING AND
; FUTURE DEVELOPMENT
; GPL JUN 2010
TESTBASE ; TEST LOOKING UP CONCEPT IDS IN RXNORM
;
N ZI
S ZI=""
S (COUNT,FOUND)=0
F S ZI=$O(^C0PALGY("TYPE","BASE",ZI)) Q:ZI="" D ; FOR EACH BASE CONCEPT
. S COUNT=COUNT+1
. S ZJ=$$GET1^DIQ(113059005,ZI_",",1,"E")
. S ZN=$$GET1^DIQ(113059005,ZI_",",.01,"E")
. S ZV=$$BASE^C0PALGY1(ZJ) ;LOOKUP VISTA MATCH
. I ZV'="" S FOUND=FOUND+1
. W !,ZJ," ",ZN," :: ",ZV
W !,"COUNT:",COUNT," FOUND:",FOUND
Q
;
TESTNAME ; TEST LOOKING UP CONCEPT IDS IN RXNORM
;
N ZI
S ZI=""
S (COUNT,FOUND)=0
F S ZI=$O(^C0PALGY("TYPE","NAME",ZI)) Q:ZI="" D ; FOR EACH BASE CONCEPT
. S COUNT=COUNT+1
. S ZJ=$$GET1^DIQ(113059005,ZI_",",1,"E")
. S ZN=$$GET1^DIQ(113059005,ZI_",",.01,"E")
. S ZV=$$NAME^C0PALGY1($$UP^XLFSTR(ZN)) ;LOOKUP VISTA MATCH
. I ZV'="" S FOUND=FOUND+1
. W !,ZJ," ",ZN," :: ",ZV
W !,"COUNT:",COUNT," FOUND:",FOUND
Q
;
TEST3 ;
;
S ZI=0
S (COUNT,FOUND)=0
F S ZI=$O(^PSNDF(50.6,ZI)) Q:+ZI=0 D ; FOR EVERY DRUG IN THE NDF
. S COUNT=COUNT+1
. S ZJ=$G(^PSNDF(50.6,ZI,"VUID")) ;VUID
. S ZJ=$P(ZJ,"^",1) ;JUST THE FIRST PIECE
. S ZJN=$G(^PSNDF(50.6,ZI,0)) ; VA NAME
. W !,ZJN," ",ZJ
. S ZK=$$NDDFBAS2^C0PLKUP(ZJ)
. I ZK'=0 D ; FDB CONCEPT ID FOUND
. . S ZL=$O(^C0PALGY("C2","BASE",ZK,""))
. . S ZN=$$GET1^DIQ(113059005,ZL_",",.01,"E")
. . I ZN'="" D ;
. . . S FOUND=FOUND+1
. . . S ZP=ZI_";PSNDF(50.6,"
. . . S C0PFDA(113059005,ZL_",",6)=ZP
. . . D UPDIE
. . W $C(9),ZI," ",ZJ," :: ",ZK," ",ZN
W !,"COUNT:",COUNT," FOUND:",FOUND
Q
;
TEST4 ;
;
S ZI=0
S (COUNT,FOUND)=0
F S ZI=$O(^PS(50.416,ZI)) Q:+ZI=0 D ; DRUG INGREDIENTS FILE
. S COUNT=COUNT+1
. S ZJ=$G(^PS(50.416,ZI,"VUID")) ;VUID
. S ZJ=$P(ZJ,"^",1) ;JUST THE FIRST PIECE
. S ZJN=$G(^PS(50.416,ZI,0)) ; VA NAME
. W !,ZJN," ",ZJ
. S ZK=$$NDDFBAS2^C0PLKUP(ZJ)
. ;I ZI=3912 B
. I ZK'=0 D ; FDB CONCEPT ID FOUND
. . S ZL=$O(^C0PALGY("C2","BASE",ZK,""))
. . S ZN=$$GET1^DIQ(113059005,ZL_",",.01,"E")
. . I ZN'="" D ;
. . . S FOUND=FOUND+1
. . . W $C(9),ZI," ",ZJ," :: ",ZK," ",ZN
. . . S ZP=ZI_";PS(50.416,"
. . . S C0PFDA(113059005,ZL_",",6)=ZP
. . . D UPDIE
W !,"COUNT:",COUNT," FOUND:",FOUND
Q
;
TEST5 ; VA PRODUCT FILE
;
S ZI=0
S (COUNT,FOUND)=0
F S ZI=$O(^PSNDF(50.68,ZI)) Q:+ZI=0 D ; FOR EVERY DRUG IN THE NDF
. S COUNT=COUNT+1
. S ZJ=$G(^PSNDF(50.68,ZI,"VUID")) ;VUID
. S ZJ=$P(ZJ,"^",1) ;JUST THE FIRST PIECE
. S ZJN=$G(^PSNDF(50.68,ZI,0)) ; VA NAME
. ;W !,ZJN," ",ZJ
. S ZK=$$NDDFBAS2^C0PLKUP(ZJ)
. I ZK'=0 D ; FDB CONCEPT ID FOUND
. . S ZL=$O(^C0PALGY("C2","NAME",ZK,""))
. . S ZN=$$GET1^DIQ(113059005,ZL_",",.01,"E")
. . I ZN'="" D ;
. . . S FOUND=FOUND+1
. . . S ZP=ZI_";PSNDF(50.68,"
. . . S C0PFDA(113059005,ZL_",",6)=ZP
. . . D UPDIE
. . W !,ZJN," ",ZJ
. . W $C(9),ZI," ",ZJ," :: ",ZK," ",ZN
W !,"COUNT:",COUNT," FOUND:",FOUND
Q
;
TEST6 ; CHECK ALL VUIDS IN VA PRODUCT FILE AGAINST RXNORM CONCEPT FILE
;
S ZI=0
S (COUNT,FOUND)=0
F S ZI=$O(^PSNDF(50.68,ZI)) Q:+ZI=0 D ; FOR EVERY DRUG IN THE NDF
. S COUNT=COUNT+1
. S ZJ=$G(^PSNDF(50.68,ZI,"VUID")) ;VUID
. S ZJ=$P(ZJ,"^",1) ;JUST THE FIRST PIECE
. S ZJN=$G(^PSNDF(50.68,ZI,0)) ; VA NAME
. ;W !,ZJN," ",ZJ
. S ZRXN=$O(^C0P("RXN","VUID",ZJ,""))
. I ZRXN'="" S FOUND=FOUND+1
W !,"COUNT:",COUNT," FOUND:",FOUND
Q
;
TEST7 ; CHECK ALL CONCEPT IDS IN THE FDB ALLERGY FILE AGAINST THE
;RXNORM CONCEPT FILE - THIS APPOACH DOESN'T WORK.
;
S ZI=0
S (COUNT,FOUND)=0
F S ZI=$O(^C0PALGY("C",ZI)) Q:+ZI=0 D ; EVERY FDB ALLERGY CONCEPT
. S ZIN=$$GET1^DIQ(113059005,ZI_",",.01) ;NAME OF CONCEPT
. S ZJ=$O(^C0P("RXN","B",ZI,"")) ; RXNORM CONCEPT FIELD IS .01
. S COUNT=COUNT+1
. I ZJ'="" D ; FOUND
. . S FOUND=FOUND+1
. . S ZJN=$G(^C0P("RXN",ZJ,1,1,0)) ;NAME OF CONCEPT
. . ;S ZJNNN=$$GET1^DIQ(1130590011.101,ZJ_",",,ZJN)
. . I ZIN'="" W !,ZI,ZIN," :: ",ZJ," ",ZJN
W !,"COUNT:",COUNT," FOUND:",FOUND
Q
;
TESTC ; PRINT OUT DUPLICATES IN THE FROM THE C INDEX OF THE ALLERGY FILE
;
S (COUNT,COUNT2)=0
S ZI=""
F S ZI=$O(^C0PALGY("C",ZI)) Q:ZI="" D ;
. S ZJ=$O(^C0PALGY("C",ZI,"")) ;IEN
. I $O(^C0PALGY("C",ZI,ZJ))'="" D ;
. . S ZZ=""
. . F S ZZ=$O(^C0PALGY("C",ZI,ZZ)) Q:ZZ="" D ;
. . . S COUNT=COUNT+1
. . . S ZK=$$GET1^DIQ(113059005,ZZ_",",6)
. . . S ZL=$$GET1^DIQ(113059005,ZZ_",",.01)
. . . S ZT=$$GET1^DIQ(113059005,ZZ_",",2)
. . . I ZK'="" S COUNT2=COUNT2+1
. . . S DUPS(ZI,ZL,ZT)=ZK
. . . W !,ZK," ",ZI
Q
;
COUNT ; COUNT THE NUMBER OF MAPPINGS IN VA POINTER INDEX OF FDB ALLERGIES
;
N ZI,ZJ,COUNT
S COUNT=0
S ZI="" S ZJ=""
F S ZI=$O(^C0PALGY("VA",ZI)) Q:ZI="" D ;
. S ZJ=""
. F S ZJ=$O(^C0PALGY("VA",ZI,ZJ)) Q:ZJ="" D ;
. . S COUNT=COUNT+1
W !,"COUNT: ",COUNT,!
Q
;
CHECK ; CHECK ALL ALLERGIES IN THE PATIENT ALLERGY FILE FOR MATCHES IN
; THE FDB ALLERGY FILE
N ZI,ZJ,COUNT
S (ZI,ZJ)=0 S COUNT=0 S COUNT2=0
F S ZI=$O(^GMR(120.8,ZI)) Q:+ZI=0 D ; FOR EACH ENTRY
. S ZJ=^GMR(120.8,ZI,0) ; ZERO NODE
. S PAT=$P(ZJ,U,1) ;PATIENT
. S ZN=$P(ZJ,U,2) ;REACTANT NAME
. S GMR=$P(ZJ,U,3) ;POINTER
. S COUNT=COUNT+1
. S FOUND=$O(^C0PALGY("VA",GMR,"")) ; VA POINTER INDEX
. S ZF=""
. I FOUND'="" D ;
. . S COUNT2=COUNT2+1
. . S ZF=$$GET1^DIQ(113059005,FOUND_",",.01,"E")
. W !,"PAT:",PAT," ",ZN," ",GMR," :: ",FOUND," ",ZF
W !,"COUNT:",COUNT," FOUND:",COUNT2
Q
;
LOADRXN ; LOAD THE FDB TO RXNORM CSV FILE INTO ^TMP
; THE FILE NAME IS CompositeAllergyID2RxCui.csv
; AND IT IS STORED IN /home/dev
N ZG
S ZG=$NA(^TMP("C0PALGY","RXNCSV",1))
W $$FTG^%ZISH("/home/dev/","CompositeAllergyID2RxCui.csv",ZG,3) ;INCREMENT
; 3rd NODE
Q
;
ADDRXN ; ADD THE CompositeAllergyID to rxcui mapping to the
; C0P FDB ALLERGY file
; the csv file with the mapping has been loaded into
; ^TMP("C0PALGY","RXNCSV") - see LOADRXN routine above
N ZI,ZJ,ZARY,ZF,C0PFDA
S ZF=113059005 ; FILE NUMBER FOR C0P FDB ALLERGY FILE
S ZARY=$NA(^TMP("C0PALGY","RXNCSV"))
S ZJ=$O(@ZARY@(""),-1) ; NUMBER OF ROWS IN THE ARRAY
F ZI=2:1:ZJ D ; SKIP ROW 1, WHICH HAS THE COLUMN NAMES
. N ZFDA,ZRXN,ZROW
. K C0PFDA
. S ZROW=@ZARY@(ZI) ; EACH ROW IS ""X"",""Y""
. S ZFDA=$P(ZROW,",",1) ; CompositeAllergyID
. S ZFDA=$TR(ZFDA,"""") ; GET RID OF EXTRA QUOTES
. S ZRXN=$P(ZROW,",",2) ; rxcui
. S ZRXN=$TR(ZRXN,"""") ; GET RID OF EXTRA QUOTES
. W !,ZFDA," ",ZRXN
. S ZOHONE=$$GET1^DIQ(ZF,ZFDA_",",.01)
. S C0PFDA(ZF,ZFDA_",",.01)=ZOHONE
. S C0PFDA(ZF,ZFDA_",",7)=ZRXN ; SET rxcui for ien ZFDA
. D UPDIE
Q
;
LOOKRXN ; LOOK UP RXCUI VALUES IN THE RXNORM CONCEPT FILE
;
S COUNT=0 S FOUND=0
S ZI=""
F S ZI=$O(^C0PALGY("RXCUI",ZI)) Q:ZI="" D ;
. S COUNT=COUNT+1
. S ZJ=$O(^C0P("RXN","B",ZI,"")) ;
. W !,ZI," ",ZJ
W !,COUNT," FOUND"
Q
;
LOOKFDB ;LOOK UP FDB NUMBERS IN THE RXNORM FILE
;
S ZI=""
F S ZI=$O(^C0PALGY("C",ZI)) Q:ZI="" D ;
. S ZJ=$O(^C0PALGY("C",ZI,""))
. W !,ZI," ",ZJ
Q
;
MKRNF ; CREATING AN RNF FILE FOR THE FDB ALLERGY TABLE
;
F ZI=1:1:999999 F ZJ=1:1:7 D ;
. I ZJ=1 S ^GRNF("V",ZI,$O(^GRNF("F",ZJ,"")))=ZI
. S ZK=$P(^GPLFDB(ZI),""",""",ZJ)
. S ZK=$TR(ZK,"""")
. I ZJ=6 D ;STATUS
. . I (ZK'="A")&(ZK'="I") D ERROR^C0PMAIN(",U113059009,",$ST($ST,"PLACE"),"ERX-INVALID-DATA","Invalid Data") QUIT
. I ZK'="" D ;
. . S ^GRNF("V",ZI,$O(^GRNF("F",ZJ,"")))=ZK
Q
;
FILEFDB ;POPULATE C0P FDB ALLERGIES FROM RNF STRUCTURE IN ^GRNF
;
F ZI=1:1:999999 D ;
. K C0PFDA
. S C0PFDA(113059005,"?+1,",.01)=^GRNF("V",ZI,"Description")
. S C0PFDA(113059005,"?+1,",.05)=$G(^GRNF("V",ZI,"CompositeAllergyID"))
. S C0PFDA(113059005,"?+1,",1)=^GRNF("V",ZI,"ConceptID")
. S C0PFDA(113059005,"?+1,",2)=^GRNF("V",ZI,"ConceptType")
. S C0PFDA(113059005,"?+1,",3)=^GRNF("V",ZI,"Source")
. S C0PFDA(113059005,"?+1,",4)=^GRNF("V",ZI,"Status")
. S C0PFDA(113059005,"?+1,",5)=^GRNF("V",ZI,"TouchDate")
. ;ZWR C0PFDA
. ;B
. D UPDIE
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

98
p/C0PALGY3.m Normal file
View File

@ -0,0 +1,98 @@
C0PALGY3 ; ERX/GPL - eRx Allergy utilities ; 5/8/12 9:11pm
;;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
;
ADDALGY(RTNXML,ZDUZ,ZDFN,ZFILE) ; ADDS PATIENT ALLERGIES TO NCSCRIPT
; CLICK-THROUGH HTLM FILE FOR
; MAPPING ALLERGIES , XML IS RETURNED IN RTN,PASSED BY NAME
; IF ZFILE IS 1, THE FILE IS WRITTEN TO AN XML FILE
;D EN^C0PMAIN("G1","G2",ZDUZ,ZDFN) ; GET THE NCSCRIPT
;S @RTNURL=G2
;D GETXML^C0PWS1("G3",14) ; GET BEGINNING OF FILE
;D GETXML^C0PWS1("G4",15) ; GET END OF FILE
N G1,G2,G3,G4,G5,G6,GBLD
D GETALGY("G6",ZDFN) ;GET ALLERGIES
;D QUEUE^C0CXPATH("GBLD","G3",1,$O(G3(""),-1)) ;BUILD LIST BEGINNING OF FILE
;;D QUEUE^C0CXPATH("GBLD","G1",1,$O(G1(""),-1)) ; NCSCRIPT
M G1=@RTNXML
S GEND=$O(G1(""),-1)-2
D QUEUE^C0CXPATH("GBLD","G1",1,GEND) ; NCSCRIPT.. UP TO </Patient>
D QUEUE^C0CXPATH("GBLD","G6",1,$O(G6(""),-1)) ; ADD THE ALLERGIES
D QUEUE^C0CXPATH("GBLD","G1",GEND+1,$O(G1(""),-1)) ;END OF NCSCRIPT
D QUEUE^C0CXPATH("GBLD","G4",1,$O(G4(""),-1)) ; END OF FILE
D BUILD^C0CXPATH("GBLD","G5") ; BUILD THE CONTENTS FROM THE BUILD LIST
K @RTNXML
M @RTNXML=G5 ;
I $G(ZFILE)=1 W $$OUTPUT^C0CXPATH("G5(1)","ALLERGY-"_ZDFN_".html","/home/dev/CCR/")
Q
;
GENTEST(RTNXML,RTNURL,ZDUZ,ZDFN,ZFILE) ; GENERATE A TEST
; CLICK-THROUGH HTLM FILE FOR
; MAPPING ALLERGIES , XML IS RETURNED IN RTN,PASSED BY NAME
; IF ZFILE IS 1, THE FILE IS WRITTEN TO HOST FILE
D EN^C0PMAIN("G1","G2",ZDUZ,ZDFN) ; GET THE NCSCRIPT
;S @RTNURL=G2
D GETXML^C0PWS1("G3",14) ; GET BEGINNING OF FILE
D GETXML^C0PWS1("G4",15) ; GET END OF FILE
D GETALGY("G6",ZDFN) ;GET ALLERGIES
D QUEUE^C0CXPATH("GBLD","G3",1,$O(G3(""),-1)) ;BUILD LIST BEGINNING OF FILE
;D QUEUE^C0CXPATH("GBLD","G1",1,$O(G1(""),-1)) ; NCSCRIPT
D QUEUE^C0CXPATH("GBLD","G1",1,76) ; NCSCRIPT.. UP TO </Patient>
D QUEUE^C0CXPATH("GBLD","G6",1,$O(G6(""),-1)) ; ADD THE ALLERGIES
D QUEUE^C0CXPATH("GBLD","G1",77,$O(G1(""),-1)) ;END OF NCSCRIPT
D QUEUE^C0CXPATH("GBLD","G4",1,$O(G4(""),-1)) ; END OF FILE
D BUILD^C0CXPATH("GBLD","G5") ; BUILD THE CONTENTS FROM THE BUILD LIST
M @RTNXML=G5 ;
I $G(ZFILE)=1 W $$OUTPUT^C0CXPATH("G5(1)","ALLERGY-"_ZDFN_".html","/home/dev/CCR/")
Q
;
GETALGY(OUTARY,ZDFN) ;
;
N ZG,ZG2,ZB,ZN
S DEBUG=0
D GETTEMP^C0PWS1("ZG",16) ;GET THE ALLERGY TEMPLATE
D EXTRACT^C0CALERT("ZG",ZDFN,"ZG2","ALGYCBK^C0PALGY3(ALTVMAP,A1)")
S ZN=$O(ZG2(""),-1) ;NUMBER OF LINES IN OUTPUT
D QUEUE^C0CXPATH("ZB","ZG2",2,ZN-1)
D BUILD^C0CXPATH("ZB",OUTARY)
Q
;
ALGYCBK(ZRTN,ZIN) ;CALLBACK ROUTINE FOR C0CALERT USED TO SET FDB CONCEPT
; ID IF FOUND. ZIN IS PASSED BY NAME AND IS ONE ALLERGY
N ZI,ZJ
S ZI=$P(ZIN,"^",9) ;THIS IS THE VARIABLE POINTER OF THE GMR ALLERGY
I ZI="" Q
S ZJ=$O(^C0PALGY("VA",ZI,""))
I ZJ'="" D ; CONCEPT WAS FOUND
. S ZK=$$GET1^DIQ(113059005,ZJ_",",.05) ;COMPOSIT ALLERGY ID (NOT CONCEPT)
. S @ZRTN@("ALERTFDBCONCEPTID")=ZK
. S @ZRTN@("ALERTFDB")="FDB"
E D ;
. S @ZRTN@("ALERTFDBCONCEPTID")=""
. S @ZRTN@("ALERTFDB")=""
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

363
p/C0PCPRS1.m Normal file
View File

@ -0,0 +1,363 @@
C0PCPRS1 ; CCDCCR/GPL - ePrescription utilities; 8/1/09 ; 5/8/12 10:18pm
;;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
;
; THESE ROUTINE CONSTITUTE ALL OF THE ENTRY POINTS IN THE ERX PACKAGE
; THAT ARE USED BY CPRS.
; ERXRPC IS USED BY CPRS TO LAUNCH THE MEDICATION COMPOSE SCREEN
; IT IS ALSO USED BY CPRS TO PROCESS AN INCOMPLETE ORDER ALERT
; ERXPULL IS USED BY CPRS AFTER A SESSION WITH THE EPRESCRIBING PROVIDER
; TO PULL BACK ANY NEW MEDICATIONS AND ALLERGIES FROM THAT SESSION
; IT DOES MEDICATION AND ALLERGY RECONCILLIATION
; ALERTRPC IS USED BY CPRS TO LAUCH THE RENEWAL REQUEST SCREEN IN THE
; EPRECRIBING PROVIDER. AFTER THE RENEWAL SESSION ENDS, ERXPULL IS ALSO
; CALLED
; GPL JUNE, 2010
;
; TEST Lines below not intended for End Users. Programmers only.
; BEWARE ZWRITE SYNTAX. It may not work in other M Implementations.
TEST1 ; TEST ERX RPC FROM COMMAND LINE - RETURN RAW HTTPS POST ARRAY
;
N C0PG1
D ERXRPC(.C0PG1,"135","2")
W $$OUTPUT^C0CXPATH("C0PG1(1)","Test-RPC-POST1.html","/home/dev/CCR/"),!
ZWRITE C0PG1
Q
;
TEST2 ; TEST ERX RPC FROM COMMAND LINE - RETURN CODED HTTPS POST ARRAY
;
Q
;
ERXPULL(RTN,IDUZ,IDFN) ;RPC TO PULL BACK DRUGS AND ALLERGIES
;
S ^TMP("GPL","PULLBACKDFN")=IDFN ; debugging
N UDFN
S UDFN=IDFN
I $D(^TMP("C0E",$J,"NEWDFN")) D ; IF THERE IS A NEW RENEWAL PATIENT
. I IDFN'=0 Q ; SHOULD BE ZERO FOR A NO MATCH RENEWAL
. S UDFN=^TMP("C0E",$J,"NEWDFN") ; GET THE MATCHED PATIENT DFN
. S ^TMP("GPL","NEWDFN")=UDFN ; debugging
. K ^TMP("C0E",$J,"NEWDFN") ; ERASE IT NOW THAT IT IS USED
D GETRXNS^C0PALGY1(IDUZ,UDFN,.RTN) ;PULL BACK ALLERGIES AND ADD TO ALLERGIES
D GETMEDS^C0PRECON(IDUZ,UDFN,.RTN) ;PULL BACK MEDS AND ADD TO NON-VA MEDS
I $G(RTN(1))="" S RTN(1)="OK"
I UDFN'=IDFN S RNT(1)="DFN="_UDFN ; TELL CPRS ABOUT THE NEW DFN
;D REFILL^C0PREFIL ; PULL BACK REFILL REQUESTS EVERY TIME
Q
;
TESTUC0P
S ZA="OR,18,11305;135;3120305.103008"
D ALERTRPC(.GPL,135,18,1,ZA)
Q
;
TESTALRT(GPL,ZDUZ,ZDFN,MODE) ; TEST THE ALERT RPC
;
;S G=$O(^XTV(8992,135,"XQA",""),-1)
;S G=3110102.15081201
;S ZA="OR,18,11305;135;"_G ;3101223.125521" ; AN ALERT RECORD ID
;S ZA="OR,0,11305;135;3110103.09324904"
I $G(MODE)'=1 S MODE=0 ; TEST MODE HERE
N ZI,ZJ S ZI=0
F S ZI=$O(^XTV(8992,ZDUZ,"XQA",ZI)) Q:ZI="" D ;
. S ZJ=^XTV(8992,ZDUZ,"XQA",ZI,0)
. I ZJ["no match" S G=ZI
I $G(G)="" W !,"OOPS" Q ;
S ZA="OR,18,11305;135;"_G
;S ZA="OR,18,11305;135;3110810.123002"
W !,ZA
D ALERTRPC(.GPL,ZDUZ,ZDFN,1,ZA,MODE)
Q
I ZDFN=18 D ALERTRPC(.GPL,135,18,1,ZA)
E D ;
. ;S ZA="OR,0,11305;1;3101223.125521"
. D ALERTRPC(.GPL,135,0,1,ZA)
Q
ALERTRPC(RTN,IDUZ,IDFN,DEST,ISTR,MODE) ;RPC FOR ERX ALERTS
; MODE IS A MODE SWITCH IF MODE=1 WE ARE USING THE BROWSER REDIRECT
; METHOD OF CLICKING THROUGH. THIS IS DONE TO COMPLETE NOMATCH RENEWALS
; FROM EWD
; IF MODE IS NOT SPECIFIED OR IS NOT 1, WE WILL USE THE CPRS REDIRECT
; METHOD OF CLICKING THROUGH.
; THE MAIN DIFFERENCE BETWEEN THE TWO MODES IS THE HTML PACKAGING
; SURROUNDING THE NCSCRIPT XML
;
I $G(MODE)'=1 S MODE=0 ; MODE IS 0 IF IT'S NOT 1
S C0PRMODE=1 ; RENEWAL MODE - KILL AT THE END
;
; FIRST SEE IF LOOK UP THE RENEWAL GUID
N ZGUID,ZALRT,C0PMED,ZDOB,ZSEX
; USE THE NEW GETALRT^C0PREFIL TO GET THE GUID DIRECTLY FROM
; THE ALERT TRACKING FILE USING THE RECORDID PASSED IN ISTR
;D GETALRT^C0PREFIL("ZALRT",ISTR) ; GET THE ENTIRE ALERT
;S ZGUID=$G(ZALRT("DATA FOR PROCESSING")) ; PULL OUT THE GUID
; GET THE GUID THE QUICK WAY DIRECTLY FROM THE GLOBAL
S ZALRT=$P(ISTR,";",3) ;THE TIME PORTION OF THE RECORD ID
S ZGUID=$G(^XTV(8992,IDUZ,"XQA",ZALRT,1)) ;WHERE THE GUID SHOULD BE
S ZDOB=$P(ZGUID,"^",2) ; DATE OF BIRTH
S ZSEX=$P(ZGUID,"^",3) ; GENDER
S ZGUID=$P(ZGUID,"^",1) ; GUID IS PIECE ONE
I ZGUID'="" D ; FOUND THE ALERT
. N ZNM S ZNM=$G(^XTV(8992,IDUZ,"XQA",ZALRT,0)) ; THE ALERT RECORD
. S C0PRNM=$P($P(ZNM,"[eRx] ",2)," Renewal",1) ; patient name
. S C0PMED=$P(ZNM,"request for ",2) ; name of the medication
;I ZGUID="" S ^G("NOGUID")=ISTR
;I ZGUID="" M ^G("NOGUID")=^XTV(8992,IDUZ,"XQA")
UC0P1 I ZGUID="" D Q ; This is usually a missing Alert due to timing
. ; of the batch job and the CPRS request to process an error.
. W "ERROR EXTRACTING ALERT",!
. I $T(LOG^%ZTER)="" D ^%ZTER Q ;
. N C0PERR S C0PERR="UC0P1"
. S C0PERR("PLACE")="UC0P1^C0PCPRS1"
. D LOG^%ZTER(.C0PERR)
;N DONE S DONE=0
;I ZGUID="" D ; TRY AND FIND THE GUID ANYWAY
;. N ZZI S ZZI=0
;. F S ZZI=$O(^XTV(8992,IDUZ,"XQA",ZZI)) Q:DONE Q:ZZI="" D ;
;. . N ZA S ZA=$G(^XTV(8992,IDUZ,"XQA",ZZI,0))
;. . ;W !,ZA B
;. . I ZA="" Q ; SHOULDN'T HAPPEN
;. . I $P(ZA,ZALRT,2)'="" D ;
;. . . N ZNM S ZNM=$G(^XTV(8992,IDUZ,"XQA",ZZI,0)) ; THE ALERT RECORD
;. . . S C0PRNM=$P($P(ZNM,"[eRx] ",2)," Renewal",1) ; patient name
;. . . S ZGUID=$G(^XTV(8992,IDUZ,"XQA",ZZI,1)) ; THE GUID
;. . . S ZDOB=$P(ZGUID,"^",2) ; DATE OF BIRTH
;. . . S ZSEX=$P(ZGUID,"^",3) ; GENDER
;. . . S ZGUID=$P(ZGUID,"^",1) ; GUID IS PIECE ONE
;. . . S C0PMED=$P(ZNM,"request for ",2) ; name of the medication
;. . . S DONE=1
I ZGUID="" W "ERROR EXTRACTING ALERT",! Q ;
;S ZGUID=$P(ZGUID,U,3) ;THE VALUE IS IN P3
;S ZIEN=$O(^C0PRE("E","A",IDUZ,IDFN,ISTR,"")) ;LOOK FOR AN ACTIVE ALERT
;I ZIEN="" D Q ; OOPS NO MATCHING ALERT. THIS IS AN ERROR
;. W "ERROR ALERT NOT FOUND",!
;S ZGUID=$$GET1^DIQ(113059006,ZIEN_",",.01,"I")
; BUILD THE NCSRIPT XML FOR RENEWALS
N ZTID
S ZTID=$$RESTID^C0PWS1(IDUZ,"RENEWREQ") ;
N GVOR ; VARIABLE OVERRIDE ARRAY
S GVOR=""
S GVOR("REQUESTED-PAGE")="renewal"
N ZARY,ZURL
D EN^C0PMAIN("ZARY","ZURL",IDUZ,IDFN,,"GVOR") ; GET THE NCSCRIPT
I IDFN=0 D DELETE^C0CXPATH("ZARY","//NCScript/Patient") ;delete patient
I IDFN=0 D ; GOING TO CALL THE EWD RENEWAL PATIENT MATCHING SCREEN
. S C0PNONAME=1
. S C0PSAV("IDUZ")=IDUZ
. M C0PSAV("DUZ")=DUZ
. S C0PSAV("DFN")=0
. S C0PSAV("C0PRenewalName")=C0PRNM ; THE RENEWAL NAME
. S C0PSAV("RenewalDOB")=ZDOB ; PHARMACY REQUEST DATE OF BIRTH
. S C0PSAV("RenewalSex")=ZSEX ; PHARMACY REQUEST GENDER
. S C0PSAV("renewalToken")=ISTR ; CPRS ALERT TOKEN IDENTIFIER
. S C0PMED=$P(C0PMED,"^",1) ; CLEAN UP THE MEDICATION NAME
. S C0PSAV("medication")=C0PMED ; MEDICATION BEING RENEWED
. S C0PSAV("C0PGuid")=ZGUID ; RENEWAL GUID
. S C0PSAV("dollarJ")=$J ; save the $J of the CPRS session
. ; PASSING THE SUPERVISING DOCTOR DUZ ALONG TO THE EWD RENEWAL SCREEN
. S C0PSAV("SUPERVISING-DUZ")=$G(C0PVARS("SUPERVISING-DOCTOR-DUZ")) ;
N ZTMP
D GETTEMP^C0PWS1("ZTMP",ZTID)
N ZV
S ZV("RENEWAL-GUID")=ZGUID
S ZV("RESPONSE-CODE")="Undetermined"
N ZRVAR,ZREXML
D BIND^C0PMAIN("ZRVAR","ZV",ZTID)
D MAP^C0CXPATH("ZTMP","ZRVAR","ZREXML")
K ZREXML(0) ;
D INSERT^C0CXPATH("ZARY","ZREXML","//NCScript")
K ZARY(0)
D WRAP(.RTN,.ZARY,MODE)
K C0PRMODE ; TURN OFF THE RENEWAL MODE
Q
;
ERXRPC(RTN,IDUZ,IDFN) ; RPC CALL TO RETURN HTTPS POST ARRAY FOR MEDS ORDERING
;
;I IDUZ=135 D TESTALRT(.RTN,IDFN) Q ;GPLTESTING
N C0PXML,C0PURL
D EN^C0PMAIN("C0PXML","C0PURL",IDUZ,IDFN,,,1) ;INCLUDE FREEFORM ALLERGIES
D WRAP(.RTN,.C0PXML) ; WRAP IN HTML FOR PROCESSING IN CPRS
Q
;
WRAP(ZRTN,ZINARY,MODE) ;WRAPS AN XML ARRAY (ZINARY) IN HTML FOR PROCESSING
; BY CPRS - ZINARY AND ZRTN ARE PASSED BY REFERENCE
; SEE COMMENT ABOVE ABOUT THE MODE SWITCH
I $G(MODE)'=1 S MODE=0 ; BROWSER REDIRECT MODE IS 0 IF IT IS NOT 1
;
I '$D(ZINARY(1)) D Q ; NOT SET UP FOR ERX
. S ZRTN(1)="ERROR, PROVIDER NOT SUBSCRIBED"
I MODE'=1 S ZINARY(1)="RxInput="_ZINARY(1)
; GPL - GET THE URL FROM THE XML TEMPLATE FILE BASED ON PRODUCTION FLAG
;S url="https://preproduction.newcropaccounts.com/InterfaceV7/RxEntry.aspx"
D SETUP^C0PMAIN() ;INITALIZE C0PACCT WS ACCOUNT IEN
S url=$$CTURL^C0PMAIN(C0PACCT) ; PRODUCTION OR TEST URL
I $G(C0PNONAME)=1 D ;
. I MODE Q ; WE'VE ALREADY BEEN TO EWD. THIS IS SECOND TIME
. n token s token=$$STORE^C0CEWD("C0PSAV") ; STORE FOR EWD SCREENS
. N ZT,ZU,ZP
. S ZT=$O(^C0PX("B","C0P RENEWAL NOMATCH URL","")) ; IEN FOR URL
. ; EXAMPLE URL: https://viper/dev/eRx/index1.ewd - be sure it matches
. ; your system
. S ZU=$$GET1^DIQ(113059001,ZT_",",1) ; URL OF NOMATCH RENEWAL SCREEN
. I C0PVARS("SUBSCRIBER-USERTYPE")="MidlevelPrescriber" S ZP="midmatch.ewd"
. E S ZP="index1.ewd" ; midlevels get their own page
. S url=ZU_ZP_"?token="""_token_"""" ; ewd interface
. S C0PNONAME=0
I MODE D BRSRDR Q ; BROWSER REDIRCT PACKAGEING INSTEAD OF httpPOST2
S ok=$$httpPOST2(.ZRTN,url,.ZINARY,"application/x-www-form-urlencoded",.gpl6,"","",.gpl5,.gpl7)
Q
;
BRSRDR ; GENERATE BROWSER REDIRECT PACKAGING TO RETURN TO BE SENT TO THE
; BROWSER
;
N ZB,ZTMP,ZTOP,ZBOT,ZTID1,ZTID2,ZVARS
S ZTID1=$$RESTID^C0PWS1(IDUZ,"C0P RENEWAL BRSRDR TOP") ; TOP XML IEN
S ZTID2=$$RESTID^C0PWS1(IDUZ,"C0P RENEWAL BRSRDR BOTTOM") ; BOTTOM XML IEN
D GETXML^C0PWS1("ZTMP",ZTID1) ; TOP XML
S ZVARS("url")=url
D MAP^C0CXPATH("ZTMP","ZVARS","ZTOP") ; SET THE URL PROPERLY
D GETXML^C0PWS1("ZBOT",ZTID2) ; BOTTOM XML
D QUEUE^C0CXPATH("ZB","ZTOP",1,$O(ZTOP(""),-1)) ; ADD TOP TO BUILD LIST
D QUEUE^C0CXPATH("ZB","ZINARY",1,$O(ZINARY(""),-1)) ; ADD NCSCRIPT
D QUEUE^C0CXPATH("ZB","ZBOT",1,$O(ZBOT(""),-1)) ; ADD BOTTOM
D BUILD^C0CXPATH("ZB","ZRTN") ; BUILD RETURN HTML
K ZRTN(0) ; KILL LENTGH NODE
Q
;
GETPOST1(URL) ;
;RETRIEVES WSDL SAMPLE XML FROM A WEBSERVICE AT ADDRESS URL PASSED BY VALUE
;RETURNS THE XML IN ARRAY gpl
s ok=$$httpGET^%zewdGTM(URL,.gpl)
;W "XML retrieved from Web Service:",!
;ZWR gpl
D INDEX^C0CXPATH("gpl","gpl2",-1,"gplTEMP")
Q
;
httpPOST2(ARY,url,payload,mimeType,html,headerArray,timeout,test,rawResponse,respHeaders,sslHost,sslPort)
;ORGINALLY THIS ROUTINE WAS FROM zewdGTM.m (thanks Rob!)
;HACKED BY GPL TO RETURN ITS HTML IN AN ARRAY (ARY PASSED BY REF)
;INSTEAD OF SENDING IT OUT A TPC PORT
;THE ARY WILL BE SENT VIA RPC TO CPRS TO LAUNCH A BROWERS
;USING THIS "POST" HTML AS THE STARTING PAGE (THANKS ART)
;USES THE ROUTINE gw BELOW TO BUILD THE ARRAY
; todo: html not used, test not used, rawResponse, respHeaders
; sam's notes: this routine doesn't actually post anything; it just formats.
n contentLength,dev,host,HTTPVersion,io,port,rawURL,ssl,urllc
n zg ; gpl
;
k rawResponse,html
s HTTPVersion="1.0"
s rawURL=url
s ssl=0
s port=80
s urllc=$$zcvt^%zewdAPI(url,"l")
i $e(urllc,1,7)="http://" d
. s url=$e(url,8,$l(url))
. s sslHost=$p(url,"/",1)
. s sslPort=80
e i $e(urllc,1,8)="https://" d
. s url=$e(url,9,$l(url))
. s ssl=1
. s sslHost=$g(sslHost)
. i sslHost="" s sslHost="127.0.0.1"
. s sslPort=$g(sslPort)
. i sslPort="" s sslPort=89
e QUIT "Invalid URL"
s host=$p(url,"/",1)
i host[":" d
. s port=$p(host,":",2)
. s host=$p(host,":",1)
s url="/"_$p(url,"/",2,5000)
i $g(timeout)="" s timeout=20
;
;GPL s io=$io
i $g(test)'=1 d
. ;GPL s dev=$$openTCP(sslHost,sslPort,timeout)
;GPL . u dev
i ssl d
. ;w "POST "_rawURL_" HTTP/"_HTTPVersion_$c(13,10)
. s zg="POST "_rawURL_" HTTP/"_HTTPVersion_"^M"
. d gw(zg)
e d
. ;w "POST "_url_" HTTP/"_HTTPVersion_$c(13,10)
. s zg="POST "_url_" HTTP/"_HTTPVersion_"^M"
. d gw(zg)
;w "Host: "_host
s zg="Host: "_host
d gw(zg)
i port'=80 s zg=":"_port d gw(zg) ;w ":"_port
s zg=$c(13,10) d gw(zg) ;w $c(13,10)
s zg="Accept: */*"_$c(13,10) d gw(zg) ;w "Accept: */*"_"^M"
;
i $d(headerArray) d
. n n
. s n=""
. f s n=$o(headerArray(n)) q:n="" d
. . ;w headerArray(n)_$c(13,10)
. . s zg=headerArray(n)_"^M"
. . d gw(zg)
;
s mimeType=$g(mimeType)
i mimeType="" s mimeType="application/x-www-form-urlencoded"
s contentLength=0
i $d(payload) d
. n no
. s no=""
. f s no=$O(payload(no)) q:no="" D
. . s contentLength=contentLength+$l(payload(no))
. s contentLength=contentLength
. s zg="Content-Type: "_mimeType ;w "Content-Type: ",mimeType
. d gw(zg)
. i $g(charset)'="" d ;
. . ;w "; charset=""",charset,""""
. . s zg="; charset="""_charset_""""
. . d gw(zg)
. s zg="^M" d gw(zg) ;w $c(13,10)
. ;w "Content-Length: ",contentLength,$c(13,10)
. s zg="Content-Length: "_contentLength_"^M"
. d gw(zg)
;
s zg="^M" d gw(zg) ;w $c(13,10)
i $D(payload) d
. n no
. s no=""
. f s no=$O(payload(no)) q:no="" d
. . ;w payload(no)
. . s zg=payload(no)
. . d gw(zg)
;
s zg="^M" d gw(zg) ;w $c(13,10)
;w $c(13,10),! gpl- what does a bang send out????????
;
; That's the request sent !
;
;g httpResponse
;
q ""
;
gw(LINE) ; Private proc; Adds line to end of array
;
I '$D(ARY(1)) S ARY(1)=LINE
E D ;
. N CNT
. S CNT=$O(ARY(""),-1)
. S CNT=CNT+1
. S ARY(CNT)=LINE
Q
;

194
p/C0PCUR.m Normal file
View File

@ -0,0 +1,194 @@
C0PCUR ; VEN/SMH - Get current medications ; 5/8/12 9:24pm
;;1.0;C0P;;Apr 25, 2012;Build 103
;
;Copyright 2009 Sam Habiel. 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.
;
GET(C0PMEDS,C0PDFN) ; Private Proc - Get Current C0PMEDS
; Input:
; C0PMEDS by reference
; C0PDFN by Value
; Output: (modified PSOORRL output)
; C0PMEDS(D0,0): Order#_File;Pkg^Drug Name^Infusion Rate^Stop Date ^Refills Remaining^Total Dose^Units per Dose^Placer#^Status^Last Filldate^Days Supply^Qty^NOT TO BE GIVEN^Pending Renewal (1 or 0)
; C0PMEDS(D0,"DRUG"): Drug IEN
; C0PMEDS(D0,"A",0) = # of lines
; C0PMEDS(D0,"A",D1,0) = Additive Name^Amount^Bottle
; C0PMEDS(D0,"ADM",0) = # of lines
; C0PMEDS(D0,"ADM",D1,0) = Administration Times
; C0PMEDS(D0,"B",0) = # of lines
; C0PMEDS(D0,"B",D1,0) = Solution Name^Amount
; C0PMEDS(D0,"MDR",0) = # of lines
; C0PMEDS(D0,"MDR",D1,0) = Medication Route abbreviation
; C0PMEDS(D0,"P",0) = IEN^Name of Ordering Provider (#200)
; C0PMEDS(D0,"SCH",0) = # of lines
; C0PMEDS(D0,"SCH",D1,0) = Schedule Name
; C0PMEDS(D0,"SIG",0) = # of lines
; C0PMEDS(D0,"SIG",D1,0) = Sig (outpatient) or Instructions (inpatient)
; C0PMEDS(D0,"SIO",0) = # of lines
; C0PMEDS(D0,"SIO",D1,0) = Special Instructions/Other Print Info
; C0PMEDS(D0,"START"): Start Date (timson)
; added by gpl
; C0PMEDS(D0,"NVAIEN") = IEN of the drug in the NVA subfile
; C0PMEDS(D0,"COMMENTS") = First line of the comment WP field in NVA
K ^TMP("PS",$J)
N BEG,END,CTX
S (BEG,END,CTX)=""
S CTX=$$GET^XPAR("ALL","ORCH CONTEXT C0PMEDS") ; PSOORRL defaults to 120d
I CTX=";" D DEL^XPAR("USR.`"_DUZ,"ORCH CONTEXT C0PMEDS")
S CTX=$$GET^XPAR("ALL","ORCH CONTEXT C0PMEDS")
S BEG=$$DT($P(CTX,";")),END=$$DT($P(CTX,";",2))
D OCL^PSOORRL(C0PDFN,BEG,END) ;DBIA #2400
M C0PMEDS=^TMP("PS",$J)
N C0PI S C0PI="" ; THIS IS THE RETURNED LIST OF MEDS
N ZI S ZI=0 ; THIS WILL BE THE MATCHING IEN IN THE NVA MULTIPLE
F S C0PI=$O(C0PMEDS(C0PI)) Q:C0PI="" D
. K ^TMP("PS",$J) ; again
. N LSIEN S LSIEN=$P(C0PMEDS(C0PI,0),U,1) ; LIST IEN xN;O OR xR;O gpl
. D OEL^PSOORRL(C0PDFN,LSIEN)
. S C0PMEDS(C0PI,"START")=$P(^TMP("PS",$J,0),U,5) ; Start Date in fm
. S:+$G(^TMP("PS",$J,"DD",1,0)) C0PMEDS(C0PI,"DRUG")=+^(0) ; Drug IEN
. ;I '$D(GPLTEST) Q ; let me test and others still work
. ; now go look for the NVAIEN in the subfile - gpl
. ;W !,"LSIEN "_LSIEN_"C0PI "_C0PI
. I $P(LSIEN,";",1)["N" D ; only for NVA drugs
. . ;N ZI S ZI=0
. . N FOUND S FOUND=0
. . ;F Q:FOUND=1 S ZI=$O(^PS(55,C0PDFN,"NVA",ZI)) Q:+ZI=0 D ;EACH NVA
. . S ZI=$O(^PS(55,C0PDFN,"NVA",ZI)) D ; NEXT NVA IEN (MAKE SURE IT MATCHES)
. . . N ZN S ZN=$NA(^PS(55,C0PDFN,"NVA",ZI))
. . . I '$D(@ZN@(0)) Q ; BAD NVA NODE
. . . I $P(@ZN@(0),U,2)=$G(C0PMEDS(C0PI,"DRUG")) S FOUND=1 ;DRUG NUMBERS MATCH
. . . E D ; CHECK FOR FREE TEXT DRUG MATCH
. . . . N Z1 S Z1=$P($P(@ZN@(0),U,3),"|",1) ; free txt drug from NVA
. . . . N Z2 S Z2=$P(C0PMEDS(C0PI,"SIG",1,0),"|",1) ; free txt from list
. . . . I Z1=Z2 S FOUND=1
. . . I FOUND=1 D ; found the NVA subfile entry
. . . . S C0PMEDS(C0PI,"NVAIEN")=ZI ; NVA ien
. . . . ;S C0PMEDS(C0PI,"COMMENTS")=$G(@ZN@(1,1,0)) ; first line of comments
. . . . N ZC ; to store the comment wp field
. . . . N ZM S ZM=$$GET1^DIQ(55.05,ZI_","_C0PDFN,14,,"ZC")
. . . . M C0PMEDS(C0PI,"COMMENTS")=ZC ; the comments
. . . . ;N ZC S ZC=0
. . . . ;F S ZC=$G(@ZN@(1,ZC)) Q:+ZC=0 D ; pull out the comments
. . . . ;. S C0PMEDS(C0PI,"COMMENTS",ZC)=$G(@ZN@(1,ZC,0)) ;line of comment
. . . . ;M C0PMEDS(C0PI,"COMMENTS")=@ZN@(1) ; all the lines of comments
. . . E D ; ERROR .. THESE SHOULD MATCH. There is a bug.
. . . . D ERROR^C0PMAIN(",U113059007,",$ST($ST,"PLACE"),"ERX-NVA","Non-VA Meds Error") QUIT
QUIT
DT(X) ; -- Returns FM date for X
N Y,%DT S %DT="T",Y="" D:X'="" ^%DT
Q Y
;
MEDLIST(ZMLIST,ZDFN,ZPARMS,NOERX,SUMMARY) ; RETURNS THE MEDLIST FOR PATIENT DFN
; USES C0C PACKAGE ROUTINES TO PULL ALL MEDS FOR THE PATIENT
; IF NOERX=1 IT WILL FILTER OUT EPRESCRIBING MEDS FROM THE LIST
; SUMMARY IS PASSED BY NAME AND IS THE PLACE TO PUT A SUMMARY IF PROVIDED
N ZCCRT,ZCCRR
D INITXPF^C0PWS1("C0PF") ; SET FILE NUMBER AND PARAMATERS
D GETTEMP^C0CMXP("ZCCRT","CCRMEDS","C0PF")
K ^TMP("C0CRIM","VARS",ZDFN) ; KILL RIM VARIABLES TO MAKE SURE THEY ARE FRESH
I '$D(ZPARMS) S ZPARMS="MEDALL"
D SET^C0CPARMS(ZPARMS) ; SET PARAMATER TO PULL ALL MEDS
I '$D(DEBUG) S DEBUG=0
D EXTRACT^C0CMED("ZCCRT",ZDFN,"ZCCRR")
M @ZMLIST=^TMP("C0CRIM","VARS",ZDFN,"MEDS")
I $G(SUMMARY)="" Q ; NO SUMMARY NEEDED
S ZI=""
F S ZI=$O(@ZMLIST@(ZI)) Q:ZI="" D ;
. S @SUMMARY@(ZI,"MED")=$G(@ZMLIST@(ZI,"MEDPRODUCTNAMETEXT"))
. ;W @SUMMARY@(ZI,"MED")
. S @SUMMARY@(ZI,"STATUS")=$G(@ZMLIST@(ZI,"MEDSTATUSTEXT"))
. S @SUMMARY@(ZI,"CODESYSTEM")=$G(@ZMLIST@(ZI,"MEDPRODUCTNAMECODINGINGSYSTEM"))
. S @SUMMARY@(ZI,"CODE")=$G(@ZMLIST@(ZI,"MEDPRODUCTNAMECODEVALUE"))
. S @SUMMARY@(ZI,"COMMENT")=$G(@ZMLIST@(ZI,"MEDFULLFILLMENTINSTRUCTIONS"))
Q
;
ANALYZE(ZSTR,ZNUM) ; ANALYZE MED LISTS FOR ZNUM PATIENTS STARTING AT
; PATIENT ZSTR. IF ZSTR="" START WHERE WE LEFT OFF
; FIRST TIME, START WITH THE FIRST PATIENT
N C0PZI
I ZSTR="" D ; WANT TO START WHERE WE LEFT OFF OR AT THE FIRST PATIENT
. S C0PZI=$G(^TMP("C0PAMED","LAST"))
. I C0PZI="" S C0PZI=0
. S C0PZI=$O(^DPT(C0PZI)) ; FIRST PATIENT TO DO
E S C0PZI=ZSTR ; STARTING PATIENT IS SPECIFIED
N SUMM
N ZN S ZN=0
N DONE S DONE=0
F ZN=1:1:ZNUM Q:DONE D ; TRY AND DO ZNUM PATIENTS
. W !,"C0PZI=",C0PZI
. I +C0PZI=0 S DONE=1 Q ; OUT OF PATIENTS
. S SUMM=$NA(^TMP("C0PAMED",C0PZI)) ; PLACE TO PUT SUMMARY
. W "SUMM ",SUMM
. K G ; MED LIST RETURN VARIABLE
. D MEDLIST("G",C0PZI,"MEDACTIVE",,SUMM) ; PULL THE MEDS FOR THIS PATIENT
. S ^TMP("C0PAMED","LAST")=C0PZI ; SAVE WHERE WE ARE
. S C0PZI=$O(^DPT(C0PZI)) ; NEXT PATIENT
Q
;
RESET ; CLEAR OUT THE ANALYZE ARRAY
K ^TMP("C0PAMED")
Q
;
INDEX ; INDEX THE ANALYSES
N ZI,ZJ
S (ZI,ZJ)=""
F S ZI=$O(^TMP("C0PAMED",ZI)) Q:ZI="" D ;
. S ZJ=""
. F S ZJ=$O(^TMP("C0PAMED",ZI,ZJ)) Q:ZJ="" D ;
. . N ZMED
. . S ZMED=$G(^TMP("C0PAMED",ZI,ZJ,"MED"))
. . I ZMED'="" S ^TMP("C0PAMED","MED",ZMED,ZI)=""
. . N ZCODE
. . S ZCODE=$G(^TMP("C0PAMED",ZI,ZJ,"CODE"))
. . I ZCODE'="" S ^TMP("C0PAMED","CODE",ZCODE,ZI)=""
D COUNT
Q
;
COUNT ; COUNT THE MEDS AND THE CODES
N ZI,ZN S ZN=0
S ZI=""
F S ZI=$O(^TMP("C0PAMED","MED",ZI)) Q:ZI="" D ;
. S ZN=ZN+1
W !,"MED COUNT: ",ZN
S ZN=0
S ZI=""
F S ZI=$O(^TMP("C0PAMED","CODE",ZI)) Q:ZI="" D ;
. S ZN=ZN+1
W !,"CODE COUNT: ",ZN
Q
;
; NB: EP below not used in C0P 1.0 --smh 5/9/2012
OUTSIDE(ZRTN,ZMEDS) ; WRAP THE MEDS IN THE OUTSIDEPRESRIPTION XML
; Here's what the xml looks like. It's stored in the Template field
; of the OUTSIDEPRESCRIPTION record in file C0P XML TEMPLATE file
;<OutsidePrescription>
; <externalId>@@PRESCRIPTIONID@@</externalId>
; <date>@@MEDDATE@@</date>
; <doctorName>@@DOCTORNAME@@</doctorName>
; <drug>@@MEDTEXT@@</drug>
; <dispenseNumber>@@DISPENSENUMBER@@</dispenseNumber>
; <sig>@@SIG@@</sig>
; <refillCount>@@REFILLCOUNT@@</refillCount>
; <prescriptionType>@@PRESCRIPTIONTYPE@@</prescriptionType>
;</OutsidePrescription>
N C0PZI,ZTEMP,C0PF
S C0PZI=""
D INITXPF^C0PWS1("C0PF") ; SET UP FILE POINTERS
D GETTEMP^C0CMXP("ZTEMP","OUTSIDEPRESCRIPTION","C0PF")
; BREAK
Q

164
p/C0PEREW.m Normal file
View File

@ -0,0 +1,164 @@
C0PEREW ; eRx/GPL - ePrescription ewd utilities; 1/3/11
;;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
;
test1(sessid) ;
d setSessionValue^%zewdAPI("testing","ZZ",sessid)
q 0
;
cbTestMethod(prefix,seedValue,lastSeedValue,optionNo,options)
;
n maxNo,noFound,dfn,dob,sex
;
s maxNo=50
s noFound=0
f s seedValue=$o(^DPT("B",seedValue)) q:seedValue="" q:noFound=maxNo d
. s lastSeedValue=seedValue
. i prefix'="",$e(seedValue,1,$l(prefix))'=prefix q
. s optionNo=optionNo+1
. s noFound=noFound+1
. s options(optionNo)=seedValue
. s dfn=$o(^DPT("B",seedValue,"")) ; dfn of the patient
. s dob=$$GET1^DIQ(2,dfn,.03) ; date of birth
. s sex=$$GET1^DIQ(2,dfn,.02,"I") ; sex M or F
. s options(optionNo)=seedValue_" "_dob_" "_sex ; complete patient
QUIT
;
set1 ;
s ^zewd("comboPlus","methodMap","test")="cbTestMethod^C0PEREW"
; THIS THE SHELL SCRIPT WHICH CREATED THE EWD PAGES IN THE C0P NAMESPACE
;cp ../w/ewdWLerxewdajaxerror.m C0PE001.m
;cp ../w/ewdWLerxewdajaxerrorredirect.m C0PE002.m
;cp ../w/ewdWLerxewderrorredirect.m C0PE003.m
;cp ../w/ewdWLerxindex1.m C0PE004.m
;cp ../w/ewdWLerxmatch.m C0PE005.m
;cp ../w/ewdWLerxnomatch.m C0PE006.m
; WE NEED TO ADD THIS CONFIGURATION ONE TIME TO ^zewd
;s ^zewd("routineMap","eRx","ewdajaxerror")="C0PE001"
;s ^zewd("routineMap","eRx","ewdajaxerrorredirect")="C0PE002"
;s ^zewd("routineMap","eRx","ewderrorredirect")="C0PE003"
;s ^zewd("routineMap","eRx","index1")="C0PE004"
;s ^zewd("routineMap","eRx","match")="C0PE005"
;s ^zewd("routineMap","eRx","nomatch")="C0PE006"
; unfortunately, the global map doesn't really work for now.. but
; we will keep trying in future releases
q
;
INITSES(sessid) ; INITIALIZE AN EWD SESSION BY PULLING "VISTA" VARIABLES
; INTO THE SESSION FROM WHERE THEY HAVE BEEN STORED. THEY ARE INDEXED
; BY A UNIQUE RANDOM TOKEN WHICH IS PASSED WITH THE URL
; FOR EXAMPLE https//example.com/ewd/myApp/index.ewd?token="12345"
N ZTOKEN,C0EARY
S ZTOKEN=$$URLTOKEN^C0CEWD(sessid) ; get the token passed on the url
D GET^C0CEWD("C0EARY",ZTOKEN,1) ; GET THE ARRAY OF VALUES
S C0EARY("TOKEN")=ZTOKEN
M ^TMP("GPL")=C0EARY
d mergeArrayToSession^%zewdAPI(.C0EARY,"VistA",sessid)
; ALL VISTA VARIABLES ARE IN THE "VistA" section of the session
Q
;
INITREW(sessid) ; initialze the eRx Renewal Patient Matching screen
;
N C0PSES,ZDJ,ZDOB,ZSEX
D INITSES(sessid) ; add the VistA Variables to the session
D mergeArrayFromSession^%zewdAPI(.C0PSES,"VistA",sessid) ; get them back
N ZNAME,ZMED,ZSV
S ZNAME=$G(C0PSES("C0PRenewalName"))
I ZNAME="" Q "" ;OOPS
S ZDOB=$G(C0PSES("RenewalDOB")) ; date of birth
I ZDOB'="" S ZDOB=$E(ZDOB,5,6)_"/"_$E(ZDOB,7,8)_"/"_$E(ZDOB,1,4) ; REFORMAT
d setSessionValue^%zewdAPI("RenewalDOB",ZDOB,sessid) ; save in session
S ZSEX=$G(C0PSES("RenewalSex")) ; gender
d setSessionValue^%zewdAPI("RenewalSex",ZSEX,sessid) ; save in session
s ZNAME=ZNAME_" "_ZDOB_" "_ZSEX ; ADD DOB AND SEX TO PATIENT NAME
d setSessionValue^%zewdAPI("C0PRenewalName",ZNAME,sessid) ;the whole name
d setSessionValue^%zewdAPI("pat4",$e(ZNAME,1,4),sessid) ;first part of name
S ZMED=$G(C0PSES("medication")) ; pull med from VistA part of session
d setSessionValue^%zewdAPI("medication",ZMED,sessid) ;the med
S ZDJ=$G(C0PSES("dollarJ")) ; job number of CPRS session
d setSessionValue^%zewdAPI("CPRSdollarJ",ZDJ,sessid) ; save in the session
S ZSV=$G(C0PSES("SUPERVISING-DUZ")) ; supervising doctor DUZ
d setSessionValue^%zewdAPI("supervisor",ZSV,sessid) ; save
d clearList^%zewdAPI("supervisor",sessid) ; make sure no list is there
M DUZ=C0PSES("DUZ") ; PASS LOG ON AUTHORITY
n svlist ; list of licensed prescribers
d SVLIST("svlist") ; generate the list
n zi,zn
s zi=""
f s zi=$o(svlist(zi)) q:zi="" d ; for each licensed prescriber
. s zn=$o(svlist(zi,"")) ; DUZ of prescriber
. d appendToList^%zewdAPI("supervisor",zi,zn,sessid) ;add to list
Q ""
;
MATCH(sessid) ; process submit after matching
S ^TMP("GPL","MATCH",sessid)=""
N ZRTN,ZNAME,ZDFN
S ZNAME=$$getSessionValue^%zewdAPI("patient",sessid) ; current match
S ZNAME=$P(ZNAME," ",1) ; GET JUST THE NAME - NOT DOB OR SEX
S ZDFN=$O(^DPT("B",ZNAME,""))
S ZRTN=""
I ZDFN="" S ZRTN="Please select a patient"
D setSessionValue^%zewdAPI("selectedDFN",ZDFN,sessid) ; record selection
Q ZRTN
;
NOMATCH(sessid) ; process submit after matching
S ^TMP("GPL","NOMATCH",sessid)=""
Q ""
;
MTCHPG(sessid) ; process the match clickthrough page
N GDFN,ZDJ
S GDFN=$$getSessionValue^%zewdAPI("selectedDFN",sessid) ; THE PATIENT SELECTED
S ZDJ=$$getSessionValue^%zewdAPI("CPRSdollarJ",sessid) ; CPRS job number
S ^TMP("C0E",ZDJ,"NEWDFN")=GDFN ; PASS THE NEW DFN TO CPRS
D BRSRDR(GDFN,sessid) ; GENERATE THE RENEWAL BROWSER REDIRECT PAGE
Q ""
;
NOMTCHPG(sessid) ; process the nomatch clickthrough page
D BRSRDR(0,sessid) ; BOTH MATCH AND NOMATCH DO THE SAME THING FOR NOW
Q ""
;
BRSRDR(ZDFN,sessid) ; GENERATE RENEWAL BROWSER REDIRCT HTML/XML TO CLICK THRU
; TO ERX RENEWAL
N ZISTR,ZDUZ,ZHTML,C0PSES
D mergeArrayFromSession^%zewdAPI(.C0PSES,"VistA",sessid) ; get SESSION VARS
S ZDUZ=$G(C0PSES("DUZ"))
M DUZ=C0PSES("DUZ") ; PASS LOG ON AUTHORITY
S ZISTR=$G(C0PSES("renewalToken"))
S C0PSPRV=$$getSessionValue^%zewdAPI("supervisor",sessid) ;supervisor selected
I C0PSPRV="" S C0PSVRV=$G(C0PSES("SUPERVISOR-DUZ")) ; SUPERVISING DOCTOR DUZ
D ALERTRPC^C0PCPRS1(.ZHTML,ZDUZ,ZDFN,1,ZISTR,1) ; CALL WITH MODE=1
d mergeArrayToSession^%zewdAPI(.ZHTML,"eRxRenew",sessid)
Q
;
SVLIST(ZLIST) ; GENERATE A LIST OF LICENSED PRESCRIBERS FOR THE
; MIDLEVEL SUPERVISING DOCTOR PULLDOWN; ZLIST IS PASSED BY NAME
N ZI,ZA
S ZA=$NA(^VA(200,"C0P","ERX")) ; INDEX TO USE
S ZI=""
F S ZI=$O(@ZA@(ZI)) Q:ZI="" D ; FOR EACH SUBSCRIBER
. N ZS
. D SETACCT^C0PSUB("ZS",ZI) ; GET SUBSCRIPTION INFO
. I $G(ZS("SUBSCRIBER-USERTYPE"))="LicensedPrescriber" D ; USE IT
. . N ZN
. . S ZN=$$GET1^DIQ(200,ZI,.01,"E") ; NAME OF SUBSCRIBER
. . S @ZLIST@(ZN,ZI)="" ; RETURN THIS SUBSCRIBER
. K ZS
Q
;

192
p/C0PEWD1.m
View File

@ -1,90 +1,102 @@
C0PEWD1 ; CCDCCR/GPL - ePrescription utilities; 12/6/08
;;0.1;CCDCCR;nopatch;noreleasedate
;Copyright 2008 WorldVistA. 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(filepath) ; filepath IS THE PATH/FILE TO BE READ IN
i $g(^%ZISH)["" d ; if the VistA Kernal routine %ZISH exists
. n zfile,zpath,ztmp s (zfile,zpath,ztmp)=""
. s zfile=$re($p($re(filepath),"/",1)) ;file name
. s zpath=$p(filepath,zfile,1) ; file path
. s ztmp=$na(^CacheTempEWD($j,0))
. s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2
q
;
TEST2 ;
s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml"
;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath)
s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global
s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0)
;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM")
w ok,!
q
;
GPLTEST ;
;s ok=$$httpGET^%zewdGTM("http://preproduction.newcropaccounts.com/InterfaceV7/NewrxFDB.xml",.gpl)
s URL="https://trac.opensourcevista.net/CCD-CCR-Project/browser/ccr/tags/CCR_1_0_7/output"
s ok=$$httpGET^%zewdGTM(URL,.gpl)
S ZG=""
F S ZG=$O(gpl(ZG)) Q:ZG="" D ;
. s gpl(ZG)=$$CLEAN^C0PEWDU(gpl(ZG)) ;
. ;w gpl(ZG)
m ^CacheTempEWD($j)=gpl
b
s ok=$$parseDocument^%zewdHTMLParser("gpl2",0)
s ok=$$outputDOM^%zewdDOM("gpl2",1,1)
Q
;
GPLTEST2 ;
s URL="https://preproduction.newcropaccounts.com/InterfaceV7/NewrxFDB.xml"
;s URL="https://trac.opensourcevista.net/CCD-CCR-Project/browser/ccr/tags/CCR_1_0_7/output"
s ok=$$httpGET^%zewdGTM(URL,.gpl)
D INDEX^C0CXPATH("gpl","gpl2")
S G=""
F S G=$O(gpl2(G)) Q:G="" D ;
. W !,G," = ",gpl2(G)
W !
Q
;
CLEAN(INX) ;DELETE NON-PRINTING CHARACTER IN INX, PASSED BY VALUE
;DON'T USE THIS -- IT DOESN'T WORK -- USE $$CLEAN^C0PEWDU
;N ZT,ZI
S ZT=""
F ZI=32:1:126 S ZT=ZT_$CHAR(ZI)
S ZZ=$TR(INX,ZT)
Q ZZ
;
LOAD(filepath) ; load an xml file into the EWD global for DOM processing
; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML)
; after to process it to the DOM - isHTML=0 for XML files
n i
i $g(^%ZISH)["" d QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09
. n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)=""
. s zfile=$re($p($re(filepath),"/",1)) ;file name
. s zpath=$p(filepath,zfile,1) ; file path
. s ztmp=$na(^CacheTempEWD($j,0))
. s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2
. s i=$o(^CacheTempEWD($j,""),-1) ; highest line number
q i
;
Q(ZQ,ZD) ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED
I '$D(ZD) S ZD="DerekDOM"
s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ;
d displayNodes^%zewdXPath(.nodes)
q
;
C0PEWD1 ; CCDCCR/GPL - ePrescription utilities; 12/6/08 ; 5/8/12 3:57pm
;;1.0;C0P;;Apr 25, 2012;Build 103
;Copyright 2008 WorldVistA. 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
; THE FOLLOWING ROUTINES ARE EXPERIMENTS USED TO TEST HTTP CALLS FROM
; MUMPS USING EWD. NONE OF THE ROUTINES ARE USED FOR PROCESSING IN THE
; ERX PACKAGE. THEY ARE INCLUDED AND BROUGHT FORWARD FOR USE IN DEBUGGING
; AND FUTURE DEVELOPMENT
; GPL JUN 2010
;
;TEST(filepath) ; filepath IS THE PATH/FILE TO BE READ IN
i $g(^%ZISH)["" d ; if the VistA Kernal routine %ZISH exists
. n zfile,zpath,ztmp s (zfile,zpath,ztmp)=""
. s zfile=$re($p($re(filepath),"/",1)) ;file name
. s zpath=$p(filepath,zfile,1) ; file path
. s ztmp=$na(^CacheTempEWD($j,0))
. s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2
q
;
TEST2 ;
s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml"
;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath)
s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global
s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0)
;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM")
w ok,!
q
;
GPLTEST ;
;s ok=$$httpGET^%zewdGTM("http://preproduction.newcropaccounts.com/InterfaceV7/NewrxFDB.xml",.gpl)
s URL="https://trac.opensourcevista.net/CCD-CCR-Project/browser/ccr/tags/CCR_1_0_7/output"
s ok=$$httpGET^%zewdGTM(URL,.gpl)
S ZG=""
F S ZG=$O(gpl(ZG)) Q:ZG="" D ;
. s gpl(ZG)=$$CLEAN^C0PEWDU(gpl(ZG)) ;
. ;w gpl(ZG)
m ^CacheTempEWD($j)=gpl
; b
s ok=$$parseDocument^%zewdHTMLParser("gpl2",0)
s ok=$$outputDOM^%zewdDOM("gpl2",1,1)
Q
;
GPLTEST2 ;
s URL="https://preproduction.newcropaccounts.com/InterfaceV7/NewrxFDB.xml"
;s URL="https://trac.opensourcevista.net/CCD-CCR-Project/browser/ccr/tags/CCR_1_0_7/output"
s ok=$$httpGET^%zewdGTM(URL,.gpl)
D INDEX^C0CXPATH("gpl","gpl2")
S G=""
F S G=$O(gpl2(G)) Q:G="" D ;
. W !,G," = ",gpl2(G)
W !
Q
;
CLEAN(INX) ;DELETE NON-PRINTING CHARACTER IN INX, PASSED BY VALUE
;DON'T USE THIS -- IT DOESN'T WORK -- USE $$CLEAN^C0PEWDU
;N ZT,ZI
S ZT=""
F ZI=32:1:126 S ZT=ZT_$CHAR(ZI)
S ZZ=$TR(INX,ZT)
Q ZZ
;
LOAD(filepath) ; load an xml file into the EWD global for DOM processing
; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML)
; after to process it to the DOM - isHTML=0 for XML files
n i
i $g(^%ZISH)["" d QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09
. n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)=""
. s zfile=$re($p($re(filepath),"/",1)) ;file name
. s zpath=$p(filepath,zfile,1) ; file path
. s ztmp=$na(^CacheTempEWD($j,0))
. s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2
. s i=$o(^CacheTempEWD($j,""),-1) ; highest line number
q i
;
Q(ZQ,ZD) ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED
I '$D(ZD) S ZD="DerekDOM"
s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ;
d displayNodes^%zewdXPath(.nodes)
q
;
TEST1
S url="https://ec2-75-101-247-83.compute-1.amazonaws.com:8181/ccr/CCRService?wsdl"
;S url="http://ec2-75-101-247-83.compute-1.amazonaws.com"
D GET1URL^C0PEWD2(url)
Q
;

245
p/C0PEWD2.m
View File

@ -1,51 +1,194 @@
C0PEWD2 ; CCDCCR/GPL - ePrescription utilities; 4/24/09
;;0.1;CCDCCR;nopatch;noreleasedate
;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 ;
s URL="https://preproduction.newcropaccounts.com/InterfaceV7/NewrxFDB.xml"
D GET1URL(URL) ;
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NCScript-RegisterLP.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/GenTestRenewalFDB.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NewrxFDB.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NewrxRxNorm.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NewrxExternalDrugOpt1.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NewrxExternalDrugOpt2.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/RenewalResponseAccept.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/RenewalResponseDeny.xml"
D GET1URL(URL)
Q
;
GET1URL(URL) ;
s ok=$$httpGET^%zewdGTM(URL,.gpl)
D INDEX^C0CXPATH("gpl","gpl2")
W !,"S URL=""",URL,"""",!
S G=""
F S G=$O(gpl2(G)) Q:G="" D ;
. W " S VDX(""",G,""")=""",gpl2(G),"""",!
W !
Q
;
C0PEWD2 ; CCDCCR/GPL - ePrescription utilities; 4/24/09 ; 5/8/12 10:22pm
;;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.
gpltest3 ; (zduz,zdfn) ; experiment with passing parameters from trigger
;W "<br><b>SESSIONID:",zduz,"</b><br><hr>"
W "<b>eRx</b> pullback trigger processing prototype<hr>",!
I $D(req4) ZWRITE req4
w "<hr>"
W "XID=",$G(req4("XID",1)),"<br>"
W "DFN=",$G(req4("DFN",1)),"<br>"
w "DUZ=",$G(req4("DUZ",1)),"<hr>"
s DFN=$G(req4("DFN",1))
D PSEUDO ; FAKE LOGIN
D XPAT^C0CCCR(DFN,"MEDALL")
W "<br>"
;D XPAT^C0CCCR(DFN)
W "<a href=""http://hollywood/dev/CCR/PAT_"_DFN_"_CCR_V1_0_0.xml"" target=""CCR"">Display CCR</a>"
;D RIM2RNF^C0CRIMA("GPL",DFN,"ALERTS")
;D RNF2HVN^C0CRNF("G1","GPL")
;D PARY^C0CXPATH("G1",-1)
F ZG="ALERTS","MEDS","PROCEDURES" D ;
. N GPL,G2
. W "<hr>"
. W "<b>Current CCR "_ZG_"</b><br>",!
. D RIM2RNF^C0CRIMA("GPL",DFN,ZG)
. D RNF2HNV^C0CRNF("G2","GPL")
. D PARY^C0CXPATH("G2",-1)
Q
;
PSEUDO ; FAKE LOGIN SETS SOME LOCAL VARIABLE TO FOOL FILEMAN
S DILOCKTM=3
S DISYS=19
S DT=3100112
S DTIME=9999
S DUZ=135
S DUZ(0)=""
S DUZ(1)=""
S DUZ(2)=67
S DUZ("AG")="E"
S DUZ("BUF")=1
S DUZ("LANG")=1
;S IO="/dev/pts/0"
;S IO(0)="/dev/pts/0"
;S IO(1,"/dev/pts/0")=""
;S IO("ERROR")=""
;S IO("HOME")="50^/dev/pts/0"
;S IO("ZIO")="/dev/pts/0"
;S IOBS="$C(8)"
;S IOF="!!!!!!!!!!!!!!!!!!!!!!!!,#,$C(27,91,50,74,27,91,72)"
;S IOM=80
;S ION="GTM/UNIX TELNET"
;S IOS=50
;S IOSL=24
;S IOST="C-VT100"
;S IOST(0)=9
;S IOT="VTRM"
;S IOXY="W $C(27,91)_((DY+1))_$C(59)_((DX+1))_$C(72)"
S U="^"
S X="1;DIC(4.2,"
S XPARSYS="1;DIC(4.2,"
S XQXFLG="^^XUP"
S Y="DEV^VISTA^hollywood^VISTA:hollywood"
Q
;
gpltest2(zduz,zdfn) ; experiment with passing parameters from trigger
W "<br><b>SESSIONID:",zduz,"</b><br><hr>"
W "HELLO WORLD<hr>",!
I $D(req4) ZWRITE req4
w "<hr>"
W "DFN=",$G(req4("DFN",1)),"<br>"
w "DUZ=",$G(req4("DUZ",1)),"<hr>"
;ZWR
Q
;
gpltest(GPLV1) ; experiment with sending a CCR to an ewd page
N ZI
S ZI=""
;W "HELLO WORLD!",!
;Q
F S ZI=$O(^GPL(ZI)) Q:ZI="" W ^GPL(ZI),!
Q
;
TESTSSL ;
s URL="https://preproduction.newcropaccounts.com/InterfaceV7/NewrxFDB.xml"
D GET1URL(URL) ;
Q
;
TEST2 ;
; httpPOST(url,payload,mimeType,html,headerArray,timeout,test,rawResponse,respHeaders,sslHost,sslPort)
;
s URL="http://preproduction.newcropaccounts.com/InterfaceV7/Doctor.xml"
D GET1URL(URL) ;
s gpl4(2)="<NCScript xmlns=""http://secure.newcropaccounts.com/interfaceV7"""
s g1="xmlns:NCStandard="
s g2="""http://secure.newcropaccounts.com/interfaceV7:NCStandard"""
s gpl4(2)=gpl4(2)_" "_g1_g2
s gpl4(2)=gpl4(2)_" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"">"
k gpl4(0) ; array size node
s gpl4(3)="<Account ID=""demo"">"
s gpl4(40)="<Location ID=""DEMOLOC1"">"
s gpl4(28)="<LicensedPrescriber ID=""DEMOLP1"">"
s gpl4(55)="<Patient ID=""DEMOPT1"">"
W $$OUTPUT^C0CXPATH("gpl4(1)","NewCropV7-DOCTOR.xml","/home/dev/CCR/"),!
S ok=$$httpPOST^%zewdGTM("https://preproduction.newcropaccounts.com/InterfaceV7/RxEntry.aspx",.gpl4,"Content-Type: text/html",.gpl6,"","",.gpl5,.gpl7)
ZWRITE gpl6
q
;
TEST3 ;
; httpPOST(url,payload,mimeType,html,headerArray,timeout,test,rawResponse,respHeaders,sslHost,sslPort)
;
s URL="http://preproduction.newcropaccounts.com/InterfaceV7/Doctor.xml"
D GET1URL(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))
K gpl(0)
S gpl(1)="RxInput="_gpl(1)
S url="https://preproduction.newcropaccounts.com/InterfaceV7/RxEntry.aspx"
W $$OUTPUT^C0CXPATH("gpl(1)","NewCropV7-DOCTOR2.xml","/home/dev/CCR/"),!
; S ok=$$httpPOST^%zewdGTM("https://preproduction.newcropaccounts.com/InterfaceV7/RxEntry.aspx",.gpl,"application/x-www-form-urlencoded",.gpl6,"","",.gpl5,.gpl7)
S ok=$$httpPOST^%zewdGTM("https://preproduction.newcropaccounts.com/InterfaceV7/ComposeRX.aspx",.gpl,"application/x-www-form-urlencoded",.gpl6,"","",.gpl5,.gpl7)
ZWRITE gpl6
q
;
TEST ;
;s URL="https://preproduction.newcropaccounts.com/InterfaceV7/NewrxFDB.xml"
; D GET1URL(URL) ;
;Q
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NCScript-RegisterLP.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/GenTestRenewalFDB.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NewrxFDB.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NewrxRxNorm.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NewrxExternalDrugOpt1.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NewrxExternalDrugOpt2.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/RenewalResponseAccept.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/RenewalResponseDeny.xml"
D GET1URL(URL)
Q
;
GET1URL0(URL) ;
s ok=$$httpGET^%zewdGTM(URL,.gpl)
D INDEX^C0CXPATH("gpl","gpl2")
W !,"S URL=""",URL,"""",!
S G=""
F S G=$O(gpl2(G)) Q:G="" D ;
. W " S VDX(""",G,""")=""",gpl2(G),"""",!
W !
Q
;
GET1URL(URL) ;
s ok=$$httpGET^%zewdGTM(URL,.gpl)
W "XML retrieved from Web Service:",!
ZWRITE gpl
D INDEX^C0CXPATH("gpl","gpl2",-1,"gplTEMP")
W "VDX array displayed as a prototype Mumps routine:",!
W !,"S URL=""",URL,"""",!
S G=""
F S G=$O(gpl2(G)) Q:G="" D ;
. W " S VDX(""",G,""")=""",gpl2(G),"""",!
W !
D VDX2XPG^C0CXPATH("gpl3","gpl2")
W "Conversion of VDX array to XPG format:",!
ZWRITE gpl3
W "Conversion of XPG array to XML:",!
D XPG2XML^C0CXPATH("gpl4","gpl3")
ZWRITE gpl4
Q
;

33
p/C0PEWD3.m Normal file
View File

File diff suppressed because one or more lines are too long

123
p/C0PEWD4.m Normal file
View File

@ -0,0 +1,123 @@
C0PEWD4 ; CCDCCR/GPL - ePrescription utilities; 4/24/09 ; 5/8/12 10:23pm
;;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.
gpltest ; experiment with sending a CCR to an ewd page
N ZI
S ZI=""
W "HELLO WORLD!",!
Q 1
F S ZI=$O(^GPL(ZI)) Q:ZI="" W ^GPL(ZI)
Q
;
TESTSSL ;
s URL="https://preproduction.newcropaccounts.com/InterfaceV7/NewrxFDB.xml"
D GET1URL(URL) ;
Q
;
TEST2 ;
; httpPOST(url,payload,mimeType,html,headerArray,timeout,test,rawResponse,respHeaders,sslHost,sslPort)
;
s URL="http://preproduction.newcropaccounts.com/InterfaceV7/Doctor.xml"
D GET1URL(URL) ;
s gpl4(2)="<NCScript xmlns=""http://secure.newcropaccounts.com/interfaceV7"""
s g1="xmlns:NCStandard="
s g2="""http://secure.newcropaccounts.com/interfaceV7:NCStandard"""
s gpl4(2)=gpl4(2)_" "_g1_g2
s gpl4(2)=gpl4(2)_" xmlns:xsi=""http://www.w3.org/2001/XMLSchema-instance"">"
k gpl4(0) ; array size node
s gpl4(3)="<Account ID=""demo"">"
s gpl4(40)="<Location ID=""DEMOLOC1"">"
s gpl4(28)="<LicensedPrescriber ID=""DEMOLP1"">"
s gpl4(55)="<Patient ID=""DEMOPT1"">"
W $$OUTPUT^C0CXPATH("gpl4(1)","NewCropV7-DOCTOR.xml","/home/dev/CCR/"),!
S ok=$$httpPOST^%zewdGTM("https://preproduction.newcropaccounts.com/InterfaceV7/RxEntry.aspx",.gpl4,"Content-Type: text/html",.gpl6,"","",.gpl5,.gpl7)
ZWRITE gpl6
q
;
TEST3 ;
; httpPOST(url,payload,mimeType,html,headerArray,timeout,test,rawResponse,respHeaders,sslHost,sslPort)
;
s URL="http://preproduction.newcropaccounts.com/InterfaceV7/Doctor.xml"
D GET1URL(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))
K gpl(0)
S gpl(1)="RxInput="_gpl(1)
S url="https://preproduction.newcropaccounts.com/InterfaceV7/RxEntry.aspx"
W $$OUTPUT^C0CXPATH("gpl(1)","NewCropV7-DOCTOR2.xml","/home/dev/CCR/"),!
; S ok=$$httpPOST^%zewdGTM("https://preproduction.newcropaccounts.com/InterfaceV7/RxEntry.aspx",.gpl,"application/x-www-form-urlencoded",.gpl6,"","",.gpl5,.gpl7)
S ok=$$httpPOST^%zewdGTM("https://preproduction.newcropaccounts.com/InterfaceV7/ComposeRX.aspx",.gpl,"application/x-www-form-urlencoded",.gpl6,"","",.gpl5,.gpl7)
ZWRITE gpl6
q
;
TEST ;
;s URL="https://preproduction.newcropaccounts.com/InterfaceV7/NewrxFDB.xml"
; D GET1URL(URL) ;
;Q
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NCScript-RegisterLP.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/GenTestRenewalFDB.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NewrxFDB.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NewrxRxNorm.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NewrxExternalDrugOpt1.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/NewrxExternalDrugOpt2.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/RenewalResponseAccept.xml"
D GET1URL(URL)
S URL="http://preproduction.newcropaccounts.com/InterfaceV7/RenewalResponseDeny.xml"
D GET1URL(URL)
Q
;
GET1URL0(URL) ;
s ok=$$httpGET^%zewdGTM(URL,.gpl)
D INDEX^C0CXPATH("gpl","gpl2")
W !,"S URL=""",URL,"""",!
S G=""
F S G=$O(gpl2(G)) Q:G="" D ;
. W " S VDX(""",G,""")=""",gpl2(G),"""",!
W !
Q
;
GET1URL(URL) ;
s ok=$$httpGET^%zewdGTM(URL,.gpl)
W "XML retrieved from Web Service:",!
ZWRITE gpl
D INDEX^C0CXPATH("gpl","gpl2",-1,"gplTEMP")
W "VDX array displayed as a prototype Mumps routine:",!
W !,"S URL=""",URL,"""",!
S G=""
F S G=$O(gpl2(G)) Q:G="" D ;
. W " S VDX(""",G,""")=""",gpl2(G),"""",!
W !
D VDX2XPG^C0CXPATH("gpl3","gpl2")
W "Conversion of VDX array to XPG format:",!
ZWRITE gpl3
W "Conversion of XPG array to XML:",!
D XPG2XML^C0CXPATH("gpl4","gpl3")
ZWRITE gpl4
Q
;

85
p/C0PEWDU.m
View File

@ -1,34 +1,51 @@
C0PEWDU ; WV/SMH - E-prescription utilities; Mar 3 2009
;;0.1;WV EPrescribing;;
Q
;
CLEAN(STR) ; extrinsic function; returns string
;; Removes all non printable characters from a string.
;; STR by Value
N TR,I
F I=0:1:31 S TR=$G(TR)_$C(I)
S TR=TR_$C(127)
QUIT $TR(STR,TR)
;
GETSOAP(ENTRY,REQUEST,RESULT) ; XML SOAP Spec for NewCrop
;; Gets world processing field from Fileman for Parsing
;; ENTRY Input by Value
;; REQUEST XML Output by Reference
;; RESULT XML Output by Reference
;; Example call: D GETSOAP^C0PEWDU("DrugAllergyInteraction",.REQ,.RES)
;
N OK,ERR,IEN,F ; if call is okay, Error, IEN, File
S F=175.101
S IEN=$$FIND1^DIC(F,"","",ENTRY,"B")
S OK=$$GET1^DIQ(F,IEN,2,"","REQUEST","ERR")
I OK=""!($D(ERR)) S REQUEST=""
; M ^CacheTempEWD($j)=REQUEST
; K REQUEST
; S ok=$$parseDocument^%zewdHTMLParser("REQUEST",0)
; S ok=$$outputDOM^%zewdDOM("REQUEST",1,1)
; Q ; remove later
K OK,ERR
S OK=$$GET1^DIQ(F,IEN,3,"","RESULT","ERR")
I OK=""!($D(ERR)) S RESULT=""
QUIT
;
C0PEWDU ; WV/SMH - E-prescription utilities; Mar 3 2009 ; 5/4/12 4:25pm
;;1.0;C0P;;Apr 25, 2012;Build 103
;Copyright 2009 Sam Habiel. 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
;
CLEAN(STR) ; extrinsic function; returns string
;; Removes all non printable characters from a string.
;; STR by Value
N TR,I
F I=0:1:31 S TR=$G(TR)_$C(I)
S TR=TR_$C(127)
QUIT $TR(STR,TR)
;
GETSOAP(ENTRY,REQUEST,RESULT) ; XML SOAP Spec for NewCrop
;; Gets world processing field from Fileman for Parsing
;; ENTRY Input by Value
;; REQUEST XML Output by Reference
;; RESULT XML Output by Reference
;; Example call: D GETSOAP^C0PEWDU("DrugAllergyInteraction",.REQ,.RES)
;
N OK,ERR,IEN,F ; if call is okay, Error, IEN, File
S F=175.101
S IEN=$$FIND1^DIC(F,"","",ENTRY,"B")
S OK=$$GET1^DIQ(F,IEN,2,"","REQUEST","ERR")
I OK=""!($D(ERR)) S REQUEST=""
; M ^CacheTempEWD($j)=REQUEST
; K REQUEST
; S ok=$$parseDocument^%zewdHTMLParser("REQUEST",0)
; S ok=$$outputDOM^%zewdDOM("REQUEST",1,1)
; Q ; remove later
K OK,ERR
S OK=$$GET1^DIQ(F,IEN,3,"","RESULT","ERR")
I OK=""!($D(ERR)) S RESULT=""
QUIT
;

349
p/C0PKIDS.m Normal file
View File

@ -0,0 +1,349 @@
C0PKIDS ; VEN/SMH - eRx KIDS Utilities ; 5/4/12 4:26pm
;;1.0;C0P;;Apr 25, 2012;Build 7
; (C) Sam Habiel 2012
; Licensed under GPL.
;
;Copyright 2012 Sam Habiel. 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.
;
; This routine contains utilities for KIDS distribution of E-Rx.
;
; PEPs:
; For RxNorm dist: RXNTRAN,RXNPOST
; For FDB files: FDBTRAN,FDBPOST
;
;
ENV ; Environment Check
; If EWD version is less than 800, don't install
I $$TRIM^XLFSTR($G(^%zewd("version")))<800 DO QUIT
. W "A recent version of EWD must be installed before installing ",!
. W "e-Prescribing. Installation cannot continue.",!
. S XPDQUIT=1
; Check if C0C 1.1 is installed
QUIT
POST ; Main Post Installation routine
;
; KIDS will file the modified RPs ORWPS COVER and ORWPS DETAIL
; KIDS will install the Mail Group ERX HELP DESK
;
D MES^XPDUTL("Adding E-Prescribing RPCs to CPRS Broker Context")
D REGNMSP("C0P","OR CPRS GUI CHART") ; Register C0P RPs to the Broker Context
;
; Add two alerts to the OE/RR Notifications file
D MES^XPDUTL("Adding E-Prescribing Notifications to the OE/RR Notification File")
;
N C0PFDA
; Entry 1
S C0PFDA(100.9,"?+1,",.001)=11305 ; NUMBER
S C0PFDA(100.9,"?+1,",.01)="C0P ERX REFILL REQUEST" ; NAME
; .02 is not filled out, but triggered by the .01
S C0PFDA(100.9,"?+1,",.03)="ERX REFILL REQUEST" ; MESSAGE TEXT
S C0PFDA(100.9,"?+1,",.04)="PKG" ; MESSAGE TYPE
S C0PFDA(100.9,"?+1,",.05)="R" ; ACTION FLAG
S C0PFDA(100.9,"?+1,",.06)="RUN" ; ENTRY POINT
S C0PFDA(100.9,"?+1,",.07)="C0PREFIL" ; ROUTINE NAME
S C0PFDA(100.9,"?+1,",1.5)="OR" ; RELATED PACKAGE
S C0PFDA(100.9,"?+1,",4)="Used by the C0P eRx package for eRx Refill Requests"
;
; Entry 2
S C0PFDA(100.9,"?+2,",.001)=11306 ; NUMBER
S C0PFDA(100.9,"?+2,",.01)="C0P ERX INCOMPLETE ORDER" ; NAME
; .02 is not filled out, but triggered by the .01
S C0PFDA(100.9,"?+2,",.03)="ERX INCOMPLETE ORDER" ; MESSAGE TEXT
S C0PFDA(100.9,"?+2,",.04)="PKG" ; MESSAGE TYPE
S C0PFDA(100.9,"?+2,",.05)="R" ; ACTION FLAG
S C0PFDA(100.9,"?+2,",.06)="STATUS" ; ENTRY POINT
S C0PFDA(100.9,"?+2,",.07)="C0PREFIL" ; ROUTINE NAME
S C0PFDA(100.9,"?+2,",1.5)="OR" ; RELATED PACKAGE
S C0PFDA(100.9,"?+2,",4)="Used by the C0P eRx package for eRx Incomplete Order Alerts"
;
N C0PERR ; Errors go here.
D UPDATE^DIE("","C0PFDA","","C0PERR") ; no flags, FDA, ien_root, msg_root
;
; ew ew ew I hate $Q... still don't understand it.
I $D(C0PERR) D
. D MES^XPDUTL("WARNING: Updating the OE/RR Notification file failed.")
. S C0PERR=$Q(C0PERR)
. F S C0PERR=$Q(@C0PERR) Q:C0PERR="" D MES^XPDUTL(C0PERR_": "_@C0PERR)
;
; Done with that; now add the x-ref to file 200 on the NPI field.
; Thank you to D ^DIKCBLD for writing this for me!
;
D MES^XPDUTL("Adding NPI Cross Reference to New Person File")
N C0PXR,C0PRES,C0POUT,C0PERR
S C0PXR("FILE")=200
S C0PXR("NAME")="C0PNPI"
S C0PXR("TYPE")="R"
S C0PXR("USE")="LS"
S C0PXR("EXECUTION")="F"
S C0PXR("ACTIVITY")="IR"
S C0PXR("SHORT DESCR")="Regular index on NPI for eRx"
S C0PXR("VAL",1)=41.99
S C0PXR("VAL",1,"SUBSCRIPT")=1
S C0PXR("VAL",1,"LENGTH")=30
S C0PXR("VAL",1,"COLLATION")="F"
D CREIXN^DDMOD(.C0PXR,"S",.C0PRES,"C0POUT","C0PERR")
I $D(C0PERR) D MES^XPDUTL("NPI Cross-Reference Creation on File 200 failed")
;
; Ditto: Add the x-ref to file 50 on the PSNDF VA PRODUCT NAME ENTRY
D MES^XPDUTL("Adding PSNDF VA PRODUCT NAME ENTRY xref to Drug File")
N C0PXR,C0PRES,C0POUT,C0PERR
S C0PXR("FILE")=50
S C0PXR("NAME")="AC0P"
S C0PXR("TYPE")="R"
S C0PXR("USE")="S"
S C0PXR("EXECUTION")="F"
S C0PXR("ACTIVITY")="IR"
S C0PXR("SHORT DESCR")="For eRx - a sort only index on the VAPRODUCT number"
S C0PXR("DESCR",1)="This index is used for the VISTA e-Rx project. This index enables a "
S C0PXR("DESCR",2)="programmer to search for a drug using the VA Product. This index will"
S C0PXR("DESCR",3)="be used to match drugs received from the remote service to the local drug"
S C0PXR("DESCR",4)="file. Drugs received using the remote service are received using RxNorm"
S C0PXR("DESCR",5)="CUI or First Databank MEDID. Either one of those will be translated to a"
S C0PXR("DESCR",6)="VUID, which is matched against the VA Product file, which then is matched"
S C0PXR("DESCR",7)="to the local drug pointing to the VA Product. "
S C0PXR("VAL",1)=22
S C0PXR("VAL",1,"SUBSCRIPT")=1
S C0PXR("VAL",1,"COLLATION")="F"
D CREIXN^DDMOD(.C0PXR,"S",.C0PRES,"C0POUT","C0PERR")
I $D(C0PERR) D MES^XPDUTL("PSNDF VA PRODUCT NAME ENTRY xref Creation failed")
;
; Add Free Txt Entry to Pharmacy Orderable Item
; Again... this time file the Free Text Drug into Pharmacy Orderablem Items
; if it isn't already there!
D MES^XPDUTL("Adding Free Txt Entry to Pharmacy Orderable Item file")
;
N PSEDITNM S PSEDITNM=1 ; Fileman gatekeeper for adding entries
N C0PFDA
S C0PFDA(50.7,"?+1,",.01)="FREE TXT DRUG" ; Name
S C0PFDA(50.7,"?+1,",.02)=40 ; DOSAGE FORM: MISCELANEOUS
S C0PFDA(50.7,"?+1,",.04)=3110428 ; INACTIVE DATE: (any value would do!)
;
N C0PERR ; Errors go here.
D UPDATE^DIE("","C0PFDA","","C0PERR") ; no flags, FDA, ien_root, msg_root
;
I $D(C0PERR) D
. D MES^XPDUTL("Couldn't add FREE TXT DRUG to Pharmacy Orderable Item File")
. S C0PERR=$Q(C0PERR)
. F S C0PERR=$Q(@C0PERR) Q:C0PERR="" D MES^XPDUTL(C0PERR_": "_@C0PERR)
;
D MES^XPDUTL("")
D MES^XPDUTL("Remember to install the following patches: ")
D MES^XPDUTL("They may be legally protected; see documentation on how to")
D MES^XPDUTL("acquire them. Contact Geroge Lilly at glilly@glilly.net for questions")
D MES^XPDUTL(" - C0P*1.0*1 -> New Crop WebServices Data")
D MES^XPDUTL(" - C0P*1.0*2 -> RxNorm Data 2012-04 Release")
D MES^XPDUTL(" - C0P*1.0*3 -> First Databank Data 2012-03 Release")
D MES^XPDUTL("")
D MES^XPDUTL("Make sure to set-up the following after installation: ")
D MES^XPDUTL(" - Account Info in C0P WS ACCT")
D MES^XPDUTL(" - Institution address fields in file 4")
D MES^XPDUTL(" - Hospital Location E-Rx fields")
D MES^XPDUTL(" - New Person E-Rx fields")
D MES^XPDUTL(" - Mail users to mail group: ERX HELP DESK")
D MES^XPDUTL(" - Schedule C0P ERX BATCH to run every 15 min using an eRx user")
;
; I think we are done!
QUIT
; --> RxNorm Files
RXNTRAN ; Transportation Routine for RxNorm Files, PEP
M @XPDGREF@("C0P","RXN")=^C0P("RXN")
QUIT
RXNPOST ; Post Install Routine for RxNorm Files, PEP
D MES^XPDUTL("Installing RxNorm Concepts File")
K ^C0P("RXN")
M ^C0P("RXN")=@XPDGREF@("C0P","RXN")
QUIT
; <-- RxNorm Files
;
; --> FDB Files
FDBTRAN ; Unified Transportation EP for FDB Files, PEP
D FDBDTRAN,FDBATRAN,IMPTRAN ; Drugs, Allergies, Import Templates
QUIT
FDBPOST ; Unified Post Install Routine for FDB Files, PEP
D FDBDPOST,FDBAPOST,IMPPOST ; Drugs, Allergies, Import Templates
QUIT
; <-- FDB Files
;
; Rest is private
FDBDTRAN ; Transportation Routine for FDB Drug File, private
M @XPDGREF@("C0P","FDBD")=^C0P("FDB")
QUIT
FDBDPOST ; Post Install Routine for FDB Drug File, private
D MES^XPDUTL("Installing FDB Drug File")
K ^C0P("FDB") ; Kill original file
M ^C0P("FDB")=@XPDGREF@("C0P","FDBD") ; Merge from Global
QUIT
FDBATRAN ; Transportation Routine for FDB Allergies File, private
M @XPDGREF@("C0P","FDBA")=^C0PALGY
QUIT
FDBAPOST ; Post Install Routine for FDB Allergies File, private
D MES^XPDUTL("Installing FDB Allergy File")
K ^C0PALGY ; Kill original file
M ^C0PALGY=@XPDGREF@("C0P","FDBA") ; Merge from Global
QUIT
;
; --> Import Templates
IMPTRAN ; Transport Import Template for loading FDB files, private
;
; Get the IEN of the import templates to transport off...
N FDBDIEN S FDBDIEN=$O(^DIST(.46,"B","C0P FDB TBLCOMPOSITEDRUG",""))
N FDBAIEN S FDBAIEN=$O(^DIST(.46,"B","C0P FDB TBLCOMPOSITEALLERGY",""))
;
; Put in transport global, remove creator DUZ (can't guarantee in dest sys)
M @XPDGREF@("C0P","IMPFDBD")=^DIST(.46,FDBDIEN) ; Get first template
S $P(@XPDGREF@("C0P","IMPFDBD",0),U,5)="" ; Remove Creator
M @XPDGREF@("C0P","IMPFDBA")=^DIST(.46,FDBAIEN) ; Get second template
S $P(@XPDGREF@("C0P","IMPFDBA",0),U,5)="" ; Remove Creator
;
QUIT
;
IMPPOST ; Post init for Import Templates, private
; TODO: Before using as a general KIDS utility, this does not
; check if the destination fields exist. Destination fields are
; FREE TEXT fields in the Import Template.
;
D MES^XPDUTL("Installing FDB Files' Import Templates")
; Part 1: Delete old entries if they already exist.
;
; Get IENs
N FDBDIEN S FDBDIEN=$O(^DIST(.46,"B","C0P FDB TBLCOMPOSITEDRUG",""))
N FDBAIEN S FDBAIEN=$O(^DIST(.46,"B","C0P FDB TBLCOMPOSITEALLERGY",""))
;
; Kill off: Indexes first, then record. Lock before you do.
N C0PNAME
F C0PNAME="FDBDIEN","FDBAIEN" D ; For each variable
. I @C0PNAME D ; If that entry is found (see $O above)
. . L +^DIST(.46,@C0PNAME):0 ; Lock
. . ; IX2: Fire all Kill x-refs for one record.
. . N DIK,DA S DIK="^DIST(.46,",DA=@C0PNAME D IX2^DIK ; Kill Logic
. . K ^DIST(.46,@C0PNAME) ; Remove record
. . L -^DIST(.46,@C0PNAME) ; Unlock
;
; Part 2: Update New Entries into File
; Get next available IEN in Import Template File
N LASTIEN S LASTIEN=$O(^DIST(.46," "),-1) ; Last internal entry number in file
;
N NEXTIEN S NEXTIEN=LASTIEN ; Use below... incrementer!
;
; Merge data into the next IEN for each of the refs in the transported global
; Block below gets next IEN available.
; Lock on ^DIST(.46,NEXTIEN) acquired below.
F C0PNAME="IMPFDBD","IMPFDBA" DO
. ;
. ; Loop below to get an IEN for our new record number
. N DONE ; control variable for mini loop below
. F D Q:$G(DONE) ; loop until done
. . S NEXTIEN=NEXTIEN+1 ; Next IEN available, we guess
. . L +^DIST(.46,NEXTIEN):0 ELSE QUIT ; Can we lock it? If not quit and try the next
. . I $D(^DIST(.46,NEXTIEN)) L -^DIST(.46,NEXTIEN) QUIT ; if we locked it, is it really empty? If not, unlock and try next
. . S DONE=1 QUIT ; ok. we are sure we got it. Tell the loop we are done.
. ;
. M ^DIST(.46,NEXTIEN)=@XPDGREF@("C0P",C0PNAME) ; Merge entry
. ;
. ; Fire off xrefs (IX1 fires SET for xrefs for one record)
. N DIK,DA S DIK="^DIST(.46,",DA=NEXTIEN D IX1^DIK
. ;
. ; Update zero node
. S $P(^DIST(.46,0),U,3)=NEXTIEN ; most recently assigned internal entry number
. S $P(^DIST(.46,0),U,4)=NEXTIEN ; current total number of entries
. ;
. L -^DIST(.46,NEXTIEN) ; Unlock it
QUIT
; <-- Import Templates
;
; SMH: All Code below comes from FOIA RPMS from routine CIAURPC
; Written by Doug Martin.
;
; Register/unregister RPCs within a given namespace to a context
REGNMSP(NMSP,CTX,DEL) ;EP
N RPC,IEN,LEN
S LEN=$L(NMSP),CTX=+$$GETOPT(CTX)
I $G(DEL) D
.S IEN=0
.F S IEN=$O(^DIC(19,CTX,"RPC","B",IEN)) Q:'IEN D
..I $E($G(^XWB(8994,IEN,0)),1,LEN)=NMSP,$$REGRPC(IEN,CTX,1)
E D
.Q:LEN<2
.S RPC=NMSP
.F D:$L(RPC) S RPC=$O(^XWB(8994,"B",RPC)) Q:NMSP'=$E(RPC,1,LEN)
..F IEN=0:0 S IEN=$O(^XWB(8994,"B",RPC,IEN)) Q:'IEN I $$REGRPC(IEN,.CTX)
Q
; Register/unregister an RPC to/from a context
; RPC = IEN or name of RPC
; CTX = IEN or name of context
; DEL = If nonzero, the RPC is unregistered (defaults to 0)
; Returns -1 if already registered; 0 if failed; 1 if succeeded
REGRPC(RPC,CTX,DEL) ;EP
S RPC=+$$GETRPC(RPC)
Q $S(RPC<1:0,1:$$REGMULT(19.05,"RPC",RPC,.CTX,.DEL))
; Add/remove a context to/from the ITEM multiple of another context.
REGCTX(SRC,DST,DEL) ;EP
S SRC=+$$GETOPT(SRC)
Q $S('SRC:0,1:$$REGMULT(19.01,10,SRC,.DST,.DEL))
; Add/delete an entry to/from a specified OPTION multiple.
; SFN = Subfile #
; NOD = Subnode for multiple
; ITM = Item IEN to add
; CTX = Option to add to
; DEL = Delete flag (optional)
REGMULT(SFN,NOD,ITM,CTX,DEL) ;
N FDA,IEN
S CTX=+$$GETOPT(CTX)
S DEL=+$G(DEL)
S IEN=+$O(^DIC(19,CTX,NOD,"B",ITM,0))
Q:'IEN=DEL -1
K ^TMP("DIERR",$J)
I DEL S FDA(SFN,IEN_","_CTX_",",.01)="@"
E S FDA(SFN,"+1,"_CTX_",",.01)=ITM
D UPDATE^DIE("","FDA")
S FDA='$D(^TMP("DIERR",$J)) K ^($J)
Q FDA
; Register a protocol to an extended action protocol
; Input: P-Parent protocol
; C-Child protocol
REGPROT(P,C,ERR) ;EP
N IENARY,PIEN,AIEN,FDA
D
.I '$L(P)!('$L(C)) S ERR="Missing input parameter" Q
.S IENARY(1)=$$FIND1^DIC(101,"","",P)
.S AIEN=$$FIND1^DIC(101,"","",C)
.I 'IENARY(1)!'AIEN S ERR="Unknown protocol name" Q
.S FDA(101.01,"?+2,"_IENARY(1)_",",.01)=AIEN
.D UPDATE^DIE("S","FDA","IENARY","ERR")
Q:$Q $G(ERR)=""
Q
; Remove nonexistent RPCs from context
CLNRPC(CTX) ;EP
N IEN
S CTX=+$$GETOPT(CTX)
F IEN=0:0 S IEN=$O(^DIC(19,CTX,"RPC","B",IEN)) Q:'IEN D:'$D(^XWB(8994,IEN)) REGRPC(IEN,CTX,1)
Q
; Return IEN of option
GETOPT(X) ;EP
N Y
Q:X=+X X
S Y=$$FIND1^DIC(19,"","X",X)
W:'Y "Cannot find option "_X,!!
Q Y
; Return IEN of RPC
GETRPC(X) ;EP
N Y
Q:X=+X X
S Y=$$FIND1^DIC(8994,"","X",X)
W:'Y "Cannot find RPC "_X,!!
Q Y

191
p/C0PLKUP.m Normal file
View File

@ -0,0 +1,191 @@
C0PLKUP ; VEN/SMH - Extrinsics to map med numbers ; 5/8/12 4:09pm
;;1.0;C0P;;Apr 25, 2012;Build 103
;Copyright 2009 Sam Habiel. 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
FDBFN() Q 1130590010 ; First Databank Drugs file number
RXNFN() Q 1130590011.001 ; RxNorm Concepts file number
FULLNAME(MEDID) ; $$ Public - Get FDB full name for the drug
; Used in Bulletin
; Input: MEDID By Value
; Output: Extrinsic
N C0PIEN S C0PIEN=$$FIND1^DIC($$FDBFN,"","QX",MEDID,"B")
Q $$GET1^DIQ($$FDBFN,C0PIEN,"MED MEDID DESC")
GCN(MEDID) ; $$ Public - Get GCN given MEDID
; Input: MEDID by Value
; Output: Extrinsic
; MEDID is the .01 field in the First Databank Drug file
; GCN is the 1 field = Generic Code Number
; WS supplies MEDID in return. Need Generic Code Number to map to RxNorm.
N X,Y,DTOUT,DUOUT,DLAYGO,DIC
S DIC=$$FDBFN
S X=MEDID
S DIC(0)="OXZ" ; One entry only, Exact match, return zero node
D ^DIC
I Y<0 Q "" ; Failed match
Q $P(Y(0),U,2) ; GCN is 2nd piece of zero node
;
RXNCUI(GCN) ; $$ Public - Get RxNorm CUI using GCN
; Input: GCN by Value
; Output: Extrinsic
; Seach GCN index for an exact match
; One match, quick lookup, Exact matching
N C0PIEN S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",GCN,"GCN")
Q $$GET1^DIQ($$RXNFN,C0PIEN,.01)
;
VUID(RXNCUI) ; $$ Public - Get VUID(s) for given RXNCUI for Clinical Drug
; Input: RXNCUI by Value
; Output: Caret delimited extrinsic. Should not be more than 2 entries.
; @;4 means return IEN and VUID.
N C0POUT,C0PVUID
I '$D(^DIC($$RXNFN,0,"GL")) Q "" ; RXNORM UMLS NOT INSTALLED
D FIND^DIC($$RXNFN,"","@;4","PXQ",RXNCUI,"","VUIDCD","","","C0POUT")
; Example output:
; SAM("DILIST",0)="2^*^0^"
; SAM("DILIST",0,"MAP")="IEN^4"
; SAM("DILIST",1,0)="112482^4010153"
; SAM("DILIST",2,0)="112484^4016607"
I +$G(C0POUT("DILIST",0))=0 Q "" ; no matches
N I S I=0
F S I=$O(C0POUT("DILIST",I)) Q:I="" S C0PVUID=$G(C0PVUID)_$P(C0POUT("DILIST",I,0),U,2)_"^"
S C0PVUID=$E(C0PVUID,1,$L(C0PVUID)-1) ; remove trailing ^
Q C0PVUID
VUID2(MEDID) ; $$ Public - Get VUID(s) for given MEDID
Q $$VUID($$RXNCUI($$GCN(MEDID)))
VAPROD(VUID) ; $$ Public - Get VA Product IEN from VUID
; Input VUID by Value
; Output: Extrinsic
Q $$FIND1^DIC(50.68,"","QX",VUID,"AVUID")
DRUG(VAPROD) ; $$ Public - Get Drug(s) using VA Product IEN
; Input: VA Product IEN By Value
; OUtput: Caret delimited extrinsic
N C0POUT,C0PDRUG
;D FIND^DIC(50,"","@;4","PXQ",VAPROD,"","C0PVAPROD","","","C0POUT")
;D FIND^DIC(50,"","@;4","PXQ",VAPROD,"","AC0P","","","C0POUT") ;GPL 7/10
I +VAPROD=0 Q 0 ;
I '$D(^PSDRUG("AC0P",VAPROD)) Q 0 ;W "AC0P cross reference error" Q 0 ;
;S C0PDRUG=$O(^PSDRUG("AC0P",VAPROD,"")) ;GPL ABOVE FIND DOESN'T WORK
N I S I=""
S C0PDRUG=""
F S I=$O(^PSDRUG("AC0P",VAPROD,I)) Q:I="" D ;
. S C0PDRUG=C0PDRUG_I_"^"
S C0PDRUG=$E(C0PDRUG,1,$L(C0PDRUG)-1) ; remove trailing ^
Q C0PDRUG
; Example output:
; C0POUT("DILIST",0)="2^*^0^"
; C0POUT("DILIST",0,"MAP")="IEN^4"
; C0POUT("DILIST",1,0)="1512^"
; C0POUT("DILIST",2,0)="21632^"
; or
; C0POUT("DILIST",0)="0^*^0^"
; C0POUT("DILIST",0,"MAP")="IEN^4"
I +$G(C0POUT("DILIST",0))=0 Q "" ; no matches
N I S I=0
F S I=$O(C0POUT("DILIST",I)) Q:I="" S C0PDRUG=$G(C0PDRUG)_$P(C0POUT("DILIST",I,0),U)_"^"
S C0PDRUG=$E(C0PDRUG,1,$L(C0PDRUG)-1) ; remove trailing ^
Q C0PDRUG
DRUG2(MEDID) ; $$ Public - Get Drugs for a FDB MEDID
; Input: MEDID by Value
; Output: Caret delimited extrinsic
N OUT S OUT=""
N C0PDRUGS ; tmp holding space for drugs
N C0PVUIDS S C0PVUIDS=$$VUID2(MEDID)
N C0PI
F C0PI=1:1:$L(C0PVUIDS,U) D ; for each VUID
. N C0PVUID S C0PVUID=$P(C0PVUIDS,U,C0PI)
. N C0PVAPROD S C0PVAPROD=$$VAPROD(C0PVUID) ; get VA Product
. S C0PDRUGS=$$DRUG(C0PVAPROD)
. S:$L(C0PDRUGS) OUT=OUT_C0PDRUGS_"^"
S OUT=$E(OUT,1,$L(OUT)-1) ; rm trailing ^
Q OUT
RXNCUI2(BASE) ; $$ Public - Get RxNorm CUI for FDB Ingredient/Base
; Input: BASE By Value
; Output: RxNorm CUI
N C0PIEN S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",BASE,"NDDFBASE")
Q $$GET1^DIQ($$RXNFN,C0PIEN,.01)
VUIDIN(RXNCUI) ; $$ Public - Get VUID Ingredient for RxNorm CUI
; Input: RXNCUI By Value
; Output: VUID
N C0PIEN S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",RXNCUI,"VUIDIN")
Q $$GET1^DIQ($$RXNFN,C0PIEN,"CODE")
VAGEN(VUID) ; $$ Public - Get VA Generic for VUID Ingredient
; Input: VUID By Value
; Output: IEN^VA Generic Name (i.e. .01 field value)
N C0PIEN S C0PIEN=$$FIND1^DIC(50.6,"","QX",VUID,"AVUID")
N C0P01 S C0P01=$$GET1^DIQ(50.6,C0PIEN,.01)
Q C0PIEN_"^"_C0P01
VAGEN2(BASE) ; $$ Public - Get VA Generic for FDB Ingredient/Base
; Input: BASE By Value
; Output: IEN^VA Generic Name (i.e. .01 field value)
Q $$VAGEN($$VUIDIN($$RXNCUI2(BASE)))
DRUGING(VUID) ; $$ Public - Get Drug Ingredient for VUID Ingredient
; Input: VUID By Value
; Output: IEN^Drug Ingredient Name (i.e. .01 field value)
N C0PIEN S C0PIEN=$$FIND1^DIC(50.416,"","QX",VUID,"AVUID")
N C0P01 S C0P01=$$GET1^DIQ(50.416,C0PIEN,.01)
Q C0PIEN_"^"_C0P01
DRUGING2(BASE) ; $$ Public - Get Drug Ingredient for FDB Ingredient/Base
; Input: BASE By Value
; Output: IEN^Drug Ingredient Name (i.e. .01 field value)
Q $$DRUGING($$VUIDIN($$RXNCUI2(BASE)))
RXNCUI3(VUID) ; $$ Public - Get RXNCUI for VUID (any VUID)
; Input: VUID By Value
; Output: RXNCUI
I $G(VUID)="" Q ""
N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",VUID,"VUID")
S C0PIEN=$O(^C0P("RXN","VUID",VUID,"")) ;GPL FIX FOR MULTIPLES
Q $$GET1^DIQ($$RXNFN,C0PIEN,.01)
NDDFBASE(RXNCUI) ; $$ Public - Get NDDF Ingredient for RXNCUI
; Input: RXNCUI By Value
; Output: NDDF Base code
N C0PIEN S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",RXNCUI,"RNDDFBASE")
Q +$$GET1^DIQ($$RXNFN,C0PIEN,"CODE") ; strip leading zeros
NDDFBAS2(VUID) ; $$ Public - Get NDDF Ingredient for VUID
; NB: WILL ONLY WORK IF VUID IS AN INGREDIENT VUID, NOT A CLINICAL DRUG
; Input: VUID By Value
; Output: NDDF Base code
Q $$NDDFBASE($$RXNCUI3(VUID))
;
DRUGNAM(CURRENTMEDS,ZMED) ; EXTRINSIC WHICH RETURNS THE FULL NAME
; OF THE DRUG FROM CURRENTMEDS, PASSED BY REFERENCE
; ZMED IS THE NUMBER OF THE MED IN THE ARRAY
; IF THERE IS A DRUGID, IT IS USED TO LOOKUP THE NAME
; IF THERE IS NO DRUGID, IT IS A FREETEXT MED AND THE NAME IS
; PULLED FROM THE SIG, WHERE IS IT STORED WITH A "|" DELIMITER
N ZD
I $D(CURRENTMEDS(ZMED,"DRUG")) S ZD=$$FULLNAME(CURRENTMEDS(ZMED,"DRUG"))
E D ; pull the name from the first piece of the sig
. N ZDSIG
. S ZDSIG=$G(CURRENTMEDS(ZMED,"SIG",1,0))
. S ZD=$P(ZDSIG,"|",1)
Q ZD
;
CODES(MEDID) ; EXTRINSIC WHICH RETURNS A LINE OF CODES FOR THE MED
; FORMAT IS MEDID:XXX GCN:XXX RXNORM:XXX VUID:XXX DRUG:XXX
N ZL
S ZL="MEDID:"_MEDID_" "
N ZG S ZG=$$GCN(MEDID) ; GCN (GENERIC CONCEPT NUMBER)
S ZL=ZL_"GCN:"_ZG_" "
N ZR S ZR=$$RXNCUI(ZG) ; RXNORM CONCEPT ID
S ZL=ZL_"RXNORM:"_ZR_" "
N ZV S ZV=$$VUID(ZR) ; VUID (VA UNIVERSAL ID)
S ZL=ZL_"VUID:"_ZV_" "
N ZD S ZD=$$DRUG2(MEDID) ; VISTA DRUG FILE IEN
I ZD=0 S ZD=""
S ZL=ZL_"DRUG:"_ZD_" "
Q ZL
;

222
p/C0PLOAD.m Normal file
View File

@ -0,0 +1,222 @@
C0PLOAD ; VEN/SMH - File Loading Utilties ; 5/8/12 4:53pm
;;1.0;C0P;;Apr 25, 2012;Build 103
; (C) Sam Habiel 2012
;
;Copyright 2012 Sam Habiel. 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.
; The routine contains utilities for Reading Files from
; RxNorm and FDB into Fileman files
;
; This is a pretty pretty alpha version. Right now it just has FDB.
;
; These files definitions will be existing already. They should
; be installed as part of the KIDS build containing this routine.
;
; The import templates will be also part of KIDS. They should
; already exist by the time you run this routine.
;
; The drug file is produced by importing a table called 'tblCompositeDrugs'
; provided in an access database from NewCrop accessed using parameter
; '1' for desiredData from this webservice:
; http://preproduction.newcropaccounts.com/V7/WebServices/Update1.asmx?op=GetMostRecentDownloadUrl
;
; The webservice provides a URL to a zip file; when unzipped, it produces an
; access database with tables for allergies, drugs, pharamcies, healthplans, and
; diagnoses.
;
; The following command (from mdb-tools) was used to extract this into an RRF
; format (i.e. '|' delimited).|
;
; mdb-sql -HFp -d'|' -i selecttblCompositeDrug.sql NCFull-200910.mdb > Drug.rrf
;
; The SQL was necessary to skip a word-processing field which I couldn't import
; into fileman using the fileman import tool (this is simply a technical
; restriction; if I hand wrote my import I could have used a word processing
; field and used WP^DIE to file it.) That's field's name is 'etc'.
; The SQL statement is as follows: SELECT MEDID, GCN_SEQNO, MED_NAME_ID,
; MED_NAME, MED_ROUTED_MED_ID_DESC, MED_ROUTED_DF_MED_ID_DESC, MED_MEDID_DESC,
; MED_STATUS_CD, MED_ROUTE_ID, ROUTED_MED_ID, ROUTED_DOSAGE_FORM_MED_ID,
; MED_STRENGTH, MED_STRENGTH_UOM, MED_ROUTE_ABBR, MED_ROUTE_DESC,
; MED_DOSAGE_FORM_ABBR, MED_DOSAGE_FORM_DESC, GenericDrugName,
; DosageFormOverride, MED_REF_DEA_CD, MED_REF_DEA_CD_DESC,
; MED_REF_MULTI_SOURCE_CD, MED_REF_MULTI_SOURCE_CD_DESC,
; MED_REF_GEN_DRUG_NAME_CD, MED_REF_GEN_DRUG_NAME_CD_DESC,
; MED_REF_FED_LEGEND_IND, MED_REF_FED_LEGEND_IND_DESC, GENERIC_MEDID,
; MED_NAME_TYPE_CD, GENERIC_MED_REF_GEN_DRUG_NAME_CD, MED_NAME_SOURCE_CD,
; DrugInfo, GenericDrugNameOverride, FormularyDrugID, Manufacturer, Status,
; TouchDate, DrugTypeID FROM tblCompositeDrug
;
; The allergies file is produced by importing the tblCompositeAllergy file
;
; Here's the mdb command to extract the file.
; mdb-export -HQ -d "|" NCFull-201203.mdb tblCompositeAllergy > tblCompositeAllergy.rrf
;
; There is no SQL here.
;
; Once you have both files, you can adjust the routine to where the files are
; and then import them by calling the PEPs below.
;
; Update: I wrote a bash script to automate this: it's called:
; drug_data_extract.sh
;
FDBIMP ; FDB Drug File Import; PEP. Interactive (for now).
;
;
N FILEPATH
R "Enter RRF FDB Drug File with Full Path: ",FILEPATH:60,!
I '$L(FILEPATH) QUIT
;
; NB: The following will only work on Unix
N PATH,FILE
N PIECES S PIECES=$L(FILEPATH,"/")
S PATH=$P(FILEPATH,"/",1,PIECES-1)
S FILE=$P(FILEPATH,"/",PIECES)
;
; Kill off the existing file
N %1 S %1=^C0P("FDB",0) ; save zero node
S $P(%1,"^",3,4)="" ; zero last record numbers
K ^C0P("FDB") ; kill file
S ^C0P("FDB",0)=%1 ; restore zero node
;
; Import File from text extract (Please I want an ODBC driver!)
;
D CLEAN^DILF
N CONTROL
S CONTROL("FLAGS")="E" ; External Values...
S CONTROL("MSGS")="" ; go as normal in ^TMP("DIERR",$J)
S CONTROL("MAXERR")="100" ; abort if you can't file a hundred records
; S CONTROL("IOP")="HOME" ; Send to home device ; smh - don't pass; API no like for HOME output
S CONTROL("QTIME")="" ; Don't Queue
N SOURCE
S SOURCE("FILE")=FILE ; File Name
S SOURCE("PATH")=PATH ; Directory
N FORMAT
S FORMAT("FDELIM")="|" ; Delimiter
S FORMAT("FIXED")="" ; Fixed Width?
S FORMAT("QUOTED")="" ; Are strings quoted?
;
D FILE^DDMP(1130590010,"[C0P FDB TBLCOMPOSITEDRUG]",.CONTROL,.SOURCE,.FORMAT)
QUIT
;
FDBAIMP ; FDB Allergies Import; PEP. Interactive (for now)
;
;
N FILEPATH
R "Enter RRF FDB Allergy File with Full Path: ",FILEPATH:60,!
I '$L(FILEPATH) QUIT
;
; NB: The following will only work on Unix
N PATH,FILE
N PIECES S PIECES=$L(FILEPATH,"/")
S PATH=$P(FILEPATH,"/",1,PIECES-1)
S FILE=$P(FILEPATH,"/",PIECES)
;
; Kill off the existing file
N %1 S %1=^C0PALGY(0) ; save zero node
S $P(%1,"^",3,4)="" ; zero last record numbers
K ^C0PALGY ; kill file
S ^C0PALGY(0)=%1 ; restore zero node
;
; Import file from text extract
D CLEAN^DILF
N CONTROL
S CONTROL("FLAGS")="E" ; External Values...
S CONTROL("MSGS")="" ; go as normal in ^TMP("DIERR",$J)
S CONTROL("MAXERR")="100" ; abort if you can't file a hundred records
; S CONTROL("IOP")="HOME" ; Send to home device ; smh - don't pass; API no like for HOME output
S CONTROL("QTIME")="" ; Don't Queue
N SOURCE
S SOURCE("FILE")=FILE ; File Name
S SOURCE("PATH")=PATH ; Directory
N FORMAT
S FORMAT("FDELIM")="|" ; Delimiter
S FORMAT("FIXED")="" ; Fixed Width?
S FORMAT("QUOTED")="" ; Are strings quoted?
;
D FILE^DDMP(113059005,"[C0P FDB TBLCOMPOSITEALLERGY]",.CONTROL,.SOURCE,.FORMAT)
QUIT
RXNIMP ; Import RxNorm Concepts File; Modded from C0CRXNRD
N FILEPATH
R "Enter RRF RxNorm Conepts File with Full Path: ",FILEPATH:60,!
I '$L(FILEPATH) QUIT
;
; NB: The following will only work on Unix
N PATH,FILE
N PIECES S PIECES=$L(FILEPATH,"/")
S PATH=$P(FILEPATH,"/",1,PIECES-1)
S FILE=$P(FILEPATH,"/",PIECES)
;
N LINES S LINES=$$GETLINES(PATH,FILE)
D OPEN^%ZISH("FILE",PATH,FILE,"R")
;
IF POP D EN^DDIOL("Error reading file..., Please check...") G EX
;
N %1 S %1=^C0P("RXN",0)
S $P(%1,"^",3,4)=""
K ^C0P("RXN")
S ^C0P("RXN",0)=%1
;
N C0CCOUNT
F C0CCOUNT=1:1 D Q:$$STATUS^%ZISH
. U IO
. N LINE R LINE:1
. IF $$STATUS^%ZISH QUIT
. I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
. N RXCUI,RXAUI,SAB,TTY,CODE,STR ; Fileman fields numbers below
. S RXCUI=$P(LINE,"|",1) ; .01
. S RXAUI=$P(LINE,"|",8) ; 1
. S SAB=$P(LINE,"|",12) ; 2
. ;
. ; Following lines not applicable here:
. ; If the source is a restricted source, decide what to do based on what's asked.
. ; N SRCIEN S SRCIEN=$$FIND1^DIC(176.003,"","QX",SAB,"B") ; SrcIEN in RXNORM SOURCES file
. ; N RESTRIC S RESTRIC=$$GET1^DIQ(176.003,SRCIEN,14,"I") ; 14 is restriction field; values 0-4
. ; If RESTRIC is zero, then it's unrestricted. Everything else is restricted.
. ; If user didn't ask to include restricted sources, and the source is restricted, then quit
. ; I 'INCRES,RESTRIC QUIT
. ;
. S TTY=$P(LINE,"|",13) ; 3
. S CODE=$P(LINE,"|",14) ; 4
. S STR=$P(LINE,"|",15) ; 5
. ; Remove embedded "^"
. S STR=$TR(STR,"^")
. ; Convert STR into an array of 80 characters on each line
. N STRLINE S STRLINE=$L(STR)\80+1
. ; In each line, chop 80 characters off, reset STR to be the rest
. N J F J=1:1:STRLINE S STR(J)=$E(STR,1,80) S STR=$E(STR,81,$L(STR))
. ; Now, construct the FDA array
. N RXNFDA
. S RXNFDA(1130590011.001,"+1,",.01)=RXCUI
. S RXNFDA(1130590011.001,"+1,",1)=RXAUI
. S RXNFDA(1130590011.001,"+1,",2)=SAB
. S RXNFDA(1130590011.001,"+1,",3)=TTY
. S RXNFDA(1130590011.001,"+1,",4)=CODE
. N RXNIEN S RXNIEN(1)=C0CCOUNT
. D UPDATE^DIE("","RXNFDA","RXNIEN")
. I $D(^TMP("DIERR",$J)) D EN^DDIOL("ERROR") G EX
. ; Now, file WP field STR
. D WP^DIE(1130590011.001,C0CCOUNT_",",5,,$NA(STR))
EX D CLOSE^%ZISH("FILE")
QUIT
GETLINES(PATH,FILENAME) ; Get number of lines in a file
D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
U IO
N I
F I=1:1 R LINE:1 Q:$$STATUS^%ZISH
D CLOSE^%ZISH("FILE")
Q I-1

211
p/C0PMAIN.m Normal file
View File

@ -0,0 +1,211 @@
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

135
p/C0PNVA.m Normal file
View File

@ -0,0 +1,135 @@
C0PNVA ; VEN/SMH - Non-VA Meds Utilities for e-Rx ; 5/8/12 4:32pm
;;1.0;C0P;;Apr 25, 2012;Build 103
;Copyright 2009 Sam Habiel. 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
;
FILE(C0PDFN,OR,DRUG,DOSAGE,ROUTE,SCHEDULE,START,C0PDUZ,COMMENT) ; Private Proc - File NVA
; Input:
; - C0PDFN: Patient DFN
; - OR: Pharmacy Orderable Item IEN
; - DRUG: Drug IEN
; - DOSAGE: Free Text Dosage
; - ROUTE: Free Text Route
; - SCHEDULE: Free Text Schedule
; - START: Start date in Timson Format
; - C0PDUZ: Provider documenting NVA DUZ
; - COMMENT: Free Text Comment
; NOTE: Right now, does nothing to file in CPRS order file.
;
D CLEAN^DILF ; Kill DIERR etc
; First Create parent file entry if it already doesn't exist
;
; We will handle the case where there are subfile entries but no
; zero node defined for the record. First, check to see if there is
; anything there at all for this patient
;
N C0PEXIT S C0PEXIT=0 ; in case of errors
I '$D(^PS(55,C0PDFN)) D Q:C0PEXIT ; if nothing is there for this patient
. N C0PFDAPT
. N C0PPTIEN S C0PPTIEN(1)=C0PDFN ; bug? in Update-doesn't honor DINUM
. S C0PFDAPT(55,"+1,",.01)=C0PDFN
. D UPDATE^DIE("","C0PFDAPT","C0PPTIEN")
. I $G(DIERR) D ^%ZTER,CLEAN^DILF S C0PEXIT=1 Q ; log error and signal q
E I '$D(^PS(55,C0PDFN,0)) D ; is there something there but not a zero node?
. S ^PS(55,C0PDFN,0)=C0PDFN ; set the zero node
. N DIK,DA
. S DIK="^PS(55,"
. S DA=C0PDFN
. S DIK(1)=".01"
. D EN^DIK ; cross reference the .01 field
;
N C0PFDA
N C0PIENS ; Return value of IEN in the NVA multiple in file 55
;
; gpl. first, create the NVA subfile if none exists
; these lines were copied from PSONVNEW, which creates non-VA meds
N ZIEN ; CREATING A NEW ENTRY, THE FIRST FOR THIS PATIENT
I '$D(^PS(55,C0PDFN,"NVA",0)) D ; NO NVA SUBFILE
. S DFN=C0PDFN
. S DA(1)=DFN
. S X=OR
. S DR="1////"_DRUG
. S DIC("DR")=DR,DIC(0)="L",DIC="^PS(55,"_DFN_",""NVA"",",DLAYGO=55.05
. D FILE^DICN S ZIEN=+Y K DR,DIC,DD,DA,DO,DINUM
. ; I don't know why the following doesn't work
. ;S C0PFDA(55.05,"+1,"_C0PDFN_",",.01)=OR
. ;D UPDATE^DIE("","C0PFDA","C0PIENS")
. ;I $G(DIERR) D ^%ZTER QUIT ; log error if update fails
. ;E D ; find the ien of the subfile
. S ZIEN=$O(^PS(55,C0PDFN,"NVA","B",OR,""))
. I ZIEN="" S ZIEN=1
. ;
. S C0PFDA(55.05,"?+"_ZIEN_","_C0PDFN_",",.01)=OR
. S C0PFDA(55.05,"?+"_ZIEN_","_C0PDFN_",",1)=DRUG
. S C0PFDA(55.05,"?+"_ZIEN_","_C0PDFN_",",2)=$E(DOSAGE,1,80) ; 80 char max
. S C0PFDA(55.05,"?+"_ZIEN_","_C0PDFN_",",3)=$E(ROUTE,1,40)
. S C0PFDA(55.05,"?+"_ZIEN_","_C0PDFN_",",4)=$E(SCHEDULE,1,50)
. S C0PFDA(55.05,"?+"_ZIEN_","_C0PDFN_",",8)=START ; Start Date
. S C0PFDA(55.05,"?+"_ZIEN_","_C0PDFN_",",11)=$$NOW^XLFDT() ; Documentated Date
. S C0PFDA(55.05,"?+"_ZIEN_","_C0PDFN_",",12)=C0PDUZ
. ;
. D UPDATE^DIE("","C0PFDA","C0PIENS")
. I $G(DIERR) D ^%ZTER QUIT ; log error if update fails
. ;
. D CLEAN^DILF ; Kill DIERR etc.
. ; File WP field
. N C0PWP ; comment is multi line
. M C0PWP=COMMENT
. ;D WP^DIE(55.05,C0PIENS(1)_","_C0PDFN_",",14,"","C0PWP")
. D WP^DIE(55.05,C0PIENS(ZIEN)_","_C0PDFN_",",14,"","C0PWP")
. I $G(DIERR) D ^%ZTER QUIT ; log error if wp filling fails.
E D ; CREATING A NEW ENTRY, NOT THE FIRST
. S ZIEN=1 ; GOING TO USE +1 CONVENTION
. S C0PFDA(55.05,"+"_ZIEN_","_C0PDFN_",",.01)=OR
. S C0PFDA(55.05,"+"_ZIEN_","_C0PDFN_",",1)=DRUG
. S C0PFDA(55.05,"+"_ZIEN_","_C0PDFN_",",2)=$E(DOSAGE,1,80) ; 80 char max
. S C0PFDA(55.05,"+"_ZIEN_","_C0PDFN_",",3)=$E(ROUTE,1,40)
. S C0PFDA(55.05,"+"_ZIEN_","_C0PDFN_",",4)=$E(SCHEDULE,1,50)
. S C0PFDA(55.05,"+"_ZIEN_","_C0PDFN_",",8)=START ; Start Date
. S C0PFDA(55.05,"+"_ZIEN_","_C0PDFN_",",11)=$$NOW^XLFDT() ; Documentated Date
. S C0PFDA(55.05,"+"_ZIEN_","_C0PDFN_",",12)=C0PDUZ
. ;
. D UPDATE^DIE("","C0PFDA","C0PIENS")
. ;I $D(GPLTEST) B ;
. I $G(DIERR) D ^%ZTER QUIT ; log error if update fails
. ;
. D CLEAN^DILF ; Kill DIERR etc.
. ; File WP field
. N C0PWP ;S C0PWP(1)=COMMENT
. M C0PWP=COMMENT ; comment is passed by reference and has multiple lines
. ;D WP^DIE(55.05,C0PIENS(1)_","_C0PDFN_",",14,"","C0PWP")
. D WP^DIE(55.05,C0PIENS(ZIEN)_","_C0PDFN_",",14,"","C0PWP")
. I $G(DIERR) D ^%ZTER QUIT ; log error if wp filling fails.
QUIT
;
DC(C0PDFN,NVAIEN) ; Private Procedure - D/C Non-VA Med
; Input:
; C0PDFN - you should know what this is by now
; NVAIEN - IEN of Non-VA in the non-VA subfile in file 55
; Output:
; None
; Notes: Does not involve order file right now...
I $G(^TMP("C0PNODISC")) Q ; DO NOT DISCONTINUE DRUGS SWITCH
; FOR TESTING NEW CROP - MAINTAINS VISTA DRUGS
D CLEAN^DILF ; Kill DIERR etc
N C0PFDA
S C0PFDA(55.05,NVAIEN_","_C0PDFN_",",5)=1 ; Status = discontinued
S C0PFDA(55.05,NVAIEN_","_C0PDFN_",",6)=$$NOW^XLFDT() ; discontinued date
D UPDATE^DIE("","C0PFDA")
I $G(DIERR) D ^%ZTER QUIT
QUIT

83
p/C0PPAT.m Normal file
View File

@ -0,0 +1,83 @@
C0PPAT ; ERX/GPL - ERX PATIENT utilities; 8/26/09 ; 12/10/09 6:46pm
;;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
;
; THIS ROUTINE IS CALLED AS PART OF ERX WEB SERVICES PROCESSING
; TO POPULATE INFORMATION ABOUT THE PATIENT TO BE MAPPED INTO XML
; AND SENT TO THE EPRESCRIBING PROVIDER TO DEFINE THE PATIENT ON THEIR
; SYSTEM. ALL WEB SERVICE CALLS REGARDING A PATIENT WILL USE THIS ROUTINE
; AND SEND A COMPLETE REPRESENTATION OF THE PATIENT.
; GPL JUN 2010
;
EN(RTNVAR,C0PDFN) ; INITIALIZE PATIENT VARIABLE ARRAY FOR PATIENT C0PDFN
; RTNVAR IS PASSED BY NAME. VARIABLES ARE PREFIXED WITH "PATIENT-"
; HERE IS A LIST OF THE VARIABLES THAT ARE POPULATED FOR THE PATIENT:
;GPL("PATIENT-ACTORADDRESSCITY")="ALTON"
;GPL("PATIENT-ACTORADDRESSLINE1")="1234 Somewhere Lane"
;GPL("PATIENT-ACTORADDRESSLINE2")=""
;GPL("PATIENT-ACTORADDRESSSOURCEID")="WS_PATIENT2"
;GPL("PATIENT-ACTORADDRESSSTATE")="KANSAS"
;GPL("PATIENT-ACTORADDRESSTYPE")="Home"
;GPL("PATIENT-ACTORADDRESSZIPCODE")=67623
;GPL("PATIENT-ACTORCELLTEL")=""
;GPL("PATIENT-ACTORCELLTELTEXT")=""
;GPL("PATIENT-ACTORDATEOFBIRTH")="1957-12-25"
;GPL("PATIENT-ACTOREMAIL")=""
;GPL("PATIENT-ACTORFAMILYNAME")="ZZ PATIENT"
;GPL("PATIENT-ACTORGENDER")="MALE"
;GPL("PATIENT-ACTORGIVENNAME")="TEST"
;GPL("PATIENT-ACTORIEN")=2
;GPL("PATIENT-ACTORMIDDLENAME")="TWO"
;GPL("PATIENT-ACTOROBJECTID")="WS_PATIENT2"
;GPL("PATIENT-ACTORRESTEL")="888-555-1212"
;GPL("PATIENT-ACTORRESTELTEXT")="Residential Telephone"
;GPL("PATIENT-ACTORSOURCEID")="ACTORSYSTEM_1"
;GPL("PATIENT-ACTORSSN")="769122557P"
;GPL("PATIENT-ACTORSSNSOURCEID")="WS_PATIENT2"
;GPL("PATIENT-ACTORSSNTEXT")="SSN"
;GPL("PATIENT-ACTORSUFFIXNAME")=""
;GPL("PATIENT-ACTORWORKTEL")="888-121-1212"
;GPL("PATIENT-ACTORWORKTELTEXT")="Work Telephone"
;GPL("PATIENTID")="PATIENT2"
N C0PTMP
D PEXTRACT^C0CACTOR("C0PTMP",C0PDFN,"WS_PATIENT_"_C0PDFN)
; todo: for state, use extended syntax
N ZG
S C0PTMP("PATIENTID")="PATIENT"_C0PDFN ; PATIENT ID BASED ON DFN
S C0PTMP("IDTYPE")="" ; DON'T KNOW WHAT SHOULD GO HERE
S C0PTMP("STARTHISTORY")="2004-01-01T00:00:00" ; DEFAULT... CHANGE THIS
S C0PTMP("ENDHISTORY")="2010-01-01T00:00:00" ; DEFAULT... CHANGE THIS
S C0PTMP("PRESCRIPTIONSTATUS")="C" ; DEFAULT... CHANGE THIS
S C0PTMP("PRESCRIPTIONSUBSTATUS")="S" ; DEFAULT... CHANGE THIS
S C0PTMP("ARCHIVESTATUS")="N" ; DEFAULT... CHANGE THIS
S ZG=$$GET1^DIQ(2,C0PDFN,.115,"I") ;NEED ABBREVIATION
S C0PTMP("ACTORADDRESSSTATE")=$$GET1^DIQ(5,ZG_",",1) ;STATE ABBREVIATION
I C0PTMP("ACTORGENDER")="MALE" S C0PTMP("ACTORGENDER")="M"
I C0PTMP("ACTORGENDER")="FEMALE" S C0PTMP("ACTORGENDER")="F"
S C0PTMP("ACTORDATEOFBIRTH")=$TR(C0PTMP("ACTORDATEOFBIRTH"),"-") ;REMOVE DASHES FROM DOB
S C0PTMP("ACTORSSN")=$TR(C0PTMP("ACTORSSN"),"P","") ;REMOVE P FROM TEST SSN
N ZI
S ZI=""
F S ZI=$O(C0PTMP(ZI)) Q:ZI="" D ; FOR EACH VARIABLE RETURNED
. S @RTNVAR@("PATIENT-"_ZI)=C0PTMP(ZI) ; RETURN PREFIXED VARIABLE
S @RTNVAR@("PATIENT-ACTORADDRESSCOUNTRY")="US" ;FIX THIS FOR INTERNATIONAL
S @RTNVAR@("PATIENT-ACTORMEMO")="" ; DON'T KNOW WHAT TO PUT HERE GPL
Q
;

235
p/C0PRECON.m Normal file
View File

@ -0,0 +1,235 @@
C0PRECON ; VEN/SMH - Utilities for Medication Reconciliation; 5/8/12 4:34pm
;;1.0;C0P;;Apr 25, 2012;Build 103
;Copyright 2009 Sam Habiel. 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
;
GETMEDS(C0PDUZ,C0PDFN,ZRTN) ; Public Proc
; Retreives meds from WebService, matches them against VistA,
; compares them with current meds, saves into Non-Va multiple in file 55
; (pharmacy patient)
;
; Input:
; - C0PDUZ: DUZ
; - C0PDFN: DFN
;
I $G(^TMP("C0PNOPULLBACK")) Q ; TURNS OFF PULLBACK PROCESSING
; FOR TESTING NEW CROP OPTIONS - KEEPS VISTA ERX DRUGS INTACT AND ADDS NO
; NEW DRUGS
N C0PWSMEDS
D SOAP^C0PWS1("C0PWSMEDS","GETMEDS",C0PDUZ,C0PDFN) ; soap call for WS meds
I C0PWSMEDS(1,"Status")'="OK" Q ; bad return from ws call
N CURRENTMEDS
D GET^C0PCUR(.CURRENTMEDS,C0PDFN) ; current meds in VistA
N ZDUPS ; ARRAY TO KEEP TRACK OF DUPLICATES SO THAT WE CAN
; DISCONTINUE ERX MEDS THAT ARE NOT IN THE WEB SERVICE LIST
N I
FOR I=1:1:C0PWSMEDS(1,"RowCount") DO
. N MEDTOADD M MEDTOADD=C0PWSMEDS(I)
. N DUPID S DUPID=$$DUP(MEDTOADD("DrugID"),.CURRENTMEDS) ; check for dups
. N MEDTXT S MEDTXT=$$FULLNAME^C0PLKUP(MEDTOADD("DrugID"))
. I 'DUPID S DUPID=$$FREMAT(MEDTXT,.CURRENTMEDS) ;check
. ; for free text drug match gpl
. I DUPID S ZDUPS(DUPID,I)="" ; INDEX BY CURRENT MED NUMBER
. I DUPID D ; if indeed duplicate, check if WS Drug is newer drug
. . N RXDATENOTIME
. . S RXDATENOTIME=$P($$FMDATE(MEDTOADD("PrescriptionDate")),".")
. . I RXDATENOTIME>CURRENTMEDS(DUPID,"START") D ; if newer
. . . ;D DC^C0PNVA(C0PDFN,$P(CURRENTMEDS(DUPID,0),U)) ;dc old one
. . . D DC^C0PNVA(C0PDFN,CURRENTMEDS(DUPID,"NVAIEN")) ; gpl
. . . D ADD(.MEDTOADD,C0PDFN,C0PDUZ) ; add new one
. . E ; do nothing here: Current med in Vista is newer or equivalent one
. E D ADD(.MEDTOADD,C0PDFN,C0PDUZ) ; not a duplicate med
; NOW LOOK THROUGH CURRENT MEDS TO SEE WHICH NEED TO BE DISCONTINUED
S I=""
F S I=$O(CURRENTMEDS(I)) Q:I="" D ; FOR EACH CURRENT MED
. I $O(ZDUPS(I,""))="" D ; DUPLICATE DRUG NOT FOUND
. . I $P(CURRENTMEDS(I,0),U,9)'="ACTIVE" Q ; might be discontinued
. . S ZT=$$DRUGNAM^C0PLKUP(.CURRENTMEDS,I)
. . I ZT="" S ZT=$P(CURRENTMEDS(I,0),U,2)
. . N ZN S ZN=$P($G(CURRENTMEDS(I,0)),U,1)
. . S ZT=ZN_" "_ZT
. . ;S ZT=$P(CURRENTMEDS(I,0),U,1)_" "_$P(CURRENTMEDS(I,0),U,2)
. . I ZN["N;" D ; DISCONTINUE THE NONVA MED
. . . I $G(CURRENTMEDS(I,"COMMENTS",1))["Received from E-Rx Web Service" D ;
. . . . D DC^C0PNVA(C0PDFN,CURRENTMEDS(I,"NVAIEN")) ;dc the med
. . . . S ZT="Discontinued "_ZT
. . E S ZT="Can't Discontinue "_ZT
. . D MAPERR(.ZRTN,"DRUGS",ZT)
QUIT
ADD(MEDTOADD,C0PDFN,C0PDUZ) ; Private Proc - Add med to VistA
; Input:
; - MEDTOADD: WebService Drug information, by Reference
; - C0PDFN: DFN, by Value
; - C0PDUZ: DUZ, By Value
; Output:
; - None
N DRUGS S DRUGS=$$DRUG2^C0PLKUP(MEDTOADD("DrugID"))
N ZR,ZII ; GPL NEED TO FIND A NON-ZERO MATCH
F ZII=1:1:10 S ZR=$P(DRUGS,U,ZII) Q:ZR>0 ; $$DRUG2 RETURNS a^b^c FOR MATCHES
S DRUGS=ZR ; WE WANT THE FIRST NON-ZERO MATCH
I +DRUGS=0 DO QUIT
. D SENDMSG(.MEDTOADD,C0PDFN)
. D NFADD(.MEDTOADD,C0PDFN,C0PDUZ)
. N ZT
. S ZT="Error Mapping Drug: "_MEDTOADD("DrugName")_" ID: "_MEDTOADD("DrugID")
. D MAPERR(.ZRTN,"DRUGS",ZT) ; CALL ERROR ROUTINE TO RECORD NO MATCH FOR DRUG
N DRUG S DRUG=+DRUGS ; grab the first entry; as good as any for now
N ORDIEN S ORDIEN=$$GET1^DIQ(50,DRUG,"PHARMACY ORDERABLE ITEM","I")
N DOSAGE S DOSAGE=MEDTOADD("DosageNumberDescription")_" "_MEDTOADD("DosageForm")
; ****** ADDED BY GPL 10/5/10 TO ALWAYS CAPTURE FDB NAME IN SIG
N MEDTXT S MEDTXT=$$FULLNAME^C0PLKUP(MEDTOADD("DrugID"))
I MEDTXT="" S MEDTXT=MEDTOADD("DrugName") ; drug not found condition gpl
S DOSAGE=MEDTXT_"| "_MEDTOADD("DosageNumberDescription")_" "_MEDTOADD("DosageForm") ; | delimiter added by gpl 2/5/2010
; ****** END MOD
N ROUTE S ROUTE=MEDTOADD("Route")
N SCHEDULE S SCHEDULE=MEDTOADD("DosageFrequencyDescription")
I MEDTOADD("TakeAsNeeded")="Y" S SCHEDULE=SCHEDULE_" PRN" ; Vista stores PRN in schedule
N START S START=$$FMDATE(MEDTOADD("PrescriptionDate"))
N COMMENT
S COMMENT(1)="Received from E-Rx Web Service" ;todo: move to dialog file
S COMMENT(2)="Order Guid: "_$G(MEDTOADD("OrderGuid"))
S COMMENT(3)="Physician Name: "_$G(MEDTOADD("PhysicianName"))
S COMMENT(4)="Prescription Date: "_$G(MEDTOADD("PrescriptionDate"))
S COMMENT(5)="Prescription Guid: "_$G(MEDTOADD("PrescriptionGuid"))
S COMMENT(6)="Notes: "_$G(MEDTOADD("PrescriptionNotes"))
; add codes for Certification and Free Txt repair processing - gpl
S COMMENT(7)=$$CODES^C0PLKUP(MEDTOADD("DrugID")) ;
D FILE^C0PNVA(C0PDFN,ORDIEN,DRUG,DOSAGE,ROUTE,SCHEDULE,START,C0PDUZ,.COMMENT)
QUIT
MAPERR(ZRTN,ZTYP,ZTXT) ; ZTYP IS THE TYPE OF MAPPING ERROR
; (IE DRUGS OR ALLERGY)
; ZRTN IS PASSED BY REFERENCE AND IS THE ARRAY OF ERROR MESSAGES
; THIS ROUTINE ADDS THE ERROR MESSAGE TO THE END OF THE ARRAY
; ZTXT IS THE ERROR MESSAGE
;
N ZI
I $G(^TMP("C0PDEBUG"))="" Q ; ONLY SHOW MAPPING ERRORS ON DEBUG
I '$D(ZRTN) S ZI=1
E S ZI=$O(ZRTN(""),-1)+1 ;ONE PASSED THE END OF ZRTN
S ZRTN(ZI)=ZTXT
Q
;
FMDATE(C0PD) ; Public $$ - Get fileman date from dates formatted like 11/7/09 10:22:34 PM
; Input: Date like 11/7/09 10:22:34 PM
; Output: Timson date precise up to seconds
S $E(C0PD,$F(C0PD," ")-1)="@" ; put @ b/n date and time for fm
N %DT S %DT="TS" ; seconds are required
N X,Y
S X=C0PD D ^%DT
I Y<0 D ^%ZTER ; Problem converting date... wake up programmer
QUIT Y
;
DUP(FDBDRUGID,CURRENTMEDS) ; Private $$ - Is Drug already documented for patient?
; Input:
; FDBDRUGID By Value
; CURRENTMEDS By Reference
; Output:
; "" if no duplicate
; CURRENTMEDS ien if duplicate
N DRUGS S DRUGS=$$DRUG2^C0PLKUP(FDBDRUGID)
; add a check for the CODES in Comment(6) - to update if not there
N C0PCODES S C0PCODES=$$CODES^C0PLKUP(FDBDRUGID)
N I S I=""
N FOUND S FOUND=0
F Q:FOUND=1 S I=$O(CURRENTMEDS(I)) Q:I="" D ; loop through current meds
. I '$D(CURRENTMEDS(I,"DRUG")) QUIT ; continue if no drug id
. I $G(CURRENTMEDS(I,"COMMENTS",1))'["Received from E-Rx Web Service" Q ;
. ; DON'T MATCH ON DRUGS THAT ARE NOT ERX
. ; check for CODES in COMMENTS(6)
. I $G(CURRENTMEDS(I,"COMMENTS",6))'=C0PCODES D ; add codes
. . ;S ^PS(55,C0PDFN,"NVA",I,1,7,0)=C0PCODES ; right into the global
. I $P(CURRENTMEDS(I,0),U,9)'["ACTIVE" QUIT ; quit if not active
. I ("^"_DRUGS_"^")[("^"_CURRENTMEDS(I,"DRUG")_"^") S FOUND=1
QUIT I ; entry if Found, "" if not found
;
FREMAT(FDBDNAME,CURRENTMEDS,ZMED) ;MATCH A FREE TEXT DRUG EXTRINSIC
; THE DRUG ID HAS BEEN STORED IN THE COMMENT OF EACH ERX NONVA DRUG
; ZMED IS WHICH DRUG IN CURRENTMEDS WHICH IS PASSED BY REF
; FDBDNAME IS THE DRUG NAME AND IS PASSED BY VALUE ; GPL
N I S I=""
; add a check for the CODES in Comment(6) - to update if not there
N C0PCODES S C0PCODES=$$CODES^C0PLKUP(MEDTOADD("DrugID"))
N FOUND S FOUND=0
F Q:FOUND=1 S I=$O(CURRENTMEDS(I)) Q:I="" D ; loop through current meds
. I $D(CURRENTMEDS(I,"DRUG")) QUIT ; SKIP OVER MAPPED DRUGS
. I $P(CURRENTMEDS(I,0),U,9)'["ACTIVE" QUIT ; quit if not active
. I FDBDNAME=$$DRUGNAM^C0PLKUP(.CURRENTMEDS,I) S FOUND=1
I FOUND=1 D ;
. S ZT="Drug Dup Found: "_MEDTOADD("DrugName")_" ID: "_MEDTOADD("DrugID")
. ; check for CODES in COMMENTS(6)
. I $G(CURRENTMEDS(I,"COMMENTS",6))'=C0PCODES D ; add codes
. . ;S ^PS(55,C0PDFN,"NVA",I,1,7,0)=C0PCODES ; right into the global
. D MAPERR(.ZRTN,"DRUGS",ZT) ; CALL ERROR ROUTINE TO RECORD NO MATCH FOR DRUG
Q I ; entry if Found, "" if not found
;
SENDMSG(MEDTOADD,C0PDFN) ; Private EP - Send Bulletin saying drug not found
; Input:
; - MEDTOADD: WS Med entry By Reference
; - C0PDFN: DFN by Value
; Output:
; - None
; info: tested 12/14/09
; todo: move this to a background call - it takes too long!
N DUZ ; remove old value to make the postmaster the sender
N XMDUZ S XMDUZ="E-Rx WebService" ; supposed sender
N XMTEXT ; unused
N XMY ; unused
N XMBTMP ; unused
N XMDF ; unused
N XMDT ; unused - will send message now
N XMYBLOB ; unused
N XMB
S XMB="C0P EXTERNAL DRUG NOT FOUND" ; bulletin name
S (XMB(1),XMB(5))=$$GET1^DIQ(2,C0PDFN,"PRIMARY LONG ID") ; chart #
S (XMB(2),XMB(3))=$$FULLNAME^C0PLKUP(MEDTOADD("DrugID")) ; drug not matched
S XMB(4)=$$GET1^DIQ(2,C0PDFN,.01) ; patient name
D ^XMB
QUIT
;
NFADD(MEDTOADD,C0PDFN,C0PDUZ) ; Private Proc - Add free text med to VistA
; Input:
; - MEDTOADD: WebService Drug information, by Reference
; - C0PDFN: DFN, by Value
; - C0PDUZ: DUZ, By Value
; Output:
; - None
; info: tested 12/16/09
; Stores med along side dosage in dosage field as free text
N ORDIEN S ORDIEN=$$FIND1^DIC(50.7,"","QX","FREE TXT DRUG","B") ; todo: change to a parameter
N DOSAGE
N MEDTXT S MEDTXT=$$FULLNAME^C0PLKUP(MEDTOADD("DrugID"))
I MEDTXT="" S MEDTXT=MEDTOADD("DrugName") ; drug not found condition gpl
S DOSAGE=MEDTXT_"| "_MEDTOADD("DosageNumberDescription")_" "_MEDTOADD("DosageForm") ; | delimiter added by gpl 2/5/2010
N ROUTE S ROUTE=MEDTOADD("Route")
N SCHEDULE S SCHEDULE=MEDTOADD("DosageFrequencyDescription")
I MEDTOADD("TakeAsNeeded")="Y" S SCHEDULE=SCHEDULE_" PRN" ;
N START S START=$$FMDATE(MEDTOADD("PrescriptionDate"))
N COMMENT
S COMMENT(1)="Received from E-Rx Web Service" ;todo: move to dialog file
S COMMENT(2)="Order Guid: "_$G(MEDTOADD("OrderGuid"))
S COMMENT(3)="Physician Name: "_$G(MEDTOADD("PhysicianName"))
S COMMENT(4)="Prescription Date: "_$G(MEDTOADD("PrescriptionDate"))
S COMMENT(5)="Prescription Guid: "_$G(MEDTOADD("PrescriptionGuid"))
S COMMENT(6)="Notes: "_$G(MEDTOADD("PrescriptionNotes"))
; add codes for Certification and Free Txt repair processing - gpl
S COMMENT(7)=$$CODES^C0PLKUP(MEDTOADD("DrugID")) ;
D FILE^C0PNVA(C0PDFN,ORDIEN,"",DOSAGE,ROUTE,SCHEDULE,START,C0PDUZ,.COMMENT)
;N COMMENT ;added DrugID to comment 1/27/2010 gpl
;S COMMENT="Received from E-Rx Web Service (DrugID:"_MEDTOADD("DrugID")_")"
;D FILE^C0PNVA(C0PDFN,ORDIEN,"",DOSAGE,ROUTE,SCHEDULE,START,C0PDUZ,COMMENT)
QUIT

385
p/C0PREFIL.m Normal file
View File

@ -0,0 +1,385 @@
C0PREFIL ; ERX/GPL - eRx Refill utilities ; 5/9/12 12:03am
;;1.0;C0P;;Apr 25, 2012;Build 103
;Copyright 2009,2010 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.
TESTREQ(ZDUZ,ZDFN) ; TEST REFILL REQUEST
I '$D(ZDFN) S ZDFN=""
D REFREQ("ZG",ZDUZ,ZDFN)
W !
ZWRITE C0PRXML
Q
;
REFREQ(GRTN,IDUZ,IDFN) ; MAKE A WEB SERVICE CALL TO GENERATE A REFIL REQUEST
;
N GPL,C0PFARY,GVOR
D ENCREQ("GPL",IDUZ,IDFN)
S GVOR("XMLIN")=GPL
S GVOR("ORIG-FILL-DATE")=""
S GVOR("CREATE-MED-YN")="0"
;D EN^C0PMAIN("GG","GURL",IDUZ,IDFN,"GENREFILL","GVOR")
D INITXPF^C0PWS2("C0PFARY")
D SOAP^C0PWS2("GRTN","GENREFILL",IDUZ,IDFN,"GVOR")
;D SOAP^C0CSOAP("GRTN","GENREFILL",,,"GG","C0PFARY") ;
Q
;
ENCREQ(ZRTN,ZDUZ,ZDFN) ; ENCODE AN NCSCRIPT RENEWAL REQUEST
;
D GENTEST("GPL","GURL",ZDUZ,ZDFN,1)
;S ZI=""
;S GPL(1)="RxInput="_GPL(1)
S ZI=0 ;
;F S ZI=$O(GPL(ZI)) Q:ZI="" D ; MAKE IT XML SAFE
;. S GPL(ZI)=$$SYMENC^MXMLUTL(GPL(ZI))
;. W !,GPL(ZI)
S ZI=0
S G=""
K GPL(0) ; GET RID OF LINE COUNT
F S ZI=$O(GPL(ZI)) Q:ZI="" D ;
. S G=G_GPL(ZI)
S @ZRTN=$$ENCODE^RGUTUU(G)
;S @ZRTN=G
Q
;
CERTTEST ; GENERATE XML FILES FOR NEWCROP CERTIFICATION
;
N ZII
S ZDFN=18 ; TEST PATIENT TO USE
F ZII=154,155,156,157 D ; IENS OF SUBSCRIBER PROFILES
. D CERTONE(ZII,ZDFN)
Q
;
CERTONE(ZI,ZDFN) ; GENERATE ONE XML FILE
N ZN
D EN^C0PMAIN("C0PG1","G2",ZI,ZDFN) ; GET THE NCSCRIPT
S ZN=$P($P(^VA(200,ZI,0),U,1),",",2) ; GIVEN NAME OF USER
; ON OUR SYSTEM THESE ARE ERX,DOCTOR ERX,MID-LEVEL ERX,NURSE AND ERX,MANAGER
S ZN=ZN_".xml" ; APPEND .xml extension
K C0PG1(0)
S ZDIR=^TMP("C0CCCR","ODIR")
W !,$$OUTPUT^C0CXPATH("C0PG1(1)",ZN,ZDIR)
Q
;
GENTEST(RTNXML,RTNURL,ZDUZ,ZDFN,ZFILE) ; GENERATE A TEST
; CLICK-THROUGH HTLM FILE FOR
; GENERATING REFILL REQUESTS , XML IS RETURNED IN RTN,PASSED BY NAME
; IF ZFILE IS 1, THE FILE IS WRITTEN TO HOST FILE
D EN^C0PMAIN("C0PG1","G2",ZDUZ,ZDFN) ; GET THE NCSCRIPT
;D GETMEDS("G6",ZDFN) ;GET MEDICATIONS
;D QUERY^C0CXPATH("G6","//NewPrescription[1]","G7") ;JUST THE FIRST ONE
;D INSERT^C0CXPATH("C0PG1","G7","//NCScript")
K C0PG1(0)
M @RTNXML=C0PG1 ;
S ZDIR=^TMP("C0CCCR","ODIR")
I $G(ZFILE)=1 W $$OUTPUT^C0CXPATH("C0PG1(1)","REFILL-"_ZDFN_".xml",ZDIR)
Q
;
GETMEDS(OUTARY,ZDFN) ; GET THE PATIENT'S MEDS AND PUT INTO XML
;
N ZG,ZG2,ZB,ZN
S DEBUG=0
D GETTEMP^C0PWS2("ZG","OUTMEDS") ;GET THE MEDICATIONS TEMPLATE
D SOAP^C0PWS2("ZG2","GETMEDS",$$PRIMARY^C0PMAIN(),ZDFN) ; GET MEDS
I '$D(ZG2) Q ; SHOULDN'T HAPPEN
I ZG2(1,"Status")'="OK" D Q ; BAD RETURN FROM WEB SERVER
. W $G(ZG2(1,"Message")),!
N ZI S ZI=""
S ZN=$NA(^TMP("C0PREFIL",$J))
K @ZN
F S ZI=$O(ZG2(ZI)) Q:ZI="" D ; FOR EACH MED
. N ZV
. S ZV=$NA(@ZN@("DATA",ZI))
. S ZX=$NA(@ZN@("XML",ZI))
. S @ZV@("dispenseNumber")=$G(ZG2(ZI,"Dispense"))
. S @ZV@("dosage")="Take "_$G(ZG2(ZI,"DosageNumberDescription"))_" "_$G(ZG2(ZI,"Route"))_" "_$G(ZG2(ZI,"DosageFrequencyDescription"))
. S @ZV@("drugIdentifier")=ZG2(ZI,"DrugID")
. S @ZV@("drugIdentifierType")="FDB"
. S @ZV@("pharmacistMessage")="No childproof caps please"
. S @ZV@("pharmacyIdentifier")=1231212
. S @ZV@("refillCount")=ZG2(ZI,"Refills")
. S @ZV@("substitution")="SubstitutionAllowed"
. D MAP^C0CXPATH("ZG",ZV,ZX)
. D QUEUE^C0CXPATH("ZB",ZX,2,$O(@ZX@(""),-1))
D BUILD^C0CXPATH("ZB",OUTARY)
K @ZN ;CLEAN UP
Q
;
;B
;
;D GET^C0PCUR(.ZG2,ZDFN) ; GET THE MEDS FOR THIS PATIENT
;D EXTRACT^C0CALERT("ZG",ZDFN,"ZG2","ALGYCBK^C0PALGY3(ALTVMAP,A1)")
S ZN=$O(ZR(""),-1) ;NUMBER OF LINES IN OUTPUT
D QUEUE^C0CXPATH("ZB","ZG2",2,ZN-1)
D BUILD^C0CXPATH("ZB",OUTARY)
Q
;
RGUIDS(ZARY,ZDUZ) ; RETURNS AN ARRAY OF ALL REFILL REQUEST GUIDS FOR
; DUZ ZDUZ. ZARY IS PASSED BY NAME
; FORMAT IS @ZARY@("GUID")=IEN
; THIS ROUTINE IS REUSED FOR THE STATUS ROUTINE - INCOMPLETE ORDERS
N ZI,ZJ,ZK,ZL,ZM,ZN
S ZI=0
;F S ZI=$O(^XTV(8992.1,"R",ZDUZ,ZI)) Q:ZI="" D ; ALL ALERT FOR DUZ
F S ZI=$O(^XTV(8992,ZDUZ,"XQA",ZI)) Q:ZI="" D ; USE XQA MULTIPLE
. S ZL=^XTV(8992,ZDUZ,"XQA",ZI,0) ;
. S ZM=$P(ZL,U,2) ; RECORD ID
. S ZN=$O(^XTV(8992.1,"B",ZM,"")) ;IEN OF ALERT TRACKING RECORD
. S ZK=$$GET1^DIQ(8992.1,ZN_",",.03)
. I ZK'["OR,1130" Q ; NOT OUR PACKAGE - ALL ERX ALERTS START WITH 1130
. ; 11305 IS FOR REFILLS
. ; 11306 IS FOR INCOMPLETE ORDERS
. S ZJ=""
. S ZJ=$$GET1^DIQ(8992.1,ZN_",",2)
. I ZJ="" Q
. ; FOR RENEWALS (11305) NEED TO PULL THE GUID OUT - IT IS THE FIRST PIECE
. ; OTHERWISE USE THE ENTIRE STRING. FOR INCOMPLETE ORDERS THIS WILL
. ; INCLUDE THE MED AND PRESCRIPTION DATE
. I ZK["OR,11305" S ZJ=$P(ZJ,"^",1) ; FIRST PIECE IS THE GUILD GUID^DOB^SEX
. S @ZARY@(ZJ)=ZN
Q
;
EN ; BATCH ENTRY POINT FOR REFILL (RENEWAL) STATUS AND FAILEDFAX CHECKING
D REFILL
K ZRSLT
;D STATUS ; ALSO RUN CHECK FOR INCOMPLETE ORDERS
D FAILFAX ; ALSO RUN CHECK FOR FAILED FAXES
; smh - C0PTRAK depends on code that's not available... won't use.
; D RUNAWAY^C0PTRAK ; kill runaway jobs gpl 4/19/2012; smh comment out 5/9/2012
Q
;
; TEST Lines below not intended for End Users. Programmers only.
; BEWARE ZWRITE SYNTAX. It may not work in other M Implementations.
SHOW ; SHOW THE CURRENT REFILL ALERTS ON THE SYSTEM
ZWRITE ^XTV(8992,"AXQAN","OR,0,11305",*)
Q
;
REFILL ; PULL REFILL REQUESTS AND POST ALERTS
;
N ZDUZ ; USER NUMBER UNDER WHICH WE BUILD THE WEB SERVICE CALL
N ZDFN ; PATIENT NUMBER USED TO BUILD THE WEB SERVICE CALL
S ZDUZ=$$PRIMARY^C0PMAIN() ; PRIMARY ERX USER FOR BATCH CALLS
;S ZDUZ=DUZ ; SHOULD CHANGE THIS FOR PRODUCTION TO A "BATCH" USER
S ZDFN="" ; NO PATIENT NEEDED FOR THESE CALLS
; S ZDFN=18 ; SHOULD NOT NEED THIS BE MAKE THE CALL - FIX IN EN^C0PMAIN
N ZRSLT
D SOAP^C0PWS2("ZRSLT","REFILLS",ZDUZ,ZDFN) ; WS CALL TO RETURN REFILS
;S XXX=YYY ;
I $G(ZRSLT(1,"Status"))'="OK" Q ; NO ROWS WERE RETURNED
I $G(ZRSLT(1,"RowCount"))=0 Q ; NO ROWS WERE RETURNED
D NOTIPURG^XQALBUTL(11305) ; DELETE ALL CURRENT REFILL ALERTS
S C0PNPIF=$$GET1^DIQ(C0PAF,C0PACCT_",",8,"I") ; LEGACY FLAG TO USE NPI FOR SID
N ZI S ZI=0
N ZAPACK S ZAPACK="OR" ; ALERT PACKAGE CODE
N ZADFN S ZADFN=0 ; DFN TO ASSOCIATE ALERT WITH - WE DON'T KNOW THIS
N ZACODE S ZACODE=11305 ; IEN TO OE/RR NOTIFICATIONS file for eRx Refills
F S ZI=$O(ZRSLT(ZI)) Q:+ZI=0 D ; FOR EACH RETURNED REFILL REQUEST
. N ZSID S ZSID=ZRSLT(ZI,"ExternalDoctorId") ; NPI FOR SUBSCRIBER
. I C0PNPIF'=1 S ZDUZ=$O(^VA(200,"AC0PSID",ZSID,"")) ; GUID SID
. E S ZDUZ=$O(^VA(200,"C0PNPI",ZSID,"")) ; DUZ FOR SUBSCRIBER
. S ZRSLT("DUZ",ZDUZ,ZI)=""
N ZJ S ZJ=""
F S ZJ=$O(ZRSLT("DUZ",ZJ)) Q:ZJ="" D ; FOR EACH PROVIDER
. N ZGUIDS
. D RGUIDS("ZGUIDS",ZJ) ; GET ARRAY OF CURRENT ACTIVE GUIDS
. S ZI=""
. F S ZI=$O(ZRSLT("DUZ",ZJ,ZI)) Q:ZI="" D ; FOR EACH REQUEST
. . N ZRRG S ZRRG=ZRSLT(ZI,"RenewalRequestGuid") ;renewal request number
. . I $D(ZGUIDS(ZRRG)) D Q ; THIS REQUEST IS A DUPLICATE, SKIP IT
. . . W ZRRG_" IS A DUP",!
. . N ZDATE S ZDATE=$P(ZRSLT(ZI,"ReceivedTimestamp")," ",1) ;DATE RECEIVED
. . I $G(^TMP("C0P","TestNoMatch"))=1 D ;
. . . S ZRSLT(ZI,"PatientMiddleName")="XXX" ;TESTING NO MATCH REMOVE ME
. . ;I DUZ=135 S ZRSLT(ZI,"PatientMiddleName")="Uta" ;TESTING NO MATCH REMOVE
. . N ZPAT S ZPAT=$G(ZRSLT(ZI,"PatientLastName"))_","_$G(ZRSLT(ZI,"PatientFirstName")) ; PATIENT NAME LAST,FIRST
. . I $G(ZRSLT(ZI,"PatientMiddleName"))'="" S ZPAT=ZPAT_" "_$G(ZRSLT(ZI,"PatientMiddleName"))
. . S ZDOB=$G(ZRSLT(ZI,"PatientDOB")) ;patient date of birth
. . S ZSEX=$G(ZRSLT(ZI,"PatientGender")) ;patient gender
. . S ZADFN=$$PATMAT(ZPAT,ZDOB,ZSEX) ; TRY AND MATCH THE PATIENT
. . ;W "DFN="_ZADFN," ",ZI,!
. . N ZXQAID S ZXQAID=ZAPACK_","_ZADFN_","_ZACODE ; FORMAT FOR P1 OF XQAID
. . N ZMED S ZMED=ZRSLT(ZI,"DrugInfo")
. . ;S XQA(ZDUZ)="" ; WHO TO SEND THE ALERT TO
. . I '$D(^TMP("C0P","AlertVerify")) S XQA(ZJ)="" ; WHO TO SEND THE ALERT TO
. . E D ; AlertVerify sends alerts only to testers, not recipients
. . . ; use this when installing eRx to verify ewd installation
. . . N ZZZ S ZZZ=""
. . . F S ZZZ=$O(^TMP("C0P","AlertVerify",ZZZ)) Q:ZZZ="" D ; WHICH DUZ
. . . . S XQA(ZZZ)="" ; MARK THIS USER TO RECIEVE ALERTS
. . ;S XQA(135)="" ; ALWAYS SEND TO GPL
. . ;S XQA(148)="" ; ALWAYS SEND TO RICH
. . N ZP6 ; STRING THAT CPRS WILL RETURN FOR MATCHING
. . I ZADFN=0 D ; NO MATCH
. . . S XQAMSG="no match: ): [eRx] "_ZPAT_" Renewal request for "_ZMED
. . . S ZP6=ZPAT_" Renewal request for "_ZMED
. . E D ;
. . . S XQAMSG=ZPAT_": ): [eRx] Renewal request for "_ZMED
. . . S ZP6="Renewal request for "_ZMED
. . ;S XQAMSG=$E(XQAMSG,1,70) ; TRUNCATE TO 70 CHARS
. . S XQAID=ZXQAID ; PACKAGE IDENTIFIER
. . ;S XQADATA=ZRRG ; THE GUID OF THE REQUEST. NEEDED TO PROCESS THE ALERT
. . S XQADATA=ZRRG_"^"_ZDOB_"^"_ZSEX ; SAVE DOB AND SEX WITH GUID
. . W "SENDING",XQAID_" "_XQADATA,!
. . D SETUP^XQALERT ; MAKE THE CALL TO SET THE ALERT
. . HANG 1 ; NEED TO MAKE SURE TIME STAMP IS UNIQUE
K ZRSLT
;D STATUS ; ALSO RUN CHECK FOR INCOMPLETE ORDERS
;D FAILFAX ; ALSO RUN CHECK FOR FAILED FAXES
Q
;
PATMAT(ZNAME,INDOB,INSEX) ;EXTRINSIC TO TRY AND MATCH THE PATIENT
; RETURNS ZERO IF NO EXACT MATCH IS FOUND
N ZP
S ZP=$O(^DPT("B",ZNAME,""))
I ZP="" Q 0 ; EXACT MATCH NOT FOUND ON NAME
; CHECK DATE OF BIRTH
;W "CHECKING DATE OF BIRTH",!
N DOB
S DOB=$$GET1^DIQ(2,ZP_",",.03,"I") ; PATIENT'S DATE OF BIRTH IN VISTA
N ZD ;INCOMING DATE OF BIRTH IS IN YYYYMMDD FORMAT
S ZD=($E(INDOB,1,4)-1700)_$E(INDOB,5,8) ; DATE OF BIRTH CONVERTED TO FM FORMAT
;W ZD_" "_DOB,!
I +ZD'=+DOB Q 0 ; DATE OF BIRTH DOES NOT MATCH
;
; CHECK GENDER
;W "CHECKING GENDER",!
N GENDER
S GENDER=$$GET1^DIQ(2,ZP_",",.02,"I") ; PATIENT'S GENDER IN VISTA
;W GENDER_INSEX,!
I GENDER'=INSEX Q 0 ;GENDER DOESN'T MATCH
Q ZP
;
STATUS ; BATCH CALL TO RETRIEVE ERX ACCOUNT STATUS
; RETURNS UNFINISHED ORDERS FOR ALL PROVIDERS
; AND SENDS STATUS ALERTS
N VOR
S VOR("STATUS-SECTION-TYPE")="AllDoctorReview"
S VOR("SORT-ORDER")="A"
S VOR("INCLUDE-SCHEMA")="N"
S ZDUZ=$$PRIMARY^C0PMAIN() ; PRIMARY ERX USER FOR BATCH CALLS
K ZRSLT
; D SOAP^C0PWS1("ZRSLT","STATUS",ZDUZ,"","VOR")
D SOAP^C0PWS2("ZRSLT","STATUS",ZDUZ,"","VOR")
I '$D(ZRSLT) Q ; SHOULDN'T HAPPEN
I $G(ZRSLT(1,"DrugInfo"))="" Q ; NO ROWS
S C0PNPIF=$$GET1^DIQ(C0PAF,C0PACCT_",",8,"I") ; LEGACY FLAG TO USE NPI FOR SID
N ZI S ZI=0
N ZAPACK S ZAPACK="OR" ; ALERT PACKAGE CODE
N ZADFN S ZADFN=0 ; DFN TO ASSOCIATE ALERT WITH - WE DON'T KNOW THIS
N ZACODE S ZACODE=11306 ; IEN TO OE/RR NOTIFICATIONS file for eRx incomplete
; orders
F S ZI=$O(ZRSLT(ZI)) Q:+ZI=0 D ; FOR EACH RETURNED REFILL REQUEST
. N ZSID S ZSID=$G(ZRSLT(ZI,"ExternalDoctorId")) ; NPI FOR SUBSCRIBER
. I ZSID="" Q ; NO EXTERNAL ID FOR THIS STATUS
. I C0PNPIF'=1 S ZDUZ=$O(^VA(200,"AC0PSID",ZSID,"")) ; GUID SID
. E S ZDUZ=$O(^VA(200,"C0PNPI",ZSID,"")) ; DUZ FOR SUBSCRIBER
. S ZRSLT("DUZ",ZDUZ,ZI)=""
N ZJ S ZJ=""
D RMSTATUS ; REMOVE ALL STATUS ALERTS
F S ZJ=$O(ZRSLT("DUZ",ZJ)) Q:ZJ="" D ; FOR EACH PROVIDER
. N ZGUIDS
. D RGUIDS("ZGUIDS",ZJ) ; GET ARRAY OF CURRENT ACTIVE ALERTS
. S ZI=""
. F S ZI=$O(ZRSLT("DUZ",ZJ,ZI)) Q:ZI="" D ; FOR EACH REQUEST
. . N ZRRG S ZRRG=$G(ZRSLT(ZI,"DrugInfo")) ; first piece of XQDATA
. . S $P(ZRRG,"^",2)=$G(ZRSLT(ZI,"PrescriptionDate")) ; second piece
. . I $D(ZGUIDS(ZRRG)) D Q ; THIS REQUEST IS A DUPLICATE, SKIP IT
. . . ;W ZRRG_" IS A DUP",!
. . I ZRRG="^" D ERROR^C0PMAIN(",U113059004,",$ST($ST,"PLACE"),"ERX-NOT","Notification Error") QUIT
. . N ZDATE S ZDATE=$P($G(ZRSLT(ZI,"PrescriptionDate"))," ",1) ;
. . N ZPAT S ZPAT=$G(ZRSLT(ZI,"ExternalPatientId")) ; format PATIENTDFN
. . I ZPAT="" Q ;THIS IS AN ERROR
. . S ZADFN=$P(ZPAT,"PATIENT",2) ; EXTRACT THE DFN
. . S ZPAT=$$GET1^DIQ(2,ZADFN_",",.01) ;PATIENT'S NAME
. . ;W "DFN="_ZADFN," ",ZI,!
. . N ZXQAID S ZXQAID=ZAPACK_","_ZADFN_","_ZACODE ; FORMAT FOR P1 OF XQAID
. . N ZMED S ZMED=ZRSLT(ZI,"DrugInfo")
. . ;S XQA(ZDUZ)="" ; WHO TO SEND THE ALERT TO
. . S XQA(ZJ)="" ; WHO TO SEND THE ALERT TO
. . ;S XQA(135)="" ; ALWAYS SEND TO GPL
. . ;S XQA(148)="" ; ALWAYS SEND TO RICH
. . N ZP6 ; STRING THAT CPRS WILL RETURN FOR MATCHING
. . I ZADFN=0 D ; NO MATCH
. . . S XQAMSG="no match: ): [eRx] "_ZPAT_" Incomplete Order for "_ZMED
. . . S ZP6=ZPAT_" Incomplete Order for "_ZMED
. . E D ;
. . . S XQAMSG=ZPAT_": ): [eRx] Incomplete Order for "_ZMED
. . . S ZP6="Incomplete Order for "_ZMED
. . ;S XQAMSG=$E(XQAMSG,1,70) ; TRUNCATE TO 70 CHARS
. . S XQAID=ZXQAID ; PACKAGE IDENTIFIER
. . S XQADATA=ZRRG ; THE GUID OF THE REQUEST. NEEDED TO PROCESS THE ALERT
. . D SETUP^XQALERT ; MAKE THE CALL TO SET THE ALERT
Q
;
RMSTATUS ; DELETES ALL STATUS ALERTS FOR ALL USERS (THEY WILL BE
; RESTORED NEXT TIME STATUS^C0PREFIL IS RUN - IN ERX BATCH
D NOTIPURG^XQALBUTL(11306) ;
W !,"ALL ERX STATUS ALERTS HAVE BEEN DELETED"
Q
;
FAILFAX ; BATCH CALL TO RETRIEVE ERX FAILED FAX STATUS
; RETURNS A COUNT OF FAILED FAXES AND AN ARRAY OF PATIENTS
N VOR,ZRSLT
S VOR("STATUS-SECTION-TYPE")="FailedFax"
;S VOR("ACCOUNT-PARTNERNAME")="demo"
S VOR("SORT-ORDER")="A"
S VOR("INCLUDE-SCHEMA")="N"
S ZDUZ=$$PRIMARY^C0PMAIN() ; PRIMARY ERX USER FOR BATCH CALLS
D SOAP^C0PWS1("ZRSLT","STATUS",ZDUZ,"","VOR")
N ZCOUNT
S ZCOUNT=$O(ZRSLT(""),-1) ; HOW MANY FAILED FAXES
I +ZCOUNT=0 Q ; NO FAILED FAXES
;I $G(ZRSLT(1,"RowCount"))=0 Q ; NO FAILED FAXES
;I $G(ZRSLT(1,"RowCount"))="" Q ; SHOULD NOT HAPPEN
N XQA,XQAMSG,XQAID,XQAKILL
S XQAID="C0P" ; GOING TO FIRST KILL ALL FAILED FAX ALERTS
D DELETEA^XQALERT ; KILL ALL FAILED FAX ALERTS
S XQA("G.ERX HELP DESK")=""
;S XQA(135)=""
S XQAID="C0P"
S XQAMSG="eRx: "_ZCOUNT_" Failed Faxes on ePrescribing"
D SETUP^XQALERT ; CREATE NEW FAILED FAX ALERTS TO THE MAILGROUP
Q
;
RUN ; USED TO PROCESS AN ALERT. THIS ROUTINE IS LISTED IN
; 0E/RR CPRS NOTIFICATIONS AS THE ROUTINE TO RUN TO PROCESS
; A C0P ERX ALERT
W "MADE IT TO RUN C0PREFIL",!
W XQADATA
; B
Q
;
GETALRT(ZARY,ZID) ; LOOKS UP AN ALERT BY USING THE "RECORDID" FROM CPRS,
; PASSED BY VALUE IN ZID. RESULTS ARE RETURNED IN ZARY, PASSED BY NAME
;N ZIEN
;S ZIEN=$O(^XTV(8992.1,"B",ZID,"")) ;IEN IN THE ALERT TRACKING FILE
;I ZIEN="" W "ERROR RETRIEVING ALERT",! Q ;
D GETN^C0CRNF(ZARY,8992.1,ZID,"B") ; GET ALL THE ALERT FIELDS
; THE FORMAT IS @ZARY@("DATA FOR PROCESSING")="FILE^FIELD^VALUE"
; ALL POPULATED FIELDS (BUT NOT SUBFILES) ARE RETURNED
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

121
p/C0PRXNRD.m Normal file
View File

@ -0,0 +1,121 @@
C0PRXNRD ; VEN/SMH - eRx: Routine to Read RxNorm files; 12/06/09 12:25am
;;0.1;C0P;nopatch;noreleasedate;Build 1
W "No entry from top" Q
;
CONFN() Q 1130590011.001
SRCFN() Q 1130590012.003
;
IMPORT(PATH)
I PATH="" QUIT
D READSRC(PATH),READCON(PATH,1)
QUIT
;
DELFILED(FN) ; Delete file data; PEP procedure; only for RxNorm files
; FN is Filenumber passed by Value
D CLEAN^DILF ; Clean FM variables
N ROOT S ROOT=$$ROOT^DILFD(FN,"",1) ; global root
N ZERO S ZERO=@ROOT@(0) ; Save zero node
S $P(ZERO,U,3,9999)="" ; Remove entry # and last edited
K @ROOT ; Kill the file -- so sad!
S @ROOT@(0)=ZERO ; It riseth again!
QUIT
GETLINES(PATH,FILENAME) ; Get number of lines in a file
D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
U IO
N I
F I=1:1 R LINE Q:$$STATUS^%ZISH
D CLOSE^%ZISH("FILE")
Q I-1
READCON(PATH,INCRES) ; Open and read concepts file: RXNCONSO.RRF; EP
; PATH ByVal, path of RxNorm files
; INCRES ByVal, include restricted sources. 1 for yes, 0 for no
I PATH="" QUIT
S INCRES=+$G(INCRES) ; if not passed, becomes zero.
N FILENAME S FILENAME="RXNCONSO.RRF"
D DELFILED($$CONFN) ; delete data
N LINES S LINES=$$GETLINES(PATH,FILENAME)
D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
IF POP D EN^DDIOL("Error reading file..., Please check...") G EX
N C0CCOUNT
F C0CCOUNT=1:1 D Q:$$STATUS^%ZISH
. U IO
. N LINE R LINE
. IF $$STATUS^%ZISH QUIT
. I '(C0CCOUNT#1000) U $P W C0CCOUNT," of ",LINES," read ",! U IO ; update every 1000
. N RXCUI,RXAUI,SAB,TTY,CODE,STR ; Fileman fields numbers below
. S RXCUI=$P(LINE,"|",1) ; .01
. S RXAUI=$P(LINE,"|",8) ; 1
. S SAB=$P(LINE,"|",12) ; 2
. ; If the source is a restricted source, decide what to do based on what's asked.
. N SRCIEN S SRCIEN=$$FIND1^DIC($$SRCFN,"","QX",SAB,"B") ; SrcIEN in RXNORM SOURCES file
. N RESTRIC S RESTRIC=$$GET1^DIQ($$SRCFN,SRCIEN,14,"I") ; 14 is restriction field; values 0-4
. ; If RESTRIC is zero, then it's unrestricted. Everything else is restricted.
. ; If user didn't ask to include restricted sources, and the source is restricted, then quit
. I 'INCRES,RESTRIC QUIT
. S TTY=$P(LINE,"|",13) ; 3
. S CODE=$P(LINE,"|",14) ; 4
. S STR=$P(LINE,"|",15) ; 5
. ; Remove embedded "^"
. S STR=$TR(STR,"^")
. ; Convert STR into an array of 80 characters on each line
. N STRLINE S STRLINE=$L(STR)\80+1
. ; In each line, chop 80 characters off, reset STR to be the rest
. N J F J=1:1:STRLINE S STR(J)=$E(STR,1,80) S STR=$E(STR,81,$L(STR))
. ; Now, construct the FDA array
. N RXNFDA
. S RXNFDA($$CONFN,"+1,",.01)=RXCUI
. S RXNFDA($$CONFN,"+1,",1)=RXAUI
. S RXNFDA($$CONFN,"+1,",2)=SAB
. S RXNFDA($$CONFN,"+1,",3)=TTY
. S RXNFDA($$CONFN,"+1,",4)=CODE
. N RXNIEN S RXNIEN(1)=C0CCOUNT
. D UPDATE^DIE("","RXNFDA","RXNIEN")
. I $D(^TMP("DIERR",$J)) D EN^DDIOL("ERROR") G EX
. ; Now, file WP field STR
. D WP^DIE($$CONFN,C0CCOUNT_",",5,,$NA(STR))
EX D CLOSE^%ZISH("FILE")
QUIT
READSRC(PATH) ; Open the read RxNorm Sources file: RXNSAB.RRF
I PATH="" QUIT
N FILENAME S FILENAME="RXNSAB.RRF"
D DELFILED($$SRCFN) ; delete data
D OPEN^%ZISH("FILE",PATH,FILENAME,"R")
IF POP W "Error reading file..., Please check...",! G EX3
F I=1:1 Q:$$STATUS^%ZISH D
. U IO
. N LINE R LINE
. IF $$STATUS^%ZISH QUIT
. U $P W I,! U IO ; Write I to the screen, then go back to reading the file
. N VCUI,RCUI,VSAB,RSAB,SON,SF,SVER,SRL,SCIT ; Fileman fields numbers below
. S VCUI=$P(LINE,"|",1) ; .01
. S RCUI=$P(LINE,"|",2) ; 2
. S VSAB=$P(LINE,"|",3) ; 3
. S RSAB=$P(LINE,"|",4) ; 4
. S SON=$P(LINE,"|",5) ; 5
. S SF=$P(LINE,"|",6) ; 6
. S SVER=$P(LINE,"|",7) ; 7
. S SRL=$P(LINE,"|",14) ; 14
. S SCIT=$P(LINE,"|",25) ; 25
. ; Remove embedded "^"
. S SCIT=$TR(SCIT,"^")
. ; Convert SCIT into an array of 80 characters on each line
. ; In each line, chop 80 characters off, reset SCIT to be the rest
. N SCITLINE S SCITLINE=$L(SCIT)\80+1
. F J=1:1:SCITLINE S SCIT(J)=$E(SCIT,1,80) S SCIT=$E(SCIT,81,$L(SCIT))
. ; Now, construct the FDA array
. N RXNFDA
. S RXNFDA($$SRCFN,"+"_I_",",.01)=VCUI
. S RXNFDA($$SRCFN,"+"_I_",",2)=RCUI
. S RXNFDA($$SRCFN,"+"_I_",",3)=VSAB
. S RXNFDA($$SRCFN,"+"_I_",",4)=RSAB
. S RXNFDA($$SRCFN,"+"_I_",",5)=SON
. S RXNFDA($$SRCFN,"+"_I_",",6)=SF
. S RXNFDA($$SRCFN,"+"_I_",",7)=SVER
. S RXNFDA($$SRCFN,"+"_I_",",14)=SRL
. D UPDATE^DIE("","RXNFDA")
. I $D(^TMP("DIERR",$J)) U $P W "ERR" G EX
. ; Now, file WP field SCIT
. D WP^DIE($$SRCFN,I_",",25,,$NA(SCIT))
EX3 D CLOSE^%ZISH("FILE")
Q

76
p/C0PSMEDS.m Normal file
View File

@ -0,0 +1,76 @@
C0PSMEDS ; ERX/GPL - Utilities for eRx SendMeds; 3/1/11
;;1.0;C0P;;Apr 25, 2012;Build 103
;Copyright 2011 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
;
ADD(RTNXML,G6) ; ADD SENDMEDS TO THE NCSCRIPT XML
N GEND,ZG1,G5,GBLD
M ZG1=@RTNXML
S GEND=$O(ZG1(""),-1)-1
D QUEUE^C0CXPATH("GBLD","ZG1",1,GEND) ; NCSCRIPT.. UP TO </NCScript>
D QUEUE^C0CXPATH("GBLD",G6,1,$O(@G6@(""),-1)) ; ADD THE MEDS
D QUEUE^C0CXPATH("GBLD","ZG1",GEND+1,GEND+1) ;END OF NCSCRIPT
D BUILD^C0CXPATH("GBLD","G5") ; BUILD THE CONTENTS FROM THE BUILD LIST
K @RTNXML
M @RTNXML=G5 ;
Q
;
FREETXT(RXML,ZDUZ,ZDFN) ; ADD FREE TEXT MEDS FOR PATIENT ZDFN TO RXML,
; PASSED BY NAME; ZDUZ IS PASSED TO RESOLVE THE TEMPLATE
N ZTID,ZMEDS,ZI,ZN,ZTMP,ZVARS,ZBLD,ZNM
S ZTID=$$RESTID^C0PWS1(ZDUZ,"FREE TEXT MEDS") ;GET TEMPLATE ID
D GET^C0PCUR(.ZMEDS,ZDFN) ; GET THE PATIENT'S CURRENT MEDS
S ZN=$O(ZMEDS(""),-1) ; COUNT OF MEDS
I +ZN=0 Q ; NO MEDS, QUIT
F ZI=1:1:ZN D ; FOR EACH MED
. N ZCMT
. S ZCMT=$G(ZMEDS(ZI,"COMMENTS",1))
. I ZCMT["E-Rx" Q ; SKIP eRx MEDS
. I ZCMT["Received by" Q ; SKIP eRx Meds
. I $P(ZMEDS(ZI,0),"^",9)'="ACTIVE" Q ; ONLY WANT ACTIVE DRUGS
. ; GET TYPE OF DRUG
. N ZTYP
. S ZTYP=$P($P(ZMEDS(ZI,0),"^",1),";",2) ; SHOULD BE AN I OR O
. I ZTYP="I" Q ; DON'T WANT INPATIENT MEDS
. S ZNM=$NA(ZTMP(ZI)) ; PLACE TO PUT THIS MED XML
. N ZDATE
. S ZDATE=$G(ZMEDS(ZI,"START"))
. I ZDATE'="" D ; TRANSLATE FM DATE TO YYYYMMDD
. . S ZDATE=$$FMDTOUTC^C0CUTIL(ZDATE,"D")
. . S ZDATE=$TR(ZDATE,"-") ;REMOVE DASHES FROM DOB
. I ZDATE="" S ZDATE=""
. S ZVARS("date")=ZDATE
. S ZVARS("dispenseNumber")=0
. S ZVARS("doctorName")=$P($G(ZMEDS(ZI,"P",0)),"^",2)
. S ZVARS("drug")=$P(ZMEDS(ZI,0),"^",2) ; NAME OF THE MED
. N ZEXID
. S ZEXID=$G(ZMEDS(ZI,"NVAIEN"))
. I ZEXID="" S ZEXID="MED_"_$G(ZMEDS(ZI,"DRUG")) ; THE MED NUMBER
. S ZVARS("externalId")=ZEXID
. S ZVARS("prescriptionType")="reconcile"
. S ZVARS("refillCount")=0
. S ZVARS("sig")=$G(ZMEDS(ZI,"SIG",1,0))
. S ZVARS("sig")=$TR(ZVARS("sig"),"'")
. D MAP^C0PMAIN(ZNM,"ZVARS",ZTID) ; GENERATE XML FOR 1 MED
. ;B
. D QUEUE^C0CXPATH("ZBLD",ZNM,1,@ZNM@(0)) ; ADD TO BUILD LIST
I +$D(ZBLD)=0 Q ; NO NON-ERX MEDS
D BUILD^C0CXPATH("ZBLD",RXML) ; BUILD ALL THE MEDS
Q
;

351
p/C0PSUB.m Normal file
View File

@ -0,0 +1,351 @@
C0PSUB ; ERX/GPL - ERX SUBSCRIBER utilities; 5/8/12 9:51pm
;;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.
;
QUIT
EN(INARY,C0PDUZ) ; creates the array inary passed by name for subscriber
; variables, mostly from the new person file
; SUBSCRIBER-FAMILY-NAME
; SUBSCRIBER-GIVEN-NAME
; SUBSCRIBER-MIDDLE-NAME
; LOCATION-PHONE
; LOCATION-FAX
; ACCOUNT-PHONE
; ACCOUNT-FAX
; LOCATION-ADDRESS1
; LOCATION-ADDRESS2
; LOCATION-CITY
; LOCATION-ZIP
; LOCATION-ZIP4
; LOCATION-STATE
; SUBSCRIBER-LICENSE
; SUBSCRIBER-LICENSE-STATE
; SUBSCRIBER-USERROLE
; SUBSCRIBER-USER
; ACCOUNT-COUNTRY
; ACCOUNT-ADDRESS-ZIP4
; LOCATION-COUNTRY
; REQUESTED-PAGE
D FAMILY(INARY,"SUBCRIBER-FAMILY-NAME",C0PDUZ)
D GIVEN(INARY,"SUBCRIBER-GIVEN-NAME",C0PDUZ)
D MIDDLE(INARY,"SUBCRIBER-MIDDLE-NAME",C0PDUZ)
D PHONEFAX(INARY,C0PLOC) ; SETS "LOCATION-PHONE" AND "LOCATION-FAX"
D ACTPHFAX(INARY,C0PACCT) ;SETS "ACCOUNT-PHONE" AND "ACCOUNT-FAX"
D GETLOC(INARY,C0PLOC) ;SETS "LOCATION-" VARIABLES (SEE ROUTINE FOR LIST)
D STLIC(INARY,C0PDUZ,C0PACCT) ;LICENSE AND LICENSE STATE
S C0PAF=113059002 ; FILE NUMBER FOR ACCOUNT FILE
S @INARY@("ACCOUNT-PARTNERNAME")=$$GET1^DIQ(C0PAF,C0PACCT_",",3.1) ;
I @INARY@("ACCOUNT-PARTNERNAME")="" S @INARY@("ACCOUNT-PARTNERNAME")="demo"
; todo: NPs, PAs, assistants need different roles
D SETACCT(INARY,C0PDUZ) ; SET SUBSCRIBER VARIABLES
;S @INARY@("SUBSCRIBER-USERROLE")="doctor" ; BASE CASE ACCESS
;S @INARY@("SUBSCRIBER-USER")="LicensedPrescriber" ; BASE CASE ACCESS
S @INARY@("ACCOUNT-COUNTRY")="US" ;BASE CASE ACCESS
S @INARY@("ACCOUNT-ADDRESS-ZIP4")="" ;DON'T HAVE THIS
S @INARY@("LOCATION-COUNTRY")="US" ; NOT IN FILE
S @INARY@("REQUESTED-PAGE")="compose" ; DEFAULT PAG
S @INARY@("ACCOUNT-ACCOUNTID")=$$GET1^DIQ(C0PAF,C0PACCT_",",2.4)
I @INARY@("ACCOUNT-ACCOUNTID")="" S @INARY@("ACCOUNT-ACCOUNTID")="demo"
S @INARY@("ACCOUNT-NAME")=$$GET1^DIQ(C0PAF,C0PACCT_",",3)
I @INARY@("ACCOUNT-NAME")="" S @INARY@("ACCOUNT-NAME")="demo"
S @INARY@("ACCOUNT-PASSWORD")=$$GET1^DIQ(C0PAF,C0PACCT_",",3.2)
I @INARY@("ACCOUNT-PASSWORD")="" S @INARY@("ACCOUNT-PASSWORD")="demo"
;S @INARY@("SUBSCRIBER-USERTYPE")="Doctor" ; IS RESET LATER
;S @INARY@("SUBSCRIBER-USERID")="demo" ; IS RESET LATER
;N NPI S NPI=$$NPI^XUSNPI("Individual_ID",C0PDUZ)
;S @INARY@("SUBSCRIBER-SID")=+NPI ; FOR NOW
;
Q
;
ACTPHFAX(RARY,ZACCT) ;SET ACCOUNT PHONE AND FAX FROM ACCOUNT FILE
; ZACCT IS A POINTER TO THE ACCOUNT FILE
S C0PAF=113059002 ; FILE NUMBER FOR ACCOUNT FILE
S @RARY@("ACCOUNT-PHONE")=$$GET1^DIQ(C0PAF,ZACCT_",",2.2) ;PHONE NUMBER
S @RARY@("ACCOUNT-FAX")=$$GET1^DIQ(C0PAF,ZACCT_",",2.1) ; FAX NUMBER
Q
;
PHONEFAX(RARY,C0PLOC) ; SET LOCATION PHONE AND FAX INTO THE RETURN ARRAY
N PRIORITY,LOCIEN
S PRIORITY=$O(^SC(C0PLOC,"C0P","PRIORITY",""))
I PRIORITY="" W "NO LOCATION PHONE SET",! Q
S LOCIEN=$O(^SC(C0PLOC,"C0P","PRIORITY",PRIORITY,""))
S C0PLOCF=44.113059
S @RARY@("LOCATION-PHONE")=$$GET1^DIQ(C0PLOCF,LOCIEN_","_C0PLOC_",",1)
S @RARY@("LOCATION-FAX")=$$GET1^DIQ(C0PLOCF,LOCIEN_","_C0PLOC_",",2)
Q
;
GETLOC(RARY,ZLOC) ; GETS LOCATIONS VARIABLE FROM POINTER ZLOC
; TO THE HOSPITAL LOCATION FILE
; THE LOCATION ADDRESS IS FOUND IN NEW FIELDS IN THE HOSPITAL LOCATION FILE 44
; IF THESE ARE NULL, THE ADDRESS WILL BE TAKEN FROM THE INSTITUTION FILE,
; WHICH IS POINTED TO BY THE FILE 44
;
S @RARY@("LOCATION-SITEID")="LOCATION_"_ZLOC ; SITE ID
S @RARY@("LOCATION-ADDRESS1")=$$GET1^DIQ(44,ZLOC_",",113059111) ;ADDR1
I @RARY@("LOCATION-ADDRESS1")'="" D ; ADDRESS PRESENT IN 44
. S @RARY@("LOCATION-ADDRESS2")=$$GET1^DIQ(44,ZLOC_",",113059112) ;ADDR2
. S @RARY@("LOCATION-CITY")=$$GET1^DIQ(44,ZLOC_",",113059114) ;CITY
. S @RARY@("LOCATION-ZIP")=$$GET1^DIQ(44,ZLOC_",",113059116) ;ZIP
. S @RARY@("LOCATION-ZIP4")="" ;NO ZIP4
. N ZJ
. S ZJ=$$GET1^DIQ(44,ZLOC_",",113059115,"I") ;STATE
. S @RARY@("LOCATION-STATE")=$$GET1^DIQ(5,ZJ_",",1) ;STATE ABBREVIATION
E D ; TAKE THE ADDRESS FROM THE INSTITUTION FILE
. N ZI
. S ZI=$$GET1^DIQ(44,ZLOC_",",3,"I") ; POINTER TO INSTITUTION FILE
. S @RARY@("LOCATION-ADDRESS1")=$$GET1^DIQ(4,ZI_",",1.01) ;ADDR1
. S @RARY@("LOCATION-ADDRESS2")=$$GET1^DIQ(4,ZI_",",1.02) ;ADDR2
. S @RARY@("LOCATION-CITY")=$$GET1^DIQ(4,ZI_",",1.03) ;CITY
. S @RARY@("LOCATION-ZIP")=$$GET1^DIQ(4,ZI_",",1.04) ;ZIP
. S @RARY@("LOCATION-ZIP4")="" ;NO ZIP4
. N ZJ
. S ZJ=$$GET1^DIQ(4,ZI_",",.02,"I") ;STATE
. S @RARY@("LOCATION-STATE")=$$GET1^DIQ(5,ZJ_",",1) ;STATE ABBREVIATION
Q
;
SUBINIT(C0PDUZ) ;
; SUBSCRIPTIONS MULTIPLE IN NEW PERSON
S C0PAF=113059002 ; FILE NUMBER FOR ACCOUNT FILE
S C0PSUBF=200.113059 ; SUBFILE NUMBER OF C0P SUBSCRIPTION MULTIPLE
S C0PSIEN=$O(^VA(200,C0PDUZ,"C0P","B","ERX","")) ; ERX SUBFILE IEN
Q C0PSIEN
;
HASLIC(ZDUZ) ;EXTRINSIC TO CHECK IF PERSON HAS ANY STATE LICENSES
;
Q ''$O(^VA(200,ZDUZ,"PS1","B",""))
;
GLICST(ZACCT) ;EXTRINSIC WHICH RETURNS THE POINTER TO THE STATE
;WHICH IS THE PREFERED LICENSE STATE IN THE ACCOUNT PASSED IN ZACCT
S C0PAF=113059002 ; FILE NUMBER FOR ACCOUNT FILE
Q $$GET1^DIQ(C0PAF,ZACCT_",",5,"I")
;
STLIC(ZARY,ZDUZ,ZACCT) ;ADDS SUBSCRIBER-LICENSE AND SUBSCRIBER-LICENSE-STATE
; TO ZARY, PASSED BY NAME BY LOOKING IN THE STATE LICENSE MULTIPLE
; OF THE NEW PERSON FILE FOR THE PREFERED STATE AS FOUND BY GLICST ABOVE
; FROM THE ACCOUNT NUMBER ZACCT
; IF THE PREFERED STATE IS NOT FOUND, THE FIRST STATE LISTED IS USED
I '$$HASLIC(ZDUZ) D ; NEW PERSON ZDUZ HAS NO STATE LICENSES DEFINED
. S @ZARY@("SUBSCRIBER-LICENSE")="" ; NULL LICENSE
. S @ZARY@("SUBSCRIBER-LICENSE-STATE")="" ;NULL LICENSE STATE
E D ; THERE IS A LICENSE
. N ZST,ZIEN
. S ZST=$$GLICST(ZACCT) ; GET PREFERED LICENSE STATE FROM ACCOUNT FILE
. S ZIEN=$O(^VA(200,ZDUZ,"PS1","B",ZST,"")) ;IEN OF PREFERED STATE
. I ZIEN="" D ; PREFERED STATE NOT FOUND
. . ; todo: use get1^diq here instead of looping through global
. . S ZST=$O(^VA(200,ZDUZ,"PS1","B","")) ; FIRST STATE IN MULTIPLE
. . S ZIEN=$O(^VA(200,ZDUZ,"PS1","B",ZST,"")) ; IEN OF FIRST STATE
. S @ZARY@("SUBSCRIBER-LICENSE")=$$GET1^DIQ(200.541,ZIEN_","_ZDUZ_",",1) ;LIC
. ; Try this...
. ; N ZG S ZG=$$GET1^DIQ(200.541,ZIEN_","_ZDUZ_",","LICENSING STATE:ABBREVIATION")
. N ZG S ZG=$$GET1^DIQ(200.541,ZIEN_","_ZDUZ_",",.01,"I") ;STATE POINTER
. S ZG=$$GET1^DIQ(5,ZG_",",1) ; STATE ABBREVIATION
. S @ZARY@("SUBSCRIBER-LICENSE-STATE")=ZG
Q
FAMILY(RARY,TAG,C0PDUZ) ; SETS @RARY@(TAG) TO FAMILY NAME OF DUZ
;USING KERNAL ROUTINE IN CCR PACKAGE. RARY IS PASSED BY NAME.
S @RARY@(TAG)=$$FAMILY^C0CVA200(C0PDUZ)
Q
;
GIVEN(RARY,TAG,C0PDUZ) ; SETS @RARY@(TAG) TO GIVEN NAME OF SUBSCRIBER
; USING KERNAL ROUTINE IN CCR PACKAGE. RARY IS PASSED BY NAME
S @RARY@(TAG)=$$GIVEN^C0CVA200(C0PDUZ)
Q
;
MIDDLE(RARY,TAG,C0PDUZ) ; SETS @RARY@(TAG) TO MIDDLE NAME OF SUBSCRIBER
; USING KERNAL ROUTINE IN CCR PACKAGE. RARY IS PASSED BY NAME
S @RARY@(TAG)=$$MIDDLE^C0CVA200(C0PDUZ)
Q
;
STATUS(C0PDUZ,SERVICE) ; $$ Private EP - Check Prescriber's ability to use Service
; FILEMAN USES THIS CALL. Field Status in C0P Subscription Multiple is
; + a computed field.
; gpl - changed the order of this Algorithm to do NPI and DEA last
; because they are not required for all user type and roles
; Algorithm as follows:
; 1. Check existence of DEA# or Institutional DEA + VA#
; 2. Check existence of NPI
; 3. Check for at least one license in the licensure subfile in 200
; 4. Check if a C0P Subscription for SERVICE in subfile C0P in 200 exists
; 5. Check if a C0P Subscription for points to a valid account
; 6. Check if a C0P Location is defined
; 7. Make sure that the service is not disabled for the user.
; 8. Check if the pointed to location has a phone and fax number filled in.
; -- Output --
; 1^ACTIVE --> Everything is fine
; 0^NO DEA^NO NPI^NO LICENSE^NO SUBSCRIPTION^NO SUBSCRIPTION ACCOUNT^
; + NO SUBSCSRIPTION LOCATION^SUBSCSRIBER IS DISABLED^LOCATION NOT SETUP
N RETURN
S RETURN="0" ; default case
; --> step 4, see if there's an entry for the service IEN
N C0PVARS
N SERVIEN S SERVIEN=$O(^VA(200,C0PDUZ,"C0P","B",SERVICE,""))
I $L(SERVIEN)=0 S RETURN=RETURN_"^NO SUBSCRIPTION"
D:SERVIEN
. ; --> step 5, see if the service points to a valid account
. N ACCOUNT S ACCOUNT=$$GET1^DIQ(200.113059,SERVIEN_","_C0PDUZ_",",1)
. I $L(ACCOUNT)=0 S RETURN=RETURN_"^NO SUBSCSRIPTION ACCOUNT"
. ; --> step 6, see if the service points to a valid location
. ; internal will return the IEN for use in a call below.
. N LOCATION S LOCATION=$$GET1^DIQ(200.113059,SERVIEN_","_C0PDUZ_",",2,"I")
. I $L(LOCATION)=0 S RETURN=RETURN_"^NO SUBSCSRIPTION LOCATION"
. ; --> step 7, see if the user is disabled from service
. ; Internal will return 1 or 0, 1 for yes
. N DISABLED S DISABLED=$$GET1^DIQ(200.113059,SERVIEN_","_C0PDUZ_",",3,"I")
. I +DISABLED S RETURN=RETURN_"^SUBSCSRIBER IS DISABLED"
. ; --> step 8, see if at least one set of location
. ; + phone and fax numbers have been set-up
. D:LOCATION
. . N PHONE,FAX,ARY
. . D PHONEFAX("ARY",LOCATION) ; GET THE LOCATION PHONE AND FAX
. . ;S PHONE=$$GET1^DIQ(44.113059,"1,"_LOCATION_",",1) ;this doesn't work
. . ;S FAX=$$GET1^DIQ(44.113059,"1,"_LOCATION_",",2) ; because of the 1
. . S PHONE=$G(ARY("LOCATION-PHONE")) ; PHONE IF ANY
. . S FAX=$G(ARY("LOCATION-FAX")) ; FAX IF ANY
. . I ($L(PHONE)=0)!($L(FAX)=0) S RETURN=RETURN_"^LOCATION NOT SETUP"
. D SETACCT("C0PVARS",C0PDUZ) ; INITIALIZE ARRAY
. ; --> step 1: DEA
. ;N DEA S DEA=$$DEA^XUSER("",C0PDUZ)
. ;I $L(DEA)=0 S RETURN=RETURN_"^NO DEA"
. I C0PVARS("SUBSCRIBER-DEA")="NONE" D ;
. . I C0PTYPE="P" S RETURN=RETURN_"^NO DEA" ; ONLY PRESCRIBERS NEED DEA
. ; --> step 2: NPI
. ;N NPI S NPI=$$NPI^XUSNPI("Individual_ID",C0PDUZ)
. ;I +NPI<0 S RETURN=RETURN_"^NO NPI"
. I C0PVARS("SUBSCRIBER-NPI")="NONE" D ;
. . I C0PTYPE="P" S RETURN=RETURN_"^NO NPI" ; ONLY PRESCRIBERS NEED DEA
. ; --> step 3, get first license # in license multiple
. N LIC S LIC=$$HASLIC(C0PDUZ)
. I 'LIC D ;
. . I (C0PTYPE="P")!(C0PROLE="N") S RETURN=RETURN_"^NO LICENSE" ;
. . ; PRESCRIBERS AND NURSES NEED LICENSE
; If Retrun is still 0 and nothing else, then we are good.
I RETURN="0" S RETURN="1^ACTIVE"
QUIT RETURN ; <-- END $$STATUS
;
STATUS2 ; Private Procedure for interactive check of status
N DIC,X,Y,DLAYGO,DTOUT,DUOUT
S DIC=200,DIC(0)="AEMQ",DIC("A")="Select New Person: "
D ^DIC
I Y<0 QUIT
N C0PDUZ S C0PDUZ=+Y
; Then which service are we checking for
; Grab this from the DD
N DIR,X,Y,DA,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="200.113059,.01"
S DIR("A")="Select Subcription Service"
D ^DIR
I $G(DIRUT) QUIT
N C0PSERV S C0PSERV=Y
N STATUS S STATUS=$$STATUS^C0PSUB(C0PDUZ,C0PSERV)
D EN^DDIOL("Status: "_$TR($P(STATUS,U,2,99),U,", "))
QUIT
;
SETACCT(C0PRTN,C0PDUZ) ; RETURN ALL SUBSCRIBER SETTINGS FOR
; GENERATING XML AND VERIFYING A COMPLETE SETUP
; ALSO, INITIALIZE NULL FIELDS WITH DEFAULTS
; C0PRTN IS PASSED BY NAME
; C0PSERV IS USUALLY "ERX" FOR EPRESCRIBING
;
;USER TYPE
;
;P LicensedPrescriber
;S Staff
;M MidlevelPrescriber
;V SupervisingDoctor
;
;USER ROLE
;
;D doctor
;N nurse
;A admin
;M manager
;SD supervisingDoctor
;MP midlevelPrescriber
;
;Requested Page
;
;C compose
;A admin
;M manager
;S status
;ME medentry
;P patientDetail
;H maintainHealthplans
;R reports-rx-daily
;
N ZI,ZJ
D SETUP^C0PMAIN() ; INITIALIZE VARIABLES
I ERXSERVIEN="" Q ; PERSON NOT SUBSCRIBED
S C0PTYPE=$$GET1^DIQ($$F200C0P^C0PMAIN(),ERXSERVIEN_","_C0PDUZ_",",4,"I")
S C0PROLE=$$GET1^DIQ($$F200C0P^C0PMAIN(),ERXSERVIEN_","_C0PDUZ_",",4.1,"I")
S C0PPAGE=$$GET1^DIQ($$F200C0P^C0PMAIN(),ERXSERVIEN_","_C0PDUZ_",",4.2,"I")
N C0PSV ; SUPERVISING DOCTOR DUZ
S C0PSV=$$GET1^DIQ($$F200C0P^C0PMAIN(),ERXSERVIEN_","_C0PDUZ_",",6,"I")
; FIELD 6 IS SUPERVISING DOCTOR. USED FOR MIDLEVEL RENEWAL PROCESSING
I $G(C0PSV)'="" D ; IF THERE IS A SUPERVISING DOCTOR
. S @C0PRTN@("SUPERVISING-DOCTOR-DUZ")=C0PSV ; RECORD FOR LATER USE
I C0PTYPE="" D ; SUBSCRIBER TYPE NOT SET
. I C0PROLE="N" S C0PTYPE="S" ; DEFAULT FOR NURSE IS STAFF
. E S C0PTYPE="P" ; ELSE DEFAULT TYPE IS LICENSEDPRESCRIBER
. K C0PFDA
. S C0PFDA($$F200C0P^C0PMAIN,ERXSERVIEN_","_C0PDUZ_",",4)=C0PTYPE ;SET TYPE
. D UPDIE ; SET THE SUBSCRIBER TYPE
I C0PROLE="" D ; SUBSCRIBER ROLE NOT SET
. I C0PTYPE="P" S C0PROLE="D" ; DOCTOR IS DEFAULT FOR LICENSED PRESCRIBER
. E S C0PROLE="N" ; ALL OTHERS SET TO NURSE
. K C0PFDA
. S C0PFDA($$F200C0P^C0PMAIN,ERXSERVIEN_","_C0PDUZ_",",4.1)=C0PROLE ;SET ROLE
. D UPDIE ; SET THE SUBSCRIBER ROLE
I C0PPAGE="" D ;
. I C0PTYPE="P" S C0PPAGE="C" ; PRESCRIBERS TO COMPOSE PAGE
. E S C0PPAGE="P" ; ALL OTHERS DEFAULT TO PATIENT DETAIL PAGE
. K C0PFDA
. S C0PFDA($$F200C0P^C0PMAIN,ERXSERVIEN_","_C0PDUZ_",",4.2)=C0PPAGE ;SET PAGE
. D UPDIE ; SET THE REQUESTED PAGE
N ZF S ZF=$$F200C0P^C0PMAIN()
S @C0PRTN@("REQUESTED-PAGE")=$$GET1^DIQ(ZF,ERXSERVIEN_","_C0PDUZ_",",4.2)
S @C0PRTN@("SUBSCRIBER-USERROLE")=$$GET1^DIQ(ZF,ERXSERVIEN_","_C0PDUZ_",",4.1)
S @C0PRTN@("SUBSCRIBER-USERTYPE")=$$GET1^DIQ(ZF,ERXSERVIEN_","_C0PDUZ_",",4)
S C0PSID=$$GET1^DIQ(ZF,ERXSERVIEN_","_C0PDUZ_",",5)
I C0PSID="" D ; SUBSCRIBER ID NOT SET
. S C0PSID=$$UUID^C0CUTIL ; SET TO RANDOM UUID
. K C0PFDA
. S C0PFDA($$F200C0P^C0PMAIN,ERXSERVIEN_","_C0PDUZ_",",5)=C0PSID ;SET SID
. D UPDIE ; SET SUBSCRIBER ID
N NPI S NPI=+$$NPI^XUSNPI("Individual_ID",C0PDUZ)
I NPI=-1 S NPI="NONE"
S @C0PRTN@("SUBSCRIBER-NPI")=NPI
N DEA S DEA=$$DEA^XUSER("",C0PDUZ)
I $L(DEA)=0 S DEA="NONE"
S @C0PRTN@("SUBSCRIBER-DEA")=DEA
;N C0PNPIF ; NPI FOR SID LEGACY FLAG - DON'T NEW THIS, IT'S NEEDED LATER
S C0PNPIF=$$GET1^DIQ(C0PAF,C0PACCT_",",8,"I") ; LEGACY FLAG TO USE NPI FOR SID
I C0PNPIF'=1 S @C0PRTN@("SUBSCRIBER-SID")=C0PSID ; IF NO FLAG, USE GUID
E D ; IF LEGACY FLAG IS ON, USE NPI FOR SID
. S @C0PRTN@("SUBSCRIBER-SID")=NPI
. I NPI="NONE" S @C0PRTN@("SUBSCRIBER-SID")="USER"_C0PDUZ ; IF NO NPI
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

15
p/C0PTEST1.m Normal file
View File

@ -0,0 +1,15 @@
C0PTEST1 ; VEN/SMH - Scratch routine for testing ; 12/6/09 9:54pm
;;0.1;C0P;nopatch;noreleasedate
Q
; The stuff below is to walk through all entries and test test test
T0
D WALK^DICW(1130590010,"W DICWIENS,!")
Q
T1
; dicwiens
; DICWHEAD
D WALK^DICW(1130590010,"W $$GCN^C0PLKUP($P(^(0),U)),!")
Q
T2
D WALK^DICW(1130590010,"W:+DICWIENS<1000 $$RXNCUI^C0PLKUP($P(^(0),U,2)),!")
Q

128
p/C0PTRAK.m Normal file
View File

@ -0,0 +1,128 @@
C0PTRAK ;KBAZ/ZAG/GPL - eRx debugging utilities; 4/1/2012 ; 5/8/12 5:12pm
;;1.0;C0P;;Apr 25, 2012;Build 84
;Copyright 2012 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.
;
QUIT ;do not call from the top
;
;INTRP(JOB) ;send interrupt to an interactive job.
;
LOG(JOB,TAG) ;send interrupt and log results
;copied from ZJOB to here for silently interrupting one job.
N $ET,$ES S $ET="D IRTERR^ZJOB"
; shouldn't interrupt ourself, but commented out to test
;I JOB=$JOB Q 0
;We need a LOCK to guarantee commands from two processes don't conflict
N X,OLDINTRPT,TMP,ZSYSCMD,ZPATH,%J
L +^XUTL("XUSYS","COMMAND"):10 Q:'$T 0
;
S ^XUTL("XUSYS","COMMAND")="EXAM",^("COMMAND",0)=$J_":"_$H
K ^XUTL("XUSYS",JOB,"JE")
S OLDINTRP=$ZINTERRUPT,%J=$J
S TMP=0,$ZINTERRUPT="S TMP=1"
;
;convert PID for VMS systems
I $ZV["VMS" D
. S JOB=$$FUNC^%DH(JOB,8)
. S %J=$$FUNC^%DH(%J,8)
;
S ZSYSCMD="mupip intrpt "_JOB_" > /dev/null 2>&1" ; interrupt other job
I $ZV["VMS" S ZPATH="@gtm$dist:" ; VMS path
E S ZPATH="$gtm_dist/" ;Unix path
ZSYSTEM ZPATH_ZSYSCMD ; System Request
;Now send to self
; wait is too long 60>>30
H 1 S TMP=1 ; wait for interrupt, will set TMP=1
;
; Restore old $ZINTERRPT
S $ZINTERRUPT=OLDINTRP
K ^XUTL("XUSYS","COMMAND") ;Cleanup
L -^XUTL("XUSYS","COMMAND")
;get values to report back on
K ^TMP("C0PERXLOG",JOB)
M ^TMP("C0PERXLOG",JOB)=^XUTL("XUSYS",JOB) ;merge off array for reporting
S ^TMP("C0PERXLOG",JOB,"LOGPOINT")=$G(TAG)
;
;D LOG(JOB) ;create the C0PLOG
;K ^C0PTRAK(JOB) ;clean up temp log
;
QUIT ;end of INTRP
;
NEWLOG(JOB,TAG) ;report on JOB interrupted
; TAG identifies the location creating the log. it is text
K ^C0PLOG(JOB)
N VARLOG ;build variable log array for further inspection
N VARTYP S VARTYP=""
F D Q:VARTYP=""
. S VARTYP=$O(^KBAZ(JOB,VARTYP)) ;type of variable
. Q:VARTYP="" ;exit if no more variable are types found
. N VARCNT S VARCNT=""
. F D Q:'VARCNT
. . S VARCNT=$O(^KBAZ(JOB,VARTYP,VARCNT)) ;variable count
. . Q:'VARCNT ;exit if no more variables are found
. . N VAR S VAR=$G(^KBAZ(JOB,VARTYP,VARCNT)) ;get the variable
. . N VARNM S VARNM=$P(VAR,"=") ;variable name
. . N VARIABLE S VARIABLE=$P(VAR,"=",2)
. . S VARIABLE=$TR(VARIABLE,"""") ;remove the extra quotes
. . S VARLOG(VARNM)=VARIABLE ;variable
. . N %H S %H=$G(VARLOG("$HOROLOG")) ;current $H
. . N PC S PC=$G(VARLOG("IO(""CLNM"")")) ;pc/client name
. . N IP S IP=$G(VARLOG("IO(""GTM-IP"")")) ;pc/client IP address
. . N USER S USER=$G(VARLOG("DUZ")) ;current user
. . N CURPAT S CURPAT=$G(VARLOG("VALUE(2)")) ;current patient
. . ;
. . ;build the final log
. . S ^TMP("C0PERXLOG",JOB,"LOGPOINT")=$G(TAG)
. . S ^TMP("C0PERXLOG",JOB,"TIME")=$$HTE^XLFDT(%H)
. . S ^TMP("C0PERXLOG",JOB,"CLNM")=PC
. . S ^TMP("C0PERXLOG",JOB,"IP")=IP
. . S ^TMP("C0PERXLOG",JOB,"DUZ")=USER
. . S ^TMP("C0PERXLOG",JOB,"PT")=CURPAT
;
QUIT ;end of LOG
;
;
UNLOG(JOB) ; clean up a log entry
K ^TMP("C0PERXLOG",JOB)
Q
;
RUNAWAY ; called from Batch to kill runaway eRx jobs
; looks at every entry in the table looking for marked jobs to kill
; if a job is not marked, it will mark it so that next time it
; will be killed.
; This insures that jobs logged to the table have at least 15 minutes
; to unlog or they will be killed.
; this is implemented to catch and kill runaway eRX webservice calls
; uses STOP^XVJK($JOB) written by Zach Gonzales to kill jobs in GT.M linux
; gpl 4/18/2012
;
N GN,ZI
S GN=$NA(^TMP("C0PERXLOG"))
S GNOLD=$NA(^TMP("C0POLDLOG"))
S ZI=""
F S ZI=$O(@GN@(ZI)) Q:+ZI=0 D ; for every entry in the table
. I $D(@GN@(ZI,"KILLED")) Q ; job already killed
. I $D(@GN@(ZI,"MARKED")) D Q ; found a job to kill then quit
. . D STOP^XVJK(ZI) ; kill the job
. . S @GN@(ZI,"KILLED")=$$NOW^XLFDT ; record the kill
. . S @GN@(ZI,"KILLEDBY")=DUZ
. . M @GNOLD@(ZI,$H)=@GN@(ZI)
. . K @GN@(ZI)
. S @GN@(ZI,"MARKED")=$$NOW^XLFDT ; mark for a kill next time
Q
;
EOR ;end of C0PTRAK

384
p/C0PTRXN.m Normal file
View File

@ -0,0 +1,384 @@
C0PTRXN ; ERX/GPL - Med file eRx analysis routines ; 7/10/10 ; 5/9/12 12:13am
;;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
;
; gpl 7/2010 - these routines are to test the Drug file mappings
; to see how well they will work for eRx. None of this code is needed
; for operation of the eRx Package. It is for analysis, debugging and future
; development
;
FDBFN() Q 1130590010 ; First Databank Drugs file number
RXNFN() Q 1130590011.001 ; RxNorm Concepts file number
T1 ; TEST1
N ZI
S ZI=""
F S ZI=$O(^C0P("FDB","B",ZI)) Q:ZI="" D ;
. N ZGCN,ZRXNCUI,ZNAME,ZVAIEN,ZDRUGIEN
. S (ZGCN,ZRXNCUI,ZNAME,ZVAIEN,ZDRUGIEN)=""
. S ZGCN=$$GCN^C0PLKUP(ZI)
. S ZRXNCUI=$$RXNCUI^C0PLKUP(ZGCN)
. I ZRXNCUI'="" S ZVUID=$$VUID^C0PLKUP(ZRXNCUI)
. E S ZRXNCUI="NONE"
. S ZNAME=$$FULLNAME^C0PLKUP(ZI)
. I ZVUID'="" S ZVAIEN=$$VAPROD^C0PLKUP(ZVUID)
. I ZVAIEN'="" S ZDRUGIEN=$$DRUG^C0PLKUP(ZVAIEN)
. E S ZDRUGIEN="N/A"
. W !,ZI," ",ZGCN," ",ZRXNCUI," ",ZVUID," ",ZVAIEN," ",ZDRUGIEN," ",ZNAME
Q
; OK, T1 IS JUST SOME EXPLORITORY WORK. TIME TO GET ORGANIZED
;
TEST ;
;
S GARY=$NA(^TMP("C0PRXN","TYPE2"))
S GOUT=$NA(^TMP("C0POUT"))
K @GOUT
D RNF2CSV^C0CRNF(GOUT,GARY,"VN") ; TURN TYPE 2 INTO A CSV
D FILEOUT^C0CRNF(GOUT,"TYPE2_TEST.csv")
Q
;
INDEX2 ; ADD AN INDEX TO TYPE2 DRUGS OF THE VUID
; FOR USE IN FINDING THE CURRENT VA->FDB MAPPING STATUS
N ZI S ZI=""
N ZBASE
S ZBASE=$NA(^TMP("C0PRXN","TYPE2","V")) ; TYPE2 DRUGS ARE HERE
S ZINDEX=$NA(^TMP("C0PRXN","TYPE2","INDEX")) ; PUT THE INDEX HERE
F S ZI=$O(@ZBASE@(ZI)) Q:ZI="" D ;
. N ZVUIDS,ZVUID
. S ZVUIDS=@ZBASE@(ZI,"VUID",1) ; LIST OF VUIDS ^ SEPARATED
. N ZN S ZN=@ZBASE@(ZI,"VANAME",1)_"^"_@ZBASE@(ZI,"FDBNAME",1)
. I ZVUIDS["^" D ;
. . N ZJ S ZJ=""
. . F S ZJ=$P(ZVUIDS,"^",1) Q:ZJ="" D ; FOR EACH VUID
. . . S ZVUID(ZJ)=ZN ;SET INDEX TO NAME
. . . S ZVUIDS=$P(ZVUIDS,"^",2) ; DROP THE FIRST IN THE LIST
. E S ZVUID(ZVUIDS)=ZN ;SET INDEX TO VA NAME
. S ZJ=""
. F S ZJ=$O(ZVUID(ZJ)) Q:ZJ="" D ; FOR EACH VUID
. . ;S @ZINDEX@(ZJ,ZI)=ZVUID(ZJ) ;SET THE INDEX
. . W !,$NA(@ZINDEX@(ZJ,ZI))_"="_ZVUID(ZJ) ;SET THE INDEX
Q
EN ; ENTRY POINT TO CREATE THE ERX DRUG ANALYSIS SPREADSHEETS
; SEE BELOW FOR DOCUMENTATION
N GARY
S GARY=$NA(^TMP("C0PRXN","ALL")) ; PLACE TO PUT THE ENTIRE ARRAY
K @GARY
D BLDARY(GARY) ; BUILD THE ENTIRE ARRAY
D IDXARY(GARY) ; INDEX THE ARRAY BY TYPE AND DRUG NAME
D TYPES
Q
;
TYPES ; BUILD AN ARRAY FOR EACH TYPE
I '$D(GARY) S GARY=$NA(^TMP("C0PRXN","ALL"))
N C0PN,ZTYPE
F C0PN=1:1:4 D ; FOR EACH ANALYSIS TYPE
. S ZTYPE=$NA(^TMP("C0PRXN","TYPE"_C0PN))
. K @ZTYPE
. D BLDTYPE(GARY,ZTYPE,C0PN) ; BUILD AN EXTRACTED ARRAY ACCORDING TO TYPE
. S GOUT=$NA(^TMP("C0POUT"))
. K @GOUT
. D RNF2CSV^C0CRNF(GOUT,ZTYPE,"VN") ; TURN TYPE 2 INTO A CSV
. W !
. D FILEOUT^C0CRNF(GOUT,"eRx_mapping__Type"_C0PN_".csv")
Q
;
IDXARY(INARY) ; INDEX THE ARRAY BY TYPE AND NAME
;
N ZI
S ZI=""
F S ZI=$O(@INARY@("V",ZI)) Q:ZI="" D ; FOR EACH ELEMENT OF THE ARRAY
. S @INARY@("INDEX",@INARY@("V",ZI,"TYPE"),@INARY@("V",ZI,"FDBNAME"),ZI)=""
D COUNT
Q
;
COUNT ; COUNT AND REPORT HOW MANY ARE IN EACH TYPE
I '$D(INARY) S INARY=$NA(^TMP("C0PRXN","ALL"))
N ZN,ZI,ZJ,ZCOUNT
S ZN=""
F S ZN=$O(@INARY@("INDEX",ZN)) Q:ZN="" D ; FOR EACH TYPE
. S ZCOUNT=0
. S ZI=""
. F S ZI=$O(@INARY@("INDEX",ZN,ZI)) Q:ZI="" D ; FOR EACH INDEX ENTRY
. . S ZCOUNT=ZCOUNT+1
. W !,"COUNT FOR TYPE "_ZN_" = "_ZCOUNT
Q
;
BLDTYPE(INARY,OARY,ITYPE) ; EXTRACT A TYPE ARRAY
;
N C0PI,C0PJ
S C0PI=""
F S C0PI=$O(@INARY@("INDEX",ITYPE,C0PI)) Q:C0PI="" D ; FOR EACH OF TYPE
. S C0PJ=$O(@INARY@("INDEX",ITYPE,C0PI,"")) ; SET RECORD NUMBER
. N C0PROW
. M C0PROW=@INARY@("V",C0PJ) ; CONTENTS OF ROW
. D RNF1TO2B^C0CRNF(OARY,"C0PROW") ; USING THE "B" VERSION TO BE ABLE TO
. ; TO CONVERT TO A CSV
Q
;
BLDARY(ZARY) ; BUILDS AN RNF2 ARRAY; ZARY IS PASSED BY NAME
; (SEE C0CRNF.m FOR DOCUMENTATION OF RNF2 FORMAT)
;
; FIRST DATA BANK DRUGS ARE MATCHED TO VISTA DRUGS THROUGH A MULTI-STEP
; PROCESS. THE MEDID IS THE FIRST DATA BANK NUMBER USED TO REFER TO THEIR
; DRUGS. EACH MEDID HAS A GCN (GENERIC CODE NUMBER) WHICH CAN BE USED TO
; LOOK UP THE DRUG IN THE RXNORM UMLS DATABASE. THE GCN IS USED TO FIND
; THE RXNORM CONCEPT NUMBER (RXNCUI). THE RXNCUI IS USED TO FIND THE VUID
; USING THE RXNORM UMLS DATABASE. THE VUID IS USED TO FIND THE IEN OF THE
; DRUG IN THE VA PRODUCTS FILE (ALSO KNOWN AS THE NDF - NATIONAL DRUG FILE).
; THE VAPROD IEN IS THEN USED TO LOOK UP THE DRUG IN THE VA DRUG FILE
; (FILE 50) USING A NEW CROSS REFERENCE (AC0P) CREATED FOR THIS PURPOSE.
; THE RESULT OF THIS CHAIN IS A DRUG MAPPED FROM THE FDB MEDID TO A
; VA DRUG FILE IEN. TO SUMMARIZE:
;
; MEDID->GCN->RXNCUI->VUID->VAPROD->DRUGIEN
;
; (NOTE: THIS PROCESS WILL CHANGE - BE IMPROVED - WHEN THE VERIFIED
; MEDID->RXNORM MAPPING BECOMES AVAILABLE. THIS ANALYSIS WILL ESTABLISH
; A BASELINE WITH WHICH TO COMPARE THE RESULT OF USING THAT MAPPING)
;
; (THE PROCESS IS ACTUALLY MORE COMPLEX THAT THIS, BECAUSE WE ALSO TRY
; AND MATCH DRUGS BY LOOKING AT THEIR CHEMICAL COMPONENTS BUT THIS ANALYSIS
; IGNORES THIS MORE COMPLEX PROCESS.)
;
; NOT ALL DRUGS MAKE IT ALL THE WAY THROUGH THIS MAPPING. IN ADDITION, THERE
; MAY BE DRUGS THAT ARE IN THE DRUG FILE THAT ARE NOT IN THE FDB FILE
; THIS ROUTINE WILL CREATE A SPREADSHEET THAT WILL SHOW THE UNMAPPED DRUGS
; IN BOTH DIRECTIONS (MEDID->...>DRUGIEN AND DRUGIEN->...>MEDID)
; IT WILL ALSO SHOW THE DRUG NAME AS IT APPEARS IN FIRST DATA BANK
; AND THE NAME THAT WILL BE USED FOR THAT DRUG IN VISTA (ERX). OFTEN
; THEY WILL BE DIFFERENT. IF THE FDB DRUG IS NOT A GENERIC, THE GENERIC NAME
; WILL BY USED BY ERX TO LIST THE DRUG IN THE PATIENT'S DRUG LIST IN VISTA
;
; WE ARE GOING TO ORGANIZE AN ARRAY WITH DRUGS BY TYPE. HERE ARE THE TYPES:
;
; TYPE 1 - FDB DRUGS THAT MAP EXACTLY TO THE DRUG FILE, WITH NAMES THAT
; MATCH EXACTLY
;
; TYPE 2 - FDB DRUGS THAT MAP TO THE DRUG FILE, BUT WITH DIFFERENT NAMES.
; THIS CATEGORY INCLUDES DRUGS THAT ARE SHOWN IN VISTA AS GENERICS BUT
; ON FDB AS BRAND NAME DRUGS
;
; TYPE 3 - FDB DRUGS THAT DO NOT MAP TO THE DRUG FILE, BUT DO MAP TO THE
; VA PRODUCT FILE (NDF). IF ANY OF THESE DRUGS MIGHT BE ORDERED VIA ERX,
; IT MIGHT BE A GOOD IDEA TO ADD THEM TO THE DRUG FILE.
; NOTE: FOR TYPE 3 AND ABOVE DRUGS, ERX WILL STILL FUNCTION PROPERLY BUT
; INSTEAD OF MAPPING THE DRUG TO THE DRUG FILE, WILL MAP IT AS A FREE TEXT
; DRUG AND WILL SEND A MAIL MESSAGE ABOUT THE MAPPING ERROR SO THAT THE
; DRUG CAN BE CONSIDERED FOR ADDING TO THE DRUG FILE
;
; TYPE 4 - FDB DRUGS THAT DO NOT MAP TO THE DRUG FILE AND ARE ALSO NOT
; FOUND IN THE NDF. THIS MIGHT BE THE CASE FOR NEWER DRUGS. ERX WILL
; STILL FUNCTION, BUT THESE WILL BE FREE TEXT DRUGS. THE REMEDY IS AN
; UPDATE FROM THE VA OF THE NDF OR ADDING THE DRUGS TO THE NDF AND THE
; DRUG FILE. (THERE ARE COMPLEXITIES IN ADDING DRUGS TO THE NDF BECAUSE
; OF HOW TO THEN HANDLE AN UPDATE FROM THE VA)
;
; TYPE 5 - DRUGS IN THE DRUG FILE THAT ARE NOT FOUND IN THE FDB DRUG DATABASE
; MAPPING. THIS MIGHT INCLUDE BRAND NAME DRUGS IN THE DRUG FILE THAT HAVE
; BEEN MAPPED TO GENERICS WHEN COMING FROM FDB. IN ANY CASE, THESE ARE DRUGS
; FOR WHICH THERE IS NO PATH TO MAP FROM THEM TO FDB. (REDUCING THE NUMBER
; OF DRUGS IN THIS TYPE TO ZERO WILL BE A GOAL BEFORE IMPLEMENTING PHASE II
; OF ERX WHERE DRUGS WILL BE ORDERED ON VISTA AND SENT TO THE ERX
; SERVICE.
;
N ZI
S ZI=""
F S ZI=$O(^C0P("FDB","B",ZI)) Q:ZI="" D ;
. N ZGCN,ZRXNCUI,ZNAME,ZVAIEN,ZDRUGIEN,ZROW,ZIEN,ZVANAME
. S (ZGCN,ZRXNCUI,ZNAME,ZVAIEN,ZDRUGIEN,ZVANAME)=""
. S ZROW("MEDID")=ZI ; FDB MEDID
. S ZIEN=$O(^C0P("FDB","B",ZI,"")) ; IEN OF THE FDB MED
. S ZROW("FDBNAME")=$$FULLNAME^C0PLKUP(ZI) ; FDB MED NAME
. S ZGCN=$$GCN^C0PLKUP(ZI)
. I ZGCN=0 D Q ; NO GCN, CAN'T MAP
. . S ZROW("TYPE")=4
. . D RNF1TO2^C0CRNF(ZARY,"ZROW")
. S ZROW("GCN")=ZGCN
. S ZRXNCUI=$$RXNCUI^C0PLKUP(ZGCN) ; RETRIEVE THE RXNORM CONCEPT ID
. I ZRXNCUI="" W !,"ERROR, NO RXNCUI "_ZGCN D ERROR^C0PMAIN(",U113059009,",$ST($ST,"PLACE"),"ERX-INVALID-DATA","Invalid Data") QUIT
. S ZROW("RXNCUI")=ZRXNCUI
. S ZVUID=$$VUID^C0PLKUP(ZRXNCUI) ; FETCH THE VUID
. I ZVUID="" D Q ; NO VUID FOUND
. . S ZROW("TYPE")=4
. . D RNF1TO2^C0CRNF(ZARY,"ZROW")
. S ZROW("VUID")=ZVUID
. I ZVUID["^" S ZVUID=$P(ZVUID,"^",1) ; USE THE FIRST ONE
. S ZVAIEN=$$VAPROD^C0PLKUP(ZVUID) ; IEN IN VA PRODUCTS (NDF)
. I ZVAIEN=0 D Q ; NOT FOUND IN NDF
. . S ZROW("TYPE")=4
. . D RNF1TO2^C0CRNF(ZARY,"ZROW")
. S ZDRUGIEN=$$DRUG^C0PLKUP(ZVAIEN) ; IEN IN DRUG FILE
. I ZDRUGIEN=0 D Q ;
. . S ZROW("TYPE")=3
. . S ZROW("VANDFNAME")=$$GET1^DIQ(50.68,ZVAIEN_",",.01) ;NDF NAME
. . D RNF1TO2^C0CRNF(ZARY,"ZROW")
. S ZVANAME=$$GET1^DIQ(50,ZDRUGIEN_",",.01) ; VA DRUG NAME
. S ZROW("VANAME")=ZVANAME ;
. I ZVANAME=$$UP^XLFSTR(ZNAME) S ZROW("TYPE")=1
. E S ZROW("TYPE")=2
. D RNF1TO2^C0CRNF(ZARY,"ZROW")
. ;B
Q
;
BLDFILE() ; BUILDS THE C0P RXNORM FDB VUID MAPPING FILE #113059010.002
;
; FIRST DATA BANK DRUGS ARE MATCHED TO VISTA DRUGS THROUGH A MULTI-STEP
; PROCESS. THE MEDID IS THE FIRST DATA BANK NUMBER USED TO REFER TO THEIR
; DRUGS. EACH MEDID HAS A GCN (GENERIC CODE NUMBER) WHICH CAN BE USED TO
; LOOK UP THE DRUG IN THE RXNORM UMLS DATABASE. THE GCN IS USED TO FIND
; THE RXNORM CONCEPT NUMBER (RXNCUI). THE RXNCUI IS USED TO FIND THE VUID
; USING THE RXNORM UMLS DATABASE. THE VUID IS USED TO FIND THE IEN OF THE
; DRUG IN THE VA PRODUCTS FILE (ALSO KNOWN AS THE NDF - NATIONAL DRUG FILE).
; THE VAPROD IEN IS THEN USED TO LOOK UP THE DRUG IN THE VA DRUG FILE
; (FILE 50) USING A NEW CROSS REFERENCE (AC0P) CREATED FOR THIS PURPOSE.
; THE RESULT OF THIS CHAIN IS A DRUG MAPPED FROM THE FDB MEDID TO A
; VA DRUG FILE IEN. TO SUMMARIZE:
;
; MEDID->GCN->RXNCUI->VUID->VAPROD->DRUGIEN
;
; (NOTE: THIS PROCESS WILL CHANGE - BE IMPROVED - WHEN THE VERIFIED
; MEDID->RXNORM MAPPING BECOMES AVAILABLE. THIS ANALYSIS WILL ESTABLISH
; A BASELINE WITH WHICH TO COMPARE THE RESULT OF USING THAT MAPPING)
;
; (THE PROCESS IS ACTUALLY MORE COMPLEX THAT THIS, BECAUSE WE ALSO TRY
; AND MATCH DRUGS BY LOOKING AT THEIR CHEMICAL COMPONENTS BUT THIS ANALYSIS
; IGNORES THIS MORE COMPLEX PROCESS.)
;
; NOT ALL DRUGS MAKE IT ALL THE WAY THROUGH THIS MAPPING. IN ADDITION, THERE
; MAY BE DRUGS THAT ARE IN THE DRUG FILE THAT ARE NOT IN THE FDB FILE
; THIS ROUTINE WILL CREATE A SPREADSHEET THAT WILL SHOW THE UNMAPPED DRUGS
; IN BOTH DIRECTIONS (MEDID->...>DRUGIEN AND DRUGIEN->...>MEDID)
; IT WILL ALSO SHOW THE DRUG NAME AS IT APPEARS IN FIRST DATA BANK
; AND THE NAME THAT WILL BE USED FOR THAT DRUG IN VISTA (ERX). OFTEN
; THEY WILL BE DIFFERENT. IF THE FDB DRUG IS NOT A GENERIC, THE GENERIC NAME
; WILL BY USED BY ERX TO LIST THE DRUG IN THE PATIENT'S DRUG LIST IN VISTA
;
; WE ARE GOING TO ORGANIZE AN ARRAY WITH DRUGS BY TYPE. HERE ARE THE TYPES:
;
; TYPE 1 - FDB DRUGS THAT MAP EXACTLY TO THE DRUG FILE, WITH NAMES THAT
; MATCH EXACTLY
;
; TYPE 2 - FDB DRUGS THAT MAP TO THE DRUG FILE, BUT WITH DIFFERENT NAMES.
; THIS CATEGORY INCLUDES DRUGS THAT ARE SHOWN IN VISTA AS GENERICS BUT
; ON FDB AS BRAND NAME DRUGS
;
; TYPE 3 - FDB DRUGS THAT DO NOT MAP TO THE DRUG FILE, BUT DO MAP TO THE
; VA PRODUCT FILE (NDF). IF ANY OF THESE DRUGS MIGHT BE ORDERED VIA ERX,
; IT MIGHT BE A GOOD IDEA TO ADD THEM TO THE DRUG FILE.
; NOTE: FOR TYPE 3 AND ABOVE DRUGS, ERX WILL STILL FUNCTION PROPERLY BUT
; INSTEAD OF MAPPING THE DRUG TO THE DRUG FILE, WILL MAP IT AS A FREE TEXT
; DRUG AND WILL SEND A MAIL MESSAGE ABOUT THE MAPPING ERROR SO THAT THE
; DRUG CAN BE CONSIDERED FOR ADDING TO THE DRUG FILE
;
; TYPE 4 - FDB DRUGS THAT DO NOT MAP TO THE DRUG FILE AND ARE ALSO NOT
; FOUND IN THE NDF. THIS MIGHT BE THE CASE FOR NEWER DRUGS. ERX WILL
; STILL FUNCTION, BUT THESE WILL BE FREE TEXT DRUGS. THE REMEDY IS AN
; UPDATE FROM THE VA OF THE NDF OR ADDING THE DRUGS TO THE NDF AND THE
; DRUG FILE. (THERE ARE COMPLEXITIES IN ADDING DRUGS TO THE NDF BECAUSE
; OF HOW TO THEN HANDLE AN UPDATE FROM THE VA)
;
; TYPE 5 - DRUGS IN THE DRUG FILE THAT ARE NOT FOUND IN THE FDB DRUG DATABASE
; MAPPING. THIS MIGHT INCLUDE BRAND NAME DRUGS IN THE DRUG FILE THAT HAVE
; BEEN MAPPED TO GENERICS WHEN COMING FROM FDB. IN ANY CASE, THESE ARE DRUGS
; FOR WHICH THERE IS NO PATH TO MAP FROM THEM TO FDB. (REDUCING THE NUMBER
; OF DRUGS IN THIS TYPE TO ZERO WILL BE A GOAL BEFORE IMPLEMENTING PHASE II
; OF ERX WHERE DRUGS WILL BE ORDERED ON VISTA AND SENT TO THE ERX
; SERVICE.
;
N FN S FN=1130590010.002 ;FILE NUMBER FOR C0P RXNORM FDB VUID MAPPING FILE
N C0PFDA
N ZI
S ZI=""
F S ZI=$O(^C0P("FDB","B",ZI)) Q:ZI="" D ;
. D DOONE(.C0PFDA,ZI) ;BUILD AN FDA
. D UPDIE ;WRITE TO FILE
Q
;
DOONE(C0PFDA,ZI) ; RETURN FDA FOR MEDID ZI
N FN S FN=1130590010.002 ;FILE NUMBER FOR C0P RXNORM FDB VUID MAPPING FILE
N ZGCN,ZRXNCUI,ZNAME,ZVAIEN,ZDRUGIEN,ZROW,ZIEN,ZVANAME,ZRXNIEN,ZRXNTXT
S (ZGCN,ZRXNCUI,ZNAME,ZVAIEN,ZDRUGIEN,ZVANAME)=""
;S ZROW("MEDID")=ZI ; FDB MEDID
S C0PFDA(FN,"+1,",.02)=ZI ; FDB MEDID
S ZIEN=$O(^C0P("FDB","B",ZI,"")) ; IEN OF THE FDB MED
S C0PFDA(FN,"+1,",1.02)=ZIEN ;POINTER TO FDB MED
;S ZROW("FDBNAME")=$$FULLNAME^C0PLKUP(ZI) ; FDB MED NAME
S ZNAME=$$FULLNAME^C0PLKUP(ZI) ; FDB MED NAME
S C0PFDA(FN,"+1,",2.02)=ZNAME ; FDB MED NAME
S ZGCN=$$GCN^C0PLKUP(ZI)
I ZGCN=0 D Q ; NO GCN, CAN'T GO FURTHER
. ;S ZROW("TYPE")=4
. S C0PFDA(FN,"+1,",3)=4 ;TYPE 4, CAN'T MAP FDB TO RXN
. S C0PFDA(FN,"+1,",.01)="MISSING RXN" ;NEED TO HAVE A .01
. ;D RNF1TO2^C0CRNF(ZARY,"ZROW")
;S ZROW("GCN")=ZGCN
S C0PFDA(FN,"+1,",.04)=$$GCN^C0PLKUP(ZI) ;GENERIC CATEGORY NUMBER
S ZRXNCUI=$$RXNCUI^C0PLKUP(ZGCN) ; RETRIEVE THE RXNORM CONCEPT ID
I ZRXNCUI="" W !,"ERROR, NO RXNCUI "_ZGCN D ERROR^C0PMAIN(",U113059009,",$ST($ST,"PLACE"),"ERX-INVALID-DATA","Invalid Data") QUIT ;shouldn't happen
S C0PFDA(FN,"+1,",.01)=ZRXNCUI ; RXN CONCEPT
S ZRXNIEN=$O(^C0P("RXN","B",ZRXNCUI,"")) ; RXN CONCEPT IEN
S C0PFDA(FN,"+1,",1.01)=ZRXNIEN ; POINTER TO RXN CONCEPT
S ZRXNTXT=$G(^C0P("RXN",ZRXNIEN,1,1,0)) ; FIRST LINE OF RXN TEXT
S C0PFDA(FN,"+1,",2.01)=ZRXNTXT ; RXN CONCEPT LABEL
;S ZROW("RXNCUI")=ZRXNCUI
S ZVUID=$$VUID^C0PLKUP(ZRXNCUI) ; FETCH THE VUID
I ZVUID="" D Q ; NO VUID FOUND
. ;S ZROW("TYPE")=4
. S C0PFDA(FN,"+1,",3)=4 ;TYPE 4, CAN'T MAP RXNCUI TO VUID
. ;D RNF1TO2^C0CRNF(ZARY,"ZROW")
;S ZROW("VUID")=ZVUID
S ZVUID=$TR(ZVUID,"^","|") ; CAN'T HAVE ^ IN FIELDS
S C0PFDA(FN,"+1,",.03)=ZVUID ;SET OF VUIDS
I ZVUID["|" S ZVUID=$P(ZVUID,"|",1) ; USE THE FIRST ONE
S ZVAIEN=$$VAPROD^C0PLKUP(ZVUID) ; IEN IN VA PRODUCTS (NDF)
I +ZVAIEN=0 D Q ; NOT FOUND IN NDF
. ;S ZROW("TYPE")=4
. S C0PFDA(FN,"+1,",3)=4 ;TYPE 4, CAN'T MAP VUID TO NDF
. ;D RNF1TO2^C0CRNF(ZARY,"ZROW")
S ZDRUGIEN=$$DRUG^C0PLKUP(ZVAIEN) ; IEN IN DRUG FILE
I ZDRUGIEN["^" S ZDRUGIEN=$P(ZDRUGIEN,"^",1) ; USE THE FIRST ONE
I +ZDRUGIEN=0 D Q ;
. S ZROW("TYPE")=3
. S C0PFDA(FN,"+1,",3)=3 ;TYPE 3, CAN'T MAP VUID TO DRUG FILE
. ;S ZROW("VANDFNAME")=$$GET1^DIQ(50.68,ZVAIEN_",",.01) ;NDF NAME
. S C0PFDA(FN,"+1,",1.04)=ZVAIEN ;POINTER TO NDF
. S C0PFDA(FN,"+1,",2.04)=$$GET1^DIQ(50.68,ZVAIEN_",",.01) ;NDF NAME
. ;D RNF1TO2^C0CRNF(ZARY,"ZROW")
S ZVANAME=$$GET1^DIQ(50,ZDRUGIEN_",",.01) ; VA DRUG NAME
S C0PFDA(FN,"+1,",2.03)=ZVANAME ; VA DRUG FILE NAME
S C0PFDA(FN,"+1,",1.03)=$G(ZDRUGIEN) ; VA DRUG FILE IEN
;S ZROW("VANAME")=ZVANAME ;
I ZVANAME=$$UP^XLFSTR(ZNAME) S ZROW("TYPE")=1
E S ZROW("TYPE")=2
S C0PFDA(FN,"+1,",3)=ZROW("TYPE") ; MATCHING TYPE 1 OR 2
;D RNF1TO2^C0CRNF(ZARY,"ZROW")
;B
Q
;
UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
;Q ;//SMH don't want an update
;I C0PFDA(FN,"+1,",3)'=3 Q ;
I C0PFDA(FN,"+1,",1.02)=1 Q ;
;ZWR C0PFDA ;
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

390
p/C0PTRXN2.m Normal file
View File

@ -0,0 +1,390 @@
C0PTRXN ; ERX/GPL - Med file eRx analysis routines ; 7/10/10
;;0.1;C0P;nopatch;noreleasedate;Build 77
;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
;
; gpl 7/2010 - these routines are to test the Drug file mappings
; to see how well they will work for eRx. None of this code is needed
; for operation of the eRx Package. It is for analysis, debugging and future
; development
;
FDBFN() Q 1130590010 ; First Databank Drugs file number
RXNFN() Q 1130590011.001 ; RxNorm Concepts file number
T1 ; TEST1
N ZI
S ZI=""
F S ZI=$O(^C0P("FDB","B",ZI)) Q:ZI="" D ;
. N ZGCN,ZRXNCUI,ZNAME,ZVAIEN,ZDRUGIEN
. S (ZGCN,ZRXNCUI,ZNAME,ZVAIEN,ZDRUGIEN)=""
. S ZGCN=$$GCN^C0PLKUP(ZI)
. S ZRXNCUI=$$RXNCUI^C0PLKUP(ZGCN)
. I ZRXNCUI'="" S ZVUID=$$VUID^C0PLKUP(ZRXNCUI)
. E S ZRXNCUI="NONE"
. S ZNAME=$$FULLNAME^C0PLKUP(ZI)
. I ZVUID'="" S ZVAIEN=$$VAPROD^C0PLKUP(ZVUID)
. I ZVAIEN'="" S ZDRUGIEN=$$DRUG^C0PLKUP(ZVAIEN)
. E S ZDRUGIEN="N/A"
. W !,ZI," ",ZGCN," ",ZRXNCUI," ",ZVUID," ",ZVAIEN," ",ZDRUGIEN," ",ZNAME
Q
; OK, T1 IS JUST SOME EXPLORITORY WORK. TIME TO GET ORGANIZED
;
TEST ;
;
S GARY=$NA(^TMP("C0PRXN","TYPE2"))
S GOUT=$NA(^TMP("C0POUT"))
K @GOUT
D RNF2CSV^C0CRNF(GOUT,GARY,"VN") ; TURN TYPE 2 INTO A CSV
D FILEOUT^C0CRNF(GOUT,"TYPE2_TEST.csv")
Q
;
INDEX2 ; ADD AN INDEX TO TYPE2 DRUGS OF THE VUID
; FOR USE IN FINDING THE CURRENT VA->FDB MAPPING STATUS
N ZI S ZI=""
N ZBASE
S ZBASE=$NA(^TMP("C0PRXN","TYPE2","V")) ; TYPE2 DRUGS ARE HERE
S ZINDEX=$NA(^TMP("C0PRXN","TYPE2","INDEX")) ; PUT THE INDEX HERE
F S ZI=$O(@ZBASE@(ZI)) Q:ZI="" D ;
. N ZVUIDS,ZVUID
. S ZVUIDS=@ZBASE@(ZI,"VUID",1) ; LIST OF VUIDS ^ SEPARATED
. N ZN S ZN=@ZBASE@(ZI,"VANAME",1)_"^"_@ZBASE@(ZI,"FDBNAME",1)
. I ZVUIDS["^" D ;
. . N ZJ S ZJ=""
. . F S ZJ=$P(ZVUIDS,"^",1) Q:ZJ="" D ; FOR EACH VUID
. . . S ZVUID(ZJ)=ZN ;SET INDEX TO NAME
. . . S ZVUIDS=$P(ZVUIDS,"^",2) ; DROP THE FIRST IN THE LIST
. E S ZVUID(ZVUIDS)=ZN ;SET INDEX TO VA NAME
. S ZJ=""
. F S ZJ=$O(ZVUID(ZJ)) Q:ZJ="" D ; FOR EACH VUID
. . ;S @ZINDEX@(ZJ,ZI)=ZVUID(ZJ) ;SET THE INDEX
. . W !,$NA(@ZINDEX@(ZJ,ZI))_"="_ZVUID(ZJ) ;SET THE INDEX
Q
EN ; ENTRY POINT TO CREATE THE ERX DRUG ANALYSIS SPREADSHEETS
; SEE BELOW FOR DOCUMENTATION
N GARY
S GARY=$NA(^TMP("C0PRXN","ALL")) ; PLACE TO PUT THE ENTIRE ARRAY
K @GARY
D BLDARY(GARY) ; BUILD THE ENTIRE ARRAY
D IDXARY(GARY) ; INDEX THE ARRAY BY TYPE AND DRUG NAME
D TYPES
Q
;
TYPES ; BUILD AN ARRAY FOR EACH TYPE
I '$D(GARY) S GARY=$NA(^TMP("C0PRXN","ALL"))
N C0PN,ZTYPE
F C0PN=1:1:4 D ; FOR EACH ANALYSIS TYPE
. S ZTYPE=$NA(^TMP("C0PRXN","TYPE"_C0PN))
. K @ZTYPE
. D BLDTYPE(GARY,ZTYPE,C0PN) ; BUILD AN EXTRACTED ARRAY ACCORDING TO TYPE
. S GOUT=$NA(^TMP("C0POUT"))
. K @GOUT
. D RNF2CSV^C0CRNF(GOUT,ZTYPE,"VN") ; TURN TYPE 2 INTO A CSV
. W !
. D FILEOUT^C0CRNF(GOUT,"eRx_mapping__Type"_C0PN_".csv")
Q
;
IDXARY(INARY) ; INDEX THE ARRAY BY TYPE AND NAME
;
N ZI
S ZI=""
F S ZI=$O(@INARY@("V",ZI)) Q:ZI="" D ; FOR EACH ELEMENT OF THE ARRAY
. S @INARY@("INDEX",@INARY@("V",ZI,"TYPE"),@INARY@("V",ZI,"FDBNAME"),ZI)=""
D COUNT
Q
;
COUNT ; COUNT AND REPORT HOW MANY ARE IN EACH TYPE
I '$D(INARY) S INARY=$NA(^TMP("C0PRXN","ALL"))
N ZN,ZI,ZJ,ZCOUNT
S ZN=""
F S ZN=$O(@INARY@("INDEX",ZN)) Q:ZN="" D ; FOR EACH TYPE
. S ZCOUNT=0
. S ZI=""
. F S ZI=$O(@INARY@("INDEX",ZN,ZI)) Q:ZI="" D ; FOR EACH INDEX ENTRY
. . S ZCOUNT=ZCOUNT+1
. W !,"COUNT FOR TYPE "_ZN_" = "_ZCOUNT
Q
;
BLDTYPE(INARY,OARY,ITYPE) ; EXTRACT A TYPE ARRAY
;
N C0PI,C0PJ
S C0PI=""
F S C0PI=$O(@INARY@("INDEX",ITYPE,C0PI)) Q:C0PI="" D ; FOR EACH OF TYPE
. S C0PJ=$O(@INARY@("INDEX",ITYPE,C0PI,"")) ; SET RECORD NUMBER
. N C0PROW
. M C0PROW=@INARY@("V",C0PJ) ; CONTENTS OF ROW
. D RNF1TO2B^C0CRNF(OARY,"C0PROW") ; USING THE "B" VERSION TO BE ABLE TO
. ; TO CONVERT TO A CSV
Q
;
BLDARY(ZARY) ; BUILDS AN RNF2 ARRAY; ZARY IS PASSED BY NAME
; (SEE C0CRNF.m FOR DOCUMENTATION OF RNF2 FORMAT)
;
; FIRST DATA BANK DRUGS ARE MATCHED TO VISTA DRUGS THROUGH A MULTI-STEP
; PROCESS. THE MEDID IS THE FIRST DATA BANK NUMBER USED TO REFER TO THEIR
; DRUGS. EACH MEDID HAS A GCN (GENERIC CODE NUMBER) WHICH CAN BE USED TO
; LOOK UP THE DRUG IN THE RXNORM UMLS DATABASE. THE GCN IS USED TO FIND
; THE RXNORM CONCEPT NUMBER (RXNCUI). THE RXNCUI IS USED TO FIND THE VUID
; USING THE RXNORM UMLS DATABASE. THE VUID IS USED TO FIND THE IEN OF THE
; DRUG IN THE VA PRODUCTS FILE (ALSO KNOWN AS THE NDF - NATIONAL DRUG FILE).
; THE VAPROD IEN IS THEN USED TO LOOK UP THE DRUG IN THE VA DRUG FILE
; (FILE 50) USING A NEW CROSS REFERENCE (AC0P) CREATED FOR THIS PURPOSE.
; THE RESULT OF THIS CHAIN IS A DRUG MAPPED FROM THE FDB MEDID TO A
; VA DRUG FILE IEN. TO SUMMARIZE:
;
; MEDID->GCN->RXNCUI->VUID->VAPROD->DRUGIEN
;
; (NOTE: THIS PROCESS WILL CHANGE - BE IMPROVED - WHEN THE VERIFIED
; MEDID->RXNORM MAPPING BECOMES AVAILABLE. THIS ANALYSIS WILL ESTABLISH
; A BASELINE WITH WHICH TO COMPARE THE RESULT OF USING THAT MAPPING)
;
; (THE PROCESS IS ACTUALLY MORE COMPLEX THAT THIS, BECAUSE WE ALSO TRY
; AND MATCH DRUGS BY LOOKING AT THEIR CHEMICAL COMPONENTS BUT THIS ANALYSIS
; IGNORES THIS MORE COMPLEX PROCESS.)
;
; NOT ALL DRUGS MAKE IT ALL THE WAY THROUGH THIS MAPPING. IN ADDITION, THERE
; MAY BE DRUGS THAT ARE IN THE DRUG FILE THAT ARE NOT IN THE FDB FILE
; THIS ROUTINE WILL CREATE A SPREADSHEET THAT WILL SHOW THE UNMAPPED DRUGS
; IN BOTH DIRECTIONS (MEDID->...>DRUGIEN AND DRUGIEN->...>MEDID)
; IT WILL ALSO SHOW THE DRUG NAME AS IT APPEARS IN FIRST DATA BANK
; AND THE NAME THAT WILL BE USED FOR THAT DRUG IN VISTA (ERX). OFTEN
; THEY WILL BE DIFFERENT. IF THE FDB DRUG IS NOT A GENERIC, THE GENERIC NAME
; WILL BY USED BY ERX TO LIST THE DRUG IN THE PATIENT'S DRUG LIST IN VISTA
;
; WE ARE GOING TO ORGANIZE AN ARRAY WITH DRUGS BY TYPE. HERE ARE THE TYPES:
;
; TYPE 1 - FDB DRUGS THAT MAP EXACTLY TO THE DRUG FILE, WITH NAMES THAT
; MATCH EXACTLY
;
; TYPE 2 - FDB DRUGS THAT MAP TO THE DRUG FILE, BUT WITH DIFFERENT NAMES.
; THIS CATEGORY INCLUDES DRUGS THAT ARE SHOWN IN VISTA AS GENERICS BUT
; ON FDB AS BRAND NAME DRUGS
;
; TYPE 3 - FDB DRUGS THAT DO NOT MAP TO THE DRUG FILE, BUT DO MAP TO THE
; VA PRODUCT FILE (NDF). IF ANY OF THESE DRUGS MIGHT BE ORDERED VIA ERX,
; IT MIGHT BE A GOOD IDEA TO ADD THEM TO THE DRUG FILE.
; NOTE: FOR TYPE 3 AND ABOVE DRUGS, ERX WILL STILL FUNCTION PROPERLY BUT
; INSTEAD OF MAPPING THE DRUG TO THE DRUG FILE, WILL MAP IT AS A FREE TEXT
; DRUG AND WILL SEND A MAIL MESSAGE ABOUT THE MAPPING ERROR SO THAT THE
; DRUG CAN BE CONSIDERED FOR ADDING TO THE DRUG FILE
;
; TYPE 4 - FDB DRUGS THAT DO NOT MAP TO THE DRUG FILE AND ARE ALSO NOT
; FOUND IN THE NDF. THIS MIGHT BE THE CASE FOR NEWER DRUGS. ERX WILL
; STILL FUNCTION, BUT THESE WILL BE FREE TEXT DRUGS. THE REMEDY IS AN
; UPDATE FROM THE VA OF THE NDF OR ADDING THE DRUGS TO THE NDF AND THE
; DRUG FILE. (THERE ARE COMPLEXITIES IN ADDING DRUGS TO THE NDF BECAUSE
; OF HOW TO THEN HANDLE AN UPDATE FROM THE VA)
;
; TYPE 5 - DRUGS IN THE DRUG FILE THAT ARE NOT FOUND IN THE FDB DRUG DATABASE
; MAPPING. THIS MIGHT INCLUDE BRAND NAME DRUGS IN THE DRUG FILE THAT HAVE
; BEEN MAPPED TO GENERICS WHEN COMING FROM FDB. IN ANY CASE, THESE ARE DRUGS
; FOR WHICH THERE IS NO PATH TO MAP FROM THEM TO FDB. (REDUCING THE NUMBER
; OF DRUGS IN THIS TYPE TO ZERO WILL BE A GOAL BEFORE IMPLEMENTING PHASE II
; OF ERX WHERE DRUGS WILL BE ORDERED ON VISTA AND SENT TO THE ERX
; SERVICE.
;
N ZI
S ZI=""
F S ZI=$O(^C0P("FDB","B",ZI)) Q:ZI="" D ;
. N ZGCN,ZRXNCUI,ZNAME,ZVAIEN,ZDRUGIEN,ZROW,ZIEN,ZVANAME
. S (ZGCN,ZRXNCUI,ZNAME,ZVAIEN,ZDRUGIEN,ZVANAME)=""
. S ZROW("MEDID")=ZI ; FDB MEDID
. S ZIEN=$O(^C0P("FDB","B",ZI,"")) ; IEN OF THE FDB MED
. S ZROW("FDBNAME")=$$FULLNAME^C0PLKUP(ZI) ; FDB MED NAME
. S ZGCN=$$GCN^C0PLKUP(ZI)
. I ZGCN=0 D Q ; NO GCN, CAN'T MAP
. . S ZROW("TYPE")=4
. . D RNF1TO2^C0CRNF(ZARY,"ZROW")
. S ZROW("GCN")=ZGCN
. S ZRXNCUI=$$RXNCUI^C0PLKUP(ZGCN) ; RETRIEVE THE RXNORM CONCEPT ID
. I ZRXNCUI="" W !,"ERROR, NO RXNCUI "_ZGCN B ; SHOULDN'T HAPPEN
. S ZROW("RXNCUI")=ZRXNCUI
. S ZVUID=$$VUID^C0PLKUP(ZRXNCUI) ; FETCH THE VUID
. I ZVUID="" D Q ; NO VUID FOUND
. . S ZROW("TYPE")=4
. . D RNF1TO2^C0CRNF(ZARY,"ZROW")
. S ZROW("VUID")=ZVUID
. I ZVUID["^" S ZVUID=$P(ZVUID,"^",1) ; USE THE FIRST ONE
. S ZVAIEN=$$VAPROD^C0PLKUP(ZVUID) ; IEN IN VA PRODUCTS (NDF)
. I ZVAIEN=0 D Q ; NOT FOUND IN NDF
. . S ZROW("TYPE")=4
. . D RNF1TO2^C0CRNF(ZARY,"ZROW")
. S ZDRUGIEN=$$DRUG^C0PLKUP(ZVAIEN) ; IEN IN DRUG FILE
. I ZDRUGIEN=0 D Q ;
. . S ZROW("TYPE")=3
. . S ZROW("VANDFNAME")=$$GET1^DIQ(50.68,ZVAIEN_",",.01) ;NDF NAME
. . D RNF1TO2^C0CRNF(ZARY,"ZROW")
. S ZVANAME=$$GET1^DIQ(50,ZDRUGIEN_",",.01) ; VA DRUG NAME
. S ZROW("VANAME")=ZVANAME ;
. I ZVANAME=$$UP^XLFSTR(ZNAME) S ZROW("TYPE")=1
. E S ZROW("TYPE")=2
. D RNF1TO2^C0CRNF(ZARY,"ZROW")
. ;B
Q
;
BLDFILE() ; BUILDS THE C0P RXNORM FDB VUID MAPPING FILE #113059010.002
;
; FIRST DATA BANK DRUGS ARE MATCHED TO VISTA DRUGS THROUGH A MULTI-STEP
; PROCESS. THE MEDID IS THE FIRST DATA BANK NUMBER USED TO REFER TO THEIR
; DRUGS. EACH MEDID HAS A GCN (GENERIC CODE NUMBER) WHICH CAN BE USED TO
; LOOK UP THE DRUG IN THE RXNORM UMLS DATABASE. THE GCN IS USED TO FIND
; THE RXNORM CONCEPT NUMBER (RXNCUI). THE RXNCUI IS USED TO FIND THE VUID
; USING THE RXNORM UMLS DATABASE. THE VUID IS USED TO FIND THE IEN OF THE
; DRUG IN THE VA PRODUCTS FILE (ALSO KNOWN AS THE NDF - NATIONAL DRUG FILE).
; THE VAPROD IEN IS THEN USED TO LOOK UP THE DRUG IN THE VA DRUG FILE
; (FILE 50) USING A NEW CROSS REFERENCE (AC0P) CREATED FOR THIS PURPOSE.
; THE RESULT OF THIS CHAIN IS A DRUG MAPPED FROM THE FDB MEDID TO A
; VA DRUG FILE IEN. TO SUMMARIZE:
;
; MEDID->GCN->RXNCUI->VUID->VAPROD->DRUGIEN
;
; (NOTE: THIS PROCESS WILL CHANGE - BE IMPROVED - WHEN THE VERIFIED
; MEDID->RXNORM MAPPING BECOMES AVAILABLE. THIS ANALYSIS WILL ESTABLISH
; A BASELINE WITH WHICH TO COMPARE THE RESULT OF USING THAT MAPPING)
;
; (THE PROCESS IS ACTUALLY MORE COMPLEX THAT THIS, BECAUSE WE ALSO TRY
; AND MATCH DRUGS BY LOOKING AT THEIR CHEMICAL COMPONENTS BUT THIS ANALYSIS
; IGNORES THIS MORE COMPLEX PROCESS.)
;
; NOT ALL DRUGS MAKE IT ALL THE WAY THROUGH THIS MAPPING. IN ADDITION, THERE
; MAY BE DRUGS THAT ARE IN THE DRUG FILE THAT ARE NOT IN THE FDB FILE
; THIS ROUTINE WILL CREATE A SPREADSHEET THAT WILL SHOW THE UNMAPPED DRUGS
; IN BOTH DIRECTIONS (MEDID->...>DRUGIEN AND DRUGIEN->...>MEDID)
; IT WILL ALSO SHOW THE DRUG NAME AS IT APPEARS IN FIRST DATA BANK
; AND THE NAME THAT WILL BE USED FOR THAT DRUG IN VISTA (ERX). OFTEN
; THEY WILL BE DIFFERENT. IF THE FDB DRUG IS NOT A GENERIC, THE GENERIC NAME
; WILL BY USED BY ERX TO LIST THE DRUG IN THE PATIENT'S DRUG LIST IN VISTA
;
; WE ARE GOING TO ORGANIZE AN ARRAY WITH DRUGS BY TYPE. HERE ARE THE TYPES:
;
; TYPE 1 - FDB DRUGS THAT MAP EXACTLY TO THE DRUG FILE, WITH NAMES THAT
; MATCH EXACTLY
;
; TYPE 2 - FDB DRUGS THAT MAP TO THE DRUG FILE, BUT WITH DIFFERENT NAMES.
; THIS CATEGORY INCLUDES DRUGS THAT ARE SHOWN IN VISTA AS GENERICS BUT
; ON FDB AS BRAND NAME DRUGS
;
; TYPE 3 - FDB DRUGS THAT DO NOT MAP TO THE DRUG FILE, BUT DO MAP TO THE
; VA PRODUCT FILE (NDF). IF ANY OF THESE DRUGS MIGHT BE ORDERED VIA ERX,
; IT MIGHT BE A GOOD IDEA TO ADD THEM TO THE DRUG FILE.
; NOTE: FOR TYPE 3 AND ABOVE DRUGS, ERX WILL STILL FUNCTION PROPERLY BUT
; INSTEAD OF MAPPING THE DRUG TO THE DRUG FILE, WILL MAP IT AS A FREE TEXT
; DRUG AND WILL SEND A MAIL MESSAGE ABOUT THE MAPPING ERROR SO THAT THE
; DRUG CAN BE CONSIDERED FOR ADDING TO THE DRUG FILE
;
; TYPE 4 - FDB DRUGS THAT DO NOT MAP TO THE DRUG FILE AND ARE ALSO NOT
; FOUND IN THE NDF. THIS MIGHT BE THE CASE FOR NEWER DRUGS. ERX WILL
; STILL FUNCTION, BUT THESE WILL BE FREE TEXT DRUGS. THE REMEDY IS AN
; UPDATE FROM THE VA OF THE NDF OR ADDING THE DRUGS TO THE NDF AND THE
; DRUG FILE. (THERE ARE COMPLEXITIES IN ADDING DRUGS TO THE NDF BECAUSE
; OF HOW TO THEN HANDLE AN UPDATE FROM THE VA)
;
; TYPE 5 - DRUGS IN THE DRUG FILE THAT ARE NOT FOUND IN THE FDB DRUG DATABASE
; MAPPING. THIS MIGHT INCLUDE BRAND NAME DRUGS IN THE DRUG FILE THAT HAVE
; BEEN MAPPED TO GENERICS WHEN COMING FROM FDB. IN ANY CASE, THESE ARE DRUGS
; FOR WHICH THERE IS NO PATH TO MAP FROM THEM TO FDB. (REDUCING THE NUMBER
; OF DRUGS IN THIS TYPE TO ZERO WILL BE A GOAL BEFORE IMPLEMENTING PHASE II
; OF ERX WHERE DRUGS WILL BE ORDERED ON VISTA AND SENT TO THE ERX
; SERVICE.
;
N FN S FN=1130590010.002 ;FILE NUMBER FOR C0P RXNORM FDB VUID MAPPING FILE
N C0PFDA
N ZI
S ZI=""
F S ZI=$O(^C0P("FDB","B",ZI)) Q:ZI="" D ;
. W !,ZI
. D DOONE(.C0PFDA,ZI) ;BUILD AN FDA
. D UPDIE ;WRITE TO FILE
. K C0PDFA
Q
;
DOONE(C0PFDA,ZI) ; RETURN FDA FOR MEDID ZI
N FN S FN=1130590010.002 ;FILE NUMBER FOR C0P RXNORM FDB VUID MAPPING FILE
N ZGCN,ZRXNCUI,ZNAME,ZVAIEN,ZDRUGIEN,ZROW,ZIEN,ZVANAME,ZRXNIEN,ZRXNTXT
S (ZGCN,ZRXNCUI,ZNAME,ZVAIEN,ZDRUGIEN,ZVANAME)=""
;S ZROW("MEDID")=ZI ; FDB MEDID
S C0PFDA(FN,"?+1,",.02)=ZI ; FDB MEDID
S ZIEN=$O(^C0P("FDB","B",ZI,"")) ; IEN OF THE FDB MED
S C0PFDA(FN,"?+1,",1.02)=ZIEN ;POINTER TO FDB MED
;S ZROW("FDBNAME")=$$FULLNAME^C0PLKUP(ZI) ; FDB MED NAME
S ZNAME=$$FULLNAME^C0PLKUP(ZI) ; FDB MED NAME
S C0PFDA(FN,"?+1,",2.02)=ZNAME ; FDB MED NAME
S ZGCN=$$GCN^C0PLKUP(ZI)
I ZGCN=0 D Q ; NO GCN, CAN'T GO FURTHER
. ;S ZROW("TYPE")=4
. S C0PFDA(FN,"?+1,",3)=4 ;TYPE 4, CAN'T MAP FDB TO RXN
. S C0PFDA(FN,"?+1,",.01)="MISSING RXN" ;NEED TO HAVE A .01
. ;D RNF1TO2^C0CRNF(ZARY,"ZROW")
;S ZROW("GCN")=ZGCN
S C0PFDA(FN,"?+1,",.04)=$$GCN^C0PLKUP(ZI) ;GENERIC CATEGORY NUMBER
S ZRXNCUI=$$RXNCUI^C0PLKUP(ZGCN) ; RETRIEVE THE RXNORM CONCEPT ID
I ZRXNCUI="" W !,"ERROR, NO RXNCUI "_ZGCN B ; SHOULDN'T HAPPEN
S C0PFDA(FN,"?+1,",.01)=ZRXNCUI ; RXN CONCEPT
S ZRXNIEN=$O(^C0P("RXN","B",ZRXNCUI,"")) ; RXN CONCEPT IEN
S C0PFDA(FN,"?+1,",1.01)=ZRXNIEN ; POINTER TO RXN CONCEPT
S ZRXNTXT=$G(^C0P("RXN",ZRXNIEN,1,1,0)) ; FIRST LINE OF RXN TEXT
S C0PFDA(FN,"?+1,",2.01)=ZRXNTXT ; RXN CONCEPT LABEL
;S ZROW("RXNCUI")=ZRXNCUI
S ZVUID=$$VUID^C0PLKUP(ZRXNCUI) ; FETCH THE VUID
I ZVUID="" D Q ; NO VUID FOUND
. ;S ZROW("TYPE")=4
. S C0PFDA(FN,"?+1,",3)=4 ;TYPE 4, CAN'T MAP RXNCUI TO VUID
. ;D RNF1TO2^C0CRNF(ZARY,"ZROW")
;S ZROW("VUID")=ZVUID
S ZVUID=$TR(ZVUID,"^","|") ; CAN'T HAVE ^ IN FIELDS
S C0PFDA(FN,"?+1,",.03)=ZVUID ;SET OF VUIDS
I ZVUID["|" S ZVUID=$P(ZVUID,"|",1) ; USE THE FIRST ONE
S ZVAIEN=$$VAPROD^C0PLKUP(ZVUID) ; IEN IN VA PRODUCTS (NDF)
I +ZVAIEN=0 D Q ; NOT FOUND IN NDF
. ;S ZROW("TYPE")=4
. S C0PFDA(FN,"?+1,",3)=4 ;TYPE 4, CAN'T MAP VUID TO NDF
. ;D RNF1TO2^C0CRNF(ZARY,"ZROW")
S ZDRUGIEN=$$DRUG^C0PLKUP(ZVAIEN) ; IEN IN DRUG FILE
I ZDRUGIEN["^" S ZDRUGIEN=$P(ZDRUGIEN,"^",1) ; USE THE FIRST ONE
I +ZDRUGIEN=0 D Q ;
. S ZROW("TYPE")=3
. S C0PFDA(FN,"?+1,",3)=3 ;TYPE 3, CAN'T MAP VUID TO DRUG FILE
. ;S ZROW("VANDFNAME")=$$GET1^DIQ(50.68,ZVAIEN_",",.01) ;NDF NAME
. S C0PFDA(FN,"?+1,",1.04)=ZVAIEN ;POINTER TO NDF
. S C0PFDA(FN,"?+1,",2.04)=$$GET1^DIQ(50.68,ZVAIEN_",",.01) ;NDF NAME
. ;D RNF1TO2^C0CRNF(ZARY,"ZROW")
S ZVANAME=$$GET1^DIQ(50,ZDRUGIEN_",",.01) ; VA DRUG NAME
S C0PFDA(FN,"?+1,",2.03)=ZVANAME ; VA DRUG FILE NAME
S C0PFDA(FN,"?+1,",1.03)=$G(ZDRUGIEN) ; VA DRUG FILE IEN
;S ZROW("VANAME")=ZVANAME ;
I ZVANAME=$$UP^XLFSTR(ZNAME) S ZROW("TYPE")=1
E S ZROW("TYPE")=2
S C0PFDA(FN,"?+1,",3)=ZROW("TYPE") ; MATCHING TYPE 1 OR 2
;D RNF1TO2^C0CRNF(ZARY,"ZROW")
;B
Q
;
UPDIE ; INTERNAL ROUTINE TO CALL UPDATE^DIE AND CHECK FOR ERRORS
;Q ;//SMH don't want an update
;I C0PFDA(FN,"+1,",3)'=3 Q ;
;I C0PFDA(FN,"+1,",1.02)=1 Q ;
;ZWR C0PFDA ;
K ZERR
D CLEAN^DILF
D UPDATE^DIE("","C0PFDA","","ZERR")
;I $D(ZERR) D ;
;. W "ERROR",!
;. ZWR ZERR
;. B
K C0PFDA
Q
;

164
p/C0PWPS.m Normal file
View File

@ -0,0 +1,164 @@
C0PWPS ; ERX/GPL - eRx CPRS RPCs ; 2/8/10 ; 5/8/12 5:24pm
;;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
; These routines are substitutes for COVER^ORWPS and DETAIL^ORWPS to
; display eRx and CCR/CCD medication lists accurately
;
COVER(LST,DFN) ; retrieve meds for cover sheet
K ^TMP("PS",$J)
D OCL^PSOORRL(DFN,"","") ;DBIA #2400
N ILST,ITMP,X S ILST=0
S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D
. S X=^TMP("PS",$J,ITMP,0)
. I '$L($P(X,U,2)) S X="??" ; show something if drug empty
. I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S LST($$NXT^ORWPS)=$P(X,U,1,2)_U_$P(X,U,8,9)_U_"C"
. E S LST($$NXT^ORWPS)=$P(X,U,1,2)_U_$P(X,U,8,9)
K ^TMP("PS",$J)
; BEGIN NEW PROCESSING (EVERYTHING ABOVE WAS COPIED FROM COVER^0RWPS
N ZCUR
D GET^C0PCUR(.ZCUR,DFN) ; GET THE DETAIL FOR THE SAME MEDS LIST
N ZI S ZI=""
F S ZI=$O(LST(ZI)) Q:ZI="" D ;FOR EACH MED IN THE LIST
. I $P(LST(ZI),U,2)["FREE TXT" D ; IS AN ERX UNMAPPED DRUG
. . N ZD
. . S ZD=$P(ZCUR(ZI,"SIG",1,0),"|",1) ; REAL DRUG NAME SHOULD BE IN SIG
. . ; SEPARATED BY "|"
. . I ZD'="" S $P(LST(ZI),U,2)=ZD ; IF SO, USE THE REAL NAME
; BEGIN VISTACOM MOD -
; SAVE THE DUZ OFF TO THE VISTACOM TMP GLOBAL
S ^TMP("ZEWD",$J,"DUZ")=DUZ ; TO BE PICKED UP AND DELETED LATER BY VISTACOM
Q
COVER2(LST,DFN) ; retrieve meds for cover sheet ;
; THIS VERSION WILL DISPLAY THE DRUG NAME FROM THE PHARMACY ORDERABLE
; ITEMS FILE FOR ERX DRUGS. THIS ALLOWS THE DRUG TO APPEAR AS GENERIC(BRAND)
; FOR CERTAIN DRUGS - GPL 10/5/10
K ^TMP("PS",$J)
D OCL^PSOORRL(DFN,"","") ;DBIA #2400
N ILST,ITMP,X S ILST=0
S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D
. S X=^TMP("PS",$J,ITMP,0)
. I '$L($P(X,U,2)) S X="??" ; show something if drug empty
. I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S LST($$NXT^ORWPS)=$P(X,U,1,2)_U_$P(X,U,8,9)_U_"C"
. E S LST($$NXT^ORWPS)=$P(X,U,1,2)_U_$P(X,U,8,9)
K ^TMP("PS",$J)
; BEGIN NEW PROCESSING (EVERYTHING ABOVE WAS COPIED FROM COVER^0RWPS
N ZCUR
D GET^C0PCUR(.ZCUR,DFN) ; GET THE DETAIL FOR THE SAME MEDS LIST
N ZI S ZI=""
F S ZI=$O(LST(ZI)) Q:ZI="" D ;FOR EACH MED IN THE LIST
. I $P(LST(ZI),U,2)["FREE TXT" D ; IS AN ERX UNMAPPED DRUG
. . N ZD
. . S ZD=$P(ZCUR(ZI,"SIG",1,0),"|",1) ; REAL DRUG NAME SHOULD BE IN SIG
. . ; SEPARATED BY "|"
. . I ZD'="" S $P(LST(ZI),U,2)=ZD ; IF SO, USE THE REAL NAME
. E I $P(LST(ZI),U,1)["N" D ; THIS IS A NONVA DRUG
. . N ZD,ZDIEN
. . I $G(ZCUR(ZI,"COMMENTS",1))["E-Rx" D ; IS AN ERX DRUG
. . . S ZDIEN=$G(ZCUR(ZI,"DRUG")) ; IEN IN THE DRUG FILE
. . . S ZD=$$GET1^DIQ(50,ZDIEN,2.1) ; THE PHARMACY ORDERABLE ITEM
. . . I ZD'="" S $P(LST(ZI),U,2)=ZD ; USE THIS DRUG NAME
; BEGIN VISTACOM MOD -
; SAVE THE DUZ OFF TO THE VISTACOM TMP GLOBAL
S ^TMP("ZEWD",$J,"DUZ")=DUZ ; TO BE PICKED UP AND DELETED LATER BY VISTACOM
Q
COVER3(LST,DFN) ; retrieve meds for cover sheet ;
; THIS VERSION WILL DISPLAY THE FIRST DATA BANK DRUG NAME WHERE AVAILABLE
; - GPL 10/6/10
K ^TMP("PS",$J)
D OCL^PSOORRL(DFN,"","") ;DBIA #2400
N ILST,ITMP,X S ILST=0
S ITMP="" F S ITMP=$O(^TMP("PS",$J,ITMP)) Q:'ITMP D
. S X=^TMP("PS",$J,ITMP,0)
. I '$L($P(X,U,2)) S X="??" ; show something if drug empty
. I $D(^TMP("PS",$J,ITMP,"CLINIC",0)) S LST($$NXT^ORWPS)=$P(X,U,1,2)_U_$P(X,U,8,9)_U_"C"
. E S LST($$NXT^ORWPS)=$P(X,U,1,2)_U_$P(X,U,8,9)
K ^TMP("PS",$J)
; BEGIN NEW PROCESSING (EVERYTHING ABOVE WAS COPIED FROM COVER^0RWPS
N ZCUR
D GET^C0PCUR(.ZCUR,DFN) ; GET THE DETAIL FOR THE SAME MEDS LIST
N ZI S ZI=""
F S ZI=$O(LST(ZI)) Q:ZI="" D ;FOR EACH MED IN THE LIST
. I $P(LST(ZI),U,2)["FREE TXT" D ; IS AN ERX UNMAPPED DRUG
. . N ZD
. . S ZD=$P(ZCUR(ZI,"SIG",1,0),"|",1) ; REAL DRUG NAME SHOULD BE IN SIG
. . ; SEPARATED BY "|"
. . I ZD'="" S $P(LST(ZI),U,2)=ZD ; IF SO, USE THE REAL NAME
. E I $P(LST(ZI),U,1)["N" D ; THIS IS A NONVA DRUG
. . N ZD,ZDSIG
. . S ZDSIG=ZCUR(ZI,"SIG",1,0) ; THE SIG (CHECK THIS PLEASE)
. . I ZDSIG["|" D ; THERE ARE TWO PARTS TO THE SIG
. . . S ZD=$P(ZDSIG,"|",1) ; FDB DRUG NAME SHOULD BE IN SIG
. . . I ZD'="" S $P(LST(ZI),U,2)=ZD ; IF SO, USE THE FDB NAME
; BEGIN VISTACOM MOD -
; SAVE THE DUZ OFF TO THE VISTACOM TMP GLOBAL
S ^TMP("ZEWD",$J,"DUZ")=DUZ ; TO BE PICKED UP AND DELETED LATER BY VISTACOM
Q
DETAIL(ROOT,DFN,ID) ; -- show details for a med order
K ^TMP("ORXPND",$J)
N ZID
S ZID=ID
N LCNT,ORVP
S LCNT=0,ORVP=DFN_";DPT("
D MEDS^ORCXPND1
S ROOT=$NA(^TMP("ORXPND",$J))
I @ROOT@(11,0)="Order #0" D ERXDET
Q
ERXDET ; BUILD ERX MED DETAIL
N ZMEDS
D GET^C0PCUR(.ZMEDS,DFN)
N ZI,FOUND
S FOUND=0 S ZI=""
F Q:FOUND'=0 S ZI=$O(ZMEDS(ZI)) Q:ZI="" D ; SEARCH FOR THE ID
. I $P(ZMEDS(ZI,0),U,1)=ZID S FOUND=1 ; ID MATCHES THE MED
I FOUND=0 Q ; NO MATCH FOR THE MED
K @ROOT ; CLEAR OUT THE NULL DETAIL
;W !,"MED FOUND ",ZI," ",ZID
N ZNAME,ZSIG,ZCOM,ZFDBN
S ZNAME=$P(ZMEDS(ZI,0),U,2)
S ZSIG=$G(ZMEDS(ZI,"SIG",1,0))
M ZCOM=ZMEDS(ZI,"COMMENTS")
I ZNAME["FREE TXT" D ;
. S ZNAME=$P(ZSIG,"|",1)
. S ZSIG=$P(ZSIG,"| ",2)
E I ZSIG["|" D ; NEED TO PULL OUT THE DRUG NAME FROM THE SIG
. S ZFDBN=$P(ZSIG,"|",1)
. S ZSIG=$P(ZSIG,"| ",2)
N ZN S ZN=1
S @ROOT@(ZN,0)=" Medication: "_ZNAME S ZN=ZN+1
I $G(ZFDBN)'="" D ; IF FIRST DATA BANK NAME IS KNOWN
. S @ROOT@(ZN,0)=" " S ZN=ZN+1
. S @ROOT@(ZN,0)=" FDB Name: "_ZFDBN S ZN=ZN+1
. S @ROOT@(ZN,0)=" " S ZN=ZN+1
E S @ROOT@(ZN,0)=" " S ZN=ZN+1
S @ROOT@(ZN,0)=" Sig: "_ZSIG S ZN=ZN+1
S @ROOT@(ZN,0)="" S ZN=ZN+1
S @ROOT@(ZN,0)=" Status: "_$P(ZMEDS(ZI,0),U,9) S ZN=ZN+1
S @ROOT@(ZN,0)="" S ZN=ZN+1
S @ROOT@(ZN,0)=" Schedule: "_$G(ZMEDS(ZI,"SCH",1,0)) S ZN=ZN+1
S @ROOT@(ZN,0)=" " S ZN=ZN+1
S @ROOT@(ZN,0)=" Start Date: "_$$FMTE^XLFDT($G(ZMEDS(ZI,"START"))) S ZN=ZN+1
S @ROOT@(ZN,0)=" " S ZN=ZN+1
S @ROOT@(ZN,0)=" Source: ePrescribing " S ZN=ZN+1
S @ROOT@(ZN,0)=" " S ZN=ZN+1
N ZI S ZI=""
F S ZI=$O(ZCOM(ZI)) Q:ZI="" D ;
. S @ROOT@(12+ZI,0)=ZCOM(ZI) ;COMMENT LINE
Q
;

452
p/C0PWS1.m Normal file
View File

@ -0,0 +1,452 @@
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
;

528
p/C0PWS2.m Normal file
View File

@ -0,0 +1,528 @@
C0PWS2 ; ERX/GPL - Web Service utilities; 8/31/09; 12/08/2010 ; 5/9/12 12:29am
;;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.
; Modified by Chris Richardson, November, 2010.
; Code has been modified to accept very large XML documents and block them logically.
; 3101208 - RCR - Correct end of buffer condition, BF=">"
QUIT
;
; 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 ; Should use ^%ZOSV Node, this is very GT.M Specific
QUIT
;
ACCOUNTF() QUIT 113059002 ; file number for account file
;
XMLFN() QUIT 113059001 ; XML TEMPLATE FILE NUMBER
;
BINDFN() QUIT 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
DO
. I C0PWS>0 S C0PA=C0PWS QUIT
. ;
. DO ; 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",!
. . .QUIT
. .QUIT
.QUIT
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,COPACCT,COPWBS,COPUTID
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")=""
N ZI,ZN,ZS
S ZN=""
D:$G(DEBUG)="" ; G NOTNEW ; SKIP NEWING THE VARIABLES IF IN DEBUG
. S ZI="",ZN="",ZS=""
. F S ZI=$O(COPV(ZI)) Q:ZI="" D
. . ; S ZJ=$O(C0PV(ZI,"")) ; SET UP NEW COMMAND
. . S ZN=ZN_ZS_$O(C0PV(ZI,"")),ZS=","
. .QUIT
.QUIT
I $L(ZN) N @ZN ; Apply collected NEW Variables 1 time
; NEW
; 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
; END ARTIFACTS
;
D INITXPF("C0PF") ; SET FILE NUMBER AND PARAMATERS
S C0PXF=C0PF("XML FILE NUMBER") ; FILE NUMBER FOR THE C0P XML TEMPLATE FILE
D
. I +C0PTID=0 D Q ; A STRING WAS PASSED FOR THE TEMPLATE NAME
. . S C0PUTID=$$RESTID(C0PDUZ,C0PTID) ;RESOLVE TEMPLATE IEN FROM NAME
. .QUIT
. ;
. S C0PUTID=C0PTID ; AN IEN WAS PASSED
.QUIT
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)
.QUIT
I $G(C0PPROXY) S C0PURL=C0PPURL
K C0PRSLT,C0PRHDR
S ok=$$httpPOST^%zewdGTM(C0PURL,.xml,C0PMIME,.C0PRSLT,.header,"",.gpl5,.C0PRHDR)
K C0PRXML
I $D(GPLTEST) D ; WAY TO TEST WITH DATA FROM LIVE
. K C0PSRLT ; GPL HACK TO TEST XML FROM LIVE
. I GPLTEST=1 M C0PRSLT=^C0PG ; THIS IS THE BIG STATUS EMBEDDED XML FROM LIVE
. I GPLTEST=2 M C0PRSLT=^C0PG2 ; THIS IS THE BIG REFILL XML FROM LIVE
. Q
; 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 $D(C0PRSLT(1)) D ;
. D CHUNK("C0PRXML","C0PRSLT",1000) ;RETURN IN AN ARRAY
. I $G(C0PRSLT("RELOC",1,1))'="" D ; THERE WAS EMBEDED XML
. . K C0PRXML ; THROW AWAY WRAPPER
. . M C0PRXML=C0PRSLT("RELOC",1) ; REPLACE WITH EMBEDDED DOCUMENT
; D:C0PUTID=6
;. I $D(C0PRSLT(1)) D CHUNK("C0PRXML","C0PRSLT",2000) QUIT ;RETURN IN AN ARRAY
;. ;
;. I $D(C0PRSLT(1)) D NORMAL("C0PRXML","C0PRSLT(1)") ;RETURN XML IN AN ARRAY
;.QUIT
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 ;
.QUIT
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
;.QUIT
;D
;. I ZBIG>0 D QUIT ; PROBABLY AN EMBEDDED XML DOCUMENT
;. . S C0PID=$$UNWRAP("C0PRXML",ZBIG,C0PNOM) ; DECODE AND PARSE THE EMBEDED XML
;. .QUIT
;. ;
;. ; ELSE
;. S C0PID=$$PARSE^C0PXEWD("C0PRXML",C0PNOM) ;CALL THE PARSER
;.QUIT
; I $D(GPLTEST) B ; STOP TO LOOK AT C0PRXML --> use ZB SOAP+137^C0PWS2 //SMH
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
QUIT
;
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
; First time we go over 1,000, we can stop.
F S ZI=$O(@ZXML@(ZI)) Q:ZI="" I $L(@ZXML@(ZI))>1000 S ZR=ZI Q ; First oversize stops
QUIT 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 INBF,ZI,ZN,ZTMP
S ZN=1,INBF=@INXML
S @OUTXML@(ZN)=$P(INBF,"><",ZN)_">"
; S ZN=ZN+1
; F S @OUTXML@(ZN)="<"_$P(@INXML,"><",ZN) Q:$P(@INXML,"><",ZN+1)="" D ;
; Should speed up, and not leave a dangling node, and doesn't stop at first NULL
F ZN=2:1:$L(INBF,"><") S @OUTXML@(ZN)="<"_$P(INBF,"><",ZN)_">"
; . ; S ZN=ZN+1
; .QUIT
QUIT
; ================
; The goal of this block has changed a little bit. Most modern MUMPS engines can
; handle a 1,000,000 byte string. We will use BF to hold hunks that big so that
; we can logically suck up a big hunk of the input to supply the reblocking of the XML
; into more logical blocks less than 2000 bytes in length blocks.
; A series of signals will be needed, Source (INXML) is exhausted (INEND),
; BF is less than 2200 bytes (BFLD, BuFfer reLoaD)
; BF is Full (BF contains 998,000 bytes or more, BFULL)
; BF and Process is Complete (BFEND)
; ZSIZE defaults to 2,000 now, but can be set lower or higher
;
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, 2000 IS USED
I '$D(ZSIZE) S ZSIZE=2000 ; DEFAULT BLOCK SIZE
N BF,BFEND,BFLD,BFMAX,BFULL,INEND,ZB,ZI,ZJ,ZK,ZL,ZN
; S ZB=ZSIZE-1
S ZN=1
S BFMAX=998000
S ZI=0 ; BEGINNING OF INDEX TO INXML
S (BFLD,BFEND,BFULL,INEND)=0,BF=""
; Major loop loads the buffer, BF, and unloads it into the Output Array
; in
F D Q:BFEND
. ; Input LOADER
. D:'INEND
. . F S ZI=$O(@INXML@(ZI)) S INEND=(ZI="") Q:INEND!BFULL D ; LOAD EACH STRING IN INXML
. . . S BF=BF_@INXML@(ZI) ; ADD TO THE BF STRING
. . . S BFULL=($L(BF)>BFMAX)
. . .QUIT
. .QUIT
. ; Full Buffer, BF, now check for Encryption and Unpack
. D TEST4COD(.BF,"C0PRSLT(""RELOC"")")
. ; Output BREAKER
. F Q:BFLD D ; ZJ=1:ZSIZE:ZL D ;
. . ; ZK=$S(ZJ+ZB<ZL:ZJ+ZB,1:ZL) ; END FOR EXTRACT
. . F ZK=ZSIZE:-1:0 Q:$E(BF,ZK)=">"
. . I ZK=0 S ZK=ZSIZE
. . S @OUTXML@(ZN)=$E(BF,1,ZK) ; PULL OUT THE PIECE
. . S ZN=ZN+1 ; INCREMENT OUT ARRAY INDEX
. . S BF=$E(BF,ZK+1,BFMAX)
. . S BFLD=($L(BF)<(ZSIZE*2))
. .QUIT
. S BFEND=(INEND&BFLD)!(">"[BF)
. I $L(BF)&BFEND S @OUTXML@(ZN)=BF,BF=""
.QUIT
QUIT
; ==============
; Test for Encryption, extract it and decode it.
TEST4COD(INBF,RELOC)
N DBF,I,MSK,TBF,TRG,RCNT
S RCNT=0
; Segments expected <seg 1>DATA</seg 1><seg 2>DATA</seg 2>
; ^ ^
S MSK="" ; It turns out that some of the characters used were not reliable
F I=32:1:42,44:1:47,62:1:64,91:1:96 S MSK=MSK_$C(I)
F I=1:1:$L(INBF,"</")-1 D
. S TBF=$RE($P($RE($P(INBF,"</",I)),">"))
. ; Remove sample for testing
. ; Set the trigger, mostly included to show intent and associated code
. ; this could be refined later if determined already obvious enough
. S TRG=0
. ;DO:$L(TBF)>20 ; If $TR doesn't remove anything, then these characters are not there
. ; gpl trying to keep refills from crashing.. 20 chars is not enough
. DO:$L(TBF)>100 ; If $TR doesn't remove anything, then these characters are not there
. . I (TBF=$TR(TBF,MSK)) S TRG=1
. . ; I (TBF=$TR(TBF," <->@*!?.,:;#$%&[/|\]={}~")) S TRG=1
. . ; <>!"#$%&'()*,-./67:;<>?@[\]^_`fqr{|}~ <<= Ignore 6,7,f,q, and r
. . ; Now we set up for the DECODE and replacement in INBF
. . DO:TRG
. . . N A,C,CC,CV,CCX,K,XBF,T,V
. . . DO
. . . . N I
. . . . S DBF=$$DECODER(TBF)
. . . .QUIT
. . . ;
. . . S CCX=""
. . . F K=1:1:$L(DBF) S CC=$E(DBF,K) S:CC?1C C=$A(CC),A(C)=$G(A(C))+1
. . . S C="",V=""
. . . F S C=$O(A(C)) Q:C="" S CCX=CCX_$C(C) S:A(C)>V V=A(C),CV=C
. . . S CC=$C(CV)
. . . ; The "_$C(13,10)_" may need to be generalized, tested and set earlier
. . . ; Expand embedded XML in XBF
. . . F K=1:1:$L(DBF,CC) S T=$P(DBF,CC,K),XBF(K)=$TR(T,CCX)
. . . S RCNT=RCNT+1
. . . M @RELOC@(RCNT)=XBF
. . . ; Curley braces and = makes it so it won't trigger a second time by retest.
. . . S INBF=$P(INBF,TBF)_"<{REPLACED}="_RCNT_$P(INBF,TBF,2,999)
. . .QUIT
. .QUIT
.QUIT
; Now shorten the INBF so it gets smaller
;S INBF=$P(INBF,">",I+1,99999)
QUIT
;
DECODER(BF) ; Decrypts the Encrypted Strings
QUIT $$DECODE^RGUTUU(BF)
;
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
. .QUIT
.QUIT
QUIT
; ===============
;
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)
; GTM Specific
; I G=0 ZWR ^TMP("MXMLERR",$J,*) B
QUIT 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 QUIT 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) ;
QUIT 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
;
QUIT 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)
.QUIT
QUIT
;
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
QUIT ZR
;
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)
QUIT
; ==========
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
QUIT
; ==========
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,ZI
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
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
. .QUIT
. 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))
QUIT
;
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"
QUIT
;
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) ;
QUIT
;
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
QUIT
;
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)
QUIT
;
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)
QUIT
;
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)
QUIT
;
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")
QUIT
;
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
QUIT

140
p/C0PXEWD.m Normal file
View File

@ -0,0 +1,140 @@
C0PXEWD ; ERX/GPL - EWD based XPath utilities; 10/11/09 ; 5/4/12 4:29pm
;;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
;
; gpl July, 2010. This routine interfaces with EWD to generate an XPath
; array from an XML file. It recursively visits the EWD DOM and creates
; an XPath index, an XPath array of node values, and an XPath template
; in three different variables. It is used to prepare incoming xml for
; processing by applications.
;
TEST ;
D XPATH($$FIRST($$ID("CCR1")),"/","GIDX","GARY")
Q
;
TEST2 ;
S REDUX="//soap:Envelope/soap:Body/GetPatientFullMedicationHistory5Response/GetPatientFullMedicationHistory5Result/patientDrugDetail"
D XPATH($$FIRST($$ID("gpl")),"/","GIDX","GARY","",REDUX)
Q
;
XPATH(ZOID,ZPATH,ZXIDX,ZXPARY,ZNUM,ZREDUX) ; RECURSIVE ROUTINE TO POPULATE
; THE XPATH INDEX ZXIDX, PASSED BY NAME
; THE XPATH ARRAY XPARY, PASSED BY NAME
; ZOID IS THE STARTING OID
; ZPATH IS THE STARTING XPATH, USUALLY "/"
; ZNUM IS THE MULTIPLE NUMBER [x], USUALLY NULL WHEN ON THE TOP NODE
; ZREDUX IS THE XPATH REDUCTION STRING, TAKEN OUT OF EACH XPATH IF PRESENT
I '$D(ZREDUX) S ZREDUX=""
N NEWPATH
N NEWNUM S NEWNUM=""
I $G(ZNUM)>0 S NEWNUM="["_ZNUM_"]"
S NEWPATH=ZPATH_"/"_$$TAG(ZOID)_NEWNUM ; CREATE THE XPATH FOR THIS NODE
I $G(ZREDUX)'="" D ; REDUX PROVIDED?
. N GT S GT=$P(NEWPATH,ZREDUX,2)
. I GT'="" S NEWPATH=GT
S @ZXIDX@(NEWPATH)=ZOID ; ADD THE XPATH FOR THIS NODE TO THE XPATH INDEX
N GD D DATA("GD",ZOID) ; SEE IF THERE IS DATA FOR THIS NODE
I $D(GD(2)) M @ZXPARY@(NEWPATH)=GD ; IF MULITPLE DATA MERGE TO THE ARRAY
E I $D(GD(1)) S @ZXPARY@(NEWPATH)=GD(1) ; IF SINGLE VALUE, ADD TO ARRAY
I GD'="" S @ZXPARY@(NEWPATH)=GD ; IF YES, ADD IT TO THE XPATH ARRAY
N ZFRST S ZFRST=$$FIRST(ZOID) ; SET FIRST CHILD
I ZFRST'="" D ; THERE IS A CHILD
. N ZMULT S ZMULT=$$ISMULT(ZFRST) ; IS FIRST CHILD A MULTIPLE
. D XPATH(ZFRST,NEWPATH,ZXIDX,ZXPARY,$S(ZMULT:1,1:""),ZREDUX) ; DO THE CHILD
N GNXT S GNXT=$$NXTSIB(ZOID)
I GNXT'="" D ; MOVE ON TO THE NEXT SIBLING
. D XPATH(GNXT,ZPATH,ZXIDX,ZXPARY,$S(ZNUM>0:ZNUM+1,1:""),ZREDUX) ; DO NEXT SIB
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
K ^CacheTempEWD($j) ; CLEAN OUT ANYTHING THAT MIGHT HAVE BEEN THERE
M ^CacheTempEWD($j)=@INXML ;
S ZR=$$parseDocument^%zewdHTMLParser(INDOC)
K ^CacheTempEWD($j) ;clean up after ourselves
Q ZR
;
DELETE(INDOC) ; DELETE A PARSED DOCUMENT FROM THE EWD DOM
; AFTER IT'S NO LONGER NEEDED
N OK
S OK=$$removeDocument^%zewdDOM(INDOC)
Q OK
;
ISMULT(ZOID) ; RETURN TRUE IF ZOID IS ONE OF A MULTIPLE
N ZN
S ZN=$$NXTSIB(ZOID)
I ZN'="" Q $$TAG(ZOID)=$$TAG(ZN) ; IF TAG IS THE SAME AS NEXT SIB TAG
Q 0
;
DETAIL(ZRTN,ZOID) ; RETURNS DETAIL FOR NODE ZOID IN ZRTN, PASSED BY NAME
N DET
D getElementDetails^%zewdXPath(ZOID,.DET)
M @ZRTN=DET
Q
;
ID(ZNAME) ;RETURNS THE docOID OF THE DOCUMENT NAMED ZNAME
Q $$getDocumentNode^%zewdDOM(ZNAME)
;
NAME(ZOID) ;RETURNS THE NAME OF THE DOCUMENAT WITH docOID ZOID
Q $$getDocumentName^%zewdDOM(ZOID)
;
FIRST(ZOID) ;RETURNS THE OID OF THE FIRST CHILD OF ZOID
N GOID
S GOID=ZOID
S GOID=$$getFirstChild^%zewdDOM(GOID)
I GOID="" Q ""
I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
Q GOID
;
HASCHILD(ZOID) ; RETURNS TRUE IF ZOID HAS CHILD NODES
Q $$hasChildNodes^%zewdDOM(ZOID)
;
CHILDREN(ZRTN,ZOID) ;RETURNS CHILDREN OF ZOID IN ARRAY ZRTN, PASSED BY NAME
N childArray
d getChildrenInOrder^%zewdDOM(ZOID,.childArray)
m @ZRTN=childArray
q
;
TAG(ZOID) ; RETURNS THE XML TAG FOR THE NODE
Q $$getName^%zewdDOM(ZOID)
;
NXTSIB(ZOID) ; RETURNS THE NEXT SIBLING
Q $$getNextSibling^%zewdDOM(ZOID)
;
NXTCHLD(ZOID) ; RETURNS THE NEXT CHILD IN PARENT ZPAR
N GOID
S GOID=$$getNextChild^%zewdDOM($$PARENT(ZOID),ZOID)
I GOID="" Q ""
I $$getNodeType^%zewdDOM(GOID)'=1 S GOID=$$NXTCHLD(GOID)
Q GOID
;
PARENT(ZOID) ; RETURNS PARENT OF ZOID
Q $$getParentNode^%zewdDOM(ZOID)
;
DATA(ZT,ZOID) ; RETURNS DATA FOR THE NODE
N ZT2
S ZT2=$$getElementText^%zewdDOM(ZOID,.ZT2)
M @ZT=ZT2
Q
;Q $$getTextValue^%zewdXPath(ZOID)
;Q $$getData^%zewdDOM(ZOID,.ZT)
;

1484
p/C0P_1_0_1_T1.KID
View File

File diff suppressed because it is too large Load Diff

1868
p/_zewdAPI.m
View File

File diff suppressed because it is too large Load Diff

1164
p/_zewdCompiler13.m
View File

File diff suppressed because it is too large Load Diff

863
p/_zewdGTM.m
View File

@ -1,863 +0,0 @@
%zewdGTM ;Enterprise Web Developer GT.M/ Virtual Appliance Functions
;
; Product: Enterprise Web Developer version 4.0.755
; Build Date: Thu, 12 Feb 2009 09:53:12
;
; ----------------------------------------------------------------------------
; | Enterprise Web Developer for GT.M and m_apache |
; | Copyright (c) 2004-9 M/Gateway Developments Ltd, |
; | Reigate, Surrey UK. |
; | All rights reserved. |
; | |
; | http://www.mgateway.com |
; | Email: rtweed@mgateway.com |
; | |
; | This program is free software: you can redistribute it and/or modify |
; | it under the terms of the GNU Affero General Public License as |
; | published by the Free Software Foundation, either version 3 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 Affero General Public License for more details. |
; | |
; | You should have received a copy of the GNU Affero General Public License |
; | along with this program. If not, see <http://www.gnu.org/licenses/>. |
; ----------------------------------------------------------------------------
;
;
QUIT
;
; EWD Virtual Appliance Version/Build
version()
QUIT "6.0"
;
buildDate()
QUIT "29 January 2009"
;
config ;
d setApplicationRootPath^%zewdAPI("/usr/ewd/apps")
d setOutputRootPath^%zewdAPI("/usr/php","php")
;s ^%eXtc("system","license")="2vxuxs3qzqxuyuvtynezvm8yy5Wrz4i7wwwrzmsvqwwtr"
QUIT
;
getMGWSIPid()
;
n io,ok,line,stop,temp
s io=$io
s temp="temp"_$p($h,",",2)_".txt"
zsystem "ps -A|grep mgwsi > "_temp
o temp:(readonly:exception="g nsFileNotExists")
u temp
r line
c temp
u io
s ok=$$deleteFile^%zewdAPI(temp)
s line=$$stripSpaces^%zewdAPI(line)
QUIT +line
startMGWSI ;
k ^%zewd("mgwsis")
d START^%ZMGWSI(0)
;s ^%zewd("mgwsi","job")=$zjob
QUIT
;
stopMGWSI ;
n pid
;s pid=$g(^%zewd("mgwsi","job"))
;s pid=$$getMGWSIPid()
;i pid'="" d
;. k ^%zewd("mgwsi","job")
;. i $$pidExists(pid) zsystem "kill -TERM "_pid
s pid=""
f s pid=$o(^%zewd("mgwsis",pid)) q:pid="" d
. k ^%zewd("mgwsis",pid)
. i $$pidExists(pid) zsystem "kill -TERM "_pid
QUIT
;
restartMGWSI
d stopMGWSI
d startMGWSI
QUIT
;
closeMGWSI(server)
; eg server=the MGWSI "server" to be closed, eg ewd, LOCAL, etc
n ok,html,url
s url="http://127.0.0.1:7040/cgi-bin/nph-mgwsic?mgwsidef=Default_CloseDown_Server&mgwsiSYS=2&mgwsiCDN="_server_"&mgwsiSYSbOK=Close+Connections(s)"
s ok=$$httpGET(url,.html)
QUIT
;
closeMGWSIConnections
n pid
s pid=""
f s pid=$o(^%zewd("mgwsis",pid)) q:pid="" d
. k ^%zewd("mgwsis",pid)
. i $$pidExists(pid) zsystem "kill -TERM "_pid
QUIT
;
shutdown
zsystem "shutdown -h now"
QUIT
;
restart
zsystem "shutdown -r now"
QUIT
;
pidExists(pid) ;
n io,line,ok,temp
s io=$io
s temp="temp"_$p($h,",",2)_".txt"
zsystem "ps --no-heading "_pid_" > "_temp
c temp
o temp:(readonly:exception="g pidFileNotExists")
u temp r line
c temp
u io
s ok=$$deleteFile^%zewdAPI(temp)
i line'[pid QUIT 0
QUIT 1
pidFileNotExists
c temp
s ok=$$deleteFile^%zewdAPI(temp)
u io
i $p($zs,",",1)=2 QUIT 0
QUIT 0
;
validDomain(domain)
;
n exists,io,ok,line,stop,temp
s io=$io
s temp="temp"_$p($h,",",2)_".txt"
zsystem "nslookup "_domain_" >"_temp
o temp:(readonly:exception="g nsFileNotExists")
u temp
s stop=0,exists=0
f r line d q:stop
. i line["authoritative answer" s stop=1,exists=1 q
. i line["server can't find" s stop=1,exists=0 q
c temp
u io
s ok=$$deleteFile^%zewdAPI(temp)
QUIT exists
nsFileNotExists
u io
i $p($zs,",",1)=2 QUIT -1
QUIT -1
;
getIP(info)
;
n exists,io,ip,ok,line,stop,temp,value
s io=$io
s temp="temp"_$p($h,",",2)_".txt"
zsystem "ifconfig eth0 >"_temp
o temp:(readonly:exception="g ipFileNotExists")
u temp
s stop=0,ok=0,ip=""
f r line d q:stop
. i line["HWaddr" d
. . s value=$p(line,"HWaddr ",2)
. . s info("mac")=$$stripSpaces^%zewdAPI(value)
. i line["inet addr:" d
. . s value=$p(line,"inet addr:",2)
. . s ip=$p(value," ",1)
. . s info("ip")=ip
. . i ip="127.0.0.1" s stop=1
. i line["Bcast:" d
. . s value=$p(line,"Bcast:",2)
. . s value=$p(value," ",1)
. . s info("broadcast")=value
. i line["Mask:" d
. . s value=$p(line,"Mask:",2)
. . s value=$p(value," ",1)
. . s info("mask")=value
. i line["inet6 addr" s stop=1 q
. i line["Local Lookback" s stop=1 q
c temp
u io
s ok=$$deleteFile^%zewdAPI(temp)
QUIT ip
ipFileNotExists
s $zt=""
u io
i $p($zs,",",1)=2 QUIT -1
QUIT ""
;
openTCP(host,port,timeout)
n delim,dev
i host'?1N.N1"."1N.N1"."1N.N1"."1N.N,'$$validDomain(host) QUIT 0
i $g(host)="" QUIT 0
i $g(port)="" QUIT 0
i $g(timeout)="" s timeout=20
s delim=$c(13)
s dev="client$"_$p($h,",",2)
o dev:(connect=host_":"_port_":TCP":attach="client":exception="g tcperr"):timeout:"SOCKET"
QUIT dev
;
tcperr ;
QUIT 0
;
resetSecurity
;
k ^%zewd("config","security","validSubnet")
QUIT
;
resetVM
n files
d resetSecurity
k ^%zewdSession
s ^%zewd("nextSessid")=1
k ^%zewd("mgwsi")
k ^%zewd("mgwsis")
k ^%zewd("emailQueue")
k ^%zewd("daemon","email")
k ^%zewd("relink")
k ^%eXtc
k ^%zewdLog
k ^%zewdError
k ^CacheTempUserNode
k ^CacheTempEWD
k ^%zewdTrace
k ^zewd("trace")
k ^%MGW,^%MGWSI
k ^rob,^robdata,^robcgi
k ^CacheTempWLD
k ^ewdDemo
d removeDOMsByPrefix^%zewdAPI()
;d getFilesInPath^%zewdHTMLParser("/usr/local/gtm/ewd",".m",.files)
;f lineNo=1:1 s line=$t(leaveAsM+lineNo) q:line["***END***" d
;. s leaveFiles($p(line,";;",2))=""
; s file=""
;f s file=$o(files(file)) q:file="" d
;. i $d(leaveFiles(file)) q
;. i file'["_zewd" q
;. s path="/usr/local/gtm/ewd/"_file
; . s ok=$$deleteFile^%zewdAPI(path)
; s ok=$$deleteFile^%zewdAPI("/usr/local/gtm/ewd/MDB.m")
; s ok=$$deleteFile^%zewdAPI("/usr/local/gtm/ewd/MDBMgr.m")
;s ok=$$deleteFile^%zewdAPI("/usr/local/gtm/ewd/MDBConfig.m")
s ok=$$deleteFile^%zewdAPI("/usr/MDB/MDB.conf")
k ^MDB,^MDBUAF
zsystem "rm -f ~/.bash_history"
zsystem "history -c"
;echo " "> /var/log/apache2/access.log
;echo " "> /var/log/apache2/error.log
;echo " "> /var/log/apache2/access.log.1"
;echo " "> /var/log/apache2/error.log.1"
;zsystem "rm /usr/php/tutorial/*.*"
; Now clear down history for root
; Shutdown Apache and clear down Apache Log files - use above commented commands
; Delete all ewdapps directories and files
; Delete all PHP directories and files
; zero-space all empty content: cat /dev/zero > zero.fill;sync;sleep 1;sync;rm -f zero.fill
; Compress the virtual drives:
; G:\virtual_machines\mdb_1_0_master>"C:\Program Files\VMware\VMware Server\vmware-vdiskmanager.exe" -k Ubuntu-cl1.vmdk
QUIT
;
setClock
zsystem "ntpdate ntp.ubuntu.com"
QUIT
;
startVM
;
n cr,ip
s cr=$c(13)
d startMGWSI
w cr,!
d setClock
s ip=$$getIP()
w cr,!
w "======================================================="_cr,!
w " Welcome to the EWD Virtual Appliance "_cr,!
w " -- Version "_$$version()_": "_$$buildDate()_" --"_cr,!
;
i ip=""!(ip="127.0.0.1") g startVMFail
w !
w " System clock set to "_$$inetDate^%zewdAPI($h)_cr,!!
w " The EWD Virtual Appliance is now ready for use!"_cr,!
w " To run the EWD Management Portal, point your browser at http://"_ip_cr,!!
g startVMFin
startVMFail
w "Unfortunately the Virtual Appliance was unable to acquire an IP"_cr,!
w "address. Please consult the readme file for what to do next"_cr,!
startVMFin
w "======================================================="_cr,!
QUIT
;
startMDBVM
;
n cr,ip
s cr=$c(13)
d startMGWSI
w cr,!
d setClock
s ip=$$getIP()
w cr,!
w "======================================================="_cr,!
w " Welcome to the M/DB Virtual Appliance "_cr,!
w " -- Version "_$$version()_": "_$$buildDate()_" --"_cr,!
;
i ip=""!(ip="127.0.0.1") g startVMFail
w !
w " System clock set to "_$$inetDate^%zewdAPI($h)_cr,!!
w " The M/DB Virtual Appliance is now ready for use!"_cr,!
w " To run the M/DB Management Portal, point your browser at http://"_ip_cr,!!
g startVMFin
;
httpGET(url,html,headerArray,timeout,test,rawResponse,respHeaders,sslHost,sslPort)
;
n dev,host,HTTPVersion,io,port,rawURL,ssl,urllc
;
k rawResponse,html
s HTTPVersion="1.0"
s rawURL=url
s ssl=0
s port=80
s urllc=$$zcvt^%zewdAPI(url,"l")
i $e(urllc,1,7)="http://" d
. s url=$e(url,8,$l(url))
. s sslHost=$p(url,"/",1)
. s sslPort=80
. i sslHost[":" d
. . s sslPort=$p(sslHost,":",2)
. . s sslHost=$p(sslHost,":",1)
e i $e(urllc,1,8)="https://" d
. s url=$e(url,9,$l(url))
. s ssl=1
. s sslHost=$g(sslHost)
. i sslHost="" s sslHost="127.0.0.1"
. s sslPort=$g(sslPort)
. i sslPort="" s sslPort=89
e QUIT "Invalid URL"
s host=$p(url,"/",1)
i host[":" d
. s port=$p(host,":",2)
. s host=$p(host,":",1)
s url="/"_$p(url,"/",2,5000)
i $g(timeout)="" s timeout=20
;
s io=$io
i $g(test)'=1 d
. s dev=$$openTCP(sslHost,sslPort,timeout)
. u dev
i ssl d
. w "GET "_rawURL_" HTTP/"_HTTPVersion_$c(13,10)
e d
. w "GET "_url_" HTTP/"_HTTPVersion_$c(13,10)
w "Host: "_host
i port'=80 w ":"_port
w $c(13,10)
w "Accept: */*"_$c(13,10)
;
i $d(headerArray) d
. n n
. s n=""
. f s n=$o(headerArray(n)) q:n="" d
. . w headerArray(n)_$c(13,10)
;
w $c(13,10),!
;
; That's the request sent !
;
httpResponse ;
;
i $g(test)=1 QUIT ""
n c,dlim,header,i,no,pos,rlen,stop,str
;
k respHeaders
s stop=0,no=1
f i=1:1 d q:stop
. i i=1
. r c#1
. i c=$c(13) q
. i c'=$c(10) s respHeaders(no)=$g(respHeaders(no))_c
. i c=$c(10),$g(respHeaders(no))="" s stop=1 q
. i c=$c(10) s no=no+1
;
s rlen=999999
f i=1:1:(no-1) d
. s header=$$zcvt^%zewdAPI(respHeaders(i),"l")
. i header["content-length" d
. . s rlen=$p(header,":",2)
. . s rlen=$$stripSpaces^%zewdAPI(rlen)
;
i rlen<999999 d
. r str#rlen
e d
. s str=""
. f pos=1:1 r str#rlen:timeout g:'$t httpTimeout q:str="" s str(pos)=str q:($l(str)<999999)
i $g(test)'=1 c dev
s dlim=$c(10)
i str[$c(13,10) s dlim=$c(13,10)
s rlen=$l(str,dlim)
f i=1:1:rlen s html(i)=$p(str,dlim,i)
s rawResponse=""
f i=1:1:(no-1) s rawResponse=rawResponse_respHeaders(i)_dlim
s rawResponse=rawResponse_dlim_str
;
u io
QUIT ""
;
httpTimeout
QUIT "Timed out waiting for response"
;
httpPOST(url,payload,mimeType,html,headerArray,timeout,test,rawResponse,respHeaders,sslHost,sslPort)
;
n contentLength,dev,host,HTTPVersion,io,port,rawURL,ssl,urllc
;
k rawResponse,html
s HTTPVersion="1.0"
s rawURL=url
s ssl=0
s port=80
s urllc=$$zcvt^%zewdAPI(url,"l")
i $e(urllc,1,7)="http://" d
. s url=$e(url,8,$l(url))
. s sslHost=$p(url,"/",1)
. s sslPort=80
e i $e(urllc,1,8)="https://" d
. s url=$e(url,9,$l(url))
. s ssl=1
. s sslHost=$g(sslHost)
. i sslHost="" s sslHost="127.0.0.1"
. s sslPort=$g(sslPort)
. i sslPort="" s sslPort=89
e QUIT "Invalid URL"
s host=$p(url,"/",1)
i host[":" d
. s port=$p(host,":",2)
. s host=$p(host,":",1)
s url="/"_$p(url,"/",2,5000)
i $g(timeout)="" s timeout=20
;
s io=$io
i $g(test)'=1 d
. s dev=$$openTCP(sslHost,sslPort,timeout)
. u dev
i ssl d
. w "POST "_rawURL_" HTTP/"_HTTPVersion_$c(13,10)
e d
. w "POST "_url_" HTTP/"_HTTPVersion_$c(13,10)
w "Host: "_host
i port'=80 w ":"_port
w $c(13,10)
w "Accept: */*"_$c(13,10)
;
i $d(headerArray) d
. n n
. s n=""
. f s n=$o(headerArray(n)) q:n="" d
. . w headerArray(n)_$c(13,10)
;
s mimeType=$g(mimeType)
i mimeType="" s mimeType="application/x-www-form-urlencoded"
s contentLength=0
i $d(payload) d
. n no
. s no=""
. f s no=$O(payload(no)) q:no="" D
. . s contentLength=contentLength+$l(payload(no))
. s contentLength=contentLength
. w "Content-Type: ",mimeType
. i $g(charset)'="" w "; charset=""",charset,""""
. w $c(13,10)
. w "Content-Length: ",contentLength,$c(13,10)
;
w $c(13,10)
i $D(payload) d
. n no
. s no=""
. f s no=$O(payload(no)) q:no="" d
. . w payload(no)
;
w $c(13,10),!
;
; That's the request sent !
;
g httpResponse
;
parseURL(url,docName)
;
n getPath,ok,server
;
i url["http://" s url=$p(url,"http://",2)
s server=$p(url,"/",1)
s getPath=$p(url,"/",2,1000)
s ok=$$parseURL^%zewdHTMLParser(server,getPath,docName)
QUIT ok
;
smtpSend(domain,from,displayFrom,to,displayTo,ccList,subject,message,dialog,authType,username,password,timeout,gmtOffset,port)
;
n attach,boundary,crlf,date,dev,error,io,mess,rcpt,resp,sent,toList
;
s timeout=$g(timeout) i timeout="" s timeout=10
s domain=$g(domain)
s port=$g(port) i port="" s port=25
s from=$g(from)
s to=$g(to)
s subject=$g(subject)
s gmtOffset=$g(gmtOffset) i gmtOffset="" s gmtOffset="GMT"
;
s error=""
i domain="" QUIT "No SMTP Domain specified"
i from="" QUIT "No sender's email address specified"
i to="" QUIT "No recipient's email address specified"
i '$d(message) QUIT "No Email content specified"
;
s date=$$inetDate^%zewdAPI($h)_" "_gmtOffset
s mess($increment(mess))="Date: "_date
i $g(displayFrom)'="" d
. s mess($increment(mess))="From: """_displayFrom_"""<"_from_">"
e d
. s mess($increment(mess))="From: "_from
i $g(displayTo)'="" d
. s mess($increment(mess))="To: """_displayTo_"""<"_to_">"
e d
. s mess($increment(mess))="To: "_to
s toList(to)=""
i $d(ccList) d
. n name
. s mess($increment(mess))="Cc: "
. i $g(ccList)'="" d
. . s toList(ccList)=""
. . s mess(mess)=mess(mess)_ccList
. s name=""
. f s name=$o(ccList(name)) q:name="" d
. . i mess(mess)'="Cc: " s mess(mess)=mess(mess)_", "
. . s mess(mess)=mess(mess)_name
. . s toList(name)=""
s mess($increment(mess))="Subject: "_subject
s mess($increment(mess))="X-Priority: 3 (Normal)"
s mess($increment(mess))="X-MSMail-Priority: Normal"
s mess($increment(mess))="X-Mailer: "_$$version^%zewdAPI()
s mess($increment(mess))="MIME-Version: 1.0"
s mess($increment(mess))="Content-Type: text/plain; charset=""us-ascii"""
s mess($increment(mess))="Content-Transfer-Encoding: 7bit"
s mess($increment(mess))=""
;
s message=$g(message)
i message'="" d
. s mess($increment(mess))=message
e d
. n mlno
. s mlno=""
. f s mlno=$o(message(mlno)) q:mlno="" d
. . s mess($increment(mess))=message(mlno)
;
k dialog
s io=$io
s crlf=$c(13,10)
s dev=$$openTCP(server,port,timeout)
i dev=0 QUIT "Unable to connect to SMTP server: "_server
u dev
r resp:timeout e d close QUIT "Unable to initiate connection with SMTP server"
s resp=$p(resp,crlf,1)
s dialog($increment(dialog))=resp
s error=""
s authType=$g(authType)
i authType="LOGIN PLAIN"!(authType="LOGIN") d i error'="" d close QUIT error
. n context,decode,passB64,str,userB64
. s context=1
. i $d(^zewd("config","MGWSI")) s context=0
. u dev w "EHLO "_domain_crlf,! s resp=$$read(.dialog)
. i resp'["250",resp'["AUTH",resp'["LOGIN" s error="Authentication type LOGIN/LOGIN PLAIN not supported on this server" q
. u dev w "AUTH LOGIN"_crlf,! s resp=$$read(.dialog)
. i resp'["334" s error="No username authentication challenge from server" q
. s str=$p(resp," ",2,1000)
. s decode=$$DB64^%ZMGWSIS(str,context)
. s resp="(decoded as : "_decode_")"
. s dialog($increment(dialog))=resp
. s userB64=$$B64^%ZMGWSIS(username,context)
. u dev w userB64_crlf,! s resp=$$read(.dialog)
. i resp'["334" s error="No password authentication challenge from server" q
. s str=$p(resp," ",2,1000)
. s decode=$$DB64^%ZMGWSIS(str,context)
. s resp="(decoded as : "_decode_")"
. s dialog($increment(dialog))=resp
. s passB64=$$B64^%ZMGWSIS(password,context)
. u dev w passB64_crlf,! s resp=$$read(.dialog)
. i resp'["235 " s error=resp q
e d i error'="" d close QUIT error
. u dev w "HELO "_domain_crlf,! s resp=$$read(.dialog)
. i resp'["250" s error=resp
;
u dev w "MAIL FROM: "_from_crlf,! s resp=$$read(.dialog)
i resp'["250" d close QUIT resp
;
s rcpt=""
f s rcpt=$o(toList(rcpt)) q:rcpt="" d i resp'[250 q
. u dev w "RCPT TO: <"_rcpt_">"_$c(13,10),!
. s resp=$$read(.dialog)
i resp'[250 d close QUIT resp
;
u dev w "DATA",crlf,! s resp=$$read(.dialog)
i resp'["250",resp'["354" d close QUIT resp
;
s message=$g(message)
i message'="" d message(message,dev)
e d
. n line,lineNo
. s lineNo=""
. f s lineNo=$o(mess(lineNo)) q:lineNo="" d
. . s line=mess(lineNo)
. . d message(line,dev)
u dev w crlf,".",crlf,! s resp=$$read(.dialog)
i resp'["250" d close QUIT resp
u dev w "QUIT",crlf,! s resp=$$read(.dialog)
d close
QUIT ""
;
read(dialog)
n resp
r resp
s resp=$p(resp,$c(13,10),1)
s dialog($increment(dialog))=resp
QUIT resp
close ;
c dev
u io
QUIT
;
message(line,dev)
n buf,p1
s buf=$g(line)
i buf="" u dev w $c(13,10),! QUIT
f q:buf="" d
. s p1=$e(buf,1,254),buf=$e(buf,255,$l(buf))
. i $e(p1)="." s p1="."_p1
. i $l(p1) u dev w p1,!
u dev w $c(13,10),!
QUIT
;
smtpTest
s server="relay.xxxx.net"
s from="rtweed@xxxxx.com"
s displayFrom="Rob Tweed"
s displayTo=displayFrom
s to="rtweed@xxxx.co.uk"
s ccList("rtweed@yyyy.co.uk")=""
s ccList("rtweed@zzzz.com")=""
s message(1)="Test Message"
s message(2)="This is line 2"
s message(3)="And here is line 3"
s authType="LOGIN PLAIN"
s user="xxxxxxxxx"
s pass="yyyyyyyyy"
s subject="Test email 2"
s ok=$$smtpSend(server,from,displayFrom,to,displayTo,.ccList,subject,.message,.dialog,authType,user,pass)
QUIT
;
getFileInfo(path,ext,info) ; Get list of files with specified extension
;
n date,dlim,%file,%io,lineNo,ok,os,%p1,result,time,%x,%y
;
k info
s dlim="/"
i $e(ext,1)'="." s ext="."_ext
i $e(path,$l(path))=dlim s path=$e(path,1,$l(path)-1)
;
d shellCommand("ls -l """_path_"""",.result)
;
; we now have directory listing in result array
s lineNo=""
f s lineNo=$o(result(lineNo)) q:lineNo="" d
. s %file=result(lineNo)
. s %p1=$P(%file," ",1)
. i $e(%p1,1)'="d" d
. . n %e1,%e2,%rfile,%p9,%len,%name,size
. . s %rfile=$re(%file)
. . s %rfile=$$replaceAll^%zewdAPI(%rfile," "," ")
. . s %p9=$p(%rfile," ",1)
. . s time=$p(%rfile," ",2)
. . s date=$p(%rfile," ",3,4)
. . s size=$p(%rfile," ",5)
. . s %p9=$re(%p9)
. . s time=$re(time)
. . s date=$re(date)
. . ;i $$zcvt^%zewdAPI(%p9,"l")=$$zcvt^%zewdAPI(%tofile,"l") q ; ignore temp file
. . i ext=".*" s info(%p9)=date_$c(1)_time_$c(1)_size q
. . s %e1="."_$$getFileExtension^%zewdHTMLParser(%p9)
. . i %e1'=ext q
. . s info(%p9)=date_$c(1)_time_$c(1)_size
QUIT
;
shellPipe ; Pipe output from shell commands to scratch global
;
n i,x
;
k ^%mgwPipe
f i=1:1:200 r x q:((i>20)&(x="")) s ^%mgwPipe(i)=x
QUIT
;
deletePipe
k ^%mgwPipe
QUIT
;
lockPipe
l +^%mgwPipe
QUIT
;
unlockPipe
l -^%mgwPipe
QUIT
;
shellCommand(command,result) ;
n lineNo
k result
d lockPipe
zsystem command_" |mumps -run shellPipe^%zewdGTM"
m result=^%mgwPipe
d deletePipe
d unlockPipe
s lineNo=""
f s lineNo=$o(result(lineNo),-1) q:lineNo="" q:result(lineNo)'="" k result(lineNo)
QUIT
;
fileInfo(path,info)
n line,temp
k info
s temp="temp"_$p($h,",",2)_".txt"
i '$$fileExists^%zewdAPI(path) QUIT
zsystem "ls -l "_path_">"_temp
o temp:(readonly:exception="g fileDateNotExists")
u temp
r line
s info("date")=$p(line," ",6,8)
s info("size")=$p(line," ",5)
c temp
s ok=$$deleteFile^%zewdAPI(temp)
QUIT
fileDateNotExists
s $zt=""
i $p($zs,",",1)=2 QUIT
QUIT
shell(command,result)
n i,io,temp
k result
s io=$io
s temp="temp"_$p($h,",",2)_".txt"
zsystem command_">"_temp
o temp:(readonly)
u temp:exception="g eoshell"
f i=1:1 r result(i)
eoshell ;
c temp
u io
s ok=$$deleteFile^%zewdAPI(temp)
QUIT i-1
;
testGlobal()
s start=$h
f i=1:1:1000 d fileInfo^%zewdAPI("/usr/php/ewdMgr/user.php",.info)
s end=$h
s dur=$p(end,",",2)-$p(start,",",2)
QUIT dur
;
testFile()
s start=$h
f i=1:1:1000 d fileInfo^%zewdGTM("/usr/php/ewdMgr/user.php",.info)
s end=$h
s dur=$p(end,",",2)-$p(start,",",2)
QUIT dur
;
mySQL(sql,resultArray,username,password,database)
n nlines,str
;
i $g(username)="" s username="root"
i $g(password)="" s password="1234567"
i $g(database)="" s database="test"
s str="mysql --xml -u "_username_" -p"_password_" "_database_" -e """_sql_""""
s nlines=$$shell(str,.resultArray)
QUIT nlines
;
encodeDate(dateString)
n %DN,%DS
s %DS=dateString
d INT^%DATE
QUIT $g(%DN)
;
relink ;
s ^%zewd("relink")=1 k ^%zewd("relink","process")
QUIT
;
install
n default,x
;
w !,"Installing/Configuring "_$$version^%zewdAPI(),!!
w "Note: hit Esc to go back at any point",!!
install1 ;
s default=$g(^zewd("config","applicationRootPath"))
i default="" s default="/usr/ewdapps"
w !,"Application Root Path ("_default_"): " r x
i $zb=$c(27) w !," Installation aborted",!! QUIT
i x="" s x=default w x
s ^zewd("config","applicationRootPath")=x
;
install2 ;
s default=$g(^zewd("config","routinePath","gtm"))
i default="" s default="/usr/local/gtm/ewd/"
w !,"Routine Path ("_default_"): " r x
i $zb=$c(27) w ! g install1
i x="" s x=default w x
s ^zewd("config","routinePath","gtm")=x
;
install3 ;
s default=$g(^zewd("config","jsScriptPath","gtm","outputPath"))
i default="" s default="/var/www/resources/"
w !,"Javascript and CSS File Output Path ("_default_"): " r x
i $zb=$c(27) w ! g install2
i x="" s x=default w x
i $e(x,$l(x))'="/" s x=x_"/"
s ^zewd("config","jsScriptPath","gtm","outputPath")=x
;
install4 ;
s default=$g(^zewd("config","jsScriptPath","gtm","path"))
i default="" s default="/resources/"
w !,"Javascript and CSS File URL Path ("_default_"): " r x
i $zb=$c(27) w ! g install3
i x="" s x=default w x
i $e(x,$l(x))'="/" s x=x_"/"
s ^zewd("config","jsScriptPath","gtm","path")=x
;
s ^zewd("config","backEndTechnology")="m"
i '$d(^zewd("config","defaultFormat")) s ^zewd("config","defaultFormat")="pretty"
s ^zewd("config","defaultTechnology")="gtm"
s ^zewd("config","frontEndTechnology")="gtm"
i '$d(^zewd("config","jsScriptPath","gtm","mode")) s ^zewd("config","jsScriptPath","gtm","mode")="fixed"
s ^zewd("config","sessionDatabase")="gtm"
w !!,$$version^%zewdAPI()_" is configured and ready for use",!!
QUIT
;
leaveAsM ;
;;_zewdCompiler11.m
;;_zewdCompiler12.m
;;_zewdCompiler14.m
;;_zewdCompiler15.m
;;_zewdCompiler17.m
;;_zewdCompiler18.m
;;_zewdCompiler21.m
;;_zewdCompiler2.m
;;_zewdCompiler9.m
;;_zewdDemo.m
;;_zewdDocumentation1.m
;;_zewdDocumentation2.m
;;_zewdDocumentation3.m
;;_zewdDocumentation4.m
;;_zewdEJSCData.m
;;_zewdExtJSCode.m
;;_zewdExtJSData.m
;;_zewdExtJSDat2.m
;;_zewdExtJSData3.m
;;_zewdGTM.m
;;_zewdGTMRuntime.m
;;_zewdHTTP.m
;;_zewdLAMP1.m
;;_zewdMgr.m
;;_zewdMgr2.m
;;_zewdMgr3.m
;;_zewdMgrAjax.m
;;_zewdMgrAjax2.m
;;_zewdSlideshow.m
;;_zewdYUI1.m
;;_zewdYUI2.m
;;_zewdvaMgr.m
;;***END***