source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAHLO4.m@ 952

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

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