VPREHL7 ;ALB/MJK,MKB - VPR HL7 Message Processor ;10/25/18 15:29
;;1.0;VIRTUAL PATIENT RECORD;**8,14,30**;Sep 01, 2011;Build 9
;;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; RMIM DRIVER 6990
; VAFC ADT-A08 SERVER 4418
; DIQ 2056
; MPIF001 2701
; XLFDT 10103
;
; Note: These variables are provided by the VistA HL7 system when a
; subscriber protocol's ROUTING LOGIC is called:
; - HLNEXT
; - HLQUIT
; - HLNODE
; - HLFS
; - HLECH
;
ADT ; -- main entry point for these VPR ADT client/router protocols:
; - VPR ADT-A08 CLIENT protocol
; o subscribes to VAFC ADT-A08 SERVER
;
; -- Posts A08 events for patient demographics changes
; Scans for PID segment and uses embedded DFN
; Sets ^VPR("AVPR"... freshness queue
;
N DONE,VPRSEG,VPREVT,DFN
S DONE=0
F X HLNEXT Q:HLQUIT'>0 D Q:DONE
. S VPRSEG=$E(HLNODE,1,3)
. ;
. I VPRSEG="EVN" D Q
. . S VPREVT=$P(HLNODE,HLFS,2)
. . ;I VPREVT="A04" Q ;no longer tracking registration events
. . ; -- 97 reason = sensitive patient change occurred
. . I VPREVT="A08" Q ;,$P(HLNODE,HLFS,5)=97 Q ;P14: all updates
. . ; -- not an event VPR is interested in so done with message
. . S DONE=1
. ; -- PID segment always comes after EVN segment
. I VPRSEG'="PID" Q
. S DONE=1
. ; -- VPREVT should always be defined at this point
. I $G(VPREVT)="" Q
. S DFN=+$P($P(HLNODE,HLFS,4),$E(HLECH))
. I 'DFN Q
. D QUE^VPRHS(DFN)
Q
;
FIM ; -- main entry point for these VPR RMIM client/router protocols:
; - VPR RMIM EVENTS protocol
; o subscribes to RMIM DRIVER
;
N DONE,VPRSEG,DFN,CASE
S DONE=0
F X HLNEXT Q:HLQUIT'>0 D Q:DONE
. S VPRSEG=$E(HLNODE,1,3)
. ;
. I VPRSEG'="PID" Q
. S DONE=1
. S DFN=+$P(HLNODE,HLFS,4) Q:DFN<1
. S CASE=+$P($P(HLNODE,HLFS,5),$E(HLECH),2)
. D POST^VPRHS(DFN,"Problem",CASE_";783")
Q
;
PRF ; -- main entry point for these VPR PRF client/router protocols:
; - VPR DGPF EVENTS protocol
; o subscribes to DGPF PRF ORU/R01 EVENT
;
Q ;replaced by new DGPF PRF EVENT protocol
N DONE,VPRSEG,ICN,DFN,ID,STS,ACT
S DONE=0
F X HLNEXT Q:HLQUIT'>0 D Q:DONE
. S VPRSEG=$E(HLNODE,1,3)
. ;
. I VPRSEG="PID" D Q
. . S ICN=$P($P(HLNODE,HLFS,4),$E(HLECH))
. . S DFN=$$GETDFN^MPIF001(ICN)
. . I DFN<1 S DONE=1
. ;
. I VPRSEG="OBR" D Q
. . S ID=+$P($P(HLNODE,HLFS,5),$E(HLECH))
. . I ID<1 S DONE=1
. ;
. I VPRSEG'="OBX" Q
. I $P(HLNODE,HLFS,3)'="ST" Q
. S DONE=1 Q:$G(DFN)<1 Q:$G(ID)<1
. S STS=$P(HLNODE,HLFS,6),ACT=$S(STS["INACT":"@",STS["ERROR":"@",1:"")
. ;I STS="@" D POST^VPRHS(DFN,"Alert") Q ;rebuild container
. D POST^VPRHS(DFN,"Alert",ID_"~"_DFN_";26.13",ACT)
Q
;
PSO ; -- main entry point for these VPR PRF client/router protocols:
; - VPR PSO VDEF EVENTS protocol
; o subscribes to PSO VDEF RDS O13 OP PHARM PREF VS
; o subscribes to PSO VDEF RDS O13 OP PHARM PPAR VS
;
N DONE,VPRSEG,ICN,DFN,ID,NOW,ORDER
S DONE=0,NOW=$$NOW^XLFDT
F X HLNEXT Q:HLQUIT'>0 D Q:DONE
. S VPRSEG=$E(HLNODE,1,3)
. ;
. I VPRSEG="PID" D Q
. . S ICN=$P(HLNODE,HLFS,3)
. . S DFN=$$GETDFN^MPIF001(ICN)
. . I DFN<1 S DONE=1
. ;
. I VPRSEG'="ORC" Q
. S ID=+$P($P(HLNODE,HLFS,4),$E(HLECH))
. S DONE=1 Q:$G(DFN)<1 Q:$G(ID)<1
. S ORDER=$$GET1^DIQ(52,ID,39.3,"I")
. D:ORDER POST^VPRHS(DFN,"Medication",ORDER_";100")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPREHL7 3726 printed Sep 23, 2025@20:21:32 Page 2
VPREHL7 ;ALB/MJK,MKB - VPR HL7 Message Processor ;10/25/18 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**8,14,30**;Sep 01, 2011;Build 9
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; RMIM DRIVER 6990
+7 ; VAFC ADT-A08 SERVER 4418
+8 ; DIQ 2056
+9 ; MPIF001 2701
+10 ; XLFDT 10103
+11 ;
+12 ; Note: These variables are provided by the VistA HL7 system when a
+13 ; subscriber protocol's ROUTING LOGIC is called:
+14 ; - HLNEXT
+15 ; - HLQUIT
+16 ; - HLNODE
+17 ; - HLFS
+18 ; - HLECH
+19 ;
ADT ; -- main entry point for these VPR ADT client/router protocols:
+1 ; - VPR ADT-A08 CLIENT protocol
+2 ; o subscribes to VAFC ADT-A08 SERVER
+3 ;
+4 ; -- Posts A08 events for patient demographics changes
+5 ; Scans for PID segment and uses embedded DFN
+6 ; Sets ^VPR("AVPR"... freshness queue
+7 ;
+8 NEW DONE,VPRSEG,VPREVT,DFN
+9 SET DONE=0
+10 FOR
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+11 SET VPRSEG=$EXTRACT(HLNODE,1,3)
+12 ;
+13 IF VPRSEG="EVN"
Begin DoDot:2
+14 SET VPREVT=$PIECE(HLNODE,HLFS,2)
+15 ;I VPREVT="A04" Q ;no longer tracking registration events
+16 ; -- 97 reason = sensitive patient change occurred
+17 ;,$P(HLNODE,HLFS,5)=97 Q ;P14: all updates
IF VPREVT="A08"
QUIT
+18 ; -- not an event VPR is interested in so done with message
+19 SET DONE=1
End DoDot:2
QUIT
+20 ; -- PID segment always comes after EVN segment
+21 IF VPRSEG'="PID"
QUIT
+22 SET DONE=1
+23 ; -- VPREVT should always be defined at this point
+24 IF $GET(VPREVT)=""
QUIT
+25 SET DFN=+$PIECE($PIECE(HLNODE,HLFS,4),$EXTRACT(HLECH))
+26 IF 'DFN
QUIT
+27 DO QUE^VPRHS(DFN)
End DoDot:1
if DONE
QUIT
+28 QUIT
+29 ;
FIM ; -- main entry point for these VPR RMIM client/router protocols:
+1 ; - VPR RMIM EVENTS protocol
+2 ; o subscribes to RMIM DRIVER
+3 ;
+4 NEW DONE,VPRSEG,DFN,CASE
+5 SET DONE=0
+6 FOR
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+7 SET VPRSEG=$EXTRACT(HLNODE,1,3)
+8 ;
+9 IF VPRSEG'="PID"
QUIT
+10 SET DONE=1
+11 SET DFN=+$PIECE(HLNODE,HLFS,4)
if DFN<1
QUIT
+12 SET CASE=+$PIECE($PIECE(HLNODE,HLFS,5),$EXTRACT(HLECH),2)
+13 DO POST^VPRHS(DFN,"Problem",CASE_";783")
End DoDot:1
if DONE
QUIT
+14 QUIT
+15 ;
PRF ; -- main entry point for these VPR PRF client/router protocols:
+1 ; - VPR DGPF EVENTS protocol
+2 ; o subscribes to DGPF PRF ORU/R01 EVENT
+3 ;
+4 ;replaced by new DGPF PRF EVENT protocol
QUIT
+5 NEW DONE,VPRSEG,ICN,DFN,ID,STS,ACT
+6 SET DONE=0
+7 FOR
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+8 SET VPRSEG=$EXTRACT(HLNODE,1,3)
+9 ;
+10 IF VPRSEG="PID"
Begin DoDot:2
+11 SET ICN=$PIECE($PIECE(HLNODE,HLFS,4),$EXTRACT(HLECH))
+12 SET DFN=$$GETDFN^MPIF001(ICN)
+13 IF DFN<1
SET DONE=1
End DoDot:2
QUIT
+14 ;
+15 IF VPRSEG="OBR"
Begin DoDot:2
+16 SET ID=+$PIECE($PIECE(HLNODE,HLFS,5),$EXTRACT(HLECH))
+17 IF ID<1
SET DONE=1
End DoDot:2
QUIT
+18 ;
+19 IF VPRSEG'="OBX"
QUIT
+20 IF $PIECE(HLNODE,HLFS,3)'="ST"
QUIT
+21 SET DONE=1
if $GET(DFN)<1
QUIT
if $GET(ID)<1
QUIT
+22 SET STS=$PIECE(HLNODE,HLFS,6)
SET ACT=$SELECT(STS["INACT":"@",STS["ERROR":"@",1:"")
+23 ;I STS="@" D POST^VPRHS(DFN,"Alert") Q ;rebuild container
+24 DO POST^VPRHS(DFN,"Alert",ID_"~"_DFN_";26.13",ACT)
End DoDot:1
if DONE
QUIT
+25 QUIT
+26 ;
PSO ; -- main entry point for these VPR PRF client/router protocols:
+1 ; - VPR PSO VDEF EVENTS protocol
+2 ; o subscribes to PSO VDEF RDS O13 OP PHARM PREF VS
+3 ; o subscribes to PSO VDEF RDS O13 OP PHARM PPAR VS
+4 ;
+5 NEW DONE,VPRSEG,ICN,DFN,ID,NOW,ORDER
+6 SET DONE=0
SET NOW=$$NOW^XLFDT
+7 FOR
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+8 SET VPRSEG=$EXTRACT(HLNODE,1,3)
+9 ;
+10 IF VPRSEG="PID"
Begin DoDot:2
+11 SET ICN=$PIECE(HLNODE,HLFS,3)
+12 SET DFN=$$GETDFN^MPIF001(ICN)
+13 IF DFN<1
SET DONE=1
End DoDot:2
QUIT
+14 ;
+15 IF VPRSEG'="ORC"
QUIT
+16 SET ID=+$PIECE($PIECE(HLNODE,HLFS,4),$EXTRACT(HLECH))
+17 SET DONE=1
if $GET(DFN)<1
QUIT
if $GET(ID)<1
QUIT
+18 SET ORDER=$$GET1^DIQ(52,ID,39.3,"I")
+19 if ORDER
DO POST^VPRHS(DFN,"Medication",ORDER_";100")
End DoDot:1
if DONE
QUIT
+20 QUIT
