PSBSVHL7 ;BIRMINGHAM/TEJ - BCMA HL7 SERVER ;5/28/10 1:48pm
;;3.0;BAR CODE MED ADMIN;**3,42**;Mar 2004;Build 23
; Reference/IA
; $$HLDATE^HLFNC/10106
; $$HLNAME^HLFNC/10106
; INIT^HLFNC2/2161
; GENERATE^HLMA/2164
; File 50.7/2880
; File 52.6/436
; File 52.7/437
; File 200/10060
; DEM^VADPT/10061
;
; Description:
; This routine is to service BCMA HL7 messaging to other COTS and
; VISTA application.
; The entry point ("EN") is accessed via BCMA. This routine
; basically consists of subroutines to generate HL7 messages
; per trigger events corresponding to BCMA transactions.
; These trigger events are captured within the routine PSBML.
; PSBML passes the affected BCMA MEDICATION LOG File IEN and
; a variable capturing the BCMA activity as the input.
; Input - PSBIEN Affected BCMA record(s)
; PSBHL7X BCMA trigger event/transaction
; Output - HL7 broadcast to subscribing Applications
;
EN(PSBIEN,PSBHL7X) ; This is the entry point for all HL7 processing
1 ; set up environment for message
N PSBHLFS,PSBHLCS
D INIT^HLFNC2("PSB BCMA RASO17 SRV",.HL)
I $G(HL) W:+HL'=16 !,"Error: "_$P(HL,2) Q ; error occurred
S PSBHLFS=$G(HL("FS")) I PSBHLFS="" S PSBHLFS="^"
S PSBHLCS=$E(HL("ECH"),1)
S PSBHLSCS=$E(HL("ECH"),4)
2 ; Add appropriate message txt to HLA array
K HLA,HLEVN
N PSBDFN,PSBHL7MS
S PSBCNT=0
I (PSBHL7X["MEDPASS")!(PSBHL7X["UPDATE STATUS") D MEDSTAT Q
I (PSBHL7X["ADD COMMENT") D COMMENT Q
I (PSBHL7X["PRN EFFECTI") D PRNEFFE Q
Q
MEDSTAT ;MEDPASS and UPDATE trigger events
D PID,PV1,ORC,RXO
D:$D(^PSB(53.79,PSBIEN,.3,0)) NTE
D RXR,RXC,RXA,TRANS Q
D PID,ORC,NTE,TRANS Q
PRNEFFE ;PRN EFFECTIVENESS trigger event
D PID,ORC,NTE,TRANS Q
PID ; PID segment -- use segment generator
S PSBDFN=$P(^PSB(53.79,PSBIEN,0),U,1),DFN=PSBDFN D DEM^VADPT
S PSBCNT=PSBCNT+1,$P(PSBHL7MS,PSBHLFS,3)=PSBDFN
S $P(VADM(4),PSBHLCS)=VADM(4),$P(VADM(4),PSBHLCS,5)="AGE",$P(PSBHL7MS,PSBHLFS,4)=VADM(4)
S $P(PSBHL7MS,PSBHLFS,5)=$$HLNAME^HLFNC(VADM(1),HL("ECH"))
S $P(PSBHL7MS,PSBHLFS,7)=$$HLDATE^HLFNC(+VADM(3),"DT")
S $P(PSBHL7MS,PSBHLFS,19)=$TR(VA("PID"),"-") ;IHS/VA - use VA("PID")
S $P(PSBHL7MS,PSBHLFS,8)=$P(VADM(5),"^")
S HLA("HLS",PSBCNT)="PID"_PSBHLFS_PSBHL7MS
Q
PV1 ; PV1 segment
K PSBHL7MS,PSBHL7FD
S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="PV1"_PSBHLFS
S $P(PSBHL7MS,PSBHLFS,2)="U"
; Construct location field
S $P(PSBHL7FD,PSBHLCS,1)=$$ESC($P(^PSB(53.79,PSBIEN,0),U,2))
S $P(PSBHL7FD,PSBHLCS,4)=$$ESC($P(^PSB(53.79,PSBIEN,0),U,3))
S $P(PSBHL7MS,PSBHLFS,3)=PSBHL7FD K PSBHL7FD
; Construct attending physician data
S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,0),U,5)
S $P(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$P(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
S $P(PSBHL7MS,PSBHLFS,7)=PSBHL7FD K PSBHL7FD
S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
Q
ORC ; ORC segment
K PSBHL7MS,PSBHL7FD
S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="ORC"_PSBHLFS
S $P(PSBHL7MS,PSBHLFS,1)="XX"
S $P(PSBHL7MS,PSBHLFS,2)=PSBIEN_PSBHLCS_"PSB"_PSBHLCS_PSBIEN_PSBHLCS_"IEN"
S $P(PSBHL7MS,PSBHLFS,3)=$P(^PSB(53.79,PSBIEN,.1),U)
D PSJ1^PSBVT(PSBDFN,$P(PSBHL7MS,PSBHLFS,3))
; Construct quantity/time
S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,.1),U,5)
S $P(PSBHL7FD,PSBHLCS,2)=$$ESC(PSBSCH)
S $P(PSBHL7FD,PSBHLCS,4)=$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,.1),U,3),"TS")
S $P(PSBHL7FD,PSBHLCS,10)=$$ESC(PSBSCHT)
S $P(PSBHL7MS,PSBHLFS,7)=PSBHL7FD K PSBHL7FD
; Construct previous (parent) order data
S:$D(PSBPONX) $P(PSBHL7FD,PSBHLCS,2)=PSBPONX
S $P(PSBHL7MS,PSBHLFS,8)=$G(PSBHL7FD) K PSBHL7FD
S $P(PSBHL7MS,PSBHLFS,9)=$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,0),U,6),"TS")
; Construct entered by data
S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,0),U,5)
S $P(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$P(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
S $P(PSBHL7MS,PSBHLFS,10)=PSBHL7FD K PSBHL7FD
S $P(PSBHL7MS,PSBHLFS,15)=$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,0),U,4),"TS")
; Construct action by data
S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,0),U,7)
S $P(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$P(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
S $P(PSBHL7MS,PSBHLFS,19)=PSBHL7FD K PSBHL7FD
S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
Q
RXO ; RXO segment
K PSBHL7MS,PSBHL7FD
S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="RXO"_PSBHLFS
; Construct rq give code data
S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,0),U,8)
S $P(PSBHL7FD,PSBHLCS,2)=$$GET1^DIQ(50.7,$P(PSBHL7FD,PSBHLCS,1)_",",.01)
S $P(PSBHL7MS,PSBHLFS,1)=PSBHL7FD K PSBHL7FD
S $P(PSBHL7MS,PSBHLFS,2)=$$ESC($P(^PSB(53.79,PSBIEN,.1),U,5))
S $P(PSBHL7MS,PSBHLFS,10)=$$ESC($P(^PSB(53.79,PSBIEN,0),U,10))
S $P(PSBHL7FD,PSBHLCS,2)=$$ESC($P(^PSB(53.79,PSBIEN,0),U,11))
S $P(PSBHL7MS,PSBHLFS,21)=PSBHL7FD
S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
Q
NTE ; NTE segment(s) - notes and comments
K PSBHL7MS,PSBHL7FD
S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="NTE"_PSBHLFS
S $P(PSBHL7MS,PSBHLFS,2)="O"
; Construct comment and comment type
D:($G(PSBSCHT)="P")&($D(^PSB(53.79,PSBIEN,.2)))&(PSBHL7X["PRN EFF")
.S $P(PSBHL7MS,PSBHLFS,3)=$$ESC($P(^PSB(53.79,PSBIEN,.2),U,2))
.S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,.2),U,3)
.S $P(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$P(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
.S $P(PSBHL7FD,PSBHLCS,4)=$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,.2),U,4),"TS")
.S $P(PSBHL7FD,PSBHLCS,5)="Date Entered"
.S $P(PSBHL7FD,PSBHLCS,7)=$P(^PSB(53.79,PSBIEN,.2),U,5)
.S $P(PSBHL7FD,PSBHLCS,8)="PRN Minutes"
.S $P(PSBHL7MS,PSBHLFS,4)=PSBHL7FD K PSBHL7FD
D:$D(^PSB(53.79,PSBIEN,.3,0))&(PSBHL7X'["PRN EFF")
.S PSBINDX="",PSBINDX=$O(^PSB(53.79,PSBIEN,.3,PSBINDX),-1)
.S $P(PSBHL7MS,PSBHLFS,3)=PSBINDX_PSBHLCS_$$ESC($P(^PSB(53.79,PSBIEN,.3,PSBINDX,0),U))
.S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,.3,PSBINDX,0),U,2)
.S $P(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$P(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
.S $P(PSBHL7FD,PSBHLCS,4)=$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,.3,PSBINDX,0),U,3),"TS")
.S $P(PSBHL7FD,PSBHLCS,5)="Date Entered"
.S $P(PSBHL7MS,PSBHLFS,4)=PSBHL7FD K PSBHL7FD
S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
Q
RXR ; RXR segment
K PSBHL7MS,PSBHL7FD
S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="RXR"_PSBHLFS
S:$D(PSBMRAB) $P(PSBHL7MS,PSBHLFS,1)=PSBMRAB
S $P(PSBHL7MS,PSBHLFS,2)=$P($G(^PSB(53.79,PSBIEN,.1)),U,6)
S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
S:""=$TR(PSBHL7MS,PSBHLFS,"") PSBCNT=PSBCNT-1
Q
RXC ; RXC segment
; loop through .5,.6,and .7 send segments for each "component"
K PSBSUBFD F PSBSUBFD=".5",".6",".7" D:$D(^PSB(53.79,PSBIEN,PSBSUBFD,1))
.K PSBFILE S PSBFILE=$S(PSBSUBFD=".5":"^PSDRUG(",PSBSUBFD=".6":"^PS(52.6,",PSBSUBFD=".7":"^PS(52.7,")
.K PSBRXTYP S PSBRXTYP=$S(PSBSUBFD=".5":"B",PSBSUBFD=".6":"A",PSBSUBFD=".7":"B")
.S PSBSUBX=0 F S PSBSUBX=$O(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX)) Q:+PSBSUBX=0 D
..K PSBHL7MS,PSBHL7FD S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="RXC"_PSBHLFS
..S $P(PSBHL7MS,PSBHLFS,1)=PSBRXTYP
..; Construct component code data
..S $P(PSBHL7FD,PSBHLCS,1)=$P(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U)
..S PSBFILE1=PSBFILE_$P(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U)_",0)"
..I $P(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U)]"" S $P(PSBHL7FD,PSBHLCS,2)=$P($G(@PSBFILE1),U) K PSBFILE1
..I $G(PSBHL7FD)]"" S $P(PSBHL7MS,PSBHLFS,2)=PSBHL7FD,PSBRXAX=PSBHL7FD,PSBRXA(PSBRXAX)="RXA ADMIN CODE" K PSBHL7FD
..S $P(PSBHL7MS,PSBHLFS,3)=$P(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U,2)
..S $P(PSBHL7MS,PSBHLFS,4)=$P(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U,4)
..I $G(PSBRXAX)]"" S PSBRXA(PSBRXAX)=$P(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U,3)_U_$P(PSBHL7MS,PSBHLFS,4)
..S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
Q
RXA ; RXA segment
K PSBHL7MS,PSBHL7FD S PSBRXAX=""
F PSBRX=1:1 S PSBRXAX=$O(PSBRXA(PSBRXAX)) Q:PSBRXAX="" D
.S PSBCNT=PSBCNT+1,HLA("HLS",PSBCNT)="RXA"_PSBHLFS
.S $P(PSBHL7MS,PSBHLFS,1)=0
.S $P(PSBHL7MS,PSBHLFS,2)=PSBRX
.S $P(PSBHL7MS,PSBHLFS,3)=$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,0),U,6),"TS")
.S $P(PSBHL7MS,PSBHLFS,4)=" "
.; Construct administered code data
.S $P(PSBHL7MS,PSBHLFS,5)=PSBRXAX
.S $P(PSBHL7MS,PSBHLFS,6)=$P(PSBRXA(PSBRXAX),U)
.S $P(PSBHL7MS,PSBHLFS,7)=$P(PSBRXA(PSBRXAX),U,2)
.D:$D(^PSB(53.79,PSBIEN,.9,1))
..S PSBINDX=$O(^PSB(53.79,PSBIEN,.9,"B"),-1)
..S:$D(PSBINDX) $P(PSBHL7MS,PSBHLFS,9)=PSBINDX_PSBHLCS_$$HLDATE^HLFNC($P(^PSB(53.79,PSBIEN,.9,PSBINDX,0),U),"TS")
.; "PRN reason"
.S:($G(PSBSCHT)="P")&($D(^PSB(53.79,PSBIEN,.2))) $P(PSBHL7FD,PSBHLCS,2)=$P(^PSB(53.79,PSBIEN,.2),U,1)
.S $P(PSBHL7MS,PSBHLFS,18)=$G(PSBHL7FD) K PSBHL7FD
.; Construct indication - "variance"
.S $P(PSBHL7FD,PSBHLCS,2)=$P(^PSB(53.79,PSBIEN,.1),U,4)
.S $P(PSBHL7MS,PSBHLFS,19)=PSBHL7FD K PSBHL7FD
.S $P(PSBHL7MS,PSBHLFS,20)=$P(^PSB(53.79,PSBIEN,0),U,9)
.S HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
K PSBRX,PSBRXA,PSBRXAX
Q
ESC(PSBINF) ; Escape message data
S PSBINFO=PSBINF K PSBESC,PSBINFO1 F PSBESCX=1:1:4 D
.S PSBCHR=$E(HL("ECH"),PSBESCX)
.I ($L(PSBINFO,PSBCHR)-1)>0 S PSBINFO1=PSBINFO F PSBESCXX=1:1:$L(PSBINFO,PSBCHR)-1 D
..S PSBESC($F(PSBINFO1,PSBCHR)-1)=$E(HL("ECH"),3)_$E("SRET",PSBESCX)_$E(HL("ECH"),3)
..S PSBINFO1=$E(PSBINFO1,1,$F(PSBINFO1,PSBCHR)-2)_U_$E(PSBINFO1,$F(PSBINFO1,PSBCHR),250)
S:$D(PSBINFO1) PSBINFO=PSBINFO1
S (PSBCNT1,PSBESCX,PSBESCXX)=0 F S PSBESCX=$O(PSBESC(PSBESCX)) Q:PSBESCX="" D
.S PSBESCXX=PSBESCX+PSBCNT1,PSBINFO=$E(PSBINFO,1,PSBESCXX-1)_$G(PSBESC(PSBESCX))_$E(PSBINFO,PSBESCXX+1,250),PSBCNT1=PSBCNT1+2
Q PSBINFO
;
TRANS ; CALL HL7 TO Transmit Message
K PSBHL7MS,PSBHL7FD
D:$D(HLA("HLS")) GENERATE^HLMA("PSB BCMA RASO17 SRV","LM",1,.PSBHL7T,"",.PSBHL7OP)
I +$P(PSBHL7T,U,2) W !,"PSB(BCMA) HL7 MESSAGE HAS FAILED TRANSMISSION - could not generate"
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBSVHL7 9988 printed Dec 13, 2024@01:41:13 Page 2
PSBSVHL7 ;BIRMINGHAM/TEJ - BCMA HL7 SERVER ;5/28/10 1:48pm
+1 ;;3.0;BAR CODE MED ADMIN;**3,42**;Mar 2004;Build 23
+2 ; Reference/IA
+3 ; $$HLDATE^HLFNC/10106
+4 ; $$HLNAME^HLFNC/10106
+5 ; INIT^HLFNC2/2161
+6 ; GENERATE^HLMA/2164
+7 ; File 50.7/2880
+8 ; File 52.6/436
+9 ; File 52.7/437
+10 ; File 200/10060
+11 ; DEM^VADPT/10061
+12 ;
+13 ; Description:
+14 ; This routine is to service BCMA HL7 messaging to other COTS and
+15 ; VISTA application.
+16 ; The entry point ("EN") is accessed via BCMA. This routine
+17 ; basically consists of subroutines to generate HL7 messages
+18 ; per trigger events corresponding to BCMA transactions.
+19 ; These trigger events are captured within the routine PSBML.
+20 ; PSBML passes the affected BCMA MEDICATION LOG File IEN and
+21 ; a variable capturing the BCMA activity as the input.
+22 ; Input - PSBIEN Affected BCMA record(s)
+23 ; PSBHL7X BCMA trigger event/transaction
+24 ; Output - HL7 broadcast to subscribing Applications
+25 ;
EN(PSBIEN,PSBHL7X) ; This is the entry point for all HL7 processing
1 ; set up environment for message
+1 NEW PSBHLFS,PSBHLCS
+2 DO INIT^HLFNC2("PSB BCMA RASO17 SRV",.HL)
+3 ; error occurred
IF $GET(HL)
if +HL'=16
WRITE !,"Error: "_$PIECE(HL,2)
QUIT
+4 SET PSBHLFS=$GET(HL("FS"))
IF PSBHLFS=""
SET PSBHLFS="^"
+5 SET PSBHLCS=$EXTRACT(HL("ECH"),1)
+6 SET PSBHLSCS=$EXTRACT(HL("ECH"),4)
2 ; Add appropriate message txt to HLA array
+1 KILL HLA,HLEVN
+2 NEW PSBDFN,PSBHL7MS
+3 SET PSBCNT=0
+4 IF (PSBHL7X["MEDPASS")!(PSBHL7X["UPDATE STATUS")
DO MEDSTAT
QUIT
+5 IF (PSBHL7X["ADD COMMENT")
DO COMMENT
QUIT
+6 IF (PSBHL7X["PRN EFFECTI")
DO PRNEFFE
QUIT
+7 QUIT
MEDSTAT ;MEDPASS and UPDATE trigger events
+1 DO PID
DO PV1
DO ORC
DO RXO
+2 if $DATA(^PSB(53.79,PSBIEN,.3,0))
DO NTE
+3 DO RXR
DO RXC
DO RXA
DO TRANS
QUIT
+1 DO PID
DO ORC
DO NTE
DO TRANS
QUIT
PRNEFFE ;PRN EFFECTIVENESS trigger event
+1 DO PID
DO ORC
DO NTE
DO TRANS
QUIT
PID ; PID segment -- use segment generator
+1 SET PSBDFN=$PIECE(^PSB(53.79,PSBIEN,0),U,1)
SET DFN=PSBDFN
DO DEM^VADPT
+2 SET PSBCNT=PSBCNT+1
SET $PIECE(PSBHL7MS,PSBHLFS,3)=PSBDFN
+3 SET $PIECE(VADM(4),PSBHLCS)=VADM(4)
SET $PIECE(VADM(4),PSBHLCS,5)="AGE"
SET $PIECE(PSBHL7MS,PSBHLFS,4)=VADM(4)
+4 SET $PIECE(PSBHL7MS,PSBHLFS,5)=$$HLNAME^HLFNC(VADM(1),HL("ECH"))
+5 SET $PIECE(PSBHL7MS,PSBHLFS,7)=$$HLDATE^HLFNC(+VADM(3),"DT")
+6 ;IHS/VA - use VA("PID")
SET $PIECE(PSBHL7MS,PSBHLFS,19)=$TRANSLATE(VA("PID"),"-")
+7 SET $PIECE(PSBHL7MS,PSBHLFS,8)=$PIECE(VADM(5),"^")
+8 SET HLA("HLS",PSBCNT)="PID"_PSBHLFS_PSBHL7MS
+9 QUIT
PV1 ; PV1 segment
+1 KILL PSBHL7MS,PSBHL7FD
+2 SET PSBCNT=PSBCNT+1
SET HLA("HLS",PSBCNT)="PV1"_PSBHLFS
+3 SET $PIECE(PSBHL7MS,PSBHLFS,2)="U"
+4 ; Construct location field
+5 SET $PIECE(PSBHL7FD,PSBHLCS,1)=$$ESC($PIECE(^PSB(53.79,PSBIEN,0),U,2))
+6 SET $PIECE(PSBHL7FD,PSBHLCS,4)=$$ESC($PIECE(^PSB(53.79,PSBIEN,0),U,3))
+7 SET $PIECE(PSBHL7MS,PSBHLFS,3)=PSBHL7FD
KILL PSBHL7FD
+8 ; Construct attending physician data
+9 SET $PIECE(PSBHL7FD,PSBHLCS,1)=$PIECE(^PSB(53.79,PSBIEN,0),U,5)
+10 SET $PIECE(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$PIECE(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
+11 SET $PIECE(PSBHL7MS,PSBHLFS,7)=PSBHL7FD
KILL PSBHL7FD
+12 SET HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
+13 QUIT
ORC ; ORC segment
+1 KILL PSBHL7MS,PSBHL7FD
+2 SET PSBCNT=PSBCNT+1
SET HLA("HLS",PSBCNT)="ORC"_PSBHLFS
+3 SET $PIECE(PSBHL7MS,PSBHLFS,1)="XX"
+4 SET $PIECE(PSBHL7MS,PSBHLFS,2)=PSBIEN_PSBHLCS_"PSB"_PSBHLCS_PSBIEN_PSBHLCS_"IEN"
+5 SET $PIECE(PSBHL7MS,PSBHLFS,3)=$PIECE(^PSB(53.79,PSBIEN,.1),U)
+6 DO PSJ1^PSBVT(PSBDFN,$PIECE(PSBHL7MS,PSBHLFS,3))
+7 ; Construct quantity/time
+8 SET $PIECE(PSBHL7FD,PSBHLCS,1)=$PIECE(^PSB(53.79,PSBIEN,.1),U,5)
+9 SET $PIECE(PSBHL7FD,PSBHLCS,2)=$$ESC(PSBSCH)
+10 SET $PIECE(PSBHL7FD,PSBHLCS,4)=$$HLDATE^HLFNC($PIECE(^PSB(53.79,PSBIEN,.1),U,3),"TS")
+11 SET $PIECE(PSBHL7FD,PSBHLCS,10)=$$ESC(PSBSCHT)
+12 SET $PIECE(PSBHL7MS,PSBHLFS,7)=PSBHL7FD
KILL PSBHL7FD
+13 ; Construct previous (parent) order data
+14 if $DATA(PSBPONX)
SET $PIECE(PSBHL7FD,PSBHLCS,2)=PSBPONX
+15 SET $PIECE(PSBHL7MS,PSBHLFS,8)=$GET(PSBHL7FD)
KILL PSBHL7FD
+16 SET $PIECE(PSBHL7MS,PSBHLFS,9)=$$HLDATE^HLFNC($PIECE(^PSB(53.79,PSBIEN,0),U,6),"TS")
+17 ; Construct entered by data
+18 SET $PIECE(PSBHL7FD,PSBHLCS,1)=$PIECE(^PSB(53.79,PSBIEN,0),U,5)
+19 SET $PIECE(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$PIECE(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
+20 SET $PIECE(PSBHL7MS,PSBHLFS,10)=PSBHL7FD
KILL PSBHL7FD
+21 SET $PIECE(PSBHL7MS,PSBHLFS,15)=$$HLDATE^HLFNC($PIECE(^PSB(53.79,PSBIEN,0),U,4),"TS")
+22 ; Construct action by data
+23 SET $PIECE(PSBHL7FD,PSBHLCS,1)=$PIECE(^PSB(53.79,PSBIEN,0),U,7)
+24 SET $PIECE(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$PIECE(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
+25 SET $PIECE(PSBHL7MS,PSBHLFS,19)=PSBHL7FD
KILL PSBHL7FD
+26 SET HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
+27 QUIT
RXO ; RXO segment
+1 KILL PSBHL7MS,PSBHL7FD
+2 SET PSBCNT=PSBCNT+1
SET HLA("HLS",PSBCNT)="RXO"_PSBHLFS
+3 ; Construct rq give code data
+4 SET $PIECE(PSBHL7FD,PSBHLCS,1)=$PIECE(^PSB(53.79,PSBIEN,0),U,8)
+5 SET $PIECE(PSBHL7FD,PSBHLCS,2)=$$GET1^DIQ(50.7,$PIECE(PSBHL7FD,PSBHLCS,1)_",",.01)
+6 SET $PIECE(PSBHL7MS,PSBHLFS,1)=PSBHL7FD
KILL PSBHL7FD
+7 SET $PIECE(PSBHL7MS,PSBHLFS,2)=$$ESC($PIECE(^PSB(53.79,PSBIEN,.1),U,5))
+8 SET $PIECE(PSBHL7MS,PSBHLFS,10)=$$ESC($PIECE(^PSB(53.79,PSBIEN,0),U,10))
+9 SET $PIECE(PSBHL7FD,PSBHLCS,2)=$$ESC($PIECE(^PSB(53.79,PSBIEN,0),U,11))
+10 SET $PIECE(PSBHL7MS,PSBHLFS,21)=PSBHL7FD
+11 SET HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
+12 QUIT
NTE ; NTE segment(s) - notes and comments
+1 KILL PSBHL7MS,PSBHL7FD
+2 SET PSBCNT=PSBCNT+1
SET HLA("HLS",PSBCNT)="NTE"_PSBHLFS
+3 SET $PIECE(PSBHL7MS,PSBHLFS,2)="O"
+4 ; Construct comment and comment type
+5 if ($GET(PSBSCHT)="P")&($DATA(^PSB(53.79,PSBIEN,.2)))&(PSBHL7X["PRN EFF")
Begin DoDot:1
+6 SET $PIECE(PSBHL7MS,PSBHLFS,3)=$$ESC($PIECE(^PSB(53.79,PSBIEN,.2),U,2))
+7 SET $PIECE(PSBHL7FD,PSBHLCS,1)=$PIECE(^PSB(53.79,PSBIEN,.2),U,3)
+8 SET $PIECE(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$PIECE(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
+9 SET $PIECE(PSBHL7FD,PSBHLCS,4)=$$HLDATE^HLFNC($PIECE(^PSB(53.79,PSBIEN,.2),U,4),"TS")
+10 SET $PIECE(PSBHL7FD,PSBHLCS,5)="Date Entered"
+11 SET $PIECE(PSBHL7FD,PSBHLCS,7)=$PIECE(^PSB(53.79,PSBIEN,.2),U,5)
+12 SET $PIECE(PSBHL7FD,PSBHLCS,8)="PRN Minutes"
+13 SET $PIECE(PSBHL7MS,PSBHLFS,4)=PSBHL7FD
KILL PSBHL7FD
End DoDot:1
+14 if $DATA(^PSB(53.79,PSBIEN,.3,0))&(PSBHL7X'["PRN EFF")
Begin DoDot:1
+15 SET PSBINDX=""
SET PSBINDX=$ORDER(^PSB(53.79,PSBIEN,.3,PSBINDX),-1)
+16 SET $PIECE(PSBHL7MS,PSBHLFS,3)=PSBINDX_PSBHLCS_$$ESC($PIECE(^PSB(53.79,PSBIEN,.3,PSBINDX,0),U))
+17 SET $PIECE(PSBHL7FD,PSBHLCS,1)=$PIECE(^PSB(53.79,PSBIEN,.3,PSBINDX,0),U,2)
+18 SET $PIECE(PSBHL7FD,PSBHLCS,2)=$$HLNAME^HLFNC($$GET1^DIQ(200,$PIECE(PSBHL7FD,PSBHLCS,1)_",",.01),HL("ECH"))
+19 SET $PIECE(PSBHL7FD,PSBHLCS,4)=$$HLDATE^HLFNC($PIECE(^PSB(53.79,PSBIEN,.3,PSBINDX,0),U,3),"TS")
+20 SET $PIECE(PSBHL7FD,PSBHLCS,5)="Date Entered"
+21 SET $PIECE(PSBHL7MS,PSBHLFS,4)=PSBHL7FD
KILL PSBHL7FD
End DoDot:1
+22 SET HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
+23 QUIT
RXR ; RXR segment
+1 KILL PSBHL7MS,PSBHL7FD
+2 SET PSBCNT=PSBCNT+1
SET HLA("HLS",PSBCNT)="RXR"_PSBHLFS
+3 if $DATA(PSBMRAB)
SET $PIECE(PSBHL7MS,PSBHLFS,1)=PSBMRAB
+4 SET $PIECE(PSBHL7MS,PSBHLFS,2)=$PIECE($GET(^PSB(53.79,PSBIEN,.1)),U,6)
+5 SET HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
+6 if ""=$TRANSLATE(PSBHL7MS,PSBHLFS,"")
SET PSBCNT=PSBCNT-1
+7 QUIT
RXC ; RXC segment
+1 ; loop through .5,.6,and .7 send segments for each "component"
+2 KILL PSBSUBFD
FOR PSBSUBFD=".5",".6",".7"
if $DATA(^PSB(53.79,PSBIEN,PSBSUBFD,1))
Begin DoDot:1
+3 KILL PSBFILE
SET PSBFILE=$SELECT(PSBSUBFD=".5":"^PSDRUG(",PSBSUBFD=".6":"^PS(52.6,",PSBSUBFD=".7":"^PS(52.7,")
+4 KILL PSBRXTYP
SET PSBRXTYP=$SELECT(PSBSUBFD=".5":"B",PSBSUBFD=".6":"A",PSBSUBFD=".7":"B")
+5 SET PSBSUBX=0
FOR
SET PSBSUBX=$ORDER(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX))
if +PSBSUBX=0
QUIT
Begin DoDot:2
+6 KILL PSBHL7MS,PSBHL7FD
SET PSBCNT=PSBCNT+1
SET HLA("HLS",PSBCNT)="RXC"_PSBHLFS
+7 SET $PIECE(PSBHL7MS,PSBHLFS,1)=PSBRXTYP
+8 ; Construct component code data
+9 SET $PIECE(PSBHL7FD,PSBHLCS,1)=$PIECE(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U)
+10 SET PSBFILE1=PSBFILE_$PIECE(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U)_",0)"
+11 IF $PIECE(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U)]""
SET $PIECE(PSBHL7FD,PSBHLCS,2)=$PIECE($GET(@PSBFILE1),U)
KILL PSBFILE1
+12 IF $GET(PSBHL7FD)]""
SET $PIECE(PSBHL7MS,PSBHLFS,2)=PSBHL7FD
SET PSBRXAX=PSBHL7FD
SET PSBRXA(PSBRXAX)="RXA ADMIN CODE"
KILL PSBHL7FD
+13 SET $PIECE(PSBHL7MS,PSBHLFS,3)=$PIECE(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U,2)
+14 SET $PIECE(PSBHL7MS,PSBHLFS,4)=$PIECE(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U,4)
+15 IF $GET(PSBRXAX)]""
SET PSBRXA(PSBRXAX)=$PIECE(^PSB(53.79,PSBIEN,PSBSUBFD,PSBSUBX,0),U,3)_U_$PIECE(PSBHL7MS,PSBHLFS,4)
+16 SET HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
End DoDot:2
End DoDot:1
+17 QUIT
RXA ; RXA segment
+1 KILL PSBHL7MS,PSBHL7FD
SET PSBRXAX=""
+2 FOR PSBRX=1:1
SET PSBRXAX=$ORDER(PSBRXA(PSBRXAX))
if PSBRXAX=""
QUIT
Begin DoDot:1
+3 SET PSBCNT=PSBCNT+1
SET HLA("HLS",PSBCNT)="RXA"_PSBHLFS
+4 SET $PIECE(PSBHL7MS,PSBHLFS,1)=0
+5 SET $PIECE(PSBHL7MS,PSBHLFS,2)=PSBRX
+6 SET $PIECE(PSBHL7MS,PSBHLFS,3)=$$HLDATE^HLFNC($PIECE(^PSB(53.79,PSBIEN,0),U,6),"TS")
+7 SET $PIECE(PSBHL7MS,PSBHLFS,4)=" "
+8 ; Construct administered code data
+9 SET $PIECE(PSBHL7MS,PSBHLFS,5)=PSBRXAX
+10 SET $PIECE(PSBHL7MS,PSBHLFS,6)=$PIECE(PSBRXA(PSBRXAX),U)
+11 SET $PIECE(PSBHL7MS,PSBHLFS,7)=$PIECE(PSBRXA(PSBRXAX),U,2)
+12 if $DATA(^PSB(53.79,PSBIEN,.9,1))
Begin DoDot:2
+13 SET PSBINDX=$ORDER(^PSB(53.79,PSBIEN,.9,"B"),-1)
+14 if $DATA(PSBINDX)
SET $PIECE(PSBHL7MS,PSBHLFS,9)=PSBINDX_PSBHLCS_$$HLDATE^HLFNC($PIECE(^PSB(53.79,PSBIEN,.9,PSBINDX,0),U),"TS")
End DoDot:2
+15 ; "PRN reason"
+16 if ($GET(PSBSCHT)="P")&($DATA(^PSB(53.79,PSBIEN,.2)))
SET $PIECE(PSBHL7FD,PSBHLCS,2)=$PIECE(^PSB(53.79,PSBIEN,.2),U,1)
+17 SET $PIECE(PSBHL7MS,PSBHLFS,18)=$GET(PSBHL7FD)
KILL PSBHL7FD
+18 ; Construct indication - "variance"
+19 SET $PIECE(PSBHL7FD,PSBHLCS,2)=$PIECE(^PSB(53.79,PSBIEN,.1),U,4)
+20 SET $PIECE(PSBHL7MS,PSBHLFS,19)=PSBHL7FD
KILL PSBHL7FD
+21 SET $PIECE(PSBHL7MS,PSBHLFS,20)=$PIECE(^PSB(53.79,PSBIEN,0),U,9)
+22 SET HLA("HLS",PSBCNT)=(HLA("HLS",PSBCNT))_PSBHL7MS
End DoDot:1
+23 KILL PSBRX,PSBRXA,PSBRXAX
+24 QUIT
ESC(PSBINF) ; Escape message data
+1 SET PSBINFO=PSBINF
KILL PSBESC,PSBINFO1
FOR PSBESCX=1:1:4
Begin DoDot:1
+2 SET PSBCHR=$EXTRACT(HL("ECH"),PSBESCX)
+3 IF ($LENGTH(PSBINFO,PSBCHR)-1)>0
SET PSBINFO1=PSBINFO
FOR PSBESCXX=1:1:$LENGTH(PSBINFO,PSBCHR)-1
Begin DoDot:2
+4 SET PSBESC($FIND(PSBINFO1,PSBCHR)-1)=$EXTRACT(HL("ECH"),3)_$EXTRACT("SRET",PSBESCX)_$EXTRACT(HL("ECH"),3)
+5 SET PSBINFO1=$EXTRACT(PSBINFO1,1,$FIND(PSBINFO1,PSBCHR)-2)_U_$EXTRACT(PSBINFO1,$FIND(PSBINFO1,PSBCHR),250)
End DoDot:2
End DoDot:1
+6 if $DATA(PSBINFO1)
SET PSBINFO=PSBINFO1
+7 SET (PSBCNT1,PSBESCX,PSBESCXX)=0
FOR
SET PSBESCX=$ORDER(PSBESC(PSBESCX))
if PSBESCX=""
QUIT
Begin DoDot:1
+8 SET PSBESCXX=PSBESCX+PSBCNT1
SET PSBINFO=$EXTRACT(PSBINFO,1,PSBESCXX-1)_$GET(PSBESC(PSBESCX))_$EXTRACT(PSBINFO,PSBESCXX+1,250)
SET PSBCNT1=PSBCNT1+2
End DoDot:1
+9 QUIT PSBINFO
+10 ;
TRANS ; CALL HL7 TO Transmit Message
+1 KILL PSBHL7MS,PSBHL7FD
+2 if $DATA(HLA("HLS"))
DO GENERATE^HLMA("PSB BCMA RASO17 SRV","LM",1,.PSBHL7T,"",.PSBHL7OP)
+3 IF +$PIECE(PSBHL7T,U,2)
WRITE !,"PSB(BCMA) HL7 MESSAGE HAS FAILED TRANSMISSION - could not generate"
+4 QUIT
+5 ;
