source: FOIAVistA/trunk/r/TEXT_INTEGRATION_UTILITIES-GMRP-TIU/TIUHL7U1.m@ 1614

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1TIUHL7U1 ; SLC/AJB - TIUHL7 Utilities; March 23, 2005
2 ;;1.0;TEXT INTEGRATION UTILITIES;**200**;Jun 20, 1997
3 Q
4ACK(CODE,ERLOC,TIUDA) ;
5 N HLA,RESULT
6 S HLA("HLA",1)="MSA"_HL("FS")_CODE_HL("FS")_HL("MID")_HL("FS")_$G(HL("RAN"))_HL("FS")_$G(HL("SAN"))
7 I CODE="AR" D
8 . N TIUCNT
9 . S TIUCNT=0 F S TIUCNT=$O(@ERLOC@("MSGERR",TIUCNT)) Q:'+TIUCNT S HLA("HLA",(TIUCNT+1))=@ERLOC@("MSGERR",TIUCNT)
10 . D SNDALRT
11 I CODE="AA" D
12 . S HLA("HLA",2)=+$G(TIUDA)_TIUCS_"Document creation successful."
13 D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.RESULT)
14 M @TIU("XTMP")@("MSGRESULT")=HLA("HLA")
15 Q
16AUDIT(TIUDA,TIUCKSM0,TIUCKSM1) ; Update audit trail
17 N DIC,DIE,DA,DR,X,Y
18 S X=""""_"`"_TIUDA_"""",(DIC,DLAYGO)=8925.5,DIC(0)="FLX" D ^DIC Q:+Y'>0
19 S DIE=DIC,DR=".02////"_$$NOW^TIULC_";.03////"_TIU("EBDA")_";.04////"_TIUCKSM0_";.05////"_TIUCKSM1
20 S DA=+Y D ^DIE
21 Q
22CANEDIT(DA) ; check whether or not document is released
23 Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<4:1,1:0)
24CLASS(CLNAME) ;
25 N TIUY S TIUY=+$O(^TIU(8925.1,"B",CLNAME,0))
26 I +TIUY>0,$S($P($G(^TIU(8925.1,+TIUY,0)),U,4)="CL":0,$P($G(^(0)),U,4)="DC":0,1:1) S TIUY=0
27 Q TIUY
28CLEAN ; removes messages older than 7 days
29 N TIUDT
30 S TIUDT=0
31 F S TIUDT=$O(^XTMP("TIUHL7",TIUDT)) Q:'+TIUDT D
32 . I $$FMDIFF^XLFDT($$NOW^XLFDT,TIUDT)'<7 K ^XTMP("TIUHL7",TIUDT)
33 Q
34COMPARE(NAME1,NAME2) ; compare first and last names only
35 N NAME,TIUX,TIUY
36 S TIUY=0
37 I $L(NAME1,",")=1,$L(NAME2,",")=1 S:NAME1=NAME2 TIUY=1 Q TIUY
38 S NAME("L1")=$P(NAME1,","),NAME("F1")=$P(NAME1,",",2),NAME("F1")=$P(NAME("F1")," ")
39 S NAME("L2")=$P(NAME2,","),NAME("F2")=$P(NAME2,",",2),NAME("F2")=$P(NAME("F2")," ")
40 I NAME("L1")=NAME("L2"),NAME("F1")=NAME("F2") S TIUY=1
41 Q TIUY
42DELDOC(TIUDA) ;
43 N ERR
44 D DELETE^TIUSRVP(.ERR,TIUDA,"",1)
45 Q
46ERR(TIUSEG,TIUP,TIUNUM,TIUTXT) ;
47 S TIU("EC")=TIU("EC")+1
48 S @TIUNAME@("MSGERR",TIU("EC"))="ERR"_TIUFS_TIUSEG_TIUFS_TIUP_TIUFS_TIUFS_TIUNUM_TIUCS_TIUTXT
49 Q
50GETADMIT(DFN,TIUDT) ;
51 N TIUCNT,TIULIST,TIUY S (TIUCNT,TIUY)=0
52 I '+$G(TIUDT) Q TIUY
53 D:+$G(DFN) ADMITLST^ORWPT(.TIULIST,DFN)
54 I $D(TIULIST) D
55 . S TIULIST="" F S TIULIST=$O(TIULIST(TIULIST)) Q:'+TIULIST I $P($P(TIULIST(TIULIST),U),".")=$P(TIUDT,".") S TIUCNT=TIUCNT+1,TIUCNT(TIULIST)=TIULIST(TIULIST)
56 . I TIUCNT=0 D ERR("ERR","44","0000.00","ADMISSION not found for "_$$FMTE^XLFDT(TIUDT)_".") Q
57 . I TIUCNT=1 S TIULIST="",TIULIST=$O(TIUCNT(TIULIST)),TIU("VSTR")=$P(TIULIST(TIULIST),U,2)_";"_$P(TIULIST(TIULIST),U)_";H",TIUY=1 Q
58 . I +TIU("HLOC") D
59 . . S TIULIST="" F S TIULIST=$O(TIUCNT(TIULIST)) Q:'+TIULIST!(+TIUY) I $P(TIUCNT(TIULIST),U,2)=TIU("HLOC") S TIU("VSTR")=TIU("HLOC")_";"_$P(TIUCNT(TIULIST),U)_";H",TIUY=1
60 Q TIUY
61GETDIV(USER) ;
62 N TIUY
63 D DIV4^XUSER(.TIUY,USER) I +$D(TIUY) S TIUY="",TIUY=$O(TIUY(TIUY))
64 I +$G(TIUY)'>0 S TIUY=$$GET1^DIQ(8989.3,1,217,"I")
65 Q TIUY
66GETVISIT(DFN,TIUDT) ;
67 N TIUCNT,TIULIST,TIUY
68 S (TIUCNT,TIUY)=0
69 I '+$G(TIUDT) Q TIUY
70 D:+$G(DFN) VST1^ORWCV(.TIULIST,DFN,$P(TIUDT,"."),$$FMADD^XLFDT(TIUDT,1),1)
71 I $D(TIULIST) D
72 . S TIULIST="" F S TIULIST=$O(TIULIST(TIULIST)) Q:'+TIULIST I $P($P(TIULIST(TIULIST),U,2),".")=$P(TIUDT,".") S TIUCNT=TIUCNT+1,TIUCNT(TIULIST)=TIULIST(TIULIST)
73 . I TIUCNT=1 S TIULIST="",TIULIST=$O(TIUCNT(TIULIST)),TIU("VSTR")=$P($P(TIULIST(TIULIST),U),";",3)_";"_$P(TIULIST(TIULIST),U,2)_";"_$S(TIU("AVAIL")="AV":"E",1:"A"),TIUY=1 Q
74 . I +TIU("HLOC") D
75 . . S TIULIST="" F S TIULIST=$O(TIUCNT(TIULIST)) Q:'+TIULIST!(+TIUY) I $P($P(TIULIST(TIULIST),U),";",3)=TIU("HLOC") S TIU("VSTR")=TIU("HLOC")_";"_$P(TIULIST(TIULIST),U,2)_";"_$S(TIU("AVAIL")="AV":"E",1:"A"),TIUY=1
76 Q TIUY
77LU(FILE,NAME,FLAGS,SCREEN,INDEXES) ;
78 Q $$FIND1^DIC(FILE,"",$G(FLAGS),NAME,$G(INDEXES),$G(SCREEN),"TIUERR")
79MEMBEROF(TITLE,CLASS) ;
80 N TIUY S TIUY=0
81 S CLASS=+$$CLASS(CLASS) Q:+CLASS'>0 TIUY
82 S TITLE=$$LU(8925.1,TITLE,"X","I $P(^(0),U,4)=""DOC""") Q:+TITLE'>0 TIUY
83 S TIUY=+$$ISA^TIULX(TITLE,CLASS)
84 Q TIUY
85PNAME(NAME) ;
86 N LAST,FIRST
87 S LAST=$P(NAME,","),FIRST=$E($P(NAME,",",2),1)
88 Q LAST_","_FIRST
89REMESC(TIUSTR) ;
90 ; Remove Escape Characters from HL7 Message Text
91 ; Escape Sequence codes:
92 ; F = field separator (TIUFS)
93 ; S = component separator (TIUCS)
94 ; R = repitition separator (TIURS)
95 ; E = escape character (TIUES)
96 ; T = subcomponent separator (TIUSS)
97 N I1,I2,J1,J2,K,TIUCHR,TIUREP,VALUE
98 F TIUCHR="F","S","R","E","T" S TIUREP(TIUES_TIUCHR_TIUES)=$S(TIUCHR="F":TIUFS,TIUCHR="S":TIUCS,TIUCHR="R":TIURS,TIUCHR="E":TIUES,TIUCHR="T":TIUSS)
99 S TIUSTR=$$REPLACE^XLFSTR(TIUSTR,.TIUREP)
100 F S I1=$P(TIUSTR,TIUES_"X") Q:$L(I1)=$L(TIUSTR) D
101 .S I2=$P(TIUSTR,TIUES_"X",2,99)
102 .S J1=$P(I2,TIUES) Q:'$L(J1)
103 .S J2=$P(I2,TIUES,2,99)
104 .S VALUE=$$BASE^XLFUTL($$UP^XLFSTR(J1),16,10)
105 .S K=$S(VALUE>255:"?",VALUE<32!(VALUE>127&(VALUE<160)):"",1:$C(VALUE))
106 .S TIUSTR=I1_K_J2
107 Q TIUSTR
108SIGNDOC(TIUDA) ;
109 N TIUDEL
110 I $G(TIU("COMP"))="LA",'+TIU("EC") D
111 . I '+$G(TIU("SIGNED")),'+$G(TIU("CSIGNED")) D Q
112 . . I TIU("AVAIL")'="AV" D DELDOC(TIUDA),ERR("TIU","","2100.040","SIGNATURE DATE[TIME] missing from HL7 message & availability not 'AV'; document has been deleted.")
113 . I +TIU("SIGNED") D
114 . . N TIUACT,TIUAUTH,TIUES,TIUSTAT S TIUACT="SIGNATURE",TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("AUDA")) I '+TIUAUTH D
115 . . . D ERR("TIU","15","0000.000",$P(TIUAUTH,U,2)) I TIU("AVAIL")="AV" Q
116 . . . S TIUDEL=1 D ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.")
117 . . I '+$G(TIUDEL) S TIUES=1_U_$$GET1^DIQ(200,TIU("AUDA"),20.2)_U_$$GET1^DIQ(200,TIU("AUDA"),20.3)
118 . . I '+$G(TIUDEL) D ES^TIUHL7U2(TIUDA,TIUES,"",TIU("AUDA"))
119 . . I '+$G(TIUDEL) S TIUSTAT=$P($G(^TIU(8925,TIUDA,0)),U,5) I TIUSTAT<6,TIU("AVAIL")'="AV" D
120 . . . S TIUDEL=1 D ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.")
121 . I +TIU("CSIGNED") D
122 . . N TIUACT,TIUAUTH,TIUES,TIUSTAT S TIUACT="COSIGNATURE",TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("CSDA")) I '+TIUAUTH D
123 . . . D ERR("TIU","29","0000.000",$P(TIUAUTH,U,2)) I TIU("AVAIL")="AV" Q
124 . . . S TIUDEL=1 D ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.")
125 . . I '+$G(TIUDEL) S TIUES=1_U_$$GET1^DIQ(200,TIU("CSDA"),20.2)_U_$$GET1^DIQ(200,TIU("CSDA"),20.3)
126 . . I '+$G(TIUDEL) D ES^TIURS(TIUDA,TIUES,"",TIU("CSDA"))
127 . . I '+$G(TIUDEL) S TIUSTAT=$P($G(^TIU(8925,TIUDA,0)),U,5) I TIUSTAT'=7,TIU("AVAIL")'="AV" D
128 . . . S TIUDEL=1 D ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.")
129 I +$G(TIUDEL) D DELDOC(TIUDA)
130 Q
131SNDALRT ;
132 N TIUCNT,XQA,XQAMSG
133 I '+$G(TIUDPRM(4)) Q
134 F TIUCNT=1:1:$L(TIUDPRM(4),U) S:+$P(TIUDPRM(4),U,TIUCNT) XQA($P(TIUDPRM(4),U,TIUCNT))=""
135 S XQAMSG="TIUHL7 has encountered an error during message ["_HL("MID")_"] processing."
136 D SETUP^XQALERT
137 Q
Note: See TracBrowser for help on using the repository browser.