source: WorldVistAEHR/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO4.m@ 1407

Last change on this file since 1407 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version
File size: 7.1 KB
RevLine 
[623]1RAHLO4 ;HIRMFO/GJC-File rpt (data from bridge program) ;7/21/99 11:45
2 ;;5.0;Radiology/Nuclear Medicine;**4,8,81**;Mar 16, 1998;Build 12
3TASK ; Task ORU message
4 S ZTDESC="Rad/Nuc Med Compiling HL7 ORU Message",ZTDTH=$H,ZTIO="",ZTRTN="RPT^RAHLRPC",ZTSAVE("RADFN")="",ZTSAVE("RADTI")="",ZTSAVE("RACNI")="",ZTSAVE("RARPT")=""
5 ;S:$L($G(RANOSEND))&'$O(RAPRSET(RADTI,0)) ZTSAVE("RANOSEND")="" D ^%ZTLOAD
6 S:$L($G(RANOSEND)) ZTSAVE("RANOSEND")="" D ^%ZTLOAD
7 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
8 Q
9VOICE ; voice dictation auto-print (background process)
10 Q:$P(^RA(79.1,+$G(RAMLC),0),U,26)'="Y" ; Voice Dictation Auto-Print
11 S ZTIO=$$GET1^DIQ(3.5,+$P(^RA(79.1,+$G(RAMLC),0),U,10),.01) ; dev name
12 Q:ZTIO']"" ; quit if the device does not exist
13 S ZTDTH=$H,ZTRTN="DQ^RARTR",ZTSAVE("RARPT")=""
14 S ZTDESC="Rad/Nuc Med voice dictation auto-print"
15 D ^%ZTLOAD K RAMES,ZTDESC,ZTSK,ZTIO,ZTSAVE,ZTRTN,RASV,ZTDTH
16 Q
17FILETST ; is anyone else working on this report?
18 L +^RARPT(RARPT):1
19 I '$T S RAERR="This report is being edited by another user" L -^RARPT(RARPT)
20 Q
21UPMEM ;copy (prim:dx,stf,res),rpt ien to other members of same print set
22 ; first clear those fields
23 K DIE,DA,DR S DA=RACNI,DA(1)=RADTI,DA(2)=RADFN
24 S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
25 S DR="13///@;12///@;15///@" D ^DIE
26 ; now set those fields based on lead case of printset
27 S DR="13////"_RA13_";12////"_RA12_";15////"_RA15 D ^DIE K DA,DR,DIE
28 ; now set the report pointer (uneditable, thus must hard set)
29 S $P(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0),"^",17)=RARPT
30 Q
31SETPHYS ;set Primary Resident or Staff, either piece 12 or piece 15 of case
32 Q:RADPIECE'=15&(RADPIECE'=12)
33 S DR=RADPIECE_"////"_$G(RAVERF)
34 S DA(2)=RADFN,DA(1)=RADTI,DA=RACNI
35 S DIE="^RADPT("_DA(2)_",""DT"","_DA(1)_",""P"","
36 D ^DIE K DA,DR
37 Q
38KILSECDG ;kill secondary diagnoses nodes of this case
39 Q:'$D(RADFN)!('$D(RADTI))!('$D(RACNI))
40 Q:RADFN=""!(RADTI="")!(RACNI="")
41 Q:'$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",0))
42 S DA(3)=RADFN,DA(2)=RADTI,DA(1)=RACNI
43 N RA1 S RA1=""
44K1 S RA1=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI,"DX",RA1)) G:RA1="" KQ
45 S DA=RA1
46 S DIK="^RADPT("_DA(3)_",""DT"","_DA(2)_",""P"","_DA(1)_",""DX"","
47 D ^DIK
48 G K1
49KQ K DA Q
50 ;
51PCEXTR(RASUB,RASEG,RAPCE,RADEL) ; extract the right piece of data
52 ; from the right data node
53 ; input: RASUB-data node subscript
54 ; RASEG-HL7 segment (minus the segment header)
55 ; RAPCE-data's piece position
56 ; RADEL-delimiter (field separator)
57 S RAHL70="",RAHL7X=0,RAHL7OFF=$L(RASEG,RADEL)
58 S RAHL7LST=$P(RASEG,RADEL,RAHL7OFF)
59 I RAPCE<RAHL7OFF S RAHL70=$P(RASEG,RADEL,RAPCE) D KILL Q RAHL70
60 I RAHL7OFF=RAPCE D ; check if data wraps to the next node (if any)
61 . S RAHL70=$P(RASEG,RADEL,RAPCE),II1=$O(^TMP("RARPT-HL7",$J,RASUB,0))
62 . S:'II1 RAHL7X=1 Q:'II1
63 . S RAHL70=RAHL70_$P(^TMP("RARPT-HL7",$J,RASUB,II1),RADEL),RAHL7X=1
64 . Q
65 I RAHL7X D KILL Q RAHL70
66 ; check if this node has descendent data nodes
67 I '$O(^TMP("RARPT-HL7",$J,RASUB,0)) D KILL Q "" ; descendents not found
68 S I=0,RAHL7CNT=RAHL7OFF
69 F S I=$O(^TMP("RARPT-HL7",$J,RASUB,I)) Q:I'>0 D Q:RAHL7X
70 . S RAHL7SUB=$G(^TMP("RARPT-HL7",$J,RASUB,I))
71 . S RAHL7PRE=$O(^TMP("RARPT-HL7",$J,RASUB,I),-1)
72 . S:RAHL7PRE RAHL7LST=$$LSTPCE(^TMP("RARPT-HL7",$J,RASUB,RAHL7PRE),RADEL)
73 . F II1=1:1:$L(RAHL7SUB,RADEL) D Q:RAHL7X
74 .. ; HL7 may have broken the string on data!
75 .. I II1=1 S RAHL7ARY(RAHL7CNT)=RAHL7LST_$P(RAHL7SUB,RADEL)
76 .. E D ; for the case II1'=1
77 ... S RAHL7CNT=RAHL7CNT+1
78 ... S RAHL7ARY(RAHL7CNT)=$P(RAHL7SUB,RADEL,II1)
79 ... Q
80 .. I RAHL7CNT=RAPCE,(II1'=$L(RAHL7SUB,RADEL)) S RAHL7X=1,RAHL70=RAHL7ARY(RAHL7CNT)
81 .. I RAHL7CNT=RAPCE,(II1=$L(RAHL7SUB,RADEL)) D
82 ... ; grab the 1st piece of the next node (if any)
83 ... S RAHL7X=1,RAHL70=RAHL7ARY(RAHL7CNT)
84 ... S N1=+$O(^TMP("RARPT-HL7",$J,RASUB,I)) Q:'N1
85 ... S RAHL70=RAHL70_$P(^TMP("RARPT-HL7",$J,RASUB,N1),RADEL)
86 ... Q
87 .. K:'RAHL7X RAHL7ARY
88 .. Q
89 . Q
90 D KILL
91 Q RAHL70
92KILL ; kill the RAHLD* variables
93 K I,II1,N1,RAHL7ARY,RAHL7CNT,RAHL7LST,RAHL7OFF,RAHL7PRE,RAHL7SUB,RAHL7X
94 Q
95LSTPCE(X,DEL) ; given a string and a delimiter, return the last piece
96 Q $P(X,DEL,$L(X,DEL))
97CKDUPA ; if duplicate addendum, send msg to members of unverify rpt mailgroup
98 S RADUPA=0 ; 0 means not a duplicate
99 N I1,I2,X1,X2,X3,X4,X21,R0,R1,R2,MATCH,XMSUB
100 S I1="I",I2="RAIMP" I $O(^RARPT(RARPT,I1,0))'="" D ISITDUP ;Q:'RADUPA
101 ;
102 I 'RADUPA S I1="R",I2="RATXT" I $O(^RARPT(RARPT,I1,0))'="" D ISITDUP Q:'RADUPA
103 ;S I1="R",I2="RATXT" I $O(^RARPT(RARPT,I1,0))'="" D ISITDUP Q:'RADUPA
104 ;
105 S XMSUB="Duplicate addendum being sent to Vista"
106 ;
107 ; check to see if mail message already sent for
108 ; this case no. TODAY only. if so quit - no need to
109 ; re-send to save time backwards $ORDER, duplicate
110 ; most likely to be most recently.
111 S (XMB,XMATCH)=""
112 D NOW^%DTC S RATDY=X K X
113 F S XMB=$O(^XMB(3.9,"B",$E(XMSUB,1,30),XMB),-1) Q:XMB="" D Q:XMATCH'=""
114 .I $P($$GET1^DIQ(3.9,XMB,1.4,"I"),".")'=RATDY S XMATCH=0 Q ;(DBIA2860)
115 .Q:$G(^XMB(3.9,XMB,2,6,0))'[RALONGCN
116 .S XMATCH=1
117 K XMB,RATDY
118 Q:XMATCH=1
119 ;
120 ; send mail to members of unverify bulletin (DBIA2861)
121 ; find ien of unverify bulletin
122 D FIND^DIC(3.6,"","","","RAD/NUC MED REPORT UNVERIFIED",1,"","","","R0")
123 Q:'$D(R0("DILIST",2,1))#2
124 ; find name of mail group linked to that bulletin
125 D GETS^DIQ(3.6,R0("DILIST",2,1),"4*","EI","R1")
126 ; check to see if MailGroup is PUBLIC, otherwise quit
127 S X=$G(R1(3.62,"1,"_R0("DILIST",2,1)_",",.01,"I")) I X="" K X Q
128 I $$GET1^DIQ(3.8,X_",",4,"I")'="PU" K X Q
129 S X=$G(R1(3.62,"1,"_R0("DILIST",2,1)_",",.01,"E")) I X="" K X Q
130 N XMDUZ,XMTEXT,XMY,MSGTXT,XRAVERF,XRATRANS,XRADFN
131 S X="G."_X,XMY(X)="" K X ;recipient mail group
132 ;
133 S XMDUZ=.5
134 S MSGTXT(1)=$G(^TMP("RARPT-REC",$J,RASUB,"VENDOR"))_" is sending duplicate addenda to Radiology/Nuclear Medicine."
135 S MSGTXT(2)=" "
136 S MSGTXT(3)="The following radiology report was sent with a duplicate addendum:"
137 S:RADFN'="" XRADFN=$$GET1^DIQ(2,RADFN,.01)
138 S:$G(XRADFN)="" XRADFN="Unknown"
139 S MSGTXT(4)=" 1) Patient : "_XRADFN
140 S MSGTXT(5)=" 2) SSN : "_$$SSN^RAUTL()
141 S MSGTXT(6)=" 3) Case Number : "_RALONGCN
142 S:RAVERF'="" XRAVERF=$$GET1^DIQ(200,RAVERF,.01)
143 S:$G(XRAVERF)="" XRAVERF="Unknown"
144 S MSGTXT(7)=" 4) Verifier : "_XRAVERF
145 S:RATRANSC'="" XRATRANS=$$GET1^DIQ(200,RATRANSC,.01)
146 S:$G(XRATRANS)="" XRATRANS="Unknown"
147 S MSGTXT(8)=" 5) Transcriptionist : "_XRATRANS
148 S MSGTXT(9)=" "
149 S MSGTXT(10)="Please notify IRM."
150 S XMTEXT="MSGTXT("
151 D ^XMD
152 Q
153ISITDUP ; X1=last ien ^RARPT, X2=LAST IEN ^TMP, x21=first ien ^TMP
154 Q:'$O(^TMP("RARPT-REC",$J,RASUB,I2,0))
155 N X1,X2,X21,X3,X4,XX
156 S RADUPA=0 ; Reset to zero otherwise Imp Text match will override
157 S X1=$O(^RARPT(RARPT,I1,""),-1)
158 S XX=$G(^RARPT(RARPT,I1,X1,0)) S XX=$S(XX=""!(XX=" "):0,1:1)
159 S X2=$O(^TMP("RARPT-REC",$J,RASUB,I2,""),-1),X21=$O(^(0))
160 S X3=X1-X2+XX Q:X3<1 ; begin comparison from ^RARPT(RARPT,I1,X3
161 ; chk 1st line of previous addendum
162 Q:^RARPT(RARPT,I1,X3,0)'["Addendum: " S X4=^(0)
163 S X4=$E(X4,$L("Addendum: ")+1,$L(X4)) ; exclude "Addendum: " from X4
164 Q:X4'=^TMP("RARPT-REC",$J,RASUB,I2,X21)
165 ; chk remaining lines
166 S X21=X21+1 F X1=X21:1:X2 S X3=X3+1 Q:^RARPT(RARPT,I1,X3,0)'=^TMP("RARPT-REC",$J,RASUB,I2,X1)
167 Q:X1<X2
168 S RADUPA=1
169 Q
Note: See TracBrowser for help on using the repository browser.