BPSJUTL ;BHAM ISC/LJF - e-Pharmacy Utils ;4/17/08 16:13
;;1.0;E CLAIMS MGMT ENGINE;**1,2,5,7,15**;JUN 2004;Build 13
;;Per VHA Directive 2004-038, this routine should not be modified.
;
HLP(PROTOCOL) ; Find the Protocol IEN
Q +$O(^ORD(101,"B",PROTOCOL,0))
;
VAHL7ECH(HL) ; Hl7 Encoding Characters
S FS=$G(HL("FS")) I FS="" S FS="|"
S ECH=$G(HL("ECH")) I ECH="" S ECH="^~\&"
S CPS=$E(ECH),REP=$E(ECH,2)
;
Q
;
MSG(BPSJMM,BPSJRTN) ; Message Handler
;
N XMDUZ,XMSUB,XMY,XMTEXT,XMZ,BPSX,BPSY
;
I $G(BPSJRTN)]"" S BPSJMM(.0001)="Source Process: "_BPSJRTN
F BPSX=1,2 S BPSY=$P($G(^BPS(9002313.99,1,"VITRIA")),"^",BPSX) I BPSY S XMY(BPSY)="" S:$L($G(^VA(200,BPSY,.15))) XMY(^(.15))=""
Q:'$D(XMY)
S XMTEXT="BPSJMM(",XMSUB="ECME Registration Problem.",XMDUZ="ECME PACKAGE"
D ^XMD
;
Q
;
VA200NM(VAIX,VATITLE,HL) ;
;
N RETDATA,BPSNMDAT
N FS,CPS,REP
;
I '$G(VAIX) Q ""
S BPSNMDAT=$P($G(^VA(200,VAIX,0)),U,1) I BPSNMDAT="" Q ""
;
D VAHL7ECH(.HL)
D STDNAME^XLFNAME(.BPSNMDAT,"C")
;
S RETDATA=$G(BPSNMDAT("FAMILY")) ;1
S RETDATA=RETDATA_CPS_$G(BPSNMDAT("GIVEN")) ;2
S RETDATA=RETDATA_CPS_$G(BPSNMDAT("MIDDLE")) ;3
S RETDATA=RETDATA_CPS_$G(BPSNMDAT("SUFFIX")) ;4
S RETDATA=RETDATA_CPS_$G(BPSNMDAT("PREFIX")) ;5
S RETDATA=RETDATA_CPS_$G(BPSNMDAT("DEGREE")) ;6
;
S VATITLE=$P($G(^VA(200,VAIX,0)),U,9)
I VATITLE S VATITLE=$G(^DIC(3.1,VATITLE,0))
;
Q RETDATA
;
VA20013(VAIX,HL) ; Build the HL7 Contact Means data field
;
N FDATA,RETDATA
N FS,CPS,REP
;
I '$G(VAIX) Q ""
; VAIX is the index to ^VA(200,n
D VAHL7ECH(.HL)
S RETDATA=$P($G(^VA(200,VAIX,.15)),U,1) ; LJF@DAOU.COM
I RETDATA]"",RETDATA["@" S RETDATA=CPS_"NET"_CPS_"INTERNET"_CPS_RETDATA
S FDATA=$$EN^BPSJPHNM(VAIX,CPS,REP)
I $L(FDATA) D
. I $L(RETDATA) S RETDATA=RETDATA_REP
. S RETDATA=RETDATA_FDATA
Q RETDATA
;
ENCODE(INSTR,TCH) ; Encode data - Primarily HL7
N X,WCHR,OSTR
S OSTR=""
I $G(INSTR)]"" F X=1:1:$L(INSTR) D S OSTR=OSTR_WCHR
. S WCHR=$E(INSTR,X) I $D(TCH(WCHR)) S WCHR=TCH(WCHR)
Q OSTR
;
SPAR(HL,BPSJSEG,HCTS) ; Segment Parsing
N II,IJ,IK,ISDATA
N FS,CPS,REP,ECH
;
I '$G(HCTS) Q
;
D VAHL7ECH(.HL)
M ISDATA=^TMP($J,"BPSJHLI",HCTS)
S IK=0,IJ=1,II=""
F S II=$O(ISDATA(II)) Q:II="" D
. S ISDATA=$G(ISDATA(II)) Q:ISDATA=""
. F D Q:ISDATA=""
. . S IK=IK+1,BPSJSEG(IJ,IK)=$P(ISDATA,FS)
. . S $P(ISDATA,FS)=""
. . I $E(ISDATA)=FS S IJ=IJ+1,$E(ISDATA)=""
;
; Promote data in 1st subnode and kill subnode
S II=""
F S II=$O(BPSJSEG(II)) Q:II="" D
. S IJ=$O(BPSJSEG(II,"")) Q:'IJ
. S BPSJSEG(II)=BPSJSEG(II,IJ) K BPSJSEG(II,IJ)
Q
;
EPPORT() ;Returns Port Number for HL7 multi-threaded listener
;
; IA #4241 allows read of Logical Link file #870
;
N ACTIVE,LIEN,LINK,PORT,PTR
S LINK="",PORT=""
;Search for links which are multi-threaded listeners
F S LINK=$O(^HLCS(870,"B",LINK)) Q:LINK="" D Q:PORT
.;Check for all links with this name
.S LIEN="" F S LIEN=$O(^HLCS(870,"B",LINK,LIEN)) Q:'LIEN D Q:PORT
..;Ignore if link is not multi-threaded service type
..I $P($G(^HLCS(870,LIEN,400)),U,3)'="M" Q
..;If any pointer field is populated assume link is active
..S ACTIVE=0 F PTR="IN QUEUE FRONT","IN QUEUE BACK","OUT QUEUE FRONT","OUT QUEUE BACK" D Q:ACTIVE
...S:+$G(^HLCS(870,LIEN,PTR_" POINTER")) ACTIVE=1
..;Ignore inactive links
..I 'ACTIVE Q
..;Get Port number
..S PORT=$P($G(^HLCS(870,LIEN,400)),U,2)
;
;Return listener port number
Q PORT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HBPSJUTL 3541 printed Sep 23, 2025@19:27:16 Page 2
BPSJUTL ;BHAM ISC/LJF - e-Pharmacy Utils ;4/17/08 16:13
+1 ;;1.0;E CLAIMS MGMT ENGINE;**1,2,5,7,15**;JUN 2004;Build 13
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
HLP(PROTOCOL) ; Find the Protocol IEN
+1 QUIT +$ORDER(^ORD(101,"B",PROTOCOL,0))
+2 ;
VAHL7ECH(HL) ; Hl7 Encoding Characters
+1 SET FS=$GET(HL("FS"))
IF FS=""
SET FS="|"
+2 SET ECH=$GET(HL("ECH"))
IF ECH=""
SET ECH="^~\&"
+3 SET CPS=$EXTRACT(ECH)
SET REP=$EXTRACT(ECH,2)
+4 ;
+5 QUIT
+6 ;
MSG(BPSJMM,BPSJRTN) ; Message Handler
+1 ;
+2 NEW XMDUZ,XMSUB,XMY,XMTEXT,XMZ,BPSX,BPSY
+3 ;
+4 IF $GET(BPSJRTN)]""
SET BPSJMM(.0001)="Source Process: "_BPSJRTN
+5 FOR BPSX=1,2
SET BPSY=$PIECE($GET(^BPS(9002313.99,1,"VITRIA")),"^",BPSX)
IF BPSY
SET XMY(BPSY)=""
if $LENGTH($GET(^VA(200,BPSY,.15)))
SET XMY(^(.15))=""
+6 if '$DATA(XMY)
QUIT
+7 SET XMTEXT="BPSJMM("
SET XMSUB="ECME Registration Problem."
SET XMDUZ="ECME PACKAGE"
+8 DO ^XMD
+9 ;
+10 QUIT
+11 ;
VA200NM(VAIX,VATITLE,HL) ;
+1 ;
+2 NEW RETDATA,BPSNMDAT
+3 NEW FS,CPS,REP
+4 ;
+5 IF '$GET(VAIX)
QUIT ""
+6 SET BPSNMDAT=$PIECE($GET(^VA(200,VAIX,0)),U,1)
IF BPSNMDAT=""
QUIT ""
+7 ;
+8 DO VAHL7ECH(.HL)
+9 DO STDNAME^XLFNAME(.BPSNMDAT,"C")
+10 ;
+11 ;1
SET RETDATA=$GET(BPSNMDAT("FAMILY"))
+12 ;2
SET RETDATA=RETDATA_CPS_$GET(BPSNMDAT("GIVEN"))
+13 ;3
SET RETDATA=RETDATA_CPS_$GET(BPSNMDAT("MIDDLE"))
+14 ;4
SET RETDATA=RETDATA_CPS_$GET(BPSNMDAT("SUFFIX"))
+15 ;5
SET RETDATA=RETDATA_CPS_$GET(BPSNMDAT("PREFIX"))
+16 ;6
SET RETDATA=RETDATA_CPS_$GET(BPSNMDAT("DEGREE"))
+17 ;
+18 SET VATITLE=$PIECE($GET(^VA(200,VAIX,0)),U,9)
+19 IF VATITLE
SET VATITLE=$GET(^DIC(3.1,VATITLE,0))
+20 ;
+21 QUIT RETDATA
+22 ;
VA20013(VAIX,HL) ; Build the HL7 Contact Means data field
+1 ;
+2 NEW FDATA,RETDATA
+3 NEW FS,CPS,REP
+4 ;
+5 IF '$GET(VAIX)
QUIT ""
+6 ; VAIX is the index to ^VA(200,n
+7 DO VAHL7ECH(.HL)
+8 ; LJF@DAOU.COM
SET RETDATA=$PIECE($GET(^VA(200,VAIX,.15)),U,1)
+9 IF RETDATA]""
IF RETDATA["@"
SET RETDATA=CPS_"NET"_CPS_"INTERNET"_CPS_RETDATA
+10 SET FDATA=$$EN^BPSJPHNM(VAIX,CPS,REP)
+11 IF $LENGTH(FDATA)
Begin DoDot:1
+12 IF $LENGTH(RETDATA)
SET RETDATA=RETDATA_REP
+13 SET RETDATA=RETDATA_FDATA
End DoDot:1
+14 QUIT RETDATA
+15 ;
ENCODE(INSTR,TCH) ; Encode data - Primarily HL7
+1 NEW X,WCHR,OSTR
+2 SET OSTR=""
+3 IF $GET(INSTR)]""
FOR X=1:1:$LENGTH(INSTR)
Begin DoDot:1
+4 SET WCHR=$EXTRACT(INSTR,X)
IF $DATA(TCH(WCHR))
SET WCHR=TCH(WCHR)
End DoDot:1
SET OSTR=OSTR_WCHR
+5 QUIT OSTR
+6 ;
SPAR(HL,BPSJSEG,HCTS) ; Segment Parsing
+1 NEW II,IJ,IK,ISDATA
+2 NEW FS,CPS,REP,ECH
+3 ;
+4 IF '$GET(HCTS)
QUIT
+5 ;
+6 DO VAHL7ECH(.HL)
+7 MERGE ISDATA=^TMP($JOB,"BPSJHLI",HCTS)
+8 SET IK=0
SET IJ=1
SET II=""
+9 FOR
SET II=$ORDER(ISDATA(II))
if II=""
QUIT
Begin DoDot:1
+10 SET ISDATA=$GET(ISDATA(II))
if ISDATA=""
QUIT
+11 FOR
Begin DoDot:2
+12 SET IK=IK+1
SET BPSJSEG(IJ,IK)=$PIECE(ISDATA,FS)
+13 SET $PIECE(ISDATA,FS)=""
+14 IF $EXTRACT(ISDATA)=FS
SET IJ=IJ+1
SET $EXTRACT(ISDATA)=""
End DoDot:2
if ISDATA=""
QUIT
End DoDot:1
+15 ;
+16 ; Promote data in 1st subnode and kill subnode
+17 SET II=""
+18 FOR
SET II=$ORDER(BPSJSEG(II))
if II=""
QUIT
Begin DoDot:1
+19 SET IJ=$ORDER(BPSJSEG(II,""))
if 'IJ
QUIT
+20 SET BPSJSEG(II)=BPSJSEG(II,IJ)
KILL BPSJSEG(II,IJ)
End DoDot:1
+21 QUIT
+22 ;
EPPORT() ;Returns Port Number for HL7 multi-threaded listener
+1 ;
+2 ; IA #4241 allows read of Logical Link file #870
+3 ;
+4 NEW ACTIVE,LIEN,LINK,PORT,PTR
+5 SET LINK=""
SET PORT=""
+6 ;Search for links which are multi-threaded listeners
+7 FOR
SET LINK=$ORDER(^HLCS(870,"B",LINK))
if LINK=""
QUIT
Begin DoDot:1
+8 ;Check for all links with this name
+9 SET LIEN=""
FOR
SET LIEN=$ORDER(^HLCS(870,"B",LINK,LIEN))
if 'LIEN
QUIT
Begin DoDot:2
+10 ;Ignore if link is not multi-threaded service type
+11 IF $PIECE($GET(^HLCS(870,LIEN,400)),U,3)'="M"
QUIT
+12 ;If any pointer field is populated assume link is active
+13 SET ACTIVE=0
FOR PTR="IN QUEUE FRONT","IN QUEUE BACK","OUT QUEUE FRONT","OUT QUEUE BACK"
Begin DoDot:3
+14 if +$GET(^HLCS(870,LIEN,PTR_" POINTER"))
SET ACTIVE=1
End DoDot:3
if ACTIVE
QUIT
+15 ;Ignore inactive links
+16 IF 'ACTIVE
QUIT
+17 ;Get Port number
+18 SET PORT=$PIECE($GET(^HLCS(870,LIEN,400)),U,2)
End DoDot:2
if PORT
QUIT
End DoDot:1
if PORT
QUIT
+19 ;
+20 ;Return listener port number
+21 QUIT PORT
