VPRSDAT ;SLC/MKB -- SDA TIU utilities ;10/25/18 15:29
;;1.0;VIRTUAL PATIENT RECORD;**20,29,31**;Sep 01, 2011;Build 3
;;Per VHA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^SC 10040
; ^TIU(8925.1 5677
; ^TIU(8925.7 7416
; DIQ 2056
; TIULQ 2693
; TIUVPR 6077
;
DOCQRY ; -- Text Integration Utilities query
; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
N VPRY,VPRI,VPRN
D LIST^TIUVPR(.VPRY,DFN,38,DSTRT,DSTOP)
S VPRN=0,VPRI="COUNT"
F S VPRI=$O(@VPRY@(VPRI),-1) Q:VPRI<1 D Q:VPRN'<DMAX
. S VPRN=VPRN+1,DLIST(VPRN)=+VPRI
K @VPRY
Q
;
DOC1(IEN) ; -- ID Action for single document
K VPRTIU S IEN=+$G(IEN) I IEN<1 S DDEOUT=1 Q
D EXTRACT^TIULQ(IEN,"VPRTIU",,".01:.08;1201;1202;1205;1207;1212;1301;1302;1307;1404;1501:1508;1601:1606;1701;2101;15001",,,"I")
Q
;
TEXT ; -- return note text in WP(#) array
N VPRT,STS,TAG,FILE,FIELD,IEN ;protect variables
S STS=+$G(VPRTIU(DIEN,.05,"I"))
I STS=15 S WP(1)="This document has been RETRACTED." Q
I STS=14 S WP(1)="This document has been DELETED." Q
I '$G(VPRTIU(DIEN,.01,"I")) S WP(1)="This document has been DELETED." Q
D RPT^VPRDTIU(.VPRT,DIEN) M WP=@VPRT
Q
;
TYPE(IEN) ; -- return code^name for document type/class
N X,Y S Y=""
S X=$$CATG^VPRDTIU(IEN) I X="PN" D
. N NATL,SVC
. S NATL=+$G(^TIU(8925.1,+$G(IEN),15)) Q:'NATL
. S SVC=$$GET1^DIQ(8926.1,NATL_",",.07) Q:SVC=""
. I SVC["HISTORY & PHYSICAL"!(SVC["HISTORY AND PHYSICAL") S Y="HP^History & Physical" Q
. I SVC["COMPENSATION & PENSION" S Y="CM^Compensation & Pension" Q
I X="" S Y="CD^Clinical Document" ;not in known doc class
S:'$L(Y) Y=X_U_$$TYPE^VPRDJ08(X) ;name of known doc class
Q Y
;
SIGDT(IEN) ; -- return date of authorization
N Y S Y="",IEN=+$G(IEN)
I $G(VPRTIU(IEN,1501,"I")) S Y=VPRTIU(IEN,1501,"I") ;Signed
I $G(VPRTIU(IEN,1507,"I")) S Y=VPRTIU(IEN,1507,"I") ;Co-signed
I $G(VPRTIU(IEN,1606,"I")) S Y=VPRTIU(IEN,1606,"I") ;Admin Closure
Q Y
;
NATL(IEN) ; -- convert 8925.1 IEN to 8926.1 IEN
; Expects VPRNATL from VPR DOCUMENT EXTENSION entity
; Returns DATA = code ^ [description] ^ system
; TIUTTL = local title name
N TIUNATL S IEN=+$G(IEN),DATA=""
S TIUNATL=$S($G(VPRNATL):VPRNATL,1:+$G(^TIU(8925.1,IEN,15)))
S TIUTTL=$P($G(^TIU(8925.1,IEN,0)),U)
; if no national mapping, return local title
I 'TIUNATL D Q
. I $P(TIUTTL," ")="LR" D Q:$L(DATA)
.. N TTL S TTL=$E($P(TIUTTL," ",2),1,2)
.. S DATA=$S(TTL="AU":"18743-5^AUTOPSY REPORT",TTL="CY":"26438-2^CYTOLOGY STUDIES",TTL="EL":"50668-3^MICROSCOPY STUDIES",TTL="SU":"27898-6^PATHOLOGY STUDIES",1:"")
.. I $L(DATA) S DATA=DATA_"^LOINC" Q
. S DATA=IEN_U_TIUTTL_"^VA8925.1"
; get LOINC or VUID
S IEN=TIUNATL,DATA=$$CODE^VPRSDA(IEN,8926.1,"LNC")
I DATA="" S DATA=$$VUID^VPRD(IEN,8926.1) S:DATA DATA=DATA_"^^VHAT"
; else default = 8926.1 ien as per usual
Q
;
AVSTS(STS) ; -- return Availability Status of document
N Y S STS=+$G(STS),Y=""
I STS<7!(STS>13) S Y="UN^Unavailable for patient care"
E S Y="AV^Available for patient care"
Q Y
;
COMP(IEN,VST) ; -- return 1 or 0, if document is complete
S IEN=+$G(IEN) I IEN<1 Q ""
N VPRTIU,STS,Y D EXTRACT^TIULQ(IEN,"VPRTIU",,".03;.05",,,"I")
S VST=$G(VPRTIU(IEN,.03,"I")) ;return, if VST passed by ref
S STS=+$G(VPRTIU(IEN,.05,"I"))
S Y=$S(STS=7:1,STS=8:1,1:0)
Q Y
;
FAC(IEN) ; -- return #4 ien for TIU document
N LOC,FAC S IEN=+$G(IEN)
; return location's facility if available
S LOC=+$G(VPRTIU(IEN,1205,"I")),FAC="" I LOC>0 D
. N L0 S L0=$G(^SC(LOC,0)),FAC=$P(L0,U,4)
. ; Get P:4 via Med Ctr Div, if not directly linked
. I 'FAC,$P(L0,U,15) S FAC=$$GET1^DIQ(44,LOC_",","3.5:.07","I")
; if no location, or loc has no facility, use Division field
I FAC="" S FAC=$G(VPRTIU(IEN,1212,"I"))
Q FAC
;
TIUS(IEN) ; -- return DLIST array of multiple signers
N I,N,MSIEN,X
S N=0 F I=1502,1508 S:$G(VPRTIU(IEN,I,"I")) N=N+1,DLIST(N)=VPRTIU(IEN,I,"I")_U_$S(I=1502:"S",1:"C")
S MSIEN=0 F S MSIEN=$O(^TIU(8925.7,"B",IEN,MSIEN)) Q:'MSIEN I MSIEN D
. S X=$G(^TIU(8925.7,MSIEN,0))
. I $P(X,U,5) S N=N+1,DLIST(N)=$P(X,U,5)_U_"C"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRSDAT 4378 printed Apr 09, 2024@21:47:17 Page 2
VPRSDAT ;SLC/MKB -- SDA TIU utilities ;10/25/18 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**20,29,31**;Sep 01, 2011;Build 3
+2 ;;Per VHA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^SC 10040
+7 ; ^TIU(8925.1 5677
+8 ; ^TIU(8925.7 7416
+9 ; DIQ 2056
+10 ; TIULQ 2693
+11 ; TIUVPR 6077
+12 ;
DOCQRY ; -- Text Integration Utilities query
+1 ; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
+2 NEW VPRY,VPRI,VPRN
+3 DO LIST^TIUVPR(.VPRY,DFN,38,DSTRT,DSTOP)
+4 SET VPRN=0
SET VPRI="COUNT"
+5 FOR
SET VPRI=$ORDER(@VPRY@(VPRI),-1)
if VPRI<1
QUIT
Begin DoDot:1
+6 SET VPRN=VPRN+1
SET DLIST(VPRN)=+VPRI
End DoDot:1
if VPRN'<DMAX
QUIT
+7 KILL @VPRY
+8 QUIT
+9 ;
DOC1(IEN) ; -- ID Action for single document
+1 KILL VPRTIU
SET IEN=+$GET(IEN)
IF IEN<1
SET DDEOUT=1
QUIT
+2 DO EXTRACT^TIULQ(IEN,"VPRTIU",,".01:.08;1201;1202;1205;1207;1212;1301;1302;1307;1404;1501:1508;1601:1606;1701;2101;15001",,,"I")
+3 QUIT
+4 ;
TEXT ; -- return note text in WP(#) array
+1 ;protect variables
NEW VPRT,STS,TAG,FILE,FIELD,IEN
+2 SET STS=+$GET(VPRTIU(DIEN,.05,"I"))
+3 IF STS=15
SET WP(1)="This document has been RETRACTED."
QUIT
+4 IF STS=14
SET WP(1)="This document has been DELETED."
QUIT
+5 IF '$GET(VPRTIU(DIEN,.01,"I"))
SET WP(1)="This document has been DELETED."
QUIT
+6 DO RPT^VPRDTIU(.VPRT,DIEN)
MERGE WP=@VPRT
+7 QUIT
+8 ;
TYPE(IEN) ; -- return code^name for document type/class
+1 NEW X,Y
SET Y=""
+2 SET X=$$CATG^VPRDTIU(IEN)
IF X="PN"
Begin DoDot:1
+3 NEW NATL,SVC
+4 SET NATL=+$GET(^TIU(8925.1,+$GET(IEN),15))
if 'NATL
QUIT
+5 SET SVC=$$GET1^DIQ(8926.1,NATL_",",.07)
if SVC=""
QUIT
+6 IF SVC["HISTORY & PHYSICAL"!(SVC["HISTORY AND PHYSICAL")
SET Y="HP^History & Physical"
QUIT
+7 IF SVC["COMPENSATION & PENSION"
SET Y="CM^Compensation & Pension"
QUIT
End DoDot:1
+8 ;not in known doc class
IF X=""
SET Y="CD^Clinical Document"
+9 ;name of known doc class
if '$LENGTH(Y)
SET Y=X_U_$$TYPE^VPRDJ08(X)
+10 QUIT Y
+11 ;
SIGDT(IEN) ; -- return date of authorization
+1 NEW Y
SET Y=""
SET IEN=+$GET(IEN)
+2 ;Signed
IF $GET(VPRTIU(IEN,1501,"I"))
SET Y=VPRTIU(IEN,1501,"I")
+3 ;Co-signed
IF $GET(VPRTIU(IEN,1507,"I"))
SET Y=VPRTIU(IEN,1507,"I")
+4 ;Admin Closure
IF $GET(VPRTIU(IEN,1606,"I"))
SET Y=VPRTIU(IEN,1606,"I")
+5 QUIT Y
+6 ;
NATL(IEN) ; -- convert 8925.1 IEN to 8926.1 IEN
+1 ; Expects VPRNATL from VPR DOCUMENT EXTENSION entity
+2 ; Returns DATA = code ^ [description] ^ system
+3 ; TIUTTL = local title name
+4 NEW TIUNATL
SET IEN=+$GET(IEN)
SET DATA=""
+5 SET TIUNATL=$SELECT($GET(VPRNATL):VPRNATL,1:+$GET(^TIU(8925.1,IEN,15)))
+6 SET TIUTTL=$PIECE($GET(^TIU(8925.1,IEN,0)),U)
+7 ; if no national mapping, return local title
+8 IF 'TIUNATL
Begin DoDot:1
+9 IF $PIECE(TIUTTL," ")="LR"
Begin DoDot:2
+10 NEW TTL
SET TTL=$EXTRACT($PIECE(TIUTTL," ",2),1,2)
+11 SET DATA=$SELECT(TTL="AU":"18743-5^AUTOPSY REPORT",TTL="CY":"26438-2^CYTOLOGY STUDIES",TTL="EL":"50668-3^MICROSCOPY STUDIES",TTL="SU":"27898-6^PATHOLOGY STUDIES",1:"")
+12 IF $LENGTH(DATA)
SET DATA=DATA_"^LOINC"
QUIT
End DoDot:2
if $LENGTH(DATA)
QUIT
+13 SET DATA=IEN_U_TIUTTL_"^VA8925.1"
End DoDot:1
QUIT
+14 ; get LOINC or VUID
+15 SET IEN=TIUNATL
SET DATA=$$CODE^VPRSDA(IEN,8926.1,"LNC")
+16 IF DATA=""
SET DATA=$$VUID^VPRD(IEN,8926.1)
if DATA
SET DATA=DATA_"^^VHAT"
+17 ; else default = 8926.1 ien as per usual
+18 QUIT
+19 ;
AVSTS(STS) ; -- return Availability Status of document
+1 NEW Y
SET STS=+$GET(STS)
SET Y=""
+2 IF STS<7!(STS>13)
SET Y="UN^Unavailable for patient care"
+3 IF '$TEST
SET Y="AV^Available for patient care"
+4 QUIT Y
+5 ;
COMP(IEN,VST) ; -- return 1 or 0, if document is complete
+1 SET IEN=+$GET(IEN)
IF IEN<1
QUIT ""
+2 NEW VPRTIU,STS,Y
DO EXTRACT^TIULQ(IEN,"VPRTIU",,".03;.05",,,"I")
+3 ;return, if VST passed by ref
SET VST=$GET(VPRTIU(IEN,.03,"I"))
+4 SET STS=+$GET(VPRTIU(IEN,.05,"I"))
+5 SET Y=$SELECT(STS=7:1,STS=8:1,1:0)
+6 QUIT Y
+7 ;
FAC(IEN) ; -- return #4 ien for TIU document
+1 NEW LOC,FAC
SET IEN=+$GET(IEN)
+2 ; return location's facility if available
+3 SET LOC=+$GET(VPRTIU(IEN,1205,"I"))
SET FAC=""
IF LOC>0
Begin DoDot:1
+4 NEW L0
SET L0=$GET(^SC(LOC,0))
SET FAC=$PIECE(L0,U,4)
+5 ; Get P:4 via Med Ctr Div, if not directly linked
+6 IF 'FAC
IF $PIECE(L0,U,15)
SET FAC=$$GET1^DIQ(44,LOC_",","3.5:.07","I")
End DoDot:1
+7 ; if no location, or loc has no facility, use Division field
+8 IF FAC=""
SET FAC=$GET(VPRTIU(IEN,1212,"I"))
+9 QUIT FAC
+10 ;
TIUS(IEN) ; -- return DLIST array of multiple signers
+1 NEW I,N,MSIEN,X
+2 SET N=0
FOR I=1502,1508
if $GET(VPRTIU(IEN,I,"I"))
SET N=N+1
SET DLIST(N)=VPRTIU(IEN,I,"I")_U_$SELECT(I=1502:"S",1:"C")
+3 SET MSIEN=0
FOR
SET MSIEN=$ORDER(^TIU(8925.7,"B",IEN,MSIEN))
if 'MSIEN
QUIT
IF MSIEN
Begin DoDot:1
+4 SET X=$GET(^TIU(8925.7,MSIEN,0))
+5 IF $PIECE(X,U,5)
SET N=N+1
SET DLIST(N)=$PIECE(X,U,5)_U_"C"
End DoDot:1
+6 QUIT
