Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIUCCHL7UT

TIUCCHL7UT.m

Go to the documentation of this file.
  1. TIUCCHL7UT ; CCRA/PB - TIUCCRA HSRM Msg Processing; November 3, 2020
  1. ;;1.0;TEXT INTEGRATION UTILITIES;**337,344,356**;Sep 27, 2023;Build 26
  1. ;
  1. ;PB - Patch 344 to modify how the note and addendum text is formatted
  1. ;PB - Patch 356 modifications to file the note as a stand-alone note and not linked to a consult
  1. Q
  1. ;
  1. TIUC(X) ; Check each segment of the CCRA TIU notes for HL7 control characters
  1. Q:$G(X)=""
  1. I $G(X)[$C(13,10,10) S X=$TR(X,$C(13,10,10),"") ; <cr><lf><lf>
  1. I $G(X)[$C(13,10) S X=$TR(X,$C(13,10),"") ; <cr><lf>
  1. I $G(X)[$C(13) S X=$TR(X,$C(13),"") ; TERM char
  1. I $G(X)[$C(1) S X=$TR(X,$C(1),"") ; SOH
  1. I $G(X)[$C(2) S X=$TR(X,$C(2),"") ; STX
  1. I $G(X)[$C(3) S X=$TR(X,$C(3),"") ; ETX
  1. I $G(X)[$C(4) S X=$TR(X,$C(4),"") ; EOT
  1. I $G(X)[$C(5) S X=$TR(X,$C(5),"") ; ENQ
  1. I $G(X)[$C(6) S X=$TR(X,$C(6),"") ; ACK
  1. I $G(X)[$C(21) S X=$TR(X,$C(21),"") ; NAK
  1. I $G(X)[$C(23) S X=$TR(X,$C(23),"") ; ETB
  1. I $G(X)[$C(11) S X=$TR(X,$C(11)," ") ; TAB with space
  1. I $G(X)[$C(160) S X=$TR(X,$C(160)," ") ; Inverted question mark formatting from HSRM
  1. Q X
  1. ;
  1. ANAK(MSGID,MSGTEXT,CONID) ; Application Error
  1. N PATNAME,EID,EIDS,MSGN,SITE,CONPAT,CS,FS,RS,ES,SS,RES,ICN ;Jan 21,2020 - PB - patch 735 new and then set FS,CS,RS,ES,SS
  1. ;D INIT^HLFNC2("TIU CCRA-HSRM MDM-T02 SERVER",.HL)
  1. S HL("FS")="|",HL("ECH")="^~\&"
  1. S CS=$E($G(HL("ECH")),1) S:CS="" CS="^"
  1. S RS=$E($G(HL("ECH")),2) S:RS="" RS="~"
  1. S ES=$E($G(HL("ECH")),3) S:ES="" ES="\"
  1. S SS=$E($G(HL("ECH")),4) S:SS="" SS="&"
  1. Q:$G(MSGTEXT)=""
  1. Q:$G(CONID)=""
  1. S CONPAT=$$GET1^DIQ(123,CONID_",",.02,"I")
  1. S:$G(CONPAT)>0 PATNAME=$$GET1^DIQ(123,CONID_",",.02,"E")
  1. S:$G(CONPAT)'>0 PATNAME=$$GET1^DIQ(123,$G(DFN)_",",.02,"E")
  1. S SITE=$$KSP^XUPARAM("INST")
  1. S:$G(ICN)="" ICN=$$GET1^DIQ(2,CONPAT_",",991.1,"E")
  1. I $G(ICN)="" S ICN="NOT IN MSG"
  1. S EID=$G(HL("EID"))
  1. S EIDS=$G(HL("EIDS"))
  1. S MSGN=$G(HL("MID"))
  1. ;S HLA("HLA",1)="MSA|AE|"_$G(MSGN)_"|"_$G(USERMAIL)_" "_$G(NAKMSG)_"|||"_$G(ICN)_"^"_$G(PATNAME)_"^"_SITE_"^"_CONID_"^"_APTTM
  1. S HLA("HLA",1)="MSA"_HL("FS")_"AE"_HL("FS")_$G(MSGID)_HL("FS")_$G(TIUEMAIL)_" "_$G(MSGTEXT)_HL("FS")_HL("FS")_HL("FS")_$G(ICN)_"^"_$G(TIU("PTNAME"))_"^"_SITE_"^"_CONID_"^"_$$FMTHL7^XLFDT($$NOW^XLFDT())
  1. D GENACK^HLMA1(EID,$G(HLMTIENS),EIDS,"LM",1,.RES)
  1. Q
  1. ERR(TIUSEG,TIUP,TIUNUM,TIUTXT) ;
  1. S TIU("EC")=TIU("EC")+1
  1. S @TIUNAME@("MSGERR",TIU("EC"))="ERR"_TIUFS_TIUSEG_TIUFS_TIUP_TIUFS_TIUFS_TIUNUM_TIUCS_TIUTXT
  1. Q
  1. ACK(MSGID,MSGTEXT,CONID) ; Application Error
  1. N PATNAME,EID,EIDS,MSGN,SITE,CONPAT,CS,FS,RS,ES,SS,RES,ICN ;Jan 21,2020 - PB - patch 735 new and then set FS,CS,RS,ES,SS
  1. ;D INIT^HLFNC2("TIU CCRA-HSRM MDM-T02 SERVER",.HL)
  1. S HL("FS")="|",HL("ECH")="^~\&"
  1. S CS=$E($G(HL("ECH")),1) S:CS="" CS="^"
  1. S RS=$E($G(HL("ECH")),2) S:RS="" RS="~"
  1. S ES=$E($G(HL("ECH")),3) S:ES="" ES="\"
  1. S SS=$E($G(HL("ECH")),4) S:SS="" SS="&"
  1. Q:$G(MSGTEXT)=""
  1. Q:$G(CONID)=""
  1. S CONPAT=$$GET1^DIQ(123,CONID_",",.02,"I")
  1. S:$G(CONPAT)>0 PATNAME=$$GET1^DIQ(123,CONID_",",.02,"E")
  1. S:$G(CONPAT)'>0 PATNAME=$$GET1^DIQ(123,$G(DFN)_",",.02,"E")
  1. S SITE=$$KSP^XUPARAM("INST")
  1. S:$G(ICN)="" ICN=$$GET1^DIQ(2,CONPAT_",",991.1,"E")
  1. I $G(ICN)="" S ICN="NOT IN MSG"
  1. S EID=$G(HL("EID"))
  1. S EIDS=$G(HL("EIDS"))
  1. S MSGN=$G(HL("MID"))
  1. ;S HLA("HLA",1)="MSA|AE|"_$G(MSGN)_"|"_$G(USERMAIL)_" "_$G(NAKMSG)_"|||"_$G(ICN)_"^"_$G(PATNAME)_"^"_SITE_"^"_CONID_"^"_APTTM
  1. S HLA("HLA",1)="MSA"_HL("FS")_"CA"_HL("FS")_$G(MSGID) ;_HL("FS")_$G(TIUEMAIL)_" "_$G(MSGTEXT)_HL("FS")_HL("FS")_HL("FS")_$G(ICN)_"^"_$G(TIU("PTNAME"))_"^"_SITE_"^"_CONID_"^"_$$FMTHL7^XLFDT($$NOW^XLFDT())
  1. D GENACK^HLMA1(EID,$G(HLMTIENS),EIDS,"LM",1,.RES)
  1. Q
  1. ;PB - Sep 23 - Patch 356 changed how to lookup the note in order to file an addendum for the note
  1. TIULKUP(CONSULTID,TITLE,NOTEDATE,NOTENUM) ;
  1. ;CONSULTID = Consult's IEN from file #123
  1. ;TITLE = Note Title IEN from file #8925.1
  1. ;NOTEDATE = date of the original note, use to look up the note in 8925, if the original note date
  1. ; is not available, use the date of the consult to begin the lookup for the note
  1. ;NOTNUM = CCP Note number from the HL7 message for this addendum
  1. S:$G(NOTEDATE)="" NOTEDATE=$$GET1^DIQ(123,CONSULTID_",",.01,"I"),NOTEDATE=$$FMADD^XLFDT(NOTEDATE,,-1)
  1. N TIUIEN,IEN,CCPNUMBER,TIUIEN1
  1. S XX=NOTEDATE,TIUIEN1=0 F S NOTEDATE=$O(^TIU(8925,"F",NOTEDATE)) Q:NOTEDATE'>0 S IEN=0 F S IEN=$O(^TIU(8925,"F",NOTEDATE,IEN)) Q:IEN'>0 D
  1. .Q:$P(^TIU(8925,IEN,0),"^")'=TITLE
  1. .N CONSULT
  1. .S TIUIEN1=0
  1. .K YY
  1. .S YY=0 F S YY=$O(^TIU(8925,IEN,"TEXT",YY)) Q:YY'>0 D
  1. ..Q:TIUIEN1>0
  1. ..I $G(^TIU(8925,IEN,"TEXT",YY,0))["Unique Consult ID: " S CONSULT=$P(^TIU(8925,IEN,"TEXT",YY,0),"_",2)
  1. ..I $G(^TIU(8925,IEN,"TEXT",YY,0))["CCPN Number: " S CCPNUMBER=$P(^TIU(8925,IEN,"TEXT",YY,0)," ",3)
  1. ..I $G(CONSULT)>0,(CONSULT=CONSULTID),($G(CCPNUMBER)=NOTENUM) S TIUIEN1=IEN ;W !,"TIUIEN= ",TIUIEN Q
  1. ..Q:$G(TIUIEN1)>0
  1. ;W !,"TIUIEN1= ",TIUIEN1
  1. Q TIUIEN1
  1. ;added CHECKLST and LIST to lookup the clinic associated with the consult service
  1. CHECKLST(SERVICENAME) ;
  1. ; lookup matching clinic for imaging comm care consults
  1. I $G(SERVICENAME)="" Q 0
  1. N CLINID,CLINIC,CONTITLE,DIVID,LEN,I,XC,RSNAME,SERVICENAMEX
  1. S CLINID=0,DIVID=$$GET1^DIQ(123,CONSULTID_",",81,"E")
  1. S:$G(SERVICENAME)[" - " SERVICENAME=$P(SERVICENAME," - ",1)_"-"_$P(SERVICENAME," - ",2)
  1. S:$G(SERVICENAME)[" -" SERVICENAME=$P(SERVICENAME," -",1)_"-"_$P(SERVICENAME," -",2)
  1. S:$G(SERVICENAME)["- " SERVICENAME=$P(SERVICENAME,"- ",1)_"-"_$P(SERVICENAME,"- ",2)
  1. S LEN=$L(SERVICENAME),XC=1
  1. F I=0:1:LEN I $E(SERVICENAME,I)="-" S XC=XC+1
  1. S CONTITLE=SERVICENAME
  1. S (RSNAME,SERVICENAME)="COM CARE-"_$P(SERVICENAME,"-",2,XC),SERVICENAME=$E(SERVICENAME,1,30) S:$E(SERVICENAME,30)=" " SERVICENAME=$E(SERVICENAME,1,29)
  1. S:$E($P(RSNAME,"-",2),1,3)="DOD" (RSNAME,SERVICENAME)="CC-"_$P(RSNAME,"-",2,XC)
  1. S CLINID=$O(^SC("B",$E($G(SERVICENAME),1,30),""))
  1. I $G(CLINID)'>0 D
  1. .F I=1:1:20 D
  1. ..Q:$G(CLINID)>0
  1. ..I $P($P($T(LIST+I),";;",2),"^",1)=CONTITLE S CLINIC=$P($P($T(LIST+I),";;",2),"^",2),CLINID=$O(^SC("B",$G(CLINIC),"")),SERVICENAME=CLINIC
  1. I CLINID'>0 D
  1. . N LENG,SERVICENAME1
  1. . S LENG=0
  1. . S LENG=$L(SERVICENAME)
  1. . S (SERVICENAME,SERVICENAME1)=$S(LENG>28:$E(SERVICENAME,1,28)_"-X",1:$G(SERVICENAME)_"-X"),CLINID=$O(^SC("B",$G(SERVICENAME1),""))
  1. S SERVICENAMEX=SERVICENAME
  1. ;Need to check to see if the clinic is inactive - is there an SDEC API for this?
  1. N INACT S:$G(CLINID)>0 INACT=$$INACTIVE^SDEC32(CLINID)
  1. I $G(INACT)=1 S (NAKMSG,ERR1)="Clinic "_$P(^SC(CLINID,0),"^")_" is inactive",ABORT="1^"_ERR1 Q 0
  1. ;If no matching clinic found look for com care-other-DIVID (DIVID from the PV! segment)
  1. I CLINID'>0!$G(INACT)=1 S CLINID=$O(^SC("B","COM CARE-OTHER-"_DIVID,"")) S:$G(CLINID)>0 (SERVICENAMEX,SERVICENAME)=$P(^SC(CLINID,0),"^") S:$G(CLINID)'>0 (SERVICENAMEX,SERVICENAME)="COM CARE-OTHER-"_$G(DIVID)
  1. I CLINID'>0!$G(INACT)=1 S CLINID=$O(^SC("B","COM CARE-OTHER","")) S:$G(CLINID)>0 (SERVICENAMEX,SERVICENAME)=$P(^SC(CLINID,0),"^") S:$G(CLINID)'>0 (SERVICENAMEX,SERVICENAME)="COM CARE-OTHER"
  1. Q CLINID
  1. LIST ; List of Imaging Community Care consult titles and clinics
  1. ;;COMMUNITY CARE-IMAGING CT-AUTO^COM CARE-IMAG CT-AUTO
  1. ;;COMMUNITY CARE-IMAGING GENERAL RADIOLOGY-AUTO^COM CARE-IMAG GEN RAD-AUTO
  1. ;;COMMUNITY CARE-IMAGING MAGNETIC RESONANCE IMAGING-AUTO^COM CARE-IMAG MRI-AUTO
  1. ;;COMMUNITY CARE-IMAGING MAMMOGRAPHY DIAGNOSTIC-AUTO^COM CARE-IMAG MAM DIAG-AUTO
  1. ;;COMMUNITY CARE-IMAGING MAMMOGRAPHY SCREEN-AUTO^COM CARE-IMAG MAM SCR-AUTO
  1. ;;COMMUNITY CARE-IMAGING NUCLEAR MEDICINE-AUTO^COM CARE-IMAG NUC MEC-AUTO
  1. ;;COMMUNITY CARE-IMAGING ULTRASOUND-AUTO^COM CARE-IMAG U/S-AUTO
  1. ;;COMMUNITY CARE-CIH BIOFEEDBACK/NEUROFEEDBACK^COM CARE-CIH BIO/NEURO FB
  1. ;;COMMUNITY CARE-CIH CLINICAL/BEHAVIORAL HYPNOTHERAPY^COM CARE-CIH CLIN/BEH HYPNO
  1. ;;COMMUNITY CARE-EMERGENCY TREATMENT APPROVED^COM CARE-EMER TREAT APPR
  1. ;;COMMUNITY CARE-INFERTILITY EVAL ONLY^COM CARE-INFERTILITY EVAL
  1. ;;COMMUNITY CARE-GEC ADULT DAY HEALTH CARE^COM CARE-GEC ADHC
  1. ;;COMMUNITY CARE-GEC NON-SKILLED HOME HEALTH AIDE^COM CARE-GEC NON-SK HHA
  1. ;;COMMUNITY CARE-IMAGING CT COLONOGRAPHY^COM CARE-IMAG CT COLON
  1. ;;COMMUNITY CARE-IMAGING BARIUM ENEMA^COM CARE-IMAG BARIUM ENEMA
  1. ;;COMMUNITY CARE-HOME SLEEP APNEA TEST^COM CARE-HOME SLEEP APNEA
  1. ;;COMMUNITY CARE-PTSD CLINICAL DEMONSTRATION (HBOT)^COM CARE-PTSD CL DEMO (HBOT)
  1. ;;COMMUNITY CARE-TREATMENT RESISTANT DEPRESSION^COM CARE-TRT RESIST DEP
  1. ;;COMMUNITY CARE-HEMATOLOGY/ONCOLOGY^COM CARE-HEMATOLOGY/ONCOLOGY
  1. ;;COMMUNITY CARE-HARDSHIP DETERMINATION^COM CARE-HARDSHIP DETER