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