TIUCOP ;SLC/TDP - Copy/Paste API(s) and RPC(s) ;Jul 29, 2020@10:13:01
;;1.0;TEXT INTEGRATION UTILITIES;**290,336**;Jun 20, 1997;Build 4
;
; External Reference
; DBIA 2051 $$FIND1^DIC
; DBIA 1544 $$ISA^USRLM
;
Q
WORDS(INST) ;Return the number of words required to begin tracking
; copied text as part of the Copy/Paste functionality.
;
; Call using $$WORDS^TIUCOP(INSTITUTION IEN)
;
; Input
; INST - institution ien
;
; Ouput
; - Number of Words required (example "5")^Max text length
; Or
; Error condition "-1^Error Msg"
;
N IEN,WRDS,MAXLNG
I $G(INST)="" S INST=$G(DUZ(2))
I +INST<1 Q "-1^Invalid institution"
S INST=$$FIND1^DIC(4,"","","`"_INST,"","","ERR")
I +INST<1 Q "-1^Invalid institution"
S IEN=$O(^TIU(8925.99,"B",INST,0))
I +IEN=0 Q "-1^Institution not defined in TIU PARAMETERS file"
S WRDS=+$P($G(^TIU(8925.99,IEN,4)),U,1)
I WRDS=0 S WRDS=5 D ERMSG^TIUCOPUT("WORD") ;Send error message if required words not set in parameter
Q WRDS
;
MAXLNG() ;Return the Maximum length string we will recalculate percentage
N MAX
S MAX=$$GET^XPAR("ALL","ORQQTIU COPY/PASTE FIND LIMIT",,"Q")
I MAX="" S MAX=10000
Q MAX
;
PCT(INST) ;Return the Copy/Paste verification percentage
; Call using $$PCT^TIUCOP(INSTITUTION IEN)
;
; Input
; INST - institution ien
;
; Output
; - Percent pasted text matches copied text needed to be considered
; as derived from the copied text (example ".5")
; Or
; Error condition "-1^Error Msg"
;
N IEN,PCT
I $G(INST)="" S INST=$G(DUZ(2))
I +INST<1 Q "-1^Invalid institution"
S INST=$$FIND1^DIC(4,"","","`"_INST,"","","ERR")
I +INST<1 Q "-1^Invalid institution"
S IEN=$O(^TIU(8925.99,"B",INST,0))
I +IEN=0 Q "-1^Institution not defined in TIU PARAMETERS file"
S PCT=+$P($G(^TIU(8925.99,IEN,4)),U,2)
I PCT=0 S PCT=90 D ERMSG^TIUCOPUT("PCT") ;Send error message if required percentage is not set in parameter
Q PCT/100
;
DAYS(INST) ;Return the number of days to save copied text information
; Call using $$DAYS^TIUCOP(INSTITUTION IEN)
;
; Input
; INST - institution ien
;
; Output
; - Days to save copied text (example "7")
; Or
; Error condition "-1^Error Msg"
;
N IEN,DAYS
I $G(INST)="" S INST=$G(DUZ(2))
I +INST<1 Q "-1^Invalid institution"
S INST=$$FIND1^DIC(4,"","","`"_INST,"","","ERR")
I +INST<1 Q "-1^Invalid institution"
S IEN=$O(^TIU(8925.99,"B",INST,0))
I +IEN=0 Q "-1^Institution not defined in TIU PARAMETERS file"
S DAYS=+$P($G(^TIU(8925.99,IEN,4)),U,3)
I DAYS=0 S DAYS=1 D ERMSG^TIUCOPUT("DAY") ;Send error message if required percentage is not set in parameter
Q DAYS
;
EXC(TIUDA) ;Return whether or not note is excluded from copy/paste tracking
; Call using $$EXC^TIUCOP(TIU IEN)
;
; Input
; TIUDA - TIU ien (#8925)
;
; Output
; - Boolean (1: Exclude, 0:Don't Exclude)
; Or
; Error condition "-1^Error Msg"
;
N CLDOC,IEN,EX,ND0,TMP,X
S EX=0
I $G(TIUDA)="" Q "-1^TIU IEN required"
I +TIUDA<1 Q "-1^Invalid TIU IEN"
I '$G(^TIU(8925,TIUDA,0)) Q "-1^Invalid TIU IEN"
S IEN=+$P($G(^TIU(8925,TIUDA,0)),U,1)
I '$D(^TIU(8925.1,IEN,0)) Q EX ;Missing TIU Document Type
S ND0=$G(^TIU(8925.1,IEN,0))
I ND0="" Q EX
S CLDOC=$O(^TIU(8925.1,"B","CLINICAL DOCUMENTS",""))
D ANCESTOR^TIUFLF4(IEN,ND0,.TMP,0)
S X=""
F S X=$O(TMP(X)) Q:X="" Q:IEN=CLDOC D Q:EX=1
. S IEN=+$G(TMP(X))
. I IEN=CLDOC Q
. S IEN=$O(^TIU(8925.95,"B",IEN,0))
. I +IEN<1 Q ;"-1^Missing TIU Document Type"
. S EX=+$P($G(^TIU(8925.95,IEN,10)),U,1)
. I EX'="" S IEN=CLDOC
Q EX
;
EXCLST(TIULST) ;Returns a list of all copy/paste excluded note titles
N CNT,DOCTTL,DOCCLS,DOCIEN,DOCNM,TIUND0
S (CNT,DOCCLS)=0
F S DOCCLS=$O(^TIU(8925.95,"AC",DOCCLS)) Q:DOCCLS="" D
. S TIUND0=$G(^TIU(8925.1,DOCCLS,0))
. ;Track list of documents to return
. I $P(TIUND0,U,4)="DOC" D
. . S CNT=CNT+1
. . S TIULST(CNT)=DOCCLS_U_$P(TIUND0,U,1)
. . S TIULST("B",DOCCLS)=""
. ;Track list of non-documents to review further
. S DOCTTL=0
. F S DOCTTL=$O(^TIU(8925.1,"ACL",DOCCLS,DOCTTL)) Q:DOCTTL="" D
. . S DOCIEN=0
. . F S DOCIEN=$O(^TIU(8925.1,"ACL",DOCCLS,DOCTTL,DOCIEN)) Q:DOCIEN="" D
. . . S DOCNM=$P($G(^TIU(8925.1,DOCIEN,0)),U,1)
. . . I '$D(TIULST("B",DOCIEN)) S CNT=CNT+1,TIULST(CNT)=DOCIEN_U_DOCNM,TIULST("B",DOCIEN)=""
I CNT=0 S TIULST(1)=""
K TIULST("B")
Q
;
VIEW(USER,IEN,INST) ;Is user allowed to view copy/paste
; Call using $$VIEW^TIUCOP(USER DUZ,TIU (NOTE) IEN,INSTITUTION)
; RSLT=
; 0 - User is not allowed to view copy/paste information
; 1 - User is AUTHOR and note is UNSIGNED, or user is COSIGNER who has yet to
; SIGN the note.
; 2 - User has a user class of "CHIEF, MIS", or "CHIEF, HIMS",
; or "PRIVACY ACT OFFICER", or one of the user classes designated
; at the site.
N AUTH,AUTHSGN,CHIM,CMIS,COSGNSGN,COSIGN,FIN,HIM,INSTIEN,PAO,TIU12,TIU15
N USRCLS,X
S FIN=""
I +USER=0 Q 0 ;Not a valid user, so not allowed to view
S INST=$G(DUZ(2))
I +INST=0 Q 0 ;Institution is required
S CMIS="CHIEF, MIS"
S CHIM="CHIEF, HIMS"
S PAO="PRIVACY ACT OFFICER"
F USRCLS=CHIM,CMIS,PAO D Q:FIN
. S FIN=$$ISA^USRLM(+USER,USRCLS)
I FIN Q 2 ;User belongs to special user class
S INSTIEN=$O(^TIU(8925.99,"B",INST,""))
I INSTIEN>0 S X=0 F S X=$O(^TIU(8925.99,INSTIEN,5,X)) Q:+X=0 D Q:FIN
. S USRCLS=$P(^TIU(8925.99,INSTIEN,5,X,0),U,1)
. S FIN=$$ISA^USRLM(+USER,USRCLS)
I FIN Q 2 ;User belongs to special user class
I +$G(IEN)=0 Q 0 ;No ien. User does not belong to special user class and no further checks.
S TIU12=$G(^TIU(8925,+IEN,12))
S TIU15=$G(^TIU(8925,+IEN,15))
S AUTH=+$P(TIU12,U,2)
S AUTHSGN=+$P(TIU15,U,2)
;I AUTH=USER,AUTH'=AUTHSGN Q 1 ;User is author and has not signed note.
I AUTH=USER,AUTHSGN=0 Q 1 ;User is author and has not signed note.
S COSIGN=+$P(TIU12,U,8)
I 'COSIGN Q 0 ;No cosigner, so user not authorized.
S COSGNSGN=+$P(TIU15,U,8)
I COSIGN=USER,COSIGN'=COSGNSGN Q 1 ;User is cosigner and unsigned, author has signed.
Q 0 ;User not authorized
;
PUTCOPY(INST,ARY,ERR) ;Save to copy buffer
N SAVE
S INST=$G(DUZ(2))
S SAVE=$$PUTCOPY^TIUCOPC(INST,.ARY,.ERR)
Q SAVE
;
GETCOPY(INST,DFN,ARY,STRT) ;Retrieve copy buffer
I $G(STRT)="" S STRT=""
S INST=$G(DUZ(2))
D GETCOPY^TIUCOPC(INST,DFN,.ARY,STRT,1)
Q
;
GETCOPY1 ;Retrieve copy buffer in background
;DFN,DIV,HWND,IP,NODE are saved variables as part of queued process
;ZTQUEUED,ZTREQ are variables that exist as part of a queued process
;DILOCKTM is a global variable
N ARY,STRT
I $D(ZTQUEUED) S ZTREQ="@"
I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE) Q ; client no longer polling
I '$D(^XTMP(NODE,0)) Q ; XTMP node has been purged
L +^XTMP(NODE):$S($G(DILOCKTM)>0:DILOCKTM,1:5)
S ^XTMP(NODE,"DFN")=DFN
S (ARY,STRT)=""
D GETCOPY^TIUCOPC(DIV,DFN,.ARY,STRT,0)
I $G(^XTMP(NODE,"STOP")) Q
I +ARY(0,0)>0 D
. N CNT,ND,ND1,X
. S CNT=0
. S ND="" F S ND=$O(ARY(ND)) Q:ND="" D
.. S ND1="" F S ND1=$O(ARY(ND,ND1)) Q:ND1="" D
... I ND=0,ND1=0 Q
... S X="("_ND_","_ND1_")="
... S CNT=CNT+1
... S ^XTMP(NODE,"COPY",CNT)=X_$G(ARY(ND,ND1))
... K ARY(ND,ND1)
;... I (CNT#100)=0 H 10
I +$G(ARY(0,0))=-1 S ^XTMP(NODE,"COPY",-1)=$P($G(ARY),U,2) K ARY(0,0)
S ^XTMP(NODE,"DONE")=1
I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE)
L -^XTMP(NODE)
Q
CHKPASTE(INST,DOC) ;Check note document for pasted text data
S INST=$G(DUZ(2))
Q $$CHKPASTE^TIUCOPP(DOC,INST)
;
PUTPASTE(RSLT,INST,ARY,ERR) ;Save pasted text SVARY
N CNTR,DIV,PIEN,RSLT1,SAVE,SVARY
S INST=$G(DUZ(2))
S SAVE=""
S SVARY=1
S SAVE=$$PUTPASTE^TIUCOPP(INST,.ARY,.ERR,.SVARY)
I +$G(SVARY(0))>0 S CNTR=0 F S CNTR=$O(SVARY(CNTR)) Q:CNTR="" D
. S DIV=+$G(SVARY(CNTR)) Q:DIV=0
. S PIEN=$P($G(SVARY(CNTR)),U,2)
. D GETPST^TIUCOP1(PIEN,DIV,.RSLT1,1)
I +$G(RSLT1(0,0))=-1 S RSLT(-1)=$P($G(RSLT1),U,2) S RSLT("0,0")=-1 K RSLT1(0,0) Q 0
I +$G(RSLT1(0,0))>0 D
. N CNT,ND,ND1
. S CNT=0
. S ND=0 F S ND=$O(RSLT1(ND)) Q:ND="" D
.. S CNT=CNT+1
.. S RSLT(CNT)=CNT_"="_$G(RSLT1(ND,0))
.. K RSLT1(ND)
Q SAVE
;
GETPASTE(TIUIEN,INST,APP,ARY) ;Retrieve pasted text
S INST=$G(DUZ(2))
D GETPASTE^TIUCOPP(TIUIEN,INST,APP,.ARY,0)
Q
;
START(VAL,DFN,IP,HWND,DIV) ;Start copy buffer build in background
N DT,NODE,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK ;,ORHTIME
S DIV=$G(DUZ(2))
S VAL=0
S DT=$$DT^XLFDT
S NODE="TIUCOP "_IP_"-"_HWND_"-"_DFN
S ZTIO="",ZTRTN="GETCOPY1^TIUCOP",ZTDTH=$H
S (ZTSAVE("DFN"),ZTSAVE("IP"),ZTSAVE("HWND"),ZTSAVE("DIV"),ZTSAVE("NODE"))=""
S ZTDESC="CPRS GUI Background Data Retrieval"
K ^XTMP(NODE)
S ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT
D ^%ZTLOAD I '$D(ZTSK) D Q
. K ^XTMP(NODE,0)
. S VAL=0
S $P(^XTMP(NODE,0),U,3)="Background CPRS "_ZTSK
S VAL=1
; Start capacity planning timing clock - will be stopped in POLL code
;I +$G(^KMPTMP("KMPD-CPRS")) S ^KMPTMP("KMPDT","ORWCV",NODE)=$G(ORHTIME)_"^^"_$G(DUZ)_"^"_$G(IO("CLNM"))
Q
;
POLL(LST,DFN,IP,HWND) ; poll for completed cover sheet parts
N I,ILST,ID,LAST,LSTDATA,NODE,DONE,STOP,OLDI,QT
S NODE="TIUCOP "_IP_"-"_HWND_"-"_DFN,ILST=1,DONE=0
I '$D(^XTMP(NODE,"DFN")) S LST(1)="~DONE=1" Q
I ^XTMP(NODE,"DFN")'=DFN S LST(1)="~DONE=1" Q
S LST(1)="~DONE=0"
I $G(^XTMP(NODE,"DONE")) S ILST=1,LST(1)="~DONE=1",DONE=1
S LAST=$O(^XTMP(NODE,"COPY",""),-1)
;I LAST="" S LST(1)="~NO DATA YET" Q
S STOP=99999999999
I $G(LAST)'="" D
. ;S STOP=($P($P($G(^XTMP(NODE,"COPY",LAST)),",",1),"(",2)-1)
. S STOP=$P($P($G(^XTMP(NODE,"COPY",LAST)),",",1),"(",2)
. I STOP<1 S STOP=0
S (OLDI,QT)=0
S I=0 F S I=$O(^XTMP(NODE,"COPY",I)) Q:'I D Q:QT=1
. I $G(^XTMP(NODE,"STOP"))=1 S (DONE,QT)=1,LST(1)="~DONE=1"
. I $P($P($G(^XTMP(NODE,"COPY",I)),",",1),"(",2)>STOP S QT=1 Q
. ;I ILST=1999!ILST-1=LAST S OLDI=($P($P($G(^XTMP(NODE,"COPY",I)),",",1),"(",2)-1)
. ;I ((ILST>1999)!(LAST'<ILST)),OLDI'=($P($P($G(^XTMP(NODE,"COPY",I)),",",1),"(",2)-1) S QT=1 Q
. S ILST=ILST+1,LST(ILST)=^(I)
. I ILST=2000 S QT=1
. K ^XTMP(NODE,"COPY",I)
I 'DONE,$G(^XTMP(NODE,"STOP"))=1 S DONE=1,LST(1)="~DONE=1"
; Stop capacity planning timing clock - was started in START code
I DONE K ^XTMP(NODE) Q ;I +$G(^KMPTMP("KMPD-CPRS")) S $P(^KMPTMP("KMPDT","ORWCV",NODE),"^",2)=$H
I $G(LST(1))="" S LST(1)="~NO DATA YET"
Q
;
STOP(OK,DFN,IP,HWND) ; stop cover sheet data retrieval
;DILOCKTM is a global variable
N NODE
S NODE="TIUCOP "_IP_"-"_HWND_"-"_DFN
S ^XTMP(NODE,"STOP")=1,OK=1
L +^XTMP(NODE):$S($G(DILOCKTM)>0:DILOCKTM,1:5)
I $G(^XTMP(NODE,"DONE")) K ^XTMP(NODE)
L -^XTMP(NODE)
Q
;
CLEAN(TASK) ;Start CLEANUP background process
N DT,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
S TASK=0
S DT=$$DT^XLFDT
S ZTIO="",ZTRTN="CLEANUP^TIUCOP",ZTDTH=$H
S ZTDESC="TIU Copy/Paste Background ^XTMP global clean-up"
D ^%ZTLOAD I '$D(ZTSK) Q Y
S TASK=ZTSK
Q
;
CLEANUP ; clean up ^XTMP nodes
N %Y,DT,KILLDATE,NODE,TIUNMSPC,X,X1,X2
S DT=$$DT^XLFDT ;Get current date
;Loop through Copy Buffer polling (retrieval) nodes
S NODE="TIUCOP"
F S NODE=$O(^XTMP(NODE)) Q:$E(NODE,1,6)'="TIUCOP" D
. S (%Y,KILLDATE,X,X1,X2)=""
. S X1=DT
. S X2=$P($G(^XTMP(NODE,0)),U,1)
. D ^%DTC
. I +X>1 K ^XTMP(NODE)
;. W !,X K ^XTMP(NODE)
;Loop through Copy Buffer save nodes
S TIUNMSPC="TIU COPY/PASTE:"
F S TIUNMSPC=$O(^XTMP(TIUNMSPC)) Q:TIUNMSPC=""!(TIUNMSPC'["TIU COPY/PASTE:") D
. S (%Y,KILLDATE,X,X1,X2)=""
. S X1=DT
. S X2=$P($G(^XTMP(TIUNMSPC,0)),U,1)
. D ^%DTC
. ;Kill off entry if 2 days past its expiration date
. I +X>1 K ^XTMP(TIUNMSPC)
Q
;
DELPST(NOTE) ;Delete pastes associated with a deleted note
N DA,DIK
S DIK="^TIUP(8928,"
S DA=""
F S DA=$O(^TIUP(8928,"AD",8925,NOTE,DA)) Q:DA="" D
. D ^DIK
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUCOP 12029 printed Dec 13, 2024@02:39:19 Page 2
TIUCOP ;SLC/TDP - Copy/Paste API(s) and RPC(s) ;Jul 29, 2020@10:13:01
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**290,336**;Jun 20, 1997;Build 4
+2 ;
+3 ; External Reference
+4 ; DBIA 2051 $$FIND1^DIC
+5 ; DBIA 1544 $$ISA^USRLM
+6 ;
+7 QUIT
WORDS(INST) ;Return the number of words required to begin tracking
+1 ; copied text as part of the Copy/Paste functionality.
+2 ;
+3 ; Call using $$WORDS^TIUCOP(INSTITUTION IEN)
+4 ;
+5 ; Input
+6 ; INST - institution ien
+7 ;
+8 ; Ouput
+9 ; - Number of Words required (example "5")^Max text length
+10 ; Or
+11 ; Error condition "-1^Error Msg"
+12 ;
+13 NEW IEN,WRDS,MAXLNG
+14 IF $GET(INST)=""
SET INST=$GET(DUZ(2))
+15 IF +INST<1
QUIT "-1^Invalid institution"
+16 SET INST=$$FIND1^DIC(4,"","","`"_INST,"","","ERR")
+17 IF +INST<1
QUIT "-1^Invalid institution"
+18 SET IEN=$ORDER(^TIU(8925.99,"B",INST,0))
+19 IF +IEN=0
QUIT "-1^Institution not defined in TIU PARAMETERS file"
+20 SET WRDS=+$PIECE($GET(^TIU(8925.99,IEN,4)),U,1)
+21 ;Send error message if required words not set in parameter
IF WRDS=0
SET WRDS=5
DO ERMSG^TIUCOPUT("WORD")
+22 QUIT WRDS
+23 ;
MAXLNG() ;Return the Maximum length string we will recalculate percentage
+1 NEW MAX
+2 SET MAX=$$GET^XPAR("ALL","ORQQTIU COPY/PASTE FIND LIMIT",,"Q")
+3 IF MAX=""
SET MAX=10000
+4 QUIT MAX
+5 ;
PCT(INST) ;Return the Copy/Paste verification percentage
+1 ; Call using $$PCT^TIUCOP(INSTITUTION IEN)
+2 ;
+3 ; Input
+4 ; INST - institution ien
+5 ;
+6 ; Output
+7 ; - Percent pasted text matches copied text needed to be considered
+8 ; as derived from the copied text (example ".5")
+9 ; Or
+10 ; Error condition "-1^Error Msg"
+11 ;
+12 NEW IEN,PCT
+13 IF $GET(INST)=""
SET INST=$GET(DUZ(2))
+14 IF +INST<1
QUIT "-1^Invalid institution"
+15 SET INST=$$FIND1^DIC(4,"","","`"_INST,"","","ERR")
+16 IF +INST<1
QUIT "-1^Invalid institution"
+17 SET IEN=$ORDER(^TIU(8925.99,"B",INST,0))
+18 IF +IEN=0
QUIT "-1^Institution not defined in TIU PARAMETERS file"
+19 SET PCT=+$PIECE($GET(^TIU(8925.99,IEN,4)),U,2)
+20 ;Send error message if required percentage is not set in parameter
IF PCT=0
SET PCT=90
DO ERMSG^TIUCOPUT("PCT")
+21 QUIT PCT/100
+22 ;
DAYS(INST) ;Return the number of days to save copied text information
+1 ; Call using $$DAYS^TIUCOP(INSTITUTION IEN)
+2 ;
+3 ; Input
+4 ; INST - institution ien
+5 ;
+6 ; Output
+7 ; - Days to save copied text (example "7")
+8 ; Or
+9 ; Error condition "-1^Error Msg"
+10 ;
+11 NEW IEN,DAYS
+12 IF $GET(INST)=""
SET INST=$GET(DUZ(2))
+13 IF +INST<1
QUIT "-1^Invalid institution"
+14 SET INST=$$FIND1^DIC(4,"","","`"_INST,"","","ERR")
+15 IF +INST<1
QUIT "-1^Invalid institution"
+16 SET IEN=$ORDER(^TIU(8925.99,"B",INST,0))
+17 IF +IEN=0
QUIT "-1^Institution not defined in TIU PARAMETERS file"
+18 SET DAYS=+$PIECE($GET(^TIU(8925.99,IEN,4)),U,3)
+19 ;Send error message if required percentage is not set in parameter
IF DAYS=0
SET DAYS=1
DO ERMSG^TIUCOPUT("DAY")
+20 QUIT DAYS
+21 ;
EXC(TIUDA) ;Return whether or not note is excluded from copy/paste tracking
+1 ; Call using $$EXC^TIUCOP(TIU IEN)
+2 ;
+3 ; Input
+4 ; TIUDA - TIU ien (#8925)
+5 ;
+6 ; Output
+7 ; - Boolean (1: Exclude, 0:Don't Exclude)
+8 ; Or
+9 ; Error condition "-1^Error Msg"
+10 ;
+11 NEW CLDOC,IEN,EX,ND0,TMP,X
+12 SET EX=0
+13 IF $GET(TIUDA)=""
QUIT "-1^TIU IEN required"
+14 IF +TIUDA<1
QUIT "-1^Invalid TIU IEN"
+15 IF '$GET(^TIU(8925,TIUDA,0))
QUIT "-1^Invalid TIU IEN"
+16 SET IEN=+$PIECE($GET(^TIU(8925,TIUDA,0)),U,1)
+17 ;Missing TIU Document Type
IF '$DATA(^TIU(8925.1,IEN,0))
QUIT EX
+18 SET ND0=$GET(^TIU(8925.1,IEN,0))
+19 IF ND0=""
QUIT EX
+20 SET CLDOC=$ORDER(^TIU(8925.1,"B","CLINICAL DOCUMENTS",""))
+21 DO ANCESTOR^TIUFLF4(IEN,ND0,.TMP,0)
+22 SET X=""
+23 FOR
SET X=$ORDER(TMP(X))
if X=""
QUIT
if IEN=CLDOC
QUIT
Begin DoDot:1
+24 SET IEN=+$GET(TMP(X))
+25 IF IEN=CLDOC
QUIT
+26 SET IEN=$ORDER(^TIU(8925.95,"B",IEN,0))
+27 ;"-1^Missing TIU Document Type"
IF +IEN<1
QUIT
+28 SET EX=+$PIECE($GET(^TIU(8925.95,IEN,10)),U,1)
+29 IF EX'=""
SET IEN=CLDOC
End DoDot:1
if EX=1
QUIT
+30 QUIT EX
+31 ;
EXCLST(TIULST) ;Returns a list of all copy/paste excluded note titles
+1 NEW CNT,DOCTTL,DOCCLS,DOCIEN,DOCNM,TIUND0
+2 SET (CNT,DOCCLS)=0
+3 FOR
SET DOCCLS=$ORDER(^TIU(8925.95,"AC",DOCCLS))
if DOCCLS=""
QUIT
Begin DoDot:1
+4 SET TIUND0=$GET(^TIU(8925.1,DOCCLS,0))
+5 ;Track list of documents to return
+6 IF $PIECE(TIUND0,U,4)="DOC"
Begin DoDot:2
+7 SET CNT=CNT+1
+8 SET TIULST(CNT)=DOCCLS_U_$PIECE(TIUND0,U,1)
+9 SET TIULST("B",DOCCLS)=""
End DoDot:2
+10 ;Track list of non-documents to review further
+11 SET DOCTTL=0
+12 FOR
SET DOCTTL=$ORDER(^TIU(8925.1,"ACL",DOCCLS,DOCTTL))
if DOCTTL=""
QUIT
Begin DoDot:2
+13 SET DOCIEN=0
+14 FOR
SET DOCIEN=$ORDER(^TIU(8925.1,"ACL",DOCCLS,DOCTTL,DOCIEN))
if DOCIEN=""
QUIT
Begin DoDot:3
+15 SET DOCNM=$PIECE($GET(^TIU(8925.1,DOCIEN,0)),U,1)
+16 IF '$DATA(TIULST("B",DOCIEN))
SET CNT=CNT+1
SET TIULST(CNT)=DOCIEN_U_DOCNM
SET TIULST("B",DOCIEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+17 IF CNT=0
SET TIULST(1)=""
+18 KILL TIULST("B")
+19 QUIT
+20 ;
VIEW(USER,IEN,INST) ;Is user allowed to view copy/paste
+1 ; Call using $$VIEW^TIUCOP(USER DUZ,TIU (NOTE) IEN,INSTITUTION)
+2 ; RSLT=
+3 ; 0 - User is not allowed to view copy/paste information
+4 ; 1 - User is AUTHOR and note is UNSIGNED, or user is COSIGNER who has yet to
+5 ; SIGN the note.
+6 ; 2 - User has a user class of "CHIEF, MIS", or "CHIEF, HIMS",
+7 ; or "PRIVACY ACT OFFICER", or one of the user classes designated
+8 ; at the site.
+9 NEW AUTH,AUTHSGN,CHIM,CMIS,COSGNSGN,COSIGN,FIN,HIM,INSTIEN,PAO,TIU12,TIU15
+10 NEW USRCLS,X
+11 SET FIN=""
+12 ;Not a valid user, so not allowed to view
IF +USER=0
QUIT 0
+13 SET INST=$GET(DUZ(2))
+14 ;Institution is required
IF +INST=0
QUIT 0
+15 SET CMIS="CHIEF, MIS"
+16 SET CHIM="CHIEF, HIMS"
+17 SET PAO="PRIVACY ACT OFFICER"
+18 FOR USRCLS=CHIM,CMIS,PAO
Begin DoDot:1
+19 SET FIN=$$ISA^USRLM(+USER,USRCLS)
End DoDot:1
if FIN
QUIT
+20 ;User belongs to special user class
IF FIN
QUIT 2
+21 SET INSTIEN=$ORDER(^TIU(8925.99,"B",INST,""))
+22 IF INSTIEN>0
SET X=0
FOR
SET X=$ORDER(^TIU(8925.99,INSTIEN,5,X))
if +X=0
QUIT
Begin DoDot:1
+23 SET USRCLS=$PIECE(^TIU(8925.99,INSTIEN,5,X,0),U,1)
+24 SET FIN=$$ISA^USRLM(+USER,USRCLS)
End DoDot:1
if FIN
QUIT
+25 ;User belongs to special user class
IF FIN
QUIT 2
+26 ;No ien. User does not belong to special user class and no further checks.
IF +$GET(IEN)=0
QUIT 0
+27 SET TIU12=$GET(^TIU(8925,+IEN,12))
+28 SET TIU15=$GET(^TIU(8925,+IEN,15))
+29 SET AUTH=+$PIECE(TIU12,U,2)
+30 SET AUTHSGN=+$PIECE(TIU15,U,2)
+31 ;I AUTH=USER,AUTH'=AUTHSGN Q 1 ;User is author and has not signed note.
+32 ;User is author and has not signed note.
IF AUTH=USER
IF AUTHSGN=0
QUIT 1
+33 SET COSIGN=+$PIECE(TIU12,U,8)
+34 ;No cosigner, so user not authorized.
IF 'COSIGN
QUIT 0
+35 SET COSGNSGN=+$PIECE(TIU15,U,8)
+36 ;User is cosigner and unsigned, author has signed.
IF COSIGN=USER
IF COSIGN'=COSGNSGN
QUIT 1
+37 ;User not authorized
QUIT 0
+38 ;
PUTCOPY(INST,ARY,ERR) ;Save to copy buffer
+1 NEW SAVE
+2 SET INST=$GET(DUZ(2))
+3 SET SAVE=$$PUTCOPY^TIUCOPC(INST,.ARY,.ERR)
+4 QUIT SAVE
+5 ;
GETCOPY(INST,DFN,ARY,STRT) ;Retrieve copy buffer
+1 IF $GET(STRT)=""
SET STRT=""
+2 SET INST=$GET(DUZ(2))
+3 DO GETCOPY^TIUCOPC(INST,DFN,.ARY,STRT,1)
+4 QUIT
+5 ;
GETCOPY1 ;Retrieve copy buffer in background
+1 ;DFN,DIV,HWND,IP,NODE are saved variables as part of queued process
+2 ;ZTQUEUED,ZTREQ are variables that exist as part of a queued process
+3 ;DILOCKTM is a global variable
+4 NEW ARY,STRT
+5 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 ; client no longer polling
IF $GET(^XTMP(NODE,"STOP"))
KILL ^XTMP(NODE)
QUIT
+7 ; XTMP node has been purged
IF '$DATA(^XTMP(NODE,0))
QUIT
+8 LOCK +^XTMP(NODE):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)
+9 SET ^XTMP(NODE,"DFN")=DFN
+10 SET (ARY,STRT)=""
+11 DO GETCOPY^TIUCOPC(DIV,DFN,.ARY,STRT,0)
+12 IF $GET(^XTMP(NODE,"STOP"))
QUIT
+13 IF +ARY(0,0)>0
Begin DoDot:1
+14 NEW CNT,ND,ND1,X
+15 SET CNT=0
+16 SET ND=""
FOR
SET ND=$ORDER(ARY(ND))
if ND=""
QUIT
Begin DoDot:2
+17 SET ND1=""
FOR
SET ND1=$ORDER(ARY(ND,ND1))
if ND1=""
QUIT
Begin DoDot:3
+18 IF ND=0
IF ND1=0
QUIT
+19 SET X="("_ND_","_ND1_")="
+20 SET CNT=CNT+1
+21 SET ^XTMP(NODE,"COPY",CNT)=X_$GET(ARY(ND,ND1))
+22 KILL ARY(ND,ND1)
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;... I (CNT#100)=0 H 10
+24 IF +$GET(ARY(0,0))=-1
SET ^XTMP(NODE,"COPY",-1)=$PIECE($GET(ARY),U,2)
KILL ARY(0,0)
+25 SET ^XTMP(NODE,"DONE")=1
+26 IF $GET(^XTMP(NODE,"STOP"))
KILL ^XTMP(NODE)
+27 LOCK -^XTMP(NODE)
+28 QUIT
CHKPASTE(INST,DOC) ;Check note document for pasted text data
+1 SET INST=$GET(DUZ(2))
+2 QUIT $$CHKPASTE^TIUCOPP(DOC,INST)
+3 ;
PUTPASTE(RSLT,INST,ARY,ERR) ;Save pasted text SVARY
+1 NEW CNTR,DIV,PIEN,RSLT1,SAVE,SVARY
+2 SET INST=$GET(DUZ(2))
+3 SET SAVE=""
+4 SET SVARY=1
+5 SET SAVE=$$PUTPASTE^TIUCOPP(INST,.ARY,.ERR,.SVARY)
+6 IF +$GET(SVARY(0))>0
SET CNTR=0
FOR
SET CNTR=$ORDER(SVARY(CNTR))
if CNTR=""
QUIT
Begin DoDot:1
+7 SET DIV=+$GET(SVARY(CNTR))
if DIV=0
QUIT
+8 SET PIEN=$PIECE($GET(SVARY(CNTR)),U,2)
+9 DO GETPST^TIUCOP1(PIEN,DIV,.RSLT1,1)
End DoDot:1
+10 IF +$GET(RSLT1(0,0))=-1
SET RSLT(-1)=$PIECE($GET(RSLT1),U,2)
SET RSLT("0,0")=-1
KILL RSLT1(0,0)
QUIT 0
+11 IF +$GET(RSLT1(0,0))>0
Begin DoDot:1
+12 NEW CNT,ND,ND1
+13 SET CNT=0
+14 SET ND=0
FOR
SET ND=$ORDER(RSLT1(ND))
if ND=""
QUIT
Begin DoDot:2
+15 SET CNT=CNT+1
+16 SET RSLT(CNT)=CNT_"="_$GET(RSLT1(ND,0))
+17 KILL RSLT1(ND)
End DoDot:2
End DoDot:1
+18 QUIT SAVE
+19 ;
GETPASTE(TIUIEN,INST,APP,ARY) ;Retrieve pasted text
+1 SET INST=$GET(DUZ(2))
+2 DO GETPASTE^TIUCOPP(TIUIEN,INST,APP,.ARY,0)
+3 QUIT
+4 ;
START(VAL,DFN,IP,HWND,DIV) ;Start copy buffer build in background
+1 ;,ORHTIME
NEW DT,NODE,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+2 SET DIV=$GET(DUZ(2))
+3 SET VAL=0
+4 SET DT=$$DT^XLFDT
+5 SET NODE="TIUCOP "_IP_"-"_HWND_"-"_DFN
+6 SET ZTIO=""
SET ZTRTN="GETCOPY1^TIUCOP"
SET ZTDTH=$HOROLOG
+7 SET (ZTSAVE("DFN"),ZTSAVE("IP"),ZTSAVE("HWND"),ZTSAVE("DIV"),ZTSAVE("NODE"))=""
+8 SET ZTDESC="CPRS GUI Background Data Retrieval"
+9 KILL ^XTMP(NODE)
+10 SET ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT
+11 DO ^%ZTLOAD
IF '$DATA(ZTSK)
Begin DoDot:1
+12 KILL ^XTMP(NODE,0)
+13 SET VAL=0
End DoDot:1
QUIT
+14 SET $PIECE(^XTMP(NODE,0),U,3)="Background CPRS "_ZTSK
+15 SET VAL=1
+16 ; Start capacity planning timing clock - will be stopped in POLL code
+17 ;I +$G(^KMPTMP("KMPD-CPRS")) S ^KMPTMP("KMPDT","ORWCV",NODE)=$G(ORHTIME)_"^^"_$G(DUZ)_"^"_$G(IO("CLNM"))
+18 QUIT
+19 ;
POLL(LST,DFN,IP,HWND) ; poll for completed cover sheet parts
+1 NEW I,ILST,ID,LAST,LSTDATA,NODE,DONE,STOP,OLDI,QT
+2 SET NODE="TIUCOP "_IP_"-"_HWND_"-"_DFN
SET ILST=1
SET DONE=0
+3 IF '$DATA(^XTMP(NODE,"DFN"))
SET LST(1)="~DONE=1"
QUIT
+4 IF ^XTMP(NODE,"DFN")'=DFN
SET LST(1)="~DONE=1"
QUIT
+5 SET LST(1)="~DONE=0"
+6 IF $GET(^XTMP(NODE,"DONE"))
SET ILST=1
SET LST(1)="~DONE=1"
SET DONE=1
+7 SET LAST=$ORDER(^XTMP(NODE,"COPY",""),-1)
+8 ;I LAST="" S LST(1)="~NO DATA YET" Q
+9 SET STOP=99999999999
+10 IF $GET(LAST)'=""
Begin DoDot:1
+11 ;S STOP=($P($P($G(^XTMP(NODE,"COPY",LAST)),",",1),"(",2)-1)
+12 SET STOP=$PIECE($PIECE($GET(^XTMP(NODE,"COPY",LAST)),",",1),"(",2)
+13 IF STOP<1
SET STOP=0
End DoDot:1
+14 SET (OLDI,QT)=0
+15 SET I=0
FOR
SET I=$ORDER(^XTMP(NODE,"COPY",I))
if 'I
QUIT
Begin DoDot:1
+16 IF $GET(^XTMP(NODE,"STOP"))=1
SET (DONE,QT)=1
SET LST(1)="~DONE=1"
+17 IF $PIECE($PIECE($GET(^XTMP(NODE,"COPY",I)),",",1),"(",2)>STOP
SET QT=1
QUIT
+18 ;I ILST=1999!ILST-1=LAST S OLDI=($P($P($G(^XTMP(NODE,"COPY",I)),",",1),"(",2)-1)
+19 ;I ((ILST>1999)!(LAST'<ILST)),OLDI'=($P($P($G(^XTMP(NODE,"COPY",I)),",",1),"(",2)-1) S QT=1 Q
+20 SET ILST=ILST+1
SET LST(ILST)=^(I)
+21 IF ILST=2000
SET QT=1
+22 KILL ^XTMP(NODE,"COPY",I)
End DoDot:1
if QT=1
QUIT
+23 IF 'DONE
IF $GET(^XTMP(NODE,"STOP"))=1
SET DONE=1
SET LST(1)="~DONE=1"
+24 ; Stop capacity planning timing clock - was started in START code
+25 ;I +$G(^KMPTMP("KMPD-CPRS")) S $P(^KMPTMP("KMPDT","ORWCV",NODE),"^",2)=$H
IF DONE
KILL ^XTMP(NODE)
QUIT
+26 IF $GET(LST(1))=""
SET LST(1)="~NO DATA YET"
+27 QUIT
+28 ;
STOP(OK,DFN,IP,HWND) ; stop cover sheet data retrieval
+1 ;DILOCKTM is a global variable
+2 NEW NODE
+3 SET NODE="TIUCOP "_IP_"-"_HWND_"-"_DFN
+4 SET ^XTMP(NODE,"STOP")=1
SET OK=1
+5 LOCK +^XTMP(NODE):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)
+6 IF $GET(^XTMP(NODE,"DONE"))
KILL ^XTMP(NODE)
+7 LOCK -^XTMP(NODE)
+8 QUIT
+9 ;
CLEAN(TASK) ;Start CLEANUP background process
+1 NEW DT,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+2 SET TASK=0
+3 SET DT=$$DT^XLFDT
+4 SET ZTIO=""
SET ZTRTN="CLEANUP^TIUCOP"
SET ZTDTH=$HOROLOG
+5 SET ZTDESC="TIU Copy/Paste Background ^XTMP global clean-up"
+6 DO ^%ZTLOAD
IF '$DATA(ZTSK)
QUIT Y
+7 SET TASK=ZTSK
+8 QUIT
+9 ;
CLEANUP ; clean up ^XTMP nodes
+1 NEW %Y,DT,KILLDATE,NODE,TIUNMSPC,X,X1,X2
+2 ;Get current date
SET DT=$$DT^XLFDT
+3 ;Loop through Copy Buffer polling (retrieval) nodes
+4 SET NODE="TIUCOP"
+5 FOR
SET NODE=$ORDER(^XTMP(NODE))
if $EXTRACT(NODE,1,6)'="TIUCOP"
QUIT
Begin DoDot:1
+6 SET (%Y,KILLDATE,X,X1,X2)=""
+7 SET X1=DT
+8 SET X2=$PIECE($GET(^XTMP(NODE,0)),U,1)
+9 DO ^%DTC
+10 IF +X>1
KILL ^XTMP(NODE)
End DoDot:1
+11 ;. W !,X K ^XTMP(NODE)
+12 ;Loop through Copy Buffer save nodes
+13 SET TIUNMSPC="TIU COPY/PASTE:"
+14 FOR
SET TIUNMSPC=$ORDER(^XTMP(TIUNMSPC))
if TIUNMSPC=""!(TIUNMSPC'["TIU COPY/PASTE
QUIT
Begin DoDot:1
+15 SET (%Y,KILLDATE,X,X1,X2)=""
+16 SET X1=DT
+17 SET X2=$PIECE($GET(^XTMP(TIUNMSPC,0)),U,1)
+18 DO ^%DTC
+19 ;Kill off entry if 2 days past its expiration date
+20 IF +X>1
KILL ^XTMP(TIUNMSPC)
End DoDot:1
+21 QUIT
+22 ;
DELPST(NOTE) ;Delete pastes associated with a deleted note
+1 NEW DA,DIK
+2 SET DIK="^TIUP(8928,"
+3 SET DA=""
+4 FOR
SET DA=$ORDER(^TIUP(8928,"AD",8925,NOTE,DA))
if DA=""
QUIT
Begin DoDot:1
+5 DO ^DIK
End DoDot:1
+6 QUIT
+7 ;
