- 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 Feb 19, 2025@00:11:41 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