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