VPREVSND ;SLC/MKB -- CPRS EVSEND listeners ;10/25/18 15:29
;;1.0;VIRTUAL PATIENT RECORD;**31,35**;Sep 01, 2011;Build 16
;;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; FH EVSEND OR 6097
; GMRC EVSEND OR 3140
; LR7O AP EVSEND OR 7011
; LR7O CH EVSEND OR 6087
; OR EVSEND FH 6090
; OR EVSEND GMRC 3135
; OR EVSEND LRCH 6091
; OR EVSEND ORG 6092
; OR EVSEND PS 6093
; OR EVSEND RA 6094
; OR EVSEND VPR 6095
; PS EVSEND OR 2415
; RA EVSEND OR 6086
; ^DPT 10035
; ^LR 525
; ^OR(100 5771
; ^RADPT 2480
; DIC 2051
; DIQ 2056
; LR7OR1,^TMP("LRRR" 2503
;
OR(MSG,FD) ; -- CPRS EVSEND protocol event listener
; FD = frontdoor msg from CPRS (get ORIFN for new backdoor orders)
; else = backdoor msg/ack from Pharmacy, Lab, Radiology, etc.
N VPRMSG,VPRPKG,VPRSDA,DFN,ORC,ACT
S VPRMSG=$S($L($G(MSG)):MSG,1:"MSG") Q:'$O(@VPRMSG@(0))
S DFN=$$PID Q:DFN<1
Q:$$FLAG ;look for flag msg (no ORC), quit if found and handled
S ORC=0 F S ORC=$O(@VPRMSG@(+ORC)) Q:ORC'>0 I $E($G(@VPRMSG@(ORC)),1,3)="ORC" D
. N ORDCNTRL,PKGIFN,ORIFN,STS,ORIG
. S ORC=ORC_U_@VPRMSG@(ORC),ORDCNTRL=$TR($P(ORC,"|",2),"@","P")
. ; QUIT if action failed, conversion, purge, or backdoor verify/new
. I ORDCNTRL["U"!("DE^ZC^ZP^ZR^ZV^SN"[ORDCNTRL) Q
. I $G(FD),ORDCNTRL'="NA" Q ;only want NA msg, from CPRS
. ; Update *Order containers
. S ORIFN=+$P($P(ORC,"|",3),U),PKGIFN=$P($P(ORC,"|",4),U)
. S VPRPKG=$P($P(ORC,"|",4),U,2) ;default namespace, if 'ORIFN
. Q:$O(^OR(100,ORIFN,2,0)) ;should not be getting parent orders
. S STS=$P($G(^OR(100,ORIFN,3)),U,3) Q:STS=10 Q:STS=11
. ; Ck consult for partial results looping condition
. I VPRPKG="GMRC",ORDCNTRL="RE",PKGIFN Q:'$$GMRCOK(PKGIFN)
. S ACT="" I "CA^OC^CR"[ORDCNTRL,STS=13 S ACT="@" ;cancelled
. ; also remove pending meds that have been dc'd
. I "OC^CR^OD^DR"[ORDCNTRL,STS=1,VPRPKG="PS",(PKGIFN["P")!(PKGIFN["S") S ACT="@"
. I ORIFN D ;IFC Consults have no local order#
.. S VPRPKG=$$NMSP(ORIFN),VPRSDA=$$ORDCONT(VPRPKG)
.. D POST^VPRHS(DFN,VPRSDA,ORIFN_";100",ACT)
. ; Update Referral or Document containers
. I VPRPKG="GMRC",PKGIFN D POST^VPRHS(DFN,"Referral",+PKGIFN_";123") Q
. Q:ORDCNTRL'="RE"
. I $E(VPRPKG,1,2)="RA" D RAD Q
. I $E(VPRPKG,1,2)="LR" D LRD Q
Q
;
PID() ; -- Returns patient from PID segment in current msg
N I,SEG,Y S I=0
F S I=$O(@VPRMSG@(I)) Q:I'>0 S SEG=$E($G(@VPRMSG@(I)),1,3) Q:SEG="ORC" I SEG="PID" D Q
. S Y=+$P(@VPRMSG@(I),"|",4)
.;I '$D(^DPT(Y,0)) S:$L($P(@VPRMSG@(I),"|",5)) Y=+$P(@VPRMSG@(I),"|",5) ;alt ID for Lab
Q Y
;
NMSP(IFN) ; -- Returns package namespace from pointer
N X,Y S X=$P($G(^OR(100,+$G(IFN),0)),U,14)
S Y=$$GET1^DIQ(9.4,+X_",",1)
Q Y
;
ORDCONT(NMSP) ; -- Returns SDA Order container name
S NMSP=$G(NMSP)
I $E(NMSP,1,2)="LR" Q "LabOrder"
I $E(NMSP,1,2)="PS" Q "Medication"
I $E(NMSP,1,2)="RA" Q "RadOrder"
Q "OtherOrder"
;
GMRCOK(IFN) ; -- returns 1 or 0, if consult/order should be updated
; Error if completed CP Transaction but consult or note incomplete
S IFN=+$G(IFN) I '$$GET1^DIQ(123,IFN,1.01,"I") Q 1 ;not a CP request
N CSTS,VPRC,VPRI,CPSTS,TIU,OK
S CSTS=$$GET1^DIQ(123,IFN,8,"I")
D FIND^DIC(702,,"@;.06I;.09I","Q",IFN,,"ACON",,,"VPRC")
S OK=1,VPRI=0 F S VPRI=$O(VPRC("DILIST",2,VPRI)) Q:VPRI<1 D Q:'OK
. S CPSTS=+$G(VPRC("DILIST","ID",VPRI,.09))
. S TIU=+$G(VPRC("DILIST","ID",VPRI,.06))
. I CPSTS=3,(CSTS'=2)!(+$$GET1^DIQ(8925,TIU,.05,"I")<7) S OK=0
Q OK
;
RAD ; -- Radiology documents
N IDT,RPT,I,X,STS,ACT
S IDT=+$O(^RADPT("AO",+PKGIFN,DFN,0)),I=0
; find report(s) for order
F S I=$O(^RADPT("AO",+PKGIFN,DFN,IDT,I)) Q:I<1 D
. S X=+$P($G(^RADPT(DFN,"DT",IDT,"P",I,0)),U,17) ;,VST=$P($G(^(0)),U,27)
. Q:'X S STS=$$GET1^DIQ(74,X_",",5,"I"),ACT=""
. Q:STS'="V"&(STS'="EF")&(STS'="X") I STS="X" S ACT="@"
. S:'$D(RPT(X)) RPT(X)=IDT_"-"_I ;S:VST VST(X)=VST
; update Document container
S X=0 F S X=$O(RPT(X)) Q:X<1 D POST^VPRHS(DFN,"Document",X_";74",ACT) ;X_"~"_RPT(X)
Q
;
LRD ; -- AP/MI documents [from XQOR, LRAP: expects PKGIFN]
N SUB,IDT,LRDFN,X
S SUB=$P($G(PKGIFN),";",4),IDT=$P($G(PKGIFN),";",5)
Q:'IDT Q:SUB="" Q:SUB="CH" ;quit if CH or no results
D RR^LR7OR1(DFN,PKGIFN) ;get all reports for order
S LRDFN=+$G(^DPT(DFN,"LR"))
S IDT=0 F S IDT=$O(^TMP("LRRR",$J,DFN,SUB,IDT)) Q:IDT<1 D
. ; quit if report in TIU or not complete
. I SUB="MI" Q:'$$MI1^VPRSDAB(LRDFN,IDT)
. I SUB'="MI" Q:$O(^LR(LRDFN,SUB,IDT,.05,0)) Q:'$P($G(^LR(LRDFN,SUB,IDT,0)),U,11)
. ; get report
. S X=IDT_","_LRDFN_"~"_SUB_";"_$S(SUB="MI":63.05,1:63.08)
. D POST^VPRHS(DFN,"Document",X)
Q
;
LRAP(MSG) ; -- LR7O AP EVSEND OR protocol listener
N VPRMSG,DFN,ORC
S VPRMSG=$S($L($G(MSG)):MSG,1:"MSG") Q:'$O(@VPRMSG@(0))
S DFN=$$PID Q:DFN<1
S ORC=0 F S ORC=$O(@VPRMSG@(+ORC)) Q:ORC'>0 I $E($G(@VPRMSG@(ORC)),1,3)="ORC" D
. N ORDCNTRL,PKGIFN
. S ORC=ORC_U_@VPRMSG@(ORC),ORDCNTRL=$TR($P(ORC,"|",2),"@","P")
. Q:ORDCNTRL'="RE" S PKGIFN=$P($P(ORC,"|",4),U)
. D LRD
Q
;
FLAG() ; -- return 1 if FL/UF message (processed, so done) [VPREVSND]
N I,X,Y,SEG,ORIFN S Y=0
S I=0 F S I=$O(@VPRMSG@(I)) Q:I'>0 S SEG=$E($G(@VPRMSG@(I)),1,3) Q:SEG="ORC" I SEG="OBR" D Q:Y
. S X=$G(@VPRMSG@(I)) I $P(X,"|",5)'="FL",$P(X,"|",5)'="UF" Q
. Q:$P($P(X,"|",4),U,2)'="PS" S ORIFN=+$P(X,"|",3)
. D POST^VPRHS(DFN,"Medication",ORIFN_";100") S Y=1
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPREVSND 6053 printed Dec 13, 2024@02:45:14 Page 2
VPREVSND ;SLC/MKB -- CPRS EVSEND listeners ;10/25/18 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**31,35**;Sep 01, 2011;Build 16
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; FH EVSEND OR 6097
+7 ; GMRC EVSEND OR 3140
+8 ; LR7O AP EVSEND OR 7011
+9 ; LR7O CH EVSEND OR 6087
+10 ; OR EVSEND FH 6090
+11 ; OR EVSEND GMRC 3135
+12 ; OR EVSEND LRCH 6091
+13 ; OR EVSEND ORG 6092
+14 ; OR EVSEND PS 6093
+15 ; OR EVSEND RA 6094
+16 ; OR EVSEND VPR 6095
+17 ; PS EVSEND OR 2415
+18 ; RA EVSEND OR 6086
+19 ; ^DPT 10035
+20 ; ^LR 525
+21 ; ^OR(100 5771
+22 ; ^RADPT 2480
+23 ; DIC 2051
+24 ; DIQ 2056
+25 ; LR7OR1,^TMP("LRRR" 2503
+26 ;
OR(MSG,FD) ; -- CPRS EVSEND protocol event listener
+1 ; FD = frontdoor msg from CPRS (get ORIFN for new backdoor orders)
+2 ; else = backdoor msg/ack from Pharmacy, Lab, Radiology, etc.
+3 NEW VPRMSG,VPRPKG,VPRSDA,DFN,ORC,ACT
+4 SET VPRMSG=$SELECT($LENGTH($GET(MSG)):MSG,1:"MSG")
if '$ORDER(@VPRMSG@(0))
QUIT
+5 SET DFN=$$PID
if DFN<1
QUIT
+6 ;look for flag msg (no ORC), quit if found and handled
if $$FLAG
QUIT
+7 SET ORC=0
FOR
SET ORC=$ORDER(@VPRMSG@(+ORC))
if ORC'>0
QUIT
IF $EXTRACT($GET(@VPRMSG@(ORC)),1,3)="ORC"
Begin DoDot:1
+8 NEW ORDCNTRL,PKGIFN,ORIFN,STS,ORIG
+9 SET ORC=ORC_U_@VPRMSG@(ORC)
SET ORDCNTRL=$TRANSLATE($PIECE(ORC,"|",2),"@","P")
+10 ; QUIT if action failed, conversion, purge, or backdoor verify/new
+11 IF ORDCNTRL["U"!("DE^ZC^ZP^ZR^ZV^SN"[ORDCNTRL)
QUIT
+12 ;only want NA msg, from CPRS
IF $GET(FD)
IF ORDCNTRL'="NA"
QUIT
+13 ; Update *Order containers
+14 SET ORIFN=+$PIECE($PIECE(ORC,"|",3),U)
SET PKGIFN=$PIECE($PIECE(ORC,"|",4),U)
+15 ;default namespace, if 'ORIFN
SET VPRPKG=$PIECE($PIECE(ORC,"|",4),U,2)
+16 ;should not be getting parent orders
if $ORDER(^OR(100,ORIFN,2,0))
QUIT
+17 SET STS=$PIECE($GET(^OR(100,ORIFN,3)),U,3)
if STS=10
QUIT
if STS=11
QUIT
+18 ; Ck consult for partial results looping condition
+19 IF VPRPKG="GMRC"
IF ORDCNTRL="RE"
IF PKGIFN
if '$$GMRCOK(PKGIFN)
QUIT
+20 ;cancelled
SET ACT=""
IF "CA^OC^CR"[ORDCNTRL
IF STS=13
SET ACT="@"
+21 ; also remove pending meds that have been dc'd
+22 IF "OC^CR^OD^DR"[ORDCNTRL
IF STS=1
IF VPRPKG="PS"
IF (PKGIFN["P")!(PKGIFN["S")
SET ACT="@"
+23 ;IFC Consults have no local order#
IF ORIFN
Begin DoDot:2
+24 SET VPRPKG=$$NMSP(ORIFN)
SET VPRSDA=$$ORDCONT(VPRPKG)
+25 DO POST^VPRHS(DFN,VPRSDA,ORIFN_";100",ACT)
End DoDot:2
+26 ; Update Referral or Document containers
+27 IF VPRPKG="GMRC"
IF PKGIFN
DO POST^VPRHS(DFN,"Referral",+PKGIFN_";123")
QUIT
+28 if ORDCNTRL'="RE"
QUIT
+29 IF $EXTRACT(VPRPKG,1,2)="RA"
DO RAD
QUIT
+30 IF $EXTRACT(VPRPKG,1,2)="LR"
DO LRD
QUIT
End DoDot:1
+31 QUIT
+32 ;
PID() ; -- Returns patient from PID segment in current msg
+1 NEW I,SEG,Y
SET I=0
+2 FOR
SET I=$ORDER(@VPRMSG@(I))
if I'>0
QUIT
SET SEG=$EXTRACT($GET(@VPRMSG@(I)),1,3)
if SEG="ORC"
QUIT
IF SEG="PID"
Begin DoDot:1
+3 SET Y=+$PIECE(@VPRMSG@(I),"|",4)
+4 ;I '$D(^DPT(Y,0)) S:$L($P(@VPRMSG@(I),"|",5)) Y=+$P(@VPRMSG@(I),"|",5) ;alt ID for Lab
End DoDot:1
QUIT
+5 QUIT Y
+6 ;
NMSP(IFN) ; -- Returns package namespace from pointer
+1 NEW X,Y
SET X=$PIECE($GET(^OR(100,+$GET(IFN),0)),U,14)
+2 SET Y=$$GET1^DIQ(9.4,+X_",",1)
+3 QUIT Y
+4 ;
ORDCONT(NMSP) ; -- Returns SDA Order container name
+1 SET NMSP=$GET(NMSP)
+2 IF $EXTRACT(NMSP,1,2)="LR"
QUIT "LabOrder"
+3 IF $EXTRACT(NMSP,1,2)="PS"
QUIT "Medication"
+4 IF $EXTRACT(NMSP,1,2)="RA"
QUIT "RadOrder"
+5 QUIT "OtherOrder"
+6 ;
GMRCOK(IFN) ; -- returns 1 or 0, if consult/order should be updated
+1 ; Error if completed CP Transaction but consult or note incomplete
+2 ;not a CP request
SET IFN=+$GET(IFN)
IF '$$GET1^DIQ(123,IFN,1.01,"I")
QUIT 1
+3 NEW CSTS,VPRC,VPRI,CPSTS,TIU,OK
+4 SET CSTS=$$GET1^DIQ(123,IFN,8,"I")
+5 DO FIND^DIC(702,,"@;.06I;.09I","Q",IFN,,"ACON",,,"VPRC")
+6 SET OK=1
SET VPRI=0
FOR
SET VPRI=$ORDER(VPRC("DILIST",2,VPRI))
if VPRI<1
QUIT
Begin DoDot:1
+7 SET CPSTS=+$GET(VPRC("DILIST","ID",VPRI,.09))
+8 SET TIU=+$GET(VPRC("DILIST","ID",VPRI,.06))
+9 IF CPSTS=3
IF (CSTS'=2)!(+$$GET1^DIQ(8925,TIU,.05,"I")<7)
SET OK=0
End DoDot:1
if 'OK
QUIT
+10 QUIT OK
+11 ;
RAD ; -- Radiology documents
+1 NEW IDT,RPT,I,X,STS,ACT
+2 SET IDT=+$ORDER(^RADPT("AO",+PKGIFN,DFN,0))
SET I=0
+3 ; find report(s) for order
+4 FOR
SET I=$ORDER(^RADPT("AO",+PKGIFN,DFN,IDT,I))
if I<1
QUIT
Begin DoDot:1
+5 ;,VST=$P($G(^(0)),U,27)
SET X=+$PIECE($GET(^RADPT(DFN,"DT",IDT,"P",I,0)),U,17)
+6 if 'X
QUIT
SET STS=$$GET1^DIQ(74,X_",",5,"I")
SET ACT=""
+7 if STS'="V"&(STS'="EF")&(STS'="X")
QUIT
IF STS="X"
SET ACT="@"
+8 ;S:VST VST(X)=VST
if '$DATA(RPT(X))
SET RPT(X)=IDT_"-"_I
End DoDot:1
+9 ; update Document container
+10 ;X_"~"_RPT(X)
SET X=0
FOR
SET X=$ORDER(RPT(X))
if X<1
QUIT
DO POST^VPRHS(DFN,"Document",X_";74",ACT)
+11 QUIT
+12 ;
LRD ; -- AP/MI documents [from XQOR, LRAP: expects PKGIFN]
+1 NEW SUB,IDT,LRDFN,X
+2 SET SUB=$PIECE($GET(PKGIFN),";",4)
SET IDT=$PIECE($GET(PKGIFN),";",5)
+3 ;quit if CH or no results
if 'IDT
QUIT
if SUB=""
QUIT
if SUB="CH"
QUIT
+4 ;get all reports for order
DO RR^LR7OR1(DFN,PKGIFN)
+5 SET LRDFN=+$GET(^DPT(DFN,"LR"))
+6 SET IDT=0
FOR
SET IDT=$ORDER(^TMP("LRRR",$JOB,DFN,SUB,IDT))
if IDT<1
QUIT
Begin DoDot:1
+7 ; quit if report in TIU or not complete
+8 IF SUB="MI"
if '$$MI1^VPRSDAB(LRDFN,IDT)
QUIT
+9 IF SUB'="MI"
if $ORDER(^LR(LRDFN,SUB,IDT,.05,0))
QUIT
if '$PIECE($GET(^LR(LRDFN,SUB,IDT,0)),U,11)
QUIT
+10 ; get report
+11 SET X=IDT_","_LRDFN_"~"_SUB_";"_$SELECT(SUB="MI":63.05,1:63.08)
+12 DO POST^VPRHS(DFN,"Document",X)
End DoDot:1
+13 QUIT
+14 ;
LRAP(MSG) ; -- LR7O AP EVSEND OR protocol listener
+1 NEW VPRMSG,DFN,ORC
+2 SET VPRMSG=$SELECT($LENGTH($GET(MSG)):MSG,1:"MSG")
if '$ORDER(@VPRMSG@(0))
QUIT
+3 SET DFN=$$PID
if DFN<1
QUIT
+4 SET ORC=0
FOR
SET ORC=$ORDER(@VPRMSG@(+ORC))
if ORC'>0
QUIT
IF $EXTRACT($GET(@VPRMSG@(ORC)),1,3)="ORC"
Begin DoDot:1
+5 NEW ORDCNTRL,PKGIFN
+6 SET ORC=ORC_U_@VPRMSG@(ORC)
SET ORDCNTRL=$TRANSLATE($PIECE(ORC,"|",2),"@","P")
+7 if ORDCNTRL'="RE"
QUIT
SET PKGIFN=$PIECE($PIECE(ORC,"|",4),U)
+8 DO LRD
End DoDot:1
+9 QUIT
+10 ;
FLAG() ; -- return 1 if FL/UF message (processed, so done) [VPREVSND]
+1 NEW I,X,Y,SEG,ORIFN
SET Y=0
+2 SET I=0
FOR
SET I=$ORDER(@VPRMSG@(I))
if I'>0
QUIT
SET SEG=$EXTRACT($GET(@VPRMSG@(I)),1,3)
if SEG="ORC"
QUIT
IF SEG="OBR"
Begin DoDot:1
+3 SET X=$GET(@VPRMSG@(I))
IF $PIECE(X,"|",5)'="FL"
IF $PIECE(X,"|",5)'="UF"
QUIT
+4 if $PIECE($PIECE(X,"|",4),U,2)'="PS"
QUIT
SET ORIFN=+$PIECE(X,"|",3)
+5 DO POST^VPRHS(DFN,"Medication",ORIFN_";100")
SET Y=1
End DoDot:1
if Y
QUIT
+6 QUIT Y
