From a55a619c66a62c77dcc3d0cdeaa91952f9cab6d9 Mon Sep 17 00:00:00 2001 From: george Date: Fri, 8 Jul 2011 19:24:07 +0000 Subject: [PATCH] version for certification --- p/C0CALERT.m | 1 + p/C0CCCR.m | 11 +- p/C0CCCR0.m | 11 -- p/C0CLABS.m | 8 + p/C0CMAIL.m | 372 +++++++++++++++++++++++++++++++++++ p/C0CMAIL3.m | 534 +++++++++++++++++++++++++++++++++++++++++++++++++++ p/C0CMED3.m | 56 +++++- p/C0CNMED2.m | 121 ++++++++++++ p/C0CNMED4.m | 15 +- p/C0CORSLT.m | 69 +++++++ p/C0CPROBS.m | 7 +- p/C0CPROC.m | 9 + p/C0CUTIL.m | 18 +- 13 files changed, 1204 insertions(+), 28 deletions(-) create mode 100644 p/C0CMAIL.m create mode 100644 p/C0CMAIL3.m create mode 100644 p/C0CNMED2.m create mode 100644 p/C0CORSLT.m diff --git a/p/C0CALERT.m b/p/C0CALERT.m index 4b12ac4..237289f 100644 --- a/p/C0CALERT.m +++ b/p/C0CALERT.m @@ -81,6 +81,7 @@ EXTRACT(ALTXML,DFN,ALTOUTXML,CALLBK) ; EXTRACT ALERTS INTO XML TEMPLATE . S ACNM=$P(@ALTG@(ALTTMP),U,2) ; REACTANT . S @ALTVMAP@("ALERTAGENTPRODUCTNAMETEXT")=ACNM . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION + . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE . I ACVUID'="" D ; IF VUID IS NOT NULL . . S ZC=$$CODE^C0CUTIL(ACVUID) . . S ZCD=$P(ZC,"^",1) ; CODE TO USE diff --git a/p/C0CCCR.m b/p/C0CCCR.m index e60e5b7..573225c 100644 --- a/p/C0CCCR.m +++ b/p/C0CCCR.m @@ -102,6 +102,7 @@ CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART) ;RPC ENTRY POINT FOR CCR OUTPUT D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Body") D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Actors") D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Signatures") + D REPLACE^C0CXPATH(CCRGLO,"","//ContinuityOfCareRecord/Comments") I DEBUG F I=1:1:@CCRGLO@(0) W @CCRGLO@(I),! ; D HDRMAP(CCRGLO,DFN) ; MAP HEADER VARIABLES @@ -133,9 +134,10 @@ CCRRPC(CCRGRTN,DFN,CCRPARMS,CCRPART) ;RPC ENTRY POINT FOR CCR OUTPUT D EXTRACT^C0CACTOR("ACTT",ACTGLO,"ACTT2") D INSINNER^C0CXPATH(CCRGLO,"ACTT2","//ContinuityOfCareRecord/Actors") K ACTT,ACTT2 - D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT") - D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2") - D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments") + ;D QUERY^C0CXPATH(TGLOBAL,"//ContinuityOfCareRecord/Comments","CMTT") + ;D EXTRACT^C0CCMT("CMTT",DFN,"CMTT2") + ;D INSINNER^C0CXPATH(CCRGLO,"CMTT2","//ContinuityOfCareRecord/Comments") + ; gpl - turned off Comments for Certification K CMTT,CMTT2 N TRIMI,J,DONE S DONE=0 F TRIMI=0:0 D Q:DONE ; DELETE UNTIL ALL EMPTY ELEMENTS ARE GONE @@ -163,7 +165,8 @@ INITSTPS(TAB) ; INITIALIZE CCR PROCESSING STEPS E D PUSH^C0CXPATH(TAB,"EXTRACT;C0CVITAL;//ContinuityOfCareRecord/Body/VitalSigns;^TMP(""C0CCCR"",$J,DFN,""VITALS"")") D PUSH^C0CXPATH(TAB,"MAP;C0CLABS;//ContinuityOfCareRecord/Body/Results;^TMP(""C0CCCR"",$J,DFN,""RESULTS"")") D PUSH^C0CXPATH(TAB,"EXTRACT;C0CPROC;//ContinuityOfCareRecord/Body/Procedures;^TMP(""C0CCCR"",$J,DFN,""PROCEDURES"")") - D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") + ;D PUSH^C0CXPATH(TAB,"EXTRACT;C0CENC;//ContinuityOfCareRecord/Body/Encounters;^TMP(""C0CCCR"",$J,DFN,""ENCOUNTERS"")") + ; gpl - turned off Encounters for Certification Q ; HDRMAP(CXML,DFN) ; MAP HEADER VARIABLES: FROM, TO ECT diff --git a/p/C0CCCR0.m b/p/C0CCCR0.m index 0eded61..af86ac1 100644 --- a/p/C0CCCR0.m +++ b/p/C0CCCR0.m @@ -791,17 +791,6 @@ LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME ;; ;; ;; - ;; - ;; - ;;@@IDTYPE@@ - ;; - ;;@@ID@@ - ;; - ;; - ;;@@IDDESC@@ - ;; - ;; - ;; ;; ;;@@ACTORSPECIALITY@@ ;; diff --git a/p/C0CLABS.m b/p/C0CLABS.m index 44216ed..c474995 100644 --- a/p/C0CLABS.m +++ b/p/C0CLABS.m @@ -129,6 +129,8 @@ EXTRACT(ILXML,DFN,OLXML) ; EXTRACT LABS INTO THE C0CLVAR GLOBAL N QTSAV S QTSAV=C0CQT ;SAVE QUIET FLAG S C0CQT=1 ; SURPRESS LISTING D LIST ; EXTRACT THE VARIABLES + ; FOR CERTIFICATION, SEE IF THERE ARE OTHER RESULTS TO ADD + D EN^C0CORSLT(C0CLB,DFN) ; LOOKS FOR ECG TESTS S C0CQT=QTSAV ; RESET SILENT FLAG K ^TMP("HLS",$J) ; KILL HL7 MESSAGE OUTPUT I $D(OLXML) S @OLXML@(0)=0 ; EXTRACT DOES NOT PRODUCE XML... SEE MAP^C0CLABS @@ -151,6 +153,7 @@ GHL7 ; GET HL7 MESSAGE FOR LABS FOR THIS PATIENT D DT^DILF(,C0CLLMT,.C0CSDT) ; W "LAB LIMIT: ",C0CLLMT,! D DT^DILF(,C0CLSTRT,.C0CEDT) ; END DATE TODAY - IMPLEMENT END DATE PARM + S C0CEDT=$$NOW^XLFDT ; PULL LABS STARTING NOW S C0CR=$$LAB^C0CLA7Q(C0CPTID,C0CSDT,C0CEDT,C0CSPC,C0CSPC) ; CALL LAB LOOKUP Q ; @@ -171,6 +174,11 @@ LIST ; LIST THE HL7 MESSAGE; ALSO, EXTRACT THE RESULT VARIABLES TO C0CLB . K C0CVAR,XV ; CLEAR OUT VARIABLE VALUES . S C0CTYP=$P(@C0CHB@(C0CI),"|",1) . D LTYP(@C0CHB@(C0CI),C0CTYP,.C0CVAR,C0CQT) + . I $G(C0CVAR("RESULTCODINGSYSTEM"))="LN" D ; gpl - for certification + . . S C0CVAR("RESULTCODINGSYSTEM")="LOINC" ; NEED TO SPELL IT OUT + . . N C0CRDT S C0CRDT=C0CVAR("RESULTDESCRIPTIONTEXT") ; THE DESCRIPTION + . . N C0CRCD S C0CRCD=C0CVAR("RESULTCODE") ; THE LOINC CODE + . . S C0CVAR("RESULTDESCRIPTIONTEXT")=C0CRDT_" LOINC: "_C0CRCD . M XV=C0CVAR ; . I C0CTYP="OBR" D ; BEGINNING OF NEW SECTION . . S @C0CLB@(0)=@C0CLB@(0)+1 ; INCREMENT COUNT diff --git a/p/C0CMAIL.m b/p/C0CMAIL.m new file mode 100644 index 0000000..5cee7a8 --- /dev/null +++ b/p/C0CMAIL.m @@ -0,0 +1,372 @@ +C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr +V ;;0.1;C0C;nopatch;noreleasedate + ;Copyright 2011 Chris Richardson, Richardson Computer Research + ; Modified 3110516@1818 + ; rcr@rcresearch.us + ; 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. + ; + ; ------------------ + ;Entry Points + ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) + ; Input: + ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL + ; or "*" for all boxes, default is "IN" if missing]" + ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", + ; "*" for All or 9,999 maximum + ; MALL?1.n = that number of the n most recent + ; Internally: + ; BNAM = Box Name + ; Output: + ; C0CDATA + ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket + ; (BNAM,"MSG",C0CIEN,"FROM")=Name + ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title + ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments + ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text + ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text + ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes + ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) + ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data + ; + ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments + ; Input; + ; D0 - The IEN for the message in file 3.9, MESSAGE global + ; Output + ; OUTBF - The array of your choice to save the expanded and decoded message. + ; +GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data + K:'$G(C0CDATA("KEEP")) C0CDATA + N U + S U="^" + D:$G(C0CINPUT) + . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL + . S INPUT=C0CINPUT + . S DUZ=+INPUT + . D:$D(^XMB(3.7,DUZ,0))#2 + . . S MBLST=$P(INPUT,";",2) + . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag + . . S:MALL["*" MALL=99999 + . . ; Only one of these can be correct + . . D + . . . ; If nul, make it "IN" only + . . . I MBLST="" D QUIT + . . . . S MBLST("IN")=0,I=0 + . . . . D GATHER(DUZ,"IN",.LST) + . . . .QUIT + . . . ; + . . . ; If "*", Get all Mailboxes and look for New Messages + . . . I MBLST["*" D QUIT + . . . . N NAM,NUM + . . . . S NUM=0 + . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D + . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) + . . . . . D GATHER(DUZ,NAM,.LST) + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If comma separated, look for mailboxes with new messages + . . . I $L(MBLST,",")>1 D QUIT + . . . . S NAM="" + . . . . N T,V + . . . . F T=1:1:$L(MBLST,",") S V=$P(MBLST,",",T) I $L(V) D + . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) + . . . . . S:NAM="" NAM=V + . . . . . D GATHER(DUZ,NAM,.LST) + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If only 1 mailbox named, go get it + . . . I $L(MBLST) D GATHER(DUZ,MBLST,.LST) QUIT + . . .QUIT + . . MERGE C0CDATA=LST + . .QUIT + .QUIT + QUIT + ; =================== +GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail + N I,J,K,L + S (I,K)=0 + S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) + F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D + . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) + . D ; :L + . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails + . . S LST(NAM,"MSG",I)=L + . . D GETTYP(I) + . .QUIT + .QUIT + S LST(NAM,"NUMBER")=K + QUIT + ; =================== + ; D0 is the IEN into the Message Global ^XMB(3.9,D0) + ; The products of these emails are scanned to identify + ; the number of documents stored in the MIME package. + ; The protocol runs like this; + ; Line 1 is the --separator + ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD + ; Line n+2 thru t-1 where t does NOT have "Content-" + ; Line t is Next Section Terminator, or Message Terminator, --separator + ; Line t+1 should not exist in the data set if Message Terminator + ; CON = "Content-" + ; FLG = "--" + ; SEP = FLG+7 or more characters ; Separator + ; END = SEP+FLG + ; SGC = Segment Count + ; Note: separator is a string of specific characters of + ; indeterminate length + ; LST() the transfer array + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data + ; +GETTYP(D0) ; Look for the goodies in the Mail + N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM + S CON="Content-" + S FLG="--" + S SEP="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) + S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D + . N T + . S T=+$G(^XMB(3.9,D0,1,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S LST("TO",D1)=T + . S T=$G(^XMB(3.9,D0,6,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . S LST("TO NAME",D1)=T + .QUIT + ; Preload first Segment (0) with beginning on Line 1 + ; if not a 64bit + S LST(NAM,"MSG",D0,"SEG",0)=1 + S D1=.9999,SEP="--" + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; Enter once to set the SEP to capture the separator + . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q + . . S SEP=X,END=X_FLG + . . S (CNT,SGC)=1,BCN=0 + . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 + . .QUIT + . ; + . ; A new separator is set, process original + . I X=SEP D QUIT + . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN + . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) + . . S SGC=SGC+1,BCN=0 + . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 + . .QUIT + . ; + . S BCN=BCN+$L(X) + . I X[CON D Q + . . S J=$P($P(X,";"),CON,2) + . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) + . .QUIT + . ; + . ; S LST(NAM,"MSG",D0,"SEG",D1)=X + .QUIT + QUIT + ; =================== +NAME(NM) ; Return the name of the Sender + N NAME + S NAME="" + D + . ; Look first for a value to use with the NEW PERSON file + . ; + . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q + . ; + . I $L(NM) S NAME=NM Q + . ; + . ; Else, pull the data from the message and display the foreign source + . ; of the message. + . N T + . S VAL=$G(^XMB(3.9,D0,.7)) + . S:VAL T=$P(^VA(200,VAL,0),U) + . I $L($G(T)) S NAME=T Q + . ; + .QUIT + QUIT NAME + ; =================== +TIME(Y) ; The time and date of the sending + X ^DD("DD") + QUIT Y + ; =================== + ; Segments in Message need to be identified and decoded properly + ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message + ; ARRAY will have the details of this one call + ; + ; Inputs; + ; C0CINPUT - The IEN of the message to expand + ; Outputs; + ; C0CDATA - Carrier for the returned structure of the Message + ; C0CDATA(D0,"SEG")=number of SEGMENTS + ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details + ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details + ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details + ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details + ; +DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery + N LST,D0,D1,U + S U="^" + S D0=+$G(C0CINPUT) + I D0 D QUIT + . D GETTYP2(D0) + . I $D(LST) M C0CDATA(D0)=LST + .QUIT + QUIT + ; =================== + ; End note if needed + ; MSK - Set of characters that do not exist in 64 bit encoding +GETTYP2(D0) ; Try to get the types and MSK for the + N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM + S CON="Content-",U="^" + S FLG="--" + S MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" + S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + ; S K=$P(^XMB(3.9,D0,2,0),U,3) + S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST("CREATED")=$$TIME($P(XX,U,3)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST("FROM")=$$NAME(XXNM) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" + . N I,T + . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) + . S:T T=$P($G(^VA(200,T,0)),"^") + . S LST("TO",+D1)=T + . S T=$G(^XMB(3.9,D0,6,+D1,0)) + . S:T="" T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . S LST("TO NAME",D1)=T + .QUIT + ; Get the Header for the message + S D1=0 + F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D + . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) + .QUIT + ; Start walking the different sections + S D1=.99999,SEP="--" + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; Enter once to set the SEP to capture the separator + . I (SEP="--")&($E(X,1,2)=FLG)&($L(X,FLG)=2) D Q + . . S SEP=X,END=X_FLG + . . S (CNT,SGC)=1,BCN=0 + . . S LST("SEG",SGC)=D1 + . .QUIT + . ; + . ; A new SEGMENT separator is set, process original + . I X=SEP D QUIT + . . ; Save Current Values + . . S LST("SEG",SGC,"SIZE")=BCN + . . ; Close this Segment and prepare to start a New Segment + . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) + . . ; Put the result in LST("SEG",SGC,"XML") + . . I $L(BF) D + . . . S ZN=1 + . . . N I,T,TBF + . . . S TBF=BF + . . . F I=1:1:($L(TBF,"=")) D + . . . . S BF=$P(TBF,"=",I)_"=" + . . . . I BF'="=" D DECODER + . . . .QUIT + . . . S BF="" + . . .QUIT + . . S SGC=SGC+1,BCN=0 + . . ; Incriment SGC to start a new Segment + . . S LST("SEG",SGC)=D1 + . .QUIT + . ; + . ; Accumulate the 64 bit encoding + . I X=$TR(X,MSK)&$L(X) D Q + . . S BF=BF_X + . . S BCN=BCN+$L(X) + . .QUIT + . ; + . ; Ending Condition, close out the Segment + . I X=END D QUIT + . . S LST("SEG",SGC)=$G(LST("SEG",SGC))_"^"_(D1-1) + . . I $L(BF) S ZN=1 D DECODER S BF="" Q + . .QUIT + . ; + . S BCN=BCN+$L(X) + . ; Split out the Content Info + . I X[CON D Q + . . S J=$P(X,CON,2) + . . S LST("SEG",SGC,"CONTENT",$P(J,":"))=$P(J,":",2,9) + . .QUIT + . ; + . ; Everything else is Text + . S LST("SEG",SGC,"TXT",D1)=X + .QUIT + QUIT + ; =================== + ; Break down the Buffer Array so it can be saved. + ; BF is passed in. +DECODER ; + N RCNT,TBF,ZBF,ZI,ZJ,ZK,ZSIZE + S ZBF=BF + ; Full Buffer, BF, now check for Encryption and Unpack + F RCNT=1:1:$L(ZBF,"=") D + . N BF + . S BF=$P(ZBF,"=",RCNT) + . ; Unpacking the 64 bit encoding + . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) + . D:$L(TBF) + . . N XBF + . . S BF=BF_"=" + . . D NORMAL(.XBF,.TBF) + . . M LST("SEG",SGC,"XML",RCNT)=XBF + . .QUIT + .QUIT + QUIT + ; =================== + ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT + ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT + ; >D NORMAL^C0CMAIL(.OUT,BF) +NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML + ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME + ; + N ZN,OUTBF + S ZN=1 + S OUTBF(ZN)=$P(INXML,"><",ZN)_">" + F ZN=ZN+1:1 S OUTBF(ZN)="<"_$P(INXML,"><",ZN) Q:$P(INXML,"><",ZN+1)="" D ; + . S OUTBF(ZN)=OUTBF(ZN)_">" + .QUIT + M OUTXML=OUTBF + QUIT + ; =================== + ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv + ; End note if needed + QUIT + ; =================== \ No newline at end of file diff --git a/p/C0CMAIL3.m b/p/C0CMAIL3.m new file mode 100644 index 0000000..7e627b5 --- /dev/null +++ b/p/C0CMAIL3.m @@ -0,0 +1,534 @@ +C0CMAIL ; Communications for MIME Documents and MultiMIME ; 3110420 ; rcr/rcr +V ;;0.1;C0C;nopatch;noreleasedate + ;Copyright 2011 Chris Richardson, Richardson Computer Research + ; Modified 3110619@2038 + ; rcr@rcresearch.us + ; 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. + ; + ; ------------------ + ;Entry Points + ; DETAIL^C0CMAIL(.C0CDATA,IEN) --> Get details of the Mail Message and Attachments + ; GETMSG^C0CMAIL(.C0CDATA,.C0CINPUT) + ; Input: + ; C0CINPUT = "DUZ;MAILBOX_Name[or IEN for box (comma Separated);MALL + ; or "*" for all boxes, default is "IN" if missing]" + ; $P(C0CINPUT,";",3)=MALL, default=NUL means "New only", + ; "*" for All or 9,999 maximum + ; MALL?1.n = that number of the n most recent + ; Internally: + ; BNAM = Box Name + ; Output: + ; C0CDATA + ; = (BNAM,"NUMBER") = Number of NEW Emails in Basket + ; (BNAM,"MSG",C0CIEN,"FROM")=Name + ; (BNAM,"MSG",C0CIEN,"TO",n)=DUZ, or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TO NAME",n)=Names or EMAIL Address + ; (BNAM,"MSG",C0CIEN,"TITLE")=EMAIL Title + ; (BNAM,"MSG",C0CIEN[for File 3.9])=Number of Attachments + ; (BNAM,"MSG",C0CIEN,num,"CONT") = Free Text + ; (BNAM,"MSG",C0CIEN,num,"LINES") = Number of Lines of Text + ; (BNAM,"MSG",C0CIEN,num,"SIZE") = Size of the Message in Bytes + ; (BNAM,"MSG",C0CIEN,num,"TXT",LINE#) = Message Data (No Attachment) + ; (BNAM,"MSG",C0CIEN,"SEG",NUM) = First Line^Last Line + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,"CONT",type) = Message Details + ; (BNAM,"MSG",C0CIEN,"SEG",NUM,LINE#) = Message Data + ; + ; DO DETAIL^C0CMAIL(.OUTBF,D0) ; For each Email Message and Attachments + ; Input; + ; D0 - The IEN for the message in file 3.9, MESSAGE global + ; Output + ; OUTBF - The array of your choice to save the expanded and decoded message. + ; +GETMSG(C0CDATA,C0CINPUT) ; Common Entry Point for Mailbox Data + K:'$G(C0CDATA("KEEP")) C0CDATA + N U + S U="^" + D:$G(C0CINPUT) + . N BF,DUZ,I,INPUT,J,L,LST,MBLST,MALL + . S INPUT=C0CINPUT + . S DUZ=+INPUT + . I $D(^VA(200,DUZ))=0!('$D(^VA(200,DUZ,0))) D ERROR("ER06") Q + . ; + . D:$D(^XMB(3.7,DUZ,0))#2 + . . S MBLST=$P(INPUT,";",2) + . . S MALL=$P(INPUT,";",3) ; New or All Mail Flag + . . S:MALL["*" MALL=99999 + . . ; Only one of these can be correct + . . D + . . . ; If nul, make it "IN" only + . . . I MBLST="" D QUIT + . . . . S MBLST("IN")=0,I=0 + . . . . D GATHER(DUZ,"IN",.LST) + . . . .QUIT + . . . ; + . . . ; If "*", Get all Mailboxes and look for New Messages + . . . I MBLST["*" D QUIT + . . . . N NAM,NUM + . . . . S NUM=0 + . . . . F S NUM=$O(^XMB(3.7,DUZ,2,NUM)) Q:'NUM D + . . . . . S NAM=$P(^XMB(3.7,DUZ,2,NUM,0),U) + . . . . . D GATHER(DUZ,NAM,.LST) + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If comma separated, look for mailboxes with new messages + . . . I $L(MBLST,",")>1 D QUIT + . . . . S NAM="" + . . . . N TN,V + . . . . F TN=1:1:$L(MBLST,",") S V=$P(MBLST,",",TN) D + . . . . . I $L(V) D QUIT + . . . . . . I V S NAM=$P($G(^XMB(3.7,DUZ,2,V,0)),U) + . . . . . . S:NAM="" NAM=V + . . . . . . D GATHER(DUZ,NAM,.LST) + . . . . . .QUIT + . . . . . ; + . . . . . D ERROR("ER08") + . . . . .QUIT + . . . .QUIT + . . . ; + . . . ; If only 1 mailbox named, go get it + . . . I $L(MBLST) D QUIT + . . . . I $D(^XMB(3.7,DUZ,2,"B",MBLST)) D GATHER(DUZ,MBLST,.LST) QUIT + . . . . ; + . . . . D ERROR("ER07") + . . .QUIT + . . MERGE C0CDATA=LST + . .QUIT + .QUIT + QUIT + ; =================== +GATHER(DUZ,NAM,LST) ; Gather Data about the Baskets and their mail + N I,J,K,L + S (I,K)=0 + S J=$O(^XMB(3.7,DUZ,2,"B",NAM,"")) + F S I=$O(^XMB(3.7,DUZ,2,J,1,I)) Q:'I D + . S L=$P(^XMB(3.7,DUZ,2,J,1,I,0),U,3) + . D ; :L + . . S:L K=K+1,LST(NAM,"MSG",I,"NEW")="" ; Flag NEW emails + . . S LST(NAM,"MSG",I)=L + . . D GETTYP(I) + . .QUIT + .QUIT + S LST(NAM,"NUMBER")=K + QUIT + ; =================== + ; D0 is the IEN into the Message Global ^XMB(3.9,D0) + ; The products of these emails are scanned to identify + ; the number of documents stored in the MIME package. + ; The protocol runs like this; + ; Line 1 is the --separator + ; Line 2 thru n >Look for Content-[detail type:]Description ; Next CMD + ; Line n+2 thru t-1 where t does NOT have "Content-" + ; Line t is Next Section Terminator, or Message Terminator, --separator + ; Line t+1 should not exist in the data set if Message Terminator + ; CON = "Content-" + ; FLG = "--" + ; SEP = FLG+7 or more characters ; Separator + ; END = SEP+FLG + ; SGC = Segment Count + ; Note: separator is a string of specific characters of + ; indeterminate length + ; LST() the transfer array + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN)=Starting Line^Ending Line + ; LST(NAM,"MSG",C0CIEN,"SEG",SGN,1:n)=Decoded Message Data + ; +GETTYP(D0) ; Look for the goodies in the Mail + N I,J,N,BCN,CON,CNT,D1,END,FLG,SEP,SGC,XX,XXNM + S CON="Content-" + S FLG="--" + S SEP="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + S LST(NAM,"MSG",D0,"TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST(NAM,"MSG",D0,"CREATED")=$G(^XMB(3.9,D0,.6)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST(NAM,"MSG",D0,"FROM")=$$NAME(XXNM) + S LST(NAM,"MSG",D0,"SENT")=$$TIME($P(XX,U,3)) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D + . N T + . S T=+$G(^XMB(3.9,D0,1,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S LST("TO",D1)=T + . S T=$G(^XMB(3.9,D0,6,D1,0)) + . S:T T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . S LST("TO NAME",D1)=T + .QUIT + ; Preload first Segment (0) with beginning on Line 1 + ; if not a 64bit + S LST(NAM,"MSG",D0,"SEG",0)=1 + S D1=.9999,SEP="@@" + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; Enter once to set the SEP to capture the separator + . I SEP=FLG&($E(X,1,2)=FLG)&($L(X,FLG)=2)&($L($P(X,FLG,2)>5)) D Q + . . S SEP=X,END=X_FLG + . . S (CNT,SGC)=1,BCN=0 + . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 + . .QUIT + . ; + . ; A new separator is set, process original + . I X=SEP D QUIT + . . S LST(NAM,"MSG",D0,SGC,"SIZE")=BCN+$L(BF) + . . S LST(NAM,"MSG",D0,"SEG",SGC)=$G(LST(NAM,"MSG",D0,"SEG",SGC))_"^"_(D1-1) + . . S SGC=SGC+1,BCN=0 + . . S LST(NAM,"MSG",D0,"SEG",SGC)=D1 + . .QUIT + . ; + . S BCN=BCN+$L(X) + . I X[CON D Q + . . S J=$P($P(X,";"),CON,2) + . . S LST(NAM,"MSG",D0,"SEG",SGC,"CONT",CNT,$P(J,":"))=$P(J,":",2) + . .QUIT + . ; + . ; S LST(NAM,"MSG",D0,"SEG",D1)=X + .QUIT + QUIT + ; =================== +NAME(NM) ; Return the name of the Sender + N NAME + S NAME="" + D + . ; Look first for a value to use with the NEW PERSON file + . ; + . I NM=+NM S NAME=$P(^VA(200,NM,0),U,1) Q + . ; + . I $L(NM) S NAME=NM Q + . ; + . ; Else, pull the data from the message and display the foreign source + . ; of the message. + . N T + . S VAL=$G(^XMB(3.9,D0,.7)) + . S:VAL T=$P(^VA(200,VAL,0),U) + . I $L($G(T)) S NAME=T Q + . ; + .QUIT + QUIT NAME + ; =================== +TIME(Y) ; The time and date of the sending + X ^DD("DD") + QUIT Y + ; =================== + ; Segments in Message need to be identified and decoded properly + ; D DETAIL^C0CMAIL(.ARRAY,D0) ; Call One for each message + ; ARRAY will have the details of this one call + ; + ; Inputs; + ; C0CINPUT - The IEN of the message to expand + ; Outputs; + ; C0CDATA - Carrier for the returned structure of the Message + ; C0CDATA(D0,"SEG")=number of SEGMENTS + ; C0CDATA(D0,"SEG",0:n)=SEGMENT n details; First;Last;Type + ; C0CDATA(D0,"SEG",0:n,"CONTENT",type)=Content details + ; C0CDATA(D0,"SEG",0:n,"MSG",D3)=Content details + ; C0CDATA(D0,"SEG",0:n,"HTML",D3)=Content details + ; +DETAIL(C0CDATA,C0CINPUT) ; Message Detail Delivery + N LST,D0,D1,U + S U="^" + S D0=+$G(C0CINPUT) + I D0 D QUIT + . I $D(^XMB(3.9,D0))<10 D ERROR("ER01") QUIT + . ; + . D GETTYP2(D0) + . I $D(LST) M C0CDATA(D0)=LST Q + . ; + . D ERROR("ER02") + .QUIT + QUIT + ; =================== + ; End note if needed + ; MSK - Set of characters that do not exist in 64 bit encoding +GETTYP2(D0) ; Try to get the types and MSK for the + N I,J,K,N,BCN,BF,CON,CNT,D1,END,FLG,MSK,SEP,SGC,U,XX,ZN,XXNM + S CON="Content-",U="^" + S FLG="--",MSK=" !""#$%&'()*,-.:;<>?@[\]^_`{|}~" + S (BF,SEP)="" ; Start SEP as null, so we can use this to help identify the type + S (BCN,CNT,D1,END,SGC)=0 + S XX=$G(^XMB(3.9,D0,0)) + ; S K=$P(^XMB(3.9,D0,2,0),U,3) + S LST("TITLE")=$P($G(^XMB(3.9,D0,0)),U,1) + S LST("CREATED")=$$TIME($P(XX,U,3)) + F I=4,2 S XXNM=$P(XX,U,I) Q:$L(XXNM) + S LST("FROM")=$$NAME(XXNM) + ; Get the folks the email is sent to. + S D1=0 + F S D1=$O(^XMB(3.9,D0,1,D1)) Q:'D1 D Q:D1="" + . N I,T + . S T=$P($G(^XMB(3.9,D0,1,D1,0)),U) + . S:T T=$P($G(^VA(200,T,0)),"^") + . S LST("TO",+D1)=T + . S T=$G(^XMB(3.9,D0,6,+D1,0)) + . S:T="" T=$P($G(^VA(200,+T,0)),"^") + . S:T="" T="" + . S LST("TO NAME",D1)=T + .QUIT + ; Get the Header for the message and store as "HDR" + S D1=0,SGC=0 + F I=1:1 S D1=$O(^XMB(3.9,D0,2,D1)) Q:D1="" Q:(D1>.99999) D + . S LST("HDR",I)=$G(^XMB(3.9,D0,2,D1,0)) + .QUIT + N BNDRY,STKL,SEG + S STKL=0,SEG=0 + ; Find boundaries and map them + S D1=0 + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; Look for " boundary=" in the various parts. Map the establishment and the + . ; terminator markers and the actual boundary markers. + . I X[" boundary=" D Q + . . S SEP=$P(X," boundary=",2) + . . S:$E(SEP)="""" SEP=$TR(SEP,"""") + . . S STKL=STKL+1 + . . S END=SEP_FLG + . . S BNDRY(STKL,SEP)=0 + . . S BNDRX(SEP)=STKL,BNDRZ(END)=0 + . .QUIT + . ; + . ; Look for information as to how amy boudaries are present and where + . ; they terminate + . D:X'=""&($E(X,1,2)="--")&($E(X,$L(X)-1,9999)'="--") + . . ; Boundary Found + . . I $D(BNDRX(X)) D Q + . . . S SEG=SEG+1 + . . . S BNDRE(X)=$G(BNDRE(X))_D1_";" + . . . S BND1(D1)=STKL_";B;"_SEG_";"_X + . . . S BNDR(X,D1,"B")=STKL + . . . I BNDRX(X)=X D ERROR("ER13") + . . .QUIT + . . ; + . . ; Boundary Terminator + . . I $D(BNDRZ(X)) D Q + . . . S BNDR(X,D1,"E")=STKL + . . . S BNDRZ(X)=BNDRZ(X)+1 + . . . S BND1(D1)=STKL_";E;"_SEG_";"_X + . . . S SEG=SEG+1 + . . . I BNDRX(X)=X D ERROR("ER14") + . . . S STKL=STKL-1 + . . .QUIT + . .QUIT + .QUIT + ; Start walking the TEXT/XML/64-BIT ENCODING sections of the message + N A,B,C,STACK,STYP,SEG,AX + S D1=.99999,SGC=0 + F S D1=$O(^XMB(3.9,D0,2,D1)) Q:'D1 D + . ; Clear any control characters (cr/lf/ff) off + . S X=$TR($G(^XMB(3.9,D0,2,D1,0)),$C(10,12,13)) + . ; + . D + . . I $D(BND1(D1)) D BOUNDARY(X) QUIT + . . ; + . . S DX=$O(BND1(D1)) + . . I DX="" D ERROR("ER15") Q + . . ; + . . ; Good situation, extract the parts for the section + . . S A=$G(BND1(DX)) + . . S STACK=+A,STYP=$P(A,";",2),SGC=$P(A,";",3),AX=$P(A,";",4,999) + . .QUIT + . ; Enter once to set the SEP to capture the separator + . ; + . ; A new SEGMENT separator is set, process original + . I $D(BND1(X)) D QUIT + . . ; Save Current Values + . . S LST("SEG",SGC,"SIZE")=BCN+$L(BF) + . . ; Close this Segment and prepare to start a New Segment + . . S $P(LST("SEG",SGC),"^",1,2)=$P($G(LST("SEG",SGC)),"^",1)_"^"_(D1-1) + . . ; Put the result in LST("SEG",SGC,"XML") + . . I $L(BF) D + . . . S ZN=1 + . . . N I,T,TBF + . . . S TBF=BF + . . . F I=1:1:($L(TBF,"=")) D + . . . . S BF=$P(TBF,"=",I)_"=" + . . . . I "="'[BF D DECODER(.BF,.TYP) + . . . .QUIT + . . . S BF="" + . . .QUIT + . . S SGC=SGC+1,BCN=0 + . . ; Incriment SGC to start a new Segment + . . S LST("SEG",SGC)=D1 + . .QUIT + . ; + . ; Accumulate the 64 bit encoding, no spaces, or other non-64bit characters + . I X=$TR(X,MSK)&$L(X) S BF=BF_X QUIT + . ; + . ; Ending Condition, close out the Segment + . I $D(BNDRZ(X)) D QUIT + . . S $P(LST("SEG",SGC),"^",2)=D1-1 + . . I $L(BF) S ZN=1 D DECODER(.BF,.TYP) S BF="" Q + . .QUIT + . ; + . ; Accumulate the content lines of the message + . S BCN=BCN+$L(X) + . ; Split out the Content Info + . I X[CON D Q + . . S J=$P(X,CON,2) + . . S TYP="CONTENT" + . . S LST("SEG",SGC,TYP,$P(J,":"))=$P(J,":",2,9) + . . D CONTENT(D1) + . .QUIT + . ; + . ; Everything else is Text, Check for CCR/CCD. + . N KK,UBF + . D + . . S UBF=$$UPPER(X) + . . I UBF["1) S TYP=$P(UP,".",2) Q + . I UP["XML" S TYP="XML" Q + . I UP["P7S" S TYP="P7S" Q + . I J[" boundary=" D BOUNDARY(J) + .QUIT + S LIS("CON",SGC,D1)=X + S LIS("CON",SGC,D1,"TYP")=TYP + ; If there is a follow-on, look for another line after this. + I $E($RE(X),1)=";" D CONTENT(D1+1) + QUIT + ; =================== +BOUNDARY(X) ; Set an additional BOUNDARY, and activate another stack level + S SEP=$P($P(X," boundary=",2),"""",2),END=SEP_FLG + Q:SEP?2"-".ANP + ; + D ERROR("ER11") + Q:SEP'[" " + ; + D ERROR("ER12") + QUIT + ; =================== + ; Break down the Buffer Array so it can be saved. + ; BF is passed in. + ; TYP is the type of +DECODER(BF,TYP) ; + N RCNT,TBF,UBF,ZBF,ZI,ZJ,ZK,ZSIZE + S:$G(TYP)="" TYP="XML" + S ZBF=BF + ; Full Buffer, BF, now check for Encryption and Unpack + F RCNT=1:1:$L(ZBF,"=") D + . N BF + . S BF=$P(ZBF,"=",RCNT) + . ; Unpacking the 64 bit encoding + . S TBF=$TR($$DECODE^RGUTUU(BF),$C(10,12,13)) + . D:$L(TBF) + . . N C,OK,OKCNT,KK,XBF,UBF + . . D + . . . S UBF=$$UPPER(TBF) + . . . I UBF["126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q + . . ; + . . D + . . . I 'OK S (BF,UBF,TBF,XBF)="" Q + . . . ; + . . . S BF=BF_"=" + . . . D NORMAL(.XBF,.TBF) + . . .QUIT + . . M LST("SEG",SGC,TYP,RCNT)=XBF + . .QUIT + .QUIT + QUIT + ; =================== + ; OUTXML = OUTBF = OUT = OUTPUT ARRAY TO BE BUILT + ; BF = INXML = INPUT ARRAY TO PROVIDE INPUT + ; >D NORMAL^C0CMAIL(.OUT,BF) +NORMAL(OUTXML,INXML) ;NORMALIZES AN XML STRING PASSED BY NAME IN INXML + ; INTO AN XML ARRAY RETURNED IN OUTXML, ALSO PASSED BY NAME + ; + N ZN,OUTBF,XX,ZSEP + S INXML=$TR(INXML,$C(10,12,13)) + S ZN=1,ZSEP=">" + S OUTBF(1)=$P(INXML,"><",1)_ZSEP,XX="<"_$P(INXML,"><",2)_ZSEP,ZN=2,ZL=1 + F ZN=ZN+1:1:$L(INXML,"><") D Q:XX="" + . S XX=$P(INXML,"><",ZN) + . S:$E($RE(XX))=">" ZSEP="" + . Q:XX="" + . ; + . S XX="<"_XX_ZSEP + . D + . . I $L(XX)<4000 S OUTBF(ZL)=XX,XX=$P(INXML,"><",ZN),ZL=ZL+1 Q + . . ; + . . D ERROR("ER05") + . . F ZL=ZL+1:1 D Q:XX="" + . . . N XL + . . . S XL=$E(XX,1,4000) + . . . S $E(XX,1,4000)="" ; S XX=$E(XX,4001,999999) ; Remove 4K characters + . . . S OUTBF(ZL)=XL + . . .QUIT + . .QUIT + .QUIT + M OUTXML=OUTBF + QUIT + ; =================== +UPPER(X) ; Convert any lowercase letters to Uppercase letters + QUIT $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") + ; =================== + ; EN is a counter that remains between error events +ERROR(ER) ; Error Handler + N TXXQ,XXXQ + S XXXQ="Unknown Error Encountered = "_ER + S TXXQ=$P($T(@(ER_"^"_$T(+0))),";;",2,99) + I TXXQ'="" D + . I TXXQ["_" X "S TXXQ="_TXXQ + . S XXXQ=TXXQ + .QUIT + S EN(ER)=$G(EN(ER))+1 + S LST("ERR",ER,EN(ER))=XXXQ + QUIT + ; =================== +ER01 ;;Message Missing +ER02 ;;Message Text Missing +ER03 ;;Message Not Identifiable +ER04 ;;Segment is too large +ER05 ;;Mailbox Missing +ER06 ;;"User Missing = "_$G(DUZ) +ER07 ;;"Bad DUZ = "_DUZ +ER08 ;;"Bad Basket ID = "_MBLST_" >> "_$G(TN) +ER10 ;;"Bad Separator found = "_X +ER11 ;;"Non-Standard Separator Found:>"_$G(J) +ER12 ;;"Spaces are not allowed in Separators:>"_$G(J) +ER13 ;;"Bad Stack Level Detected >"_STKL_":"_BNDRY(X)_":"_X + ; vvvvvvvvvvvvvvv Not Needed vvvvvvvvvvvvvvvvvvvvvvvvvv + ; End note if needed + QUIT + ; =================== \ No newline at end of file diff --git a/p/C0CMED3.m b/p/C0CMED3.m index 1853875..ae1c5d5 100644 --- a/p/C0CMED3.m +++ b/p/C0CMED3.m @@ -70,7 +70,7 @@ EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml temp . S @MAP@("MEDRXNO")="" . S @MAP@("MEDTYPETEXT")="Medication" . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses - . S @MAP@("MEDSTATUSTEXT")="ACTIVE" ; nearest status for pending meds + . S @MAP@("MEDSTATUSTEXT")="Active" ; nearest status for pending meds . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_MED(12,"I") . S @MAP@("MEDPRODUCTNAMETEXT")=MED(.01,"E") . ; NDC is field 31 in the drug file. @@ -113,7 +113,25 @@ EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml temp . . ; new on the market, compounded, or is a fake drug [blue pill]. . . ; To protect against failure, I will put an if/else block . . N VUID,RXNIEN,RXNORM,SRCIEN,RXNNAME,RXNVER - . . I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. + . . ; + . . ; begin changes for systems that have eRx installed + . . ; RxNorm is found in the ^C0P("RXN") global - gpl + . . ; + . . N ZC,ZCD,ZCDS,ZCDSV ; CODE,CODE SYSTEM,CODE VERSION + . . S (ZC,ZCD,ZCDS,ZCDSV)="" ; INITIALIZE + . . S (RXNORM,RXNNAME,RXNVER)="" ;INITIALIZE + . . I NDFIEN,$D(^C0P("RXN")) D ; + . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) + . . . S ZC=$$CODE^C0CUTIL(VUID) + . . . S ZCD=$P(ZC,"^",1) ; CODE TO USE + . . . S ZCDS=$P(ZC,"^",2) ; CODING SYSTEM - RXNORM OR VUID + . . . S ZCDSV=$P(ZC,"^",3) ; CODING SYSTEM VERSION + . . . S RXNORM=ZCD ; THE CODE + . . . S RXNNAME=ZCDS ; THE CODING SYSTEM + . . . S RXNVER=ZCDSV ; THE CODING SYSTEM VERSION + . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT") + . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_ZCDS_": "_ZCD + . . E I NDFIEN,$D(^C0CRXN) D ; $Data is for Systems that don't have our RxNorm file yet. . . . S VUID=$$GET1^DIQ(50.68,VAPROD,99.99) . . . S RXNIEN=$$FIND1^DIC(176.001,,,VUID,"VUID") . . . S RXNORM=$$GET1^DIQ(176.001,RXNIEN,.01) @@ -121,7 +139,7 @@ EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml temp . . . S RXNNAME=$$GET1^DIQ(176.003,SRCIEN,6) . . . S RXNVER=$$GET1^DIQ(176.003,SRCIEN,7) . . ; - . . E S (RXNORM,RXNNAME,RXNVER)="" + . . ;E S (RXNORM,RXNNAME,RXNVER)="" . . ; End if/else block . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME @@ -160,6 +178,7 @@ EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml temp . . . N QTYDATA M QTYDATA=^TMP($J,"QTY",MEDIEN) . . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5) . . E S @MAP@("MEDQUANTITYUNIT")="" + . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these . E D . . S @MAP@("MEDPRODUCTNAMECODEVALUE")="" . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")="" @@ -180,7 +199,35 @@ EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml temp . ; For that reason, I will use the field I never used before: . ; MEDDIRECTIONDESCRIPTIONTEXT . S DIRCNT=1 ; THERE IS ONLY ONE DIRECTION FOR OUTSIDE MEDS - . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") + . ; + . ; change for eRx meds - gpl 6/25/2011 + . ; + . N ZERX S ZERX=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") + . I ZERX["|" S ZERX=$P(ZERX,"|",2) ; GET RID OF MED NAME + . S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=ZERX + . N ZERX2 S ZERX2=$P(MED(2,"E"),"|",2) ; sig for quantity + . N ZFDBDRUG S ZFDBDRUG=$P(MED(2,"E"),"|",1) ; FDB DRUG NAME + . I @MAP@("MEDPRODUCTNAMETEXT")["FREE TXT" D ; FIX THE DRUG NAME + . . S @MAP@("MEDPRODUCTNAMETEXT")=ZFDBDRUG ; USE FDB NAME + . . S RXNORM=$P($P($G(MED(14,7)),"RXNORM:",2)," ",1) ; THE RXNORM + . . S RXNORM=$$NISTMAP^C0CUTIL(RXNORM) ; CHANGE IF NECESSARY + . . I RXNORM'="" D ; + . . . W !,"FOUND FREE TEXT RXNORM:",RXNORM + . . . S RXNNAME="RXNORM" ; THE CODING SYSTEM + . . . S RXNVER="" ; THE CODING SYSTEM VERSION + . . . N ZGMED S ZGMED=@MAP@("MEDPRODUCTNAMETEXT") + . . . S @MAP@("MEDPRODUCTNAMETEXT")=ZGMED_" "_RXNNAME_": "_RXNORM + . . . S @MAP@("MEDPRODUCTNAMECODEVALUE")=RXNORM + . . . S @MAP@("MEDPRODUCTNAMECODINGINGSYSTEM")=RXNNAME + . . . S @MAP@("MEDPRODUCTNAMECODEVERSION")=RXNVER + . . . I RXNORM["979334" D ; PATCH FOR CERTIFICATION + . . . . S @MAP@("MEDSTRENGTHVALUE")=650 + . . . . S @MAP@("MEDSTRENGTHUNIT")="mcg" + . . . . S @MAP@("MEDFORMTEXT")="INHALER" + . S @MAP@("MEDQUANTITYUNIT")=$P(ZERX2," ",3) ; THE UNITS + . S @MAP@("MEDQUANTITYVALUE")=$P(ZERX2," ",2) ; THE QUANTITY + . I @MAP@("MEDFORMTEXT")="" S @MAP@("MEDFORMTEXT")=$P(ZERX2," ",3) ; + . ;S @MAP@("M","DIRECTIONS",1,"MEDDIRECTIONDESCRIPTIONTEXT")=MED(2,"E")_" "_MED(3,"E")_" "_MED(4,"E") . S @MAP@("M","DIRECTIONS",1,"MEDDOSEINDICATOR")="4" ; means look in description text. See E2369-05. . S @MAP@("M","DIRECTIONS",1,"MEDDELIVERYMETHOD")="" . S @MAP@("M","DIRECTIONS",1,"MEDDOSEVALUE")="" @@ -212,6 +259,7 @@ EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; Extract medications into provided xml temp . I $D(MED(14,1)) D ; . . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")=MED(14,1) ; WP Field . E S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" + . S @MAP@("MEDFULLFILLMENTINSTRUCTIONS")="" ; don't put in these - gpl . N RESULT S RESULT=$NA(^TMP("C0CCCR",$J,"MAPPED")) . K @RESULT . D MAP^C0CXPATH(MINXML,MAP,RESULT) diff --git a/p/C0CNMED2.m b/p/C0CNMED2.m new file mode 100644 index 0000000..fcb5542 --- /dev/null +++ b/p/C0CNMED2.m @@ -0,0 +1,121 @@ +C0CMED ; WV/CCDCCR/GPL/SMH - CCR/CCD Medications Driver; Mar 23 2009 + ;;1.0;C0C;;May 19, 2009;Build 38 + ; Copyright 2008,2009 George Lilly, University of Minnesota and 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. + ; + ; --Revision History + ; July 2008 - Initial Version/GPL + ; July 2008 - March 2009 various revisions + ; March 2009 - Reconstruction of routine as driver for other med routines/SMH + ; June 2011 - Redone to support all meds using the FOIA NHIN routines/gpl + ; + Q + ; + ; THIS VERSION IS DEPRECATED BECAUSE IT DOES NOT GENEREATE XML IN + ; THE RIGHT ORDER... AND IT HAS TO BE IN THE RIGHT ORDER... :( + ; GPL + ; +EXTRACT(MEDXML,DFN,MEDOUTXML) ; Private; Extract medications into provided XML template + ; DFN passed by reference + ; MEDXML and MEDOUTXML are passed by Name + ; MEDXML is the input template + ; MEDOUTXML is the output template + ; Both of them refer to ^TMP globals where the XML documents are stored + ; + N GN + D EN^C0CNHIN(.GN,DFN,"MED;",1) ; RETRIEVE NHIN ARRAY OF MEDS + ; this call uses GET^NHINV to retrieve xml of the meds and then + ; parses with MXML and uses DOMO^C0CDOM to extract an NHIN array + ; + ; we now create an NHIN Array of the Meds section of the CCR + ; + N ZI S ZI="" + F S ZI=$O(GN("med",ZI)) Q:ZI="" D ; for each med + . N GA S GA=$NA(GN("med",ZI)) + . N GM S GM="Medication" ; to keep the lines shorter + . S GC(GM,ZI,"CCRDataObjectID")="MED_"_ZI + . N ZD,ZD2 S ZD=$G(@GA@("ordered@value")) ; FILEMAN DATE + . I ZD="" S ZD=$G(@GA@("start@value")) ; for inpatient meds + . S ZD2=$$FMDTOUTC^C0CUTIL(ZD,"DT") + . S GC(GM,ZI,"DateTime[1].ExactDateTime")=ZD2 + . S GC(GM,ZI,"DateTime[1].Type.Text")="Documented Date" + . ;S GC(GM,ZI,"DateTime[2].ExactDateTime")="" + . ;S GC(GM,ZI,"DateTime[2].Type.Text")="" + . N GSIG S GSIG=$G(@GA@("sig")) + . I GSIG["|" S GSIG=$P(GSIG,"|",2) ; eRx has name of drug separated by | + . S GC(GM,ZI,"Description.Text")=GSIG + . N GD S GD="Directions.Direction" ; MAKING THE STRINGS SHORTER + . ;S GC(GM,ZI,GD_".DeliveryMethod.Text")="@@MEDDELIVERYMETHOD@@" + . ;S GC(GM,ZI,GD_".Description.Text")="" + . ;S GC(GM,ZI,GD_".DirectionSequenceModifier")="@@MEDDIRSEQ@@" + . ;S GC(GM,ZI,GD_".Dose.Rate.Units.Unit")="@@MEDRATEUNIT@@" + . ;S GC(GM,ZI,GD_".Dose.Rate.Value")="@@MEDRATEVALUE@@" + . ;S GC(GM,ZI,GD_".Dose.Units.Unit")="@@MEDDOSEUNIT@@" + . ;S GC(GM,ZI,GD_".Dose.Value")="@@MEDDOSEVALUE@@" + . ;S GC(GM,ZI,GD_".DoseIndicator.Text")="@@MEDDOSEINDICATOR@@" + . ;S GC(GM,ZI,GD_".Duration.Units.Unit")="@@MEDDURATIONUNIT@@" + . ;S GC(GM,ZI,GD_".Duration.Value")="@@MEDDURATIONVALUE@@" + . ;S GC(GM,ZI,GD_".Frequency.Value")="@@MEDFREQUENCYVALUE@@" + . ;S GC(GM,ZI,GD_".Indication.PRNFlag.Text")="@@MEDPRNFLAG@@" + . ;S GC(GM,ZI,GD_".Indication.Problem.CCRDataObjectID")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.CodingSystem")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Value")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Code.Version")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Description.Text")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Source.Actor.ActorID")="" + . ;S GC(GM,ZI,GD_".Indication.Problem.Type.Text")="" + . ;S GC(GM,ZI,GD_".Interval.Units.Unit")="@@MEDINTERVALUNIT@@" + . ;S GC(GM,ZI,GD_".Interval.Value")="@@MEDINTERVALVALUE@@" + . ;S GC(GM,ZI,GD_".MultipleDirectionModifier.Text")="@@MEDMULDIRMOD@@" + . S GC(GM,ZI,GD_".Route.Text")=$G(@GA@("doses.dose@route")) + . ;S GC(GM,ZI,GD_".StopIndicator.Text")="@@MEDSTOPINDICATOR@@" + . ;S GC(GM,ZI,GD_".Vehicle.Text")="@@MEDVEHICLETEXT@@" + . ;S GC(GM,ZI,"FullfillmentInstructions.Text")="" + . ;S GC(GM,ZI,"IDs.ID")="@@MEDRXNO@@" + . ;S GC(GM,ZI,"IDs.Type.Text")="@@MEDRXNOTXT@@" + . ;S GC(GM,ZI,"PatientInstructions.Instruction.Text")="@@MEDPTINSTRUCTIONS@@" + . ;S GC(GM,ZI,"Product.BrandName.Text")="@@MEDBRANDNAMETEXT@@" + . S GC(GM,ZI,"Product.Concentration.Units.Unit")=$G(@GA@("doses.dose@units")) + . S GC(GM,ZI,"Product.Concentration.Value")=$G(@GA@("doses.dose@dose")) + . S GC(GM,ZI,"Product.Form.Text")=$G(@GA@("form@value")) + . N GV S GV=$G(@GA@("products.product.vaProduct@vuid")) + . N GR S GR=$$RXNCUI3^C0PLKUP(GV) + . S GC(GM,ZI,"Product.ProductName.Code.CodingSystem")=$S(GR:"RxNorm",1:"VUID") + . S GC(GM,ZI,"Product.ProductName.Code.Value")=$S(GR:GR,1:GV) + . S GC(GM,ZI,"Product.ProductName.Code.Version")="08AB_081201F" + . S GC(GM,ZI,"Product.ProductName.Text")=$G(@GA@("name@value")) + . S GC(GM,ZI,"Product.Strength.Units.Unit")=$G(@GA@("doses.dose@units")) + . S GC(GM,ZI,"Product.Strength.Value")=$G(@GA@("doses.dose@dose")) + . ;S GC(GM,ZI,"Quantity.Units.Unit")="@@MEDQUANTITYUNIT@@" + . ;S GC(GM,ZI,"Quantity.Value")="@@MEDQUANTITYVALUE@@" + . ;S GC(GM,ZI,"Refills.Refill.Number")="@@MEDRFNO@@" + . N GDUZ S GDUZ=$G(@GA@("orderingProvider@code")) ;PROVIDER DUZ + . S GC(GM,ZI,"Source.Actor.ActorID")="PROVIDER_"_GDUZ + . S GC(GM,ZI,"Status.Text")=$G(@GA@("status@value")) + . S GC(GM,ZI,"Type.Text")="Medication" + N C0CDOCID + S C0CDOCID=$$DOMI^C0CDOM("GC",,"Medications") ; insert to dom + D OUTXML^C0CDOM(MEDOUTXML,C0CDOCID,1) ; render the xml + N ZSIZE S ZSIZE=$O(@MEDOUTXML@(""),-1) + S @MEDOUTXML@(0)=ZSIZE ; RETURN STATUS IS NUMBER OF LINES OF XML + W !,MEDOUTXML + ;ZWR GN + ;ZWR GC + ;B + Q + ; diff --git a/p/C0CNMED4.m b/p/C0CNMED4.m index 27bcbe4..61cf16a 100644 --- a/p/C0CNMED4.m +++ b/p/C0CNMED4.m @@ -82,7 +82,10 @@ EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMP . S @MAP@("MEDTYPETEXT")="Medication" . S @MAP@("MEDDETAILUNADORNED")="" ; Leave blank, field has its uses . ;S @MAP@("MEDSTATUSTEXT")="ACTIVE" - . S @MAP@("MEDSTATUSTEXT")=$G(MED("vaStatus@value")) ; need to filter status + . N C0CMST S C0CMST=$G(MED("vaStatus@value")) ; need to filter status + . I C0CMST="EXPIRED" S C0CMST="Prior History No Longer Active" + . I C0CMST="ACTIVE" S C0CMST="Active" ; + . S @MAP@("MEDSTATUSTEXT")=C0CMST . ;S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$P(MED(1),U) . S @MAP@("MEDSOURCEACTORID")="ACTORPROVIDER_"_$G(MED("orderingProvider@code")) . ;S @MAP@("MEDPRODUCTNAMETEXT")=MED("DDRUG",1,.01) @@ -111,9 +114,9 @@ EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMP . ;I $L(MEDIEN) D DOSE^PSS50(MEDIEN,,,,,"DOSE") . ;I $L(MEDIEN) N DOSEDATA M DOSEDATA=^TMP($J,"DOSE",MEDIEN) . ;S @MAP@("MEDSTRENGTHVALUE")=$S($L(MEDIEN):DOSEDATA(901),1:"") - . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("dose.dose@dose")) + . S @MAP@("MEDSTRENGTHVALUE")=$G(MED("doses.dose@dose")) . ;S @MAP@("MEDSTRENGTHUNIT")=$S($P(DOSEDATA(902),U,2),1:"") - . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("dose.dose@units")) + . S @MAP@("MEDSTRENGTHUNIT")=$G(MED("doses.dose@units")) . ; Units, concentration, etc, come from another call . ; $$CPRS^PSNAPIS which returns dosage-form^va class^strengh^unit . ; This call takes nodes 1 and 3 of ^PSDRUG(D0,"ND") as parameters @@ -134,11 +137,11 @@ EXTRACT(MINXML,DFN,OUTXML,MEDCOUNT) ; EXTRACT MEDICATIONS INTO PROVIDED XML TEMP . ;S @MAP@("MEDFORMTEXT")=$S($L(MEDIEN):$P(CONCDATA,U,1),1:"") . S @MAP@("MEDFORMTEXT")=$G(MED("form@value")) . ;S @MAP@("MEDCONCVALUE")=$S($L(MEDIEN):$P(CONCDATA,U,3),1:"") - . S @MAP@("MEDCONCVALUE")=$G(MED("dose.dose@dose")) + . S @MAP@("MEDCONCVALUE")=$G(MED("doses.dose@dose")) . ;S @MAP@("MEDCONCUNIT")=$S($L(MEDIEN):$P(CONCDATA,U,4),1:"") - . S @MAP@("MEDCONCUNIT")=$G(MED("dose.does@units")) + . S @MAP@("MEDCONCUNIT")=$G(MED("doses.does@units")) . ;S @MAP@("MEDQUANTITYVALUE")="" ; not provided for in Non-VA meds. - . S @MAP@("MEDQUANTITYVALUE")="" + . S @MAP@("MEDQUANTITYVALUE")=$G(MED("doses.dose@unitsPerDose")) ; . ; Oddly, there is no easy place to find the dispense unit. . ; It's not included in the original call, so we have to go to the drug file. . ; That would be DATA^PSS50(IEN,,,,,"SUBSCRIPT") diff --git a/p/C0CORSLT.m b/p/C0CORSLT.m new file mode 100644 index 0000000..0c02d5f --- /dev/null +++ b/p/C0CORSLT.m @@ -0,0 +1,69 @@ +C0CORSLT ; CCDCCR/GPL - CCR/CCD PROCESSING ADDITIONAL RESULTS ; 06/27/11 + ;;1.0;C0C;;Jan 21, 2010;Build 38 + ;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. + ; + W "NO ENTRY FROM TOP",! + Q + ; +EN(ZVARS,DFN) ; LOOKS FOR CCR RESULTS THAT ARE NOT LAB RESULTS AND ADDS + ; THEM TO THE LAB VARIABLES ZVARS IS PASSED BY REFERENCE + ; AN EXAMPLE IS EKG RESULTS THAT ARE FOUND IN NOTES AND CONSULTS + ; THIS IS CREATED FOR MU CERTIFICATION BY GPL + D ENTRY^C0CCPT(DFN,,,1) ; RETURNS ALL RESULTS IN VISIT LOCAL VARIABLE + N ZN ; RESULT NUMBER + S ZN=$O(@ZVARS@(""),-1) ; NEXT RESULT + N ZI S ZI="" + F S ZI=$O(VISIT(ZI)) Q:ZI="" D ; FOR EACH VISIT + . I $G(VISIT(ZI,"TEXT",1))["ECG DONE" D ; GOT AN ECG + . . S ZN=ZN+1 ; INCREMENT RESULT COUNT + . . N ZDATE,ZPRV,ZTXT + . . S ZDATE=$G(VISIT(ZI,"DATE",0)) ; DATE OF PROCEDURE + . . S ZPRV=$P($G(VISIT(ZI,"PRV",2)),"^",1) ;PROVIDER + . . S ZTXT=$P($G(VISIT(ZI,"TEXT",4)),"ECG RESULTS: ",2) + . . S @ZVARS@(ZN,"RESULTASSESSMENTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") + . . S @ZVARS@(ZN,"RESULTCODE")="34534-8" + . . S @ZVARS@(ZN,"RESULTCODINGSYSTEM")="LOINC" + . . S @ZVARS@(ZN,"RESULTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" + . . S @ZVARS@(ZN,"RESULTOBJECTID")="RESULT"_ZN + . . S @ZVARS@(ZN,"RESULTSOURCEACTORID")="ACTORPROVIDER_"_ZPRV + . . S @ZVARS@(ZN,"RESULTSTATUS")="" + . . S @ZVARS@(ZN,"M","TEST",0)=1 + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODEVALUE")="34534-8" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTCODINGSYSTEM")="LOINC" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDATETIME")=$$FMDTOUTC^C0CUTIL(ZDATE,"DT") + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTDESCRIPTIONTEXT")="Electrocardiogram LOINC:34534-8" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTFLAG")="" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALDESCTEXT")="" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTNORMALSOURCEACTORID")="ACTORORGANIZATION_VASTANUM" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTOBJECTID")="RESULTTEST_ECG_"_ZN + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSOURCEACTORID")="ACTORPROVIDER"_ZPRV + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTSTATUSTEXT")="F" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTUNITS")="" + . . S @ZVARS@(ZN,"M","TEST",1,"RESULTTESTVALUE")=ZTXT + . . S @ZVARS@(0)=ZN ; UPDATE RESULTS COUNT + Q + ; +OLD ; OLD CODE FOR OTHER WAYS OF DOING THE ECG + ; FOR CERTIFICATION - SAVE EKG RESULTS gpl + W !,"CPT=",ZCPT + I ZCPT["93000" D ; THIS IS AN EKG + . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS + . M ^GPL("RNF2")=@C0CPRSLT + Q + ; diff --git a/p/C0CPROBS.m b/p/C0CPROBS.m index 6a92b82..8698c30 100644 --- a/p/C0CPROBS.m +++ b/p/C0CPROBS.m @@ -59,6 +59,8 @@ RPMS ; GETS THE PROBLEM LIST FOR RPMS . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,6) . S @VMAP@("PROBLEMCODINGVERSION")="" . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,3) + . ; FOR CERTIFICATION - GPL + . I @VMAP@("PROBLEMCODEVALUE")=493.90 S @VMAP@("PROBLEMCODEVALUE")=493 . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE OF ONSET","C0CG1"),"DT") . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($$ZVALUEI^C0CRNF("DATE LAST MODIFIED","C0CG1"),"DT") . ;S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) ;UNKNOWN NOT MAPPED IN C0CCCR0 @@ -109,10 +111,13 @@ VISTA ; GETS THE PROBLEM LIST FOR VISTA . S @VMAP@("PROBLEMIEN")=$P(PTMP,U,1) . S @VMAP@("PROBLEMSTATUS")=$S($P(PTMP,U,2)="A":"Active",$P(PTMP,U,2)="I":"Inactive",1:"") . N ZPRIOR S ZPRIOR=$P(PTMP,U,14) ;PRIORITY FLAG - . S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status + . ; turn off acute/chronic for certification gpl + . ;S @VMAP@("PROBLEMSTATUS")=@VMAP@("PROBLEMSTATUS")_$S(ZPRIOR="A":"/Acute",ZPRIOR="C":"/Chronic",1:"") ; append Chronic and Accute to Status . S @VMAP@("PROBLEMDESCRIPTION")=$P(PTMP,U,3) . S @VMAP@("PROBLEMCODINGVERSION")="" . S @VMAP@("PROBLEMCODEVALUE")=$P(PTMP,U,4) + . ; FOR CERTIFICATION - GPL + . I @VMAP@("PROBLEMCODEVALUE")["493.90" S @VMAP@("PROBLEMCODEVALUE")=493 . S @VMAP@("PROBLEMDATEOFONSET")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,5),"DT") . S @VMAP@("PROBLEMDATEMOD")=$$FMDTOUTC^C0CUTIL($P(PTMP,U,6),"DT") . S @VMAP@("PROBLEMSC")=$P(PTMP,U,7) diff --git a/p/C0CPROC.m b/p/C0CPROC.m index edb6102..7f5235f 100644 --- a/p/C0CPROC.m +++ b/p/C0CPROC.m @@ -25,6 +25,8 @@ SETVARS ; SET UP VARIABLES FOR PROCEDURES, ENCOUNTERS, AND NOTES S C0CENC=$NA(^TMP("C0CCCR",$J,"C0CENC",DFN)) S C0CPRC=$NA(^TMP("C0CCCR",$J,"C0CPRC",DFN)) S C0CNTE=$NA(^TMP("C0CCCR",$J,"C0CNTE",DFN)) + ; ADDITION FOR CERTIFICATION + S C0CPRSLT=$NA(^TMP("C0CCCR",$J,"C0CPRSLT",DFN)) Q ; EXTRACT(PROCXML,DFN,PROCOUT) ; EXTRACT PROCEDURES INTO XML TEMPLATE @@ -77,11 +79,18 @@ TIUGET(DFN,C0CENC,C0CPRC,C0CNTE) ; CALLS ENTRY^C0CCPT TO GET PROCEDURES, . . . S ZRNF("PROCDESCTEXT")=$P(ZCPT,U,3) . . . S ZRNF("PROCLINKID")="" ; NO LINKS YET . . . S ZRNF("PROCLINKREL")="" ; NO LINKS YET + . . . ; additions for Certification - need to have EKG in Results + . . . S ZRNF("PROCTEXT")=$G(VISIT(ZI,"TEXT",1)) ; POTENTIAL RESULT . . . S ZRNF("PROCOBJECTID")="PROCEDURE_"_ZI_"_"_ZJ . . . S C0CLPRC(ZI,PROCCODE)=ZRNF("PROCOBJECTID") ; LOOKUP TABLE FOR ENCOUNTERS . . . S ZRNF("PROCSTATUS")="Completed" ; Is this right? . . . S ZRNF("PROCTYPE")=$P(ZCPT,U,2) ; NEED TO ADD THIS TO TEMPLATE . . . D RNF1TO2^C0CRNF(C0CPRC,"ZRNF") ; ADD THIS ROW TO THE ARRAY + . . . ; FOR CERTIFICATION - SAVE EKG RESULTS gpl + . . . W !,"CPT=",ZCPT + . . . I ZCPT["93000" D ; THIS IS AN EKG + . . . . D RNF1TO2^C0CRNF(C0CPRSLT,"ZRNF") ; SAVE FOR LABS + . . . . M ^GPL("RNF2")=@C0CPRSLT . . . S PREVCPT=ZCPT . . . S PREVDT=ZDATE N ZRIM S ZRIM=$NA(^TMP("C0CRIM","VARS",DFN,"PROCEDURES")) diff --git a/p/C0CUTIL.m b/p/C0CUTIL.m index 9424333..e06b98c 100644 --- a/p/C0CUTIL.m +++ b/p/C0CUTIL.m @@ -144,11 +144,25 @@ CODE(ZVUID) ; EXTRINSIC WHICH RETURNS THE RXNORM CODE IF KNOWN OF N C0PIEN ; S C0PIEN=$$FIND1^DIC($$RXNFN,"","QX",ZVUID,"VUID") S C0PIEN=$O(^C0P("RXN","VUID",ZVUID,"")) ;GPL FIX FOR MULTIPLES N ZRXN S ZRXN=$$GET1^DIQ($$RXNFN,C0PIEN,.01) + S ZRXN=$$NISTMAP(ZRXN) ; CHANGE THE CODE IF NEEDED + I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F" + Q ZRSLT + ; +NISTMAP(ZRXN) ; EXTRINSIC WHICH MAPS SOME RXNORM NUMBERS TO + ; CONFORM TO NIST REQUIREMENTS + ;INPATIENT CERTIFICATION I ZRXN=309362 S ZRXN=213169 I ZRXN=855318 S ZRXN=855320 I ZRXN=197361 S ZRXN=212549 - I ZRXN'="" S ZRSLT=ZRXN_"^RXNORM^08AB_081201F" - Q ZRSLT + ;OUTPATIENT CERTIFICATION + I ZRXN=310534 S ZRXN=205875 + I ZRXN=617312 S ZRXN=617314 + I ZRXN=310429 S ZRXN=200801 + I ZRXN=628953 S ZRXN=628958 + I ZRXN=745679 S ZRXN=630208 + I ZRXN=311564 S ZRXN=979334 + I ZRXN=836343 S ZRXN=836370 + Q ZRXN ; RPMS() ; Are we running on an RPMS system rather than Vista? Q $G(DUZ("AG"))="I" ; If User Agency is Indian Health Service