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