version for certification
This commit is contained in:
george
parent
07194d2d80
commit
a55a619c66
|
|
@ -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
|
||||
|
|
|
|||
11
p/C0CCCR.m
11
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
|
||||
|
|
|
|||
11
p/C0CCCR0.m
11
p/C0CCCR0.m
|
|
@ -791,17 +791,6 @@ LOAD(ARY) ; LOAD A CCR TEMPLATE INTO ARY PASSED BY NAME
|
|||
;;</CurrentName>
|
||||
;;</Name>
|
||||
;;</Person>
|
||||
;;<IDs>
|
||||
;;<Type>
|
||||
;;<Text>@@IDTYPE@@</Text>
|
||||
;;</Type>
|
||||
;;<ID>@@ID@@</ID>
|
||||
;;<IssuedBy>
|
||||
;;<Description>
|
||||
;;<Text>@@IDDESC@@</Text>
|
||||
;;</Description>
|
||||
;;</IssuedBy>
|
||||
;;</IDs>
|
||||
;;<Specialty>
|
||||
;;<Text>@@ACTORSPECIALITY@@</Text>
|
||||
;;</Specialty>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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="<Unknown>"
|
||||
. 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="<Unknown Sender>"
|
||||
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="<Unknown>"
|
||||
. 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
|
||||
; ===================
|
||||
|
|
@ -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="<Unknown>"
|
||||
. 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="<Unknown Sender>"
|
||||
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="<Unknown>"
|
||||
. 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["<CONTINUITYOFCARERECORD" S $P(LST("SEG",SGC),U,3)="CCR" Q
|
||||
. . ;
|
||||
. . I UBF["<CLINICALDOCUMENT" S $P(LST("SEG",SGC),U,3)="CCD" Q
|
||||
. .QUIT
|
||||
. ; Look for directives in the text before it gets published
|
||||
. ; Look for "=3D" and replace it with a single "=". I can do more parsing
|
||||
. ; but there may be situations where the line has been wrapped.
|
||||
. D:X["=3D"
|
||||
. . F KK=1:1 S X=$P(X,"=3D",1)_"="_$P(X,"=3D",2,999) Q:X'["=3D"
|
||||
. .QUIT
|
||||
. S LST("SEG",SGC,TYP,D1)=X
|
||||
.QUIT
|
||||
QUIT
|
||||
; ===================
|
||||
CONTENT(D1) ; Try pulling Content Statements
|
||||
N J,UP,X
|
||||
S X=$G(^XMB(3.9,D0,2,D1,0))
|
||||
S J=$P(X,CON,2)
|
||||
S UP=$TR($$UPPER(X),"""")
|
||||
S:$G(TYP)="" TYP="TXT"
|
||||
D
|
||||
. I UP["NAME=",($L(UP,".")>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["<CONTINUITYOFCARERECORD XMLNS=" S $P(LST("SEG",SGC),U,3)="CCR" Q
|
||||
. . . ;
|
||||
. . . I UBF["<CLINICALDOCUMENT XMLNS=" S $P(LST("SEG",SGC),U,3)="CCD" Q
|
||||
. . .QUIT
|
||||
. . ; Check for Bad Signature Decoding, after 100 bad characters
|
||||
. . S OK=1,OKCNT=0
|
||||
. . F KK=1:1:$L(UBF) S C=$A(UBF,KK) S:C>126 OKCNT=OKCNT+1 I OKCNT>100 S OK=0 Q
|
||||
. . ;
|
||||
. . D
|
||||
. . . I 'OK S (BF,UBF,TBF,XBF)="<Crypto-Signature redacted>" 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
|
||||
; ===================
|
||||
56
p/C0CMED3.m
56
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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;
|
||||
15
p/C0CNMED4.m
15
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")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
|
|
|
|||
18
p/C0CUTIL.m
18
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue