- TIUHL7U1 ; SLC/AJB - TIUHL7 Utilities; March 23, 2005
- ;;1.0;TEXT INTEGRATION UTILITIES;**200,228**;Jun 20, 1997
- Q
- ACK(CODE,ERLOC,TIUDA) ;
- N HLA,RESULT,TIUMID,TIUREC,TIUSND
- S HLA("HLA",1)="MSA"_HL("FS")_CODE_HL("FS")_HL("MID")_HL("FS")_$G(HL("RAN"))_HL("FS")_$G(HL("SAN"))
- S TIUMID=$G(HL("MID")),TIUREC=HL("RAN"),TIUSND=HL("SAN")
- I CODE="AR" D
- . N TIUCNT
- . S TIUCNT=0 F S TIUCNT=$O(@ERLOC@("MSGERR",TIUCNT)) Q:'+TIUCNT S HLA("HLA",(TIUCNT+1))=@ERLOC@("MSGERR",TIUCNT)
- . I +$E($G(TIU("SSN")),1,5) D SNDALRT("TIUHL7 rejected an incoming HL7 message from "_TIUSND_" (Msg ID "_TIUMID_".")
- I CODE="AA" D
- . S HLA("HLA",2)="ERR"_TIUFS_TIUFS_TIUFS_TIUFS_+$G(TIUDA)_TIUCS_"Document creation successful."
- I HL("SAN")="HTAPPL" D M @TIU("XTMP")@("MSGRESULT")=HLA("HLS") Q
- . N HL,HLL,HLP,TIUDNS,TIUEVT,TIUFAC,TIULLNK,TIUSUB
- . M HLA("HLS")=HLA("HLA") K HLA("HLA")
- . S TIUEVT="TIUHL7 HTAPPL ACK EVT",TIUSUB="TIUHL7 HTAPPL ACK SUB"
- . I '+$$LU^TIUHL7U1(101,TIUEVT) D SNDALRT("Unable to resolve Event Protocol for ACK to "_TIUSND_".")
- . I '+$$LU^TIUHL7U1(101,TIUSUB) D SNDALRT("Unable to resolve Subscriber Protocol for ACK to "_TIUSND_".")
- . S TIUFAC=$P(TIUMSG(1),TIUFS,4),TIUDNS=$P(TIUFAC,TIUCS,2) ; set facility & DNS address
- . S TIULLNK(1)=$$LU^TIUHL7U1(870,$$UP^XLFSTR(TIUDNS),,,"DNS"),TIULLNK(2)=$$LU^TIUHL7U1(870,$$LOW^XLFSTR(TIUDNS),,,"DNS")
- . S TIULLNK=$S(+TIULLNK(1):TIULLNK(1),+TIULLNK(2):TIULLNK(2),1:0) I '+TIULLNK D SNDALRT("Unable to resolve DNS for ACK to "_TIUSND_".")
- . S TIULLNK=$$GET1^DIQ(870,TIULLNK,.01) ; get logical link associated with DNS
- . D INIT^HLFNC2(TIUEVT,.HL) I +$G(HL) Q
- . S HLP("SUBSCRIBER")="^^^^"_TIUFAC
- . S HLL("LINKS",1)=TIUSUB_U_TIULLNK
- . D GENERATE^HLMA(TIUEVT,"LM",1,.TIURSLT,"",.HLP)
- D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.TIURSLT)
- M @TIU("XTMP")@("MSGRESULT")=HLA("HLA")
- Q
- SNDALRT(MSG) ;
- N XQA,XQAMSG
- S MSG("RECEIVER")=$P($$GETAPP^HLCS2(TIUREC),U),MSG("SENDER")=$P($$GETAPP^HLCS2(TIUSND),U)
- I '+$L(MSG("RECEIVER")),'+$L(MSG("SENDER")) Q
- I +$L(MSG("RECEIVER")) S XQA("G."_MSG("RECEIVER"))=""
- I +$L(MSG("SENDER")) S XQA("G."_MSG("SENDER"))=""
- S XQAMSG=MSG
- I $$SETUP1^XQALERT
- Q
- AUDIT(TIUDA,TIUCKSM0,TIUCKSM1) ; Update audit trail
- N DA,DIC,DIE,DLAYGO,DR,X,Y
- S X=""""_"`"_TIUDA_"""",(DIC,DLAYGO)=8925.5,DIC(0)="FLX" D ^DIC Q:+Y'>0
- S DIE=DIC,DR=".02////"_$$NOW^TIULC_";.03////"_TIU("EBDA")_";.04////"_TIUCKSM0_";.05////"_TIUCKSM1
- S DA=+Y D ^DIE
- Q
- CANEDIT(DA) ; check whether or not document is released
- Q $S(+$P($G(^TIU(8925,+DA,0)),U,5)<4:1,1:0)
- CLASS(CLNAME) ;
- N TIUY S TIUY=+$O(^TIU(8925.1,"B",CLNAME,0))
- 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
- Q TIUY
- CLEAN ; removes messages older than 7 days
- N TIUDT
- S TIUDT=0
- F S TIUDT=$O(^XTMP("TIUHL7",TIUDT)) Q:'+TIUDT D
- . I $$FMDIFF^XLFDT($$NOW^XLFDT,TIUDT)'<7 K ^XTMP("TIUHL7",TIUDT)
- Q
- COMPARE(NAME1,NAME2) ; compare first and last names only
- N NAME,TIUX,TIUY
- S TIUY=0
- I $L(NAME1,",")=1,$L(NAME2,",")=1 S:NAME1=NAME2 TIUY=1 Q TIUY
- S NAME("L1")=$P(NAME1,","),NAME("F1")=$P(NAME1,",",2),NAME("F1")=$P(NAME("F1")," ")
- S NAME("L2")=$P(NAME2,","),NAME("F2")=$P(NAME2,",",2),NAME("F2")=$P(NAME("F2")," ")
- I NAME("L1")=NAME("L2"),NAME("F1")=NAME("F2") S TIUY=1
- Q TIUY
- DELDOC(TIUDA) ;
- N ERR
- D DELETE^TIUSRVP(.ERR,TIUDA,"",1)
- Q
- ERR(TIUSEG,TIUP,TIUNUM,TIUTXT) ;
- S TIU("EC")=TIU("EC")+1
- S @TIUNAME@("MSGERR",TIU("EC"))="ERR"_TIUFS_TIUSEG_TIUFS_TIUP_TIUFS_TIUFS_TIUNUM_TIUCS_TIUTXT
- Q
- GETADMIT(DFN,TIUDT) ;
- N TIUCNT,TIULIST,TIUY S (TIUCNT,TIUY)=0
- I '+$G(TIUDT) Q TIUY
- D:+$G(DFN) ADMITLST^ORWPT(.TIULIST,DFN)
- I $D(TIULIST) D
- . 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)
- . I TIUCNT=0 D ERR("ERR","44","0000.00","ADMISSION not found for "_$$FMTE^XLFDT(TIUDT)_".") Q
- . I TIUCNT=1 S TIULIST="",TIULIST=$O(TIUCNT(TIULIST)),TIU("VSTR")=$P(TIULIST(TIULIST),U,2)_";"_$P(TIULIST(TIULIST),U)_";H",TIUY=1 Q
- . I +TIU("HLOC") D
- . . 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
- Q TIUY
- GETDIV(USER) ;
- N TIUY
- D DIV4^XUSER(.TIUY,USER) I +$D(TIUY) S TIUY="",TIUY=$O(TIUY(TIUY))
- I +$G(TIUY)'>0 S TIUY=$$GET1^DIQ(8989.3,1,217,"I")
- Q TIUY
- GETVISIT(DFN,TIUDT) ;
- N TIUCNT,TIULIST,TIUY
- S (TIUCNT,TIUY)=0
- I '+$G(TIUDT) Q TIUY
- D:+$G(DFN) VST1^ORWCV(.TIULIST,DFN,$P(TIUDT,"."),$$FMADD^XLFDT(TIUDT,1),1)
- I $D(TIULIST) D
- . 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)
- . 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
- . I +TIU("HLOC") D
- . . 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
- Q TIUY
- LU(FILE,NAME,FLAGS,SCREEN,INDEXES) ;
- Q $$FIND1^DIC(FILE,"",$G(FLAGS),NAME,$G(INDEXES),$G(SCREEN),"TIUERR")
- MEMBEROF(TITLE,CLASS) ;
- N TIUY S TIUY=0
- S CLASS=+$$CLASS(CLASS) Q:+CLASS'>0 TIUY
- S TITLE=$$LU(8925.1,TITLE,"X","I $P(^(0),U,4)=""DOC""") Q:+TITLE'>0 TIUY
- S TIUY=+$$ISA^TIULX(TITLE,CLASS)
- Q TIUY
- PNAME(NAME) ;
- N LAST,FIRST
- S LAST=$P(NAME,","),FIRST=$E($P(NAME,",",2),1)
- Q LAST_","_FIRST
- REMESC(TIUSTR) ;
- ; Remove Escape Characters from HL7 Message Text
- ; Escape Sequence codes:
- ; F = field separator (TIUFS)
- ; S = component separator (TIUCS)
- ; R = repitition separator (TIURS)
- ; E = escape character (TIUES)
- ; T = subcomponent separator (TIUSS)
- N I1,I2,J1,J2,K,TIUCHR,TIUREP,VALUE
- 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)
- S TIUSTR=$$REPLACE^XLFSTR(TIUSTR,.TIUREP)
- F S I1=$P(TIUSTR,TIUES_"X") Q:$L(I1)=$L(TIUSTR) D
- .S I2=$P(TIUSTR,TIUES_"X",2,99)
- .S J1=$P(I2,TIUES) Q:'$L(J1)
- .S J2=$P(I2,TIUES,2,99)
- .S VALUE=$$BASE^XLFUTL($$UP^XLFSTR(J1),16,10)
- .S K=$S(VALUE>255:"?",VALUE<32!(VALUE>127&(VALUE<160)):"",1:$C(VALUE))
- .S TIUSTR=I1_K_J2
- Q TIUSTR
- SIGNDOC(TIUDA) ;
- N TIUDEL
- I $G(TIU("COMP"))="LA",'+TIU("EC") D
- . I '+$G(TIU("SIGNED")),'+$G(TIU("CSIGNED")) D Q
- . . 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.")
- . I +TIU("SIGNED") D
- . . N TIUACT,TIUAUTH,TIUES,TIUSTAT S TIUACT="SIGNATURE",TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("AUDA")) I '+TIUAUTH D
- . . . D ERR("TIU","15","0000.000",$P(TIUAUTH,U,2)) I TIU("AVAIL")="AV" Q
- . . . S TIUDEL=1 D ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.")
- . . I '+$G(TIUDEL) S TIUES=1_U_$$GET1^DIQ(200,TIU("AUDA"),20.2)_U_$$GET1^DIQ(200,TIU("AUDA"),20.3)
- . . I '+$G(TIUDEL) D ES^TIUHL7U2(TIUDA,TIUES,"",TIU("AUDA"))
- . . I '+$G(TIUDEL) S TIUSTAT=$P($G(^TIU(8925,TIUDA,0)),U,5) I TIUSTAT<6,TIU("AVAIL")'="AV" D
- . . . S TIUDEL=1 D ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.")
- . I +TIU("CSIGNED") D
- . . N TIUACT,TIUAUTH,TIUES,TIUSTAT S TIUACT="COSIGNATURE",TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("CSDA")) I '+TIUAUTH D
- . . . D ERR("TIU","29","0000.000",$P(TIUAUTH,U,2)) I TIU("AVAIL")="AV" Q
- . . . S TIUDEL=1 D ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.")
- . . I '+$G(TIUDEL) S TIUES=1_U_$$GET1^DIQ(200,TIU("CSDA"),20.2)_U_$$GET1^DIQ(200,TIU("CSDA"),20.3)
- . . I '+$G(TIUDEL) D ES^TIURS(TIUDA,TIUES,"",TIU("CSDA"))
- . . I '+$G(TIUDEL) S TIUSTAT=$P($G(^TIU(8925,TIUDA,0)),U,5) I TIUSTAT'=7,TIU("AVAIL")'="AV" D
- . . . S TIUDEL=1 D ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.")
- I +$G(TIUDEL) D DELDOC(TIUDA)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUHL7U1 8265 printed Jan 18, 2025@03:42:51 Page 2
- TIUHL7U1 ; SLC/AJB - TIUHL7 Utilities; March 23, 2005
- +1 ;;1.0;TEXT INTEGRATION UTILITIES;**200,228**;Jun 20, 1997
- +2 QUIT
- ACK(CODE,ERLOC,TIUDA) ;
- +1 NEW HLA,RESULT,TIUMID,TIUREC,TIUSND
- +2 SET HLA("HLA",1)="MSA"_HL("FS")_CODE_HL("FS")_HL("MID")_HL("FS")_$GET(HL("RAN"))_HL("FS")_$GET(HL("SAN"))
- +3 SET TIUMID=$GET(HL("MID"))
- SET TIUREC=HL("RAN")
- SET TIUSND=HL("SAN")
- +4 IF CODE="AR"
- Begin DoDot:1
- +5 NEW TIUCNT
- +6 SET TIUCNT=0
- FOR
- SET TIUCNT=$ORDER(@ERLOC@("MSGERR",TIUCNT))
- if '+TIUCNT
- QUIT
- SET HLA("HLA",(TIUCNT+1))=@ERLOC@("MSGERR",TIUCNT)
- +7 IF +$EXTRACT($GET(TIU("SSN")),1,5)
- DO SNDALRT("TIUHL7 rejected an incoming HL7 message from "_TIUSND_" (Msg ID "_TIUMID_".")
- End DoDot:1
- +8 IF CODE="AA"
- Begin DoDot:1
- +9 SET HLA("HLA",2)="ERR"_TIUFS_TIUFS_TIUFS_TIUFS_+$GET(TIUDA)_TIUCS_"Document creation successful."
- End DoDot:1
- +10 IF HL("SAN")="HTAPPL"
- Begin DoDot:1
- +11 NEW HL,HLL,HLP,TIUDNS,TIUEVT,TIUFAC,TIULLNK,TIUSUB
- +12 MERGE HLA("HLS")=HLA("HLA")
- KILL HLA("HLA")
- +13 SET TIUEVT="TIUHL7 HTAPPL ACK EVT"
- SET TIUSUB="TIUHL7 HTAPPL ACK SUB"
- +14 IF '+$$LU^TIUHL7U1(101,TIUEVT)
- DO SNDALRT("Unable to resolve Event Protocol for ACK to "_TIUSND_".")
- +15 IF '+$$LU^TIUHL7U1(101,TIUSUB)
- DO SNDALRT("Unable to resolve Subscriber Protocol for ACK to "_TIUSND_".")
- +16 ; set facility & DNS address
- SET TIUFAC=$PIECE(TIUMSG(1),TIUFS,4)
- SET TIUDNS=$PIECE(TIUFAC,TIUCS,2)
- +17 SET TIULLNK(1)=$$LU^TIUHL7U1(870,$$UP^XLFSTR(TIUDNS),,,"DNS")
- SET TIULLNK(2)=$$LU^TIUHL7U1(870,$$LOW^XLFSTR(TIUDNS),,,"DNS")
- +18 SET TIULLNK=$SELECT(+TIULLNK(1):TIULLNK(1),+TIULLNK(2):TIULLNK(2),1:0)
- IF '+TIULLNK
- DO SNDALRT("Unable to resolve DNS for ACK to "_TIUSND_".")
- +19 ; get logical link associated with DNS
- SET TIULLNK=$$GET1^DIQ(870,TIULLNK,.01)
- +20 DO INIT^HLFNC2(TIUEVT,.HL)
- IF +$GET(HL)
- QUIT
- +21 SET HLP("SUBSCRIBER")="^^^^"_TIUFAC
- +22 SET HLL("LINKS",1)=TIUSUB_U_TIULLNK
- +23 DO GENERATE^HLMA(TIUEVT,"LM",1,.TIURSLT,"",.HLP)
- End DoDot:1
- MERGE @TIU("XTMP")@("MSGRESULT")=HLA("HLS")
- QUIT
- +24 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.TIURSLT)
- +25 MERGE @TIU("XTMP")@("MSGRESULT")=HLA("HLA")
- +26 QUIT
- SNDALRT(MSG) ;
- +1 NEW XQA,XQAMSG
- +2 SET MSG("RECEIVER")=$PIECE($$GETAPP^HLCS2(TIUREC),U)
- SET MSG("SENDER")=$PIECE($$GETAPP^HLCS2(TIUSND),U)
- +3 IF '+$LENGTH(MSG("RECEIVER"))
- IF '+$LENGTH(MSG("SENDER"))
- QUIT
- +4 IF +$LENGTH(MSG("RECEIVER"))
- SET XQA("G."_MSG("RECEIVER"))=""
- +5 IF +$LENGTH(MSG("SENDER"))
- SET XQA("G."_MSG("SENDER"))=""
- +6 SET XQAMSG=MSG
- +7 IF $$SETUP1^XQALERT
- +8 QUIT
- AUDIT(TIUDA,TIUCKSM0,TIUCKSM1) ; Update audit trail
- +1 NEW DA,DIC,DIE,DLAYGO,DR,X,Y
- +2 SET X=""""_"`"_TIUDA_""""
- SET (DIC,DLAYGO)=8925.5
- SET DIC(0)="FLX"
- DO ^DIC
- if +Y'>0
- QUIT
- +3 SET DIE=DIC
- SET DR=".02////"_$$NOW^TIULC_";.03////"_TIU("EBDA")_";.04////"_TIUCKSM0_";.05////"_TIUCKSM1
- +4 SET DA=+Y
- DO ^DIE
- +5 QUIT
- CANEDIT(DA) ; check whether or not document is released
- +1 QUIT $SELECT(+$PIECE($GET(^TIU(8925,+DA,0)),U,5)<4:1,1:0)
- CLASS(CLNAME) ;
- +1 NEW TIUY
- SET TIUY=+$ORDER(^TIU(8925.1,"B",CLNAME,0))
- +2 IF +TIUY>0
- IF $SELECT($PIECE($GET(^TIU(8925.1,+TIUY,0)),U,4)="CL":0,$PIECE($GET(^(0)),U,4)="DC":0,1:1)
- SET TIUY=0
- +3 QUIT TIUY
- CLEAN ; removes messages older than 7 days
- +1 NEW TIUDT
- +2 SET TIUDT=0
- +3 FOR
- SET TIUDT=$ORDER(^XTMP("TIUHL7",TIUDT))
- if '+TIUDT
- QUIT
- Begin DoDot:1
- +4 IF $$FMDIFF^XLFDT($$NOW^XLFDT,TIUDT)'<7
- KILL ^XTMP("TIUHL7",TIUDT)
- End DoDot:1
- +5 QUIT
- COMPARE(NAME1,NAME2) ; compare first and last names only
- +1 NEW NAME,TIUX,TIUY
- +2 SET TIUY=0
- +3 IF $LENGTH(NAME1,",")=1
- IF $LENGTH(NAME2,",")=1
- if NAME1=NAME2
- SET TIUY=1
- QUIT TIUY
- +4 SET NAME("L1")=$PIECE(NAME1,",")
- SET NAME("F1")=$PIECE(NAME1,",",2)
- SET NAME("F1")=$PIECE(NAME("F1")," ")
- +5 SET NAME("L2")=$PIECE(NAME2,",")
- SET NAME("F2")=$PIECE(NAME2,",",2)
- SET NAME("F2")=$PIECE(NAME("F2")," ")
- +6 IF NAME("L1")=NAME("L2")
- IF NAME("F1")=NAME("F2")
- SET TIUY=1
- +7 QUIT TIUY
- DELDOC(TIUDA) ;
- +1 NEW ERR
- +2 DO DELETE^TIUSRVP(.ERR,TIUDA,"",1)
- +3 QUIT
- ERR(TIUSEG,TIUP,TIUNUM,TIUTXT) ;
- +1 SET TIU("EC")=TIU("EC")+1
- +2 SET @TIUNAME@("MSGERR",TIU("EC"))="ERR"_TIUFS_TIUSEG_TIUFS_TIUP_TIUFS_TIUFS_TIUNUM_TIUCS_TIUTXT
- +3 QUIT
- GETADMIT(DFN,TIUDT) ;
- +1 NEW TIUCNT,TIULIST,TIUY
- SET (TIUCNT,TIUY)=0
- +2 IF '+$GET(TIUDT)
- QUIT TIUY
- +3 if +$GET(DFN)
- DO ADMITLST^ORWPT(.TIULIST,DFN)
- +4 IF $DATA(TIULIST)
- Begin DoDot:1
- +5 SET TIULIST=""
- FOR
- SET TIULIST=$ORDER(TIULIST(TIULIST))
- if '+TIULIST
- QUIT
- IF $PIECE($PIECE(TIULIST(TIULIST),U),".")=$PIECE(TIUDT,".")
- SET TIUCNT=TIUCNT+1
- SET TIUCNT(TIULIST)=TIULIST(TIULIST)
- +6 IF TIUCNT=0
- DO ERR("ERR","44","0000.00","ADMISSION not found for "_$$FMTE^XLFDT(TIUDT)_".")
- QUIT
- +7 IF TIUCNT=1
- SET TIULIST=""
- SET TIULIST=$ORDER(TIUCNT(TIULIST))
- SET TIU("VSTR")=$PIECE(TIULIST(TIULIST),U,2)_";"_$PIECE(TIULIST(TIULIST),U)_";H"
- SET TIUY=1
- QUIT
- +8 IF +TIU("HLOC")
- Begin DoDot:2
- +9 SET TIULIST=""
- FOR
- SET TIULIST=$ORDER(TIUCNT(TIULIST))
- if '+TIULIST!(+TIUY)
- QUIT
- IF $PIECE(TIUCNT(TIULIST),U,2)=TIU("HLOC")
- SET TIU("VSTR")=TIU("HLOC")_";"_$PIECE(TIUCNT(TIULIST),U)_";H"
- SET TIUY=1
- End DoDot:2
- End DoDot:1
- +10 QUIT TIUY
- GETDIV(USER) ;
- +1 NEW TIUY
- +2 DO DIV4^XUSER(.TIUY,USER)
- IF +$DATA(TIUY)
- SET TIUY=""
- SET TIUY=$ORDER(TIUY(TIUY))
- +3 IF +$GET(TIUY)'>0
- SET TIUY=$$GET1^DIQ(8989.3,1,217,"I")
- +4 QUIT TIUY
- GETVISIT(DFN,TIUDT) ;
- +1 NEW TIUCNT,TIULIST,TIUY
- +2 SET (TIUCNT,TIUY)=0
- +3 IF '+$GET(TIUDT)
- QUIT TIUY
- +4 if +$GET(DFN)
- DO VST1^ORWCV(.TIULIST,DFN,$PIECE(TIUDT,"."),$$FMADD^XLFDT(TIUDT,1),1)
- +5 IF $DATA(TIULIST)
- Begin DoDot:1
- +6 SET TIULIST=""
- FOR
- SET TIULIST=$ORDER(TIULIST(TIULIST))
- if '+TIULIST
- QUIT
- IF $PIECE($PIECE(TIULIST(TIULIST),U,2),".")=$PIECE(TIUDT,".")
- SET TIUCNT=TIUCNT+1
- SET TIUCNT(TIULIST)=TIULIST(TIULIST)
- +7 IF TIUCNT=1
- SET TIULIST=""
- SET TIULIST=$ORDER(TIUCNT(TIULIST))
- SET TIU("VSTR")=$PIECE($PIECE(TIULIST(TIULIST),U),";",3)_";"_$PIECE(TIULIST(TIULIST),U,2)_";"_$SELECT(TIU("AVAIL")="AV":"E",1:"A")
- SET TIUY=1
- QUIT
- +8 IF +TIU("HLOC")
- Begin DoDot:2
- +9 SET TIULIST=""
- FOR
- SET TIULIST=$ORDER(TIUCNT(TIULIST))
- if '+TIULIST!(+TIUY)
- QUIT
- IF $PIECE($PIECE(TIULIST(TIULIST),U),";",3)=TIU("HLOC")
- SET TIU("VSTR")=TIU("HLOC")_";"_$PIECE(TIULIST(TIULIST),U,2)_";"_$SELECT(TIU("AVAIL")="AV":"E",1:"A")
- SET TIUY=1
- End DoDot:2
- End DoDot:1
- +10 QUIT TIUY
- LU(FILE,NAME,FLAGS,SCREEN,INDEXES) ;
- +1 QUIT $$FIND1^DIC(FILE,"",$GET(FLAGS),NAME,$GET(INDEXES),$GET(SCREEN),"TIUERR")
- MEMBEROF(TITLE,CLASS) ;
- +1 NEW TIUY
- SET TIUY=0
- +2 SET CLASS=+$$CLASS(CLASS)
- if +CLASS'>0
- QUIT TIUY
- +3 SET TITLE=$$LU(8925.1,TITLE,"X","I $P(^(0),U,4)=""DOC""")
- if +TITLE'>0
- QUIT TIUY
- +4 SET TIUY=+$$ISA^TIULX(TITLE,CLASS)
- +5 QUIT TIUY
- PNAME(NAME) ;
- +1 NEW LAST,FIRST
- +2 SET LAST=$PIECE(NAME,",")
- SET FIRST=$EXTRACT($PIECE(NAME,",",2),1)
- +3 QUIT LAST_","_FIRST
- REMESC(TIUSTR) ;
- +1 ; Remove Escape Characters from HL7 Message Text
- +2 ; Escape Sequence codes:
- +3 ; F = field separator (TIUFS)
- +4 ; S = component separator (TIUCS)
- +5 ; R = repitition separator (TIURS)
- +6 ; E = escape character (TIUES)
- +7 ; T = subcomponent separator (TIUSS)
- +8 NEW I1,I2,J1,J2,K,TIUCHR,TIUREP,VALUE
- +9 FOR TIUCHR="F","S","R","E","T"
- SET TIUREP(TIUES_TIUCHR_TIUES)=$SELECT(TIUCHR="F":TIUFS,TIUCHR="S":TIUCS,TIUCHR="R":TIURS,TIUCHR="E":TIUES,TIUCHR="T":TIUSS)
- +10 SET TIUSTR=$$REPLACE^XLFSTR(TIUSTR,.TIUREP)
- +11 FOR
- SET I1=$PIECE(TIUSTR,TIUES_"X")
- if $LENGTH(I1)=$LENGTH(TIUSTR)
- QUIT
- Begin DoDot:1
- +12 SET I2=$PIECE(TIUSTR,TIUES_"X",2,99)
- +13 SET J1=$PIECE(I2,TIUES)
- if '$LENGTH(J1)
- QUIT
- +14 SET J2=$PIECE(I2,TIUES,2,99)
- +15 SET VALUE=$$BASE^XLFUTL($$UP^XLFSTR(J1),16,10)
- +16 SET K=$SELECT(VALUE>255:"?",VALUE<32!(VALUE>127&(VALUE<160)):"",1:$CHAR(VALUE))
- +17 SET TIUSTR=I1_K_J2
- End DoDot:1
- +18 QUIT TIUSTR
- SIGNDOC(TIUDA) ;
- +1 NEW TIUDEL
- +2 IF $GET(TIU("COMP"))="LA"
- IF '+TIU("EC")
- Begin DoDot:1
- +3 IF '+$GET(TIU("SIGNED"))
- IF '+$GET(TIU("CSIGNED"))
- Begin DoDot:2
- +4 IF TIU("AVAIL")'="AV"
- DO DELDOC(TIUDA)
- DO ERR("TIU","","2100.040","SIGNATURE DATE[TIME] missing from HL7 message & availability not 'AV'; document has been deleted.")
- End DoDot:2
- QUIT
- +5 IF +TIU("SIGNED")
- Begin DoDot:2
- +6 NEW TIUACT,TIUAUTH,TIUES,TIUSTAT
- SET TIUACT="SIGNATURE"
- SET TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("AUDA"))
- IF '+TIUAUTH
- Begin DoDot:3
- +7 DO ERR("TIU","15","0000.000",$PIECE(TIUAUTH,U,2))
- IF TIU("AVAIL")="AV"
- QUIT
- +8 SET TIUDEL=1
- DO ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.")
- End DoDot:3
- +9 IF '+$GET(TIUDEL)
- SET TIUES=1_U_$$GET1^DIQ(200,TIU("AUDA"),20.2)_U_$$GET1^DIQ(200,TIU("AUDA"),20.3)
- +10 IF '+$GET(TIUDEL)
- DO ES^TIUHL7U2(TIUDA,TIUES,"",TIU("AUDA"))
- +11 IF '+$GET(TIUDEL)
- SET TIUSTAT=$PIECE($GET(^TIU(8925,TIUDA,0)),U,5)
- IF TIUSTAT<6
- IF TIU("AVAIL")'="AV"
- Begin DoDot:3
- +12 SET TIUDEL=1
- DO ERR("TIU","","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.")
- End DoDot:3
- End DoDot:2
- +13 IF +TIU("CSIGNED")
- Begin DoDot:2
- +14 NEW TIUACT,TIUAUTH,TIUES,TIUSTAT
- SET TIUACT="COSIGNATURE"
- SET TIUAUTH=$$CANDO^TIULP(TIUDA,TIUACT,TIU("CSDA"))
- IF '+TIUAUTH
- Begin DoDot:3
- +15 DO ERR("TIU","29","0000.000",$PIECE(TIUAUTH,U,2))
- IF TIU("AVAIL")="AV"
- QUIT
- +16 SET TIUDEL=1
- DO ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.")
- End DoDot:3
- +17 IF '+$GET(TIUDEL)
- SET TIUES=1_U_$$GET1^DIQ(200,TIU("CSDA"),20.2)_U_$$GET1^DIQ(200,TIU("CSDA"),20.3)
- +18 IF '+$GET(TIUDEL)
- DO ES^TIURS(TIUDA,TIUES,"",TIU("CSDA"))
- +19 IF '+$GET(TIUDEL)
- SET TIUSTAT=$PIECE($GET(^TIU(8925,TIUDA,0)),U,5)
- IF TIUSTAT'=7
- IF TIU("AVAIL")'="AV"
- Begin DoDot:3
- +20 SET TIUDEL=1
- DO ERR("TIU","29","0000.000","Legal authentication failed & availability not 'AV'; document has been deleted.")
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 IF +$GET(TIUDEL)
- DO DELDOC(TIUDA)
- +22 QUIT