- 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 Feb 18, 2025@23:07:36 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 ;