HMPDJ08 ;SLC/MKB,ASMR/RRB,ASF,HM - TIU Documents;May 15, 2016 14:15
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2**;May 15, 2016;Build 28
;Per VA Directive 6402, this routine should not be modified.
;
;11/19/14 - Fix missing MCAR documents tag EN1+4, EN1+13 js
;
; 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, [HMPSTART, HMPSTOP, HMPMAX, HMPTEXT]
Q
;
TIU1(ID) ; -- document
I ID[";" D Q
. I ID D EN1($$CP1^HMPDJ08A(DFN,ID),"CP") Q ;CP
. D EN1($$LR1^HMPDJ08A(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^HMPDJ08A(DFN,ID),"RA") K ^TMP($J,"RAE1")
D EN1(ID,38)
Q
;
EN1(HMPX,TIU,OUTPUT) ; -- document
; Expects DFN, HMPX=IEN^$$RESOLVE^TIUSRVLO(IEN) or equivalent
; TIU = document class#, or code (CP, RA, LR) if non-TIU
; OUTPUT = store the result in the output array instead (by reference)
N DOC,IEN,X,HMPTIU,NT,ES,I,TEXT,SUB,HMPY,ERR
; --- CP HMPX records with $p1 not the file ien ---
S IEN=$P($G(HMPX),U),TIU=$G(TIU) I TIU="CP" I IEN="" D Q:IEN="" ;invalid ien
. S HMPIEN=+$P(HMPX,$J_",""",2)
. I +HMPIEN>0 S IEN=+HMPIEN
. Q
; ---
I +HMPX=HMPX,TIU D ;get TIU data string, if needed
. N SHOWADD,DA S SHOWADD=1,DA=+HMPX
. S HMPX=DA_U_$$RESOLVE^TIUSRVLO(DA)
; --- CP HMPX records with $p1 not the file ien ---
I +HMPX="" I TIU="CP" D ;get TIU data string, if needed
. N SHOWADD,DA S SHOWADD=1,DA=+IEN
. S HMPX=DA_U_$$RESOLVE^TIUSRVLO(DA)
; ---
Q:"UNKNOWN"[$P($G(HMPX),U,2) ;null or invalid
N $ES,$ET,ERRPAT,ERRMSG
S $ET="D ERRHDLR^HMPDERRH",ERRPAT=DFN
S ERRMSG="A problem occurred converting record "_IEN_" for the document domain"
S DOC("localId")=IEN,DOC("uid")=$$SETUID^HMPUTILS("document",DFN,IEN)
S DOC("localTitle")=$P(HMPX,U,2)
S DOC("referenceDateTime")=$$JSONDT^HMPUTILS($P(HMPX,U,3))
S X=$P(HMPX,U,6) D ;S:$L(X) DOC("location")=X
. N LOC,FAC S LOC=$S($L(X):+$O(^SC("B",X,0)),1:0) ;ICR 10040 DE2818 ASF 11/10/15
. S X=$$FAC^HMPD(LOC)
. S DOC("facilityCode")=$P(X,U),DOC("facilityName")=$P(X,U,2)
S X=$P(HMPX,U,7) I $L(X) S DOC("status")=$$UP^XLFSTR(X)
S:$P(HMPX,U,11) DOC("images")=+$P(HMPX,U,11)
S:$L($P(HMPX,U,12)) DOC("subject")=$P(HMPX,U,12)
I $P(HMPX,U,14)>5 S DOC("parentUid")=$$SETUID^HMPUTILS("document",DFN,$P(HMPX,U,14)) ;ID notes
B ; other TIU data
D:TIU EXTRACT^TIULQ(IEN,"HMPTIU",,,,1,,1) ;".01:.04;1501:1508")
S X=$G(HMPTIU(IEN,.01,"I")) S:X DOC("documentDefUid")=$$SETUID^HMPUTILS("doc-def",,X)
S NT=$S(X:+$G(^TIU(8925.1,X,15)),1:$P(HMPX,U,10)) I NT D ;ICR 2321 DE2818 ASF 11/10/15
. S DOC("nationalTitle","vuid")="urn:va:vuid:"_$$VUID^HMPD(NT,8926.1)
. S DOC("nationalTitle","name")=$$GET1^DIQ(8926.1,NT_",",.01)
S X=$G(HMPTIU(IEN,1201,"I")) S:X DOC("entered")=$$JSONDT^HMPUTILS(X)
S X=$G(HMPTIU(IEN,1601,"I")) S:X DOC("amended")=$$JSONDT^HMPUTILS(X) ;amended date #DE5456
S X=$G(HMPTIU(IEN,.09,"E")) S:$L(X) DOC("urgency")=X
S X=TIU I TIU S X=+$G(HMPTIU(IEN,.01,"I")),X=$$CATG^HMPDTIU(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(HMPTIU(IEN,.03,"I")),1:$P(HMPX,U,8)) ;visit#
S:X DOC("encounterUid")=$$SETUID^HMPUTILS("visit",DFN,X),DOC("encounterName")=$$NAME^HMPDJ04(X)
C ; text blocks, signatures
N HMPT,HMPA,HMPADD
S DOC("text",1,"dateTime")=DOC("referenceDateTime")
S DOC("text",1,"status")=$G(DOC("status"))
S DOC("text",1,"uid")=DOC("uid")
S HMPT=1,X=$P(HMPX,U,5),I=0
I X D USER(.I,+X,$P(X,";",3),"AU") ;author
M ES=HMPTIU(IEN) S X=$P(HMPX,"//",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)
; USER API calling convention
; USER(Incrementer,UserIEN,UserDisplayName,UserRole,SignedByDate,SignedByName,SignedByTitle)
I $G(ES(1501,"I")) D USER(.I,ES(1502,"I"),ES(1502,"E"),"S",ES(1501,"I"),$G(ES(1503,"E")),$G(ES(1504,"E")))
I $G(ES(1507,"I")) D USER(.I,ES(1508,"I"),ES(1508,"E"),"C",ES(1507,"I"),$G(ES(1509,"E")),$G(ES(1510,"E")))
I $G(ES(1204,"I")) D USER(.I,ES(1204,"I"),ES(1204,"E"),"ES") ;expected signer
I $G(ES(1208,"I")) D USER(.I,ES(1208,"I"),ES(1208,"E"),"EC") ;expected cosigner
I $G(ES(1302,"I")) D USER(.I,ES(1302,"I"),ES(1302,"E"),"E") ;entered
I $G(ES(1209,"I")) D USER(.I,ES(1209,"I"),ES(1209,"E"),"ATT") ;attending
I $G(ES(1601,"I")) D USER(.I,ES(1602,"I"),ES(1602,"E"),"AM",ES(1603,"I"),$G(ES(1604,"E")),$G(ES(1605,"E"))) ;amended by #DE5456
I $G(HMPTEXT) D
. S X=$S(TIU:$NA(HMPTIU(IEN,"TEXT")),1:$NA(^TMP("HMPTEXT",$J,IEN)))
. K ^TMP($J,"HMP TIU TEXT")
. D SETTEXT^HMPUTILS(X,$NA(^TMP($J,"HMP TIU TEXT")))
. M DOC("text",1,"content","\")=^TMP($J,"HMP TIU TEXT")
D ; addenda
S HMPA=0 F S HMPA=$O(HMPTIU(IEN,"ZADD",HMPA)) Q:HMPA<1 D
. S HMPT=HMPT+1,I=0 K HMPADD M HMPADD=HMPTIU(IEN,"ZADD",HMPA)
. S DOC("text",HMPT,"status")=$G(HMPADD(.05,"E"))
. S DOC("text",HMPT,"uid")=$$SETUID^HMPUTILS("document",DFN,HMPA)
. S DOC("text",HMPT,"dateTime")=$$JSONDT^HMPUTILS($G(HMPADD(1301,"I")))
. I $G(HMPADD(1302,"I")) D USER(.I,HMPADD(1302,"I"),HMPADD(1302,"E"),"E")
. I $G(HMPADD(1202,"I")) D USER(.I,HMPADD(1202,"I"),HMPADD(1202,"E"),"AU")
. I $G(HMPADD(1501,"I")) D USER(.I,HMPADD(1502,"I"),HMPADD(1502,"E"),"S",HMPADD(1501,"I"))
. I $G(HMPADD(1507,"I")) D USER(.I,HMPADD(1508,"I"),HMPADD(1508,"E"),"C",HMPADD(1507,"I"))
. I $G(HMPADD(1204,"I")) D USER(.I,HMPADD(1204,"I"),HMPADD(1204,"E"),"ES")
. I $G(HMPADD(1208,"I")) D USER(.I,HMPADD(1208,"I"),HMPADD(1208,"E"),"EC")
. I $G(HMPADD(1209,"I")) D USER(.I,HMPADD(1209,"I"),HMPADD(1209,"E"),"ATT")
. Q:'$G(HMPTEXT) K ^TMP($J,"HMP TIU TEXT")
. D ; DE3153, replace "not PRINT" with "not VIEW" MARCH 17, 2016 HM
.. N V,X,T,R,L S V="HMPTIU",T=" You may not PRINT",R=" You may not VIEW",L=$L(T)
.. F S V=$Q(@V) Q:V="" S X=@V S:$E(X,1,L)=T @V=R_$E(X,L+1,$L(X))
. S X=$NA(HMPTIU(IEN,"ZADD",HMPA,"TEXT"))
. D SETTEXT^HMPUTILS(X,$NA(^TMP($J,"HMP TIU TEXT")))
. M DOC("text",HMPT,"content","\")=^TMP($J,"HMP TIU TEXT")
ENQ ; end
K ^TMP($J,"HMP TIU TEXT")
S DOC("lastUpdateTime")=$$EN^HMPSTMP("document") ;RHL 20150102
S DOC("stampTime")=DOC("lastUpdateTime") ; RHL 20150102
;US6734 - pre-compile metastamp
I '$D(OUTPUT),$G(HMPMETA) D ADD^HMPMETA("document",DOC("uid"),DOC("stampTime")) Q:HMPMETA=1 ;US6734,US11019
I '$D(OUTPUT) D ADD^HMPDJ("DOC","document") Q
M OUTPUT=DOC
Q
;
USER(N,IEN,NAME,ROLE,DATE,SBN,SBT) ; -- set author, signer(s)
Q:'$G(IEN) S N=+$G(N)+1
S DOC("text",HMPT,"clinicians",N,"uid")=$$SETUID^HMPUTILS("user",,IEN)
S DOC("text",HMPT,"clinicians",N,"name")=$S($L($G(NAME)):NAME,1:$P($G(^VA(200,IEN,0)),U)) ;ICR 10060 DE2818 ASF 11/10/15
S DOC("text",HMPT,"clinicians",N,"role")=$G(ROLE)
Q:'$G(DATE) ;not co/signed
S DOC("text",HMPT,"clinicians",N,"signedDateTime")=$$JSONDT^HMPUTILS(DATE)
I '$D(SBN) S SBN=NAME
S DOC("text",HMPT,"clinicians",N,"signature")=SBN_$S($L($G(SBT)):" "_SBT,1:"")
;$$SIG^HMPDTIU(IEN)
Q
;
;
; ------------ Get/apply search criteria ------------
; [from DOCUMENT^HMPDJ0]
;
SETUP ; -- convert FILTER("attribute") = value to TIU criteria
; Expects: FILTER("category") = code (see $$CATG)
; FILTER("status") = 'signed','unsigned','all'
; Returns: CLASS,[SUBCLASS,STATUS]
;
K 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)) ;ICR 2321 DE2818 ASF 11/10/15
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,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[HHMPDJ08 10752 printed Dec 13, 2024@01:53:26 Page 2
HMPDJ08 ;SLC/MKB,ASMR/RRB,ASF,HM - TIU Documents;May 15, 2016 14:15
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2**;May 15, 2016;Build 28
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;11/19/14 - Fix missing MCAR documents tag EN1+4, EN1+13 js
+5 ;
+6 ; External References DBIA#
+7 ; ------------------- -----
+8 ; ^SC 10040
+9 ; ^TIU(8925.1 2321,5677
+10 ; ^TIU(8926.1 5678
+11 ; ^VA(200 10060
+12 ; DIQ 2056
+13 ; RAO7PC1 2043
+14 ; TIUCNSLT 5546
+15 ; TIUCP 3568
+16 ; TIULQ 2693
+17 ; TIULX 3058
+18 ; TIUSROI 5676
+19 ; TIUSRVLO 2834,2865
+20 ; XLFSTR 10104
+21 ;
+22 ; All tags expect DFN, ID, [HMPSTART, HMPSTOP, HMPMAX, HMPTEXT]
+23 QUIT
+24 ;
TIU1(ID) ; -- document
+1 IF ID[";"
Begin DoDot:1
+2 ;CP
IF ID
DO EN1($$CP1^HMPDJ08A(DFN,ID),"CP")
QUIT
+3 ;Lab
DO EN1($$LR1^HMPDJ08A(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^HMPDJ08A(DFN,ID),"RA")
KILL ^TMP($JOB,"RAE1")
End DoDot:1
QUIT
+8 DO EN1(ID,38)
+9 QUIT
+10 ;
EN1(HMPX,TIU,OUTPUT) ; -- document
+1 ; Expects DFN, HMPX=IEN^$$RESOLVE^TIUSRVLO(IEN) or equivalent
+2 ; TIU = document class#, or code (CP, RA, LR) if non-TIU
+3 ; OUTPUT = store the result in the output array instead (by reference)
+4 NEW DOC,IEN,X,HMPTIU,NT,ES,I,TEXT,SUB,HMPY,ERR
+5 ; --- CP HMPX records with $p1 not the file ien ---
+6 ;invalid ien
SET IEN=$PIECE($GET(HMPX),U)
SET TIU=$GET(TIU)
IF TIU="CP"
IF IEN=""
Begin DoDot:1
+7 SET HMPIEN=+$PIECE(HMPX,$JOB_",""",2)
+8 IF +HMPIEN>0
SET IEN=+HMPIEN
+9 QUIT
End DoDot:1
if IEN=""
QUIT
+10 ; ---
+11 ;get TIU data string, if needed
IF +HMPX=HMPX
IF TIU
Begin DoDot:1
+12 NEW SHOWADD,DA
SET SHOWADD=1
SET DA=+HMPX
+13 SET HMPX=DA_U_$$RESOLVE^TIUSRVLO(DA)
End DoDot:1
+14 ; --- CP HMPX records with $p1 not the file ien ---
+15 ;get TIU data string, if needed
IF +HMPX=""
IF TIU="CP"
Begin DoDot:1
+16 NEW SHOWADD,DA
SET SHOWADD=1
SET DA=+IEN
+17 SET HMPX=DA_U_$$RESOLVE^TIUSRVLO(DA)
End DoDot:1
+18 ; ---
+19 ;null or invalid
if "UNKNOWN"[$PIECE($GET(HMPX),U,2)
QUIT
+20 NEW $ESTACK,$ETRAP,ERRPAT,ERRMSG
+21 SET $ETRAP="D ERRHDLR^HMPDERRH"
SET ERRPAT=DFN
+22 SET ERRMSG="A problem occurred converting record "_IEN_" for the document domain"
+23 SET DOC("localId")=IEN
SET DOC("uid")=$$SETUID^HMPUTILS("document",DFN,IEN)
+24 SET DOC("localTitle")=$PIECE(HMPX,U,2)
+25 SET DOC("referenceDateTime")=$$JSONDT^HMPUTILS($PIECE(HMPX,U,3))
+26 ;S:$L(X) DOC("location")=X
SET X=$PIECE(HMPX,U,6)
Begin DoDot:1
+27 ;ICR 10040 DE2818 ASF 11/10/15
NEW LOC,FAC
SET LOC=$SELECT($LENGTH(X):+$ORDER(^SC("B",X,0)),1:0)
+28 SET X=$$FAC^HMPD(LOC)
+29 SET DOC("facilityCode")=$PIECE(X,U)
SET DOC("facilityName")=$PIECE(X,U,2)
End DoDot:1
+30 SET X=$PIECE(HMPX,U,7)
IF $LENGTH(X)
SET DOC("status")=$$UP^XLFSTR(X)
+31 if $PIECE(HMPX,U,11)
SET DOC("images")=+$PIECE(HMPX,U,11)
+32 if $LENGTH($PIECE(HMPX,U,12))
SET DOC("subject")=$PIECE(HMPX,U,12)
+33 ;ID notes
IF $PIECE(HMPX,U,14)>5
SET DOC("parentUid")=$$SETUID^HMPUTILS("document",DFN,$PIECE(HMPX,U,14))
B ; other TIU data
+1 ;".01:.04;1501:1508")
if TIU
DO EXTRACT^TIULQ(IEN,"HMPTIU",,,,1,,1)
+2 SET X=$GET(HMPTIU(IEN,.01,"I"))
if X
SET DOC("documentDefUid")=$$SETUID^HMPUTILS("doc-def",,X)
+3 ;ICR 2321 DE2818 ASF 11/10/15
SET NT=$SELECT(X:+$GET(^TIU(8925.1,X,15)),1:$PIECE(HMPX,U,10))
IF NT
Begin DoDot:1
+4 SET DOC("nationalTitle","vuid")="urn:va:vuid:"_$$VUID^HMPD(NT,8926.1)
+5 SET DOC("nationalTitle","name")=$$GET1^DIQ(8926.1,NT_",",.01)
End DoDot:1
+6 SET X=$GET(HMPTIU(IEN,1201,"I"))
if X
SET DOC("entered")=$$JSONDT^HMPUTILS(X)
+7 ;amended date #DE5456
SET X=$GET(HMPTIU(IEN,1601,"I"))
if X
SET DOC("amended")=$$JSONDT^HMPUTILS(X)
+8 SET X=$GET(HMPTIU(IEN,.09,"E"))
if $LENGTH(X)
SET DOC("urgency")=X
+9 ;2U type code
SET X=TIU
IF TIU
SET X=+$GET(HMPTIU(IEN,.01,"I"))
SET X=$$CATG^HMPDTIU(X)
+10 SET DOC("documentTypeCode")=X
SET DOC("documentTypeName")=$$TYPE(X)
+11 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")
+12 ;visit#
SET X=$SELECT(TIU:$GET(HMPTIU(IEN,.03,"I")),1:$PIECE(HMPX,U,8))
+13 if X
SET DOC("encounterUid")=$$SETUID^HMPUTILS("visit",DFN,X)
SET DOC("encounterName")=$$NAME^HMPDJ04(X)
C ; text blocks, signatures
+1 NEW HMPT,HMPA,HMPADD
+2 SET DOC("text",1,"dateTime")=DOC("referenceDateTime")
+3 SET DOC("text",1,"status")=$GET(DOC("status"))
+4 SET DOC("text",1,"uid")=DOC("uid")
+5 SET HMPT=1
SET X=$PIECE(HMPX,U,5)
SET I=0
+6 ;author
IF X
DO USER(.I,+X,$PIECE(X,";",3),"AU")
+7 ;non-TIU, put into ES for use:
MERGE ES=HMPTIU(IEN)
SET X=$PIECE(HMPX,"//",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 ; USER API calling convention
+10 ; USER(Incrementer,UserIEN,UserDisplayName,UserRole,SignedByDate,SignedByName,SignedByTitle)
+11 IF $GET(ES(1501,"I"))
DO USER(.I,ES(1502,"I"),ES(1502,"E"),"S",ES(1501,"I"),$GET(ES(1503,"E")),$GET(ES(1504,"E")))
+12 IF $GET(ES(1507,"I"))
DO USER(.I,ES(1508,"I"),ES(1508,"E"),"C",ES(1507,"I"),$GET(ES(1509,"E")),$GET(ES(1510,"E")))
+13 ;expected signer
IF $GET(ES(1204,"I"))
DO USER(.I,ES(1204,"I"),ES(1204,"E"),"ES")
+14 ;expected cosigner
IF $GET(ES(1208,"I"))
DO USER(.I,ES(1208,"I"),ES(1208,"E"),"EC")
+15 ;entered
IF $GET(ES(1302,"I"))
DO USER(.I,ES(1302,"I"),ES(1302,"E"),"E")
+16 ;attending
IF $GET(ES(1209,"I"))
DO USER(.I,ES(1209,"I"),ES(1209,"E"),"ATT")
+17 ;amended by #DE5456
IF $GET(ES(1601,"I"))
DO USER(.I,ES(1602,"I"),ES(1602,"E"),"AM",ES(1603,"I"),$GET(ES(1604,"E")),$GET(ES(1605,"E")))
+18 IF $GET(HMPTEXT)
Begin DoDot:1
+19 SET X=$SELECT(TIU:$NAME(HMPTIU(IEN,"TEXT")),1:$NAME(^TMP("HMPTEXT",$JOB,IEN)))
+20 KILL ^TMP($JOB,"HMP TIU TEXT")
+21 DO SETTEXT^HMPUTILS(X,$NAME(^TMP($JOB,"HMP TIU TEXT")))
+22 MERGE DOC("text",1,"content","\")=^TMP($JOB,"HMP TIU TEXT")
End DoDot:1
D ; addenda
+1 SET HMPA=0
FOR
SET HMPA=$ORDER(HMPTIU(IEN,"ZADD",HMPA))
if HMPA<1
QUIT
Begin DoDot:1
+2 SET HMPT=HMPT+1
SET I=0
KILL HMPADD
MERGE HMPADD=HMPTIU(IEN,"ZADD",HMPA)
+3 SET DOC("text",HMPT,"status")=$GET(HMPADD(.05,"E"))
+4 SET DOC("text",HMPT,"uid")=$$SETUID^HMPUTILS("document",DFN,HMPA)
+5 SET DOC("text",HMPT,"dateTime")=$$JSONDT^HMPUTILS($GET(HMPADD(1301,"I")))
+6 IF $GET(HMPADD(1302,"I"))
DO USER(.I,HMPADD(1302,"I"),HMPADD(1302,"E"),"E")
+7 IF $GET(HMPADD(1202,"I"))
DO USER(.I,HMPADD(1202,"I"),HMPADD(1202,"E"),"AU")
+8 IF $GET(HMPADD(1501,"I"))
DO USER(.I,HMPADD(1502,"I"),HMPADD(1502,"E"),"S",HMPADD(1501,"I"))
+9 IF $GET(HMPADD(1507,"I"))
DO USER(.I,HMPADD(1508,"I"),HMPADD(1508,"E"),"C",HMPADD(1507,"I"))
+10 IF $GET(HMPADD(1204,"I"))
DO USER(.I,HMPADD(1204,"I"),HMPADD(1204,"E"),"ES")
+11 IF $GET(HMPADD(1208,"I"))
DO USER(.I,HMPADD(1208,"I"),HMPADD(1208,"E"),"EC")
+12 IF $GET(HMPADD(1209,"I"))
DO USER(.I,HMPADD(1209,"I"),HMPADD(1209,"E"),"ATT")
+13 if '$GET(HMPTEXT)
QUIT
KILL ^TMP($JOB,"HMP TIU TEXT")
+14 ; DE3153, replace "not PRINT" with "not VIEW" MARCH 17, 2016 HM
Begin DoDot:2
+15 NEW V,X,T,R,L
SET V="HMPTIU"
SET T=" You may not PRINT"
SET R=" You may not VIEW"
SET L=$LENGTH(T)
+16 FOR
SET V=$QUERY(@V)
if V=""
QUIT
SET X=@V
if $EXTRACT(X,1,L)=T
SET @V=R_$EXTRACT(X,L+1,$LENGTH(X))
End DoDot:2
+17 SET X=$NAME(HMPTIU(IEN,"ZADD",HMPA,"TEXT"))
+18 DO SETTEXT^HMPUTILS(X,$NAME(^TMP($JOB,"HMP TIU TEXT")))
+19 MERGE DOC("text",HMPT,"content","\")=^TMP($JOB,"HMP TIU TEXT")
End DoDot:1
ENQ ; end
+1 KILL ^TMP($JOB,"HMP TIU TEXT")
+2 ;RHL 20150102
SET DOC("lastUpdateTime")=$$EN^HMPSTMP("document")
+3 ; RHL 20150102
SET DOC("stampTime")=DOC("lastUpdateTime")
+4 ;US6734 - pre-compile metastamp
+5 ;US6734,US11019
IF '$DATA(OUTPUT)
IF $GET(HMPMETA)
DO ADD^HMPMETA("document",DOC("uid"),DOC("stampTime"))
if HMPMETA=1
QUIT
+6 IF '$DATA(OUTPUT)
DO ADD^HMPDJ("DOC","document")
QUIT
+7 MERGE OUTPUT=DOC
+8 QUIT
+9 ;
USER(N,IEN,NAME,ROLE,DATE,SBN,SBT) ; -- set author, signer(s)
+1 if '$GET(IEN)
QUIT
SET N=+$GET(N)+1
+2 SET DOC("text",HMPT,"clinicians",N,"uid")=$$SETUID^HMPUTILS("user",,IEN)
+3 ;ICR 10060 DE2818 ASF 11/10/15
SET DOC("text",HMPT,"clinicians",N,"name")=$SELECT($LENGTH($GET(NAME)):NAME,1:$PIECE($GET(^VA(200,IEN,0)),U))
+4 SET DOC("text",HMPT,"clinicians",N,"role")=$GET(ROLE)
+5 ;not co/signed
if '$GET(DATE)
QUIT
+6 SET DOC("text",HMPT,"clinicians",N,"signedDateTime")=$$JSONDT^HMPUTILS(DATE)
+7 IF '$DATA(SBN)
SET SBN=NAME
+8 SET DOC("text",HMPT,"clinicians",N,"signature")=SBN_$SELECT($LENGTH($GET(SBT)):" "_SBT,1:"")
+9 ;$$SIG^HMPDTIU(IEN)
+10 QUIT
+11 ;
+12 ;
+13 ; ------------ Get/apply search criteria ------------
+14 ; [from DOCUMENT^HMPDJ0]
+15 ;
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 KILL CLASS,SUBCLASS,STATUS
+6 NEW TYPE,STS,CP
+7 SET TYPE=$$UP^XLFSTR($GET(FILTER("category")))
+8 SET CLASS=0
SET (SUBCLASS,STATUS)=""
+9 ;
+10 ; status [default='signed']
+11 SET STS=$$LOW^XLFSTR($GET(FILTER("status")))
+12 ;TIUSRVLO statuses
SET STATUS=$SELECT(STS?1"unsig".E:2,STS="all":"5^2",1:5)
+13 ;
+14 ; all documents
+15 if TYPE=""
SET TYPE="ALL"
+16 IF TYPE="ALL"
SET CLASS="3^244^"_+$$CLASS^TIUSROI("SURGICAL REPORTS")_"^CP^LR^RA"
QUIT
+17 ;
+18 ;Progress Notes
IF TYPE="PN"
SET CLASS=3
QUIT
+19 ;Consults
IF TYPE="CR"
SET CLASS=3
SET SUBCLASS=$$CLASS^TIUCNSLT
QUIT
+20 ;CWAD
IF TYPE="CWAD"
SET CLASS=3
SET SUBCLASS="25^27^30^31"
QUIT
+21 ;Crisis Note
IF TYPE="C"
SET CLASS=3
SET SUBCLASS=30
QUIT
+22 ;Clinical Warning
IF TYPE="W"
SET CLASS=3
SET SUBCLASS=31
QUIT
+23 ;Allergy Note
IF TYPE="A"
SET CLASS=3
SET SUBCLASS=25
QUIT
+24 ;Advance Directive
IF TYPE="D"
SET CLASS=3
SET SUBCLASS=27
QUIT
+25 ;
+26 ;Discharge Summary
IF TYPE="DS"
SET CLASS=244
QUIT
+27 ;
+28 IF TYPE="SR"
SET CLASS=$$CLASS^TIUSROI("SURGICAL REPORTS")
QUIT
+29 ;Clin Procedures
IF TYPE="CP"
Begin DoDot:1
+30 ; if unsigned,
IF STATUS'=2
SET CLASS="CP"
+31 ; use TIU class#
IF '$TEST
DO CPCLASS^TIUCP(.CP)
SET CLASS=CP
End DoDot:1
QUIT
+32 ;
+33 ;Lab/Pathology
IF TYPE="LR"
SET CLASS=$SELECT(STATUS=2:$$LR,1:"LR")
QUIT
+34 ;
+35 ;Radiology
IF TYPE="RA"
SET CLASS="RA"
QUIT
+36 ;
+37 QUIT
+38 ;
LR() ; -- Return ien of Lab class
+1 ;ICR 2321 DE2818 ASF 11/10/15
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,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 ""
