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