iSharkFly-Open
/
VistA-WorldVistAEHR
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
VistA-WorldVistAEHR/r/BAR_CODE_MED_ADMIN-ALPB-PSB/PSBSVHL7.m

208 lines
9.5 KiB
Mathematica
Raw Permalink Blame History

PSBSVHL7 ;BIRMINGHAM/TEJ-BCMA HL7 SERVER ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**3**;Mar 2004
; 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 coresponding 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 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
COMMENT ;ADD COMNMENT trigger event
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)=$P(VADM(2),"^")
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
;
Reference in New Issue View Git Blame Copy Permalink