Index: ccr/trunk/p/C0CALERT.m
===================================================================
--- ccr/trunk/p/C0CALERT.m (revision 1204)
+++ ccr/trunk/p/C0CALERT.m (revision 1205)
@@ -82,4 +82,5 @@
. 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)
Index: ccr/trunk/p/C0CCCR.m
===================================================================
--- ccr/trunk/p/C0CCCR.m (revision 1204)
+++ ccr/trunk/p/C0CCCR.m (revision 1205)
@@ -103,4 +103,5 @@
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),!
;
@@ -134,7 +135,8 @@
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
@@ -164,5 +166,6 @@
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
;
Index: ccr/trunk/p/C0CCCR0.m
===================================================================
--- ccr/trunk/p/C0CCCR0.m (revision 1204)
+++ ccr/trunk/p/C0CCCR0.m (revision 1205)
@@ -792,15 +792,4 @@
;;
;;
- ;;
- ;;
- ;;@@IDTYPE@@
- ;;
- ;;@@ID@@
- ;;
- ;;
- ;;@@IDDESC@@
- ;;
- ;;
- ;;
;;
;;@@ACTORSPECIALITY@@
Index: ccr/trunk/p/C0CLABS.m
===================================================================
--- ccr/trunk/p/C0CLABS.m (revision 1204)
+++ ccr/trunk/p/C0CLABS.m (revision 1205)
@@ -130,4 +130,6 @@
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
@@ -152,4 +154,5 @@
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
@@ -172,4 +175,9 @@
. 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
Index: ccr/trunk/p/C0CMAIL.m
===================================================================
--- ccr/trunk/p/C0CMAIL.m (revision 1205)
+++ ccr/trunk/p/C0CMAIL.m (revision 1205)
@@ -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
+ ; ===================
Index: ccr/trunk/p/C0CMAIL3.m
===================================================================
--- ccr/trunk/p/C0CMAIL3.m (revision 1205)
+++ ccr/trunk/p/C0CMAIL3.m (revision 1205)
@@ -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
+ ; ===================
Index: ccr/trunk/p/C0CMED3.m
===================================================================
--- ccr/trunk/p/C0CMED3.m (revision 1204)
+++ ccr/trunk/p/C0CMED3.m (revision 1205)
@@ -71,5 +71,5 @@
. 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")
@@ -114,5 +114,23 @@
. . ; 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")
@@ -122,5 +140,5 @@
. . . 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
@@ -161,4 +179,5 @@
. . . S @MAP@("MEDQUANTITYUNIT")=QTYDATA(14.5)
. . E S @MAP@("MEDQUANTITYUNIT")=""
+ . . S @MAP@("MEDQUANTITYUNIT")="" ; don't show these
. E D
. . S @MAP@("MEDPRODUCTNAMECODEVALUE")=""
@@ -181,5 +200,33 @@
. ; 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")=""
@@ -213,4 +260,5 @@
. . 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
Index: ccr/trunk/p/C0CNMED2.m
===================================================================
--- ccr/trunk/p/C0CNMED2.m (revision 1205)
+++ ccr/trunk/p/C0CNMED2.m (revision 1205)
@@ -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
+ ;
Index: ccr/trunk/p/C0CNMED4.m
===================================================================
--- ccr/trunk/p/C0CNMED4.m (revision 1204)
+++ ccr/trunk/p/C0CNMED4.m (revision 1205)
@@ -83,5 +83,8 @@
. 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"))
@@ -112,7 +115,7 @@
. ;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
@@ -135,9 +138,9 @@
. 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.
Index: ccr/trunk/p/C0CORSLT.m
===================================================================
--- ccr/trunk/p/C0CORSLT.m (revision 1205)
+++ ccr/trunk/p/C0CORSLT.m (revision 1205)
@@ -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
+ ;
Index: ccr/trunk/p/C0CPROBS.m
===================================================================
--- ccr/trunk/p/C0CPROBS.m (revision 1204)
+++ ccr/trunk/p/C0CPROBS.m (revision 1205)
@@ -60,4 +60,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")
@@ -110,8 +112,11 @@
. 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")
Index: ccr/trunk/p/C0CPROC.m
===================================================================
--- ccr/trunk/p/C0CPROC.m (revision 1204)
+++ ccr/trunk/p/C0CPROC.m (revision 1205)
@@ -26,4 +26,6 @@
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
;
@@ -78,4 +80,6 @@
. . . 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
@@ -83,4 +87,9 @@
. . . 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
Index: ccr/trunk/p/C0CUTIL.m
===================================================================
--- ccr/trunk/p/C0CUTIL.m (revision 1204)
+++ ccr/trunk/p/C0CUTIL.m (revision 1205)
@@ -145,9 +145,23 @@
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?