TIUPRF1 ; SLC/JMH - Modules for Patient Record Flags ; 1/9/06
;;1.0;TEXT INTEGRATION UTILITIES;**184**;Jun 20, 1997
;
SELECT(TIUTTL,DFN,TIUDA) ; Select flag action for VISTA
;Requires:
; TIUTTL - 8925.1 IEN
; DFN - Patient IEN
;Optional:
; TIUDA - Note IEN: If user picks the link that TIUDA is already
; linked to, question the pick
;Returns:
; PRFAssignmentIEN^PRFAssignmentHistoryIEN or
; 0^msg ;
; LINEOK = Line of action selected by user
; TIUAGN = 2 if note TIUDA is already linked to selected action
; TIUAGN = 1 if Assignment History IEN selected by user already has
; another note linked to it
N TIUDG,TIUER,TIURET,TIUAGN,LKBLARR
N FLAGNM,HASFLAG,AVAIL,LINKBL,UNLINKBL,TIUJ
S TIUAGN=0,HASFLAG=1
S FLAGNM=$$FNDFLAG^TIUPRFL(TIUTTL)
I 'FLAGNM S HASFLAG=0
S FLAGNM=$S(HASFLAG:$P(FLAGNM,U,2),1:"UNKNOWN")
S TIUDG=$$GETHTIU^DGPFAPI1(DFN,+$G(TIUTTL),"^TMP(""TIUPRFH"",$J)")
F D Q:'TIUAGN
. I 'TIUAGN W !!,"This Note must be linked to Patient Record Flag:",!," ",FLAGNM,!," Checking for available Flag Actions...",!
. I 'TIUDG S TIURET="0^"_$P(TIUDG,U,2) D Q
. . W !,$P(TIUDG,U,2),"!",!
. . I $$READ^TIUU("EA","RETURN to continue...") ; pause
. S AVAIL=$$AVAILACT^TIUPRFL("^TMP(""TIUPRFH"",$J)",.LINKBL,.UNLINKBL)
. I 'AVAIL D Q
. . S TIURET="0^All linked"
. . W !,"All linkable Flag actions for this Patient and Title are already linked!",!
. . I $$READ^TIUU("EA","RETURN to continue...") ; pause
. I TIUAGN=1 W " ?? This action already has a note linked to it.",! S TIUAGN=0
. I TIUAGN=2 W " ?? The note is already linked to this action.",! S TIUAGN=0
. ; -- If flag assgnmt array has unlinkable actions, omit them and set
. ; a new arr starting subscript at 1:
. I UNLINKBL D S LKBLARR="^TMP(""TIUPRFLKBL"",$J)"
. . F TIUJ=1:1:LINKBL M ^TMP("TIUPRFLKBL",$J,"HISTORY",TIUJ)=^TMP("TIUPRFH",$J,"HISTORY",TIUJ+UNLINKBL)
. I 'UNLINKBL S LKBLARR="^TMP(""TIUPRFH"",$J)"
. ; Display all linkable actions and prompt user to select one:
. W !,"Please select a Patient Record Flag Assignment Action: "
. W !,?7,"Date",?27,"Action",?52,"Note"
. S (TIUER,LINEOK)=0
. ; -- Display the flag actions and ask for choice in BREAK
. F LINENO=1:1:LINKBL D Q:+TIUER!+LINEOK
. . D WRITE(LINENO) I '(LINENO#5) D BREAK(LINENO,LINKBL,.TIUER,.LINEOK)
. I LINENO#5 D BREAK(LINENO,LINKBL,.TIUER,.LINEOK)
. ; -- Check if user ^ out
. I TIUER S TIURET="0^USER EXITED" Q
. S TIURET=+^TMP("TIUPRFH",$J,"ASSIGNIEN")_U_+@LKBLARR@("HISTORY",LINEOK,"HISTIEN")
. ; -- If action already has a note linked to it, try again:
. I +$G(TIUDA),+@LKBLARR@("HISTORY",LINEOK,"TIUIEN")=$G(TIUDA) S TIUAGN=2 Q
. I @LKBLARR@("HISTORY",LINEOK,"TIUIEN") S TIUAGN=1 Q
SELECTQ K ^TMP("TIUPRFH",$J),^TMP("TIUPRFLKBL",$J)
Q TIURET
;
BREAK(LINENO,LINKBL,TIUER,LINEOK) ; Handle prompting
N TIUX,MORE
S MORE=$S(LINKBL>LINENO:1,1:0)
BREAK1 ;
W !,"CHOOSE 1-",LINENO
I MORE W !,"<RETURN> TO CONTINUE",!,"OR '^' TO QUIT"
W ": " R TIUX:DTIME
I $S('$T!(TIUX["^"):1,TIUX=""&'MORE:1,1:0) S TIUER=1 Q
I TIUX="" Q
I TIUX'=+TIUX!'$D(@LKBLARR@("HISTORY",+TIUX)) W !!,$C(7),"INVALID RESPONSE",! G BREAK1
S LINEOK=TIUX
Q
;
WRITE(LINENO) ; write the selectable item
; Uses LKBLARR
N TIUX,TIUIEN,TIUAHIST,REFDT
S TIUX=$P($G(@LKBLARR@("HISTORY",LINENO,"DATETIME")),U)
W !,?2,LINENO,">",?7,$$FMTE^XLFDT(TIUX,"2D")
W ?27,$P(@LKBLARR@("HISTORY",LINENO,"ACTION"),U,2),?52
S TIUIEN=+@LKBLARR@("HISTORY",LINENO,"TIUIEN")
S TIUAHIST=+@LKBLARR@("HISTORY",LINENO,"HISTIEN")
I TIUIEN S REFDT=+$G(^TIU(8925,TIUIEN,13)),REFDT=$$DATE^TIULS(REFDT,"MM/DD/YY HR:MIN") W REFDT
Q
;
LINK(TIUDA,ASSGNDA,ACTDA,DFN) ;links a note to a flag assignment action
;for patient DFN.
; Returns 1 if successful otherwise 0^"error message"
N TIUTTL
S TIUTTL=+$G(^TIU(8925,TIUDA,0))
I 'TIUTTL Q "0^Document does not exist"
; -- GUI doesn't link if we check if TIUDA is PRF note, so don't
;I '$$ISPFTTL^TIUPRFL(TIUTTL) Q "0^Can't link non-PRF notes"
S TIURES=$$STOTIU^DGPFAPI2(DFN,ASSGNDA,ACTDA,TIUDA)
I 'TIURES Q TIURES
Q 1
UNLINK(TIUDA) ;removes any link the note TIUDA might have
N TIUTTL
S TIUTTL=+$G(^TIU(8925,TIUDA,0))
I 'TIUTTL Q
S TIURES=$$DELTIU^DGPFAPI2(TIUDA)
Q
RELINK(TIUDA,DFN) ; removes old link for TIUDA and links to new PRF assignment for patient DFN
; returns 1 if successful otherwise 0^"error message"
N TIUPRF,TIUTTL,TIUASS,TIUACT,TIURES
S TIUTTL=+$G(^TIU(8925,TIUDA,0))
S TIUPRF=$$SELECT(TIUTTL,DFN,TIUDA)
I '+TIUPRF Q TIUPRF
S TIUASS=+TIUPRF,TIUACT=$P(TIUPRF,U,2)
D UNLINK(TIUDA)
S TIURES=$$LINK^TIUPRF1(TIUDA,TIUASS,TIUACT,DFN)
Q 1
;
CHANGE(TIUDA) ; removes old link for TIUDA and links to new PRF assignment for TIUDA's patient
N DFN,TIUTTL,TIUPRF
S DFN=$P($G(^TIU(8925,TIUDA,0)),U,2)
S TIUTTL=+$G(^TIU(8925,TIUDA,0))
S TIUPRF=$$SELECT(TIUTTL,DFN,TIUDA)
I '+TIUPRF W !,"You must select an action ... Nothing (re)-linked." S TIUPOP=1 Q
S TIUASS=+TIUPRF,TIUACT=$P(TIUPRF,U,2)
D UNLINK(TIUDA)
S TIUPRF=$$LINK(TIUDA,TIUASS,TIUACT,DFN)
I '+TIUPRF S TIUPOP=1 Q
Q
;
PRFCT(TIUOTTL,TIUNTTL,TIUDA) ; handles changing title situations for PRF notes in LM
N NEWISPRF,DFN,TIULINK,TIULINKC,OLDISPRF
S DFN=$P($G(^TIU(8925,TIUDA,0)),U,2)
S NEWISPRF=$$ISPFTTL^TIUPRFL(TIUNTTL)
S OLDISPRF=$$ISPFTTL^TIUPRFL(TIUOTTL)
;-- non PRF title to PRF title
I NEWISPRF,'OLDISPRF D Q
. W !,"The Title you selected is a PRF Title."
. W !," PRF Notes must be linked to Patient Record Flags.",!
. W !,"Do you want to continue with this Change Title Action?"
. I +$$READ^TIUU("YO",,"N")'>0 S TIUQUIT=1 W !,"Title not changed." Q
. S TIULINK=$$SELECT^TIUPRF1(TIUNTTL,DFN)
. I 'TIULINK S TIUQUIT=1 W !,"Title not changed." Q
. ; -- get new link
. S TIULINKC=$$LINK^TIUPRF1(TIUDA,+TIULINK,$P(TIULINK,U,2),DFN)
;-- PRF title to PRF title
I NEWISPRF,OLDISPRF D Q
. W !,"This document is already attached to a Patient Record"
. W !," Flag. It will be unlinked from the current flag"
. W !," and linked to a new flag.",!
. W !,"Do you want to continue with this Change Title Action?"
. I +$$READ^TIUU("YO",,"N")'>0 S TIUQUIT=1 W !,"Title not changed." Q
. ; -- get new PRF Assignment to link to
. S TIULINK=$$SELECT^TIUPRF1(TIUNTTL,DFN)
. I 'TIULINK S TIUQUIT=1 W !,"Title not changed." Q
. D UNLINK^TIUPRF1(+TIUDA)
. S TIULINKC=$$LINK^TIUPRF1(TIUDA,+TIULINK,$P(TIULINK,U,2),DFN)
; -- PRF title to non PRF title
I 'NEWISPRF,OLDISPRF D Q
. W !,"The Title you selected is not a PRF Title."
. W !," The note is currently linked to a Patient Record Flag,"
. W !," but will be unlinked when the title is changed"
. W !," to a non-PRF Title.",!
. W !,"Do you want to continue with this Change Title Action?"
. I +$$READ^TIUU("YO",,"N")'>0 S TIUQUIT=1 W !,"Title not changed." Q
. D UNLINK^TIUPRF1(+TIUDA)
Q
;
GETLINK(TIUTYP,DFN,TIUDA) ; Ask user for link for NEW note and link it. Return success or failure
N TIUPRF,TIUPRFL
S TIUPRF=$$SELECT^TIUPRF1(TIUTYP,DFN)
I 'TIUPRF W !,"Patient Record Flag Notes must be linked to Flag Actions.",! Q 0
S TIUPRFL=$$LINK^TIUPRF1(TIUDA,$P(TIUPRF,U,1),$P(TIUPRF,U,2),DFN)
I 'TIUPRFL W !,$P(TIUPRFL,U,2),! Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUPRF1 7322 printed Apr 09, 2024@21:43:30 Page 2
TIUPRF1 ; SLC/JMH - Modules for Patient Record Flags ; 1/9/06
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**184**;Jun 20, 1997
+2 ;
SELECT(TIUTTL,DFN,TIUDA) ; Select flag action for VISTA
+1 ;Requires:
+2 ; TIUTTL - 8925.1 IEN
+3 ; DFN - Patient IEN
+4 ;Optional:
+5 ; TIUDA - Note IEN: If user picks the link that TIUDA is already
+6 ; linked to, question the pick
+7 ;Returns:
+8 ; PRFAssignmentIEN^PRFAssignmentHistoryIEN or
+9 ; 0^msg ;
+10 ; LINEOK = Line of action selected by user
+11 ; TIUAGN = 2 if note TIUDA is already linked to selected action
+12 ; TIUAGN = 1 if Assignment History IEN selected by user already has
+13 ; another note linked to it
+14 NEW TIUDG,TIUER,TIURET,TIUAGN,LKBLARR
+15 NEW FLAGNM,HASFLAG,AVAIL,LINKBL,UNLINKBL,TIUJ
+16 SET TIUAGN=0
SET HASFLAG=1
+17 SET FLAGNM=$$FNDFLAG^TIUPRFL(TIUTTL)
+18 IF 'FLAGNM
SET HASFLAG=0
+19 SET FLAGNM=$SELECT(HASFLAG:$PIECE(FLAGNM,U,2),1:"UNKNOWN")
+20 SET TIUDG=$$GETHTIU^DGPFAPI1(DFN,+$GET(TIUTTL),"^TMP(""TIUPRFH"",$J)")
+21 FOR
Begin DoDot:1
+22 IF 'TIUAGN
WRITE !!,"This Note must be linked to Patient Record Flag:",!," ",FLAGNM,!," Checking for available Flag Actions...",!
+23 IF 'TIUDG
SET TIURET="0^"_$PIECE(TIUDG,U,2)
Begin DoDot:2
+24 WRITE !,$PIECE(TIUDG,U,2),"!",!
+25 ; pause
IF $$READ^TIUU("EA","RETURN to continue...")
End DoDot:2
QUIT
+26 SET AVAIL=$$AVAILACT^TIUPRFL("^TMP(""TIUPRFH"",$J)",.LINKBL,.UNLINKBL)
+27 IF 'AVAIL
Begin DoDot:2
+28 SET TIURET="0^All linked"
+29 WRITE !,"All linkable Flag actions for this Patient and Title are already linked!",!
+30 ; pause
IF $$READ^TIUU("EA","RETURN to continue...")
End DoDot:2
QUIT
+31 IF TIUAGN=1
WRITE " ?? This action already has a note linked to it.",!
SET TIUAGN=0
+32 IF TIUAGN=2
WRITE " ?? The note is already linked to this action.",!
SET TIUAGN=0
+33 ; -- If flag assgnmt array has unlinkable actions, omit them and set
+34 ; a new arr starting subscript at 1:
+35 IF UNLINKBL
Begin DoDot:2
+36 FOR TIUJ=1:1:LINKBL
MERGE ^TMP("TIUPRFLKBL",$JOB,"HISTORY",TIUJ)=^TMP("TIUPRFH",$JOB,"HISTORY",TIUJ+UNLINKBL)
End DoDot:2
SET LKBLARR="^TMP(""TIUPRFLKBL"",$J)"
+37 IF 'UNLINKBL
SET LKBLARR="^TMP(""TIUPRFH"",$J)"
+38 ; Display all linkable actions and prompt user to select one:
+39 WRITE !,"Please select a Patient Record Flag Assignment Action: "
+40 WRITE !,?7,"Date",?27,"Action",?52,"Note"
+41 SET (TIUER,LINEOK)=0
+42 ; -- Display the flag actions and ask for choice in BREAK
+43 FOR LINENO=1:1:LINKBL
Begin DoDot:2
+44 DO WRITE(LINENO)
IF '(LINENO#5)
DO BREAK(LINENO,LINKBL,.TIUER,.LINEOK)
End DoDot:2
if +TIUER!+LINEOK
QUIT
+45 IF LINENO#5
DO BREAK(LINENO,LINKBL,.TIUER,.LINEOK)
+46 ; -- Check if user ^ out
+47 IF TIUER
SET TIURET="0^USER EXITED"
QUIT
+48 SET TIURET=+^TMP("TIUPRFH",$JOB,"ASSIGNIEN")_U_+@LKBLARR@("HISTORY",LINEOK,"HISTIEN")
+49 ; -- If action already has a note linked to it, try again:
+50 IF +$GET(TIUDA)
IF +@LKBLARR@("HISTORY",LINEOK,"TIUIEN")=$GET(TIUDA)
SET TIUAGN=2
QUIT
+51 IF @LKBLARR@("HISTORY",LINEOK,"TIUIEN")
SET TIUAGN=1
QUIT
End DoDot:1
if 'TIUAGN
QUIT
SELECTQ KILL ^TMP("TIUPRFH",$JOB),^TMP("TIUPRFLKBL",$JOB)
+1 QUIT TIURET
+2 ;
BREAK(LINENO,LINKBL,TIUER,LINEOK) ; Handle prompting
+1 NEW TIUX,MORE
+2 SET MORE=$SELECT(LINKBL>LINENO:1,1:0)
BREAK1 ;
+1 WRITE !,"CHOOSE 1-",LINENO
+2 IF MORE
WRITE !,"<RETURN> TO CONTINUE",!,"OR '^' TO QUIT"
+3 WRITE ": "
READ TIUX:DTIME
+4 IF $SELECT('$TEST!(TIUX["^"):1,TIUX=""&'MORE:1,1:0)
SET TIUER=1
QUIT
+5 IF TIUX=""
QUIT
+6 IF TIUX'=+TIUX!'$DATA(@LKBLARR@("HISTORY",+TIUX))
WRITE !!,$CHAR(7),"INVALID RESPONSE",!
GOTO BREAK1
+7 SET LINEOK=TIUX
+8 QUIT
+9 ;
WRITE(LINENO) ; write the selectable item
+1 ; Uses LKBLARR
+2 NEW TIUX,TIUIEN,TIUAHIST,REFDT
+3 SET TIUX=$PIECE($GET(@LKBLARR@("HISTORY",LINENO,"DATETIME")),U)
+4 WRITE !,?2,LINENO,">",?7,$$FMTE^XLFDT(TIUX,"2D")
+5 WRITE ?27,$PIECE(@LKBLARR@("HISTORY",LINENO,"ACTION"),U,2),?52
+6 SET TIUIEN=+@LKBLARR@("HISTORY",LINENO,"TIUIEN")
+7 SET TIUAHIST=+@LKBLARR@("HISTORY",LINENO,"HISTIEN")
+8 IF TIUIEN
SET REFDT=+$GET(^TIU(8925,TIUIEN,13))
SET REFDT=$$DATE^TIULS(REFDT,"MM/DD/YY HR:MIN")
WRITE REFDT
+9 QUIT
+10 ;
LINK(TIUDA,ASSGNDA,ACTDA,DFN) ;links a note to a flag assignment action
+1 ;for patient DFN.
+2 ; Returns 1 if successful otherwise 0^"error message"
+3 NEW TIUTTL
+4 SET TIUTTL=+$GET(^TIU(8925,TIUDA,0))
+5 IF 'TIUTTL
QUIT "0^Document does not exist"
+6 ; -- GUI doesn't link if we check if TIUDA is PRF note, so don't
+7 ;I '$$ISPFTTL^TIUPRFL(TIUTTL) Q "0^Can't link non-PRF notes"
+8 SET TIURES=$$STOTIU^DGPFAPI2(DFN,ASSGNDA,ACTDA,TIUDA)
+9 IF 'TIURES
QUIT TIURES
+10 QUIT 1
UNLINK(TIUDA) ;removes any link the note TIUDA might have
+1 NEW TIUTTL
+2 SET TIUTTL=+$GET(^TIU(8925,TIUDA,0))
+3 IF 'TIUTTL
QUIT
+4 SET TIURES=$$DELTIU^DGPFAPI2(TIUDA)
+5 QUIT
RELINK(TIUDA,DFN) ; removes old link for TIUDA and links to new PRF assignment for patient DFN
+1 ; returns 1 if successful otherwise 0^"error message"
+2 NEW TIUPRF,TIUTTL,TIUASS,TIUACT,TIURES
+3 SET TIUTTL=+$GET(^TIU(8925,TIUDA,0))
+4 SET TIUPRF=$$SELECT(TIUTTL,DFN,TIUDA)
+5 IF '+TIUPRF
QUIT TIUPRF
+6 SET TIUASS=+TIUPRF
SET TIUACT=$PIECE(TIUPRF,U,2)
+7 DO UNLINK(TIUDA)
+8 SET TIURES=$$LINK^TIUPRF1(TIUDA,TIUASS,TIUACT,DFN)
+9 QUIT 1
+10 ;
CHANGE(TIUDA) ; removes old link for TIUDA and links to new PRF assignment for TIUDA's patient
+1 NEW DFN,TIUTTL,TIUPRF
+2 SET DFN=$PIECE($GET(^TIU(8925,TIUDA,0)),U,2)
+3 SET TIUTTL=+$GET(^TIU(8925,TIUDA,0))
+4 SET TIUPRF=$$SELECT(TIUTTL,DFN,TIUDA)
+5 IF '+TIUPRF
WRITE !,"You must select an action ... Nothing (re)-linked."
SET TIUPOP=1
QUIT
+6 SET TIUASS=+TIUPRF
SET TIUACT=$PIECE(TIUPRF,U,2)
+7 DO UNLINK(TIUDA)
+8 SET TIUPRF=$$LINK(TIUDA,TIUASS,TIUACT,DFN)
+9 IF '+TIUPRF
SET TIUPOP=1
QUIT
+10 QUIT
+11 ;
PRFCT(TIUOTTL,TIUNTTL,TIUDA) ; handles changing title situations for PRF notes in LM
+1 NEW NEWISPRF,DFN,TIULINK,TIULINKC,OLDISPRF
+2 SET DFN=$PIECE($GET(^TIU(8925,TIUDA,0)),U,2)
+3 SET NEWISPRF=$$ISPFTTL^TIUPRFL(TIUNTTL)
+4 SET OLDISPRF=$$ISPFTTL^TIUPRFL(TIUOTTL)
+5 ;-- non PRF title to PRF title
+6 IF NEWISPRF
IF 'OLDISPRF
Begin DoDot:1
+7 WRITE !,"The Title you selected is a PRF Title."
+8 WRITE !," PRF Notes must be linked to Patient Record Flags.",!
+9 WRITE !,"Do you want to continue with this Change Title Action?"
+10 IF +$$READ^TIUU("YO",,"N")'>0
SET TIUQUIT=1
WRITE !,"Title not changed."
QUIT
+11 SET TIULINK=$$SELECT^TIUPRF1(TIUNTTL,DFN)
+12 IF 'TIULINK
SET TIUQUIT=1
WRITE !,"Title not changed."
QUIT
+13 ; -- get new link
+14 SET TIULINKC=$$LINK^TIUPRF1(TIUDA,+TIULINK,$PIECE(TIULINK,U,2),DFN)
End DoDot:1
QUIT
+15 ;-- PRF title to PRF title
+16 IF NEWISPRF
IF OLDISPRF
Begin DoDot:1
+17 WRITE !,"This document is already attached to a Patient Record"
+18 WRITE !," Flag. It will be unlinked from the current flag"
+19 WRITE !," and linked to a new flag.",!
+20 WRITE !,"Do you want to continue with this Change Title Action?"
+21 IF +$$READ^TIUU("YO",,"N")'>0
SET TIUQUIT=1
WRITE !,"Title not changed."
QUIT
+22 ; -- get new PRF Assignment to link to
+23 SET TIULINK=$$SELECT^TIUPRF1(TIUNTTL,DFN)
+24 IF 'TIULINK
SET TIUQUIT=1
WRITE !,"Title not changed."
QUIT
+25 DO UNLINK^TIUPRF1(+TIUDA)
+26 SET TIULINKC=$$LINK^TIUPRF1(TIUDA,+TIULINK,$PIECE(TIULINK,U,2),DFN)
End DoDot:1
QUIT
+27 ; -- PRF title to non PRF title
+28 IF 'NEWISPRF
IF OLDISPRF
Begin DoDot:1
+29 WRITE !,"The Title you selected is not a PRF Title."
+30 WRITE !," The note is currently linked to a Patient Record Flag,"
+31 WRITE !," but will be unlinked when the title is changed"
+32 WRITE !," to a non-PRF Title.",!
+33 WRITE !,"Do you want to continue with this Change Title Action?"
+34 IF +$$READ^TIUU("YO",,"N")'>0
SET TIUQUIT=1
WRITE !,"Title not changed."
QUIT
+35 DO UNLINK^TIUPRF1(+TIUDA)
End DoDot:1
QUIT
+36 QUIT
+37 ;
GETLINK(TIUTYP,DFN,TIUDA) ; Ask user for link for NEW note and link it. Return success or failure
+1 NEW TIUPRF,TIUPRFL
+2 SET TIUPRF=$$SELECT^TIUPRF1(TIUTYP,DFN)
+3 IF 'TIUPRF
WRITE !,"Patient Record Flag Notes must be linked to Flag Actions.",!
QUIT 0
+4 SET TIUPRFL=$$LINK^TIUPRF1(TIUDA,$PIECE(TIUPRF,U,1),$PIECE(TIUPRF,U,2),DFN)
+5 IF 'TIUPRFL
WRITE !,$PIECE(TIUPRFL,U,2),!
QUIT 0
+6 QUIT 1
