- 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 Jan 18, 2025@03:40:12 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