TIUPRF2 ;SLC/JMH - RPCs for Patient Record Flags ;May 6, 2024@12:20
;;1.0;TEXT INTEGRATION UTILITIES;**184,318**;Jun 20, 1997;Build 120
;
;
; Reference to NS^XUAF4 in ICR #2171
; Reference to GETACT^DGPFAPI in ICR #3860
; Reference to GETHTIU^DGPFAPI1 in ICR #4383
; Reference to STOTIU^DGPFAPI2 in ICR #4384
; Reference to SITE^VASITE in ICR #10112
;
GETTITLE(TIUY,PTDFN,FLAGID) ; RPC TIU GET PRF TITLE
; RPC Gets Note Title associated with FLAGID for PTDFN
; INPUT PARAMETERS
; PTDFN - required - pointer to file 2
; FLAGID - required - identifier for particular flag assignment
; Set as subscript in GETACT^DGPFAPI
; See GETFLG^ORPRF
; RETURN PARAMETER
; .TIUY = passed by ref, TitleIEN^Title
; 0 if no title is associated or flag assignment is not active
;
N PRFARR K TIUY S TIUY=0
Q:'$G(PTDFN) Q:'$G(FLAGID)
S TIUY=$$GETACT^DGPFAPI(PTDFN,"PRFARR") ;Get Active flag info
Q:'TIUY
S TIUY=$G(PRFARR(FLAGID,"TIUTITLE"))
I TIUY'>0 S TIUY=0
Q
;
GETNOTES(TIUY,PTDFN,TIUTTL,REVERSE) ; RPC TIU GET LINKED PRF NOTES
; RPC gets SIGNED, LINKED PRF
; INPUT PARAMETERS
; PTDFN - required - pointer to file 2
; TIUTTL - required - IEN of TIU DOCUMENT DEFINITION (#8925.1) file
; REVERSE - optional - Boolean, 0/1
; 0 - default - sort return chronologically
; 1 - sort return inverse chronological
; RETURN PARAMETER
; .TIUY - passed by reference, TIUY=total # of notes
; TIUY(TIUIDATE)=TIUIEN_U_TIUACT_U_TIUEDATE_U_TIUAUTH
; TIUIDATE - FM date of note, or inverse FM date
; TIUIEN - pointer to file 8925
; TIUACT - name of action
; TIUEDATE - external date of note
; TIUAUTH - name of author of note
;
; Excludes Notes with Entered in Error (EIE) action
; Also excludes all notes chronologically prior to EIE action
; Only includes notes complete or amended or not cosigned
;
N X,ACTID,ARRAYNM,DTARRAY,HASERR
K TIUY ; purge return array
S (TIUY,ACTID)=0
S ARRAYNM=$NA(^TMP("TIUPRFH",$J)) D KILL
;
; Get PRF Assgn Hist info
S X=$$GETHTIU^DGPFAPI1(PTDFN,TIUTTL,ARRAYNM)
I 'X G KILL
;
; Filter DGPF History records Entered in Error
; HASERR = history ID with EIE status
; all history records with date<EIE are also invalid
S HASERR=$$HASERR^TIUPRFL(ARRAYNM)
;
F S ACTID=$O(@ARRAYNM@("HISTORY",ACTID)) Q:'ACTID D
. N X,ARRTMP,DIERR,FLDS,IENS,STATUS
. N TIUACT,TIUAUTH,TIUERR,TIUFLDS,TIUEDATE,TIUIDATE,TIUIEN
. S ARRTMP=$NA(@ARRAYNM@("HISTORY",ACTID))
. I ACTID=+HASERR Q
. I HASERR>0 Q:$$ISERR(ARRAYNM,ACTID,$P(HASERR,U,2))
. ;
. ; ARRAYNM node value may be just ^
. ; STATUS - only include complete or amended or not cosigned notes
. S TIUIEN=+(@ARRTMP@("TIUIEN"))
. Q:TIUIEN'>0 Q:'$D(^TIU(8925,TIUIEN))
. D GETS^DIQ(8925,TIUIEN_",",".05;1202;1301","IE","TIUFLDS","TIUERR")
. M FLDS=TIUFLDS(8925,TIUIEN_",")
. S TIUIDATE=FLDS(1301,"I")
. S TIUEDATE=$E(FLDS(1301,"E"),1,18)
. S TIUAUTH=FLDS(1202,"E")
. S STATUS=FLDS(.05,"I")
. I '((STATUS=6)!(STATUS=7)!(STATUS=8)) Q
. S TIUACT=$P(@ARRTMP@("ACTION"),U,2)
. ; -- Increment date if there are multiple notes w/ same exact date:
. S X=0 F D Q:X
. . I $D(DTARRAY(TIUIDATE)) S TIUIDATE=TIUIDATE+.0000001
. . I '$D(DTARRAY(TIUIDATE)) S DTARRAY(TIUIDATE)="",X=1
. . Q
. I $G(REVERSE) S TIUIDATE=9999999-TIUIDATE
. I TIUEDATE="" S TIUEDATE="No Ref Date"
. I TIUAUTH="" S TIUAUTH="No Author"
. S TIUY=TIUY+1
. S TIUY(TIUIDATE)=TIUIEN_U_TIUACT_U_TIUEDATE_U_TIUAUTH
. Q
G KILL
;
GETACTS(TIUY,TIUTTL,DFN) ; RPC TIU GET PRF ACTIONS
; RPC Gets PRF Action info
; Action in PRF is the reason a History (#26.14) record was created
; Input:
; DFN - [Required] IEN of PATIENT (#2) file
; TIUTTL - [Required] IEN of TIU DOCUMENT DEFINITION (#8925.1) file
; RETURN ARRAY
; .TIUY - passed by reference
; see description of return array from GETHTIU^DGPFAPI1
; reformat data for TIU RPC return
; dg*951 brought in p8
; TIUY(ACTID) = p1^p2^p3^p4^p5^p6^p7^p8 where
; p1 = flag name p5 = action date, FM internal
; p2 = assignment ien [.001/#26.13] p6 = action date, external
; p3 = action name [.03/#26.14] p7 = file 8925 ien
; p4 = action ien p8 = originate facility name
;
; Returns linkable action for Patient DFN and flag assoc w/ TIUTTL
; Action may be currently linked or not
; Excludes UNLINKABLE actions
; Entered in Error actions (EIE)
; Actions taken prior to that EIE action
; Prior to DG*5.3*951, return array used ACTID from GETHTIU^DGPFAPI1
; DG*5.3*951 sort array by Originating Facility, always lists the
; History records created by the local facility first.
;
N X,ACTID,ARRAYNM,DG951,FLAG,TIUFLG,UNLINKBL
;
S ARRAYNM=$NA(^TMP("TIUPRFH",$J)) D KILL
S TIUY=1
S X=$$GETHTIU^DGPFAPI1(DFN,TIUTTL,ARRAYNM)
I 'X S TIUY="0^"_$P(X,U,2) G KILL
;
; -- If no unlinked, linkable actions exist, say so but go on:
I '$$AVAILACT^TIUPRFL(ARRAYNM,,.UNLINKBL) D
. S TIUY="0^All linkable Flag actions are already linked"
. Q
;
; -- Return ALL linkable actions (linked or not)
; Pre DG*3.5*951
S TIUFLG=$$GETP("FLAG",2)_U_$$GETP("ASSIGNIEN",1)
S ACTID=0,DG951=$$PATCH^XPDUTL("DG*5.3*951")
F S ACTID=$O(@ARRAYNM@("HISTORY",ACTID)) Q:'+ACTID D
. Q:$G(UNLINKBL(ACTID))
. S TIUY(ACTID)=TIUFLG
. S $P(TIUY(ACTID),U,3)=$$GETPA("ACTION",2)
. S $P(TIUY(ACTID),U,4)=$$GETPA("HISTIEN",1)
. S $P(TIUY(ACTID),U,5)=$$GETPA("DATETIME",1)
. S $P(TIUY(ACTID),U,6)=$$GETPA("DATETIME",2)
. S $P(TIUY(ACTID),U,7)=$$GETPA("TIUIEN",1)
. Q
;
; If patch DG*5.3*951, resort return array
I DG951 D
. N I,X,Y,APPRVBY,HERE,LOC,NAME,ST3
. S HERE=$$HERE
. S ACTID=0 F S ACTID=$O(TIUY(ACTID)) Q:'ACTID D
. . S APPRVBY=$$GETPA("APPRVBY",1)
. . S Y=$$GETPA("ORIGFAC",1)
. . S X=$$STN(Y,APPRVBY)
. . S LOC=$P(X,U)
. . S ST3=$P(X,U,3)
. . S NAME=$P(X,U,5)
. . S $P(TIUY(ACTID),U,8)=NAME
. . S ^TMP($J,LOC,ST3,NAME,ACTID)=TIUY(ACTID)
. . Q
. S Y=TIUY K TIUY S TIUY=Y
. S I=0,X=$NA(^TMP($J))
. F S X=$Q(@X) Q:X="" Q:$QS(X,1)'=$J S I=I+1,TIUY(I)=@X
. Q
;
G KILL
;
LINK(TIUY,TIUIEN,ASSGNDA,ACTIEN,DFN) ;RPC Link TIU Doc TIUIEN to
; the PRF action
N TIUTTL
S TIUTTL=+$G(^TIU(8925,TIUIEN,0))
I 'TIUTTL S TIUY="0^Document does not exist" Q
; Remove any links before making new link
D UNLINK^TIUPRF1(TIUIEN)
S TIUY=$$STOTIU^DGPFAPI2(DFN,ASSGNDA,ACTIEN,TIUIEN)
Q
GETSTAT(TIUY,TIUIEN) ;RPC Gets the status of TIU Doc TIUIEN
;Returns STATIEN^STATNAME
N TIUTTL
S TIUTTL=+$G(^TIU(8925,TIUIEN,0))
I 'TIUTTL S TIUY="0^Document does not exist" Q
S TIUY=$P(^TIU(8925,TIUIEN,0),U,5)
S TIUY=TIUY_U_$P($G(^TIU(8925.6,TIUY,0)),U,1)
Q
;
ISPRFTTL(TIUY,TIUDA) ;RPC Takes as input 8925.1 IEN
; and checks if it is a PRF title
; Cf ISPFTTL^TIUPRFL. which is a FUNCTION
N TIUCAT1,TIUCAT2,TIUD1
S TIUY=0,TIUD1=""
S TIUCAT1=+$$DDEFIEN^TIUFLF7("PATIENT RECORD FLAG CAT I","DC")
S TIUCAT2=+$$DDEFIEN^TIUFLF7("PATIENT RECORD FLAG CAT II","DC")
S TIUD1=$O(^TIU(8925.1,"AD",TIUDA,TIUD1))
I TIUD1=TIUCAT1!(TIUD1=TIUCAT2) S TIUY=1
Q
;
;----------------------- PRIVATE SUBROUTINES ------------------------
GETP(NODE,P) S:'$G(P) P=1 Q $P($G(@ARRAYNM@(NODE)),U,P)
GETPA(NODE,P) S:'$G(P) P=1 Q $P($G(@ARRAYNM@("HISTORY",ACTID,NODE)),U,P)
;
HERE() ; get facility
; RETURN file_4_ien ^name ^full_site# ^3-digit_site#
N X S X=$$SITE^VASITE
Q X_U_$E($P(X,U,3),1,3)
;
ISERR(TDAT,ACTID,HASERR) ; is history record prior to EIE status?
Q $$ISERR^TIUPRFL(TDAT,ACTID,HASERR)
;
KILL K @ARRAYNM,^TMP($J) Q
;
STN(INST,APPRVBY) ; get station information
; INPUT PARAMETERS:
; INST - optional - ien to file 4
;APPRVBY - optional - pointer to the NEW PERSON file (#200)
; value from the APPROVED BY field in file 26.14
; if APPRVBY=.5 then this History record was
; created at another facility.
; EXTRINSIC FUNCTION returns p1^p2^p3^p4^p5 where
; p1 = L:local; R:remote p4 = institution-name
; p2 = file_4_ien p5 = station#_" "_institution-name
; p3 = 3-digit station# or UNK
;
N X,FILE4,STNAME,STNUM,STNUM3
I '$G(HERE) N HERE S HERE=$$HERE
S INST=$G(INST),APPRVBY=$G(APPRVBY)
S (FILE4,STNAME,STNUM,STNUM3)=""
; have file_4 pointer (originating facility)
I INST>0 D
. S FILE4=INST,X=$$NS^XUAF4(INST)
. S STNAME=$P(X,U),STNUM=$P(X,U,2),STNUM3=$E(STNUM,1,3)
. Q
; do not have file_4 pointer
I INST<1 D
. I APPRVBY>.9 D
. . S FILE4=+HERE,STNAME=$P(HERE,U,2)
. . S STNUM=$P(HERE,U,3),STNUM3=$P(HERE,U,4)
. . Q
. E S FILE4="",STNAME="UNKNOWN",(STNUM,STNUM3)="UNK"
. Q
;
S X=$S(STNUM3=$P(HERE,U,4):"L",1:"R")
S X=X_U_FILE4_U_STNUM3_U_STNAME_U_STNAME
I STNUM3'="UNK" S $P(X,U,5)=STNUM_" "_STNAME
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPRF2 9079 printed Oct 16, 2024@18:44:17 Page 2
TIUPRF2 ;SLC/JMH - RPCs for Patient Record Flags ;May 6, 2024@12:20
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**184,318**;Jun 20, 1997;Build 120
+2 ;
+3 ;
+4 ; Reference to NS^XUAF4 in ICR #2171
+5 ; Reference to GETACT^DGPFAPI in ICR #3860
+6 ; Reference to GETHTIU^DGPFAPI1 in ICR #4383
+7 ; Reference to STOTIU^DGPFAPI2 in ICR #4384
+8 ; Reference to SITE^VASITE in ICR #10112
+9 ;
GETTITLE(TIUY,PTDFN,FLAGID) ; RPC TIU GET PRF TITLE
+1 ; RPC Gets Note Title associated with FLAGID for PTDFN
+2 ; INPUT PARAMETERS
+3 ; PTDFN - required - pointer to file 2
+4 ; FLAGID - required - identifier for particular flag assignment
+5 ; Set as subscript in GETACT^DGPFAPI
+6 ; See GETFLG^ORPRF
+7 ; RETURN PARAMETER
+8 ; .TIUY = passed by ref, TitleIEN^Title
+9 ; 0 if no title is associated or flag assignment is not active
+10 ;
+11 NEW PRFARR
KILL TIUY
SET TIUY=0
+12 if '$GET(PTDFN)
QUIT
if '$GET(FLAGID)
QUIT
+13 ;Get Active flag info
SET TIUY=$$GETACT^DGPFAPI(PTDFN,"PRFARR")
+14 if 'TIUY
QUIT
+15 SET TIUY=$GET(PRFARR(FLAGID,"TIUTITLE"))
+16 IF TIUY'>0
SET TIUY=0
+17 QUIT
+18 ;
GETNOTES(TIUY,PTDFN,TIUTTL,REVERSE) ; RPC TIU GET LINKED PRF NOTES
+1 ; RPC gets SIGNED, LINKED PRF
+2 ; INPUT PARAMETERS
+3 ; PTDFN - required - pointer to file 2
+4 ; TIUTTL - required - IEN of TIU DOCUMENT DEFINITION (#8925.1) file
+5 ; REVERSE - optional - Boolean, 0/1
+6 ; 0 - default - sort return chronologically
+7 ; 1 - sort return inverse chronological
+8 ; RETURN PARAMETER
+9 ; .TIUY - passed by reference, TIUY=total # of notes
+10 ; TIUY(TIUIDATE)=TIUIEN_U_TIUACT_U_TIUEDATE_U_TIUAUTH
+11 ; TIUIDATE - FM date of note, or inverse FM date
+12 ; TIUIEN - pointer to file 8925
+13 ; TIUACT - name of action
+14 ; TIUEDATE - external date of note
+15 ; TIUAUTH - name of author of note
+16 ;
+17 ; Excludes Notes with Entered in Error (EIE) action
+18 ; Also excludes all notes chronologically prior to EIE action
+19 ; Only includes notes complete or amended or not cosigned
+20 ;
+21 NEW X,ACTID,ARRAYNM,DTARRAY,HASERR
+22 ; purge return array
KILL TIUY
+23 SET (TIUY,ACTID)=0
+24 SET ARRAYNM=$NAME(^TMP("TIUPRFH",$JOB))
DO KILL
+25 ;
+26 ; Get PRF Assgn Hist info
+27 SET X=$$GETHTIU^DGPFAPI1(PTDFN,TIUTTL,ARRAYNM)
+28 IF 'X
GOTO KILL
+29 ;
+30 ; Filter DGPF History records Entered in Error
+31 ; HASERR = history ID with EIE status
+32 ; all history records with date<EIE are also invalid
+33 SET HASERR=$$HASERR^TIUPRFL(ARRAYNM)
+34 ;
+35 FOR
SET ACTID=$ORDER(@ARRAYNM@("HISTORY",ACTID))
if 'ACTID
QUIT
Begin DoDot:1
+36 NEW X,ARRTMP,DIERR,FLDS,IENS,STATUS
+37 NEW TIUACT,TIUAUTH,TIUERR,TIUFLDS,TIUEDATE,TIUIDATE,TIUIEN
+38 SET ARRTMP=$NAME(@ARRAYNM@("HISTORY",ACTID))
+39 IF ACTID=+HASERR
QUIT
+40 IF HASERR>0
if $$ISERR(ARRAYNM,ACTID,$PIECE(HASERR,U,2))
QUIT
+41 ;
+42 ; ARRAYNM node value may be just ^
+43 ; STATUS - only include complete or amended or not cosigned notes
+44 SET TIUIEN=+(@ARRTMP@("TIUIEN"))
+45 if TIUIEN'>0
QUIT
if '$DATA(^TIU(8925,TIUIEN))
QUIT
+46 DO GETS^DIQ(8925,TIUIEN_",",".05;1202;1301","IE","TIUFLDS","TIUERR")
+47 MERGE FLDS=TIUFLDS(8925,TIUIEN_",")
+48 SET TIUIDATE=FLDS(1301,"I")
+49 SET TIUEDATE=$EXTRACT(FLDS(1301,"E"),1,18)
+50 SET TIUAUTH=FLDS(1202,"E")
+51 SET STATUS=FLDS(.05,"I")
+52 IF '((STATUS=6)!(STATUS=7)!(STATUS=8))
QUIT
+53 SET TIUACT=$PIECE(@ARRTMP@("ACTION"),U,2)
+54 ; -- Increment date if there are multiple notes w/ same exact date:
+55 SET X=0
FOR
Begin DoDot:2
+56 IF $DATA(DTARRAY(TIUIDATE))
SET TIUIDATE=TIUIDATE+.0000001
+57 IF '$DATA(DTARRAY(TIUIDATE))
SET DTARRAY(TIUIDATE)=""
SET X=1
+58 QUIT
End DoDot:2
if X
QUIT
+59 IF $GET(REVERSE)
SET TIUIDATE=9999999-TIUIDATE
+60 IF TIUEDATE=""
SET TIUEDATE="No Ref Date"
+61 IF TIUAUTH=""
SET TIUAUTH="No Author"
+62 SET TIUY=TIUY+1
+63 SET TIUY(TIUIDATE)=TIUIEN_U_TIUACT_U_TIUEDATE_U_TIUAUTH
+64 QUIT
End DoDot:1
+65 GOTO KILL
+66 ;
GETACTS(TIUY,TIUTTL,DFN) ; RPC TIU GET PRF ACTIONS
+1 ; RPC Gets PRF Action info
+2 ; Action in PRF is the reason a History (#26.14) record was created
+3 ; Input:
+4 ; DFN - [Required] IEN of PATIENT (#2) file
+5 ; TIUTTL - [Required] IEN of TIU DOCUMENT DEFINITION (#8925.1) file
+6 ; RETURN ARRAY
+7 ; .TIUY - passed by reference
+8 ; see description of return array from GETHTIU^DGPFAPI1
+9 ; reformat data for TIU RPC return
+10 ; dg*951 brought in p8
+11 ; TIUY(ACTID) = p1^p2^p3^p4^p5^p6^p7^p8 where
+12 ; p1 = flag name p5 = action date, FM internal
+13 ; p2 = assignment ien [.001/#26.13] p6 = action date, external
+14 ; p3 = action name [.03/#26.14] p7 = file 8925 ien
+15 ; p4 = action ien p8 = originate facility name
+16 ;
+17 ; Returns linkable action for Patient DFN and flag assoc w/ TIUTTL
+18 ; Action may be currently linked or not
+19 ; Excludes UNLINKABLE actions
+20 ; Entered in Error actions (EIE)
+21 ; Actions taken prior to that EIE action
+22 ; Prior to DG*5.3*951, return array used ACTID from GETHTIU^DGPFAPI1
+23 ; DG*5.3*951 sort array by Originating Facility, always lists the
+24 ; History records created by the local facility first.
+25 ;
+26 NEW X,ACTID,ARRAYNM,DG951,FLAG,TIUFLG,UNLINKBL
+27 ;
+28 SET ARRAYNM=$NAME(^TMP("TIUPRFH",$JOB))
DO KILL
+29 SET TIUY=1
+30 SET X=$$GETHTIU^DGPFAPI1(DFN,TIUTTL,ARRAYNM)
+31 IF 'X
SET TIUY="0^"_$PIECE(X,U,2)
GOTO KILL
+32 ;
+33 ; -- If no unlinked, linkable actions exist, say so but go on:
+34 IF '$$AVAILACT^TIUPRFL(ARRAYNM,,.UNLINKBL)
Begin DoDot:1
+35 SET TIUY="0^All linkable Flag actions are already linked"
+36 QUIT
End DoDot:1
+37 ;
+38 ; -- Return ALL linkable actions (linked or not)
+39 ; Pre DG*3.5*951
+40 SET TIUFLG=$$GETP("FLAG",2)_U_$$GETP("ASSIGNIEN",1)
+41 SET ACTID=0
SET DG951=$$PATCH^XPDUTL("DG*5.3*951")
+42 FOR
SET ACTID=$ORDER(@ARRAYNM@("HISTORY",ACTID))
if '+ACTID
QUIT
Begin DoDot:1
+43 if $GET(UNLINKBL(ACTID))
QUIT
+44 SET TIUY(ACTID)=TIUFLG
+45 SET $PIECE(TIUY(ACTID),U,3)=$$GETPA("ACTION",2)
+46 SET $PIECE(TIUY(ACTID),U,4)=$$GETPA("HISTIEN",1)
+47 SET $PIECE(TIUY(ACTID),U,5)=$$GETPA("DATETIME",1)
+48 SET $PIECE(TIUY(ACTID),U,6)=$$GETPA("DATETIME",2)
+49 SET $PIECE(TIUY(ACTID),U,7)=$$GETPA("TIUIEN",1)
+50 QUIT
End DoDot:1
+51 ;
+52 ; If patch DG*5.3*951, resort return array
+53 IF DG951
Begin DoDot:1
+54 NEW I,X,Y,APPRVBY,HERE,LOC,NAME,ST3
+55 SET HERE=$$HERE
+56 SET ACTID=0
FOR
SET ACTID=$ORDER(TIUY(ACTID))
if 'ACTID
QUIT
Begin DoDot:2
+57 SET APPRVBY=$$GETPA("APPRVBY",1)
+58 SET Y=$$GETPA("ORIGFAC",1)
+59 SET X=$$STN(Y,APPRVBY)
+60 SET LOC=$PIECE(X,U)
+61 SET ST3=$PIECE(X,U,3)
+62 SET NAME=$PIECE(X,U,5)
+63 SET $PIECE(TIUY(ACTID),U,8)=NAME
+64 SET ^TMP($JOB,LOC,ST3,NAME,ACTID)=TIUY(ACTID)
+65 QUIT
End DoDot:2
+66 SET Y=TIUY
KILL TIUY
SET TIUY=Y
+67 SET I=0
SET X=$NAME(^TMP($JOB))
+68 FOR
SET X=$QUERY(@X)
if X=""
QUIT
if $QSUBSCRIPT(X,1)'=$JOB
QUIT
SET I=I+1
SET TIUY(I)=@X
+69 QUIT
End DoDot:1
+70 ;
+71 GOTO KILL
+72 ;
LINK(TIUY,TIUIEN,ASSGNDA,ACTIEN,DFN) ;RPC Link TIU Doc TIUIEN to
+1 ; the PRF action
+2 NEW TIUTTL
+3 SET TIUTTL=+$GET(^TIU(8925,TIUIEN,0))
+4 IF 'TIUTTL
SET TIUY="0^Document does not exist"
QUIT
+5 ; Remove any links before making new link
+6 DO UNLINK^TIUPRF1(TIUIEN)
+7 SET TIUY=$$STOTIU^DGPFAPI2(DFN,ASSGNDA,ACTIEN,TIUIEN)
+8 QUIT
GETSTAT(TIUY,TIUIEN) ;RPC Gets the status of TIU Doc TIUIEN
+1 ;Returns STATIEN^STATNAME
+2 NEW TIUTTL
+3 SET TIUTTL=+$GET(^TIU(8925,TIUIEN,0))
+4 IF 'TIUTTL
SET TIUY="0^Document does not exist"
QUIT
+5 SET TIUY=$PIECE(^TIU(8925,TIUIEN,0),U,5)
+6 SET TIUY=TIUY_U_$PIECE($GET(^TIU(8925.6,TIUY,0)),U,1)
+7 QUIT
+8 ;
ISPRFTTL(TIUY,TIUDA) ;RPC Takes as input 8925.1 IEN
+1 ; and checks if it is a PRF title
+2 ; Cf ISPFTTL^TIUPRFL. which is a FUNCTION
+3 NEW TIUCAT1,TIUCAT2,TIUD1
+4 SET TIUY=0
SET TIUD1=""
+5 SET TIUCAT1=+$$DDEFIEN^TIUFLF7("PATIENT RECORD FLAG CAT I","DC")
+6 SET TIUCAT2=+$$DDEFIEN^TIUFLF7("PATIENT RECORD FLAG CAT II","DC")
+7 SET TIUD1=$ORDER(^TIU(8925.1,"AD",TIUDA,TIUD1))
+8 IF TIUD1=TIUCAT1!(TIUD1=TIUCAT2)
SET TIUY=1
+9 QUIT
+10 ;
+11 ;----------------------- PRIVATE SUBROUTINES ------------------------
GETP(NODE,P) if '$GET(P)
SET P=1
QUIT $PIECE($GET(@ARRAYNM@(NODE)),U,P)
GETPA(NODE,P) if '$GET(P)
SET P=1
QUIT $PIECE($GET(@ARRAYNM@("HISTORY",ACTID,NODE)),U,P)
+1 ;
HERE() ; get facility
+1 ; RETURN file_4_ien ^name ^full_site# ^3-digit_site#
+2 NEW X
SET X=$$SITE^VASITE
+3 QUIT X_U_$EXTRACT($PIECE(X,U,3),1,3)
+4 ;
ISERR(TDAT,ACTID,HASERR) ; is history record prior to EIE status?
+1 QUIT $$ISERR^TIUPRFL(TDAT,ACTID,HASERR)
+2 ;
KILL KILL @ARRAYNM,^TMP($JOB)
QUIT
+1 ;
STN(INST,APPRVBY) ; get station information
+1 ; INPUT PARAMETERS:
+2 ; INST - optional - ien to file 4
+3 ;APPRVBY - optional - pointer to the NEW PERSON file (#200)
+4 ; value from the APPROVED BY field in file 26.14
+5 ; if APPRVBY=.5 then this History record was
+6 ; created at another facility.
+7 ; EXTRINSIC FUNCTION returns p1^p2^p3^p4^p5 where
+8 ; p1 = L:local; R:remote p4 = institution-name
+9 ; p2 = file_4_ien p5 = station#_" "_institution-name
+10 ; p3 = 3-digit station# or UNK
+11 ;
+12 NEW X,FILE4,STNAME,STNUM,STNUM3
+13 IF '$GET(HERE)
NEW HERE
SET HERE=$$HERE
+14 SET INST=$GET(INST)
SET APPRVBY=$GET(APPRVBY)
+15 SET (FILE4,STNAME,STNUM,STNUM3)=""
+16 ; have file_4 pointer (originating facility)
+17 IF INST>0
Begin DoDot:1
+18 SET FILE4=INST
SET X=$$NS^XUAF4(INST)
+19 SET STNAME=$PIECE(X,U)
SET STNUM=$PIECE(X,U,2)
SET STNUM3=$EXTRACT(STNUM,1,3)
+20 QUIT
End DoDot:1
+21 ; do not have file_4 pointer
+22 IF INST<1
Begin DoDot:1
+23 IF APPRVBY>.9
Begin DoDot:2
+24 SET FILE4=+HERE
SET STNAME=$PIECE(HERE,U,2)
+25 SET STNUM=$PIECE(HERE,U,3)
SET STNUM3=$PIECE(HERE,U,4)
+26 QUIT
End DoDot:2
+27 IF '$TEST
SET FILE4=""
SET STNAME="UNKNOWN"
SET (STNUM,STNUM3)="UNK"
+28 QUIT
End DoDot:1
+29 ;
+30 SET X=$SELECT(STNUM3=$PIECE(HERE,U,4):"L",1:"R")
+31 SET X=X_U_FILE4_U_STNUM3_U_STNAME_U_STNAME
+32 IF STNUM3'="UNK"
SET $PIECE(X,U,5)=STNUM_" "_STNAME
+33 QUIT X
