TIUCCRHL7P1 ; CCRA/PB - TIU CCRA HL7 Msg Processing; January 6, 2006
;;1.0;TEXT INTEGRATION UTILITIES;**337,344,348,349,352,356,366,371**;Sep 27, 2023;Build 4
;
;PB - Patch 344 to modify how the note and addendum text is formatted
;PB - Patch 348 modification to parse the note text from NTE segments rather than the OBX segment
;PB - Patch 349 modification to parse and file the consult factor from the note and file as a comment with the consult
;NOTES FROM NOV 10: Need to loop thru the XTMP("TIUHL7" temp global and if the last character is
;$C(160), remove it.
;PB - Patch 352 removes the text CF#: from the CFNOTE
;PB - Patch 356 modifications to file the note as a stand-alone note and not linked to a consult
;PB - Patch 371 removes unused code
Q
PROCMSG ;
N DFN,DUZ,CONSULTID,MSGID,TIU,TIUDA,TIUDPRM,TIUDT,TIUERR,TIUI,TIUJ,TIUMSG,TIUELS,STOP,TIUIEN,NOTEDATE,NOTENUM
N TIUEMAIL,TIUNAME,TIUTMP,TIUFS,TIUCS,TIURS,TIUES,TIUSS,TIUZ,VNUM,MSGTEXT,ADDENDUM,CFNOTE,ORIGSTAT,CONSULTID
S ADDENDUM=""
; remove HL7 message entries7 days or older
D CLEAN^TIUHL7U1
S U="^"
S TIUDT=$$NOW^XLFDT
; sets field, component and repetition separators from HL7 Message
S TIUFS=$G(HL("FS")),TIUJ=0 F TIUI="TIUCS","TIURS","TIUES","TIUSS" S TIUJ=TIUJ+1 S @TIUI=$E(HL("ECH"),TIUJ,TIUJ)
; initializes variables and ^XTMP expiration
S TIU="TIU",(TIU("EC"),TIUDA)=0,TIUNAME=$NA(^XTMP("TIUHL7",TIUDT,HLMTIENS)),^XTMP("TIUHL7",0)=$$FMADD^XLFDT(TIUDT,7)_U_TIUDT
S MSGID=HL("MID")
; retrieves HL7 message and stores to temporary global
F TIUI=1:1 X HLNEXT Q:HLQUIT'>0 D
. S @TIUNAME@("MSG",TIUI)=HLNODE,TIUJ=0
. F S TIUJ=$O(HLNODE(TIUJ)) Q:'TIUJ D
. . S @TIUNAME@("MSG",TIUI)=@TIUNAME@("MSG",TIUI)_HLNODE(TIUJ) ;$$TIUC^TIUCCHL7UT(HLNODE(TIUJ))
; places temporary global in local meory & adds EOM flag
M TIUMSG=@TIUNAME@("MSG")
S TIU("XTMP")=TIUNAME,TIUNAME="TIUMSG",TIUI="",TIUI=$O(TIUMSG(TIUI),-1),TIUI=TIUI+1,TIUMSG(TIUI)="EOM"
; verify message format
S TIUI="" F S TIUI=$O(@TIUNAME@(TIUI)) Q:@TIUNAME@(TIUI)="EOM" D
. S TIUJ=$S(TIUI=1:"MSH",TIUI=2:"EVN",TIUI=3:"PID",TIUI=4:"PV1",TIUI=5:"TXA",TIUI=6:"OBX",TIUI>6:"NTE",1:"OBX")
. I $P(@TIUNAME@(TIUI),TIUFS)'=TIUJ D ERR^TIUCCHL7UT("MSG",1,"000.000","Improper/missing message format: "_TIUJ_" segment.")
; get consult id
S CONSULTID=$$REMESC^TIUHL7U1($P($G(@TIUNAME@(4)),TIUFS,20))
; get patient name [required]
S TIU("PTNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($P($P($G(@TIUNAME@(3)),TIUFS,6),TIUCS,1,4),TIUCS)),TIU("PTNAME")=$$REMESC^TIUHL7U1(TIU("PTNAME"))
; get patient ICN/SSN/DFN - order may vary [conditionally required]
S (TIU("DFN"),TIU("ICN"),TIU("SSN"))="" F TIUI=1:1:$L($P($G(@TIUNAME@(3)),U,4),TIURS) S TIUJ=$P($P($G(@TIUNAME@(3)),TIUFS,4),TIURS,TIUI) I +TIUJ>0 D
. S TIU("ICN")=+$P(TIUJ,U,1)
I +$G(TIU("ICN"))'>0 S MSGTEXT="Patient ICN not in HL7 message.",STOP=1 D MESSAGE^TIUCCRHL7P3(MSGID,$G(CONSULTID),MSGTEXT),ANAK^TIUCCHL7UT(MSGID,$G(MSGTEXT),$G(CONSULTID))
Q:$G(STOP)=1
Q:+$G(TIU("ICN"))'>0
S (DFN,TIU("DFN"))=$$GETDFN^MPIF001($P(TIU("ICN"),"V")),TIU("SSN")=$$GET1^DIQ(2,TIU("DFN")_",",.09,"I")
S TIUTMP=$S($P(TIUJ,TIUCS,5)="NI":"ICN",$P(TIUJ,TIUCS,5)="SS":"SSN",$P(TIUJ,TIUCS,5)="PI":"DFN",1:"UNK")
I +TIU("DFN")=-1 S MSGTEXT="Patient not found on VistA ",STOP=1 D MESSAGE^TIUCCRHL7P3(MSGID,$G(CONSULTID),MSGTEXT),ANAK^TIUCCHL7UT(MSGID,$G(MSGTEXT),$G(CONSULTID))
Q:$G(STOP)=1
Q:+TIU("DFN")=-1
; get DOCUMENT TITLE (#8925.1) [required] & set IEN, document title is in TIU("TITLE")
S TIU("TITLE")=$$UPPER^HLFNC($P($G(@TIUNAME@(5)),TIUFS,17)),TIU("TITLE")=$$REMESC^TIUHL7U1(TIU("TITLE"))
S TIU("TITLEB")=$$UPPER^HLFNC($P($G(@TIUNAME@(5)),TIUFS,3)),TIU("TITLEB")=$$REMESC^TIUHL7U1(TIU("TITLEB")),TIU("TITLEB")=$P(TIU("TITLEB"),"^",2)
;patch 344 code below to determine if this is an original note or an addendum
I $G(TIU("TITLEB"))["ADDENDUM" D
.K T2 S T2(" - ")="-" S TIU("TITLEB")=$$REPLACE^XLFSTR(TIU("TITLEB"),.T2) K T2
.S:$G(TIU("TITLEB"))["ADDENDUM" ADDENDUM=$P(TIU("TITLEB"),"-",2)
S TIU("TDA")=$$LU^TIUHL7U1(8925.1,TIU("TITLE"),"X","I $P(^TIU(8925.1,+Y,0),U,4)=""DOC""") I $L(TIU("TITLE"))'>0 S TIU("TITLE")="[UNKNOWN]"
; get VISIT # [optional]
S:$G(TIU("VNUM"))'="" TIU("AVAIL")="AV",TIU("COMP")="LA"
;line of code added below to test filing a note but not linking it to a consult
S TIU("AVAIL")="AV",TIU("COMP")="LA"
S TIU("SIGNED")=$$NOW^TIULC,TIU("CSIGNED")=""
S TIUEMAIL=$$LOW^XLFSTR($P($G(@TIUNAME@(5)),TIUFS,10))
I $L(TIUEMAIL)'>0 S MSGTEXT="Missing or invalid VA Email Address.",STOP=1 D MESSAGE^TIUCCRHL7P3(MSGID,$G(CONSULTID),MSGTEXT),ANAK^TIUCCHL7UT(MSGID,$G(MSGTEXT),$G(CONSULTID))
Q:$G(STOP)=1
Q:$L(TIUEMAIL)'>0
S (TIU("AUIEN"),TIU("AUDA"))=$O(^VA(200,"ADUPN",TIUEMAIL,""))
I $L(TIU("AUIEN"))'>0 S MSGTEXT="No valid User Account for "_$G(TIUEMAIL),STOP=1 D MESSAGE^TIUCCRHL7P3(MSGID,$G(CONSULTID),MSGTEXT),ANAK^TIUCCHL7UT(MSGID,$G(MSGTEXT),$G(CONSULTID))
Q:$G(STOP)=1
Q:$L(TIU("AUIEN"))'>0
S TIU("AUNAME")=$$UPPER^HLFNC($P(^VA(200,TIU("AUIEN"),0),U,1))
S TIU("AUNAME")=$$REMESC^TIUHL7U1(TIU("AUNAME"))
S TIU("ELESIG")=$$GET1^DIQ(200,TIU("AUIEN"),20.4)
S TIUTMP="" F S TIUTMP=$O(@TIUNAME@(TIUTMP)) Q:TIUTMP="" D:$P($G(@TIUNAME@(TIUTMP)),TIUFS)="OBX"
. I $P(@TIUNAME@(TIUTMP),TIUFS,2)=1,$L($G(TIU("SUB")))'>0 S TIU("SUB")=$P($P(@TIUNAME@(TIUTMP),TIUFS,4),TIUCS,2),TIU("SUB")=$$REMESC^TIUHL7U1(TIU("SUB"))
. F TIUI=1:1:$L($P(@TIUNAME@(TIUTMP),TIUFS,6),TIURS) D
. . S TIUZ("TEXT",TIUI,0)=$P($P(@TIUNAME@(TIUTMP),TIUFS,6),TIURS,TIUI)
. . S TIUZ("TEXT",TIUI,0)=$$STRIP^TIUHL7U2($$REMESC^TIUHL7U1(TIUZ("TEXT",TIUI,0)))
I $L(@TIUNAME@(7))>0&($E(@TIUNAME@(7),1,3)="NTE") D
.N X1X,XCNTX S XCNTX=1,X1X=6 F S X1X=$O(@TIUNAME@(X1X)) Q:X1X'>"" D
..S TIUZ("TEXT",XCNTX,0)=$TR($P($G(@TIUNAME@(X1X)),"|",4),$C(160)," ")
..I $G(TIUZ("TEXT",XCNTX,0))["'" D
...N SPEC,T5 S SPEC("'")="'",T5=TIUZ("TEXT",XCNTX,0)
...S TIUZ("TEXT",XCNTX,0)=$$REPLACE^XLFSTR(T5,.SPEC)
..I $G(TIUZ("TEXT",XCNTX,0))[""" D
...N SPEC,T5 S SPEC(""")="""",T5=TIUZ("TEXT",XCNTX,0)
...S TIUZ("TEXT",XCNTX,0)=$$REPLACE^XLFSTR(T5,.SPEC)
..I $G(TIUZ("TEXT",XCNTX,0))["Original CCP Note Date (mm/dd/yyyy):" S NOTEDATE=$P(TIUZ("TEXT",XCNTX,0),":",2)
..I $G(TIUZ("TEXT",XCNTX,0))["CCPN Number:" S NOTENUM=$P(TIUZ("TEXT",XCNTX,0),":",2)
..I $G(TIUZ("TEXT",XCNTX,0))'=""&($L(TIUZ("TEXT",XCNTX,0))>80) D SPLIT(TIUZ("TEXT",XCNTX,0),XCNTX)
..;patch 349, PB - Feb 15, 2022 - modifications to capture the Consult Factor text to be filed as a comment with the consult
..I $G(TIUZ("TEXT",XCNTX,0))["CF#:" S CFNOTE=$P($G(TIUZ("TEXT",XCNTX,0)),"CF#: ",2)
..S XCNTX=XCNTX+1
I '$D(@TIUNAME@(7)) D
.D:$G(ADDENDUM)="" WORD
.D:$G(ADDENDUM)'="" WORD^TIUCCRHL7P4
; begin data verification
; PATIENT IDENTIFICATION
D
.Q
. N TIUI,TIUJ,TIUERR,TIUN,TIUOUT,TIUTMP,TIUQUIT
. I $D(TIU("DFN")) S TIUJ=1
. I '+$L($G(TIU("PTNAME"))) D ERR^TIUCCHL7UT("PID",5,"0000.00","Missing PATIENT NAME.")
. I +TIUJ=1 D
. . I '+$L($P(TIU("PTNAME"),",",2)) D ERR^TIUCCHL7UT("PID",5,"0000.00","FIRST NAME/INITIAL missing with only one numeric identifier sent.")
. . S TIUN("PT")=$$PNAME^TIUHL7U1(TIU("PTNAME")),TIUTMP=1
. E S TIUN("PT")=$P(TIU("PTNAME"),",")
. S TIUJ=0
. ; check DFN if available
. I +$G(TIU("DFN")) S TIUJ=TIUJ+1,DFN(TIUJ)=TIU("DFN") D
. . I +$G(TIUTMP) S TIUN("DFN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,TIU("DFN"),.01))
. . E S TIUN("DFN")=$P($$GET1^DIQ(2,TIU("DFN"),.01),",")
. . I '$$COMPARE^TIUHL7U1(TIUN("DFN"),TIUN("PT")) D ERR^TIUCCHL7UT("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message DFN #"_TIU("DFN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].")
. ; check ICN if available
. I +$G(TIU("ICN")) S TIUJ=TIUJ+1,DFN(TIUJ)=+$$FIND1^DIC(2,"","X",TIU("ICN"),"AICN") D
. . I +$G(TIUTMP) S TIUN("ICN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,DFN(TIUJ),.01))
. . E S TIUN("ICN")=$P($$GET1^DIQ(2,DFN(TIUJ),.01),",")
. . I '$$COMPARE^TIUHL7U1(TIUN("ICN"),TIUN("PT")) D ERR^TIUCCHL7UT("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message ICN #"_TIU("ICN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].")
. ; check SSN if available
. I +$G(TIU("SSN")) S TIUJ=TIUJ+1,DFN(TIUJ)=+$$FIND1^DIC(2,"","X",TIU("SSN"),"SSN") D
. . I +$G(TIUTMP) S TIUN("SSN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,DFN(TIUJ),.01))
. . E S TIUN("SSN")=$P($$GET1^DIQ(2,DFN(TIUJ),.01),",")
. . I '$$COMPARE^TIUHL7U1(TIUN("SSN"),TIUN("PT")) D ERR^TIUCCHL7UT("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message SSN #"_TIU("SSN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].")
. ; compare DFN lookup values
. I TIUJ>1 S (TIUI,TIUJ)=0 F S TIUI=$O(DFN(TIUI)) Q:'TIUI I TIUI>1 S TIUJ=TIUI-1 I DFN(TIUI)'=DFN(TIUJ) D ERR^TIUCCHL7UT("PID",5,"0000.00","PATIENT IEN discrepancies between the numeric lookups.") Q
. I TIU("EC") Q
. S DFN=DFN(1)
I $G(ADDENDUM)'="" D
.N N1 S N1=0 F S N1=$O(TIUZ("TEXT",N1)) Q:N1'>0 D
..I $G(TIUZ("TEXT",N1,0))["Original CCP Note Date (mm/dd/yyyy):" S NOTEDATE=$P(TIUZ("TEXT",N1,0),": ",2)
..I $G(TIUZ("TEXT",N1,0))["CCPN Number:" S NOTENUM=$P(TIUZ("TEXT",N1,0),": ",2)
.S:$G(NOTENUM)'="" TIUIEN=$$TIULKUP^TIUCCHL7UT(CONSULTID,TIU("TDA"),$G(NOTEDATE),NOTENUM)
;
D CONTINUE^TIUCCRHL7P2
Q
SPLIT(NODE,CNTR) ;
Q:$G(NODE)=""
Q:$G(CNTR)=""
Q:$L(NODE)<80
K LINE
S NODE=$TR(NODE,$C(160),""),XCNTX=CNTR
N WORDS,I,XX,SEGS,LEN
S LEN=$L(NODE),SEGS=LEN/80 S:$P(SEGS,".",2)>0 SEGS=SEGS+1
S WORDS=0 F I=1:1:$L(NODE) I $E(NODE,I)=" " S WORDS=WORDS+1
S XX="",CNT=1,LASTWORD=0
F I=1:1:(WORDS+1) D
.S XX=XX_$P(NODE," ",I)_" "
.I $L(XX)>80 D
..S LASTWORD=I
..S LINE(CNT)=XX,CNT=CNT+1 S XX="",TIUZ("TEXT",XCNTX,0)=$G(LINE(CNT-1)),XCNTX=XCNTX+1
I ((WORDS+1)>LASTWORD) D
.S LINE(CNT)=$P(NODE," ",LASTWORD+1,WORDS+1),TIUZ("TEXT",XCNTX,0)=$G(LINE(CNT)),XCNTX=XCNTX+1
K I,CNT,LASTWORD
Q
WORD ;
K I1,CNT,LCNT,LEN,I,LINES,T2,LASTWORDS,TEST1,WORDS,WORDSLEN,XX,T2,T4,T5
S WORDS=$G(TIUZ("TEXT",1,0)),WORDSLEN=$L(TIUZ("TEXT",1,0))
I $G(ADDENDUM)'="" D
.S NOTEDATE=$$GETDATE^TIUCCRHL7P4
.S NOTENUM=$$NOTENUM^TIUCCRHL7P4
.S:$G(NOTENUM)'="" TIUIEN=$$TIULKUP^TIUCCHL7UT(CONSULTID,TIU("TDA"),NOTEDATE,NOTENUM) ;Patch 344 lookup the note in the consult to file the addendum with
F TEST1=1:1:WORDSLEN S LASTWORDS=$E(TIUZ("TEXT",1,0),WORDSLEN,(WORDSLEN-25))
K T2 S T2("PROVIDER"_$C(160)_"CONTACT ADDENDUM")="PROVIDER CONTACT ADDENDUM"
S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("CCP Note Create Date:")=$C(10)_"CCP Note Create Date:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("CCPN Number:")=$C(10)_"CCPN Number:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Veteran Last Name:")=$C(10)_"Veteran Last Name:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Veteran First Name:")=$C(10)_"Veteran First Name:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Veteran Social:")=$C(10)_"Veteran Social:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2($C(160)_$C(160)_"CONSULT AND REFERRAL INFORMATION ")=$C(10)_"CONSULT AND REFERRAL INFORMATION " S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Name of Referring VA Provider:")=$C(10)_"Name of Referring VA Provider:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Selected SEOC:")=$C(10)_"Selected SEOC:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Referral Number:")=$C(10)_"Referral Number:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Unique Consult ID:")=$C(10)_"Unique Consult ID:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Patient Admitted (Yes/No): If yes, then please complete the Discharge Planning Addendum.")=$C(10)_"Patient Admitted (Yes/No): If yes, then please complete the Discharge Planning Addendum" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Chief Complaint: "_$C(160))=$C(10)_"Chief Complaint:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Risks")=$C(10)_"Risks x" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Level of Care Coordination: ")=$C(10)_"Level of Care Coordination: " S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2,T4 S T4="BasicPlease review all notes, this note may have one or more of the following addenda associated:" D
.K T5 S T5="Basic Please review all notes, this note may have one or more of the following addenda associated:"
.S T2($G(T4))=$C(10)_$G(T5) S WORDS=$$REPLACE^XLFSTR(WORDS,.T2) K T5
K T2 S T2("Care Coordination Follow Up:")=$C(10)_"Care Coordination Follow Up:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Appointment Management:")=$C(10)_"Appointment Management:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Case Management:")=$C(10)_"Case Management:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Continued Stay Review:")=$C(10)_"Continued Stay Review:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Disease Management:")=$C(10)_"Disease Management:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Discharge Planning:")=$C(10)_"Discharge Planning: " S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Discharge Disposition:")=$C(10)_"Discharge Disposition:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Veteran Contact: ")=$C(10)_"Veteran Contact:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Provider Contact: ")=$C(10)_"Provider Contact:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Transfer:")=$C(10)_"Transfer:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Veteran Handoff:")=$C(10)_"Veteran Handoff:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("FACILITY COMMUNITY CARE OFFICE CONTACT")=$C(10)_"FACILITY COMMUNITY CARE OFFICE CONTACT" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Care Coordination Point of Contact:")=$C(10)_"Care Coordination Point of Contact:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2(" Phone Number:")=$C(10)_"Phone Number:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2,T4 S T4="Is Veteran's caregiver same as next of kin listed in the demographic section of CPRS (Yes/No)?:" D
.S T2(T4)=$C(10)_T4 S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("If no, provide the following:")=$C(160)_"If no, provider the following:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Veteran's Caregiver Point of Contact:")=$C(10)_"Veteran's Caregiver Point of Contact" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Caregiver's Relationship to Veteran:")=$C(10)_"Caregiver's Relationship to Veteran:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Caregiver's Primary Phone Number:")=$C(10)_"Caregiver's Primary Phone Number::" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("Caregiver's Alternate Phone Number:")=$C(10)_"Caregiver's Alternate Phone Number:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("PLAN:")=$C(10)_"PLAN:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2,T4 S T4="*** CC Plan may include specialty and associated appointment information, date of surgery, post-op needs, post d/c appointment, and any other care coordination plan ***" D
.S T2(T4)=$C(10)_T4 S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
K T2 S T2("ADDITIONAL NOTES:")=$C(10)_"ADDITIONAL NOTES:" S WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
S LEN=$L(WORDS),I1=1,XX=1,CNT=0,LCNT=0
F I=1:1:LEN D
.S LCNT=LCNT+1
.I LCNT>100&($E(WORDS,I)=" ")!($E(WORDS,I)=$C(160))!($E(WORDS,I)=$C(10)) D
..S:XX=1 LINES("TEXT",XX,0)=$$TRIM^XLFSTR($E(WORDS,1,63),"LR"),XX=XX+1,I=64,LCNT=0,I1=I
..Q:XX=1
..S LINES("TEXT",XX,0)=$TR($E(WORDS,I1,I-1),$C(160)," "),LINES("TEXT",XX,0)=$$TRIM^XLFSTR(LINES("TEXT",XX,0),"LR"),XX=XX+1,LCNT=0 ;,I1=I
..S I1=I
I I1'=LEN N LASTLINES S LASTLINES=$E(WORDS,I1,I) K T2 S T2($C(160)_" ")="" S LINES("TEXT",XX,0)=$$REPLACE^XLFSTR(LASTLINES,.T2)
M TIUZ("TEXT")=LINES("TEXT")
K LINES("TEXT")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUCCRHL7P1 15733 printed Sep 23, 2025@20:15:22 Page 2
TIUCCRHL7P1 ; CCRA/PB - TIU CCRA HL7 Msg Processing; January 6, 2006
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**337,344,348,349,352,356,366,371**;Sep 27, 2023;Build 4
+2 ;
+3 ;PB - Patch 344 to modify how the note and addendum text is formatted
+4 ;PB - Patch 348 modification to parse the note text from NTE segments rather than the OBX segment
+5 ;PB - Patch 349 modification to parse and file the consult factor from the note and file as a comment with the consult
+6 ;NOTES FROM NOV 10: Need to loop thru the XTMP("TIUHL7" temp global and if the last character is
+7 ;$C(160), remove it.
+8 ;PB - Patch 352 removes the text CF#: from the CFNOTE
+9 ;PB - Patch 356 modifications to file the note as a stand-alone note and not linked to a consult
+10 ;PB - Patch 371 removes unused code
+11 QUIT
PROCMSG ;
+1 NEW DFN,DUZ,CONSULTID,MSGID,TIU,TIUDA,TIUDPRM,TIUDT,TIUERR,TIUI,TIUJ,TIUMSG,TIUELS,STOP,TIUIEN,NOTEDATE,NOTENUM
+2 NEW TIUEMAIL,TIUNAME,TIUTMP,TIUFS,TIUCS,TIURS,TIUES,TIUSS,TIUZ,VNUM,MSGTEXT,ADDENDUM,CFNOTE,ORIGSTAT,CONSULTID
+3 SET ADDENDUM=""
+4 ; remove HL7 message entries7 days or older
+5 DO CLEAN^TIUHL7U1
+6 SET U="^"
+7 SET TIUDT=$$NOW^XLFDT
+8 ; sets field, component and repetition separators from HL7 Message
+9 SET TIUFS=$GET(HL("FS"))
SET TIUJ=0
FOR TIUI="TIUCS","TIURS","TIUES","TIUSS"
SET TIUJ=TIUJ+1
SET @TIUI=$EXTRACT(HL("ECH"),TIUJ,TIUJ)
+10 ; initializes variables and ^XTMP expiration
+11 SET TIU="TIU"
SET (TIU("EC"),TIUDA)=0
SET TIUNAME=$NAME(^XTMP("TIUHL7",TIUDT,HLMTIENS))
SET ^XTMP("TIUHL7",0)=$$FMADD^XLFDT(TIUDT,7)_U_TIUDT
+12 SET MSGID=HL("MID")
+13 ; retrieves HL7 message and stores to temporary global
+14 FOR TIUI=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+15 SET @TIUNAME@("MSG",TIUI)=HLNODE
SET TIUJ=0
+16 FOR
SET TIUJ=$ORDER(HLNODE(TIUJ))
if 'TIUJ
QUIT
Begin DoDot:2
+17 ;$$TIUC^TIUCCHL7UT(HLNODE(TIUJ))
SET @TIUNAME@("MSG",TIUI)=@TIUNAME@("MSG",TIUI)_HLNODE(TIUJ)
End DoDot:2
End DoDot:1
+18 ; places temporary global in local meory & adds EOM flag
+19 MERGE TIUMSG=@TIUNAME@("MSG")
+20 SET TIU("XTMP")=TIUNAME
SET TIUNAME="TIUMSG"
SET TIUI=""
SET TIUI=$ORDER(TIUMSG(TIUI),-1)
SET TIUI=TIUI+1
SET TIUMSG(TIUI)="EOM"
+21 ; verify message format
+22 SET TIUI=""
FOR
SET TIUI=$ORDER(@TIUNAME@(TIUI))
if @TIUNAME@(TIUI)="EOM"
QUIT
Begin DoDot:1
+23 SET TIUJ=$SELECT(TIUI=1:"MSH",TIUI=2:"EVN",TIUI=3:"PID",TIUI=4:"PV1",TIUI=5:"TXA",TIUI=6:"OBX",TIUI>6:"NTE",1:"OBX")
+24 IF $PIECE(@TIUNAME@(TIUI),TIUFS)'=TIUJ
DO ERR^TIUCCHL7UT("MSG",1,"000.000","Improper/missing message format: "_TIUJ_" segment.")
End DoDot:1
+25 ; get consult id
+26 SET CONSULTID=$$REMESC^TIUHL7U1($PIECE($GET(@TIUNAME@(4)),TIUFS,20))
+27 ; get patient name [required]
+28 SET TIU("PTNAME")=$$UPPER^HLFNC($$FMNAME^HLFNC($PIECE($PIECE($GET(@TIUNAME@(3)),TIUFS,6),TIUCS,1,4),TIUCS))
SET TIU("PTNAME")=$$REMESC^TIUHL7U1(TIU("PTNAME"))
+29 ; get patient ICN/SSN/DFN - order may vary [conditionally required]
+30 SET (TIU("DFN"),TIU("ICN"),TIU("SSN"))=""
FOR TIUI=1:1:$LENGTH($PIECE($GET(@TIUNAME@(3)),U,4),TIURS)
SET TIUJ=$PIECE($PIECE($GET(@TIUNAME@(3)),TIUFS,4),TIURS,TIUI)
IF +TIUJ>0
Begin DoDot:1
+31 SET TIU("ICN")=+$PIECE(TIUJ,U,1)
End DoDot:1
+32 IF +$GET(TIU("ICN"))'>0
SET MSGTEXT="Patient ICN not in HL7 message."
SET STOP=1
DO MESSAGE^TIUCCRHL7P3(MSGID,$GET(CONSULTID),MSGTEXT)
DO ANAK^TIUCCHL7UT(MSGID,$GET(MSGTEXT),$GET(CONSULTID))
+33 if $GET(STOP)=1
QUIT
+34 if +$GET(TIU("ICN"))'>0
QUIT
+35 SET (DFN,TIU("DFN"))=$$GETDFN^MPIF001($PIECE(TIU("ICN"),"V"))
SET TIU("SSN")=$$GET1^DIQ(2,TIU("DFN")_",",.09,"I")
+36 SET TIUTMP=$SELECT($PIECE(TIUJ,TIUCS,5)="NI":"ICN",$PIECE(TIUJ,TIUCS,5)="SS":"SSN",$PIECE(TIUJ,TIUCS,5)="PI":"DFN",1:"UNK")
+37 IF +TIU("DFN")=-1
SET MSGTEXT="Patient not found on VistA "
SET STOP=1
DO MESSAGE^TIUCCRHL7P3(MSGID,$GET(CONSULTID),MSGTEXT)
DO ANAK^TIUCCHL7UT(MSGID,$GET(MSGTEXT),$GET(CONSULTID))
+38 if $GET(STOP)=1
QUIT
+39 if +TIU("DFN")=-1
QUIT
+40 ; get DOCUMENT TITLE (#8925.1) [required] & set IEN, document title is in TIU("TITLE")
+41 SET TIU("TITLE")=$$UPPER^HLFNC($PIECE($GET(@TIUNAME@(5)),TIUFS,17))
SET TIU("TITLE")=$$REMESC^TIUHL7U1(TIU("TITLE"))
+42 SET TIU("TITLEB")=$$UPPER^HLFNC($PIECE($GET(@TIUNAME@(5)),TIUFS,3))
SET TIU("TITLEB")=$$REMESC^TIUHL7U1(TIU("TITLEB"))
SET TIU("TITLEB")=$PIECE(TIU("TITLEB"),"^",2)
+43 ;patch 344 code below to determine if this is an original note or an addendum
+44 IF $GET(TIU("TITLEB"))["ADDENDUM"
Begin DoDot:1
+45 KILL T2
SET T2(" - ")="-"
SET TIU("TITLEB")=$$REPLACE^XLFSTR(TIU("TITLEB"),.T2)
KILL T2
+46 if $GET(TIU("TITLEB"))["ADDENDUM"
SET ADDENDUM=$PIECE(TIU("TITLEB"),"-",2)
End DoDot:1
+47 SET TIU("TDA")=$$LU^TIUHL7U1(8925.1,TIU("TITLE"),"X","I $P(^TIU(8925.1,+Y,0),U,4)=""DOC""")
IF $LENGTH(TIU("TITLE"))'>0
SET TIU("TITLE")="[UNKNOWN]"
+48 ; get VISIT # [optional]
+49 if $GET(TIU("VNUM"))'=""
SET TIU("AVAIL")="AV"
SET TIU("COMP")="LA"
+50 ;line of code added below to test filing a note but not linking it to a consult
+51 SET TIU("AVAIL")="AV"
SET TIU("COMP")="LA"
+52 SET TIU("SIGNED")=$$NOW^TIULC
SET TIU("CSIGNED")=""
+53 SET TIUEMAIL=$$LOW^XLFSTR($PIECE($GET(@TIUNAME@(5)),TIUFS,10))
+54 IF $LENGTH(TIUEMAIL)'>0
SET MSGTEXT="Missing or invalid VA Email Address."
SET STOP=1
DO MESSAGE^TIUCCRHL7P3(MSGID,$GET(CONSULTID),MSGTEXT)
DO ANAK^TIUCCHL7UT(MSGID,$GET(MSGTEXT),$GET(CONSULTID))
+55 if $GET(STOP)=1
QUIT
+56 if $LENGTH(TIUEMAIL)'>0
QUIT
+57 SET (TIU("AUIEN"),TIU("AUDA"))=$ORDER(^VA(200,"ADUPN",TIUEMAIL,""))
+58 IF $LENGTH(TIU("AUIEN"))'>0
SET MSGTEXT="No valid User Account for "_$GET(TIUEMAIL)
SET STOP=1
DO MESSAGE^TIUCCRHL7P3(MSGID,$GET(CONSULTID),MSGTEXT)
DO ANAK^TIUCCHL7UT(MSGID,$GET(MSGTEXT),$GET(CONSULTID))
+59 if $GET(STOP)=1
QUIT
+60 if $LENGTH(TIU("AUIEN"))'>0
QUIT
+61 SET TIU("AUNAME")=$$UPPER^HLFNC($PIECE(^VA(200,TIU("AUIEN"),0),U,1))
+62 SET TIU("AUNAME")=$$REMESC^TIUHL7U1(TIU("AUNAME"))
+63 SET TIU("ELESIG")=$$GET1^DIQ(200,TIU("AUIEN"),20.4)
+64 SET TIUTMP=""
FOR
SET TIUTMP=$ORDER(@TIUNAME@(TIUTMP))
if TIUTMP=""
QUIT
if $PIECE($GET(@TIUNAME@(TIUTMP)),TIUFS)="OBX"
Begin DoDot:1
+65 IF $PIECE(@TIUNAME@(TIUTMP),TIUFS,2)=1
IF $LENGTH($GET(TIU("SUB")))'>0
SET TIU("SUB")=$PIECE($PIECE(@TIUNAME@(TIUTMP),TIUFS,4),TIUCS,2)
SET TIU("SUB")=$$REMESC^TIUHL7U1(TIU("SUB"))
+66 FOR TIUI=1:1:$LENGTH($PIECE(@TIUNAME@(TIUTMP),TIUFS,6),TIURS)
Begin DoDot:2
+67 SET TIUZ("TEXT",TIUI,0)=$PIECE($PIECE(@TIUNAME@(TIUTMP),TIUFS,6),TIURS,TIUI)
+68 SET TIUZ("TEXT",TIUI,0)=$$STRIP^TIUHL7U2($$REMESC^TIUHL7U1(TIUZ("TEXT",TIUI,0)))
End DoDot:2
End DoDot:1
+69 IF $LENGTH(@TIUNAME@(7))>0&($EXTRACT(@TIUNAME@(7),1,3)="NTE")
Begin DoDot:1
+70 NEW X1X,XCNTX
SET XCNTX=1
SET X1X=6
FOR
SET X1X=$ORDER(@TIUNAME@(X1X))
if X1X'>""
QUIT
Begin DoDot:2
+71 SET TIUZ("TEXT",XCNTX,0)=$TRANSLATE($PIECE($GET(@TIUNAME@(X1X)),"|",4),$CHAR(160)," ")
+72 IF $GET(TIUZ("TEXT",XCNTX,0))["'"
Begin DoDot:3
+73 NEW SPEC,T5
SET SPEC("'")="'"
SET T5=TIUZ("TEXT",XCNTX,0)
+74 SET TIUZ("TEXT",XCNTX,0)=$$REPLACE^XLFSTR(T5,.SPEC)
End DoDot:3
+75 IF $GET(TIUZ("TEXT",XCNTX,0))["""
Begin DoDot:3
+76 NEW SPEC,T5
SET SPEC(""")=""""
SET T5=TIUZ("TEXT",XCNTX,0)
+77 SET TIUZ("TEXT",XCNTX,0)=$$REPLACE^XLFSTR(T5,.SPEC)
End DoDot:3
+78 IF $GET(TIUZ("TEXT",XCNTX,0))["Original CCP Note Date (mm/dd/yyyy):"
SET NOTEDATE=$PIECE(TIUZ("TEXT",XCNTX,0),":",2)
+79 IF $GET(TIUZ("TEXT",XCNTX,0))["CCPN Number:"
SET NOTENUM=$PIECE(TIUZ("TEXT",XCNTX,0),":",2)
+80 IF $GET(TIUZ("TEXT",XCNTX,0))'=""&($LENGTH(TIUZ("TEXT",XCNTX,0))>80)
DO SPLIT(TIUZ("TEXT",XCNTX,0),XCNTX)
+81 ;patch 349, PB - Feb 15, 2022 - modifications to capture the Consult Factor text to be filed as a comment with the consult
+82 IF $GET(TIUZ("TEXT",XCNTX,0))["CF#:"
SET CFNOTE=$PIECE($GET(TIUZ("TEXT",XCNTX,0)),"CF#: ",2)
+83 SET XCNTX=XCNTX+1
End DoDot:2
End DoDot:1
+84 IF '$DATA(@TIUNAME@(7))
Begin DoDot:1
+85 if $GET(ADDENDUM)=""
DO WORD
+86 if $GET(ADDENDUM)'=""
DO WORD^TIUCCRHL7P4
End DoDot:1
+87 ; begin data verification
+88 ; PATIENT IDENTIFICATION
+89 Begin DoDot:1
+90 QUIT
+91 NEW TIUI,TIUJ,TIUERR,TIUN,TIUOUT,TIUTMP,TIUQUIT
+92 IF $DATA(TIU("DFN"))
SET TIUJ=1
+93 IF '+$LENGTH($GET(TIU("PTNAME")))
DO ERR^TIUCCHL7UT("PID",5,"0000.00","Missing PATIENT NAME.")
+94 IF +TIUJ=1
Begin DoDot:2
+95 IF '+$LENGTH($PIECE(TIU("PTNAME"),",",2))
DO ERR^TIUCCHL7UT("PID",5,"0000.00","FIRST NAME/INITIAL missing with only one numeric identifier sent.")
+96 SET TIUN("PT")=$$PNAME^TIUHL7U1(TIU("PTNAME"))
SET TIUTMP=1
End DoDot:2
+97 IF '$TEST
SET TIUN("PT")=$PIECE(TIU("PTNAME"),",")
+98 SET TIUJ=0
+99 ; check DFN if available
+100 IF +$GET(TIU("DFN"))
SET TIUJ=TIUJ+1
SET DFN(TIUJ)=TIU("DFN")
Begin DoDot:2
+101 IF +$GET(TIUTMP)
SET TIUN("DFN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,TIU("DFN"),.01))
+102 IF '$TEST
SET TIUN("DFN")=$PIECE($$GET1^DIQ(2,TIU("DFN"),.01),",")
+103 IF '$$COMPARE^TIUHL7U1(TIUN("DFN"),TIUN("PT"))
DO ERR^TIUCCHL7UT("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message DFN #"_TIU("DFN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].")
End DoDot:2
+104 ; check ICN if available
+105 IF +$GET(TIU("ICN"))
SET TIUJ=TIUJ+1
SET DFN(TIUJ)=+$$FIND1^DIC(2,"","X",TIU("ICN"),"AICN")
Begin DoDot:2
+106 IF +$GET(TIUTMP)
SET TIUN("ICN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,DFN(TIUJ),.01))
+107 IF '$TEST
SET TIUN("ICN")=$PIECE($$GET1^DIQ(2,DFN(TIUJ),.01),",")
+108 IF '$$COMPARE^TIUHL7U1(TIUN("ICN"),TIUN("PT"))
DO ERR^TIUCCHL7UT("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message ICN #"_TIU("ICN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].")
End DoDot:2
+109 ; check SSN if available
+110 IF +$GET(TIU("SSN"))
SET TIUJ=TIUJ+1
SET DFN(TIUJ)=+$$FIND1^DIC(2,"","X",TIU("SSN"),"SSN")
Begin DoDot:2
+111 IF +$GET(TIUTMP)
SET TIUN("SSN")=$$PNAME^TIUHL7U1($$GET1^DIQ(2,DFN(TIUJ),.01))
+112 IF '$TEST
SET TIUN("SSN")=$PIECE($$GET1^DIQ(2,DFN(TIUJ),.01),",")
+113 IF '$$COMPARE^TIUHL7U1(TIUN("SSN"),TIUN("PT"))
DO ERR^TIUCCHL7UT("PID",5,"0000.00","PATIENT NAME discrepancy between HL7 message name ["_TIU("PTNAME")_"] & the HL7 message SSN #"_TIU("SSN")_" ["_$$GET1^DIQ(2,DFN(TIUJ),.01)_"].")
End DoDot:2
+114 ; compare DFN lookup values
+115 IF TIUJ>1
SET (TIUI,TIUJ)=0
FOR
SET TIUI=$ORDER(DFN(TIUI))
if 'TIUI
QUIT
IF TIUI>1
SET TIUJ=TIUI-1
IF DFN(TIUI)'=DFN(TIUJ)
DO ERR^TIUCCHL7UT("PID",5,"0000.00","PATIENT IEN discrepancies between the numeric lookups.")
QUIT
+116 IF TIU("EC")
QUIT
+117 SET DFN=DFN(1)
End DoDot:1
+118 IF $GET(ADDENDUM)'=""
Begin DoDot:1
+119 NEW N1
SET N1=0
FOR
SET N1=$ORDER(TIUZ("TEXT",N1))
if N1'>0
QUIT
Begin DoDot:2
+120 IF $GET(TIUZ("TEXT",N1,0))["Original CCP Note Date (mm/dd/yyyy):"
SET NOTEDATE=$PIECE(TIUZ("TEXT",N1,0),": ",2)
+121 IF $GET(TIUZ("TEXT",N1,0))["CCPN Number:"
SET NOTENUM=$PIECE(TIUZ("TEXT",N1,0),": ",2)
End DoDot:2
+122 if $GET(NOTENUM)'=""
SET TIUIEN=$$TIULKUP^TIUCCHL7UT(CONSULTID,TIU("TDA"),$GET(NOTEDATE),NOTENUM)
End DoDot:1
+123 ;
+124 DO CONTINUE^TIUCCRHL7P2
+125 QUIT
SPLIT(NODE,CNTR) ;
+1 if $GET(NODE)=""
QUIT
+2 if $GET(CNTR)=""
QUIT
+3 if $LENGTH(NODE)<80
QUIT
+4 KILL LINE
+5 SET NODE=$TRANSLATE(NODE,$CHAR(160),"")
SET XCNTX=CNTR
+6 NEW WORDS,I,XX,SEGS,LEN
+7 SET LEN=$LENGTH(NODE)
SET SEGS=LEN/80
if $PIECE(SEGS,".",2)>0
SET SEGS=SEGS+1
+8 SET WORDS=0
FOR I=1:1:$LENGTH(NODE)
IF $EXTRACT(NODE,I)=" "
SET WORDS=WORDS+1
+9 SET XX=""
SET CNT=1
SET LASTWORD=0
+10 FOR I=1:1:(WORDS+1)
Begin DoDot:1
+11 SET XX=XX_$PIECE(NODE," ",I)_" "
+12 IF $LENGTH(XX)>80
Begin DoDot:2
+13 SET LASTWORD=I
+14 SET LINE(CNT)=XX
SET CNT=CNT+1
SET XX=""
SET TIUZ("TEXT",XCNTX,0)=$GET(LINE(CNT-1))
SET XCNTX=XCNTX+1
End DoDot:2
End DoDot:1
+15 IF ((WORDS+1)>LASTWORD)
Begin DoDot:1
+16 SET LINE(CNT)=$PIECE(NODE," ",LASTWORD+1,WORDS+1)
SET TIUZ("TEXT",XCNTX,0)=$GET(LINE(CNT))
SET XCNTX=XCNTX+1
End DoDot:1
+17 KILL I,CNT,LASTWORD
+18 QUIT
WORD ;
+1 KILL I1,CNT,LCNT,LEN,I,LINES,T2,LASTWORDS,TEST1,WORDS,WORDSLEN,XX,T2,T4,T5
+2 SET WORDS=$GET(TIUZ("TEXT",1,0))
SET WORDSLEN=$LENGTH(TIUZ("TEXT",1,0))
+3 IF $GET(ADDENDUM)'=""
Begin DoDot:1
+4 SET NOTEDATE=$$GETDATE^TIUCCRHL7P4
+5 SET NOTENUM=$$NOTENUM^TIUCCRHL7P4
+6 ;Patch 344 lookup the note in the consult to file the addendum with
if $GET(NOTENUM)'=""
SET TIUIEN=$$TIULKUP^TIUCCHL7UT(CONSULTID,TIU("TDA"),NOTEDATE,NOTENUM)
End DoDot:1
+7 FOR TEST1=1:1:WORDSLEN
SET LASTWORDS=$EXTRACT(TIUZ("TEXT",1,0),WORDSLEN,(WORDSLEN-25))
+8 KILL T2
SET T2("PROVIDER"_$CHAR(160)_"CONTACT ADDENDUM")="PROVIDER CONTACT ADDENDUM"
+9 SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+10 KILL T2
SET T2("CCP Note Create Date:")=$CHAR(10)_"CCP Note Create Date:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+11 KILL T2
SET T2("CCPN Number:")=$CHAR(10)_"CCPN Number:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+12 KILL T2
SET T2("Veteran Last Name:")=$CHAR(10)_"Veteran Last Name:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+13 KILL T2
SET T2("Veteran First Name:")=$CHAR(10)_"Veteran First Name:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+14 KILL T2
SET T2("Veteran Social:")=$CHAR(10)_"Veteran Social:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+15 KILL T2
SET T2($CHAR(160)_$CHAR(160)_"CONSULT AND REFERRAL INFORMATION ")=$CHAR(10)_"CONSULT AND REFERRAL INFORMATION "
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+16 KILL T2
SET T2("Name of Referring VA Provider:")=$CHAR(10)_"Name of Referring VA Provider:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+17 KILL T2
SET T2("Selected SEOC:")=$CHAR(10)_"Selected SEOC:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+18 KILL T2
SET T2("Referral Number:")=$CHAR(10)_"Referral Number:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+19 KILL T2
SET T2("Unique Consult ID:")=$CHAR(10)_"Unique Consult ID:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+20 KILL T2
SET T2("Patient Admitted (Yes/No): If yes, then please complete the Discharge Planning Addendum.")=$CHAR(10)_"Patient Admitted (Yes/No): If yes, then please complete the Discharge Planning Addendum"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+21 KILL T2
SET T2("Chief Complaint: "_$CHAR(160))=$CHAR(10)_"Chief Complaint:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+22 KILL T2
SET T2("Risks")=$CHAR(10)_"Risks x"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+23 KILL T2
SET T2("Level of Care Coordination: ")=$CHAR(10)_"Level of Care Coordination: "
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+24 KILL T2,T4
SET T4="BasicPlease review all notes, this note may have one or more of the following addenda associated:"
Begin DoDot:1
+25 KILL T5
SET T5="Basic Please review all notes, this note may have one or more of the following addenda associated:"
+26 SET T2($GET(T4))=$CHAR(10)_$GET(T5)
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
KILL T5
End DoDot:1
+27 KILL T2
SET T2("Care Coordination Follow Up:")=$CHAR(10)_"Care Coordination Follow Up:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+28 KILL T2
SET T2("Appointment Management:")=$CHAR(10)_"Appointment Management:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+29 KILL T2
SET T2("Case Management:")=$CHAR(10)_"Case Management:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+30 KILL T2
SET T2("Continued Stay Review:")=$CHAR(10)_"Continued Stay Review:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+31 KILL T2
SET T2("Disease Management:")=$CHAR(10)_"Disease Management:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+32 KILL T2
SET T2("Discharge Planning:")=$CHAR(10)_"Discharge Planning: "
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+33 KILL T2
SET T2("Discharge Disposition:")=$CHAR(10)_"Discharge Disposition:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+34 KILL T2
SET T2("Veteran Contact: ")=$CHAR(10)_"Veteran Contact:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+35 KILL T2
SET T2("Provider Contact: ")=$CHAR(10)_"Provider Contact:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+36 KILL T2
SET T2("Transfer:")=$CHAR(10)_"Transfer:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+37 KILL T2
SET T2("Veteran Handoff:")=$CHAR(10)_"Veteran Handoff:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+38 KILL T2
SET T2("FACILITY COMMUNITY CARE OFFICE CONTACT")=$CHAR(10)_"FACILITY COMMUNITY CARE OFFICE CONTACT"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+39 KILL T2
SET T2("Care Coordination Point of Contact:")=$CHAR(10)_"Care Coordination Point of Contact:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+40 KILL T2
SET T2(" Phone Number:")=$CHAR(10)_"Phone Number:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+41 KILL T2,T4
SET T4="Is Veteran's caregiver same as next of kin listed in the demographic section of CPRS (Yes/No)?:"
Begin DoDot:1
+42 SET T2(T4)=$CHAR(10)_T4
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
End DoDot:1
+43 KILL T2
SET T2("If no, provide the following:")=$CHAR(160)_"If no, provider the following:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+44 KILL T2
SET T2("Veteran's Caregiver Point of Contact:")=$CHAR(10)_"Veteran's Caregiver Point of Contact"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+45 KILL T2
SET T2("Caregiver's Relationship to Veteran:")=$CHAR(10)_"Caregiver's Relationship to Veteran:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+46 KILL T2
SET T2("Caregiver's Primary Phone Number:")=$CHAR(10)_"Caregiver's Primary Phone Number::"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+47 KILL T2
SET T2("Caregiver's Alternate Phone Number:")=$CHAR(10)_"Caregiver's Alternate Phone Number:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+48 KILL T2
SET T2("PLAN:")=$CHAR(10)_"PLAN:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+49 KILL T2,T4
SET T4="*** CC Plan may include specialty and associated appointment information, date of surgery, post-op needs, post d/c appointment, and any other care coordination plan ***"
Begin DoDot:1
+50 SET T2(T4)=$CHAR(10)_T4
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
End DoDot:1
+51 KILL T2
SET T2("ADDITIONAL NOTES:")=$CHAR(10)_"ADDITIONAL NOTES:"
SET WORDS=$$REPLACE^XLFSTR(WORDS,.T2)
+52 SET LEN=$LENGTH(WORDS)
SET I1=1
SET XX=1
SET CNT=0
SET LCNT=0
+53 FOR I=1:1:LEN
Begin DoDot:1
+54 SET LCNT=LCNT+1
+55 IF LCNT>100&($EXTRACT(WORDS,I)=" ")!($EXTRACT(WORDS,I)=$CHAR(160))!($EXTRACT(WORDS,I)=$CHAR(10))
Begin DoDot:2
+56 if XX=1
SET LINES("TEXT",XX,0)=$$TRIM^XLFSTR($EXTRACT(WORDS,1,63),"LR")
SET XX=XX+1
SET I=64
SET LCNT=0
SET I1=I
+57 if XX=1
QUIT
+58 ;,I1=I
SET LINES("TEXT",XX,0)=$TRANSLATE($EXTRACT(WORDS,I1,I-1),$CHAR(160)," ")
SET LINES("TEXT",XX,0)=$$TRIM^XLFSTR(LINES("TEXT",XX,0),"LR")
SET XX=XX+1
SET LCNT=0
+59 SET I1=I
End DoDot:2
End DoDot:1
+60 IF I1'=LEN
NEW LASTLINES
SET LASTLINES=$EXTRACT(WORDS,I1,I)
KILL T2
SET T2($CHAR(160)_" ")=""
SET LINES("TEXT",XX,0)=$$REPLACE^XLFSTR(LASTLINES,.T2)
+61 MERGE TIUZ("TEXT")=LINES("TEXT")
+62 KILL LINES("TEXT")
+63 QUIT
