- 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 Feb 19, 2025@00:12:17 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
