MDHL7U3 ;HOIFO/WAA - Utilities for CP to process HL7 messages ;02/17/10 15:59
;;1.0;CLINICAL PROCEDURES;**6,21,29**;Apr 01, 2004;Build 22
; Reference DBIA #2729 [Supported] for XMXPAI
; Reference DBIA #4262 [Supported] for HLUOPT2 call.
; Reference DBIA #3244 [Subscription] for MSH node of HLMA file (#773).
; Reference DBIA #3273 [Subscription] for reference HLMA of file (#773).
; Reference DBIA #10138 [Supported] for reference of HL file (#772).
; Reference DBIA #1131 [Supported] for XMB("NETNAME") reference
; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call
; Reference DBIA #10060 [Supported] NEW PERSON FILE (#200) Lookup.
; Reference DBIA #10111 [Supported] for FILE 3.8 call
; Reference DBIA #10103 [Supported] for XLFDT call
;
HL7CHK(MDD702) ; Check to see of there is an entry in 703.1 for a patient.
N X
S X="1^"
D
. N Y
. I $G(^MDD(702,MDD702,0))="" S X="-1^No Entry in 702." Q
. I $D(^MDD(703.1,"ASTUDYID",MDD702))=0 Q
. S Y=0
. S Y=$O(^MDD(703.1,"ASTUDYID",MDD702,Y)) I Y>0 S X="-1^This Study has Data on file."
. Q
Q X
XVERT(MDA,MDB) ; Strip out blank Lines
Q:MDA=""
Q:MDB=""
Q:$G(^TMP($J,MDA,1))
N I,CNT,CNT2,NODE,FLG
S (CNT,I,FLG)=0
F S I=$O(^TMP($J,MDA,I)) Q:I<1 D
. S NODE=$TR(^TMP($J,MDA,I),$C(10),"")
. I NODE=" " S NODE=""
. I NODE="" S FLG=0 Q
. I FLG D Q
. . S CNT2=CNT2+1
. . S ^TMP($J,MDB,CNT,CNT2)=NODE
. . Q
. I 'FLG D Q
. . S CNT=CNT+1
. . S ^TMP($J,MDB,CNT)=NODE
. . S FLG=1,CNT2=0
. . Q
. Q
Q
;
PURGE(MDD7031) ;
; This sub-routine will delete HL7 772 Message text after a message
; been processed by Imaging.
Q:'$D(^MDD(703.1,MDD7031,0)) ; No entry found
S MDD772=$P(^MDD(703.1,MDD7031,0),U,6) Q:MDD772=""
D DELBODY^HLUOPT2(MDD772,"CLINICAL PROCEDURES message purge","^TMP($J,""IN"")")
S $P(^MDD(703.1,MDD7031,0),U,6)=""
Q
;
PHY(X,MDIEN) ; Add the doc who did the exam to the report
Q
; This will be implemented with the Doctor Lookup when it comes out.
N LINE1,LINE
S LINE1=$P(X,"|",17)
S LINE=$P(LINE1,"^",2) ; Last
S LINE=LINE_$S($P(LINE1,"^",3)'="":", "_$P(LINE1,"^",3),1:"") ; First
S LINE=LINE_$S($P(LINE1,"^",4)'="":" "_$P(LINE1,"^",4),1:"") ; MI
D ADD(MDIEN,"9",LINE)
Q
;
CPTICD(X,MDIEN) ; Break out CPT and ICD9 codes
N ICD,CPT
Q:MDIEN<1
S CPT=$P(X,"|",45) I CPT'="" D FILECD(MDIEN,CPT,"7")
S ICD=$P(X,"|",14) I ICD'="" D FILECD(MDIEN,ICD,"8")
Q
FILECD(MDIEN,CODE,TYPE) ; fILE THE DATA
N LINE,Y,I,CNT,RESULT
S CNT=$L(CODE,"~")
S LINE=""
F I=1:1:CNT S Y=$P(CODE,"~",I),RESULT=$P(Y,"^",1),LINE(.2,I,0)=RESULT
S LINE(.2,0)="^^"_CNT_"^"_CNT_"^"_$P(%,".")
Q:CNT<1 ; file the results if there is any
D ADD(MDIEN,TYPE,.LINE,CNT)
Q
;
ADD(MDIEN,TYPE,LINE,CNT) ;
; Create an entry in the .1 node
N NODE,X
S NODE=$G(^MDD(703.1,MDIEN,.1,0)) Q:NODE=""
S NODE=$P(NODE,"^",3)
S NODE=NODE+1
S $P(^MDD(703.1,MDIEN,.1,0),"^",3,4)=NODE_"^"_NODE
S $P(^MDD(703.1,MDIEN,.1,NODE,0),"^")=TYPE
D NOW^%DTC
M ^MDD(703.1,MDIEN,.1,NODE)=LINE
Q
;
MSGIEN(MDHLIENS,MDHLREST) ; Return the message as definded in MDHLIENS to the array in MDHLREST
; Only TCP type messages
; input: MDHLIENS= the intern entry number of the message in ^HLMA
; MDHLREST = the return array that will contain the whole HL7 message
; output: return "1^Message complete" if message was successful, "0^reason" if failed.
;
N MDHLIEN,MDHLI,MDHLCNT,MDHLZ,RET
S (MDHLCNT,MDHLI,RET)=0
I $G(MDHLIENS)="" S RET=RET_"^No IEN defined" Q RET ; Exit because no IEN for ^HLMA was provided
I $G(MDHLREST)="" S RET=RET_"^No Return ARRAY provided" Q RET ; Exit because no return array was provided
I $G(^HLMA(MDHLIENS,0))="" S RET=RET_"^HLMA entry does not exist" Q RET ; Exit because invalid OR non-EXISTING HLMA ENTRY
S MDHLIEN=$P(^HLMA(MDHLIENS,0),U)
I MDHLIEN="" S RET=RET_"^No pointer value to file 772" Q RET ; No Pointer to 772
I $G(^HL(772,MDHLIEN,0))="" S RET=RET_"^772 Entry does not exist" Q RET ; No 772 entry exist
;get header
S MDHLZ=$G(^HLMA(MDHLIENS,"MSH",1,0))
I MDHLZ="" S RET=RET_"^No MSH segment found" Q RET ; No MSH was found
S MDHLCNT=MDHLCNT+1,@MDHLREST@(MDHLCNT)=MDHLZ
S MDHLCNT=MDHLCNT+1,@MDHLREST@(MDHLCNT)=""
;get body
S MDHLI=0
F S MDHLI=$O(^HL(772,MDHLIEN,"IN",MDHLI)) Q:'MDHLI D
. S MDHLCNT=MDHLCNT+1
. S @MDHLREST@(MDHLCNT)=$G(^HL(772,MDHLIEN,"IN",MDHLI,0))
. Q
I MDHLCNT'>2 S RET=RET_"^No message body found" Q RET ; There was no body
S RET="1^Message complete"
Q RET
;
CICNV(MDIEN,RETURN) ; This subroutine will read the data in 703.1 and return the results
;in the indicated global
N NODE,FLG
S FLG=1
Q:MDIEN="" ; The ien was null
Q:RETURN="" ; the array was null
S ARRAY(0)="0^0"
I $G(^MDD(703.1,MDIEN,.1,0))="" S FLG=0 Q ; There is not data.
; Start the processing of ICD/POV codes Value is 8
S NODE=0
I FLG I $G(^MDD(703.1,MDIEN,.1,0))'="" D
. F S NODE=$O(^MDD(703.1,MDIEN,.1,NODE)) Q:NODE<1 D
. . S TYPE=$P($G(^MDD(703.1,MDIEN,.1,NODE,0),0),"^",1)
. . I TYPE=8 D PROCESS(MDIEN,NODE,TYPE,.ARRAY)
. . I TYPE=7 D PROCESS(MDIEN,NODE,TYPE,.ARRAY)
. . Q
. Q
M @RETURN=ARRAY
Q
PROCESS(MDIEN,NODE,TYPE,ARRAY) ; This will process the data for each
N CNT,X,CONT,CODE,AR,TP,LOC
S CNT=0,CONT=0
F S CNT=$O(^MDD(703.1,MDIEN,.1,NODE,.2,CNT)) Q:CNT<1 D
. S CODE=$G(^MDD(703.1,MDIEN,.1,NODE,.2,CNT,0),"") ; Grabbing the ICD9 AND CPT codes
. I CODE="" Q
. I TYPE=8 S AR=1,TP="POV",X=$$ICDDATA^ICDXCODE(80,CODE,$P($P(^MDD(703.1,MDIEN,0),"^",3),".",1)) Q:X=""
. I TYPE=7 S AR=2,TP="CPT",X=$$CPT^ICPTCOD(CODE) Q:X="" ; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call
. S CONT=CONT+1
. S ARRAY(AR)=CONT_"^"_CONT
. I AR=1 D
. . N DESC,IN,LN
. . S IN=$P(X,"^",1) Q:IN<1
. . S DESC=$P(X,"^",4) Q:DESC=""
. . S I=CONT
. . S $P(ARRAY(AR,I),"^",1)=TP
. . S $P(ARRAY(AR,I),"^",2)=$P(X,"^",1)
. . S $P(ARRAY(AR,I),"^",3)=$P(X,"^",2)
. . S $P(ARRAY(AR,I),"^",5)=DESC
. . S $P(ARRAY(AR,I),"^",6)=$S(I=1:1,1:0)
. . Q
. I AR=2 D
. . N DESC,IN,LN,LEX,CPTCNT
. . S IN=$P(X,"^",1) Q:IN<1
. . D CPTLEX^MDRPCWU(.LEX,CODE,"CPT")
. . Q:$D(^TMP("MDLEX",$J))<1
. . S DESC="",CPTCNT=""
. . F S CPTCNT=$O(^TMP("MDLEX",$J,CPTCNT)) Q:CPTCNT<1 D Q:$L(DESC)>200
. . . N LINE
. . . S LINE=$P(^TMP("MDLEX",$J,CPTCNT),"^",3)
. . . Q:LINE=""
. . . S DESC=DESC_LINE_" "
. . . Q
. . I $L(DESC)>200 S DESC=$E(DESC,1,200)
. . ; S LN=$G(^ICPT(IN,0),0) Q:LN=""
. . ; S DESC=$P(X,"^",3) Q:DESC="" ; DBIA1995 $$CPT^ICPTCOD(CODE) returns X and the second piece of X is the DESC
. . S I=CNT
. . S $P(ARRAY(AR,I),"^",1)=TP
. . S $P(ARRAY(AR,I),"^",2)=$P(X,"^",1)
. . S $P(ARRAY(AR,I),"^",3)=$P(X,"^",2)
. . S $P(ARRAY(AR,I),"^",5)=DESC
. . ; S $P(ARRAY(AR,I),"^",5)=LEX^MDRPCW1(RESULTS,CODE,"CPT") ; 02
. . S $P(ARRAY(AR,I),"^",7)=$S(I=1:1,1:0)
. . Q
. Q
I $D(ARRAY(1))!$D(ARRAY(2)) S ARRAY(0)="1^1"
Q
;
NOTICE(SUBJECT,TXT,DEVIEN,DUZ) ; This will fire off a mail message to the Indicated mail group saying that a study was deleted
;
N INST,MG,XMTO,XMDUZ,XMSUBJ,XMBODY,N,X
S MG=0
S INST=DEVIEN
I INST>1 S MG=$P($G(^MDS(702.09,INST,0)),"^",2)
I 'MG!('$$MG^MDHL7U2(MG)) S MG=$$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS") Q:'MG
S MG=$$GET1^DIQ(3.8,+MG_",",.01)
S XMTO="G."_MG_"@"_^XMB("NETNAME"),XMINSTR("FROM")=.5
S XMBODY="TXT"
S XMSUBJ=SUBJECT
D SENDMSG^XMXAPI(DUZ,XMSUBJ,XMBODY,XMTO,.XMINSTR)
Q
;
ALERT(MDSIEN) ; This is to send an e-mail to the main device mail group that a study has been deleted
D NOW^%DTC
S SUBJECT="Study "_MDSIEN_" for Patient "_$$GET1^DIQ(702,MDSIEN,.01,"E")_" has been DELETED!"
S BODY(1)="The following study has been deleted."
S BODY(2)=" By the USER: "_$$GET1^DIQ(200,DUZ,.01,"E")
S BODY(3)=" On Date: "_$$FMTE^XLFDT(%,1)
S BODY(4)=" "
S BODY(5)=" CP Study Information"
S BODY(6)="------------------------------------------------------------------------------ "
S BODY(7)="CP Study ID: "_MDSIEN
S BODY(8)="CP Study Def: "_$$GET1^DIQ(702,MDSIEN,.04,"E")
S BODY(9)="Created on: "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.02,"I"),1)
S BODY(10)="Created by: "_$$GET1^DIQ(702,MDSIEN,.03,"E")
S BODY(11)="On Instrument: "_$$GET1^DIQ(702,MDSIEN,.11,"E")
S BODY(12)="For Patient: "_$$GET1^DIQ(702,MDSIEN,.01,"E")
S BODY(13)=" SSN: "_$E($$GET1^DIQ(702,MDSIEN,.011,"E"),6,9)
S BODY(14)=" DOB: "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.012,"I"),1)
S DEVIEN=$$GET1^DIQ(702,MDSIEN,.11,"I")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDHL7U3 8670 printed Oct 16, 2024@17:43:49 Page 2
MDHL7U3 ;HOIFO/WAA - Utilities for CP to process HL7 messages ;02/17/10 15:59
+1 ;;1.0;CLINICAL PROCEDURES;**6,21,29**;Apr 01, 2004;Build 22
+2 ; Reference DBIA #2729 [Supported] for XMXPAI
+3 ; Reference DBIA #4262 [Supported] for HLUOPT2 call.
+4 ; Reference DBIA #3244 [Subscription] for MSH node of HLMA file (#773).
+5 ; Reference DBIA #3273 [Subscription] for reference HLMA of file (#773).
+6 ; Reference DBIA #10138 [Supported] for reference of HL file (#772).
+7 ; Reference DBIA #1131 [Supported] for XMB("NETNAME") reference
+8 ; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call
+9 ; Reference DBIA #10060 [Supported] NEW PERSON FILE (#200) Lookup.
+10 ; Reference DBIA #10111 [Supported] for FILE 3.8 call
+11 ; Reference DBIA #10103 [Supported] for XLFDT call
+12 ;
HL7CHK(MDD702) ; Check to see of there is an entry in 703.1 for a patient.
+1 NEW X
+2 SET X="1^"
+3 Begin DoDot:1
+4 NEW Y
+5 IF $GET(^MDD(702,MDD702,0))=""
SET X="-1^No Entry in 702."
QUIT
+6 IF $DATA(^MDD(703.1,"ASTUDYID",MDD702))=0
QUIT
+7 SET Y=0
+8 SET Y=$ORDER(^MDD(703.1,"ASTUDYID",MDD702,Y))
IF Y>0
SET X="-1^This Study has Data on file."
+9 QUIT
End DoDot:1
+10 QUIT X
XVERT(MDA,MDB) ; Strip out blank Lines
+1 if MDA=""
QUIT
+2 if MDB=""
QUIT
+3 if $GET(^TMP($JOB,MDA,1))
QUIT
+4 NEW I,CNT,CNT2,NODE,FLG
+5 SET (CNT,I,FLG)=0
+6 FOR
SET I=$ORDER(^TMP($JOB,MDA,I))
if I<1
QUIT
Begin DoDot:1
+7 SET NODE=$TRANSLATE(^TMP($JOB,MDA,I),$CHAR(10),"")
+8 IF NODE=" "
SET NODE=""
+9 IF NODE=""
SET FLG=0
QUIT
+10 IF FLG
Begin DoDot:2
+11 SET CNT2=CNT2+1
+12 SET ^TMP($JOB,MDB,CNT,CNT2)=NODE
+13 QUIT
End DoDot:2
QUIT
+14 IF 'FLG
Begin DoDot:2
+15 SET CNT=CNT+1
+16 SET ^TMP($JOB,MDB,CNT)=NODE
+17 SET FLG=1
SET CNT2=0
+18 QUIT
End DoDot:2
QUIT
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
PURGE(MDD7031) ;
+1 ; This sub-routine will delete HL7 772 Message text after a message
+2 ; been processed by Imaging.
+3 ; No entry found
if '$DATA(^MDD(703.1,MDD7031,0))
QUIT
+4 SET MDD772=$PIECE(^MDD(703.1,MDD7031,0),U,6)
if MDD772=""
QUIT
+5 DO DELBODY^HLUOPT2(MDD772,"CLINICAL PROCEDURES message purge","^TMP($J,""IN"")")
+6 SET $PIECE(^MDD(703.1,MDD7031,0),U,6)=""
+7 QUIT
+8 ;
PHY(X,MDIEN) ; Add the doc who did the exam to the report
+1 QUIT
+2 ; This will be implemented with the Doctor Lookup when it comes out.
+3 NEW LINE1,LINE
+4 SET LINE1=$PIECE(X,"|",17)
+5 ; Last
SET LINE=$PIECE(LINE1,"^",2)
+6 ; First
SET LINE=LINE_$SELECT($PIECE(LINE1,"^",3)'="":", "_$PIECE(LINE1,"^",3),1:"")
+7 ; MI
SET LINE=LINE_$SELECT($PIECE(LINE1,"^",4)'="":" "_$PIECE(LINE1,"^",4),1:"")
+8 DO ADD(MDIEN,"9",LINE)
+9 QUIT
+10 ;
CPTICD(X,MDIEN) ; Break out CPT and ICD9 codes
+1 NEW ICD,CPT
+2 if MDIEN<1
QUIT
+3 SET CPT=$PIECE(X,"|",45)
IF CPT'=""
DO FILECD(MDIEN,CPT,"7")
+4 SET ICD=$PIECE(X,"|",14)
IF ICD'=""
DO FILECD(MDIEN,ICD,"8")
+5 QUIT
FILECD(MDIEN,CODE,TYPE) ; fILE THE DATA
+1 NEW LINE,Y,I,CNT,RESULT
+2 SET CNT=$LENGTH(CODE,"~")
+3 SET LINE=""
+4 FOR I=1:1:CNT
SET Y=$PIECE(CODE,"~",I)
SET RESULT=$PIECE(Y,"^",1)
SET LINE(.2,I,0)=RESULT
+5 SET LINE(.2,0)="^^"_CNT_"^"_CNT_"^"_$PIECE(%,".")
+6 ; file the results if there is any
if CNT<1
QUIT
+7 DO ADD(MDIEN,TYPE,.LINE,CNT)
+8 QUIT
+9 ;
ADD(MDIEN,TYPE,LINE,CNT) ;
+1 ; Create an entry in the .1 node
+2 NEW NODE,X
+3 SET NODE=$GET(^MDD(703.1,MDIEN,.1,0))
if NODE=""
QUIT
+4 SET NODE=$PIECE(NODE,"^",3)
+5 SET NODE=NODE+1
+6 SET $PIECE(^MDD(703.1,MDIEN,.1,0),"^",3,4)=NODE_"^"_NODE
+7 SET $PIECE(^MDD(703.1,MDIEN,.1,NODE,0),"^")=TYPE
+8 DO NOW^%DTC
+9 MERGE ^MDD(703.1,MDIEN,.1,NODE)=LINE
+10 QUIT
+11 ;
MSGIEN(MDHLIENS,MDHLREST) ; Return the message as definded in MDHLIENS to the array in MDHLREST
+1 ; Only TCP type messages
+2 ; input: MDHLIENS= the intern entry number of the message in ^HLMA
+3 ; MDHLREST = the return array that will contain the whole HL7 message
+4 ; output: return "1^Message complete" if message was successful, "0^reason" if failed.
+5 ;
+6 NEW MDHLIEN,MDHLI,MDHLCNT,MDHLZ,RET
+7 SET (MDHLCNT,MDHLI,RET)=0
+8 ; Exit because no IEN for ^HLMA was provided
IF $GET(MDHLIENS)=""
SET RET=RET_"^No IEN defined"
QUIT RET
+9 ; Exit because no return array was provided
IF $GET(MDHLREST)=""
SET RET=RET_"^No Return ARRAY provided"
QUIT RET
+10 ; Exit because invalid OR non-EXISTING HLMA ENTRY
IF $GET(^HLMA(MDHLIENS,0))=""
SET RET=RET_"^HLMA entry does not exist"
QUIT RET
+11 SET MDHLIEN=$PIECE(^HLMA(MDHLIENS,0),U)
+12 ; No Pointer to 772
IF MDHLIEN=""
SET RET=RET_"^No pointer value to file 772"
QUIT RET
+13 ; No 772 entry exist
IF $GET(^HL(772,MDHLIEN,0))=""
SET RET=RET_"^772 Entry does not exist"
QUIT RET
+14 ;get header
+15 SET MDHLZ=$GET(^HLMA(MDHLIENS,"MSH",1,0))
+16 ; No MSH was found
IF MDHLZ=""
SET RET=RET_"^No MSH segment found"
QUIT RET
+17 SET MDHLCNT=MDHLCNT+1
SET @MDHLREST@(MDHLCNT)=MDHLZ
+18 SET MDHLCNT=MDHLCNT+1
SET @MDHLREST@(MDHLCNT)=""
+19 ;get body
+20 SET MDHLI=0
+21 FOR
SET MDHLI=$ORDER(^HL(772,MDHLIEN,"IN",MDHLI))
if 'MDHLI
QUIT
Begin DoDot:1
+22 SET MDHLCNT=MDHLCNT+1
+23 SET @MDHLREST@(MDHLCNT)=$GET(^HL(772,MDHLIEN,"IN",MDHLI,0))
+24 QUIT
End DoDot:1
+25 ; There was no body
IF MDHLCNT'>2
SET RET=RET_"^No message body found"
QUIT RET
+26 SET RET="1^Message complete"
+27 QUIT RET
+28 ;
CICNV(MDIEN,RETURN) ; This subroutine will read the data in 703.1 and return the results
+1 ;in the indicated global
+2 NEW NODE,FLG
+3 SET FLG=1
+4 ; The ien was null
if MDIEN=""
QUIT
+5 ; the array was null
if RETURN=""
QUIT
+6 SET ARRAY(0)="0^0"
+7 ; There is not data.
IF $GET(^MDD(703.1,MDIEN,.1,0))=""
SET FLG=0
QUIT
+8 ; Start the processing of ICD/POV codes Value is 8
+9 SET NODE=0
+10 IF FLG
IF $GET(^MDD(703.1,MDIEN,.1,0))'=""
Begin DoDot:1
+11 FOR
SET NODE=$ORDER(^MDD(703.1,MDIEN,.1,NODE))
if NODE<1
QUIT
Begin DoDot:2
+12 SET TYPE=$PIECE($GET(^MDD(703.1,MDIEN,.1,NODE,0),0),"^",1)
+13 IF TYPE=8
DO PROCESS(MDIEN,NODE,TYPE,.ARRAY)
+14 IF TYPE=7
DO PROCESS(MDIEN,NODE,TYPE,.ARRAY)
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 MERGE @RETURN=ARRAY
+18 QUIT
PROCESS(MDIEN,NODE,TYPE,ARRAY) ; This will process the data for each
+1 NEW CNT,X,CONT,CODE,AR,TP,LOC
+2 SET CNT=0
SET CONT=0
+3 FOR
SET CNT=$ORDER(^MDD(703.1,MDIEN,.1,NODE,.2,CNT))
if CNT<1
QUIT
Begin DoDot:1
+4 ; Grabbing the ICD9 AND CPT codes
SET CODE=$GET(^MDD(703.1,MDIEN,.1,NODE,.2,CNT,0),"")
+5 IF CODE=""
QUIT
+6 IF TYPE=8
SET AR=1
SET TP="POV"
SET X=$$ICDDATA^ICDXCODE(80,CODE,$PIECE($PIECE(^MDD(703.1,MDIEN,0),"^",3),".",1))
if X=""
QUIT
+7 ; Reference DBIA #1995 [Supported] for ICPTCOD to handle CPT Codes call
IF TYPE=7
SET AR=2
SET TP="CPT"
SET X=$$CPT^ICPTCOD(CODE)
if X=""
QUIT
+8 SET CONT=CONT+1
+9 SET ARRAY(AR)=CONT_"^"_CONT
+10 IF AR=1
Begin DoDot:2
+11 NEW DESC,IN,LN
+12 SET IN=$PIECE(X,"^",1)
if IN<1
QUIT
+13 SET DESC=$PIECE(X,"^",4)
if DESC=""
QUIT
+14 SET I=CONT
+15 SET $PIECE(ARRAY(AR,I),"^",1)=TP
+16 SET $PIECE(ARRAY(AR,I),"^",2)=$PIECE(X,"^",1)
+17 SET $PIECE(ARRAY(AR,I),"^",3)=$PIECE(X,"^",2)
+18 SET $PIECE(ARRAY(AR,I),"^",5)=DESC
+19 SET $PIECE(ARRAY(AR,I),"^",6)=$SELECT(I=1:1,1:0)
+20 QUIT
End DoDot:2
+21 IF AR=2
Begin DoDot:2
+22 NEW DESC,IN,LN,LEX,CPTCNT
+23 SET IN=$PIECE(X,"^",1)
if IN<1
QUIT
+24 DO CPTLEX^MDRPCWU(.LEX,CODE,"CPT")
+25 if $DATA(^TMP("MDLEX",$JOB))<1
QUIT
+26 SET DESC=""
SET CPTCNT=""
+27 FOR
SET CPTCNT=$ORDER(^TMP("MDLEX",$JOB,CPTCNT))
if CPTCNT<1
QUIT
Begin DoDot:3
+28 NEW LINE
+29 SET LINE=$PIECE(^TMP("MDLEX",$JOB,CPTCNT),"^",3)
+30 if LINE=""
QUIT
+31 SET DESC=DESC_LINE_" "
+32 QUIT
End DoDot:3
if $LENGTH(DESC)>200
QUIT
+33 IF $LENGTH(DESC)>200
SET DESC=$EXTRACT(DESC,1,200)
+34 ; S LN=$G(^ICPT(IN,0),0) Q:LN=""
+35 ; S DESC=$P(X,"^",3) Q:DESC="" ; DBIA1995 $$CPT^ICPTCOD(CODE) returns X and the second piece of X is the DESC
+36 SET I=CNT
+37 SET $PIECE(ARRAY(AR,I),"^",1)=TP
+38 SET $PIECE(ARRAY(AR,I),"^",2)=$PIECE(X,"^",1)
+39 SET $PIECE(ARRAY(AR,I),"^",3)=$PIECE(X,"^",2)
+40 SET $PIECE(ARRAY(AR,I),"^",5)=DESC
+41 ; S $P(ARRAY(AR,I),"^",5)=LEX^MDRPCW1(RESULTS,CODE,"CPT") ; 02
+42 SET $PIECE(ARRAY(AR,I),"^",7)=$SELECT(I=1:1,1:0)
+43 QUIT
End DoDot:2
+44 QUIT
End DoDot:1
+45 IF $DATA(ARRAY(1))!$DATA(ARRAY(2))
SET ARRAY(0)="1^1"
+46 QUIT
+47 ;
NOTICE(SUBJECT,TXT,DEVIEN,DUZ) ; This will fire off a mail message to the Indicated mail group saying that a study was deleted
+1 ;
+2 NEW INST,MG,XMTO,XMDUZ,XMSUBJ,XMBODY,N,X
+3 SET MG=0
+4 SET INST=DEVIEN
+5 IF INST>1
SET MG=$PIECE($GET(^MDS(702.09,INST,0)),"^",2)
+6 IF 'MG!('$$MG^MDHL7U2(MG))
SET MG=$$FIND1^DIC(3.8,"","BX","MD DEVICE ERRORS")
if 'MG
QUIT
+7 SET MG=$$GET1^DIQ(3.8,+MG_",",.01)
+8 SET XMTO="G."_MG_"@"_^XMB("NETNAME")
SET XMINSTR("FROM")=.5
+9 SET XMBODY="TXT"
+10 SET XMSUBJ=SUBJECT
+11 DO SENDMSG^XMXAPI(DUZ,XMSUBJ,XMBODY,XMTO,.XMINSTR)
+12 QUIT
+13 ;
ALERT(MDSIEN) ; This is to send an e-mail to the main device mail group that a study has been deleted
+1 DO NOW^%DTC
+2 SET SUBJECT="Study "_MDSIEN_" for Patient "_$$GET1^DIQ(702,MDSIEN,.01,"E")_" has been DELETED!"
+3 SET BODY(1)="The following study has been deleted."
+4 SET BODY(2)=" By the USER: "_$$GET1^DIQ(200,DUZ,.01,"E")
+5 SET BODY(3)=" On Date: "_$$FMTE^XLFDT(%,1)
+6 SET BODY(4)=" "
+7 SET BODY(5)=" CP Study Information"
+8 SET BODY(6)="------------------------------------------------------------------------------ "
+9 SET BODY(7)="CP Study ID: "_MDSIEN
+10 SET BODY(8)="CP Study Def: "_$$GET1^DIQ(702,MDSIEN,.04,"E")
+11 SET BODY(9)="Created on: "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.02,"I"),1)
+12 SET BODY(10)="Created by: "_$$GET1^DIQ(702,MDSIEN,.03,"E")
+13 SET BODY(11)="On Instrument: "_$$GET1^DIQ(702,MDSIEN,.11,"E")
+14 SET BODY(12)="For Patient: "_$$GET1^DIQ(702,MDSIEN,.01,"E")
+15 SET BODY(13)=" SSN: "_$EXTRACT($$GET1^DIQ(702,MDSIEN,.011,"E"),6,9)
+16 SET BODY(14)=" DOB: "_$$FMTE^XLFDT($$GET1^DIQ(702,MDSIEN,.012,"I"),1)
+17 SET DEVIEN=$$GET1^DIQ(702,MDSIEN,.11,"I")
+18 QUIT
