SDTMBUS ;MS/TG/MS/PB - TMP HL7 Routine;JULY 05, 2018
;;5.3;Scheduling;**704,773**;May 29, 2018;Build 9
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; Segment builders common to multiple messages.
; Message builders with message specific segments will contain
; those message specific segment builders. Examples would be the
; RDF for RTB^K13 messages or the PID for the ADR^A19.
;
; Integration Control Agreements
; ICR 4837 reads to GMR(123
; DBIA 4557 reads to GMR(123.5
Q
;
MSA(MID,ERROR,HL) ;build MSA segment
N MSA,ACK
S ACK=$P(ERROR,"^",5)
I ACK="NF"!(ACK="") S ACK="AA"
S MSA(0)="MSA"
S MSA(1)=ACK ;ACK code
S MSA(2)=HL("MID") ;message control ID
S MSA(3)=$P(ERROR,"^",6) ;text message
Q $$BLDSEG^SDHL7UL(.MSA,.HL)
;
ERR(ERROR,HL) ;build ERR segment
N ERR
S ERR(0)="ERR"
S ERR(1,1,1)=$P(ERROR,"^",1) ;segment
S ERR(1,1,2)=$P(ERROR,"^",2) ;sequence
S ERR(1,1,3)=$P(ERROR,"^",3) ;field
S ERR(1,1,4,1)=$P(ERROR,"^",4) ;code
S ERR(1,1,4,2)=$$ESCAPE^SDHL7UL($P(ERROR,"^",6),.HL) ;text
Q $$BLDSEG^SDHL7UL(.ERR,.HL)
;
QAK(HL,ERROR) ;build QAK segment
N QAK,STATUS
S STATUS=$P(ERROR,"^",5)
I STATUS="" S STATUS="OK"
S QAK(0)="QAK"
S QAK(1)=HL("MID") ;ACK code
S QAK(2)=STATUS ;message control ID
S QAK(3)=""
Q $$BLDSEG^SDHL7UL(.QAK,.HL)
;
QPD(QPD,HL) ;build QPD segment
Q $$BLDSEG^SDHL7UL(.QPD,.HL)
;
QRF(QRY,EXTIME,HL) ; Build QRF segment
N QRF
M QRF=QRY("QRF")
S QRF(0)="QRF"
Q $$BLDSEG^SDHL7UL(.QRF,.HL)
;
RDF(RDF,HL) ; Build RDF segment for DSS Units data
;
; Input:
; HL - HL7 package array variable
;
; Output:
; - Populated message array
;
Q $$BLDSEG^SDHL7UL(.RDF,.HL)
;
RDT(MSGROOT,DATAROOT,CNT,LEN,HL,FOUND) ; Build RDT segments for Consults elements
;
; Walks data in DATAROOT to populate MSGROOT with RDT segments
; sequentially numbered starting at CNT
;
; Integration Agreements:
; 10103 : FMTHL7^XLFDT
;
; Input:
; MSGROOT - Root of array holding the message
; DATAROOT - Root of array to hold extract data
; CNT - Current message line counter
; LEN - Current message length
; HL - HL7 package array variable
; FOUND - (0/1) Flag to indicate consults returned (1) or not (0)
;
; Output:
; - Populated message array
; - Updated LEN and CNT
;
; POPULATE SEQUENCE NUMBER
N I,APP,RDT,II,XDT,IEN,DATA,TO,XX,STOP,FS,CC,INST
S FOUND=0,INST=$$KSP^XUPARAM("INST")
;
S FS="~"
F CC=1:1 Q:'$D(@DATAROOT@(CC)) D
. S APP=@DATAROOT@(CC,0)
. N RDT,TO,XX,XDT,IEN,CONSULTS,DATA,STOPDT,REMOTECS,RMTCNID,RMTCS,CONDT
. S DATA="RDT"
. S IEN=$P(^TMP("ORQQCN",$J,"CS",CC,0),U)
. Q:+IEN=0
. S CONSULTS=$G(^TMP("ORQQCN",$J,"CS",CC,0))
. S CONDT=$P(CONSULTS,"^",2),STOPDT=$$FMADD^XLFDT(DT,-730) ;773 increase Consults lookup from 365 to 730
. Q:$G(CONDT)<STOPDT ; 2 years of consults.
. S DATA=DATA_"|"_"C"_FS_$P(CONSULTS,U)_FS_$$TMCONV^SDTMPHLA($P(CONSULTS,"^",2),INST)_FS_$P(CONSULTS,U,4)_FS_$P(CONSULTS,U,7)
. D GETS^DIQ(123,+IEN_",",".06;.07;.08;10;17","IE","RDT")
. S RMTCNID=$G(RDT(123,+IEN_",",".06","I"))
. S RMTCS=$G(RDT(123,+IEN_",",".07","I"))
. S:$G(RMTCNID)>0 REMOTECS=RMTCS_","_RMTCNID
. S XDT=$G(RDT(123,+IEN_",","17","I"))
. S:$G(XDT)'="" XDT=$$TMCONV^SDTMPHLA(XDT,INST)
. S TO=+$P($G(^GMR(123,+IEN,0)),U,5) ;ICR 4837
. S XX=0,STOP="" F S XX=$O(^GMR(123.5,TO,688,XX)) Q:XX'>0!(XX>5) S STOP=$G(STOP)_$P(^GMR(123.5,TO,688,XX,0),U)_","
. S DATA=DATA_FS_$G(XDT)_FS_STOP_FS_$G(RDT(123,+IEN_",","10","E"))_FS_$G(REMOTECS)_FS_$$UP^XLFSTR($P(CONSULTS,"^",3))
. F II=1:1:9 S RDT(II)=$P(DATA,II,FS)
. S CNT=CNT+1
. S @MSGROOT@(CNT)=DATA
. S LEN=LEN+$L(@MSGROOT@(CNT))
. S FOUND=1
. Q
Q
RTCRDT(MSGROOT,DATAROOT,CNT,LEN,HL,FOUND) ; Build RDT segments for Return to Clinic elements
;
; Walks data in DATAROOT to populate MSGROOT with RDT segments
; sequentially numbered starting at CNT
;
; Integration Agreements:
; 10103 : FMTHL7^XLFDT
;
; Input:
; MSGROOT - Root of array holding the message
; DATAROOT - Root of array to hold extract data
; CNT - Current message line counter
; LEN - Current message length
; HL - HL7 package array variable
; FOUND - (0/1) Flag to indicate consults returned (1) or not (0)
;
; Output:
; - Populated message array
; - Updated LEN and CNT
N I,RDT,II,XDT,IEN,DATA,TO,XX,STOP,FS,CC
S FOUND=0
;
S FS="~"
S CC=0
F S CC=$O(@DATAROOT@(CC)) Q:'CC D
. N RDT,TO,XX,XDT,IEN,CONSULTS,DATA,STOPDT,REMOTECS,RMTCNID,RMTCS,CONDT,MRTC,RTCINT,RTCPAR,MULTIRTC,PRVID,PRVNM
. S DATA="RDT"
. S IEN=$P(@DATAROOT@(CC),U)
. Q:+IEN=0
. S REQDT=$P(@DATAROOT@(CC),U,2)
. S CLINID=$P(@DATAROOT@(CC),U,3)
. S CID=$P(@DATAROOT@(CC),U,4)
. S PRVID=$P(@DATAROOT@(CC),U,5)
. S CMTS=$P(@DATAROOT@(CC),U,6)
. S MRTC=$P(@DATAROOT@(CC),U,7)
. S RTCINT=$P(@DATAROOT@(CC),U,8)
. S RTCPAR=$P(@DATAROOT@(CC),U,9)
. S:$L(MRTC)>0 MULTIRTC=$G(MRTC)_","_$G(RTCINT)_","_$G(RTCPAR)
. I +CLINID D
. . S CLINNM=$$GET1^DIQ(44,CLINID_",",".01") Q:CLINNM=""
. . S STOP=$$GET1^DIQ(44,CLINID_",",8,"I")_","_$$GET1^DIQ(44,CLINID_",",2503,"I")
. I +PRVID D
. . S PRVNM=$$GET1^DIQ(200,PRVID_",",".01")
. S STOPDT=$$FMADD^XLFDT(DT,-730) ;773 increase RTCs lookup from 365 to 730
. Q:$G(REQDT)<STOPDT ; 2 years of requests
. S DATA=DATA_"|"_"R"_FS_IEN_FS_$$TMCONV^SDTMPHLA(REQDT,$$INST^SDTMPHLA(CLINID))_FS_CLINID_FS_$G(CLINNM)_FS_$$TMCONV^SDTMPHLA(CID,$$INST^SDTMPHLA(CLINID))_FS_$G(STOP)_FS_$G(PRVNM)_FS_FS_FS_CMTS_FS_$G(MULTIRTC)
. S CNT=CNT+1
. S @MSGROOT@(CNT)=DATA
. S LEN=LEN+$L(@MSGROOT@(CNT))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDTMBUS 5875 printed Apr 09, 2024@22:02:43 Page 2
SDTMBUS ;MS/TG/MS/PB - TMP HL7 Routine;JULY 05, 2018
+1 ;;5.3;Scheduling;**704,773**;May 29, 2018;Build 9
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; Segment builders common to multiple messages.
+5 ; Message builders with message specific segments will contain
+6 ; those message specific segment builders. Examples would be the
+7 ; RDF for RTB^K13 messages or the PID for the ADR^A19.
+8 ;
+9 ; Integration Control Agreements
+10 ; ICR 4837 reads to GMR(123
+11 ; DBIA 4557 reads to GMR(123.5
+12 QUIT
+13 ;
MSA(MID,ERROR,HL) ;build MSA segment
+1 NEW MSA,ACK
+2 SET ACK=$PIECE(ERROR,"^",5)
+3 IF ACK="NF"!(ACK="")
SET ACK="AA"
+4 SET MSA(0)="MSA"
+5 ;ACK code
SET MSA(1)=ACK
+6 ;message control ID
SET MSA(2)=HL("MID")
+7 ;text message
SET MSA(3)=$PIECE(ERROR,"^",6)
+8 QUIT $$BLDSEG^SDHL7UL(.MSA,.HL)
+9 ;
ERR(ERROR,HL) ;build ERR segment
+1 NEW ERR
+2 SET ERR(0)="ERR"
+3 ;segment
SET ERR(1,1,1)=$PIECE(ERROR,"^",1)
+4 ;sequence
SET ERR(1,1,2)=$PIECE(ERROR,"^",2)
+5 ;field
SET ERR(1,1,3)=$PIECE(ERROR,"^",3)
+6 ;code
SET ERR(1,1,4,1)=$PIECE(ERROR,"^",4)
+7 ;text
SET ERR(1,1,4,2)=$$ESCAPE^SDHL7UL($PIECE(ERROR,"^",6),.HL)
+8 QUIT $$BLDSEG^SDHL7UL(.ERR,.HL)
+9 ;
QAK(HL,ERROR) ;build QAK segment
+1 NEW QAK,STATUS
+2 SET STATUS=$PIECE(ERROR,"^",5)
+3 IF STATUS=""
SET STATUS="OK"
+4 SET QAK(0)="QAK"
+5 ;ACK code
SET QAK(1)=HL("MID")
+6 ;message control ID
SET QAK(2)=STATUS
+7 SET QAK(3)=""
+8 QUIT $$BLDSEG^SDHL7UL(.QAK,.HL)
+9 ;
QPD(QPD,HL) ;build QPD segment
+1 QUIT $$BLDSEG^SDHL7UL(.QPD,.HL)
+2 ;
QRF(QRY,EXTIME,HL) ; Build QRF segment
+1 NEW QRF
+2 MERGE QRF=QRY("QRF")
+3 SET QRF(0)="QRF"
+4 QUIT $$BLDSEG^SDHL7UL(.QRF,.HL)
+5 ;
RDF(RDF,HL) ; Build RDF segment for DSS Units data
+1 ;
+2 ; Input:
+3 ; HL - HL7 package array variable
+4 ;
+5 ; Output:
+6 ; - Populated message array
+7 ;
+8 QUIT $$BLDSEG^SDHL7UL(.RDF,.HL)
+9 ;
RDT(MSGROOT,DATAROOT,CNT,LEN,HL,FOUND) ; Build RDT segments for Consults elements
+1 ;
+2 ; Walks data in DATAROOT to populate MSGROOT with RDT segments
+3 ; sequentially numbered starting at CNT
+4 ;
+5 ; Integration Agreements:
+6 ; 10103 : FMTHL7^XLFDT
+7 ;
+8 ; Input:
+9 ; MSGROOT - Root of array holding the message
+10 ; DATAROOT - Root of array to hold extract data
+11 ; CNT - Current message line counter
+12 ; LEN - Current message length
+13 ; HL - HL7 package array variable
+14 ; FOUND - (0/1) Flag to indicate consults returned (1) or not (0)
+15 ;
+16 ; Output:
+17 ; - Populated message array
+18 ; - Updated LEN and CNT
+19 ;
+20 ; POPULATE SEQUENCE NUMBER
+21 NEW I,APP,RDT,II,XDT,IEN,DATA,TO,XX,STOP,FS,CC,INST
+22 SET FOUND=0
SET INST=$$KSP^XUPARAM("INST")
+23 ;
+24 SET FS="~"
+25 FOR CC=1:1
if '$DATA(@DATAROOT@(CC))
QUIT
Begin DoDot:1
+26 SET APP=@DATAROOT@(CC,0)
+27 NEW RDT,TO,XX,XDT,IEN,CONSULTS,DATA,STOPDT,REMOTECS,RMTCNID,RMTCS,CONDT
+28 SET DATA="RDT"
+29 SET IEN=$PIECE(^TMP("ORQQCN",$JOB,"CS",CC,0),U)
+30 if +IEN=0
QUIT
+31 SET CONSULTS=$GET(^TMP("ORQQCN",$JOB,"CS",CC,0))
+32 ;773 increase Consults lookup from 365 to 730
SET CONDT=$PIECE(CONSULTS,"^",2)
SET STOPDT=$$FMADD^XLFDT(DT,-730)
+33 ; 2 years of consults.
if $GET(CONDT)<STOPDT
QUIT
+34 SET DATA=DATA_"|"_"C"_FS_$PIECE(CONSULTS,U)_FS_$$TMCONV^SDTMPHLA($PIECE(CONSULTS,"^",2),INST)_FS_$PIECE(CONSULTS,U,4)_FS_$PIECE(CONSULTS,U,7)
+35 DO GETS^DIQ(123,+IEN_",",".06;.07;.08;10;17","IE","RDT")
+36 SET RMTCNID=$GET(RDT(123,+IEN_",",".06","I"))
+37 SET RMTCS=$GET(RDT(123,+IEN_",",".07","I"))
+38 if $GET(RMTCNID)>0
SET REMOTECS=RMTCS_","_RMTCNID
+39 SET XDT=$GET(RDT(123,+IEN_",","17","I"))
+40 if $GET(XDT)'=""
SET XDT=$$TMCONV^SDTMPHLA(XDT,INST)
+41 ;ICR 4837
SET TO=+$PIECE($GET(^GMR(123,+IEN,0)),U,5)
+42 SET XX=0
SET STOP=""
FOR
SET XX=$ORDER(^GMR(123.5,TO,688,XX))
if XX'>0!(XX>5)
QUIT
SET STOP=$GET(STOP)_$PIECE(^GMR(123.5,TO,688,XX,0),U)_","
+43 SET DATA=DATA_FS_$GET(XDT)_FS_STOP_FS_$GET(RDT(123,+IEN_",","10","E"))_FS_$GET(REMOTECS)_FS_$$UP^XLFSTR($PIECE(CONSULTS,"^",3))
+44 FOR II=1:1:9
SET RDT(II)=$PIECE(DATA,II,FS)
+45 SET CNT=CNT+1
+46 SET @MSGROOT@(CNT)=DATA
+47 SET LEN=LEN+$LENGTH(@MSGROOT@(CNT))
+48 SET FOUND=1
+49 QUIT
End DoDot:1
+50 QUIT
RTCRDT(MSGROOT,DATAROOT,CNT,LEN,HL,FOUND) ; Build RDT segments for Return to Clinic elements
+1 ;
+2 ; Walks data in DATAROOT to populate MSGROOT with RDT segments
+3 ; sequentially numbered starting at CNT
+4 ;
+5 ; Integration Agreements:
+6 ; 10103 : FMTHL7^XLFDT
+7 ;
+8 ; Input:
+9 ; MSGROOT - Root of array holding the message
+10 ; DATAROOT - Root of array to hold extract data
+11 ; CNT - Current message line counter
+12 ; LEN - Current message length
+13 ; HL - HL7 package array variable
+14 ; FOUND - (0/1) Flag to indicate consults returned (1) or not (0)
+15 ;
+16 ; Output:
+17 ; - Populated message array
+18 ; - Updated LEN and CNT
+19 NEW I,RDT,II,XDT,IEN,DATA,TO,XX,STOP,FS,CC
+20 SET FOUND=0
+21 ;
+22 SET FS="~"
+23 SET CC=0
+24 FOR
SET CC=$ORDER(@DATAROOT@(CC))
if 'CC
QUIT
Begin DoDot:1
+25 NEW RDT,TO,XX,XDT,IEN,CONSULTS,DATA,STOPDT,REMOTECS,RMTCNID,RMTCS,CONDT,MRTC,RTCINT,RTCPAR,MULTIRTC,PRVID,PRVNM
+26 SET DATA="RDT"
+27 SET IEN=$PIECE(@DATAROOT@(CC),U)
+28 if +IEN=0
QUIT
+29 SET REQDT=$PIECE(@DATAROOT@(CC),U,2)
+30 SET CLINID=$PIECE(@DATAROOT@(CC),U,3)
+31 SET CID=$PIECE(@DATAROOT@(CC),U,4)
+32 SET PRVID=$PIECE(@DATAROOT@(CC),U,5)
+33 SET CMTS=$PIECE(@DATAROOT@(CC),U,6)
+34 SET MRTC=$PIECE(@DATAROOT@(CC),U,7)
+35 SET RTCINT=$PIECE(@DATAROOT@(CC),U,8)
+36 SET RTCPAR=$PIECE(@DATAROOT@(CC),U,9)
+37 if $LENGTH(MRTC)>0
SET MULTIRTC=$GET(MRTC)_","_$GET(RTCINT)_","_$GET(RTCPAR)
+38 IF +CLINID
Begin DoDot:2
+39 SET CLINNM=$$GET1^DIQ(44,CLINID_",",".01")
if CLINNM=""
QUIT
+40 SET STOP=$$GET1^DIQ(44,CLINID_",",8,"I")_","_$$GET1^DIQ(44,CLINID_",",2503,"I")
End DoDot:2
+41 IF +PRVID
Begin DoDot:2
+42 SET PRVNM=$$GET1^DIQ(200,PRVID_",",".01")
End DoDot:2
+43 ;773 increase RTCs lookup from 365 to 730
SET STOPDT=$$FMADD^XLFDT(DT,-730)
+44 ; 2 years of requests
if $GET(REQDT)<STOPDT
QUIT
+45 SET DATA=DATA_"|"_"R"_FS_IEN_FS_$$TMCONV^SDTMPHLA(REQDT,$$INST^SDTMPHLA(CLINID))_FS_CLINID_FS_$GET(CLINNM)_FS_$$TMCONV^SDTMPHLA(CID,$$INST^SDTMPHLA(CLINID))_FS_$GET(STOP)_FS_$GET(PRVNM)_FS_FS_FS_CMTS_FS_$GET(MULTIRTC)
+46 SET CNT=CNT+1
+47 SET @MSGROOT@(CNT)=DATA
+48 SET LEN=LEN+$LENGTH(@MSGROOT@(CNT))
End DoDot:1
+49 QUIT
