Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VPRSDAT

VPRSDAT.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VHA Directive 6402, this routine should not be modified.
  1. ;
  1. ; External References DBIA#
  1. ; ------------------- -----
  1. ; ^SC 10040
  1. ; ^TIU(8925.1 5677
  1. ; ^TIU(8925.7 7416
  1. ; DIQ 2056
  1. ; TIULQ 2693
  1. ; TIUVPR 6077
  1. ;
  1. DOCQRY ; -- Text Integration Utilities query
  1. ; Expects DSTRT, DSTOP, DMAX from DDEGET and returns DLIST(#)=ien
  1. N VPRY,VPRI,VPRN
  1. D LIST^TIUVPR(.VPRY,DFN,38,DSTRT,DSTOP)
  1. S VPRN=0,VPRI="COUNT"
  1. F S VPRI=$O(@VPRY@(VPRI),-1) Q:VPRI<1 D Q:VPRN'<DMAX
  1. . S VPRN=VPRN+1,DLIST(VPRN)=+VPRI
  1. K @VPRY
  1. Q
  1. ;
  1. DOC1(IEN) ; -- ID Action for single document
  1. K VPRTIU S IEN=+$G(IEN) I IEN<1 S DDEOUT=1 Q
  1. D EXTRACT^TIULQ(IEN,"VPRTIU",,".01:.08;1201;1202;1205;1207;1212;1301;1302;1307;1404;1501:1508;1601:1606;1701;2101;15001",,,"I")
  1. Q
  1. ;
  1. TEXT ; -- return note text in WP(#) array
  1. N VPRT,STS,TAG,FILE,FIELD,IEN ;protect variables
  1. S STS=+$G(VPRTIU(DIEN,.05,"I"))
  1. I STS=15 S WP(1)="This document has been RETRACTED." Q
  1. I STS=14 S WP(1)="This document has been DELETED." Q
  1. I '$G(VPRTIU(DIEN,.01,"I")) S WP(1)="This document has been DELETED." Q
  1. D RPT^VPRDTIU(.VPRT,DIEN) M WP=@VPRT
  1. Q
  1. ;
  1. TYPE(IEN) ; -- return code^name for document type/class
  1. N X,Y S Y=""
  1. S X=$$CATG^VPRDTIU(IEN) I X="PN" D
  1. . N NATL,SVC
  1. . S NATL=+$G(^TIU(8925.1,+$G(IEN),15)) Q:'NATL
  1. . S SVC=$$GET1^DIQ(8926.1,NATL_",",.07) Q:SVC=""
  1. . I SVC["HISTORY & PHYSICAL"!(SVC["HISTORY AND PHYSICAL") S Y="HP^History & Physical" Q
  1. . I SVC["COMPENSATION & PENSION" S Y="CM^Compensation & Pension" Q
  1. I X="" S Y="CD^Clinical Document" ;not in known doc class
  1. S:'$L(Y) Y=X_U_$$TYPE^VPRDJ08(X) ;name of known doc class
  1. Q Y
  1. ;
  1. SIGDT(IEN) ; -- return date of authorization
  1. N Y S Y="",IEN=+$G(IEN)
  1. I $G(VPRTIU(IEN,1501,"I")) S Y=VPRTIU(IEN,1501,"I") ;Signed
  1. I $G(VPRTIU(IEN,1507,"I")) S Y=VPRTIU(IEN,1507,"I") ;Co-signed
  1. I $G(VPRTIU(IEN,1606,"I")) S Y=VPRTIU(IEN,1606,"I") ;Admin Closure
  1. Q Y
  1. ;
  1. NATL(IEN) ; -- convert 8925.1 IEN to 8926.1 IEN
  1. ; Expects VPRNATL from VPR DOCUMENT EXTENSION entity
  1. ; Returns DATA = code ^ [description] ^ system
  1. ; TIUTTL = local title name
  1. N TIUNATL S IEN=+$G(IEN),DATA=""
  1. S TIUNATL=$S($G(VPRNATL):VPRNATL,1:+$G(^TIU(8925.1,IEN,15)))
  1. S TIUTTL=$P($G(^TIU(8925.1,IEN,0)),U)
  1. ; if no national mapping, return local title
  1. I 'TIUNATL D Q
  1. . I $P(TIUTTL," ")="LR" D Q:$L(DATA)
  1. .. N TTL S TTL=$E($P(TIUTTL," ",2),1,2)
  1. .. 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:"")
  1. .. I $L(DATA) S DATA=DATA_"^LOINC" Q
  1. . S DATA=IEN_U_TIUTTL_"^VA8925.1"
  1. ; get LOINC or VUID
  1. S IEN=TIUNATL,DATA=$$CODE^VPRSDA(IEN,8926.1,"LNC")
  1. I DATA="" S DATA=$$VUID^VPRD(IEN,8926.1) S:DATA DATA=DATA_"^^VHAT"
  1. ; else default = 8926.1 ien as per usual
  1. Q
  1. ;
  1. AVSTS(STS) ; -- return Availability Status of document
  1. N Y S STS=+$G(STS),Y=""
  1. I STS<7!(STS>13) S Y="UN^Unavailable for patient care"
  1. E S Y="AV^Available for patient care"
  1. Q Y
  1. ;
  1. COMP(IEN,VST) ; -- return 1 or 0, if document is complete
  1. S IEN=+$G(IEN) I IEN<1 Q ""
  1. N VPRTIU,STS,Y D EXTRACT^TIULQ(IEN,"VPRTIU",,".03;.05",,,"I")
  1. S VST=$G(VPRTIU(IEN,.03,"I")) ;return, if VST passed by ref
  1. S STS=+$G(VPRTIU(IEN,.05,"I"))
  1. S Y=$S(STS=7:1,STS=8:1,1:0)
  1. Q Y
  1. ;
  1. FAC(IEN) ; -- return #4 ien for TIU document
  1. N LOC,FAC S IEN=+$G(IEN)
  1. ; return location's facility if available
  1. S LOC=+$G(VPRTIU(IEN,1205,"I")),FAC="" I LOC>0 D
  1. . N L0 S L0=$G(^SC(LOC,0)),FAC=$P(L0,U,4)
  1. . ; Get P:4 via Med Ctr Div, if not directly linked
  1. . I 'FAC,$P(L0,U,15) S FAC=$$GET1^DIQ(44,LOC_",","3.5:.07","I")
  1. ; if no location, or loc has no facility, use Division field
  1. I FAC="" S FAC=$G(VPRTIU(IEN,1212,"I"))
  1. Q FAC
  1. ;
  1. TIUS(IEN) ; -- return DLIST array of multiple signers
  1. N I,N,MSIEN,X
  1. 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")
  1. S MSIEN=0 F S MSIEN=$O(^TIU(8925.7,"B",IEN,MSIEN)) Q:'MSIEN I MSIEN D
  1. . S X=$G(^TIU(8925.7,MSIEN,0))
  1. . I $P(X,U,5) S N=N+1,DLIST(N)=$P(X,U,5)_U_"C"
  1. Q