Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VPREVSND

VPREVSND.m

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