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

VPRDJ08.m

Go to the documentation of this file.
  1. VPRDJ08 ;SLC/MKB -- Documents ;6/25/12 16:11
  1. ;;1.0;VIRTUAL PATIENT RECORD;**2**;Sep 01, 2011;Build 317
  1. ;;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;
  1. ; External References DBIA#
  1. ; ------------------- -----
  1. ; ^SC 10040
  1. ; ^TIU(8925.1 2321,5677
  1. ; ^TIU(8926.1 5678
  1. ; ^VA(200 10060
  1. ; DIQ 2056
  1. ; RAO7PC1 2043
  1. ; TIUCNSLT 5546
  1. ; TIUCP 3568
  1. ; TIULQ 2693
  1. ; TIULX 3058
  1. ; TIUSROI 5676
  1. ; TIUSRVLO 2834,2865
  1. ; XLFSTR 10104
  1. ;
  1. ; All tags expect DFN, ID, [VPRSTART, VPRSTOP, VPRMAX, VPRTEXT]
  1. ;
  1. TIU1(ID) ; -- document
  1. I ID[";" D Q
  1. . I ID D EN1($$CP1^VPRDJ08A(DFN,ID),"CP") Q ;CP
  1. . D EN1($$LR1^VPRDJ08A(DFN,ID),"LR") Q ;Lab
  1. I ID["-" D Q ;Radiology
  1. . S (BEG,END)=9999999.9999-+ID D EN1^RAO7PC1(DFN,BEG,END,"99P")
  1. . Q:'$D(^TMP($J,"RAE1",DFN,ID)) ;deleted
  1. . D EN1($$RA1^VPRDJ08A(DFN,ID),"RA") K ^TMP($J,"RAE1")
  1. D EN1(ID,38)
  1. Q
  1. ;
  1. EN1(VPRX,TIU) ; -- document
  1. ; Expects DFN, VPRX=IEN^$$RESOLVE^TIUSRVLO(IEN) or equivalent
  1. ; TIU = document class#, or code (CP, RA, LR) if non-TIU
  1. N DOC,IEN,X,VPRTIU,ES,I,TEXT,SUB,VPRY,ERR
  1. S IEN=$P($G(VPRX),U),TIU=$G(TIU) Q:IEN="" ;invalid ien
  1. ;
  1. I +VPRX=VPRX,TIU D ;get TIU data string, if needed
  1. . N SHOWADD,DA S SHOWADD=1,DA=+VPRX
  1. . S VPRX=DA_U_$$RESOLVE^TIUSRVLO(DA)
  1. Q:"UNKNOWN"[$P($G(VPRX),U,2) ;null or invalid
  1. S DOC("localId")=IEN,DOC("uid")=$$SETUID^VPRUTILS("document",DFN,IEN)
  1. S DOC("localTitle")=$P(VPRX,U,2)
  1. S DOC("referenceDateTime")=$$JSONDT^VPRUTILS($P(VPRX,U,3))
  1. S X=$P(VPRX,U,6) D ;S:$L(X) DOC("location")=X
  1. . N LOC,FAC S LOC=$S($L(X):+$O(^SC("B",X,0)),1:0)
  1. . S X=$$FAC^VPRD(LOC)
  1. . S DOC("facilityCode")=$P(X,U),DOC("facilityName")=$P(X,U,2)
  1. S X=$P(VPRX,U,7) S:$L(X) DOC("statusName")=X
  1. S:$P(VPRX,U,11) DOC("images")=+$P(VPRX,U,11)
  1. S:$L($P(VPRX,U,12)) DOC("subject")=$P(VPRX,U,12)
  1. I $P(VPRX,U,14)>5 S DOC("parent")=$P(VPRX,U,14) ;ID notes
  1. A ; national title
  1. S X=$S(TIU:$$GET1^DIQ(8925,IEN_",",".01:1501","I"),1:$P(VPRX,U,10))
  1. I X D ;National Title + attributes
  1. . N IENS,TIU,Y,FNUM,NAME
  1. . S IENS=X_"," D GETS^DIQ(8926.1,IENS,"*","IE","TIU")
  1. . S DOC("nationalTitle","vuid")="urn:va:vuid:"_$G(TIU(8926.1,IENS,99.99,"E"))
  1. . S DOC("nationalTitle","title")=$G(TIU(8926.1,IENS,.01,"E"))
  1. . F I=".04^Subject^2",".05^Role^3",".06^Setting^4",".07^Service^5",".08^Type^6" D
  1. .. S Y=+$G(TIU(8926.1,IENS,+I,"I")) Q:Y'>0
  1. .. S FNUM="8926."_+$P(I,U,3),NAME=$$LOW^XLFSTR($P(I,U,2))
  1. .. S DOC("nationalTitle"_$P(I,U,2),"vuid")="urn:va:vuid:"_$$VUID^VPRD(Y,FNUM)
  1. .. S DOC("nationalTitle"_$P(I,U,2),NAME)=$G(TIU(8926.1,IENS,+I,"E"))
  1. B ; other TIU data
  1. D:TIU EXTRACT^TIULQ(IEN,"VPRTIU",,".01:.05;.09;1201;1202;1208;1209;1301;1501:1508",,1,,1) ;".01:.04;1501:1508")
  1. S X=$G(VPRTIU(IEN,1201,"I")) S:X DOC("entered")=$$JSONDT^VPRUTILS(X)
  1. S X=$G(VPRTIU(IEN,.09,"E")) S:$L(X) DOC("urgency")=X
  1. S X=TIU I TIU S X=+$G(VPRTIU(IEN,.01,"I")),X=$$CATG^VPRDTIU(X) ;2U type code
  1. S DOC("documentTypeCode")=X,DOC("documentTypeName")=$$TYPE(X)
  1. S DOC("documentClass")=$S(X="LR":"LR LABORATORY REPORTS",X="SR":"SURGICAL REPORTS",X="CP":"CLINICAL PROCEDURES",X="RA":"RADIOLOGY REPORTS",X="DS":"DISCHARGE SUMMARY",1:"PROGRESS NOTES")
  1. S X=$S(TIU:$G(VPRTIU(IEN,.03,"I")),1:$P(VPRX,U,8))
  1. S:X DOC("encounterUid")=$$SETUID^VPRUTILS("visit",DFN,X),DOC("encounterName")=$$NAME^VPRDJ04(X)
  1. C ; text blocks, signatures
  1. N VPRT,VPRA,VPRADD
  1. S DOC("text",1,"dateTime")=DOC("referenceDateTime")
  1. S DOC("text",1,"status")=$G(DOC("statusName"))
  1. S DOC("text",1,"uid")=DOC("uid")
  1. S VPRT=1,X=$P(VPRX,U,5),I=0
  1. I X D USER(.I,+X,$P(X,";",3),"A") ;author
  1. M ES=VPRTIU(IEN) S X=$P(VPRX,"//",2) ;non-TIU, put into ES for use:
  1. I $L(X) S ES(1502,"I")=+X,ES(1502,"E")=$P(X,";",2),ES(1501,"I")=$P(X,";",3)
  1. I $G(ES(1501,"I")) D USER(.I,ES(1502,"I"),ES(1502,"E"),"S",ES(1501,"I")) ;signer
  1. I $G(ES(1507,"I")) D USER(.I,ES(1508,"I"),ES(1508,"E"),"C",ES(1507,"I")) ;cosigner
  1. I $G(ES(1208,"I")) D USER(.I,ES(1208,"I"),ES(1208,"E"),"X") ;expected cosigner
  1. S X=+$G(ES(1209,"I")) I X D
  1. . S DOC("attendingUid")=$$SETUID^VPRUTILS("user",,X)
  1. . S DOC("attendingName")=$P($G(^VA(200,X,0)),U)
  1. I $G(VPRTEXT) D
  1. . S X=$S(TIU:$NA(VPRTIU(IEN,"TEXT")),1:$NA(^TMP("VPRTEXT",$J,IEN)))
  1. . K ^TMP($J,"VPR TIU TEXT")
  1. . D SETTEXT^VPRUTILS(X,$NA(^TMP($J,"VPR TIU TEXT")))
  1. . M DOC("text",1,"content","\")=^TMP($J,"VPR TIU TEXT")
  1. D ; addenda
  1. S VPRA=0 F S VPRA=$O(VPRTIU(IEN,"ZADD",VPRA)) Q:VPRA<1 D
  1. . S VPRT=VPRT+1,I=0 K VPRADD M VPRADD=VPRTIU(IEN,"ZADD",VPRA)
  1. . S DOC("text",VPRT,"status")=$G(VPRADD(.05,"E"))
  1. . S DOC("text",VPRT,"uid")=$$SETUID^VPRUTILS("document",DFN,VPRA)
  1. . S DOC("text",VPRT,"dateTime")=$$JSONDT^VPRUTILS($G(VPRADD(1301,"I")))
  1. . I $G(VPRADD(1202,"I")) D USER(.I,VPRADD(1202,"I"),VPRADD(1202,"E"),"A")
  1. . I $G(VPRADD(1501,"I")) D USER(.I,VPRADD(1502,"I"),VPRADD(1502,"E"),"S",VPRADD(1501,"I"))
  1. . I $G(VPRADD(1507,"I")) D USER(.I,VPRADD(1508,"I"),VPRADD(1508,"E"),"C",VPRADD(1507,"I"))
  1. . Q:'$G(VPRTEXT) K ^TMP($J,"VPR TIU TEXT")
  1. . S X=$NA(VPRTIU(IEN,"ZADD",VPRA,"TEXT"))
  1. . D SETTEXT^VPRUTILS(X,$NA(^TMP($J,"VPR TIU TEXT")))
  1. . M DOC("text",VPRT,"content","\")=^TMP($J,"VPR TIU TEXT")
  1. ENQ ; end
  1. K ^TMP($J,"VPR TIU TEXT")
  1. D ADD^VPRDJ("DOC","document")
  1. Q
  1. ;
  1. USER(N,IEN,NAME,ROLE,DATE) ; -- set author, signer(s)
  1. Q:'$G(IEN) S N=+$G(N)+1
  1. S DOC("text",VPRT,"clinicians",N,"uid")=$$SETUID^VPRUTILS("user",,IEN)
  1. S DOC("text",VPRT,"clinicians",N,"name")=$S($L($G(NAME)):NAME,1:$P($G(^VA(200,IEN,0)),U))
  1. S DOC("text",VPRT,"clinicians",N,"role")=$G(ROLE)
  1. Q:'$G(DATE) ;not co/signed
  1. S DOC("text",VPRT,"clinicians",N,"signedDateTime")=$$JSONDT^VPRUTILS(DATE)
  1. S DOC("text",VPRT,"clinicians",N,"signature")=$$SIG^VPRDTIU(IEN)
  1. Q
  1. ;
  1. ; ------------ Get/apply search criteria ------------
  1. ; [from DOCUMENT^VPRDJ0]
  1. ;
  1. SETUP ; -- convert FILTER("attribute") = value to TIU criteria
  1. ; Expects: FILTER("category") = code (see $$CATG)
  1. ; FILTER("status") = 'signed','unsigned','all'
  1. ; Returns: CLASS,[SUBCLASS,STATUS]
  1. ;
  1. N TYPE,STS,CP
  1. S TYPE=$$UP^XLFSTR($G(FILTER("category")))
  1. S CLASS=0,(SUBCLASS,STATUS)=""
  1. ;
  1. ; status [default='signed']
  1. S STS=$$LOW^XLFSTR($G(FILTER("status")))
  1. S STATUS=$S(STS?1"unsig".E:2,STS="all":"5^2",1:5) ;TIUSRVLO statuses
  1. ;
  1. ; all documents
  1. S:TYPE="" TYPE="ALL"
  1. I TYPE="ALL" S CLASS="3^244^"_+$$CLASS^TIUSROI("SURGICAL REPORTS")_"^CP^LR^RA" Q
  1. ;
  1. I TYPE="PN" S CLASS=3 Q ;Progress Notes
  1. I TYPE="CR" S CLASS=3,SUBCLASS=$$CLASS^TIUCNSLT Q ;Consults
  1. I TYPE="CWAD" S CLASS=3,SUBCLASS="25^27^30^31" Q ;CWAD
  1. I TYPE="C" S CLASS=3,SUBCLASS=30 Q ;Crisis Note
  1. I TYPE="W" S CLASS=3,SUBCLASS=31 Q ;Clinical Warning
  1. I TYPE="A" S CLASS=3,SUBCLASS=25 Q ;Allergy Note
  1. I TYPE="D" S CLASS=3,SUBCLASS=27 Q ;Advance Directive
  1. ;
  1. I TYPE="DS" S CLASS=244 Q ;Discharge Summary
  1. ;
  1. I TYPE="SR" S CLASS=$$CLASS^TIUSROI("SURGICAL REPORTS") Q
  1. I TYPE="CP" D Q ;Clin Procedures
  1. . I STATUS'=2 S CLASS="CP" ; if unsigned,
  1. . E D CPCLASS^TIUCP(.CP) S CLASS=CP ; use TIU class#
  1. ;
  1. I TYPE="LR" S CLASS=$S(STATUS=2:$$LR,1:"LR") Q ;Lab/Pathology
  1. ;
  1. I TYPE="RA" S CLASS="RA" Q ;Radiology
  1. ;
  1. Q
  1. ;
  1. LR() ; -- Return ien of Lab class
  1. N Y S Y=+$O(^TIU(8925.1,"B","LR LABORATORY REPORTS",0))
  1. I Y>0,$S($P($G(^TIU(8925.1,Y,0)),U,4)="CL":0,$P($G(^(0)),U,4)="DC":0,1:1) S Y=0
  1. Q Y
  1. ;
  1. MATCH(DOC,STS) ; -- Return 1 or 0, if document DA matches search criteria
  1. N Y,DA,LOCAL,NATL,X0,OK S Y=0
  1. S DA=+$G(DOC) G:DA<1 MQ
  1. ; include addenda if pulling only unsigned items
  1. I $P(DOC,U,2)?1"Addendum ".E,STATUS'=2 G MQ
  1. ; TIU unsigned list can include completed parent notes
  1. I $G(STS)=2,$P(DOC,U,7)'="unsigned" G MQ
  1. S LOCAL=$$GET1^DIQ(8925,DA_",",.01,"I") ;local Title 8925.1 ien
  1. I $L(SUBCLASS) D G:'OK MQ
  1. . N I,X S OK=0
  1. . F I=1:1:$L(SUBCLASS,"^") S X=$P(SUBCLASS,U,I) I $$ISA^TIULX(LOCAL,X) S OK=1 Q
  1. S Y=1
  1. MQ Q Y
  1. ;
  1. TYPE(X) ; -- Return name of category type X
  1. S X=$G(X)
  1. I X="PN" Q "Progress Note"
  1. I X="DS" Q "Discharge Summary"
  1. I X="CP" Q "Clinical Procedure"
  1. I X="SR" Q "Surgery Report"
  1. I X="LR" Q "Laboratory Report"
  1. I X="RA" Q "Radiology Report"
  1. I X="CR" Q "Consult Report"
  1. I X="C" Q "Crisis Note"
  1. I X="W" Q "Clinical Warning"
  1. I X="A" Q "Allergy/Adverse Reaction"
  1. I X="D" Q "Advance Directive"
  1. Q ""