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***