From 274fdc1ff506ad6fa609efc3b7418c9b94612e87 Mon Sep 17 00:00:00 2001 From: george Date: Sun, 11 Nov 2012 16:20:01 +0000 Subject: [PATCH] initial release of ePrescribing --- p/C0PALGY1.m | 116 +++ p/C0PALGY2.m | 299 +++++++ p/C0PALGY3.m | 98 +++ p/C0PCPRS1.m | 363 +++++++++ p/C0PCUR.m | 194 +++++ p/C0PEREW.m | 164 ++++ p/C0PEWD1.m | 192 ++--- p/C0PEWD2.m | 245 ++++-- p/C0PEWD3.m | 33 + p/C0PEWD4.m | 123 +++ p/C0PEWDU.m | 85 +- p/C0PKIDS.m | 349 ++++++++ p/C0PLKUP.m | 191 +++++ p/C0PLOAD.m | 222 +++++ p/C0PMAIN.m | 211 +++++ p/C0PNVA.m | 135 ++++ p/C0PPAT.m | 83 ++ p/C0PRECON.m | 235 ++++++ p/C0PREFIL.m | 385 +++++++++ p/C0PRXNRD.m | 121 +++ p/C0PSMEDS.m | 76 ++ p/C0PSUB.m | 351 ++++++++ p/C0PTEST1.m | 15 + p/C0PTRAK.m | 128 +++ p/C0PTRXN.m | 384 +++++++++ p/C0PTRXN2.m | 390 +++++++++ p/C0PWPS.m | 164 ++++ p/C0PWS1.m | 452 +++++++++++ p/C0PWS2.m | 528 ++++++++++++ p/C0PXEWD.m | 140 ++++ p/C0P_1_0_1_T1.KID | 1484 ---------------------------------- p/_zewdAPI.m | 1868 ------------------------------------------- p/_zewdCompiler13.m | 1164 --------------------------- p/_zewdGTM.m | 863 -------------------- 34 files changed, 6297 insertions(+), 5554 deletions(-) create mode 100644 p/C0PALGY1.m create mode 100644 p/C0PALGY2.m create mode 100644 p/C0PALGY3.m create mode 100644 p/C0PCPRS1.m create mode 100644 p/C0PCUR.m create mode 100644 p/C0PEREW.m create mode 100644 p/C0PEWD3.m create mode 100644 p/C0PEWD4.m create mode 100644 p/C0PKIDS.m create mode 100644 p/C0PLKUP.m create mode 100644 p/C0PLOAD.m create mode 100644 p/C0PMAIN.m create mode 100644 p/C0PNVA.m create mode 100644 p/C0PPAT.m create mode 100644 p/C0PRECON.m create mode 100644 p/C0PREFIL.m create mode 100644 p/C0PRXNRD.m create mode 100644 p/C0PSMEDS.m create mode 100644 p/C0PSUB.m create mode 100644 p/C0PTEST1.m create mode 100644 p/C0PTRAK.m create mode 100644 p/C0PTRXN.m create mode 100644 p/C0PTRXN2.m create mode 100644 p/C0PWPS.m create mode 100644 p/C0PWS1.m create mode 100644 p/C0PWS2.m create mode 100644 p/C0PXEWD.m delete mode 100644 p/C0P_1_0_1_T1.KID delete mode 100644 p/_zewdAPI.m delete mode 100644 p/_zewdCompiler13.m delete mode 100644 p/_zewdGTM.m diff --git a/p/C0PALGY1.m b/p/C0PALGY1.m new file mode 100644 index 0000000..e6cd5d5 --- /dev/null +++ b/p/C0PALGY1.m @@ -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 + ; diff --git a/p/C0PALGY2.m b/p/C0PALGY2.m new file mode 100644 index 0000000..1c5dd27 --- /dev/null +++ b/p/C0PALGY2.m @@ -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 diff --git a/p/C0PALGY3.m b/p/C0PALGY3.m new file mode 100644 index 0000000..d981bd8 --- /dev/null +++ b/p/C0PALGY3.m @@ -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 + 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 + 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 diff --git a/p/C0PCPRS1.m b/p/C0PCPRS1.m new file mode 100644 index 0000000..e037b85 --- /dev/null +++ b/p/C0PCPRS1.m @@ -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 + ; diff --git a/p/C0PCUR.m b/p/C0PCUR.m new file mode 100644 index 0000000..d0c7a87 --- /dev/null +++ b/p/C0PCUR.m @@ -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 + ; + ; @@PRESCRIPTIONID@@ + ; @@MEDDATE@@ + ; @@DOCTORNAME@@ + ; @@MEDTEXT@@ + ; @@DISPENSENUMBER@@ + ; @@SIG@@ + ; @@REFILLCOUNT@@ + ; @@PRESCRIPTIONTYPE@@ + ; + N C0PZI,ZTEMP,C0PF + S C0PZI="" + D INITXPF^C0PWS1("C0PF") ; SET UP FILE POINTERS + D GETTEMP^C0CMXP("ZTEMP","OUTSIDEPRESCRIPTION","C0PF") + ; BREAK + Q diff --git a/p/C0PEREW.m b/p/C0PEREW.m new file mode 100644 index 0000000..aa454a8 --- /dev/null +++ b/p/C0PEREW.m @@ -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 + ; diff --git a/p/C0PEWD1.m b/p/C0PEWD1.m index cd746fb..074feca 100644 --- a/p/C0PEWD1.m +++ b/p/C0PEWD1.m @@ -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 + ; diff --git a/p/C0PEWD2.m b/p/C0PEWD2.m index e7ba392..6e59c1f 100644 --- a/p/C0PEWD2.m +++ b/p/C0PEWD2.m @@ -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 "
SESSIONID:",zduz,"
" + W "eRx pullback trigger processing prototype
",! + I $D(req4) ZWRITE req4 + w "
" + W "XID=",$G(req4("XID",1)),"
" + W "DFN=",$G(req4("DFN",1)),"
" + w "DUZ=",$G(req4("DUZ",1)),"
" + s DFN=$G(req4("DFN",1)) + D PSEUDO ; FAKE LOGIN + D XPAT^C0CCCR(DFN,"MEDALL") + W "
" + ;D XPAT^C0CCCR(DFN) + W "Display CCR" + ;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 "
" + . W "Current CCR "_ZG_"
",! + . 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 "
SESSIONID:",zduz,"
" + W "HELLO WORLD
",! + I $D(req4) ZWRITE req4 + w "
" + W "DFN=",$G(req4("DFN",1)),"
" + w "DUZ=",$G(req4("DUZ",1)),"
" + ;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)="" + k gpl4(0) ; array size node + s gpl4(3)="" + s gpl4(40)="" + s gpl4(28)="" + s gpl4(55)="" + 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 + ; diff --git a/p/C0PEWD3.m b/p/C0PEWD3.m new file mode 100644 index 0000000..693bc1b --- /dev/null +++ b/p/C0PEWD3.m @@ -0,0 +1,33 @@ +C0PEWD3 ; 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 + ; THIS ROUTINE WAS USED TO GENERATE A TEST CASE FOR PROCESSING EMBEDDED + ; BASE 64 ENCODED XML MESSAGES FROM WEB SERVICE RESPONSES + ; THIS BASE 64 MESSAGE IS ACTUALLY A VALID XML FILE. THIS ROUTINE IS NOT + ; USE IN ERX PROCESSING. IT IS INCLUDED HERE FOR DEBUGGING PURPOSES AND + ; FOR FUTURE DEVELOPMENT + ; GPL JUN 2010 + ; +GETBIG ;TESTING BASE64 DECODING + ;;PD94bWwgdmVyc2lvbj0iMS4wIiBlbmNvZGluZz0iVVRGLTgiPz4KPD94bWwtc3R5bGVzaGVldCB0eXBlPSJ0ZXh0L3hzbCIgaHJlZj0iY2NyLnhzbCI/PgoKPENvbnRpbnVpdHlPZkNhcmVSZWNvcmQgeG1sbnM9InVybjphc3RtLW9yZzpDQ1IiPgogICAgPENDUkRvY3VtZW50T2JqZWN0SUQ+ODcxYmQ2MDUtZThmOC00YjgwLTk5MTgtNGIwM2Y3ODExMjllPC9DQ1JEb2N1bWVudE9iamVjdElEPgogICAgPExhbmd1YWdlPgogICAgICAgIDxUZXh0PkVuZ2xpc2g8L1RleHQ+CiAgICA8L0xhbmd1YWdlPgogICAgPFZlcnNpb24+VjEuMDwvVmVyc2lvbj4KICAgIDxEYXRlVGltZT4KICAgICAgICA8RXhhY3REYXRlVGltZT4yMDA5LTA5LTI5VDE1OjE5OjQyLTA1OjAwPC9FeGFjdERhdGVUaW1lPgogICAgPC9EYXRlVGltZT4KICAgIDxQYXRpZW50PgogICAgICAgIDxBY3RvcklEPkFDVE9SUEFUSUVOVF8yPC9BY3RvcklEPgogICAgPC9QYXRpZW50PgogICAgPEZyb20+CiAgICAgICAgPEFjdG9yTGluaz4KICAgICAgICAgICAgPEFjdG9ySUQ+QUNUT1JPUkdBTklaQVRJT05fNzY8L0FjdG9ySUQ+CiAgICAgICAgPC9BY3Rvckxpbms+CiAgICAgICAgPEFjdG9yTGluaz4KICAgICAgICAgICAgPEFjdG9ySUQ+QUNUT1JTWVNURU1fMTwvQWN0b3JJRD4KICAgICAgICA8L0FjdG9yTGluaz4KICAgIDwvRnJvbT4KICAgIDxUbz4KICAgICAgICA8QWN0b3JMaW5rPgogICAgICAgICAgICA8QWN0b3JJRD5BQ1RPUlBBVElFTlRfMjwvQWN0b3JJRD4KICAgICAgICAgICAgPEFjdG9yUm9sZT4KICAgICAgICAgICAgICAgIDxUZXh0PlBhdGllbnQ8L1RleHQ+CiAgICAgICAgICAgIDwvQWN0b3JSb2xlPgogICAgICAgIDwvQWN0b3JMaW5rPgogICAgPC9Ubz4KICAgIDxQdXJwb3NlPgogICAgICAgIDxEZXNjcmlwdGlvbj4KICAgICAgICAgICAgPFRleHQ+Q0VORCBQSFI8L1RleHQ+CiAgICAgICAgPC9EZXNjcmlwdGlvbj4KICAgIDwvUHVycG9zZT4KICAgIDxCb2R5PgogICAgICAgIDxQcm9ibGVtcz4KICAgICAgICAgICAgPFByb2JsZW0+CiAgICAgICAgICAgICAgICA8Q0NSRGF0YU9iamVjdElEPlBST0JMRU0xPC9DQ1JEYXRhT2JqZWN0SUQ+CiAgICAgICAgICAgICAgICA8VHlwZT4KICAgICAgICAgICAgICAgICAgICA8VGV4dD5Qcm9ibGVtPC9UZXh0PgogICAgICAgICAgICAgICAgPC9UeXBlPgogICAgICAgICAgICAgICAgPFN0YXR1cz4KICAgICAgICAgICAgICAgICAgICA8VGV4dD5BY3RpdmU8L1RleHQ+CiAgICAgICAgICAgICAgICA8L1N0YXR1cz4KICAgICAgICAgICAgICAgIDxEZXNjcmlwdGlvbj4KICAgICAgICAgICAgICAgICAgICA8VGV4dD5GYW1pbHkgSGlzdG9yeSBvZiBEaWFiZXRlcyBNZWxsaXR1cyAoSUNELTktQ00gVjE4LjApPC9UZXh0PgogICAgICAgICAgICAgICAgICAgIDxDb2RlPgogICAgICAgICAgICAgICAgICAgICAgICA8VmFsdWU+VjE4LjA8L1ZhbHVlPgogICAgICAgICAgICAgICAgICAgICAgICA8Q29kaW5nU3lzdGVtPklDRDlDTTwvQ29kaW5nU3lzdGVtPgogICAgICAgICAgICAgICAgICAgIDwvQ29kZT4KICAgICAgICAgICAgICAgIDwvRGVzY3JpcHRpb24+CiAgICAgICAgICAgICAgICA8RGF0ZVRpbWU+CiAgICAgICAgICAgICAgICAgICAgPEV4YWN0RGF0ZVRpbWU+MjAwNS0wNy0xOVQwMDowMDowMC0wNTowMDwvRXhhY3REYXRlVGltZT4KICAgICAgICAgICAgICAgIDwvRGF0ZVRpbWU+CiAgICAgICAgICAgICAgICA8U291cmNlPgogICAgICAgICAgICAgICAgICAgIDxBY3Rvcj4KICAgICAgICAgICAgICAgICAgICAgICAgPEFjdG9ySUQ+QUNUT1JQUk9WSURFUl8xMTwvQWN0b3JJRD4KICAgICAgICAgICAgICAgICAgICA8L0FjdG9yPgogICAgICAgICAgICAgICAgPC9Tb3VyY2U+CiAgICAgICAgICAgIDwvUHJvYmxlbT4KICAgICAgICAgICAgPFByb2JsZW0+CiAgICAgICAgICAgICAgICA8Q0NSRGF0YU9iamVjdElEPlBST0JMRU0yPC9DQ1JEYXRhT2JqZWN0SUQ+CiAgICAgICAgICAgICAgICA8VHlwZT4KICAgICAgICAgICAgICAgICAgICA8VGV4dD5Qcm9ibGVtPC9UZXh0PgogICAgICAgICAgICAgICAgPC9UeXBlPgogICAgICAgICAgICAgICAgPFN0YXR1cz4KICAgICAgICAgICAgICAgICAgICA8VGV4dD5BY3RpdmU8L1RleHQ+CiAgICAgICAgICAgICAgICA8L1N0YXR1cz4KICAgICAgICAgICAgICAgIDxEZXNjcmlwdGlvbj4KICAgICAgICAgICAgICAgICAgICA8VGV4dD5EaWFiZXRlcyBNZWxsaXR1cyB3aXRob3V0IG1lbnRpb24gb2YgQ29tcGxpY2F0aW9uLCB0eXBlIElJIG9yIHVuc3BlY2lmaWVkIHR5cGUsPC9UZXh0PgogICAgICAgICAgICAgICAgICAgIDxDb2RlPgogICAgICAgICAgICAgICAgICAgICAgICA8VmFsdWU+MjUwLjAyPC9WYWx1ZT4KICAgICAgICAgICAgICAgICAgICAgICAgPENvZGluZ1N5c3RlbT5JQ0Q5Q008L0NvZGluZ1N5c3RlbT4KICAgICAgICAgICAgICAgICAgICA8L0NvZGU+CiAgICAgICAgICAgICAgICA8L0Rlc2NyaXB0aW9uPgogICAgICAgICAgICAgICAgPERhdGVUaW1lPgogICAgICAgICAgICAgICAgICAgIDxFeGFjdERhdGVUaW1lPjIwMDUtMDctMTlUMDA6MDA6MDAtMDU6MDA8L0V4YWN0RGF0ZVRpbWU+CiAgICAgICAgICAgICAgICA8L0RhdGVUaW1lPgogICAgICAgICAgICAgICAgPFNvdXJjZT4KICAgICAgICAgICAgICAgICAgICA8QWN0b3I+CiAgICAgICAgICAgICAgICAgICAgICAgIDxBY3RvcklEPkFDVE9SUFJPVklERVJfMTE8L0FjdG9ySUQ+CiAgICAgICAgICAgICAgICAgICAgPC9BY3Rvcj4KICAgICAgICAgICAgICAgIDwvU291cmNlPgogICAgICAgICAgICA8L1Byb2JsZW0+CiAgICAgICAgICAgIDxQcm9ibGVtPgogICAgICAgICAgICAgICAgPENDUkRhdGFPYmplY3RJRD5QUk9CTEVNMzwvQ0NSRGF0YU9iamVjdElEPgogICAgICAgICAgICAgICAgPFR5cGU+CiAgICAgICAgICAgICAgICAgICAgPFRleHQ+UHJvYmxlbTwvVGV4dD4KICAgICAgICAgICAgICAgIDwvVHlwZT4KICAgICAgICAgICAgICAgIDxTdGF0dXM+CiAgICAgICAgICAgICAgICAgICAgPFRleHQ+QWN0aXZlPC9UZXh0PgogICAgICAgICAgICAgICAgPC9TdGF0dXM+CiAgICAgICAgICAgICAgICA8RGVzY3JpcHRpb24+CiAgICAgICAgICAgICAgICAgICAgPFRleHQ+TGVmdCBWZW50cmljdWxhciBIeXBlcnRyb3BoeTwvVGV4dD4KICAgICAgICAgICAgICAgICAgICA8Q29kZT4KICAgICAgICAgICAgICAgICAgICAgICAgPFZhbHVlPjc5OS45PC9WYWx1ZT4KICAgICAgICAgICAgICAgICAgICAgICAgPENvZGluZ1N5c3RlbT5JQ0Q5Q008L0NvZGluZ1N5c3RlbT4KICAgICAgICAgICAgICAgICAgICA8L0NvZGU+CiAgICAgICAgICAgICAgICA8L0Rlc2NyaXB0aW9uPgogICAgICAgICAgICAgICAgPERhdGVUaW1lPgogICAgICAgICAgICAgICAgICAgIDxFeGFjdERhdGVUaW1lPjIwMDUtMDctMjBUMDA6MDA6MDAtMDU6MDA8L0V4YWN0RGF0ZVRpbWU+CiAgICAgICAgICAgICAgICA8L0RhdGVUaW1lPgogICAgICAgICAgICAgICAgPFNvdXJjZT4KICAgICAgICAgICAgICAgICAgICA8QWN0b3I+CiAgICAgICAgICAgICAgICAgICAgICAgIDxBY3RvcklEPkFDVE9SUFJPVklERVJfNjA8L0FjdG9ySUQ+CiAgICAgICAgICAgICAgICAgICAgPC9BY3Rvcj4KICAgICAgICAgICAgICAgIDwvU291cmNlPgogICAgICAgICAgICA8L1Byb2JsZW0+CiAgICAgICAgPC9Qcm9ibGVtcz4KICAgICAgICA8QWxlcnRzPgogICAgICAgICAgICA8QWxlcnQ+CiAgICAgICAgICAgICAgICA8Q0NSRGF0YU9iamVjdElEPkFMRVJUMTwvQ0NSRGF0YU9iamVjdElEPgogICAgICAgICAgICAgICAgPFR5cGU+CiAgICAgICAgICAgICAgICAgICAgPFRleHQ+QWxsZXJneTwvVGV4dD4KICAgICAgICAgICAgICAgIDwvVHlwZT4KICAgICAgICAgICAgICAgIDxEZXNjcmlwdGlvbj4KICAgICAgICAgICAgICAgICAgICA8VGV4dD5QYXRpZW50IGhhcyBhbiBBTExFUkdJQyByZWFjdGlvbiB0byBQRUFOVVQgT0lMLjwvVGV4dD4KICAgICAgICAgICAgICAgICAgICA8Q29kZT4KICAgICAgICAgICAgICAgICAgICAgICAgPFZhbHVlPjQxODYzNDAwNTwvVmFsdWU+CiAgICAgICAgICAgICAgICAgICAgICAgIDxDb2RpbmdTeXN0ZW0+U05PTUVEIENUPC9Db2RpbmdTeXN0ZW0+CiAgICAgICAgICAgICAgICAgICAgPC9Db2RlPgogICAgICAgICAgICAgICAgPC9EZXNjcmlwdGlvbj4KICAgICAgICAgICAgICAgIDxEYXRlVGltZT4KICAgICAgICAgICAgICAgICAgICA8RXhhY3REYXRlVGltZT4yMDA1LTA3LTE5PC9FeGFjdERhdGVUaW1lPgogICAgICAgICAgICAgICAgPC9EYXRlVGltZT4KICAgICAgICAgICAgICAgIDxTb3VyY2U+CiAgICAgICAgICAgICAgICAgICAgPEFjdG9yPgogICAgICAgICAgICAgICAgICAgICAgICA8QWN0b3JJRD5BQ1RPUlBST1ZJREVSXzExPC9BY3RvcklEPgogICAgICAgICAgICAgICAgICAgIDwvQWN0b3I+CiAgICAgICAgICAgICAgICA8L1NvdXJjZT4KICAgICAgICAgICAgICAgIDxBZ2VudD4KICAgICAgICAgICAgICAgICAgICA8UHJvZHVjdHM+CiAgICAgICAgICAgICAgICAgICAgICAgIDxQcm9kdWN0PgogICAgICAgICAgICAgICAgICAgICAgICAgICAgPENDUkRhdGFPYmplY3RJRD5QUk9EVUNUXzEwNjwvQ0NSRGF0YU9iamVjdElEPgogICAgICAgICAgICAgICAgICAgICAgICAgICAgPFByb2R1Y3ROYW1lPgogICAgICAgICAgICAgICAgICAgICAgICAgICAgICAgIDxUZXh0PlBFQU5VVCBPSUw8L1RleHQ+CiAgICAgICAgICAgICAgICAgICAgICAgICAgICA8L1Byb2R1Y3ROYW1lPgogICAgICAgICAgICAgICAgICAgICAgICA8L1Byb2R1Y3Q+CiAgICAgICAgICAgICAgICAgICAgPC9Qcm9kdWN0cz4KICAgICAgICAgICAgICAgIDwvQWdlbnQ+CiAgICAgICAgICAgICAgICA8UmVhY3Rpb24+CiAgICAgICAgICAgICAgICAgICAgPERlc2NyaXB0aW9uPgogICAgICAgICAgICAgICAgICAgICAgICA8VGV4dD5ISVZFUzwvVGV4dD4KICAgICAgICAgICAgICAgICAgICA8L0Rlc2NyaXB0aW9uPgogICAgICAgICAgICAgICAgPC9SZWFjdGlvbj4KICAgICAgICAgICAgPC9BbGVydD4KICAgICAgICA8L0FsZXJ0cz4KICAgIDwvQm9keT4KICAgIDxBY3RvcnM+CiAgICAgICAgPEFjdG9yPgogICAgICAgICAgICA8QWN0b3JPYmplY3RJRD5BQ1RPUk9SR0FOSVpBVElPTl83NjwvQWN0b3JPYmplY3RJRD4KICAgICAgICAgICAgPE9yZ2FuaXphdGlvbj4KICAgICAgICAgICAgICAgIDxOYW1lPlZPRSBPRkZJQ0UgSU5TVElUVVRJT04gT0xEPC9OYW1lPgogICAgICAgICAgICA8L09yZ2FuaXphdGlvbj4KICAgICAgICAgICAgPFNvdXJjZT4KICAgICAgICAgICAgICAgIDxBY3Rvcj4KICAgICAgICAgICAgICAgICAgICA8QWN0b3JJRD5BQ1RPUlNZU1RFTV8xPC9BY3RvcklEPgogICAgICAgICAgICAgICAgPC9BY3Rvcj4KICAgICAgICAgICAgPC9Tb3VyY2U+CiAgICAgICAgPC9BY3Rvcj4KICAgICAgICA8QWN0b3I+CiAgICAgICAgICAgIDxBY3Rvck9iamVjdElEPkFDVE9SUEFUSUVOVF8yPC9BY3Rvck9iamVjdElEPgogICAgICAgICAgICA8UGVyc29uPgogICAgICAgICAgICAgICAgPE5hbWU+CiAgICAgICAgICAgICAgICAgICAgPEN1cnJlbnROYW1lPgogICAgICAgICAgICAgICAgICAgICAgICA8R2l2ZW4+R0FMTE9XPC9HaXZlbj4KICAgICAgICAgICAgICAgICAgICAgICAgPEZhbWlseT5ZT1VOR0VSPC9GYW1pbHk+CiAgICAgICAgICAgICAgICAgICAgPC9DdXJyZW50TmFtZT4KICAgICAgICAgICAgICAgIDwvTmFtZT4KICAgICAgICAgICAgICAgIDxEYXRlT2ZCaXJ0aD4KICAgICAgICAgICAgICAgICAgICA8RXhhY3REYXRlVGltZT4xOTk5LTA2LTI3PC9FeGFjdERhdGVUaW1lPgogICAgICAgICAgICAgICAgPC9EYXRlT2ZCaXJ0aD4KICAgICAgICAgICAgICAgIDxHZW5kZXI+CiAgICAgICAgICAgICAgICAgICAgPFRleHQ+TUFMRTwvVGV4dD4KICAgICAgICAgICAgICAgICAgICA8Q29kZT4KICAgICAgICAgICAgICAgICAgICAgICAgPFZhbHVlPk1BTEU8L1ZhbHVlPgogICAgICAgICAgICAgICAgICAgICAgICA8Q29kaW5nU3lzdGVtPjIuMTYuODQwLjEuMTEzODgzLjUuMTwvQ29kaW5nU3lzdGVtPgogICAgICAgICAgICAgICAgICAgIDwvQ29kZT4KICAgICAgICAgICAgICAgIDwvR2VuZGVyPgogICAgICAgICAgICA8L1BlcnNvbj4KICAgICAgICAgICAgPEFkZHJlc3M+CiAgICAgICAgICAgICAgICA8VHlwZT4KICAgICAgICAgICAgICAgICAgICA8VGV4dD5Ib21lPC9UZXh0PgogICAgICAgICAgICAgICAgPC9UeXBlPgogICAgICAgICAgICAgICAgPExpbmUxPjEyMzQgU29tZXdoZXJlIExhbmU8L0xpbmUxPgogICAgICAgICAgICAgICAgPENpdHk+QUxUT048L0NpdHk+CiAgICAgICAgICAgICAgICA8U3RhdGU+S0FOU0FTPC9TdGF0ZT4KICAgICAgICAgICAgICAgIDxQb3N0YWxDb2RlPjY3NjIzPC9Qb3N0YWxDb2RlPgogICAgICAgICAgICA8L0FkZHJlc3M+CiAgICAgICAgICAgIDxUZWxlcGhvbmU+CiAgICAgICAgICAgICAgICA8VmFsdWU+ODg4LTU1NS0xMjEyPC9WYWx1ZT4KICAgICAgICAgICAgICAgIDxUeXBlPgogICAgICAgICAgICAgICAgICAgIDxUZXh0PlJlc2lkZW50aWFsIFRlbGVwaG9uZTwvVGV4dD4KICAgICAgICAgICAgICAgIDwvVHlwZT4KICAgICAgICAgICAgPC9UZWxlcGhvbmU+CiAgICAgICAgICAgIDxUZWxlcGhvbmU+CiAgICAgICAgICAgICAgICA8VmFsdWU+ODg4LTEyMS0xMjEyPC9WYWx1ZT4KICAgICAgICAgICAgICAgIDxUeXBlPgogICAgICAgICAgICAgICAgICAgIDxUZXh0PldvcmsgVGVsZXBob25lPC9UZXh0PgogICAgICAgICAgICAgICAgPC9UeXBlPgogICAgICAgICAgICA8L1RlbGVwaG9uZT4KICAgICAgICAgICAgPFNvdXJjZT4KICAgICAgICAgICAgICAgIDxBY3Rvcj4KICAgICAgICAgICAgICAgICAgICA8QWN0b3JJRD5BQ1RPUlBBVElFTlRfMjwvQWN0b3JJRD4KICAgICAgICAgICAgICAgIDwvQWN0b3I+CiAgICAgICAgICAgIDwvU291cmNlPgogICAgICAgIDwvQWN0b3I+CiAgICAgICAgPEFjdG9yPgogICAgICAgICAgICA8QWN0b3JPYmplY3RJRD5BQ1RPUlBST1ZJREVSXzExPC9BY3Rvck9iamVjdElEPgogICAgICAgICAgICA8UGVyc29uPgogICAgICAgICAgICAgICAgPE5hbWU+CiAgICAgICAgICAgICAgICAgICAgPEN1cnJlbnROYW1lPgogICAgICAgICAgICAgICAgICAgICAgICA8R2l2ZW4+T05FPC9HaXZlbj4KICAgICAgICAgICAgICAgICAgICAgICAgPEZhbWlseT5ET0NUT1I8L0ZhbWlseT4KICAgICAgICAgICAgICAgICAgICAgICAgPFRpdGxlPlBoeXNpY2lhbjwvVGl0bGU+CiAgICAgICAgICAgICAgICAgICAgPC9DdXJyZW50TmFtZT4KICAgICAgICAgICAgICAgIDwvTmFtZT4KICAgICAgICAgICAgPC9QZXJzb24+CiAgICAgICAgICAgIDxTcGVjaWFsdHk+CiAgICAgICAgICAgICAgICA8VGV4dD5BbGxvcGF0aGljIGFuZCBPc3Rlb3BhdGhpYyBQaHlzaWNpYW5zLUZhbWlseSBQcmFjdGljZTwvVGV4dD4KICAgICAgICAgICAgPC9TcGVjaWFsdHk+CiAgICAgICAgICAgIDxBZGRyZXNzPgogICAgICAgICAgICAgICAgPFR5cGU+CiAgICAgICAgICAgICAgICAgICAgPFRleHQ+V29yazwvVGV4dD4KICAgICAgICAgICAgICAgIDwvVHlwZT4KICAgICAgICAgICAgPC9BZGRyZXNzPgogICAgICAgICAgICA8U291cmNlPgogICAgICAgICAgICAgICAgPEFjdG9yPgogICAgICAgICAgICAgICAgICAgIDxBY3RvcklEPkFDVE9SU1lTVEVNXzE8L0FjdG9ySUQ+CiAgICAgICAgICAgICAgICA8L0FjdG9yPgogICAgICAgICAgICA8L1NvdXJjZT4KICAgICAgICA8L0FjdG9yPgogICAgICAgIDxBY3Rvcj4KICAgICAgICAgICAgPEFjdG9yT2JqZWN0SUQ+QUNUT1JQUk9WSURFUl82MDwvQWN0b3JPYmplY3RJRD4KICAgICAgICAgICAgPFBlcnNvbj4KICAgICAgICAgICAgICAgIDxOYW1lPgogICAgICAgICAgICAgICAgICAgIDxDdXJyZW50TmFtZT4KICAgICAgICAgICAgICAgICAgICAgICAgPEdpdmVuPlNJWDwvR2l2ZW4+CiAgICAgICAgICAgICAgICAgICAgICAgIDxGYW1pbHk+Q09PUkRJTkFUT1I8L0ZhbWlseT4KICAgICAgICAgICAgICAgICAgICAgICAgPFRpdGxlPkNMSU5JQ0FMIENPT1JESU5BVE9SPC9UaXRsZT4KICAgICAgICAgICAgICAgICAgICA8L0N1cnJlbnROYW1lPgogICAgICAgICAgICAgICAgPC9OYW1lPgogICAgICAgICAgICA8L1BlcnNvbj4KICAgICAgICAgICAgPFNwZWNpYWx0eT4KICAgICAgICAgICAgICAgIDxUZXh0PkFsbG9wYXRoaWMgYW5kIE9zdGVvcGF0aGljIFBoeXNpY2lhbnMtRmFtaWx5IFByYWN0aWNlPC9UZXh0PgogICAgICAgICAgICA8L1NwZWNpYWx0eT4KICAgICAgICAgICAgPEFkZHJlc3M+CiAgICAgICAgICAgICAgICA8VHlwZT4KICAgICAgICAgICAgICAgICAgICA8VGV4dD5Xb3JrPC9UZXh0PgogICAgICAgICAgICAgICAgPC9UeXBlPgogICAgICAgICAgICA8L0FkZHJlc3M+CiAgICAgICAgICAgIDxTb3VyY2U+CiAgICAgICAgICAgICAgICA8QWN0b3I+CiAgICAgICAgICAgICAgICAgICAgPEFjdG9ySUQ+QUNUT1JTWVNURU1fMTwvQWN0b3JJRD4KICAgICAgICAgICAgICAgIDwvQWN0b3I+CiAgICAgICAgICAgIDwvU291cmNlPgogICAgICAgIDwvQWN0b3I+CiAgICAgICAgPEFjdG9yPgogICAgICAgICAgICA8QWN0b3JPYmplY3RJRD5BQ1RPUlNZU1RFTV8xPC9BY3Rvck9iamVjdElEPgogICAgICAgICAgICA8SW5mb3JtYXRpb25TeXN0ZW0+CiAgICAgICAgICAgICAgICA8TmFtZT5Xb3JsZFZpc3RBIEVIUi9WT0U8L05hbWU+CiAgICAgICAgICAgICAgICA8VmVyc2lvbj4xLjA8L1ZlcnNpb24+CiAgICAgICAgICAgIDwvSW5mb3JtYXRpb25TeXN0ZW0+CiAgICAgICAgICAgIDxTb3VyY2U+CiAgICAgICAgICAgICAgICA8QWN0b3I+CiAgICAgICAgICAgICAgICAgICAgPEFjdG9ySUQ+QUNUT1JTWVNURU1fMTwvQWN0b3JJRD4KICAgICAgICAgICAgICAgIDwvQWN0b3I+CiAgICAgICAgICAgIDwvU291cmNlPgogICAgICAgIDwvQWN0b3I+CiAgICA8L0FjdG9ycz4KPC9Db250aW51aXR5T2ZDYXJlUmVjb3JkPgo=" + W $L(GPLBIG) + Q + ; + diff --git a/p/C0PEWD4.m b/p/C0PEWD4.m new file mode 100644 index 0000000..c37a7ac --- /dev/null +++ b/p/C0PEWD4.m @@ -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)="" + k gpl4(0) ; array size node + s gpl4(3)="" + s gpl4(40)="" + s gpl4(28)="" + s gpl4(55)="" + 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 + ; diff --git a/p/C0PEWDU.m b/p/C0PEWDU.m index ff6e457..66d65f0 100644 --- a/p/C0PEWDU.m +++ b/p/C0PEWDU.m @@ -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 + ; diff --git a/p/C0PKIDS.m b/p/C0PKIDS.m new file mode 100644 index 0000000..c078eda --- /dev/null +++ b/p/C0PKIDS.m @@ -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 diff --git a/p/C0PLKUP.m b/p/C0PLKUP.m new file mode 100644 index 0000000..5767f4b --- /dev/null +++ b/p/C0PLKUP.m @@ -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 + ; diff --git a/p/C0PLOAD.m b/p/C0PLOAD.m new file mode 100644 index 0000000..3491d41 --- /dev/null +++ b/p/C0PLOAD.m @@ -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 diff --git a/p/C0PMAIN.m b/p/C0PMAIN.m new file mode 100644 index 0000000..ffdb930 --- /dev/null +++ b/p/C0PMAIN.m @@ -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 diff --git a/p/C0PNVA.m b/p/C0PNVA.m new file mode 100644 index 0000000..266b8c6 --- /dev/null +++ b/p/C0PNVA.m @@ -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 diff --git a/p/C0PPAT.m b/p/C0PPAT.m new file mode 100644 index 0000000..3e157ae --- /dev/null +++ b/p/C0PPAT.m @@ -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 + ; diff --git a/p/C0PRECON.m b/p/C0PRECON.m new file mode 100644 index 0000000..45a3dad --- /dev/null +++ b/p/C0PRECON.m @@ -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 diff --git a/p/C0PREFIL.m b/p/C0PREFIL.m new file mode 100644 index 0000000..f4307c2 --- /dev/null +++ b/p/C0PREFIL.m @@ -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 diff --git a/p/C0PRXNRD.m b/p/C0PRXNRD.m new file mode 100644 index 0000000..418b54e --- /dev/null +++ b/p/C0PRXNRD.m @@ -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 + diff --git a/p/C0PSMEDS.m b/p/C0PSMEDS.m new file mode 100644 index 0000000..440d952 --- /dev/null +++ b/p/C0PSMEDS.m @@ -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 + 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 + ; diff --git a/p/C0PSUB.m b/p/C0PSUB.m new file mode 100644 index 0000000..667a6d8 --- /dev/null +++ b/p/C0PSUB.m @@ -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 diff --git a/p/C0PTEST1.m b/p/C0PTEST1.m new file mode 100644 index 0000000..2dfdd6b --- /dev/null +++ b/p/C0PTEST1.m @@ -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 diff --git a/p/C0PTRAK.m b/p/C0PTRAK.m new file mode 100644 index 0000000..617dd4b --- /dev/null +++ b/p/C0PTRAK.m @@ -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 diff --git a/p/C0PTRXN.m b/p/C0PTRXN.m new file mode 100644 index 0000000..f332c00 --- /dev/null +++ b/p/C0PTRXN.m @@ -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 diff --git a/p/C0PTRXN2.m b/p/C0PTRXN2.m new file mode 100644 index 0000000..926b12b --- /dev/null +++ b/p/C0PTRXN2.m @@ -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 + ; diff --git a/p/C0PWPS.m b/p/C0PWPS.m new file mode 100644 index 0000000..d8d57f3 --- /dev/null +++ b/p/C0PWPS.m @@ -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 + ; diff --git a/p/C0PWS1.m b/p/C0PWS1.m new file mode 100644 index 0000000..5427534 --- /dev/null +++ b/p/C0PWS1.m @@ -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<",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="" + I $E(ZX,1,5)'="" + 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"[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 DATADATA + ; ^ ^ + 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,"")) + . ; 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="" + I $E(ZX,1,5)'="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) + ; diff --git a/p/C0P_1_0_1_T1.KID b/p/C0P_1_0_1_T1.KID deleted file mode 100644 index cc04c95..0000000 --- a/p/C0P_1_0_1_T1.KID +++ /dev/null @@ -1,1484 +0,0 @@ -KIDS Distribution saved on Apr 11, 2009@16:23:57 -Initial ePrescribing prototyping -**KIDS**:C0P*1.0*1^ - -**INSTALL NAME** -C0P*1.0*1 -"BLD",6966,0) -C0P*1.0*1^^0^3090411^y -"BLD",6966,4,0) -^9.64PA^175.201^2 -"BLD",6966,4,175.101,0) -175.101 -"BLD",6966,4,175.101,222) -y^y^f^^n^^y^o^n -"BLD",6966,4,175.201,0) -175.201 -"BLD",6966,4,175.201,222) -y^y^f^^n^^y^o^n -"BLD",6966,4,"B",175.101,175.101) - -"BLD",6966,4,"B",175.201,175.201) - -"BLD",6966,6.3) -1 -"BLD",6966,"KRN",0) -^9.67PA^8989.52^19 -"BLD",6966,"KRN",.4,0) -.4 -"BLD",6966,"KRN",.401,0) -.401 -"BLD",6966,"KRN",.402,0) -.402 -"BLD",6966,"KRN",.403,0) -.403 -"BLD",6966,"KRN",.5,0) -.5 -"BLD",6966,"KRN",.84,0) -.84 -"BLD",6966,"KRN",3.6,0) -3.6 -"BLD",6966,"KRN",3.8,0) -3.8 -"BLD",6966,"KRN",9.2,0) -9.2 -"BLD",6966,"KRN",9.8,0) -9.8 -"BLD",6966,"KRN",9.8,"NM",0) -^9.68A^2^2 -"BLD",6966,"KRN",9.8,"NM",1,0) -C0PEWD1^^0^B8658372 -"BLD",6966,"KRN",9.8,"NM",2,0) -C0PEWDU^^0^B1881609 -"BLD",6966,"KRN",9.8,"NM","B","C0PEWD1",1) - -"BLD",6966,"KRN",9.8,"NM","B","C0PEWDU",2) - -"BLD",6966,"KRN",19,0) -19 -"BLD",6966,"KRN",19.1,0) -19.1 -"BLD",6966,"KRN",101,0) -101 -"BLD",6966,"KRN",409.61,0) -409.61 -"BLD",6966,"KRN",771,0) -771 -"BLD",6966,"KRN",870,0) -870 -"BLD",6966,"KRN",8989.51,0) -8989.51 -"BLD",6966,"KRN",8989.52,0) -8989.52 -"BLD",6966,"KRN",8994,0) -8994 -"BLD",6966,"KRN","B",.4,.4) - -"BLD",6966,"KRN","B",.401,.401) - -"BLD",6966,"KRN","B",.402,.402) - -"BLD",6966,"KRN","B",.403,.403) - -"BLD",6966,"KRN","B",.5,.5) - -"BLD",6966,"KRN","B",.84,.84) - -"BLD",6966,"KRN","B",3.6,3.6) - -"BLD",6966,"KRN","B",3.8,3.8) - -"BLD",6966,"KRN","B",9.2,9.2) - -"BLD",6966,"KRN","B",9.8,9.8) - -"BLD",6966,"KRN","B",19,19) - -"BLD",6966,"KRN","B",19.1,19.1) - -"BLD",6966,"KRN","B",101,101) - -"BLD",6966,"KRN","B",409.61,409.61) - -"BLD",6966,"KRN","B",771,771) - -"BLD",6966,"KRN","B",870,870) - -"BLD",6966,"KRN","B",8989.51,8989.51) - -"BLD",6966,"KRN","B",8989.52,8989.52) - -"BLD",6966,"KRN","B",8994,8994) - -"DATA",175.101,1,0) -DrugAllergyInteraction^https://secure.newcropaccounts.com/V7/webservices/DrugAllergyInteraction -"DATA",175.101,1,1,0) -^175.1012^28^28^3090303^^ -"DATA",175.101,1,1,1,0) - -"DATA",175.101,1,1,3,0) - -"DATA",175.101,1,1,4,0) - string -"DATA",175.101,1,1,5,0) - string -"DATA",175.101,1,1,6,0) - string -"DATA",175.101,1,1,7,0) - -"DATA",175.101,1,1,8,0) - -"DATA",175.101,1,1,9,0) - string -"DATA",175.101,1,1,10,0) - string -"DATA",175.101,1,1,11,0) - -"DATA",175.101,1,1,12,0) - -"DATA",175.101,1,1,13,0) - string -"DATA",175.101,1,1,14,0) - -"DATA",175.101,1,1,15,0) - -"DATA",175.101,1,1,16,0) - string -"DATA",175.101,1,1,17,0) - string -"DATA",175.101,1,1,18,0) - -"DATA",175.101,1,1,19,0) - -"DATA",175.101,1,1,20,0) - string -"DATA",175.101,1,1,21,0) - string -"DATA",175.101,1,1,22,0) - -"DATA",175.101,1,1,23,0) - -"DATA",175.101,1,1,24,0) - string -"DATA",175.101,1,1,25,0) - string -"DATA",175.101,1,1,26,0) - -"DATA",175.101,1,1,27,0) - string -"DATA",175.101,1,1,28,0) - -"DATA",175.101,1,2,0) -^175.1013^18^18^3090303^^ -"DATA",175.101,1,2,1,0) - -"DATA",175.101,1,2,2,0) - -"DATA",175.101,1,2,3,0) - Unknown or OK or Fail or NotFound -"DATA",175.101,1,2,4,0) - string -"DATA",175.101,1,2,5,0) - string -"DATA",175.101,1,2,6,0) - int -"DATA",175.101,1,2,7,0) - int -"DATA",175.101,1,2,8,0) - -"DATA",175.101,1,2,9,0) - -"DATA",175.101,1,2,10,0) - -"DATA",175.101,1,2,11,0) - string -"DATA",175.101,1,2,12,0) - -"DATA",175.101,1,2,13,0) - -"DATA",175.101,1,2,14,0) - string -"DATA",175.101,1,2,15,0) - -"DATA",175.101,1,2,16,0) - -"DATA",175.101,1,2,17,0) - -"DATA",175.101,1,2,18,0) - -"DATA",175.101,2,0) -DrugDrugInteraction^https://secure.newcropaccounts.com/V7/webservices/DrugDrugInteraction -"DATA",175.101,2,1,0) -^^28^28^3090303^ -"DATA",175.101,2,1,1,0) - -"DATA",175.101,2,1,3,0) - -"DATA",175.101,2,1,4,0) - string -"DATA",175.101,2,1,5,0) - string -"DATA",175.101,2,1,6,0) - string -"DATA",175.101,2,1,7,0) - -"DATA",175.101,2,1,8,0) - -"DATA",175.101,2,1,9,0) - string -"DATA",175.101,2,1,10,0) - string -"DATA",175.101,2,1,11,0) - -"DATA",175.101,2,1,12,0) - -"DATA",175.101,2,1,13,0) - string -"DATA",175.101,2,1,14,0) - -"DATA",175.101,2,1,15,0) - -"DATA",175.101,2,1,16,0) - string -"DATA",175.101,2,1,17,0) - string -"DATA",175.101,2,1,18,0) - -"DATA",175.101,2,1,19,0) - -"DATA",175.101,2,1,20,0) - string -"DATA",175.101,2,1,21,0) - string -"DATA",175.101,2,1,22,0) - -"DATA",175.101,2,1,23,0) - -"DATA",175.101,2,1,24,0) - string -"DATA",175.101,2,1,25,0) - string -"DATA",175.101,2,1,26,0) - -"DATA",175.101,2,1,27,0) - string -"DATA",175.101,2,1,28,0) - -"DATA",175.101,2,2,0) -^^48^48^3090303^ -"DATA",175.101,2,2,1,0) - -"DATA",175.101,2,2,3,0) - -"DATA",175.101,2,2,4,0) - -"DATA",175.101,2,2,5,0) - Unknown or OK or Fail or NotFound -"DATA",175.101,2,2,6,0) - string -"DATA",175.101,2,2,7,0) - string -"DATA",175.101,2,2,8,0) - int -"DATA",175.101,2,2,9,0) - int -"DATA",175.101,2,2,10,0) - -"DATA",175.101,2,2,11,0) - -"DATA",175.101,2,2,12,0) - -"DATA",175.101,2,2,13,0) - string -"DATA",175.101,2,2,14,0) - string -"DATA",175.101,2,2,15,0) - string -"DATA",175.101,2,2,16,0) - string -"DATA",175.101,2,2,17,0) - string -"DATA",175.101,2,2,18,0) - string -"DATA",175.101,2,2,19,0) - string -"DATA",175.101,2,2,20,0) - string -"DATA",175.101,2,2,21,0) - string -"DATA",175.101,2,2,22,0) - string -"DATA",175.101,2,2,23,0) - string -"DATA",175.101,2,2,24,0) - string -"DATA",175.101,2,2,25,0) - string -"DATA",175.101,2,2,26,0) - string -"DATA",175.101,2,2,27,0) - string -"DATA",175.101,2,2,28,0) - -"DATA",175.101,2,2,29,0) - -"DATA",175.101,2,2,30,0) - string -"DATA",175.101,2,2,31,0) - string -"DATA",175.101,2,2,32,0) - string -"DATA",175.101,2,2,33,0) - string -"DATA",175.101,2,2,34,0) - string -"DATA",175.101,2,2,35,0) - string -"DATA",175.101,2,2,36,0) - string -"DATA",175.101,2,2,37,0) - string -"DATA",175.101,2,2,38,0) - string -"DATA",175.101,2,2,39,0) - string -"DATA",175.101,2,2,40,0) - string -"DATA",175.101,2,2,41,0) - string -"DATA",175.101,2,2,42,0) - string -"DATA",175.101,2,2,43,0) - string -"DATA",175.101,2,2,44,0) - string -"DATA",175.101,2,2,45,0) - -"DATA",175.101,2,2,46,0) - -"DATA",175.101,2,2,47,0) - -"DATA",175.101,2,2,48,0) - -"DATA",175.101,3,0) -DrugFoodInteraction^https://secure.newcropaccounts.com/V7/webservices/DrugFoodInteraction -"DATA",175.101,3,1,0) -^^14^14^3090303^ -"DATA",175.101,3,1,1,0) - -"DATA",175.101,3,1,3,0) - -"DATA",175.101,3,1,4,0) - string -"DATA",175.101,3,1,5,0) - string -"DATA",175.101,3,1,6,0) - string -"DATA",175.101,3,1,7,0) - -"DATA",175.101,3,1,8,0) - -"DATA",175.101,3,1,9,0) - string -"DATA",175.101,3,1,10,0) - string -"DATA",175.101,3,1,11,0) - -"DATA",175.101,3,1,12,0) - string -"DATA",175.101,3,1,13,0) - string -"DATA",175.101,3,1,14,0) - -"DATA",175.101,3,2,0) -^^32^32^3090303^ -"DATA",175.101,3,2,1,0) - -"DATA",175.101,3,2,3,0) - -"DATA",175.101,3,2,4,0) - -"DATA",175.101,3,2,5,0) - Unknown or OK or Fail or NotFound -"DATA",175.101,3,2,6,0) - string -"DATA",175.101,3,2,7,0) - string -"DATA",175.101,3,2,8,0) - int -"DATA",175.101,3,2,9,0) - int -"DATA",175.101,3,2,10,0) - -"DATA",175.101,3,2,11,0) - -"DATA",175.101,3,2,12,0) - -"DATA",175.101,3,2,13,0) - string -"DATA",175.101,3,2,14,0) - string -"DATA",175.101,3,2,15,0) - string -"DATA",175.101,3,2,16,0) - string -"DATA",175.101,3,2,17,0) - string -"DATA",175.101,3,2,18,0) - string -"DATA",175.101,3,2,19,0) - string -"DATA",175.101,3,2,20,0) - -"DATA",175.101,3,2,21,0) - -"DATA",175.101,3,2,22,0) - string -"DATA",175.101,3,2,23,0) - string -"DATA",175.101,3,2,24,0) - string -"DATA",175.101,3,2,25,0) - string -"DATA",175.101,3,2,26,0) - string -"DATA",175.101,3,2,27,0) - string -"DATA",175.101,3,2,28,0) - string -"DATA",175.101,3,2,29,0) - -"DATA",175.101,3,2,30,0) - -"DATA",175.101,3,2,31,0) - -"DATA",175.101,3,2,32,0) - -"DATA",175.101,4,0) -DrugSearchWithFormulary^https://secure.newcropaccounts.com/V7/webservices/DrugSearchWithFormulary -"DATA",175.101,4,1,0) -^^26^26^3090303^ -"DATA",175.101,4,1,1,0) - -"DATA",175.101,4,1,3,0) - -"DATA",175.101,4,1,4,0) - string -"DATA",175.101,4,1,5,0) - string -"DATA",175.101,4,1,6,0) - string -"DATA",175.101,4,1,7,0) - -"DATA",175.101,4,1,8,0) - -"DATA",175.101,4,1,9,0) - string -"DATA",175.101,4,1,10,0) - string -"DATA",175.101,4,1,11,0) - -"DATA",175.101,4,1,12,0) - -"DATA",175.101,4,1,13,0) - string -"DATA",175.101,4,1,14,0) - -"DATA",175.101,4,1,15,0) - -"DATA",175.101,4,1,16,0) - string -"DATA",175.101,4,1,17,0) - string -"DATA",175.101,4,1,18,0) - -"DATA",175.101,4,1,19,0) - string -"DATA",175.101,4,1,20,0) - string -"DATA",175.101,4,1,21,0) - string -"DATA",175.101,4,1,22,0) - string -"DATA",175.101,4,1,23,0) - string -"DATA",175.101,4,1,24,0) - string -"DATA",175.101,4,1,25,0) - string -"DATA",175.101,4,1,26,0) - -"DATA",175.101,4,2,0) -^^22^22^3090303^ -"DATA",175.101,4,2,1,0) - -"DATA",175.101,4,2,3,0) - -"DATA",175.101,4,2,4,0) - -"DATA",175.101,4,2,5,0) - Unknown or OK or Fail or NotFound -"DATA",175.101,4,2,6,0) - string -"DATA",175.101,4,2,7,0) - string -"DATA",175.101,4,2,8,0) - int -"DATA",175.101,4,2,9,0) - int -"DATA",175.101,4,2,10,0) - -"DATA",175.101,4,2,11,0) - -"DATA",175.101,4,2,12,0) - -"DATA",175.101,4,2,13,0) - -"DATA",175.101,4,2,14,0) - string -"DATA",175.101,4,2,15,0) - -"DATA",175.101,4,2,16,0) - -"DATA",175.101,4,2,17,0) - -"DATA",175.101,4,2,18,0) - string -"DATA",175.101,4,2,19,0) - -"DATA",175.101,4,2,20,0) - -"DATA",175.101,4,2,21,0) - -"DATA",175.101,4,2,22,0) - -"DATA",175.101,5,0) -DrugsByDiagnosis^https://secure.newcropaccounts.com/V7/webservices/DrugsByDiagnosis -"DATA",175.101,5,1,0) -^^24^24^3090303^ -"DATA",175.101,5,1,1,0) - -"DATA",175.101,5,1,3,0) - -"DATA",175.101,5,1,4,0) - string -"DATA",175.101,5,1,5,0) - string -"DATA",175.101,5,1,6,0) - string -"DATA",175.101,5,1,7,0) - -"DATA",175.101,5,1,8,0) - -"DATA",175.101,5,1,9,0) - string -"DATA",175.101,5,1,10,0) - string -"DATA",175.101,5,1,11,0) - -"DATA",175.101,5,1,12,0) - -"DATA",175.101,5,1,13,0) - string -"DATA",175.101,5,1,14,0) - -"DATA",175.101,5,1,15,0) - -"DATA",175.101,5,1,16,0) - string -"DATA",175.101,5,1,17,0) - string -"DATA",175.101,5,1,18,0) - -"DATA",175.101,5,1,19,0) - -"DATA",175.101,5,1,20,0) - string -"DATA",175.101,5,1,21,0) - string -"DATA",175.101,5,1,22,0) - -"DATA",175.101,5,1,23,0) - string -"DATA",175.101,5,1,24,0) - -"DATA",175.101,5,2,0) -^^56^56^3090303^ -"DATA",175.101,5,2,1,0) - -"DATA",175.101,5,2,3,0) - -"DATA",175.101,5,2,4,0) - -"DATA",175.101,5,2,5,0) - Unknown or OK or Fail or NotFound -"DATA",175.101,5,2,6,0) - string -"DATA",175.101,5,2,7,0) - string -"DATA",175.101,5,2,8,0) - int -"DATA",175.101,5,2,9,0) - int -"DATA",175.101,5,2,10,0) - -"DATA",175.101,5,2,11,0) - -"DATA",175.101,5,2,12,0) - -"DATA",175.101,5,2,13,0) - string -"DATA",175.101,5,2,14,0) - string -"DATA",175.101,5,2,15,0) - string -"DATA",175.101,5,2,16,0) - string -"DATA",175.101,5,2,17,0) - string -"DATA",175.101,5,2,18,0) - string -"DATA",175.101,5,2,19,0) - string -"DATA",175.101,5,2,20,0) - string -"DATA",175.101,5,2,21,0) - string -"DATA",175.101,5,2,22,0) - string -"DATA",175.101,5,2,23,0) - string -"DATA",175.101,5,2,24,0) - string -"DATA",175.101,5,2,25,0) - string -"DATA",175.101,5,2,26,0) - string -"DATA",175.101,5,2,27,0) - -"DATA",175.101,5,2,28,0) -string -"DATA",175.101,5,2,29,0) - string -"DATA",175.101,5,2,30,0) - string -"DATA",175.101,5,2,31,0) - string -"DATA",175.101,5,2,32,0) - -"DATA",175.101,5,2,33,0) - -"DATA",175.101,5,2,34,0) - string -"DATA",175.101,5,2,35,0) - string -"DATA",175.101,5,2,36,0) - string -"DATA",175.101,5,2,37,0) - string -"DATA",175.101,5,2,38,0) - string -"DATA",175.101,5,2,39,0) - string -"DATA",175.101,5,2,40,0) - string -"DATA",175.101,5,2,41,0) - string -"DATA",175.101,5,2,42,0) - string -"DATA",175.101,5,2,43,0) - string -"DATA",175.101,5,2,44,0) - string -"DATA",175.101,5,2,45,0) - string -"DATA",175.101,5,2,46,0) - string -"DATA",175.101,5,2,47,0) - string -"DATA",175.101,5,2,48,0) - -"DATA",175.101,5,2,49,0) -string -"DATA",175.101,5,2,50,0) - string -"DATA",175.101,5,2,51,0) - string -"DATA",175.101,5,2,52,0) - string -"DATA",175.101,5,2,53,0) - -"DATA",175.101,5,2,54,0) - -"DATA",175.101,5,2,55,0) - -"DATA",175.101,5,2,56,0) - -"DATA",175.101,6,0) -DrugsByDiagnosisWithFormulary^https://secure.newcropaccounts.com/V7/webservices/DrugsByDiagnosisWithFormulary -"DATA",175.101,6,1,0) -^^26^26^3090303^ -"DATA",175.101,6,1,1,0) - -"DATA",175.101,6,1,3,0) - -"DATA",175.101,6,1,4,0) - string -"DATA",175.101,6,1,5,0) - string -"DATA",175.101,6,1,6,0) - string -"DATA",175.101,6,1,7,0) - -"DATA",175.101,6,1,8,0) - -"DATA",175.101,6,1,9,0) - string -"DATA",175.101,6,1,10,0) - string -"DATA",175.101,6,1,11,0) - -"DATA",175.101,6,1,12,0) - -"DATA",175.101,6,1,13,0) - string -"DATA",175.101,6,1,14,0) - -"DATA",175.101,6,1,15,0) - -"DATA",175.101,6,1,16,0) - string -"DATA",175.101,6,1,17,0) - string -"DATA",175.101,6,1,18,0) - -"DATA",175.101,6,1,19,0) - string -"DATA",175.101,6,1,20,0) - string -"DATA",175.101,6,1,21,0) - -"DATA",175.101,6,1,22,0) - string -"DATA",175.101,6,1,23,0) - string -"DATA",175.101,6,1,24,0) - -"DATA",175.101,6,1,25,0) - string -"DATA",175.101,6,1,26,0) - -"DATA",175.101,6,2,0) -^^22^22^3090303^ -"DATA",175.101,6,2,1,0) - -"DATA",175.101,6,2,3,0) - -"DATA",175.101,6,2,4,0) - -"DATA",175.101,6,2,5,0) - Unknown or OK or Fail or NotFound -"DATA",175.101,6,2,6,0) - string -"DATA",175.101,6,2,7,0) - string -"DATA",175.101,6,2,8,0) - int -"DATA",175.101,6,2,9,0) - int -"DATA",175.101,6,2,10,0) - -"DATA",175.101,6,2,11,0) - -"DATA",175.101,6,2,12,0) - -"DATA",175.101,6,2,13,0) - -"DATA",175.101,6,2,14,0) - string -"DATA",175.101,6,2,15,0) - -"DATA",175.101,6,2,16,0) - -"DATA",175.101,6,2,17,0) - -"DATA",175.101,6,2,18,0) - string -"DATA",175.101,6,2,19,0) - -"DATA",175.101,6,2,20,0) - -"DATA",175.101,6,2,21,0) - -"DATA",175.101,6,2,22,0) - -"DATA",175.101,7,0) -ValidateNDCList^https://secure.newcropaccounts.com/V7/webservices/ValidateNDCList -"DATA",175.101,7,1,0) -^^13^13^3090303^ -"DATA",175.101,7,1,1,0) - -"DATA",175.101,7,1,3,0) - -"DATA",175.101,7,1,4,0) - string -"DATA",175.101,7,1,5,0) - string -"DATA",175.101,7,1,6,0) - string -"DATA",175.101,7,1,7,0) - -"DATA",175.101,7,1,8,0) - -"DATA",175.101,7,1,9,0) - string -"DATA",175.101,7,1,10,0) - string -"DATA",175.101,7,1,11,0) - -"DATA",175.101,7,1,12,0) - string -"DATA",175.101,7,1,13,0) - -"DATA",175.101,7,2,0) -^^22^22^3090303^ -"DATA",175.101,7,2,1,0) - -"DATA",175.101,7,2,3,0) - -"DATA",175.101,7,2,4,0) - -"DATA",175.101,7,2,5,0) - Unknown or OK or Fail or NotFound -"DATA",175.101,7,2,6,0) - string -"DATA",175.101,7,2,7,0) - string -"DATA",175.101,7,2,8,0) - int -"DATA",175.101,7,2,9,0) - int -"DATA",175.101,7,2,10,0) - -"DATA",175.101,7,2,11,0) - -"DATA",175.101,7,2,12,0) - -"DATA",175.101,7,2,13,0) - string -"DATA",175.101,7,2,14,0) - string -"DATA",175.101,7,2,15,0) - -"DATA",175.101,7,2,16,0) - -"DATA",175.101,7,2,17,0) - string -"DATA",175.101,7,2,18,0) - string -"DATA",175.101,7,2,19,0) - -"DATA",175.101,7,2,20,0) - -"DATA",175.101,7,2,21,0) - -"DATA",175.101,7,2,22,0) - -"DATA",175.201,2,0) -EPRESCRIBING -"DATA",175.201,2,1,0) -^175.2011P^2^2 -"DATA",175.201,2,1,1,0) -1^1 -"DATA",175.201,2,1,2,0) -3^2 -"FIA",175.101) -C0P APPLICATION STEPS -"FIA",175.101,0) -^C0PS( -"FIA",175.101,0,0) -175.101 -"FIA",175.101,0,1) -y^y^f^^n^^y^o^n -"FIA",175.101,0,10) - -"FIA",175.101,0,11) - -"FIA",175.101,0,"RLRO") - -"FIA",175.101,175.101) -0 -"FIA",175.101,175.1012) -0 -"FIA",175.101,175.1013) -0 -"FIA",175.201) -C0P WEB APPLICATIONS -"FIA",175.201,0) -^C0PAPP( -"FIA",175.201,0,0) -175.201 -"FIA",175.201,0,1) -y^y^f^^n^^y^o^n -"FIA",175.201,0,10) - -"FIA",175.201,0,11) - -"FIA",175.201,0,"RLRO") - -"FIA",175.201,175.201) -0 -"FIA",175.201,175.2011) -0 -"MBREQ") -0 -"QUES","XPF1",0) -Y -"QUES","XPF1","??") -^D REP^XPDH -"QUES","XPF1","A") -Shall I write over your |FLAG| File -"QUES","XPF1","B") -YES -"QUES","XPF1","M") -D XPF1^XPDIQ -"QUES","XPF2",0) -Y -"QUES","XPF2","??") -^D DTA^XPDH -"QUES","XPF2","A") -Want my data |FLAG| yours -"QUES","XPF2","B") -YES -"QUES","XPF2","M") -D XPF2^XPDIQ -"QUES","XPI1",0) -YO -"QUES","XPI1","??") -^D INHIBIT^XPDH -"QUES","XPI1","A") -Want KIDS to INHIBIT LOGONs during the install -"QUES","XPI1","B") -NO -"QUES","XPI1","M") -D XPI1^XPDIQ -"QUES","XPM1",0) -PO^VA(200,:EM -"QUES","XPM1","??") -^D MG^XPDH -"QUES","XPM1","A") -Enter the Coordinator for Mail Group '|FLAG|' -"QUES","XPM1","B") - -"QUES","XPM1","M") -D XPM1^XPDIQ -"QUES","XPO1",0) -Y -"QUES","XPO1","??") -^D MENU^XPDH -"QUES","XPO1","A") -Want KIDS to Rebuild Menu Trees Upon Completion of Install -"QUES","XPO1","B") -NO -"QUES","XPO1","M") -D XPO1^XPDIQ -"QUES","XPZ1",0) -Y -"QUES","XPZ1","??") -^D OPT^XPDH -"QUES","XPZ1","A") -Want to DISABLE Scheduled Options, Menu Options, and Protocols -"QUES","XPZ1","B") -NO -"QUES","XPZ1","M") -D XPZ1^XPDIQ -"QUES","XPZ2",0) -Y -"QUES","XPZ2","??") -^D RTN^XPDH -"QUES","XPZ2","A") -Want to MOVE routines to other CPUs -"QUES","XPZ2","B") -NO -"QUES","XPZ2","M") -D XPZ2^XPDIQ -"RTN") -2 -"RTN","C0PEWD1") -0^1^B8658372 -"RTN","C0PEWD1",1,0) -C0CEWD1 ; CCDCCR/GPL - CCR FILEMAN utilities; 12/6/08 -"RTN","C0PEWD1",2,0) - ;;0.1;CCDCCR;nopatch;noreleasedate;Build 1 -"RTN","C0PEWD1",3,0) - ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU -"RTN","C0PEWD1",4,0) - ;General Public License See attached copy of the License. -"RTN","C0PEWD1",5,0) - ; -"RTN","C0PEWD1",6,0) - ;This program is free software; you can redistribute it and/or modify -"RTN","C0PEWD1",7,0) - ;it under the terms of the GNU General Public License as published by -"RTN","C0PEWD1",8,0) - ;the Free Software Foundation; either version 2 of the License, or -"RTN","C0PEWD1",9,0) - ;(at your option) any later version. -"RTN","C0PEWD1",10,0) - ; -"RTN","C0PEWD1",11,0) - ;This program is distributed in the hope that it will be useful, -"RTN","C0PEWD1",12,0) - ;but WITHOUT ANY WARRANTY; without even the implied warranty of -"RTN","C0PEWD1",13,0) - ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -"RTN","C0PEWD1",14,0) - ;GNU General Public License for more details. -"RTN","C0PEWD1",15,0) - ; -"RTN","C0PEWD1",16,0) - ;You should have received a copy of the GNU General Public License along -"RTN","C0PEWD1",17,0) - ;with this program; if not, write to the Free Software Foundation, Inc., -"RTN","C0PEWD1",18,0) - ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -"RTN","C0PEWD1",19,0) - ; -"RTN","C0PEWD1",20,0) - Q -"RTN","C0PEWD1",21,0) - ;TEST(filepath) ; filepath IS THE PATH/FILE TO BE READ IN -"RTN","C0PEWD1",22,0) - i $g(^%ZISH)["" d ; if the VistA Kernal routine %ZISH exists -"RTN","C0PEWD1",23,0) - . n zfile,zpath,ztmp s (zfile,zpath,ztmp)="" -"RTN","C0PEWD1",24,0) - . s zfile=$re($p($re(filepath),"/",1)) ;file name -"RTN","C0PEWD1",25,0) - . s zpath=$p(filepath,zfile,1) ; file path -"RTN","C0PEWD1",26,0) - . s ztmp=$na(^CacheTempEWD($j,0)) -"RTN","C0PEWD1",27,0) - . s ok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file incrementing subscr 2 -"RTN","C0PEWD1",28,0) - q -"RTN","C0PEWD1",29,0) - ; -"RTN","C0PEWD1",30,0) -TEST2 ; -"RTN","C0PEWD1",31,0) - s zfilepath="/home/vademo2/CCR/PAT_780_CCR_V1_0_17.xml" -"RTN","C0PEWD1",32,0) - ;s ok=$$gtmImportFile^%zewdHTMLParser(zfilepath) -"RTN","C0PEWD1",33,0) - s ok=$$LOAD(zfilepath) ;load the XML file to the EWD global -"RTN","C0PEWD1",34,0) - s ok=$$parseDocument^%zewdHTMLParser("DerekDOM",0) -"RTN","C0PEWD1",35,0) - ;s ok=$$parseXMLFile^%zewdAPI(zfilepath,"fourthDOM") -"RTN","C0PEWD1",36,0) - w ok,! -"RTN","C0PEWD1",37,0) - q -"RTN","C0PEWD1",38,0) - ; -"RTN","C0PEWD1",39,0) -GPLTEST ; -"RTN","C0PEWD1",40,0) - ;s ok=$$httpGET^%zewdGTM("http://preproduction.newcropaccounts.com/InterfaceV7/NewrxFDB.xml",.gpl) -"RTN","C0PEWD1",41,0) - s URL="https://trac.opensourcevista.net/CCD-CCR-Project/browser/ccr/tags/CCR_1_0_7/output" -"RTN","C0PEWD1",42,0) - s ok=$$httpGET^%zewdGTM(URL,.gpl) -"RTN","C0PEWD1",43,0) - S ZG="" -"RTN","C0PEWD1",44,0) - F S ZG=$O(gpl(ZG)) Q:ZG="" D ; -"RTN","C0PEWD1",45,0) - . s gpl(ZG)=$$CLEAN^C0PEWDU(gpl(ZG)) ; -"RTN","C0PEWD1",46,0) - . ;w gpl(ZG) -"RTN","C0PEWD1",47,0) - m ^CacheTempEWD($j)=gpl -"RTN","C0PEWD1",48,0) - b -"RTN","C0PEWD1",49,0) - s ok=$$parseDocument^%zewdHTMLParser("gpl2",0) -"RTN","C0PEWD1",50,0) - s ok=$$outputDOM^%zewdDOM("gpl2",1,1) -"RTN","C0PEWD1",51,0) - Q -"RTN","C0PEWD1",52,0) - ; -"RTN","C0PEWD1",53,0) -CLEAN(INX) ;DELETE NON-PRINTING CHARACTER IN INX, PASSED BY VALUE -"RTN","C0PEWD1",54,0) - ;DON'T USE THIS -- IT DOESN'T WORK -- USE $$CLEAN^C0PEWDU -"RTN","C0PEWD1",55,0) - ;N ZT,ZI -"RTN","C0PEWD1",56,0) - S ZT="" -"RTN","C0PEWD1",57,0) - F ZI=32:1:126 S ZT=ZT_$CHAR(ZI) -"RTN","C0PEWD1",58,0) - S ZZ=$TR(INX,ZT) -"RTN","C0PEWD1",59,0) - Q ZZ -"RTN","C0PEWD1",60,0) - ; -"RTN","C0PEWD1",61,0) -LOAD(filepath) ; load an xml file into the EWD global for DOM processing -"RTN","C0PEWD1",62,0) - ; need to call s error=$$parseDocument^%zewdHTMLParser(docName,isHTML) -"RTN","C0PEWD1",63,0) - ; after to process it to the DOM - isHTML=0 for XML files -"RTN","C0PEWD1",64,0) - n i -"RTN","C0PEWD1",65,0) - i $g(^%ZISH)["" d QUIT i ; if VistA Kernal routine %ZISH exists - gpl 2/23/09 -"RTN","C0PEWD1",66,0) - . n zfile,zpath,ztmp,zok s (zfile,zpath,ztmp)="" -"RTN","C0PEWD1",67,0) - . s zfile=$re($p($re(filepath),"/",1)) ;file name -"RTN","C0PEWD1",68,0) - . s zpath=$p(filepath,zfile,1) ; file path -"RTN","C0PEWD1",69,0) - . s ztmp=$na(^CacheTempEWD($j,0)) -"RTN","C0PEWD1",70,0) - . s zok=$$FTG^%ZISH(zpath,zfile,ztmp,2) ; import the file increment subscr 2 -"RTN","C0PEWD1",71,0) - . s i=$o(^CacheTempEWD($j,""),-1) ; highest line number -"RTN","C0PEWD1",72,0) - q i -"RTN","C0PEWD1",73,0) - ; -"RTN","C0PEWD1",74,0) -Q(ZQ,ZD) ; SEND QUERY ZQ TO DOM ZD AND DIPLAY NODES RETURNED -"RTN","C0PEWD1",75,0) - I '$D(ZD) S ZD="DerekDOM" -"RTN","C0PEWD1",76,0) - s error=$$select^%zewdXPath(ZQ,ZD,.nodes) ; -"RTN","C0PEWD1",77,0) - d displayNodes^%zewdXPath(.nodes) -"RTN","C0PEWD1",78,0) - q -"RTN","C0PEWD1",79,0) - ; -"RTN","C0PEWDU") -0^2^B1881609 -"RTN","C0PEWDU",1,0) -C0PEWDU ; WV/SMH - E-prescription utilities; Mar 3 2009 -"RTN","C0PEWDU",2,0) - ;;0.1;WV EPrescribing;;;Build 1 -"RTN","C0PEWDU",3,0) - Q -"RTN","C0PEWDU",4,0) - ; -"RTN","C0PEWDU",5,0) -CLEAN(STR) ; extrinsic function; returns string -"RTN","C0PEWDU",6,0) - ;; Removes all non printable characters from a string. -"RTN","C0PEWDU",7,0) - ;; STR by Value -"RTN","C0PEWDU",8,0) - N TR,I -"RTN","C0PEWDU",9,0) - F I=0:1:31 S TR=$G(TR)_$C(I) -"RTN","C0PEWDU",10,0) - S TR=TR_$C(127) -"RTN","C0PEWDU",11,0) - QUIT $TR(STR,TR) -"RTN","C0PEWDU",12,0) - ; -"RTN","C0PEWDU",13,0) -GETSOAP(ENTRY,REQUEST,RESULT) ; XML SOAP Spec for NewCrop -"RTN","C0PEWDU",14,0) - ;; Gets world processing field from Fileman for Parsing -"RTN","C0PEWDU",15,0) - ;; ENTRY Input by Value -"RTN","C0PEWDU",16,0) - ;; REQUEST XML Output by Reference -"RTN","C0PEWDU",17,0) - ;; RESULT XML Output by Reference -"RTN","C0PEWDU",18,0) - ;; Example call: D GETSOAP^C0PEWDU("DrugAllergyInteraction",.REQ,.RES) -"RTN","C0PEWDU",19,0) - ; -"RTN","C0PEWDU",20,0) - N OK,ERR,IEN,F ; if call is okay, Error, IEN, File -"RTN","C0PEWDU",21,0) - S F=175.101 -"RTN","C0PEWDU",22,0) - S IEN=$$FIND1^DIC(F,"","",ENTRY,"B") -"RTN","C0PEWDU",23,0) - S OK=$$GET1^DIQ(F,IEN,2,"","REQUEST","ERR") -"RTN","C0PEWDU",24,0) - I OK=""!($D(ERR)) S REQUEST="" -"RTN","C0PEWDU",25,0) - ; M ^CacheTempEWD($j)=REQUEST -"RTN","C0PEWDU",26,0) - ; K REQUEST -"RTN","C0PEWDU",27,0) - ; S ok=$$parseDocument^%zewdHTMLParser("REQUEST",0) -"RTN","C0PEWDU",28,0) - ; S ok=$$outputDOM^%zewdDOM("REQUEST",1,1) -"RTN","C0PEWDU",29,0) - ; Q ; remove later -"RTN","C0PEWDU",30,0) - K OK,ERR -"RTN","C0PEWDU",31,0) - S OK=$$GET1^DIQ(F,IEN,3,"","RESULT","ERR") -"RTN","C0PEWDU",32,0) - I OK=""!($D(ERR)) S RESULT="" -"RTN","C0PEWDU",33,0) - QUIT -"RTN","C0PEWDU",34,0) - ; -"SEC","^DIC",175.101,175.101,0,"AUDIT") -@ -"SEC","^DIC",175.101,175.101,0,"DD") -@ -"SEC","^DIC",175.101,175.101,0,"DEL") -@ -"SEC","^DIC",175.101,175.101,0,"LAYGO") -@ -"SEC","^DIC",175.101,175.101,0,"RD") -@ -"SEC","^DIC",175.101,175.101,0,"WR") -@ -"SEC","^DIC",175.201,175.201,0,"AUDIT") -@ -"SEC","^DIC",175.201,175.201,0,"DD") -@ -"SEC","^DIC",175.201,175.201,0,"DEL") -@ -"SEC","^DIC",175.201,175.201,0,"LAYGO") -@ -"SEC","^DIC",175.201,175.201,0,"RD") -@ -"SEC","^DIC",175.201,175.201,0,"WR") -@ -"VER") -8.0^22.0 -"^DD",175.101,175.101,0) -FIELD^^.05^5 -"^DD",175.101,175.101,0,"DDA") -N -"^DD",175.101,175.101,0,"DT") -3090303 -"^DD",175.101,175.101,0,"IX","B",175.101,.01) - -"^DD",175.101,175.101,0,"NM","C0P APPLICATION STEPS") - -"^DD",175.101,175.101,0,"PT",175.2011,.01) - -"^DD",175.101,175.101,.01,0) -STEP NAME^RF^^0;1^K:$L(X)>30!(X?.N)!($L(X)<3)!'(X'?1P.E) X -"^DD",175.101,175.101,.01,.1) -APPLICATION STEP NAME -"^DD",175.101,175.101,.01,1,0) -^.1 -"^DD",175.101,175.101,.01,1,1,0) -175.101^B -"^DD",175.101,175.101,.01,1,1,1) -S ^C0PS("B",$E(X,1,30),DA)="" -"^DD",175.101,175.101,.01,1,1,2) -K ^C0PS("B",$E(X,1,30),DA) -"^DD",175.101,175.101,.01,3) -APPLICATION STEP NAME -"^DD",175.101,175.101,.01,"DT") -3090303 -"^DD",175.101,175.101,.05,0) -SEQUENCE^NJ9,0^^3;1^K:+X'=X!(X>999999999)!(X<1)!(X?.E1"."1.N) X -"^DD",175.101,175.101,.05,.1) -STEP SEQUENCE NUMBER -"^DD",175.101,175.101,.05,3) -STEP SEQUENCE NUMBER -"^DD",175.101,175.101,.05,"DT") -3090303 -"^DD",175.101,175.101,1,0) -URL^F^^0;2^K:$L(X)>200!($L(X)<1) X -"^DD",175.101,175.101,1,.1) -URL OF WEB SERVICE -"^DD",175.101,175.101,1,3) -URL OF WEB SERVICE -"^DD",175.101,175.101,1,"DT") -3090303 -"^DD",175.101,175.101,2,0) -REQUEST XML^175.1012^^1;0 -"^DD",175.101,175.101,3,0) -RESPONSE XML^175.1013^^2;0 -"^DD",175.101,175.1012,0) -REQUEST XML SUB-FIELD^^.01^1 -"^DD",175.101,175.1012,0,"DT") -3090303 -"^DD",175.101,175.1012,0,"NM","REQUEST XML") - -"^DD",175.101,175.1012,0,"UP") -175.101 -"^DD",175.101,175.1012,.01,0) -REQUEST XML^Wx^^0;1 -"^DD",175.101,175.1012,.01,.1) -REQUEST XML FOR THIS WEB SERVICE STEP -"^DD",175.101,175.1012,.01,3) -REQUEST XML FOR THIS WEB SERVICE STEP -"^DD",175.101,175.1012,.01,"DT") -3090303 -"^DD",175.101,175.1013,0) -RESPONSE XML SUB-FIELD^^.01^1 -"^DD",175.101,175.1013,0,"DT") -3090303 -"^DD",175.101,175.1013,0,"NM","RESPONSE XML") - -"^DD",175.101,175.1013,0,"UP") -175.101 -"^DD",175.101,175.1013,.01,0) -RESPONSE XML^Wx^^0;1 -"^DD",175.101,175.1013,.01,.1) -RESPONSE XML FOR THIS APPLICATION STEP -"^DD",175.101,175.1013,.01,3) -RESPONSE XML FOR THIS APPLICATION STEP -"^DD",175.101,175.1013,.01,"DT") -3090303 -"^DD",175.201,175.201,0) -FIELD^^1^2 -"^DD",175.201,175.201,0,"DDA") -N -"^DD",175.201,175.201,0,"DT") -3090303 -"^DD",175.201,175.201,0,"IX","B",175.201,.01) - -"^DD",175.201,175.201,0,"NM","C0P WEB APPLICATIONS") - -"^DD",175.201,175.201,.01,0) -APPLICATION NAME^RF^^0;1^K:$L(X)>30!($L(X)<3)!'(X'?1P.E) X -"^DD",175.201,175.201,.01,.1) -WEB APPLICATION NAME -"^DD",175.201,175.201,.01,1,0) -^.1 -"^DD",175.201,175.201,.01,1,1,0) -175.201^B -"^DD",175.201,175.201,.01,1,1,1) -S ^C0PAPP("B",$E(X,1,30),DA)="" -"^DD",175.201,175.201,.01,1,1,2) -K ^C0PAPP("B",$E(X,1,30),DA) -"^DD",175.201,175.201,.01,3) -APPLICATION NAME -"^DD",175.201,175.201,.01,"DT") -3090303 -"^DD",175.201,175.201,1,0) -STEPS^175.2011P^^1;0 -"^DD",175.201,175.2011,0) -STEPS SUB-FIELD^^1^2 -"^DD",175.201,175.2011,0,"DT") -3090303 -"^DD",175.201,175.2011,0,"IX","B",175.2011,.01) - -"^DD",175.201,175.2011,0,"NM","STEPS") - -"^DD",175.201,175.2011,0,"UP") -175.201 -"^DD",175.201,175.2011,.01,0) -STEPS^MP175.101^C0PS(^0;1^Q -"^DD",175.201,175.2011,.01,.1) -APPLICATION STEPS -"^DD",175.201,175.2011,.01,1,0) -^.1 -"^DD",175.201,175.2011,.01,1,1,0) -175.2011^B -"^DD",175.201,175.2011,.01,1,1,1) -S ^C0PAPP(DA(1),1,"B",$E(X,1,30),DA)="" -"^DD",175.201,175.2011,.01,1,1,2) -K ^C0PAPP(DA(1),1,"B",$E(X,1,30),DA) -"^DD",175.201,175.2011,.01,3) -APPLICATIONS STEPS -"^DD",175.201,175.2011,.01,"DT") -3090303 -"^DD",175.201,175.2011,1,0) -SEQUENCE^NJ8,0^^0;2^K:+X'=X!(X>99999999)!(X<1)!(X?.E1"."1.N) X -"^DD",175.201,175.2011,1,.1) -STEP SEQUENCE -"^DD",175.201,175.2011,1,3) -STEP SEQUENCE -"^DD",175.201,175.2011,1,"DT") -3090303 -"^DIC",175.101,175.101,0) -C0P APPLICATION STEPS^175.101 -"^DIC",175.101,175.101,0,"GL") -^C0PS( -"^DIC",175.101,175.101,"%",0) -^1.005^^ -"^DIC",175.101,175.101,"%D",0) -^^10^10^3090303^ -"^DIC",175.101,175.101,"%D",1,0) -This file is being built to support the ePrescribing project. It contains -"^DIC",175.101,175.101,"%D",2,0) -application steps that are used in combination to retrieve information -"^DIC",175.101,175.101,"%D",3,0) -from external web services, combine them, and store them in variables for -"^DIC",175.101,175.101,"%D",4,0) -use in the Order Checking process. In addition, if external meds are -"^DIC",175.101,175.101,"%D",5,0) -identified by the web services for a patient, they are saved to the CCR -"^DIC",175.101,175.101,"%D",6,0) -ELEMENTS file and will be accessioned to the patient's record as "NON-VA" -"^DIC",175.101,175.101,"%D",7,0) -meds. -"^DIC",175.101,175.101,"%D",8,0) - -"^DIC",175.101,175.101,"%D",9,0) -This prototype file was created by George Lilly during the RMU VistA -"^DIC",175.101,175.101,"%D",10,0) -sprint March 3, 2009 -"^DIC",175.101,"B","C0P APPLICATION STEPS",175.101) - -"^DIC",175.201,175.201,0) -C0P WEB APPLICATIONS^175.201 -"^DIC",175.201,175.201,0,"GL") -^C0PAPP( -"^DIC",175.201,175.201,"%",0) -^1.005^^ -"^DIC",175.201,175.201,"%D",0) -^^6^6^3090303^ -"^DIC",175.201,175.201,"%D",1,0) -This file is being created as part of the ePrescription RMU sprint by -"^DIC",175.201,175.201,"%D",2,0) -George Lilly, Nancy Anthracite, Sam Habiel, and Greg Woodhouse. -"^DIC",175.201,175.201,"%D",3,0) - -"^DIC",175.201,175.201,"%D",4,0) -The Web Application file contains a sequence of processing steps for a -"^DIC",175.201,175.201,"%D",5,0) -named application. The processing steps are pointers to the C0P -"^DIC",175.201,175.201,"%D",6,0) -APPLICATION STEP file (175.101). -"^DIC",175.201,"B","C0P WEB APPLICATIONS",175.201) - -**END** -**END** diff --git a/p/_zewdAPI.m b/p/_zewdAPI.m deleted file mode 100644 index d7ef04a..0000000 --- a/p/_zewdAPI.m +++ /dev/null @@ -1,1868 +0,0 @@ -%zewdAPI ; Enterprise Web Developer run-time functions and user APIs - ; - ; 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 . | - ; ---------------------------------------------------------------------------- - ; - QUIT - ; - ; -version() ; - QUIT "Enterprise Web Developer (Build "_$$getVersion^%zewdCompiler()_")" - ; -date() ; - QUIT $$getDate^%zewdCompiler() - ; -compilePage(app,page,mode,technology,outputPath,multilingual,maxLines) - d compilePage^%zewdCompiler($g(app),$g(page),$g(mode),$g(technology),$g(outputPath),$g(multilingual),$g(maxLines)) - QUIT - ; -compileAll(app,mode,technology,outputPath,multilingual,templatePageName,maxLines) - d compileAll^%zewdCompiler($g(app),$g(mode),$g(technology),$g(outputPath),$g(multilingual),$g(templatePageName),$g(maxLines)) - QUIT - ; -autoTranslate(app,language,verbose) - d autoTranslate^%zewdMgr($g(app),$g(language),$g(verbose)) - ; -startSession(page,requestArray,serverArray,sessionArray,filesArray) ; - ; - QUIT $$startSession^%zewdPHP(page,.requestArray,.serverArray,.sessionArray,.filesArray) - ; -closeSession(requestArray) ; - ; - QUIT $$closeSession^%zewdPHP(.requestArray) - ; -saveSession(sessionArray) ; - ; - d saveSession^%zewdPHP(.sessionArray) - QUIT - ; -endOfPage(sessionArray) - ; - d endOfPage^%zewdPHP(.sessionArray) - QUIT - ; -prePageScript(sessid) - QUIT $$prePageScript^%zewdPHP(sessid) - ; -releaseLock(sessid) - d releaseLock^%zewdPHP(sessid) - QUIT - ; -tokeniseURL(url,sessid) - QUIT $$tokeniseURL^%zewdCompiler16($g(url),$g(sessid)) - ; -getSessid(token) - ; - i token="" QUIT "" - i $$isTokenExpired(token) QUIT "" - QUIT +^%zewdSession("tokens",token) - ; -initialiseSession(sessid) - k ^%zewdSession("session",sessid) - QUIT - ; -deleteSession(sessid) - ; - d deleteSession^%zewdPHP(sessid) - ; - QUIT - ; -setRedirect(toPage,sessid) - d setJump(toPage,sessid) - QUIT - ; -setJump(toPage,sessid) - ; - n token - ; - d setSessionValue("ewd_nextPage",toPage,sessid) - d setSessionValue("ewd_jump",toPage,sessid) - QUIT:$e(sessid,1,4)="csp:" - s token=$$setNextPageToken(toPage,sessid) - d setSessionValue("ewd_pageToken",token,sessid) - QUIT - ; -setNextPageToken(nextPage,sessid) - ; - n token,length - ; - s length=$$getSessionValue("ewd_sessid_length",sessid) - i length="" s length=30 - f s token=$$makeTokenString(length) q:'$d(^%zewdSession("nextPageTokens",sessid,token)) - i $g(^zewd("trace"))=1 d trace^%zewdAPI("setNextPageToken^%zewdAPI: sessid="_sessid_"; token="_token_"; nextPage="_nextPage) - s ^%zewdSession("nextPageTokens",sessid,token,$$zcvt(nextPage,"l"))="" - QUIT token - ; -isNextPageTokenValid(token,sessid,page) - QUIT $$isNextPageTokenValid^%zewdCompiler13(token,sessid,page) - ; -isCSP(sessid) - QUIT $e(sessid,1,4)="csp:" - ; -normaliseTextValue(text) - s text=$$replaceAll(text,"'","'") - QUIT $$zcvt(text,"o","HTML") - ; -displayOptions(fieldName,listName,escape) - ;d displayOptions^%zewdCompiler13($g(fieldName),$g(listName),$g(escape)) - n codeValue,%d,i,name,nnvp,nvp,pos,textValue,value - ; - s fieldName=$tr(fieldName,".","_") - s listName=$tr(listName,".","_") - i 0 - e d - . s escape=+$g(escape) - . s pos="" - . f s pos=$o(^%zewdSession("session",sessid,"ewd_list",listName,pos)) q:pos="" d - . . k %d,textValue,codeValue,codeValueEsc,textValueEsc - . . s %d=^%zewdSession("session",sessid,"ewd_list",listName,pos) - . . s textValue=$p(%d,$c(1),1) - . . ; - . . s textValueEsc=textValue - . . s textValueEsc=$$replaceAll(textValueEsc,"'","'") - . . i escape s textValueEsc=$$zcvt(textValue,"o","HTML") - . . ; - . . s codeValue=$p(%d,$c(1),2) - . . i codeValue="" s codeValue=textValue - . . s codeValueEsc=codeValue - . . s codeValueEsc=$$replaceAll(codeValueEsc,"'","'") - . . i escape s codeValueEsc=$$zcvt(codeValue,"o","HTML") - . . w ""_$c(13,10) - QUIT - ; -displayTextArea(fieldName) - d displayTextArea^%zewdCompiler13($g(fieldName)) - QUIT - ; -mCSPReq2(fields) - ; - n i,noOfFields,field,type - s noOfFields=$l(fields,"`") - f i=1:1:noOfFields d - . s field=$p(fields,"`",i) - . q:field="" - . s type=$p(field,"|",2) - . S field=$P(field,"|",1) - . d mergeCSPRequestToSession(field,type) - d mergeCSPRequestToSession("ewd_pressed","hidden") - QUIT - ; -mCSPReq(fieldName,type) - d mergeCSPRequestToSession(fieldName,type) - QUIT - ; -mergeCSPRequestToSession(fieldName,type) - d mergeCSPRequestToSession^%zewdCompiler16($g(fieldName),$g(type)) - QUIT - ; - ; note - textarea data storage can be queried using SQL with the following construct - ; - ; listAttributeFL {type=%Library.String ; sqllisttype=subnode} - ; -displayText(textID,reviewMode,sessid) - QUIT $$displayText^%zewdCompiler13($g(textID),$g(reviewMode),$g(sessid)) - ; -systemMessage(text,type,sessid,appName,langCode) - n textid,fragments,outputText,error,technology,translationMode,typex - ; - ;d trace^%zewdAPI("systemMessage : text="_text_" ; type="_type_" ; sessid="_sessid) - i $g(text)="" QUIT "" - ; manual API or where sessid not known - i $g(sessid)="" QUIT $$systemMessage^%zewdCompiler5(text,$g(type),$g(appName),$g(langCode)) - s translationMode=+$$getSessionValue^%zewdAPI("ewd_translationMode",sessid) - ;d trace^%zewdAPI("ewd_translationMode="_translationMode) - i 'translationMode QUIT text - s appName=$$getSessionValue^%zewdAPI("ewd_appName",sessid) - ;d trace^%zewdAPI("appName="_appName) - s typex=type ; avoid Cache bug ! - i $$getPhraseIndex^%zewdCompiler5(text)="" QUIT "" - i '$$isTextPreviouslyFound^%zewdCompiler5(text,appName,"","",.textid,,,type) d - . s textid=$$addTextToIndex^%zewdCompiler5(text,appName,"","",.fragments,.outputText,typex) - s error=$$displayText(textid,0,sessid) - QUIT error - ; -errorMessage(text,sessid) - QUIT $$systemMessage(text,"error",sessid) - ; - ; ============================================================================ - ; User API Methods - ; ============================================================================ - ; -isCSPPage(docOID) - ; - n docName - ; - s docName=$$getDocumentName^%zewdDOM(docOID) - QUIT $$bypassMode^%zewdCompiler(docName) - ; -getSessionValue(name,sessid) - ; - n %zt,return,value - ; - s name=$$stripSpaces(name) - s %zt=$zt - i $g(name)="" QUIT "" - i $g(sessid)="" QUIT "" - i name["." d QUIT value - . n np,obj,prop - . i name["_" s name=$p(name,"_",1)_"."_$p(name,"_",2,200) - . s np=$l(name,".") - . s obj=$p(name,".",1,np-1) - . s prop=$p(name,".",np) - . s value=$$getSessionObject(obj,prop,sessid) - ;s $zt="extcErr" - ;i $r(100)<10 i '$$$licensed("DOM",,,,,,,,,,) d setWarning("You do not have a current eXtc License",sessid) - ;i $$isTemp(name) d QUIT value - i $e(name,1,4)="tmp_" d QUIT value - . s value=$g(zewdSession(name)) - . i value="",$g(^%zewdSession("session",sessid,"ewd_technology"))="gtm" s value=$g(sessionArray(name)) - QUIT $g(^%zewdSession("session",sessid,name)) - ; -setWLDSymbol(name,sessid) - ; - ; ------------------------------------------------------ - ; Duplicate copy for performance: see also %zewdPHP! - ; ------------------------------------------------------ - ; - n wldAppName,wldName,wldSessid,%zzname - ; - QUIT:$zv["GT.M" - QUIT - ; -extcErr - ; - n mess - s mess="eXtc does not appear to have been installed or is unavailable in the "_$$namespace()_" namespace where your application is attempting to run. Your application will be unable to run correctly" - d setWarning(mess,sessid) - s $zt=%zt - QUIT "" - ; -valueErr ; - s $zt=%zt - QUIT "" - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -exportCustomTags(tagList,filepath) - QUIT $$exportCustomTags^%zewdCompiler16(.tagList,$g(filepath)) - ; -exportAllCustomTags(filepath) - QUIT $$exportAllCustomTags^%zewdCompiler16($g(filepath)) - ; -importCustomTags(filePath) - QUIT $$importCustomTags^%zewdForm($g(filePath)) - ; -setSessionValue(name,value,sessid) - ; - s name=$$stripSpaces(name) - i $g(name)="" QUIT - i $g(sessid)="" QUIT - i name["." d QUIT - . n np,obj,prop - . i name["_" s name=$p(name,"_",1)_"."_$p(name,"_",2,200) - . s np=$l(name,".") - . s obj=$p(name,".",1,np-1) - . s prop=$p(name,".",np) - . d setSessionObject(obj,prop,value,sessid) - s value=$g(value) - i $e(name,1,4)="tmp_" s zewdSession(name)=value QUIT - s ^%zewdSession("session",sessid,name)=value - QUIT - ; -allowJSONAccess(sessionName,access,sessid) - ; access="r|rw" - s ^%zewdSession("jsonAccess",sessid,sessionName)=access - QUIT - ; -disallowJSONAccess(sessionName,sessid) - k ^%zewdSession("jsonAccess",sessid,sessionName) - QUIT - ; -JSONAccess(sessionName,sessid) - QUIT $g(^%zewdSession("jsonAccess",sessid,sessionName)) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -isTemp(name) - QUIT $e(name,1,4)="tmp_" - ; - ; -existsInSession(name,sessid) - QUIT $$existsInSession^%zewdCompiler13($g(name),$g(sessid)) - ; -existsInSessionArray(name,p1,p2,p3,p4,p5,p6,p7,p8,p9,p10,p11) - QUIT $$existsInSessionArray^%zewdCompiler13($g(name),$g(p1),$g(p2),$g(p3),$g(p4),$g(p5),$g(p6),$g(p7),$g(p8),$g(p9),$g(p10),$g(p11)) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -clearSessionArray(arrayName,sessid) - s arrayName=$$stripSpaces(arrayName) - i $g(sessid)="" QUIT - i $g(arrayName)="" QUIT - s arrayName=$tr(arrayName,".","_") - ;i $$isTemp(arrayName) k zewdSession(arrayName) QUIT - i $e(arrayName,1,4)="tmp_" k zewdSession(arrayName) QUIT - k ^%zewdSession("session",sessid,arrayName) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -setSessionArray(arrayName,itemName,itemValue,sessid) - ; - s arrayName=$$stripSpaces(arrayName) - QUIT:$g(arrayName)="" - QUIT:$g(itemName)="" - QUIT:$g(sessid)="" - s arrayName=$tr(arrayName,".","_") - i $$isTemp(arrayName) s zewdSession(arrayName,itemName)=itemValue QUIT - s ^%zewdSession("session",sessid,arrayName,itemName)=itemValue - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -getSessionArray(arrayName,sessid,array,clearArray) - ; - s arrayName=$$stripSpaces(arrayName) - QUIT:$g(arrayName)="" - s arrayName=$tr(arrayName,".","_") - QUIT:$g(sessid)="" - set $zt="getSessionArrayErr" - i $g(clearArray)=1 k array - i $$isTemp(arrayName) m array=zewdSession(arrayName) QUIT - m array=^%zewdSession("session",sessid,arrayName) - QUIT - ; -getSessionArrayErr ; --- Come here if error occurred in 'getSessionArray' --- - set $zt="" - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -addToSession(name,sessid) - s name=$$stripSpaces(name) - QUIT:$g(sessid)="" - QUIT:$g(name)="" - s name=$tr(name,".","_") - i $$isTemp(name) m zewdSession(name)=@name QUIT - m ^%zewdSession("session",sessid,name)=@name - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -mergeToSession(name,sessid) - QUIT:$g(sessid)="" - QUIT:$g(name)="" - d addToSession(name,sessid) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -mergeGlobalToSession(globalName,sessionName,sessid) - d mergeGlobalToSession^%zewdCompiler13($g(globalName),$g(sessionName),$g(sessid)) - QUIT - ; -mergeGlobalFromSession(globalName,sessionName,sessid) - d mergeGlobalFromSession^%zewdCompiler13($g(globalName),$g(sessionName),$g(sessid)) - QUIT - ; -mergeArrayToSession(array,sessionName,sessid) - QUIT:$g(sessid)="" - QUIT:$g(sessionName)="" - s sessionName=$tr(sessionName,".","_") - ;i $$isTemp(sessionName) m zewdSession(sessionName)=array QUIT - i $e(sessionName,1,4)="tmp_" m zewdSession(sessionName)=array QUIT - m ^%zewdSession("session",sessid,sessionName)=array - QUIT - ; -mergeArrayToSessionObject(array,sessionName,sessid) - d mergeArrayToSessionObject^%zewdCompiler16(.array,$g(sessionName),$g(sessid)) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -mergeArrayFromSession(array,sessionName,sessid) - QUIT:$g(sessid)="" - QUIT:$g(sessionName)="" - s sessionName=$tr(sessionName,".","_") - ;i $$isTemp(sessionName) m array=zewdSession(sessionName) QUIT - i $e(sessionName,1,4)="tmp_" m array=zewdSession(sessionName) QUIT - m array=^%zewdSession("session",sessid,sessionName) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -mergeFromSession(name,sessid) - QUIT:$g(sessid)="" - QUIT:$g(name)="" - s name=$tr(name,".","_") - i $$isTemp(name) m @name=zewdSession(name) - m @name=^%zewdSession("session",sessid,name) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -deleteFromSession(name,sessid) - QUIT:$g(sessid)="" - QUIT:$g(name)="" - i name["." d QUIT - . n np,obj,prop - . s np=$l(name,".") - . s obj=$p(name,".",1,np-1) - . s prop=$p(name,".",np) - . d deleteFromSessionObject(obj,prop,sessid) - ;i $$isTemp(name) k zewdSession(name) QUIT - i $e(name,1,4)="tmp_" k zewdSession(name) QUIT - k ^%zewdSession("session",sessid,name) - QUIT - ; -sessionNameExists(name,sessid) - QUIT:$g(sessid)="" - QUIT:$g(name)="" - s name=$tr(name,".","_") - i $$isTemp(name) QUIT $d(zewdSession(name)) - QUIT $d(^%zewdSession("session",sessid,name)) - ; -getSessionArrayValue(arrayName,subscript,sessid,exists) - QUIT $$getSessionArrayValue^%zewdCompiler13($g(arrayName),$g(subscript),$g(sessid),.exists) - ; -sessionArrayValueExists(arrayName,subscript,sessid) - QUIT $$sessionArrayValueExists^%zewdCompiler13($g(arrayName),$g(subscript),$g(sessid)) - ; -deleteSessionArrayValue(arrayName,subscript,sessid) - d deleteSessionArrayValue^%zewdCompiler13($g(arrayName),$g(subscript),$g(sessid)) - QUIT - ; - ; Objects - ; -setSessionObject(objectName,propertyName,propertyValue,sessid) - ;d setSessionObject^%zewdCompiler13($g(objectName),$g(propertyName),$g(propertyValue),$g(sessid)) - ;QUIT - ; - n comma,i,np,p,sessionArray,x - ; - i $g(objectName)="" QUIT - i $g(propertyName)="" QUIT - ;i $g(propertyValue)="" QUIT - i $g(sessid)="" QUIT - s np=$l(objectName,".") - ;s objectName=$$replace(objectName,".","_") - i objectName["." s objectName=$p(objectName,".",1)_"_"_$p(objectName,".",2,2000) - i np=1 d QUIT - . i $e(objectName,1,3)="tmp" s zewdSession(objectName_"_"_propertyName)=propertyValue q - . s ^%zewdSession("session",sessid,(objectName_"_"_propertyName))=propertyValue - ; - f i=1:1:np-1 s p(i)=$p(objectName,".",i) - s comma="," - i $e(objectName,1,4)="tmp_" d - . s x="s zewdSession(",comma="" - e d - . s x="s ^%zewdSession(""session"","_sessid - f i=1:1:np-1 s x=x_comma_""""_p(i)_"""",comma="," - s x=x_","""_propertyName_""")="""_propertyValue_"""" - x x - QUIT - ; -getSessionObject(objectName,propertyName,sessid) - ; - n i,np,p,value,x - ; - i $g(sessid)="" QUIT "" - s value="" - s np=$l(objectName,".") - i objectName[".",objectName'["_" s objectName=$p(objectName,".",1)_"_"_$p(objectName,".",2,2000) - ;s objectName=$$replace(objectName,".","_") - i np=1 QUIT $g(^%zewdSession("session",sessid,(objectName_"_"_propertyName))) - ; - f i=1:1:np-1 s p(i)=$p(objectName,".",i) - s x="s value=$g(^%zewdSession(""session"","_sessid - f i=1:1:np-1 s x=x_","""_p(i)_"""" - s x=x_","""_propertyName_"""))" - x x - QUIT value - ; -deleteFromSessionObject(objectName,propertyName,sessid) - d deleteFromSessionObject^%zewdCompiler13($g(objectName),$g(propertyName),$g(sessid)) - QUIT - ; -sessionObjectPropertyExists(objectName,propertyName,sessid) - QUIT $$sessionObjectPropertyExists^%zewdCompiler13($g(objectName),$g(propertyName),$g(sessid)) - ; -deleteSessionObject(objectName,sessid) - n obj - s obj=objectName - i obj["." s obj=$tr(obj,".","_") - i obj'["_" s obj=obj_"_" - d clearSessionByPrefix(obj,$g(sessid)) - ;d deleteSessionObject^%zewdCompiler13($g(objectName),$g(sessid)) - QUIT - ; -copyObjectToSession(oref,objectName,sessid) - d copyObjectToSession^%zewdCompiler13($g(oref),$g(objectName),$g(sessid)) - QUIT - ; -copyResultSetToSession(oref,objectName,sessid) - d copyResultSetToSession^%zewdCompiler13($g(oref),$g(objectName),$g(sessid)) - QUIT - ; -getResultSetValue(resultSetName,index,propertyName,sessid) - QUIT $$getResultSetValue^%zewdCompiler13($g(resultSetName),$g(index),$g(propertyName),$g(sessid)) - ; -addToResultSet(sessionName,propertyName,value,sessid) - d addToResultSet^%zewdCompiler13($g(sessionName),$g(propertyName),$g(value),$g(sessid)) - QUIT - ; -mergeRecordArrayToResultSet(sessionName,recordArray,sessid) - d mergeRecordArrayToResultSet^%zewdCompiler13($g(sessionName),.recordArray,$g(sessid)) - QUIT - ; -JSONToSessionObject(objectName,jsonString,sessid) - d JSONToSessionObject^%zewdCompiler13($g(objectName),$g(jsonString),$g(sessid)) - QUIT - ; -sessionObjectToJSON(objectName,sessid) - QUIT $$sessionObjectToJSON^%zewdCompiler13($g(objectName),$g(sessid)) - ; -objectGlobalToJSON(objectName) - QUIT $$objectGlobalToJSON^%zewdCompiler13($g(objectName)) - ; -saveJSON(objectName,jsonString) - QUIT $$saveJSON^%zewdCompiler13($g(objectName),$g(jsonString)) - ; -getJSON(objectName,addRefCol) - QUIT $$getJSON^%zewdCompiler13($g(objectName),$g(addRefCol)) - ; -setJSONValue(JSONName,objectName,sessid) - d setJSONValue^%zewdCompiler16($g(JSONName),$g(objectName),$g(sessid)) - d allowJSONAccess(objectName,"r",sessid) - QUIT - ; -convertToJSON(arrayName,isExtJS) - n dojo - i '$d(@arrayName) QUIT "" - s dojo="" - i $g(isExtJS)=1 s dojo=2 - QUIT $$walkArray^%zewdCompiler13("",arrayName,dojo) - ; -mergeToJSObject(sessionObject,JSObject) - QUIT $$mergeToJSObject^%zewdCompiler13($g(sessionObject),$g(JSObject),$g(sessid)) - ; - ; Javascript objects - ; -getJavascriptObjectBlock(objectName,docName,textArray) - QUIT $$getJavascriptObjectBlock^%zewdCompiler13($g(objectName),$g(docName),.textArray) - ; -replaceJavascriptObject(objectName,newFunctionText,docName) - QUIT $$replaceJavascriptObject^%zewdCompiler13($g(objectName),$g(newFunctionText),$g(docName)) - ; -replaceJavascriptObjectBody(functionName,newBody,docName) - QUIT $$replaceJavascriptObjectBody^%zewdCompiler13($g(functionName),$g(newBody),$g(docName)) - ; -getJavascriptObjectBody(functionName,docName) - QUIT $$getJavascriptObjectBody^%zewdCompiler13($g(functionName),$g(docName)) - ; -getJavascriptObject(objectName,docName,eOID) - QUIT $$getJavascriptObject^%zewdCompiler13($g(objectName),$g(docName),$g(eOID)) - ; -javascriptObjectExists(objectName,docName) - QUIT $$javascriptObjectExists^%zewdCompiler13($g(objectName),$g(docName)) - ; -getLastJavascriptTag(docName,textArray) - QUIT $$getLastJavascriptTag^%zewdCompiler13($g(docName),.textArray) - ; -addJavascriptObject(docName,jsText) - QUIT $$addJavascriptObject^%zewdCompiler13($g(docName),.jsText) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -setSessionValues(nvArray,sessid) - ; - QUIT:$g(sessid)="" - n name,no,value - s name="" - f s name=$o(nvArray(name)) q:name="" d - . d deleteFromSession(name,sessid) - . d clearSelected(name,sessid) - . s value=$g(nvArray(name)) - . d setSessionValue(name,value,sessid) - . s no="" - . f s no=$o(nvArray(name,no)) q:no="" d - . . s value=nvArray(name,no) - . . d addToSelected(name,value,sessid) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -getSessionValues(prefix,nvArray,sessid) - ; - n len,name,no,value - QUIT:$g(sessid)="" - QUIT:$g(prefix)="" - set $zt="getSessionValuesErr" - s len=$l(prefix) - k nvArray - s name=prefix - f s name=$o(^%zewdSession("session",sessid,name)) q:name="" q:$e(name,1,len)'=prefix d - . d setNVArray(name,.nvArray,sessid) - s name=prefix,no=0 - f s name=$o(^%zewdSession("session",sessid,"ewd_selected",name)) q:name="" q:$e(name,1,len)'=prefix d - . s value="" - . f s value=$o(^%zewdSession("session",sessid,"ewd_selected",name,value)) q:value="" d - . . s no=no+1 - . . s nvArray(name,no)=value - QUIT - ; -getSessionValuesErr ; --- Come here if error occurred in 'getSessionValues' --- - set $zt="" - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -getSessionValuesByPrefix(prefix,sessid) - ; - n len,name - QUIT:$g(sessid)="" - QUIT:$g(prefix)="" - s prefix=$tr(prefix,".","_") - set $zt="getSessionValuesByPrefixErr" - s len=$l(prefix) - s name=prefix - f s name=$o(^%zewdSession("session",sessid,name)) q:name="" q:$e(name,1,len)'=prefix d - . i name?1A.AN m @name=^%zewdSession("session",sessid,name) - QUIT - ; -getSessionValuesByPrefixErr - set $zt="" - QUIT - ; -setNVArray(name,nvArray,sessid) - n selected,value,no - s nvArray(name)=$$getSessionValue(name,sessid) - QUIT - ; -clearSessionByPrefix(prefix,sessid) - ; - n len,name - QUIT:$g(sessid)="" - QUIT:$g(prefix)="" - s prefix=$tr(prefix,".","_") - s len=$l(prefix) - ; - s name=prefix - f s name=$o(^%zewdSession("session",sessid,name)) q:name="" q:$e(name,1,len)'=prefix d - . i $e(name,1,4)="ewd_" q - . d deleteFromSession(name,sessid) - s name=prefix - f s name=$o(^%zewdSession("session",sessid,"ewd_selected",name)) q:name="" q:$e(name,1,len)'=prefix d - . d clearSelected(name,sessid) - s name=prefix - f s name=$o(^%zewdSession("session",sessid,"ewd_list",name)) q:name="" q:$e(name,1,len)'=prefix d - . d clearList(name,sessid) - s name=prefix - f s name=$o(^%zewdSession("session",sessid,"ewd_textarea",name)) q:name="" q:$e(name,1,len)'=prefix d - . d clearTextArea(name,sessid) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; - ; HTML Form-specific APIs - ; -getTextValue(fieldName,sessid) - QUIT $$getSessionValue(fieldName,sessid) - ; -setTextValue(fieldName,value,sessid) - d setSessionValue(fieldName,value,sessid) - QUIT - ; -getPasswordValue(fieldName,sessid) - QUIT $$getSessionValue(fieldName,sessid) - ; -getHiddenValue(fieldName,sessid) - QUIT $$getSessionValue(fieldName,sessid) - ; -setHiddenValue(fieldName,value,sessid) - d setSessionValue(fieldName,value,sessid) - ; -getRadioValue(fieldName,sessid) - QUIT $$getSessionValue(fieldName,sessid) - ; -setRadioOn(fieldName,value,sessid) - d setSessionValue(fieldName,value,sessid) - QUIT - ; -isRadionOn(fieldName,value,sessid) - QUIT $$getRadioValue(fieldName,sessid)=value - ; -isCheckboxOn(fieldName,value,sessid) - QUIT $$isSelected(fieldName,value,sessid) - ; -getCheckboxValues(fieldName,selectedValueArray,sessid) - d mergeFromSelected(fieldName,.selectedValueArray,sessid) - QUIT - ; -initialiseCheckbox(fieldName,sessid) - d clearSelected(fieldName,sessid) - QUIT - ; -setCheckboxOn(fieldName,value,sessid) - d addToSelected(fieldName,value,sessid) - QUIT - ; -setCheckboxOff(fieldName,value,sessid) - d removeFromSelected(fieldName,value,sessid) - ; -setCheckboxValues(fieldName,selectedValueArray,sessid) - ; - ; array format : array(checkboxValue)=checkboxValue - ; eg selected("red")="red" - ; - d mergeToSelected(fieldName,.selectedValueArray,sessid) - QUIT - ; -getSelectValue(fieldName,sessid,nullify) - ; - n value - ; - s value=$$getSessionValue(fieldName,sessid) - i $a(value)=160 s value="" - QUIT value - ; -setSelectValue(fieldName,value,sessid) - d setSessionValue(fieldName,value,sessid) - ; -isSelectOn(fieldName,value,sessid) - QUIT $$getSelectValue(fieldName,sessid)=value - ; -isMultipleSelectOn(fieldName,value,sessid) - QUIT $$isSelected(fieldName,value,sessid) - ; -getMultipleSelectValues(fieldName,selectedValueArray,sessid) - d mergeFromSelected(fieldName,.selectedValueArray,sessid) - QUIT - ; -initialiseMultipleSelect(fieldName,sessid) - d clearSelected(fieldName,sessid) - QUIT - ; -setMultipleSelectOn(fieldName,value,sessid) - d addToSelected(fieldName,value,sessid) - QUIT - ; -setMultipleSelectOff(fieldName,value,sessid) - d removeFromSelected(fieldName,value,sessid) - ; -setMultipleSelectValues(fieldName,selectedValueArray,sessid) - ; - ; array format : array(checkboxValue)=checkboxValue - ; eg selected("red")="red" - ; - d mergeToSelected(fieldName,.selectedValueArray,sessid) - QUIT - ; -getTextArea(fieldName,textArray,sessid) - d mergeFromTextArea(fieldName,.textArray,sessid) - QUIT - ; -setFieldError(fieldName,sessid) - ; - n errors - s errors(fieldName)=$$getSessionValue("ewd_errorClass",sessid) - d mergeArrayToSession^%zewdAPI(.errors,"ewd_errorFields",sessid) - d setSessionValue^%zewdAPI("ewd_hasErrors",1,sessid) - QUIT - ; -setErrorClasses() - QUIT $$setErrorClasses^%zewdUtilities() - ; -getRequestValue(fieldName,sessid) - set $zt="getRequestValueErr" - s sessid=$g(sessid) - i $g(fieldName)="" QUIT "" - QUIT $g(requestArray(fieldName)) - ; -getRequestValueErr - set $zt="" - QUIT "" - ; -mergeFromRequest(array,fieldName,sessid) - QUIT:fieldName="" - m array=requestArray(fieldName) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -copyRequestValueToSession(fieldName,sessid) - ; - QUIT:$g(sessid)="" - QUIT:$g(fieldName)="" - i $$isTemp(fieldName) m zewdSession(fieldName)=requestArray(fieldName) - m ^%zewdSession("session",sessid,fieldName)=requestArray(fieldName) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -getCookieValue(cookieName,sessid) - QUIT:$g(cookieName)="" - set $zt="getCookieValueErr" - QUIT $g(requestArray(cookieName)) - ; -getCookieValueErr ; --- Come here if error occurred in 'getCookieValue' --- - set $zt="" - QUIT "" - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -deleteCookie(cookieName,sessid) - d setCookieValue(cookieName,"",-3600,sessid) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -convertDaysToSeconds(days) - QUIT days*86400 - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -parseHTMLFile(filepath,docName) - QUIT $$parseHTMLFile^%zewdCompiler16($g(filepath),$g(docName)) - ; -parseXMLFile(filepath,docName) - QUIT $$parseXMLFile^%zewdCompiler16($g(filepath),$g(docName)) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -parseStream(streamName,docName,error,isHTML) - d parseStream^%zewdCompiler16($g(streamName),$g(docName),.error,$g(isHTML)) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -parseHTMLStream(streamName,docName) - QUIT $$parseHTMLStream^%zewdCompiler16($g(streamName),$g(docName)) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -parseURL(server,getPath,docName,port,isHTML,responseTime,browserType,post) - ; - QUIT $$parseURL^%zewdHTMLParser($g(server),$g(getPath),$g(docName),$g(port),$g(isHTML),.responseTime,$g(browserType),$g(post)) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -setCookieValue(cookieName,value,expiryDuration,sessid) - ; - ; expiryDuration is no of seconds - ; - n expires - s expires=expiryDuration - i $$isCSP(sessid) d - . s expires=$$convertDateToSeconds($h)+expires - . s expires=$$convertSecondsToDate(expires) - . s expires=$$inetDate(expires) - s value=value_$c(1)_expires - d setSessionArray("ewd_cookie",cookieName,value,sessid) - ; - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -setResponseHeader(headerName,headerValue,sessid) - d setSessionArray^%zewdAPI("ewd_header",$g(headerName),$g(headerValue),$g(sessid)) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -suppressResponseHeader(headerName,sessid) - i $$isCSP(sessid) d setResponseHeader(headerName,"",sessid) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -addServerToSession(sessid,serverArray) - d addServerToSession^%zewdCompiler13($g(sessid),.serverArray) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -getServerValue(serverFieldName,sessid) - ; - s sessid=$g(sessid) - set $zt="getServerValueErr" - s $zt="g "_$zt - i $g(serverFieldName)="" QUIT "" - ; - s $zt="" - QUIT $g(serverArray(serverFieldName)) - ; -getServerValueErr ; --- Come here if error occurred in 'getServerValue' --- - set $zt="" - QUIT "" - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -deleteWarning(sessid) - QUIT:$g(sessid)="" - d deleteFromSession("ewd_warning",sessid) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -setWarning(warningMessage,sessid) - QUIT:$g(sessid)="" - QUIT:$g(warningMessage)="" - s warningMessage=$$systemMessage(warningMessage,"warning",sessid) - i '$$isCSP(sessid) s warningMessage=$$zcvt(warningMessage,"o","JS") - d setSessionValue("ewd_warning",warningMessage,sessid) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -clearAllSelected(sessid) - k ^%zewdSession("session",sessid,"ewd_selected") - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -clearSelected(fieldName,sessid) - QUIT:$g(fieldName)="" - QUIT:$g(sessid)="" - s fieldName=$tr(fieldName,".","_") - k ^%zewdSession("session",sessid,"ewd_selected",fieldName) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -addToSelected(fieldName,fieldValue,sessid) - ; - n shortFieldValue - QUIT:$g(fieldName)="" - QUIT:$g(sessid)="" - QUIT:$g(fieldValue)="" - s fieldName=$tr(fieldName,".","_") - s shortFieldValue=$e(fieldValue,1,200) - s ^%zewdSession("session",sessid,"ewd_selected",fieldName,shortFieldValue)=fieldValue - QUIT - ; -removeFromSelected(fieldName,fieldValue,sessid) - ; - n shortFieldValue - QUIT:$g(fieldName)="" - QUIT:$g(sessid)="" - QUIT:$g(fieldValue)="" - s fieldName=$tr(fieldName,".","_") - s shortFieldValue=$e(fieldValue,1,200) - k ^%zewdSession("session",sessid,"ewd_selected",fieldName,shortFieldValue) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -mergeFromSelected(fieldName,selected,sessid) - ; - k selected - s fieldName=$tr(fieldName,".","_") - m selected=^%zewdSession("session",sessid,"ewd_selected",fieldName) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -mergeToSelected(fieldName,selected,sessid) - ; - s fieldName=$tr(fieldName,".","_") - ; - k ^%zewdSession("session",sessid,"ewd_selected",fieldName) - m ^%zewdSession("session",sessid,"ewd_selected",fieldName)=selected - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -isSelected(fieldName,fieldValue,sessid) - n shortFieldValue - i $g(fieldName)="" QUIT 0 - i $g(sessid)="" QUIT 0 - i $g(fieldValue)="" QUIT 0 - s fieldName=$tr(fieldName,".","_") - set $zt="isSelectedErr" - s shortFieldValue=$e(fieldValue,1,200) - QUIT $d(^%zewdSession("session",sessid,"ewd_selected",fieldName,shortFieldValue)) - ; -isSelectedErr ; --- Come here if error occurred in 'isSelected' --- - set $zt="" - QUIT 0 - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -clearTextArea(fieldName,sessid) - QUIT:$g(fieldName)="" - QUIT:$g(sessid)="" - s fieldName=$tr(fieldName,".","_") - k ^%zewdSession("session",sessid,"ewd_textarea",fieldName) - s ^%zewdSession("session",sessid,"ewd_textarea",fieldName,1)="" - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -createTextArea(fieldName,textArray,sessid) - ; - QUIT:$g(fieldName)="" - QUIT:$g(sessid)="" - s fieldName=$tr(fieldName,".","_") - m ^%zewdSession("session",sessid,"ewd_textarea",fieldName)=textArray - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -mergeTextAreaFromRequest(fieldName,requestArray,sessid) - ; - q:$g(sessid)="" - s fieldName=$tr(fieldName,".","_") - ; - q:'$d(^%zewdSession("session",sessid,"ewd_textarea",fieldName)) - d clearTextArea(fieldName,sessid) - m ^%zewdSession("session",sessid,"ewd_textarea",fieldName)=requestArray(fieldName) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -appendToTextArea(fieldName,lineOfText,sessid) - ; - n position - ; - QUIT:$g(fieldName)="" - QUIT:$g(sessid)="" - s fieldName=$tr(fieldName,".","_") - ; - s position=$o(^%zewdSession("session",sessid,"ewd_textarea",fieldName,""),-1)+1 - s ^%zewdSession("session",sessid,"ewd_textarea",fieldName,position)=lineOfText - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -mergeFromTextArea(fieldName,textArray,sessid) - ; - s fieldName=$tr(fieldName,".","_") - m textArray=^%zewdSession("session",sessid,"ewd_textarea",fieldName) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -mergeToTextArea(fieldName,textArray,sessid) - ; - s fieldName=$tr(fieldName,".","_") - m ^%zewdSession("session",sessid,"ewd_textarea",fieldName)=textArray - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -clearList(listName,sessid) - QUIT:$g(listName)="" - QUIT:$g(sessid)="" - s listName=$tr(listName,".","_") - k ^%zewdSession("session",sessid,"ewd_list",listName) - k ^%zewdSession("session",sessid,"ewd_listIndex",listName) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -isListDefined(listName,sessid) - QUIT $d(^%zewdSession("session",sessid,"ewd_list",listName)) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -countList(listName,sessid) - QUIT $$countList^%zewdCompiler16($g(listName),$g(sessid)) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -appendToList(listName,textValue,codeValue,sessid,otherAttrs) - ; - n position - ; - QUIT:$g(listName)="" - QUIT:$g(sessid)="" - ;QUIT:$g(textValue)="" - ;QUIT:$g(codeValue)="" - s listName=$tr(listName,".","_") - ; - s position=$o(^%zewdSession("session",sessid,"ewd_list",listName,""),-1)+1 - d addToList(listName,textValue,codeValue,position,sessid,.otherAttrs) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -addToList(listName,textValue,codeValue,position,sessid,otherAttrs) - ;d addToList^%zewdCompiler16($g(listName),$g(textValue),$g(codeValue),$g(position),$g(sessid),.otherAttrs) - ; - n attrList,attrName - ; - QUIT:$g(listName)="" - QUIT:$g(sessid)="" - QUIT:$g(position)="" - i $g(codeValue)="",$g(textValue)="" QUIT - s position=+position - d removeFromList(listName,codeValue,sessid) ; just in case - s attrName="",attrList="" - f s attrName=$o(otherAttrs(attrName)) q:attrName="" d - . s attrList=attrList_attrName_$c(3)_otherAttrs(attrName)_$c(1) - ; - s codeValue=$g(codeValue) i codeValue="" s codeValue=textValue - s ^%zewdSession("session",sessid,"ewd_list",listName,position)=textValue_$c(1)_codeValue_$c(1)_attrList - s ^%zewdSession("session",sessid,"ewd_listIndex",listName,codeValue)=position - k otherAttrs - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -mergeToList(listName,listArray,sessid) - ; - d mergeToList^%zewdCompiler7(listName,.listArray,sessid) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -removeFromList(listName,codeValue,sessid) - ; - ;d removeFromList^%zewdCompiler7(listName,codeValue,sessid) - n position - ; - QUIT:$g(listName)="" - QUIT:$g(sessid)="" - QUIT:$g(codeValue)="" - ; - s position=$g(^%zewdSession("session",sessid,"ewd_listIndex",listName,codeValue)) - QUIT:position="" - k ^%zewdSession("session",sessid,"ewd_list",listName,position) - k ^%zewdSession("session",sessid,"ewd_listIndex",listName,codeValue) - d setWLDSymbol("ewd_list",sessid) - d setWLDSymbol("ewd_listIndex",sessid) - QUIT - ; - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -copyList(fromListName,toListName,sessid) - ; - d copyList^%zewdCompiler7($g(fromListName),$g(toListName),$g(sessid)) - QUIT - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -getTextFromList(listName,codeValue,sessid) - ; - QUIT $$getTextFromList^%zewdCompiler7(listName,codeValue,sessid) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -replaceOptionsByFieldName(formName,fieldName,listName,sessid) - ; - QUIT $$replaceOptionsByFieldName^%zewdCompiler7(formName,fieldName,listName,sessid) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= -replaceOptionsByID(fieldID,listName,sessid) - ; - QUIT $$replaceOptionsByID^%zewdCompiler7(fieldID,listName,sessid) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -getUploadedFileName(fieldName,sessid) - ; - n filename,technology - s technology=$$getSessionValue^%zewdAPI("ewd_technology",sessid) - QUIT 0 - ; -getUploadedFileNameErr - set $zt="" - QUIT "" - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -getUploadedFileSize(fieldName,sessid) - ; - set $zt="getUploadedFileSizeErr" - QUIT 0 - ; -getUploadedFileSizeErr ; - set $zt="" - QUIT "" - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -getUploadedFileType(fieldName,sessid) - ; - set $zt="getUploadedFileTypeErr" - QUIT 0 - ; -getUploadedFileTypeErr - set $zt="" - QUIT "" - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -errorOccurred(sessid) - ; - n warning - ; - i $g(Error)="" QUIT 0 - s warning=$$getSessionValue("ewd_warning",sessid) - QUIT Error'=warning - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -removeQuotes(string) - ; - n quoted,c1,quote - s quote="" - s c1=$e(string,1) - s quoted=0 - i c1=""""!(c1="'") s quoted=1,quote=c1 - i 'quoted QUIT string - i $e(string,$l(string))'=quote QUIT string - QUIT $e(string,2,$l(string)-1) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -escapeQuotes(text) - ; - s text=$$replaceAll(text,"'",$c(4)) - s text=$$replaceAll(text,$c(4),"\'") - s text=$$replaceAll(text,"""",$c(4)) - s text=$$replaceAll(text,$c(4),"\""") - ; - QUIT text - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -getAttrValue(attrName,attrValues,technology) - QUIT $$getAttrValue^%zewdCompiler4(attrName,.attrValues,technology) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -replaceAll(InText,FromStr,ToStr) ; Replace all occurrences of a substring - ; - n %p - ; - s %p=InText - i ToStr[FromStr d QUIT %p - . n i,stop,tempText,tempTo - . s stop=0 - . f i=0:1:255 d q:stop - . . q:InText[$c(i) - . . q:FromStr[$c(i) - . . q:ToStr[$c(i) - . . s stop=1 - . s tempTo=$c(i) - . s tempText=$$replaceAll(InText,FromStr,tempTo) - . s %p=$$replaceAll(tempText,tempTo,ToStr) - f q:%p'[FromStr S %p=$$replace(%p,FromStr,ToStr) - QUIT %p - ; -replace(InText,FromStr,ToStr) ; replace old with new in string - ; - n %p1,%p2 - ; - i InText'[FromStr q InText - s %p1=$p(InText,FromStr,1),%p2=$p(InText,FromStr,2,255) - QUIT %p1_ToStr_%p2 - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -addImmediateOneOffTask(executeCode,startTime,namespace,rc,rm) - QUIT $$addImmediateOneOffTask^%zewdScheduler($g(executeCode),$g(startTime),$g(namespace),.rc,.rm) - ; - ;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= - ; -getDataTypeErrors(errorArray,sessid) - k errorArray - d mergeArrayFromSession(.errorArray,"ewd_DataTypeError",sessid) - QUIT - ; -clearSchemaFormErrors(sessid) - d deleteFromSession("ewd_SchemaFormError",sessid) - QUIT - ; -getSchemaFormErrors(errorArray,sessid) - QUIT $$getSchemaFormErrors^%zewdCompiler13(.errorArray,$g(sessid)) - ; -setSchemaFormErrors(errorArray,sessid) - ; - n sessionName - ; - s sessionName="ewd_SchemaFormError" - d deleteFromSession(sessionName,sessid) - d mergeArrayToSession(.errorArray,sessionName,sessid) - QUIT - ; -removeInstanceDocument(instanceName) - ; - n ok - s ok=$$openDOM - i ok'="" QUIT ok - s ok=$$removeDocument^%zewdDOM(instanceName,"","") - d clearXMLIndex^%zewdSchemaForm(instanceName) - s ok=$$closeDOM^%zewdDOM() - QUIT "" - ; - ; -makeTokenString(length) - ; - n string,token,i - ; - s string="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890" - s token="" - f i=1:1:length s token=token_$e(string,($r($l(string))+1)) - QUIT token - ; -makeString(%char,%len) ; create a string of len characters - ; - n %str - ; - s %str="",$p(%str,%char,%len+1)="" - QUIT %str - ; -convertDateToSeconds(hdate) - ; - Q (hdate*86400)+$p(hdate,",",2) - ; -convertSecondsToDate(secs) - ; - QUIT (secs\86400)_","_(secs#86400) - ; -getTokenExpiry(token) - ; - n sessid - ; - i $g(token)="" QUIT 0 - s sessid=+$g(^%zewdSession("tokens",token)) - i sessid="" QUIT 0 - QUIT $$getSessionValue("ewd_sessionExpiry",sessid) - ; -isTokenExpired(token) - ; - ;QUIT $$getTokenExpiry(token)'>$$convertDateToSeconds($h) - QUIT $$getTokenExpiry(token)'>(($h*86400)+$p($h,",",2)) - ; -randChar() - ; - n string - ; - s string="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz1234567890" - QUIT $e(string,($R($l(string))+1)) - ; -lowerCase(string) - QUIT $tr(string,"ABCDEFGHIJKLMNOPQRSTUVQXYZ","abcdefghijklmnopqrstuvwxyz") - ; -stripSpaces(string) - s string=$$stripLeadingSpaces(string) - QUIT $$stripTrailingSpaces(string) - ; -stripLeadingSpaces(string) - n i - ; - f i=1:1:$l(string) QUIT:$e(string,i)'=" " - QUIT $e(string,i,$l(string)) - ; -stripTrailingSpaces(string) - n i,spaces,new - ; - s spaces=$$makeString(" ",100) - s new=string_spaces - QUIT $p(new,spaces,1) - ; -parseMethod(methodString,class,method) - ; - n %p1,%p2,meth - ; - s %p1=$p(methodString,"##class(",2) - s class=$p(%p1,")",1) - s %p2=$p(%p1,")",2,500) - s method=$p(%p2,".",2) - s method=$p(method,"(",1) - QUIT - ; -event(requestArray) - QUIT $$event^%zewdPHP(.requestArray) - ; -clearURLNVP(urlNo) - ; - QUIT - ; -setURLNVP(urlNo,name) - ; - QUIT - ; -decodeDataType(name,dataType,sessid) - ; - n value,inputMethod,x,decodedValue - ; - q:$g(name)="" - q:$g(dataType)="" - s value=$$getSessionValue(name,sessid) - s inputMethod=$$getInputMethod^%zewdCompiler(dataType) - q:inputMethod="" - s x="s decodedValue=$$"_inputMethod_"("""_value_""",sessid)" - x x - d setSessionValue(name,decodedValue,sessid) - QUIT - ; -encodeDataType(name,dataType,sessid) - QUIT $$encodeDataType^%zewdCompiler13($g(name),$g(dataType),$g(sessid)) - ; -copyURLNVPsToSession(urlNo) - ; - n name - ; - QUIT - ; -doubleQuotes(string) - ; - s string=$$replaceAll(string,"""",$c(1,1)) - s string=$tr(string,$c(1),"""") - QUIT string - ; - ; ========================================================================== - ; Error Trap Functions - ; ========================================================================== - ; -copySessionToSymbolTable(sessid) - d copySessionToSymbolTable^%zewdCompiler16($g(sessid)) - QUIT - ; -saveSymbolTable(sessid) - ; - n ok - ;s sessid=0 - k ^%zewdError(sessid) - n %zzv - k ^%zewdError(sessid) - s %zzv="%" - f s %zzv=$o(@%zzv) Q:%zzv="" m ^%zewdError(sessid,%zzv)=@%zzv - QUIT - ; -recoverSymbolTable(sessid,web) - n (sessid,web) - n %zzv - s %zzv="" - f s %zzv=$o(^%zewdError(sessid,%zzv)) QUIT:%zzv="" d - . m @%zzv=^%zewdError(sessid,%zzv) - d writeSymbolTable(web) - QUIT - ; -writeSymbolTable(web) - i $g(web) w "
"
- zwrite
- i $g(web) w "
" - QUIT - ; -loadErrorSymbols(sessid) - d loadErrorSymbols^%zewdCompiler19($g(sessid)) - QUIT - ; -deleteErrorLog(sessid) - k ^%zewdError(sessid) - QUIT - ; -deleteAllErrorLogs - k ^%zewdError - QUIT - ; -fileSize(path) - QUIT $$fileSize^%zewdCompiler13($g(path)) - ; -fileExists(path) - QUIT $$fileExists^%zewdCompiler13($g(path)) - ; -fileInfo(path,info) - d fileInfo^%zewdCompiler13($g(path),.info) - QUIT - ; -directoryExists(path) - QUIT $$directoryExists^%zewdCompiler13($g(path)) - ; -deleteFile(filepath) - QUIT $$deleteFile^%zewdCompiler13($g(filepath)) - ; -renameFile(filepath,newpath) - QUIT $$renameFile^%zewdCompiler13($g(filepath),$g(newpath)) - ; -createDirectory(path) - QUIT $$createDirectory^%zewdCompiler13($g(path)) - ; -removeCR(string) - i $e(string,$l(string))=$c(13) s string=$e(string,1,$l(string)-1) - QUIT string - ; -setApplicationRootPath(path) - d setApplicationRootPath^%zewdCompiler(path) - QUIT - ; -applicationRootPath() - QUIT $$applicationRootPath^%zewdCompiler() - ; -getApplicationRootPath() - QUIT $$getApplicationRootPath^%zewdCompiler() - ; -setOutputRootPath(path,technology) - d setOutputRootPath^%zewdCompiler(path,technology) - QUIT - ; -getRootURL(technology) - QUIT $$getRootURL^%zewdCompiler(technology) - ; -setRootURL(cspURL,technology) - d setRootURL^%zewdCompiler(cspURL,technology) - QUIT - ; -getDefaultTechnology() - QUIT $$getDefaultTechnology^%zewdCompiler() - ; -getDefaultMultiLingual() - QUIT $$getDefaultMultiLingual^%zewdCompiler() - ; -getOutputRootPath(technology) - QUIT $$getOutputRootPath^%zewdCompiler(technology) - ; -getJSScriptsPath(app,technology) - QUIT $$getJSScriptsPath^%zewdCompiler8(app,technology) - ; -getJSScriptsPathMode(technology) - QUIT $$getJSScriptsPathMode^%zewdCompiler8(technology) - ; -setJSScriptsPathMode(technology,mode) - d setJSScriptsPathMode^%zewdCompiler8(technology,mode) - QUIT - ; -getJSScriptsRootPath(technology) - QUIT $$getJSScriptsRootPath^%zewdCompiler8(technology) - ; -setJSScriptsRootPath(technology,path) - d setJSScriptsRootPath^%zewdCompiler8(technology,path) - QUIT - ; -getHomePage() - QUIT $$getHomePage^%zewdCompiler() - ; -setHomePage(homePage) - d setHomePage^%zewdCompiler($g(homePage)) - QUIT - ; -getApplications(appList) - QUIT $$getApplications^%zewdCompiler16(.appList) - ; -getPages(application,pageList) - QUIT $$getPages^%zewdCompiler16($g(application),.pageList) - ; -getDefaultFormat() - QUIT $$getDefaultFormat^%zewdCompiler() - ; -getNextChild(parentOID,childOID) - i $g(parentOID)="" QUIT "" - i childOID="" QUIT $$getFirstChild^%zewdDOM(parentOID) - QUIT $$getNextSibling^%zewdDOM(childOID) - ; -addCSPServerScript(parentOID,text) - QUIT $$addCSPServerScript^%zewdCompiler4(parentOID,text) - ; -createPHPCommand(data,docOID) - QUIT $$createPHPCommand^%zewdCompiler4(data,docOID) - ; -createJSPCommand(data,docOID) - QUIT $$createJSPCommand^%zewdCompiler4(data,docOID) - ; -instantiateJSPVar(var,type,docOID,arraySize,initialValue) - d instantiateJSPVar^%zewdCompiler4(var,type,docOID,arraySize,initialValue) - QUIT - ; -removeIntermediateNode(inOID) - d removeIntermediateNode^%zewdCompiler4(inOID) - QUIT - ; -getNormalisedAttributeValue(attrName,nodeOID,technology) - QUIT $$getNormalAttributeValue^%zewdCompiler($g(attrName),$g(nodeOID),$g(technology)) - ; -getNormalAttributeValue(attrName,nodeOID,technology) - QUIT $$getNormalAttributeValue^%zewdCompiler($g(attrName),$g(nodeOID),$g(technology)) - ; -getTagOID(tagName,docName,lowerCase) - QUIT $$getTagOID^%zewdCompiler($g(tagName),$g(docName),$g(lowerCase)) - ; -getTagByNameAndAttr(tagName,attrName,attrValue,matchCase,docName) - QUIT $$getTagByNameAndAttr^%zewdCompiler3($g(tagName),$g(attrName),$g(attrValue),$g(matchCase),$g(docName)) - ; -javascriptFunctionExists(functionName,docName) - QUIT $$javascriptFunctionExists^%zewdCompiler7($g(functionName),$g(docName)) - ; -addJavascriptFunction(docName,jsTextArray) - QUIT $$addJavascriptFunction^%zewdCompiler7($g(docName),.jsTextArray) - ; -getJavascriptFunctionBody(functionName,docName) - QUIT $$getJavascriptFunctionBody^%zewdCompiler7($g(functionName),docName) - ; -replaceJavascriptFunctionBody(functionName,jsText,docName) - QUIT $$replaceJavascriptFunctionBody^%zewdCompiler7($g(functionName),$g(jsText),$g(docName)) - ; -getDelim() - QUIT $$getDelim^%zewdCompiler() - ; - ; =========================================================================== - ; WLD conversion utilities - ; =========================================================================== - ; -configureWebLink(webserver,mode,alias,path) - QUIT $$configure^%zewdWLD($g(webserver),$g(mode),$g(alias),$g(path)) - ; -mergeListToSession(fieldName,sessid) - d mergeListToSession^%zewdCompiler16($g(fieldName),$g(sessid)) - QUIT - ; -getPREVPAGE(sessid) ; - QUIT $$getPREVPAGE^%zewdCompiler19($g(sessid)) ; - ; -copyToWLDSymbolTable(sessid) - d copyToWLDSymbolTable^%zewdCompiler16($g(sessid)) - ; -getPRESSED(sessid) - QUIT $$getSessionValue("ewd_pressed",sessid) - ; -copyToLIST(listName,sessid) - ; - k LIST(listName) - m LIST(listName)=^%zewdSession("session",sessid,"ewd_list",listName) - QUIT - ; -copyToSELECTED(fieldName,sessid) - ; - k SELECTED(fieldName) - m SELECTED(fieldName)=^%zewdSession("session",sessid,"ewd_selected",fieldName) - QUIT - ; -traceModeOn - s ^zewd("trace")=1 - QUIT - ; -traceModeOff - k ^zewd("trace") - QUIT - ; -getTraceMode() - i $g(^zewd("trace"))=1 QUIT 1 - QUIT 0 - ; -trace(text,clear) ; trace ; - n i - s text=$g(text) - i $g(clear)=1 k ^%zewdTrace - s i=$increment(^%zewdTrace) - s ^%zewdTrace(i)=text - QUIT - ; -inetDate(hdate) ; Decode $H date and time to Internet format - ; - N %d,%day,%time,%date - ; - S %time=$P(hdate,",",2) - I %time>86400 D - .S %time=%time-86400 - .S hdate=(hdate+1)_","_%time - ; - S %d="Thu,Fri,Sat,Sun,Mon,Tue,Wed" - S %day=(hdate#7)+1 - S %day=$P(%d,",",%day) - ; - S %date=$$decDate(hdate) - ;S %date=$TR(%date," ","-") - S %time=$$inetTime(hdate) - S %date=%day_", "_%date_" "_%time - Q %date -decDate(hdate) ; Decode a date from $H format - ; - n %yy,%mm,%dd,%d1,%d - i $zv'["GT.M" d - . s %d1=$zd(hdate,5) - . s %yy=$p(%d1,", ",2) - . s %dd=+$p(%d1," ",2) I %dd<10 S %dd="0"_%dd - . s %mm=$p(%d1," ",1) - e d - . n p1,p2 - . s %d1=$zd(hdate,2) - . s %dd=$p(%d1,"-",1) - . s %mm=$p(%d1,"-",2) - . s p1=$e(%mm,1),p2=$e(%mm,2,$l(%mm)) - . s %mm=p1_$$lowerCase(p2) - . s %yy=$p(%d1,"-",3) - . i hdate>58073 s %yy="20"_%yy - s %d=%dd_" "_%mm_" "_%yy - QUIT %d - ; -inetTime(hdate) ; Decode Internet Format Time from $H format - ; Offset is relative to GMT, eg -0500 - ; - n hh,mm,ss,time - s time=$p(hdate,",",2) - s hh=time\3600 i hh<10 s hh="0"_hh - s time=time#3600 - s mm=time\60 i mm<10 s mm="0"_mm - s ss=time#60 i ss<10 s ss="0"_ss - QUIT hh_":"_mm_":"_ss - ; -openNewFile(filepath) - QUIT $$openNewFile^%zewdCompiler($g(filepath)) - ; -openFile(filepath) - QUIT $$openFile^%zewdCompiler($g(filepath)) - ; -openDOM() - ; - n i,ok - ; - f i=1:1:20 s ok=$$openDOM^%zewdDOM(0,,,,,,,,,,,,,,,,,) q:$$zcvt(ok,"l")["licensing violation" q:ok="" h 1 - i ok'="" s ok="No eXtc Licenses available!" - QUIT ok - ; -removeChild(nodeOID,removeFromDOM) - ; - n ver - ; - s ver="" - QUIT $$removeChild^%zewdDOM(nodeOID,$g(removeFromDOM)) - ; -removeAttribute(attrName,nodeOID,removeFromDOM) - ; - n ver - ; - s ver="" - d removeAttribute^%zewdDOM(attrName,nodeOID,$g(removeFromDOM)) QUIT - ; -removeAttributeNS(ns,attrName,nodeOID,removeFromDOM) - ; - n ver - ; - s ver="" - d removeAttributeNS^%zewdDOM(ns,attrName,nodeOID,$g(removeFromDOM)) QUIT - ; -removeIntermediateNodeeXtc(nodeOID,removeFromDOM) - ; - n ver - ; - d removeIntermediateNode^%zewdDOM(nodeOID,$g(removeFromDOM)) - QUIT - ; -export(fileName,prefix,extension) - d export^%zewdCompiler16($g(fileName),$g(prefix),$g(extension)) - QUIT - ; -import(fileName) - ; - i $g(fileName)="" s fileName="zewd.xml" - QUIT - ; -listDOMsByPrefix(prefix) - d listDOMsByPrefix^%zewdCompiler19($g(prefix)) - QUIT - ; -removeDOMsByPrefix(prefix) - d removeDOMsByPrefix^%zewdCompiler19($g(prefix)) - QUIT - ; -dumpDOM(docName) - ; - d dumpDOM^%zewdCompiler20($g(docName)) - QUIT - ; -namespace() - QUIT $zdir - ; -setNamespace(namespace) - s $zdir=namespace - QUIT - ; -zcvt(string,param,param2) - ; - i $g(param)="" s param="l" - i param="l"!(param="L") QUIT $tr(string,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") - i param="u"!(param="U") QUIT $tr(string,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") - QUIT string - ; -getIP() ; Get own IP address - ; - n ip,ipInfo - ; - QUIT $g(ip) - ; -ajaxErrorRedirect(sessid) - ; - n errorPage - ; - s errorPage=$$getSessionValue^%zewdAPI("ewd.errorPage",sessid) - d setRedirect^%zewdAPI(errorPage,sessid) - ; - QUIT "" - ; -classExport(className,methods,filepath) - ; - QUIT $$classExport^%zewdCompiler16($g(className),.methods,$g(filepath)) - ; -strx(string) - n i,c,a,ok - f i=1:1:$l(string) s c=$e(string,i),a=$a(c) w i_": "_c_" : "_a,! r ok - QUIT - ; -disableEwdMgr - s ^%zewd("disabled")=1 - QUIT - ; -enableEwdMgr - k ^%zewd("disabled") - QUIT - ; -enableWLDAccess(app,page) - i $g(^zewd("allowWLDAccess",$$zcvt(app,"l"),$$zcvt(page,"l")))'=1 s ^zewd("allowWLDAccess",$$zcvt(app,"l"),$$zcvt(page,"l"))=1 - QUIT - ; -disableWLDAccess(app,page) - k ^zewd("allowWLDAccess",$$zcvt(app,"l"),$$zcvt(page,"l")) - QUIT -isSSOValid(sso,username,password,sessid) - QUIT $$isSSOValid^%zewdMgrAjax2($g(sso),$g(username),$g(password),$g(sessid)) - ; -uniqueId(nodeOID,filename) - QUIT $p(filename,".ewd",1)_$p(nodeOID,"-",2) - ; -exportToGTM(routine) diff --git a/p/_zewdCompiler13.m b/p/_zewdCompiler13.m deleted file mode 100644 index e88872d..0000000 --- a/p/_zewdCompiler13.m +++ /dev/null @@ -1,1164 +0,0 @@ -%zewdCompiler13 ; Enterprise Web Developer Compiler 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 . | - ; ---------------------------------------------------------------------------- - ; - QUIT - ; - ; -ifArrayExists(nodeOID,attrValues,docOID,technology) - ; - ; - ; - n arrayName,comma,param,subs,pval - set arrayName=$$getAttrValue^%zewdAPI("arrayname",.attrValues,technology) - s param="param",subs="",comma="" - f s param=$o(attrValues(param)) q:param="" q:param'["param" d - . s pval=attrValues(param) - . d - . . s pval=$$replaceAll^%zewdHTMLParser(pval,"""",""") - . . s subs=subs_comma_pval,comma="," - d - . ; - . n cwOID,attr - . ; - . s cwOID=$$addIntermediateNode^%zewdCompiler4("csp:if",nodeOID) - . ; - . ; - . ; - . s arrayName=$$removeQuotes^%zewdAPI(arrayName) - . i arrayName="" s arrayName="%ewdVar" - . i subs="" s attr="$d("_arrayName_")" - . e s attr="$d("_arrayName_"("_subs_"))" - . d setAttribute^%zewdDOM("condition",attr,cwOID) - ; - d removeIntermediateNode^%zewdCompiler4(nodeOID) - ; - QUIT - ; -url(nodeOID,attrValues,docOID,technology) - ; - ; - ; - n return,url - ; - set url=$$getAttrValue^%zewdAPI("url",.attrValues,technology) - set return=$$getAttrValue^%zewdAPI("return",.attrValues,technology) - ; - d - . n page,serverOID,text - . s page=url,text="" - . s url=$$getRootURL^%zewdCompiler("gtm")_app_"/"_url_".mgwsi?" - . s url=url_"ewd_token=""_$g(^%zewdSession(""session"",sessid,""ewd_token""))_""&n=""_tokens("_$tr(page,"'","")_")" - . s text=text_" s "_return_"="""_url - . s serverOID=$$addCSPServerScript^%zewdCompiler4(nodeOID,text) - ; - d removeIntermediateNode^%zewdCompiler4(nodeOID) - ; - QUIT - ; -tabMenuOption(nodeOID,attrValues,docOID,technology) - ; - ; - ; - n attr,decOID,defaultSelected,docName,greyIf,help,newOID,nextpage - n position,text,value - ; - set position=$$getAttrValue^%zewdAPI("position",.attrValues,technology) - s position=$$removeQuotes^%zewdAPI(position) - set text=$$getAttrValue^%zewdAPI("text",.attrValues,technology) - s text=$$removeQuotes^%zewdAPI(text) - set nextpage=$$getAttrValue^%zewdAPI("nextpage",.attrValues,technology) - s nextpage=$$removeQuotes^%zewdAPI(nextpage) - set defaultSelected=$$getAttrValue^%zewdAPI("defaultselected",.attrValues,technology) - s defaultSelected=$$removeQuotes^%zewdAPI(defaultSelected) - set help=$$getAttrValue^%zewdAPI("help",.attrValues,technology) - s help=$$removeQuotes^%zewdAPI(help) - set greyIf=$$getAttrValue^%zewdAPI("greyif",.attrValues,technology) - s greyIf=$$removeQuotes^%zewdAPI(greyIf) - ; - ; Map to - ; - ; and place just after tag - ; - s docName=$$getDocumentName^%zewdDOM(docOID) - s value=text_"|"_nextpage_"|"_defaultSelected_"|"_help_"|"_greyIf - s newOID=$$getFirstElementByTagName^%zewdDOM("ewd:tabmenuarray",docName,"") - i $$getParentNode^%zewdDOM(newOID)="" s newOID="" - i newOID="" d - . n parentOID,xOID - . s parentOID=$$getFirstElementByTagName^%zewdDOM("head",docName,"") - . s newOID=$$getFirstElementByTagName^%zewdDOM("ewd:new","",parentOID) - . i newOID="" d - . . s newOID=$$addNewFirstChild^%zewdCompiler4("ewd:tabmenuarray",docOID,parentOID) - . e d - . . n fcOID,nextOID,tagOID - . . s nextOID=$$getNextSibling^%zewdDOM(newOID) - . . s tagOID=$$createElement^%zewdDOM("ewd:tabmenuarray",docOID) - . . s newOID=$$insertBefore^%zewdDOM(tagOID,nextOID) - s attr("arrayname")="$ewdTabMenu" - s attr("param1")=position - s attr("value")=value - s decOID=$$addElementToDOM^%zewdDOM("ewd:setarrayvalue",newOID,,.attr,"") - ; - i nextpage'="" d - . d - . . n phpString - . . s phpString=" s tokens("""_nextpage_""")=$$setNextPageToken^%zewdCompiler20("""_nextpage_""")" - . . d addVBHeaderPreCache^%zewdCompiler8(phpString) - ; - ; $tokens['run'] = setNextPageToken('run', $ewd_session) ; - d removeIntermediateNode^%zewdCompiler4(nodeOID) - ; - QUIT - ; -xhtml(nodeOID,attrValues,docOID,technology) - ; - n dtOID,fcOID,htmlOID - ; - s dtOID=$$createDocumentType^%zewdDOM("html","-//W3C//DTD XHTML 1.0 Strict//EN","http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd",docOID) - ; - s dtOID=$$insertBefore^%zewdDOM(dtOID,nodeOID) - ; - s fcOID=$$getFirstChild^%zewdDOM(nodeOID) - s htmlOID=$$insertNewIntermediateElement^%zewdDOM(nodeOID,"html",docOID) - d setAttribute^%zewdDOM("xmlns","http://www.w3.org/1999/xhtml",htmlOID) - d setAttribute^%zewdDOM("xml:lang","en",htmlOID) - do removeIntermediateNode^%zewdDOM(nodeOID) - QUIT - ; -getSessionArrayValue(arrayName,subscript,sessid,exists) - ; - n value - ; - i $g(subscript)="" QUIT "" - i $g(arrayName)="" QUIT "" - ; - s arrayName=$tr(arrayName,".","_") - s exists=1 - i $$isTemp^%zewdAPI(arrayName) d QUIT $g(value) - . m value=zewdSession(arrayName,subscript) - . i '$d(value) s exists=0 - m value=^%zewdSession("session",sessid,arrayName,subscript) - i '$d(value) s exists=0 - QUIT $g(value) - ; -sessionArrayValueExists(arrayName,subscript,sessid) - ; - n exists,value - ; - s value=$$getSessionArrayValue(arrayName,subscript,sessid,.exists) - QUIT exists - ; -deleteSessionArrayValue(arrayName,subscript,sessid) - ; - i $g(subscript)="" QUIT "" - i $g(arrayName)="" QUIT "" - s arrayName=$tr(arrayName,".","_") - ; - i $$isTemp^%zewdAPI(arrayName) k zewdSession(arrayName,subscript) QUIT - k ^%zewdSession("session",sessid,arrayName,subscript) - d setWLDSymbol^%zewdAPI(arrayName,sessid) - QUIT - ; -setSessionObject(objectName,propertyName,propertyValue,sessid) - ; - n comma,i,np,p,sessionArray,x - ; - i $g(objectName)="" QUIT - i $g(propertyName)="" QUIT - ;i $g(propertyValue)="" QUIT - i $g(sessid)="" QUIT - s np=$l(objectName,".") - s objectName=$$replace^%zewdAPI(objectName,".","_") - i np=1 d QUIT - . i $$isTemp^%zewdAPI(objectName) s zewdSession(objectName_"_"_propertyName)=propertyValue q - . s ^%zewdSession("session",sessid,(objectName_"_"_propertyName))=propertyValue - ; - f i=1:1:np-1 s p(i)=$p(objectName,".",i) - s comma="," - i $$isTemp^%zewdAPI(objectName) d - . s x="s zewdSession(",comma="" - e d - . s x="s ^%zewdSession(""session"","_sessid - f i=1:1:np-1 s x=x_comma_""""_p(i)_"""",comma="," - s x=x_","""_propertyName_""")="""_propertyValue_"""" - x x - QUIT - ; -deleteFromSessionObject(objectName,propertyName,sessid) - ; - d deleteSessionArrayValue(objectName,propertyName,sessid) - QUIT - ; -sessionObjectPropertyExists(objectName,propertyName,sessid) - QUIT $$sessionArrayValueExists(objectName,propertyName,sessid) - ; -deleteSessionObject(objectName,sessid) - d deleteFromSession^%zewdAPI(objectName,sessid) - QUIT - ; - ; -countResultSetRecords(sessionName,sessid) - i $$isTemp^%zewdAPI(sessionName) QUIT $o(zewdSession(sessionName,""),-1) - QUIT $o(^%zewdSession("session",sessid,sessionName,""),-1) - ; -addToResultSet(sessionName,propertyName,value,sessid) - ; - n array,recNo - ; - s recNo=$$countResultSetRecords(sessionName,sessid)+1 - s array(recNo,propertyName)=value - d mergeArrayToSession^%zewdAPI(.array,sessionName,sessid) - QUIT - ; -mergeRecordArrayToResultSet(sessionName,array,sessid) - ; - n recArray,recNo - ; - s recNo=$$countResultSetRecords(sessionName,sessid)+1 - m recArray(recNo)=array - d mergeArrayToSession^%zewdAPI(.recArray,sessionName,sessid) - QUIT - ; -getResultSetValue(resultSetName,index,propertyName,sessid) - ; - n exists,value - ; - i $g(resultSetName)="" QUIT "" - i $g(index)="" QUIT "" - i $g(propertyName)="" QUIT "" - i $g(sessid)="" QUIT "" - ; - i $$isTemp^%zewdAPI(resultSetName) d QUIT $g(value) - . m value=zewdSession(resultSetName,index,propertyName) - . i '$d(value) s exists=0 - m value=^%zewdSession("session",sessid,resultSetName,index,propertyName) - i '$d(value) s exists=0 - QUIT $g(value) - ; -saveJSON(objectName,jsonString) - i objectName="ewd" QUIT "alert(""Invalid request"")" - i $$JSONAccess^%zewdAPI(objectName,sessid)'="rw" QUIT "alert(""Invalid request"")" - i jsonString["\""" s jsonString=$$replaceAll^%zewdAPI(jsonString,"\""","""") - i jsonString["\'" s jsonString=$$replaceAll^%zewdAPI(jsonString,"\'","""") - d JSONToSessionObject(objectName,jsonString,sessid) - QUIT "" - ; -getJSON(objectName,addRefCol) - i objectName="ewd" QUIT "alert(""Invalid request"")" - ;d trace^%zewdAPI("*** sessid="_sessid_"; JSONAccess="_$$JSONAccess^%zewdAPI(objectName,sessid)) - i $$JSONAccess^%zewdAPI(objectName,sessid)="" QUIT "alert(""Invalid request"")" - QUIT $$sessionObjectToJSON($g(objectName),sessid,$g(addRefCol)) - ; -JSONToSessionObject(objectName,jsonString,sessid) ; - ; - n array,obj,prop - ; - ;d parseJSON(jsonString,.array) - d parseJSON^%zewdCompiler19(jsonString,.array) - d deleteSessionObject^%zewdAPI(objectName,sessid) - d mergeArrayToSessionObject^%zewdAPI(.array,objectName,sessid) - ;s prop="" - ;f s prop=$o(array(prop)) q:prop="" d - ;. s obj=objectName_"."_prop - ;. d trace^%zewdAPI("obj="_obj_"; "_$g(array(prop))) - ;. d setSessionValue^%zewdAPI(obj,$g(array(prop)),sessid) - ;;d deleteFromSession^%zewdAPI(objectName,sessid) - ;;d mergeArrayToSession^%zewdAPI(.array,objectName,sessid) - QUIT - ; -parseJSON(jsonString,propertiesArray) - ; - n c,i,len,name,processing,started,type,value - ; - k propertiesArray - s jsonString=$g(jsonString) - s started=0 - s processing="" - s name="",value="",type="" - s len=$l(jsonString) - ; - f i=1:1:len d - . s c=$e(jsonString,i) - . i 'started,c="{" s started=1,processing="name" q - . i processing="",c="""" s processing="name",name="" q - . i processing="",c=":" s processing="value",value="",type="" q - . i processing="name" d q - . . i c=",",name="" q - . . i c="""" s processing="" q - . . i c=":" s processing="value" q - . . s name=name_c - . i processing="value" d - . . i value="" d q - . . . i c="""" s type="literal" - . . . i c?1N s type="number" - . . . i c="-" s type="number" - . . . i c="f" s type="boolean" - . . . i c="t" s type="boolean" - . . . i c="n" s type="null" - . . . i c="[" d q - . . . . n arr,no,j,val - . . . . s no=0,val="" - . . . . f j=i+1:1 d q:c="]" - . . . . . s c=$e(jsonString,j) - . . . . . i c="]" s no=$$saveSubArray(no,.val,.arr) q - . . . . . i c="," s no=$$saveSubArray(no,.val,.arr) q - . . . . . s val=val_c - . . . . m propertiesArray(name)=arr - . . . . s i=j,name="",value="",processing="name" - . . . s value=value_c - . . ;i c="]" break s name="",value="",processing="name",i=j q - . . i type="literal",c="""" s type="literalComplete",value=value_c q - . . i ((c=",")!(c="}")),type'="literal" d q - . . . i type="literalComplete" s value=$e(value,2,$l(value)-1) - . . . s processing="name" - . . . s propertiesArray(name)=value - . . . s name="",value="" - . . s value=value_c - QUIT - ; -saveSubArray(no,value,arr) - i $e(value,1)=""""!($e(value,1)="'") s value=$e(value,2,$l(value)-1) - s no=no+1 - s arr(no)=value - s value="" - QUIT no - ; -sessionObjectToJSON(objectName,sessid,addRefCol) - ; - n object,poropName,sub - ; - s sub=objectName_"_" - i $$isTemp^%zewdAPI(objectName) d - . f s sub=$o(zewdSession(sub)) q:sub="" q:sub'[(objectName_"_") d - . . s propName=$p(sub,(objectName_"_"),2) - . . m object(propName)=zewdSession(sub) - . i '$d(object) m object=zewdSession(objectName) - e d - . f s sub=$o(^%zewdSession("session",sessid,sub)) q:sub="" q:sub'[(objectName_"_") d - . . s propName=$p(sub,(objectName_"_"),2) - . . m object(propName)=^%zewdSession("session",sessid,sub) - . i '$d(object) m object=^%zewdSession("session",sessid,objectName) - QUIT $$createJSONString(objectName,.object,,$g(addRefCol)) - ; -mergeToJSObject(sessionObjRef,JSObjRef,sessid) - ; - ; eg sessionObjRef = wld.%User.bridge - ; JSObjRef = EZBRIDGE.Config - ; - n i,json,nsub,objName,ref,sessRef - ; - s sessRef=$$replace^%zewdAPI(sessionObjRef,".","_") - s nsub=$l(sessRef,".") - ; - s objName=$p(sessionObjRef,".",1) - i objName="ewd" QUIT "alert(""Invalid request"")" - i $$JSONAccess^%zewdAPI(objName,sessid)="" QUIT "alert(""Invalid request"")" - ; - s ref="",comma="" - f i=1:1:nsub s ref=ref_comma_""""_$p(sessRef,".",i)_"""",comma="," - i $$isTemp^%zewdAPI(sessRef) d - . s ref="m jsArray=zewdSession("_ref_")" - e d - . s ref="m jsArray=^%zewdSession(""session"",sessid,"_ref_")" - x ref - s json=$$createJSONString(JSObjRef,.jsArray) - QUIT json - ; -objectGlobalToJSON(objectName) - ; - QUIT $g(^zewd("jsObject",objectName)) - ; -createJSONString(objectName,objectArray,isDojo,addRefCol,directOutput) - ; - n comma,dd,json,name,object,type - ; - s directOutput=+$g(directOutput) - s isDojo=$g(isDojo) - i isDojo=1 s directOutput=0 - i '$d(objectArray) QUIT "" - s name="" - s json="" - i isDojo'=1 d - . i directOutput w objectName_"=" q - . s json=objectName_"=" - i $g(addRefCol)=1 d - . n rowNo - . s rowNo="" - . f s rowNo=$o(objectArray(rowNo)) q:rowNo="" d - . . s objectArray(rowNo,0)=rowNo-1 - s json=$$walkArray(json,$name(objectArray),isDojo) - ; - ;s json=$e(json,1,$l(json)-1)_"}" - i isDojo=1 s json="{identifier:'id',"_$e(json,2,$l(json)) - i isDojo'=1 d - . i directOutput w ";" q - . s json=json_" ;" - i $g(^zewd("trace"))=1 d trace^%zewdAPI("json="_json) - QUIT json - ; -walkArray(json,name,dojo,subscripts,isObject,mixed) - ; - n arrComma,brace,comma,cr,dd,i,no,numsub,dblquot,quot,ref,sub,subNo,subscripts1,type,valquot,value,xref,zobj - ; - s cr=$c(13,10),comma="," - s mixed=+$g(mixed) - s (dblquot,valquot)="""" - s dojo=+$g(dojo) - i dojo=1 s dblquot="",valquot="'" - i $g(isObject) d - . s json=json_"(" - s dd=$d(@name) - i dd=1!(dd=11) d i dd=1 QUIT json - . s value=@name - . i value'[">" q - . i dojo=2,value="" d q - . . i $d(subscripts) q - . . s mixed=1 - . i dojo=2,$e(value,1)="<",$e(value,$l(value))=">" q - . i dojo=2 d - . . s json=json_$p(value,">",1) ;_"("_cr - . i dojo=2 d - . . s json=$$walkArray(json,$p(value,">",2),$g(dojo),,1) - . e d - . . s json=$$walkArray(json,value,$g(dojo),,1) - . ;s json=json_cr_")" - i 'mixed d - . s json=json_"{" - s ref=name_"(" - s no=$o(subscripts(""),-1) - i no>0 f i=1:1:no d - . s quot="""" - . i subscripts(i)?."-"1N.N s quot="" - . s ref=ref_quot_subscripts(i)_quot_"," - ;i no>0 f i=1:1:no s ref=ref_dblquot_subscripts(i)_dblquot_"," - s ref=ref_"sub)" - s sub="",numsub=0,subNo=0 - f s sub=$o(@ref) q:sub="" d - . s subscripts(no+1)=sub - . s subNo=subNo+1 - . i 'mixed,subNo=1,sub?1N.N d - . . s numsub=1 - . . s json=$e(json,1,$l(json)-1)_"[" - . s dd=$d(@ref) - . i dd=1 d - . . ;w ref_"="_@ref,! - . . s value=@ref - . . ;i sub'?1N.N s json=json_dblquot_sub_dblquot_":" - . . i sub'?1N.N d - . . . s json=json_sub_":" - . . s type="literal" - . . i dojo=2,value[">",value'["?>" d - . . . i $e(value,$l(value))=">" q - . . . d - . . . . s json=json_$p(value,">",1) ;_"("_cr - . . . s json=$$walkArray(json,$p(value,">",2),$g(dojo),,1) - . . . s type="object" - . . . s value="" - . . i value?1N.N s type="numeric" - . . i value?1"-"1N.N s type="numeric" - . . i value?1N.N1"."1N.N s type="numeric" - . . i value?1"-"1N.N1"."1N.N s type="numeric" - . . i value="true"!(value="false") s type="boolean" - . . i $e(value,1)="{",$e(value,$l(value))="}" s type="variable" - . . i dojo=2,value["" d - . . . s value=$p(value,"",1) - . . . s value=$$stripSpaces^%zewdAPI(value) - . . . s type="variable" - . . ;i type="literal" s value=""""_value_"""" - . . i type="literal" s value=valquot_value_valquot - . . i dojo=1,type="numeric" s value=valquot_value_valquot - . . d - . . . s json=json_value_"," - . k subscripts1 - . m subscripts1=subscripts - . i dd>9 d - . . i sub?1N.N d - . . . i 'mixed,subNo=1 d - . . . . s numsub=1 - . . . . s json=$e(json,1,$l(json)-1)_"[" - . . e d - . . . ;s json=json_dblquot_sub_dblquot_":" - . . . i $e(sub,1,4)'="zobj" d - . . . . s json=json_sub_":" - . . . i $e(sub,1,4)="zobj" d - . . . . i $e(json,$l(json))'="," d - . . . . . s json=$e(json,1,$l(json)-1),zobj=1 ; remove { at end - . . s json=$$walkArray(json,name,dojo,.subscripts1) - . . i dojo=1,numsub d - . . . s json=$e(json,1,$l(json)-1) - . . . s json=json_",id:'"_sub_"'}" - . . d - . . . s json=json_"," - ; - s json=$e(json,1,$l(json)-1) - s brace="}" - i mixed s brace="" - i $g(isObject) s brace=brace_")" - i numsub s brace="]" - i $g(zobj)'=1 d - . s json=json_brace - QUIT json ; exit! - ; -createRef(name,subscripts) - ; - n no,ref - ; - s ref=name_"(" - s no=$o(subscripts(""),-1) - i no>0 f i=1:1:no d - . s quot="""" - . i subscripts(i)?."-"1N.N s quot="" - . s ref=ref_quot_subscripts(i)_quot_"," - s ref=ref_""""")" - QUIT ref - ; -test - k array - s array("label")="name" - s array("items",1,"name")="Fruit" - s array("items",1,"type")="category" - s array("items",2,"name")="Cinammon" - s array("items",2,"type")="category" - s array("items",2,"children",1,"name")="Cinnamon Lozenge" - s array("items",2,"children",1,"type")="category" - s array("items",2,"children",2,"name")="Cinnamon Toast" - s array("items",2,"children",2,"type")="category" - s array("items",2,"children",3,"name")="Cinnamon Spread" - s array("items",2,"children",3,"type")="category" - s array("items",3,"name")="Apple" - s array("items",3,"type")="category" - w $$createJSONString("myTest",.array,1) - QUIT - ; -addJavascriptObject(docName,jsText) - ; - n childOID,lastLineNo,line,lineNo,OIDArray,scriptOID,text,textArray,textOID - ; - s scriptOID=$$getLastJavascriptTag(docName,.textArray) - s lastLineNo=$o(textArray(""),-1) - s lineNo="",text="" - f s lineNo=$o(jsText(lineNo)) q:lineNo="" d - . i jsText(lineNo)[""_temp_" || echo ""0"">"_temp - o temp:(readonly:exception="g dirFileNotExists") - u temp - r line - c temp - s ok=$$deleteFile(temp) - QUIT line -dirFileNotExists - i $p($zs,",",1)=2 QUIT 0 - QUIT 0 - ; -fileSize(path) - n line,temp - i '$$fileExists(path) QUIT 0 - d shellCommand^%zewdGTM("ls -s """_path_"""",.results) - s line=$g(results(1)) - s line=$$stripLeadingSpaces^%zewdAPI(line) - s line=$p(line," ",1) - QUIT +line - ; -displayText(textID,reviewMode,sessid) - ; - i $g(textID)="" QUIT "" - s reviewMode=+$g(reviewMode) - n text,language,phraseType,appName - s language=$$getSessionValue^%zewdAPI("ewd_Language",sessid) - i $g(language)="" d - . n appName - . s appName=$$getTextAppName^%zewdCompiler5(textID) - . s language=$$getDefaultLanguage^%zewdCompiler5(appName) - i '$d(^ewdTranslation("textid",textID)) QUIT "textid "_textID_" : text missing" - s text=$g(^ewdTranslation("textid",textID,language)) - i text="" s text=$g(^ewdTranslation("textid",textID,$$getDefaultLanguage^%zewdCompiler5($$getTextAppName^%zewdCompiler5(textID)))) - i language="xx" s text=textID_" ("_text_")" - i reviewMode d - . s text=text_" {textid="_textID_" : "_$g(^ewdTranslation("textid",textID,$$getDefaultLanguage^%zewdCompiler5($$getTextAppName^%zewdCompiler5(textID))))_"}" - s phraseType=$$getTextPhraseType^%zewdCompiler5(textID) - ;d trace^%zewdAPI("phraseType="_phraseType_" ; text="_text) - i phraseType'="error" d - . s text=$$replaceAll^%zewdAPI(text,"\'","'") - . s text=$$replaceAll^%zewdAPI(text,"\""","""") - . s text=$$replaceAll^%zewdAPI(text,"'","'") - e d - . s text=$$replaceAll^%zewdAPI(text,"'",$c(5)) - . s text=$$replaceAll^%zewdAPI(text,$c(5),"\'") - QUIT text - ; -mergeGlobalToSession(globalName,sessionName,sessid) - s globalName=$$stripSpaces^%zewdAPI(globalName) - QUIT:$g(sessid)="" - QUIT:$g(sessionName)="" - s sessionName=$tr(sessionName,".","_") - i $$isTemp^%zewdAPI(sessionName) m zewdSession(sessionName)=@globalName QUIT - m ^%zewdSession("session",sessid,sessionName)=@globalName - QUIT - ; - ; -mergeGlobalFromSession(globalName,sessionName,sessid) - ; - n x - ; - s globalName=$$stripSpaces^%zewdAPI(globalName) - QUIT:$g(sessid)="" - QUIT:$g(sessionName)="" - s sessionName=$tr(sessionName,".","_") - i $$isTemp^%zewdAPI(sessionName) s x="m "_globalName_"=zewdSession(sessionName)" x x QUIT - s x="m "_globalName_"=^%zewdSession(""session"",sessid,sessionName)" x x - QUIT - ; -createCSSFile(outputPath,mode,verbose,technology) ; - ; - n filePath,label,line,lineNo,no,stop,x - ; - i $d(^zewd("config","jsScriptPath",technology,"outputPath")) d - . n dlim - . s dlim=$$getDelim^%zewdAPI() - . s outputPath=^zewd("config","jsScriptPath",technology,"outputPath") - . i $e(outputPath,$l(outputPath))'=dlim s outputPath=outputPath_dlim - s filePath=outputPath_"ewd.css" - i '$$openNewFile^%zewdCompiler(filePath) QUIT - u filePath - f label="ewdStyles" d - . s stop=0 - . f lineNo=1:1 d q:stop - . . s x="s line=$t("_label_"+lineNo^%zewdCompiler18)" - . . x x - . . i line["***END***" s stop=1 q - . . i line[";;*php*",technology'="php" q - . . i line[";;*csp*",((technology'="csp")!(technology="wl")!(technology="gtm")) q - . . i line[";;*jsp*",technology'="jsp" q - . . i line[";;*vb.net*",technology'="vb.net" q - . . i line["left(up)" d - . . . ; left(up):-4px - . . . s line=$$replace^%zewdAPI(line,"(up)","") - . . . i mode="collapse" s line=";; left:0px;" - . . i line["left(down)" d - . . . ;; left(down):-33px ; - . . . s line=$$replace^%zewdAPI(line,"(down)","") - . . . i mode="collapse" s line=";; left:-25px;" - . . s line=$$replace^%zewdHTMLParser(line,"*php*"," ") - . . s line=$$replace^%zewdHTMLParser(line,"*csp*"," ") - . . s line=$$replace^%zewdHTMLParser(line,"*jsp*"," ") - . . s line=$$replace^%zewdHTMLParser(line,"*vb.net*"," ") - . . w $p(line,";;",2,250),! - c filePath - QUIT - ; -spinner(nodeOID,attrValues,docOID,technology) - ; - n attr,attrName,elOID,imagePath,increment,max,min,name,onBlur - n onDown,onUp,onUpOrDown,size,value,width - ; - s name=$$getAttrValue^%zewdAPI("name",.attrValues,technology) - s name=$$removeQuotes^%zewdAPI(name) - i name="" s name="spinner"_$p(nodeOID,"-",2) - s size=$$getAttrValue^%zewdAPI("size",.attrValues,technology) - s size=$$removeQuotes^%zewdAPI(size) - i size="" s size=2 - s width=size*8 - s value=$$getAttrValue^%zewdAPI("value",.attrValues,technology) - s value=$$removeQuotes^%zewdAPI(value) - i value="" s value="*" - s max=$$getAttrValue^%zewdAPI("max",.attrValues,technology) - s max=$$removeQuotes^%zewdAPI(max) - i max="" s max="9999999999" - s min=$$getAttrValue^%zewdAPI("min",.attrValues,technology) - s min=$$removeQuotes^%zewdAPI(min) - i min="" s min="0" - s increment=$$getAttrValue^%zewdAPI("increment",.attrValues,technology) - s increment=$$removeQuotes^%zewdAPI(increment) - i increment="" s increment="100" - s imagePath=$$getAttrValue^%zewdAPI("imagepath",.attrValues,technology) - s imagePath=$$removeQuotes^%zewdAPI(imagePath) - s onUp=$$getAttrValue^%zewdAPI("onup",.attrValues,technology) - s onUp=$$removeQuotes^%zewdAPI(onUp) - s onDown=$$getAttrValue^%zewdAPI("ondown",.attrValues,technology) - s onDown=$$removeQuotes^%zewdAPI(onDown) - s onBlur=$$getAttrValue^%zewdAPI("onblur",.attrValues,technology) - s onBlur=$$removeQuotes^%zewdAPI(onBlur) - s onUpOrDown=$$getAttrValue^%zewdAPI("onupordown",.attrValues,technology) - s onUpOrDown=$$removeQuotes^%zewdAPI(onUpOrDown) - s attrName="" - f s attrName=$o(attrValues(attrName)) q:attrName="" d - . i "|name|size|value|max|min|increment|onup|ondown|onupordown|"[("|"_attrName_"|") q - . s attr(attrName)=$$removeQuotes^%zewdAPI(attrValues(attrName)) - s attr("type")="text" - s attr("name")=name - s attr("value")=value - s attr("class")="ewdSpinnerText" - s attr("style")="width:"_width_"px" - s attr("onKeyDown")="EWD.page.spinnerControl(event,'"_name_"',"_min_","_max_")" - i onBlur="" d - . s attr("onBlur")="EWD.page.spinnerValueCheck(this.value,'"_name_"',"_min_","_max_")" - e d - . s attr("onBlur")=onBlur - s elOID=$$addElementToDOM^%zewdDOM("input",nodeOID,,.attr) - i onUp'="" s attr("onClick")=onUp - i onUpOrDown'="" d - . i onUp'="" s onUpOrDown=onUp_" ; "_onUpOrDown - . s attr("onClick")=onUpOrDown - s attr("type")="button" - s attr("name")=name_"Up" - s attr("tabIndex")="-1" - s attr("class")="ewdSpinnerButtonUp" - i imagePath'="" s attr("style")="background: url("_imagePath_"spinnerUp.gif) no-repeat;" - s attr("onMouseDown")="EWD.page.spinnerKeyDown = true ;EWD.page.incrementSpinner('"_name_"',"_max_","_increment_")" - s attr("onMouseUp")="EWD.page.spinnerKeyDown=false" - s elOID=$$addElementToDOM^%zewdDOM("input",nodeOID,,.attr) - i onDown'="" s attr("onClick")=onDown - i onUpOrDown'="" d - . i onDown'="" s onUpOrDown=onDown_" ; "_onUpOrDown - . s attr("onClick")=onUpOrDown - s attr("type")="button" - s attr("name")=name_"Down" - s attr("tabIndex")="-1" - s attr("class")="ewdSpinnerButtonDown" - i imagePath'="" s attr("style")="background: url("_imagePath_"spinnerDown.gif) no-repeat;" - s attr("onMouseDown")="EWD.page.spinnerKeyDown = true ;EWD.page.decrementSpinner('"_name_"',"_min_","_increment_")" - s attr("onMouseUp")="EWD.page.spinnerKeyDown=false" - s elOID=$$addElementToDOM^%zewdDOM("input",nodeOID,,.attr) - ; - do removeIntermediateNode^%zewdDOM(nodeOID) - ; - QUIT - ; -popups(allArray,docOID,jsOID,nextPageList,urlNameList,technology) - ; - ; Process pop-up directives - ; - n attr,eh,ehx,ehy,ehz,event,found,jsName,jsParams,nextPage - n nodeOID,nodeType,nvp,properties,props,tagName,url,useCurrentPosition - n winHandle,winName - ; - ;d getAllNodes^%zewdCompiler(docOID,.allArray) - s nodeOID="",found=0 - f s nodeOID=$o(allArray(0,nodeOID)) q:nodeOID="" d - . ; - . ; popup="eHelpWindow" page="sysConfigHelp" event="OnClick" x=50 y=50 height=400 width=600 - . ; ewdOpenWindow(url,winName,x,y,height,width,toolbar,location,directories,status,menubar,scrollbars,resizable) - . ; toolbar=no,location=no,directories=no,status=no,menubar=no,scrollbars=yes,resizable=yes - . ; - . s nodeType=$$getNodeType^%zewdDOM(nodeOID) - . i nodeType'=1 q - . s winHandle=$$getAttributeValue^%zewdDOM("popup",1,nodeOID) - . if winHandle="" quit - . s winName=winHandle - . i winHandle["[]" d - . . n attr,headOID,jsOID,jsText - . . s winName=$$getAttributeValue^%zewdDOM("windowname",1,nodeOID) - . . s jsOID=$$getTagByNameAndAttr^%zewdAPI("script","id","ewdWinNames",1,docName) - . . i jsOID="" d - . . . s attr("language")="javascript" - . . . s attr("id")="ewdWinNames" - . . . s headOID=$$getTagOID^%zewdAPI("head",docName) - . . . s jsText=$p(winHandle,"[",1)_" = new Array() ;" - . . . s jsOID=$$addElementToDOM^%zewdDOM("script",headOID,,.attr,jsText) - . . e d - . . . n refStr,textOID - . . . s textOID=$$getFirstChild^%zewdDOM(jsOID) - . . . s jsText=$$getData^%zewdDOM(textOID) - . . . s refStr=$p(winHandle,"[",1)_" = new Array() ;" - . . . i jsText'[refStr s jsText=jsText_$c(13,10)_refStr - . . . s textOID=$$modifyTextData^%zewdDOM(jsText,textOID) - . ; - . s found=1 - . s event=$$zcvt^%zewdAPI($$getAttributeValue^%zewdDOM("event",1,nodeOID),"L") - . i event="" set event="onclick" - . s nextPage=$$getAttributeValue^%zewdDOM("page",0,nodeOID) - . s props("x")=+$$getAttributeValue^%zewdDOM("x",1,nodeOID) - . s props("y")=+$$getAttributeValue^%zewdDOM("y",1,nodeOID) - . s useCurrentPosition=$$getAttributeValue^%zewdDOM("usecurrentposition",1,nodeOID) - . i $$zcvt^%zewdAPI(useCurrentPosition,"l")="true" d - . . s props("x")="EWD.utils.findPosX(this)+"_props("x") - . . s props("y")="EWD.utils.findPosY(this)+"_props("y") - . e d - . . s props("x")="'"_props("x")_"'" - . . s props("y")="'"_props("y")_"'" - . s props("width")=$$getAttributeValue^%zewdDOM("width",1,nodeOID) if props("width")="" set props("width")=100 - . s props("height")=$$getAttributeValue^%zewdDOM("height",1,nodeOID) if props("height")="" set props("height")=100 - . s props("toolbar")=$$getAttributeValue^%zewdDOM("toolbar",1,nodeOID) if props("toolbar")="" set props("toolbar")="no" - . s props("location")=$$getAttributeValue^%zewdDOM("location",1,nodeOID) if props("location")="" set props("location")="no" - . s props("directories")=$$getAttributeValue^%zewdDOM("directories",1,nodeOID) if props("directories")="" set props("directories")="no" - . s props("status")=$$getAttributeValue^%zewdDOM("status",1,nodeOID) if props("status")="" set props("status")="no" - . s props("menubar")=$$getAttributeValue^%zewdDOM("menubar",1,nodeOID) if props("menubar")="" set props("menubar")="no" - . s props("scrollbars")=$$getAttributeValue^%zewdDOM("scrollbars",1,nodeOID) if props("scrollbars")="" set props("scrollbars")="yes" - . s props("resizable")=$$getAttributeValue^%zewdDOM("resizable",1,nodeOID) if props("resizable")="" set props("resizable")="yes" - . f attr="useCurrentPosition","popup","event","page","x","y","width","height","toolbar","location","directories","status","menubar","scrollbars","resizable" do - . . d removeAttribute^%zewdAPI(attr,nodeOID,1) - . ; - . s ehx=$$getAttributeValue^%zewdDOM(event,1,nodeOID) - . s ehy=$$getAttributeValue^%zewdDOM("onclickpre",1,nodeOID) - . s ehz=$$getAttributeValue^%zewdDOM("onclickpost",1,nodeOID) - . d removeAttribute^%zewdAPI("onclickpre",nodeOID,1) - . d removeAttribute^%zewdAPI("onclickpost",nodeOID,1) - . s url=$$expandPageName^%zewdCompiler8(nextPage,.nextPageList,.urlNameList,technology,.jsParams) - . ; allow popup names defined in JS reference - ie use unquoted - . s winHandle=$s($e($$zcvt^%zewdAPI($tr(winHandle,"",""),"L"),1,9)="document.":winHandle,1:"'"_winHandle_"'") - . s winName=$s($e($$zcvt^%zewdAPI($tr(winName,"",""),"L"),1,9)="document.":winName,1:"'"_winName_"'") - . set eh="EWD.page.openWindow('"_url_"',"_winHandle_","_winName - . for attr="x","y","height","width","toolbar","location","directories","status","menubar","scrollbars","resizable" do - . . i attr'="x",attr'="y" d - . . . set eh=eh_",'"_props(attr)_"'" - . . e d - . . . set eh=eh_","_props(attr) - . set jsName="" - . for set jsName=$order(jsParams(jsName)) quit:jsName="" do - . . set eh=eh_","_jsParams(jsName) - . set eh=eh_")" - . if ehx'="" set eh=eh_" ; "_ehx - . if ehz'="" set eh=eh_" ; "_ehz - . if ehy'="" set eh=ehy_" ; "_eh - . do setAttribute^%zewdDOM(event,eh,nodeOID) - ; - QUIT - ; -addServerToSession(sessid,serverArray) - QUIT:$g(sessid)="" - ; - k ^%zewdSession("session",sessid,"ewd_Server") - m ^%zewdSession("session",sessid,"ewd_Server")=serverArray - d setWLDSymbol^%zewdAPI("ewd_Server",sessid) - QUIT - ; -displayTextArea(fieldName) - n lineNo,text,lastLineNo - ; - s fieldName=$tr(fieldName,".","_") - d - . s lastLineNo=$o(^%zewdSession("session",sessid,"ewd_textarea",fieldName,""),-1) - . s lineNo=0 - . f s lineNo=$o(^%zewdSession("session",sessid,"ewd_textarea",fieldName,lineNo)) q:lineNo="" d - . . k text - . . s text=^%zewdSession("session",sessid,"ewd_textarea",fieldName,lineNo) - . . s text=$$replaceAll^%zewdHTMLParser(text,"'","'") - . . w $$zcvt^%zewdAPI(text,"o","HTML") - . . i lineNo'=lastLineNo w $c(13,10) - QUIT - ; -isNextPageTokenValid(token,sessid,page) - ; - n allowedFrom,expectedPage,fromPage - ; - s expectedPage=$p($g(^%zewdSession("nextPageTokens",sessid,token)),"~",1) - ;s allowedFrom=$p($g(^%zewdSession("nextPageTokens",sessid,token)),"~",2) - i expectedPage="" QUIT 0 - ;d trace^%zewdAPI("token="_token_" ; allowedFrom="_allowedFrom_" ; actual from page="_fromPage) - ;i allowedFrom'=fromPage QUIT 0 - i page[".php" d - . s page=$p(page,"/",$l(page,"/")) - . s page=$p(page,".php",1) - QUIT $$zcvt^%zewdAPI(expectedPage,"L")=$$zcvt^%zewdAPI(page,"L") - ; -existsInSessionArray(name,p1,p2,p3,p4,p5,p6,p7,p8,p9,p10,p11) - ; - n exists,i,nparams,param,ref,sessid,stop,technology,value - ; - s stop=0 - f i=11:-1:1 d q:stop - . s param="p"_i - . i $g(@param)'="" s stop=1 - s sessid=@("p"_i) - s technology=$$getSessionValue^%zewdAPI("ewd_technology",sessid) - s nparams=i-1 - s name=$tr($g(name),".","_") - i $$isTemp^%zewdAPI(name) d - . s ref="s exists=$d(zewdSession("""_name_"""" - . s ref="s exists=$d(sessionArray("""_name_"""" - e s ref="s exists=$d(^%zewdSession(""session"","""_sessid_""","""_name_"""" - i nparams>0 d - . f i=1:1:nparams s ref=ref_","""_$g(@("p"_i))_"""" - s ref=ref_"))" - ;d trace^%zewdAPI("ref="_$g(ref)) - x ref - ;d trace^%zewdAPI("ref="_ref_" ; exists="_exists) - QUIT exists - ; -getSchemaFormErrors(errorArray,sessid) - ; - n error,num - ; - k errorArray - d mergeArrayFromSession^%zewdAPI(.errorArray,"ewd_SchemaFormError",sessid) - s error="" - s num="" - f s num=$o(errorArray("list",num)) q:num="" d - . s error=error_errorArray("list",num)_$c(13,10) - QUIT error - ; -existsInSession(name,sessid) - n result,technology - ; - s name=$$stripSpaces^%zewdAPI(name) - i $g(name)="" QUIT 0 - s name=$tr(name,".","_") - i $g(sessid)="" QUIT 0 - s technology=$$getSessionValue^%zewdAPI("ewd_technology",sessid) - i $$isTemp^%zewdAPI(name) QUIT $d(sessionArray(name)) - QUIT $d(^%zewdSession("session",sessid,name)) - ; -encodeDataType(name,dataType,sessid) - ; - n value,outputMethod,x,encodedValue,Error - ; - i $g(name)="" QUIT "Data Type encoding attempted but field name was not specified" - i $g(dataType)="" QUIT "Data Type encoding attempted for the "_name_" field, but no data type was defined" - s value=$$getSessionValue^%zewdAPI(name,sessid) - s outputMethod=$$getOutputMethod^%zewdCompiler(dataType) - i outputMethod="" QUIT "" - s x="s encodedValue=$$"_outputMethod_"("""_value_""",.Error,sessid)" - x x - i $g(Error)="" d setSessionValue^%zewdAPI(name,encodedValue,sessid) - ;i Error'="" s Error=name_" : "_Error - QUIT Error - ; diff --git a/p/_zewdGTM.m b/p/_zewdGTM.m deleted file mode 100644 index 989347c..0000000 --- a/p/_zewdGTM.m +++ /dev/null @@ -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 . | - ; ---------------------------------------------------------------------------- - ; - ; - 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***