VPRSDAF ;SLC/MKB -- SDA PRF/Alert utilities ;10/25/18 15:29
;;1.0;VIRTUAL PATIENT RECORD;**23,31**;Sep 01, 2011;Build 3
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DDE 7014
; DGPFAA 7107
; DGPFAAH 7108
; TIULQ 2693
; TIULX 3058
; TIUPP3, ^TMP("TIUPPCV") 2864
;
PRFQ ; -- Patient Record Flags query
; Expects DSTRT, DSTOP, DMAX from DDEGET
; Returns DLIST(#)=assignment ien
N NUM,I,IEN,VPRF
S:$G(DFN) NUM=$$GETALL^DGPFAA(DFN,.VPRF,,1) Q:$G(NUM)<1
S (I,IEN)=0 F S IEN=$O(VPRF(IEN)) Q:IEN<1 S I=I+1,DLIST(I)=IEN
Q
;
PRF1(IEN) ; -- set up one patient record flag assignment
; Returns IEN and VPRF, VPRF1H, VPRFLH arrays
K VPRF,VPRF1H,VPRFLH
; convert old vptr ID to IEN
I $G(IEN)["~" S IEN=$$FNDASGN^DGPFAA(+$P(IEN,"~",2),+IEN_";DGPF(26.15,")
S IEN=+$G(IEN) I IEN<1 S DDEOUT=1 Q
I '$$GETASGN^DGPFAA(IEN,.VPRF,1) S DDEOUT=1 Q
S VPRF1H=$$GETFIRST^DGPFAAH(IEN) D:VPRF1H GETHIST^DGPFAAH(VPRF1H,.VPRF1H)
S VPRFLH=$$GETLAST^DGPFAAH(IEN) D:VPRFLH GETHIST^DGPFAAH(VPRFLH,.VPRFLH)
Q
;
EVT ; -- DGPF PRF EVENT protocol listener
N DFN,IEN
S IEN=+$G(DGIEN) Q:IEN<1
S DFN=+$G(DGPRF("DFN")) Q:DFN<1
I $P($G(DGPRF("FLAG")),U)'?1.N1";DGPF(26.15," Q ;Cat I flags,
;I +$G(DGPRF("OWNER"))'=+$$SITE^VASITE Q ;local only
D POST^VPRHS(DFN,"Alert",IEN_";26.13")
Q
;
;
CWQ ; -- Crisis/Warning notes (alerts) query
; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
N I,X,CNT,TIUD
D:$G(DFN) ENCOVER^TIUPP3(DFN)
; ^TMP = IEN^Acronym^Category Name^Optional Subject^Date/Time^Optional Addendum
; sort by Ref D/T order to retrieve by most recent
S I=0 F S I=$O(^TMP("TIUPPCV",$J,I)) Q:I<1 S X=$G(^(I)) I $P(X,U,2)="C"!($P(X,U,2)="W") S TIUD($P(X,U,5))=X
Q:'$O(TIUD(0)) ;no CW's for patient
S CNT=0,I=DSTOP
F S I=$O(TIUD(I),-1) Q:I<1!(I<DSTRT) S CNT=CNT+1,DLIST(CNT)=+$G(TIUD(I))_"~"_$P(X,U,2) Q:CNT'<DMAX
K ^TMP("TIUPPCV",$J)
Q
;
CW1 ; -- get info for one CW note/alert
K VPRTIU S VPRTYP=$P($G(DIEN),"~",2),DIEN=+$G(DIEN)
D EXTRACT^TIULQ(DIEN,"VPRTIU",,".01:.05;1201;1202;1212;1301",,1,"I")
I VPRTYP="" D S:VPRTYP="" DDEOUT=1
. N TTL,DAD
. S TTL=+$G(VPRTIU(DIEN,.01,"I")),DAD=+$G(VPRTIU(DIEN,.04,"I"))
. S VPRTYP=$S(DAD=30:"C",DAD=31:"W",$$ISA^TIULX(TTL,30):"C",$$ISA^TIULX(TTL,31):"W",1:"")
Q
;
CW23 ; -- ID Action for P23 entity
D CW1 Q:$G(DDEOUT)
N RDT S RDT=$G(VPRTIU(DIEN,1301,"I")),DNAME="Alert"
I RDT<3190101 S DDEOUT=1 Q ;pre-load entries ok
; pre-17: cont w/P23 entity to fix AlertType only
I RDT<3191101 Q
; re-send all since patch 17, when OpsMode may have errored
S DIENTY=+$O(^DDE("B","VPR CW NOTES",0))
Q
;
ADQ ; -- Adv Directive query
; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
N I,AD,TIUD,CNT
D:$G(DFN) ENCOVER^TIUPP3(DFN)
; ^TMP = IEN^Acronym^Category Name^Optional Subject^Date/Time^Optional Addendum
; sort by Ref D/T order to retrieve by most recent
S I=0 F S I=$O(^TMP("TIUPPCV",$J,I)) Q:I<1 S AD=$G(^(I)) I $P(AD,U,2)="D" S TIUD($P(AD,U,5))=AD
Q:'$O(TIUD(0)) ;no AD's for patient
S CNT=0,I=DSTOP
F S I=$O(TIUD(I),-1) Q:I<1!(I<DSTRT) S CNT=CNT+1,DLIST(CNT)=+$G(TIUD(I)) Q:CNT'<DMAX
Q
;
AD1(ID) ; -- get info for one Adv Directive
K VPRTIU S ID=+$G(ID)
D EXTRACT^TIULQ(+ID,"VPRTIU",,".01:.05;1201;1212;1301;1302",,,"I")
S:'DFN DFN=+$G(VPRTIU(+ID,.02,"I"))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAF 3602 printed Sep 23, 2025@20:22:12 Page 2
VPRSDAF ;SLC/MKB -- SDA PRF/Alert utilities ;10/25/18 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**23,31**;Sep 01, 2011;Build 3
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DDE 7014
+7 ; DGPFAA 7107
+8 ; DGPFAAH 7108
+9 ; TIULQ 2693
+10 ; TIULX 3058
+11 ; TIUPP3, ^TMP("TIUPPCV") 2864
+12 ;
PRFQ ; -- Patient Record Flags query
+1 ; Expects DSTRT, DSTOP, DMAX from DDEGET
+2 ; Returns DLIST(#)=assignment ien
+3 NEW NUM,I,IEN,VPRF
+4 if $GET(DFN)
SET NUM=$$GETALL^DGPFAA(DFN,.VPRF,,1)
if $GET(NUM)<1
QUIT
+5 SET (I,IEN)=0
FOR
SET IEN=$ORDER(VPRF(IEN))
if IEN<1
QUIT
SET I=I+1
SET DLIST(I)=IEN
+6 QUIT
+7 ;
PRF1(IEN) ; -- set up one patient record flag assignment
+1 ; Returns IEN and VPRF, VPRF1H, VPRFLH arrays
+2 KILL VPRF,VPRF1H,VPRFLH
+3 ; convert old vptr ID to IEN
+4 IF $GET(IEN)["~"
SET IEN=$$FNDASGN^DGPFAA(+$PIECE(IEN,"~",2),+IEN_";DGPF(26.15,")
+5 SET IEN=+$GET(IEN)
IF IEN<1
SET DDEOUT=1
QUIT
+6 IF '$$GETASGN^DGPFAA(IEN,.VPRF,1)
SET DDEOUT=1
QUIT
+7 SET VPRF1H=$$GETFIRST^DGPFAAH(IEN)
if VPRF1H
DO GETHIST^DGPFAAH(VPRF1H,.VPRF1H)
+8 SET VPRFLH=$$GETLAST^DGPFAAH(IEN)
if VPRFLH
DO GETHIST^DGPFAAH(VPRFLH,.VPRFLH)
+9 QUIT
+10 ;
EVT ; -- DGPF PRF EVENT protocol listener
+1 NEW DFN,IEN
+2 SET IEN=+$GET(DGIEN)
if IEN<1
QUIT
+3 SET DFN=+$GET(DGPRF("DFN"))
if DFN<1
QUIT
+4 ;Cat I flags,
IF $PIECE($GET(DGPRF("FLAG")),U)'?1.N1";DGPF(26.15,"
QUIT
+5 ;I +$G(DGPRF("OWNER"))'=+$$SITE^VASITE Q ;local only
+6 DO POST^VPRHS(DFN,"Alert",IEN_";26.13")
+7 QUIT
+8 ;
+9 ;
CWQ ; -- Crisis/Warning notes (alerts) query
+1 ; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
+2 NEW I,X,CNT,TIUD
+3 if $GET(DFN)
DO ENCOVER^TIUPP3(DFN)
+4 ; ^TMP = IEN^Acronym^Category Name^Optional Subject^Date/Time^Optional Addendum
+5 ; sort by Ref D/T order to retrieve by most recent
+6 SET I=0
FOR
SET I=$ORDER(^TMP("TIUPPCV",$JOB,I))
if I<1
QUIT
SET X=$GET(^(I))
IF $PIECE(X,U,2)="C"!($PIECE(X,U,2)="W")
SET TIUD($PIECE(X,U,5))=X
+7 ;no CW's for patient
if '$ORDER(TIUD(0))
QUIT
+8 SET CNT=0
SET I=DSTOP
+9 FOR
SET I=$ORDER(TIUD(I),-1)
if I<1!(I<DSTRT)
QUIT
SET CNT=CNT+1
SET DLIST(CNT)=+$GET(TIUD(I))_"~"_$PIECE(X,U,2)
if CNT'<DMAX
QUIT
+10 KILL ^TMP("TIUPPCV",$JOB)
+11 QUIT
+12 ;
CW1 ; -- get info for one CW note/alert
+1 KILL VPRTIU
SET VPRTYP=$PIECE($GET(DIEN),"~",2)
SET DIEN=+$GET(DIEN)
+2 DO EXTRACT^TIULQ(DIEN,"VPRTIU",,".01:.05;1201;1202;1212;1301",,1,"I")
+3 IF VPRTYP=""
Begin DoDot:1
+4 NEW TTL,DAD
+5 SET TTL=+$GET(VPRTIU(DIEN,.01,"I"))
SET DAD=+$GET(VPRTIU(DIEN,.04,"I"))
+6 SET VPRTYP=$SELECT(DAD=30:"C",DAD=31:"W",$$ISA^TIULX(TTL,30):"C",$$ISA^TIULX(TTL,31):"W",1:"")
End DoDot:1
if VPRTYP=""
SET DDEOUT=1
+7 QUIT
+8 ;
CW23 ; -- ID Action for P23 entity
+1 DO CW1
if $GET(DDEOUT)
QUIT
+2 NEW RDT
SET RDT=$GET(VPRTIU(DIEN,1301,"I"))
SET DNAME="Alert"
+3 ;pre-load entries ok
IF RDT<3190101
SET DDEOUT=1
QUIT
+4 ; pre-17: cont w/P23 entity to fix AlertType only
+5 IF RDT<3191101
QUIT
+6 ; re-send all since patch 17, when OpsMode may have errored
+7 SET DIENTY=+$ORDER(^DDE("B","VPR CW NOTES",0))
+8 QUIT
+9 ;
ADQ ; -- Adv Directive query
+1 ; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
+2 NEW I,AD,TIUD,CNT
+3 if $GET(DFN)
DO ENCOVER^TIUPP3(DFN)
+4 ; ^TMP = IEN^Acronym^Category Name^Optional Subject^Date/Time^Optional Addendum
+5 ; sort by Ref D/T order to retrieve by most recent
+6 SET I=0
FOR
SET I=$ORDER(^TMP("TIUPPCV",$JOB,I))
if I<1
QUIT
SET AD=$GET(^(I))
IF $PIECE(AD,U,2)="D"
SET TIUD($PIECE(AD,U,5))=AD
+7 ;no AD's for patient
if '$ORDER(TIUD(0))
QUIT
+8 SET CNT=0
SET I=DSTOP
+9 FOR
SET I=$ORDER(TIUD(I),-1)
if I<1!(I<DSTRT)
QUIT
SET CNT=CNT+1
SET DLIST(CNT)=+$GET(TIUD(I))
if CNT'<DMAX
QUIT
+10 QUIT
+11 ;
AD1(ID) ; -- get info for one Adv Directive
+1 KILL VPRTIU
SET ID=+$GET(ID)
+2 DO EXTRACT^TIULQ(+ID,"VPRTIU",,".01:.05;1201;1212;1301;1302",,,"I")
+3 if 'DFN
SET DFN=+$GET(VPRTIU(+ID,.02,"I"))
+4 QUIT
