TIUCNSLT ; SLC/JER - Patient movement look-up ;1/7/03 [6/11/04 8:34am]
;;1.0;TEXT INTEGRATION UTILITIES;**4,31,109,131,142,144,184**;Jun 20, 1997
; External References
; DBIA 2324 $$ISA^USRLM
; DBIA 3473 SEND^GMRCTIU
; DBIA 3473 GET^GMRCTIU
; DBIA 3575 ROLLBACK^GMRCTIU1
GETCNSLT(DFN,TIUCPF,TIUDA,TIUOVR) ; Match consult result
;to an active request
; Call with:
; [DFN] - patient file entry number
; [TIUCPF] - flag to indicate clinical procedure (Optional)
; [TIUDA] - TIU document IEN of consult result (Optional).
; If TIUDA has a request, return it w/o asking user.
; [TIUOVR] - flag to override restrictions on selectable requests
; (Optional). If not received or received as null, reset
; according to whether user is in MIS.
; Note - If DA is defined and TIU document DA has a request,
; code returns its request instead of asking user.
; Returns: TIUY - Variable pointer to consult request
; = -1 if pat has no requests
; = 0 if no request is selected
AGN ; Loop for handling repeated attempts
N TIUI,TIUII,TIUER,TIUOK,TIUOUT,TIUX,TIUY,TIUCNT,X
I +DFN'>0 S TIUOUT=1 Q 0
I +$G(GMRCO) S TIUX=+$G(GMRCO) G GETX
; -- If TIUDA is not defined, try DA for backward
; compatibility:
S TIUDA=$S('$D(TIUDA):+$G(DA),1:+TIUDA)
; -- Ignore TIUDA if it doesn't match pt DFN:
I $P($G(^TIU(8925,TIUDA,0)),U,2)'=+DFN S TIUDA=0
; -- If TIUDA or its parent already has a request,
; return it & don't ask user:
I +$P($G(^TIU(8925,TIUDA,14)),U,5) S TIUX=+$P($G(^(14)),U,5) G GETX
I +$$ISADDNDM^TIULC1(TIUDA) S TIUX=+$$DADCR(TIUDA) G:+TIUX>0 GETX
; -- If override flag is null or is not defined, set it according to
; user's membership in MIS:
S TIUOVR=$S($G(TIUOVR)="":+$$ISA^USRLM(DUZ,"MEDICAL INFORMATION SECTION"),1:+TIUOVR)
D SEND^GMRCTIU(DFN,$G(TIUOVR),$G(TIUCPF))
; If no consult requests for patient, then quit with -1
I $S($G(^TMP("GMRCR",$J,"TIU",1,0))["No Consults":1,'$D(^TMP("GMRCR",$J,"TIU")):1,1:0) D Q -1
. W !!,$C(7),"No CONSULT REQUESTS to Result for ",$P($G(^DPT(DFN,0)),U),".",!
S (TIUCNT,TIUI)=0 F S TIUI=+$O(^TMP("GMRCR",$J,"TIU",TIUI)) Q:+TIUI'>0 D
. S TIUCNT=+$G(TIUCNT)+1
W !,"You must link this Result to a Consult Request...",!
D I +TIUER Q:+$G(TIUOUT) 0 G AGN
. W !,"The following CONSULT REQUEST"
. W $S(+TIUCNT>1:"(S) are",1:" is")," available:"
. S (TIUER,TIUOK,TIUI)=0
. F S TIUI=$O(^TMP("GMRCR",$J,"TIU",TIUI)) Q:+TIUI'>0!+TIUER!+TIUOK D
. . S TIUII=TIUI,TIUX=$G(^TMP("GMRCR",$J,"TIU",TIUI,0))
. . D WRITE I '(TIUI#5) D BREAK
. Q:$D(TIUOUT)
. I +TIUER S TIUOUT=1 Q
. I TIUII#5 D BREAK Q:$D(TIUOUT)
. I +TIUER S TIUOUT=1 Q
. S TIUX=$O(^TMP("GMRCR",$J,"TIU","B",+TIUOK,0))
. ;,^DISV(DUZ,"^GMR(123,",DFN)=+TIUX
. W " ",+TIUX
GETX S TIUY=+TIUX_";GMR(123,"
Q $G(TIUY)
BREAK ; Handle prompting
W !,"CHOOSE 1-",TIUII W:$D(^TMP("GMRCR",$J,"TIU",TIUII+1,0)) !,"<RETURN> TO CONTINUE",!,"OR '^' TO QUIT" W ": " R X:DTIME
I $S('$T!(X["^"):1,X=""&'$D(^TMP("GMRCR",$J,"TIU",TIUII+1)):1,1:0) S TIUER=1 Q
I X="" Q
I X'=+X!'$D(^TMP("GMRCR",$J,"TIU",+X)) W !!,$C(7),"INVALID RESPONSE",! G BREAK
S TIUOK=X
Q
DADCR(DA) ; Get the Consult request associated with the parent record
N TIUDADA,TIUY S TIUDADA=$P($G(^TIU(8925,+DA,0)),U,6)
S TIUY=$P($G(^TIU(8925,TIUDADA,14)),U,5)
Q TIUY
WRITE W !,TIUX
Q
POST(TIUDA,STATUS) ; Post status updates to Consult Tracking
N GMRCDA,DA,TIUAUTH S GMRCDA=+$P($G(^TIU(8925,+TIUDA,14)),U,5)
I +GMRCDA'>0 Q
S TIUAUTH=$P($G(^TIU(8925,TIUDA,12)),U,2)
D GET^GMRCTIU(GMRCDA,TIUDA,STATUS,TIUAUTH)
Q
ISCNSLT(TIUY,TITLE) ; Boolean RPC to evaluate whether TITLE is a CONSULT
N TIUCLASS
S TIUCLASS=+$$CLASS
I +TIUCLASS'>0 S TIUY=0 Q
S TIUY=+$$ISA^TIULX(TITLE,TIUCLASS)
Q
CHANGE(TIUDA,TIUCPF,TIUNOCS) ; Re-direct the TIU Document to a different CT Record
; Passes back TIUNOCS=-1 if pt has no requests or none is selected
N DA,DFN,DIE,DR,GMRCO,GMRCSTAT,GMRCVP,TIUD0,TIUD14
S TIUD0=$G(^TIU(8925,TIUDA,0)),TIUD14=$G(^(14))
S DFN=$P(TIUD0,U,2),GMRCO=$P(TIUD14,U,5)
Q:+DFN'>0
I GMRCO'="" D ROLLBACK(TIUDA) K GMRCO ;P144
CHAGN S DA=TIUDA,TIUNOCS=0
W ! S GMRCVP=+$$GETCNSLT(DFN,$G(TIUCPF))_";GMR(123,"
I +GMRCVP=0 W !!,$C(7),"You must select a Consult Request...Restoring record."
I +GMRCVP'>0 D RETREAT(TIUDA,TIUD14) S TIUPOP=1,TIUNOCS=-1 Q ;P144
S DIE=8925,DA=TIUDA,DR="1405////^S X=GMRCVP" D ^DIE
D UPDTADD(TIUDA,GMRCVP)
S GMRCO=+GMRCVP,GMRCSTAT=$S($P(TIUD0,U,5)>6:"COMPLETED",1:"INCOMPLETE")
D POST(TIUDA,GMRCSTAT)
Q
RETREAT(DA,TIUD14) ; If Pt has no requests, retreat gracefully
N DIE,DR,GMRCO,GMRCSTAT
S DIE=8925,DR="1405////^S X=$P(TIUD14,U,5)" D ^DIE
S GMRCO=+$P(TIUD14,U,5)
S GMRCSTAT=$S($P(TIUD0,U,5)>6:"COMPLETED",1:"INCOMPLETE")
D POST(TIUDA,GMRCSTAT)
Q
UPDTADD(TIUDA,TIUCVP) ; Addenda for re-linked original are updated
;Update TIU(8925 ONLY. GMR(123 doesn't track individual adda
I $$HASADDEN^TIULC1(+TIUDA) D
. N DA
. S DA=0 F S DA=$O(^TIU(8925,"DAD",+TIUDA,DA)) Q:+DA'>0 D
. . N DR,DIE
. . I '+$$ISADDNDM^TIULC1(+DA) Q
. . S DR="1405////^S X=TIUCVP"
. . S DIE=8925 D ^DIE
. . D ^DIE
Q
ROLLBACK(TIUDA) ; Roll back CT Record when TIU changes require it
N GMRCDA,DIE,DR,DA S GMRCDA=+$P($G(^TIU(8925,TIUDA,14)),U,5)
I +GMRCDA>0 D ROLLBACK^GMRCTIU1(GMRCDA,TIUDA) ;P144
S DIE="^TIU(8925,",DA=TIUDA,DR="1405///@" D ^DIE
Q
CLASS() ; What is the TIU Class (or Document Class) for CONSULTS
N GMRCY
S GMRCY=+$O(^TIU(8925.1,"B","CONSULTS",0))
I +GMRCY>0,$S($P($G(^TIU(8925.1,+GMRCY,0)),U,4)="CL":0,$P($G(^(0)),U,4)="DC":0,1:1) S GMRCY=0
Q GMRCY
REMCNSLT(TIUDA) ;Remove link to consult if there is one ;*171
;TIUDA is a TIU record number
N TIUTYPE,TIUDELX
S TIUTYPE=+$G(^TIU(8925,+TIUDA,0))
S TIUDELX=$$DELETE^TIULC1(TIUTYPE)
I TIUDELX]"" X TIUDELX
Q
CONSCT(TIUDA,TIUOTTL,TIUNTTL) ;
;non cons title to cons title - already handled
;cons title to cons title - already handled
;cons title to non cons title
N TIUCLASS
S TIUCLASS=$$CLASS^TIUCNSLT()
I +$$ISA^TIULX(TIUOTTL,TIUCLASS),'+$$ISA^TIULX(TIUNTTL,TIUCLASS) D
. W !,"The Title you selected is not a Consults Title."
. W !," The note is currently linked to a Consults Request,"
. W !," but will be disassociated when the title is changed"
. W !," to a non Consults Title.",!
. W !,"Do you want to continue with this Change Title Action?"
. I +$$READ^TIUU("YO",,"N")'>0 S TIUQUIT=1
. I $G(TIUQUIT)=1 W !,"Title not changed." Q
. D REMCNSLT(+TIUDA)
Q
CNSCTGUI(TIUDA,TIUOTTL,TIUNTTL) ;
;non cons title to cons title - already handled
;cons title to cons title - already handled
;cons title to non cons title
N TIUCLASS
S TIUCLASS=$$CLASS^TIUCNSLT()
I +$$ISA^TIULX(TIUOTTL,TIUCLASS),'+$$ISA^TIULX(TIUNTTL,TIUCLASS) D
. ;Assume the confirmation has been taken care of already
. D REMCNSLT(+TIUDA)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIUCNSLT 7021 printed Oct 16, 2024@18:39:55 Page 2
TIUCNSLT ; SLC/JER - Patient movement look-up ;1/7/03 [6/11/04 8:34am]
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**4,31,109,131,142,144,184**;Jun 20, 1997
+2 ; External References
+3 ; DBIA 2324 $$ISA^USRLM
+4 ; DBIA 3473 SEND^GMRCTIU
+5 ; DBIA 3473 GET^GMRCTIU
+6 ; DBIA 3575 ROLLBACK^GMRCTIU1
GETCNSLT(DFN,TIUCPF,TIUDA,TIUOVR) ; Match consult result
+1 ;to an active request
+2 ; Call with:
+3 ; [DFN] - patient file entry number
+4 ; [TIUCPF] - flag to indicate clinical procedure (Optional)
+5 ; [TIUDA] - TIU document IEN of consult result (Optional).
+6 ; If TIUDA has a request, return it w/o asking user.
+7 ; [TIUOVR] - flag to override restrictions on selectable requests
+8 ; (Optional). If not received or received as null, reset
+9 ; according to whether user is in MIS.
+10 ; Note - If DA is defined and TIU document DA has a request,
+11 ; code returns its request instead of asking user.
+12 ; Returns: TIUY - Variable pointer to consult request
+13 ; = -1 if pat has no requests
+14 ; = 0 if no request is selected
AGN ; Loop for handling repeated attempts
+1 NEW TIUI,TIUII,TIUER,TIUOK,TIUOUT,TIUX,TIUY,TIUCNT,X
+2 IF +DFN'>0
SET TIUOUT=1
QUIT 0
+3 IF +$GET(GMRCO)
SET TIUX=+$GET(GMRCO)
GOTO GETX
+4 ; -- If TIUDA is not defined, try DA for backward
+5 ; compatibility:
+6 SET TIUDA=$SELECT('$DATA(TIUDA):+$GET(DA),1:+TIUDA)
+7 ; -- Ignore TIUDA if it doesn't match pt DFN:
+8 IF $PIECE($GET(^TIU(8925,TIUDA,0)),U,2)'=+DFN
SET TIUDA=0
+9 ; -- If TIUDA or its parent already has a request,
+10 ; return it & don't ask user:
+11 IF +$PIECE($GET(^TIU(8925,TIUDA,14)),U,5)
SET TIUX=+$PIECE($GET(^(14)),U,5)
GOTO GETX
+12 IF +$$ISADDNDM^TIULC1(TIUDA)
SET TIUX=+$$DADCR(TIUDA)
if +TIUX>0
GOTO GETX
+13 ; -- If override flag is null or is not defined, set it according to
+14 ; user's membership in MIS:
+15 SET TIUOVR=$SELECT($GET(TIUOVR)="":+$$ISA^USRLM(DUZ,"MEDICAL INFORMATION SECTION"),1:+TIUOVR)
+16 DO SEND^GMRCTIU(DFN,$GET(TIUOVR),$GET(TIUCPF))
+17 ; If no consult requests for patient, then quit with -1
+18 IF $SELECT($GET(^TMP("GMRCR",$JOB,"TIU",1,0))["No Consults":1,'$DATA(^TMP("GMRCR",$JOB,"TIU")):1,1:0)
Begin DoDot:1
+19 WRITE !!,$CHAR(7),"No CONSULT REQUESTS to Result for ",$PIECE($GET(^DPT(DFN,0)),U),".",!
End DoDot:1
QUIT -1
+20 SET (TIUCNT,TIUI)=0
FOR
SET TIUI=+$ORDER(^TMP("GMRCR",$JOB,"TIU",TIUI))
if +TIUI'>0
QUIT
Begin DoDot:1
+21 SET TIUCNT=+$GET(TIUCNT)+1
End DoDot:1
+22 WRITE !,"You must link this Result to a Consult Request...",!
+23 Begin DoDot:1
+24 WRITE !,"The following CONSULT REQUEST"
+25 WRITE $SELECT(+TIUCNT>1:"(S) are",1:" is")," available:"
+26 SET (TIUER,TIUOK,TIUI)=0
+27 FOR
SET TIUI=$ORDER(^TMP("GMRCR",$JOB,"TIU",TIUI))
if +TIUI'>0!+TIUER!+TIUOK
QUIT
Begin DoDot:2
+28 SET TIUII=TIUI
SET TIUX=$GET(^TMP("GMRCR",$JOB,"TIU",TIUI,0))
+29 DO WRITE
IF '(TIUI#5)
DO BREAK
End DoDot:2
+30 if $DATA(TIUOUT)
QUIT
+31 IF +TIUER
SET TIUOUT=1
QUIT
+32 IF TIUII#5
DO BREAK
if $DATA(TIUOUT)
QUIT
+33 IF +TIUER
SET TIUOUT=1
QUIT
+34 SET TIUX=$ORDER(^TMP("GMRCR",$JOB,"TIU","B",+TIUOK,0))
+35 ;,^DISV(DUZ,"^GMR(123,",DFN)=+TIUX
+36 WRITE " ",+TIUX
End DoDot:1
IF +TIUER
if +$GET(TIUOUT)
QUIT 0
GOTO AGN
GETX SET TIUY=+TIUX_";GMR(123,"
+1 QUIT $GET(TIUY)
BREAK ; Handle prompting
+1 WRITE !,"CHOOSE 1-",TIUII
if $DATA(^TMP("GMRCR",$JOB,"TIU",TIUII+1,0))
WRITE !,"<RETURN> TO CONTINUE",!,"OR '^' TO QUIT"
WRITE ": "
READ X:DTIME
+2 IF $SELECT('$TEST!(X["^"):1,X=""&'$DATA(^TMP("GMRCR",$JOB,"TIU",TIUII+1)):1,1:0)
SET TIUER=1
QUIT
+3 IF X=""
QUIT
+4 IF X'=+X!'$DATA(^TMP("GMRCR",$JOB,"TIU",+X))
WRITE !!,$CHAR(7),"INVALID RESPONSE",!
GOTO BREAK
+5 SET TIUOK=X
+6 QUIT
DADCR(DA) ; Get the Consult request associated with the parent record
+1 NEW TIUDADA,TIUY
SET TIUDADA=$PIECE($GET(^TIU(8925,+DA,0)),U,6)
+2 SET TIUY=$PIECE($GET(^TIU(8925,TIUDADA,14)),U,5)
+3 QUIT TIUY
WRITE WRITE !,TIUX
+1 QUIT
POST(TIUDA,STATUS) ; Post status updates to Consult Tracking
+1 NEW GMRCDA,DA,TIUAUTH
SET GMRCDA=+$PIECE($GET(^TIU(8925,+TIUDA,14)),U,5)
+2 IF +GMRCDA'>0
QUIT
+3 SET TIUAUTH=$PIECE($GET(^TIU(8925,TIUDA,12)),U,2)
+4 DO GET^GMRCTIU(GMRCDA,TIUDA,STATUS,TIUAUTH)
+5 QUIT
ISCNSLT(TIUY,TITLE) ; Boolean RPC to evaluate whether TITLE is a CONSULT
+1 NEW TIUCLASS
+2 SET TIUCLASS=+$$CLASS
+3 IF +TIUCLASS'>0
SET TIUY=0
QUIT
+4 SET TIUY=+$$ISA^TIULX(TITLE,TIUCLASS)
+5 QUIT
CHANGE(TIUDA,TIUCPF,TIUNOCS) ; Re-direct the TIU Document to a different CT Record
+1 ; Passes back TIUNOCS=-1 if pt has no requests or none is selected
+2 NEW DA,DFN,DIE,DR,GMRCO,GMRCSTAT,GMRCVP,TIUD0,TIUD14
+3 SET TIUD0=$GET(^TIU(8925,TIUDA,0))
SET TIUD14=$GET(^(14))
+4 SET DFN=$PIECE(TIUD0,U,2)
SET GMRCO=$PIECE(TIUD14,U,5)
+5 if +DFN'>0
QUIT
+6 ;P144
IF GMRCO'=""
DO ROLLBACK(TIUDA)
KILL GMRCO
CHAGN SET DA=TIUDA
SET TIUNOCS=0
+1 WRITE !
SET GMRCVP=+$$GETCNSLT(DFN,$GET(TIUCPF))_";GMR(123,"
+2 IF +GMRCVP=0
WRITE !!,$CHAR(7),"You must select a Consult Request...Restoring record."
+3 ;P144
IF +GMRCVP'>0
DO RETREAT(TIUDA,TIUD14)
SET TIUPOP=1
SET TIUNOCS=-1
QUIT
+4 SET DIE=8925
SET DA=TIUDA
SET DR="1405////^S X=GMRCVP"
DO ^DIE
+5 DO UPDTADD(TIUDA,GMRCVP)
+6 SET GMRCO=+GMRCVP
SET GMRCSTAT=$SELECT($PIECE(TIUD0,U,5)>6:"COMPLETED",1:"INCOMPLETE")
+7 DO POST(TIUDA,GMRCSTAT)
+8 QUIT
RETREAT(DA,TIUD14) ; If Pt has no requests, retreat gracefully
+1 NEW DIE,DR,GMRCO,GMRCSTAT
+2 SET DIE=8925
SET DR="1405////^S X=$P(TIUD14,U,5)"
DO ^DIE
+3 SET GMRCO=+$PIECE(TIUD14,U,5)
+4 SET GMRCSTAT=$SELECT($PIECE(TIUD0,U,5)>6:"COMPLETED",1:"INCOMPLETE")
+5 DO POST(TIUDA,GMRCSTAT)
+6 QUIT
UPDTADD(TIUDA,TIUCVP) ; Addenda for re-linked original are updated
+1 ;Update TIU(8925 ONLY. GMR(123 doesn't track individual adda
+2 IF $$HASADDEN^TIULC1(+TIUDA)
Begin DoDot:1
+3 NEW DA
+4 SET DA=0
FOR
SET DA=$ORDER(^TIU(8925,"DAD",+TIUDA,DA))
if +DA'>0
QUIT
Begin DoDot:2
+5 NEW DR,DIE
+6 IF '+$$ISADDNDM^TIULC1(+DA)
QUIT
+7 SET DR="1405////^S X=TIUCVP"
+8 SET DIE=8925
DO ^DIE
+9 DO ^DIE
End DoDot:2
End DoDot:1
+10 QUIT
ROLLBACK(TIUDA) ; Roll back CT Record when TIU changes require it
+1 NEW GMRCDA,DIE,DR,DA
SET GMRCDA=+$PIECE($GET(^TIU(8925,TIUDA,14)),U,5)
+2 ;P144
IF +GMRCDA>0
DO ROLLBACK^GMRCTIU1(GMRCDA,TIUDA)
+3 SET DIE="^TIU(8925,"
SET DA=TIUDA
SET DR="1405///@"
DO ^DIE
+4 QUIT
CLASS() ; What is the TIU Class (or Document Class) for CONSULTS
+1 NEW GMRCY
+2 SET GMRCY=+$ORDER(^TIU(8925.1,"B","CONSULTS",0))
+3 IF +GMRCY>0
IF $SELECT($PIECE($GET(^TIU(8925.1,+GMRCY,0)),U,4)="CL":0,$PIECE($GET(^(0)),U,4)="DC":0,1:1)
SET GMRCY=0
+4 QUIT GMRCY
REMCNSLT(TIUDA) ;Remove link to consult if there is one ;*171
+1 ;TIUDA is a TIU record number
+2 NEW TIUTYPE,TIUDELX
+3 SET TIUTYPE=+$GET(^TIU(8925,+TIUDA,0))
+4 SET TIUDELX=$$DELETE^TIULC1(TIUTYPE)
+5 IF TIUDELX]""
XECUTE TIUDELX
+6 QUIT
CONSCT(TIUDA,TIUOTTL,TIUNTTL) ;
+1 ;non cons title to cons title - already handled
+2 ;cons title to cons title - already handled
+3 ;cons title to non cons title
+4 NEW TIUCLASS
+5 SET TIUCLASS=$$CLASS^TIUCNSLT()
+6 IF +$$ISA^TIULX(TIUOTTL,TIUCLASS)
IF '+$$ISA^TIULX(TIUNTTL,TIUCLASS)
Begin DoDot:1
+7 WRITE !,"The Title you selected is not a Consults Title."
+8 WRITE !," The note is currently linked to a Consults Request,"
+9 WRITE !," but will be disassociated when the title is changed"
+10 WRITE !," to a non Consults Title.",!
+11 WRITE !,"Do you want to continue with this Change Title Action?"
+12 IF +$$READ^TIUU("YO",,"N")'>0
SET TIUQUIT=1
+13 IF $GET(TIUQUIT)=1
WRITE !,"Title not changed."
QUIT
+14 DO REMCNSLT(+TIUDA)
End DoDot:1
+15 QUIT
CNSCTGUI(TIUDA,TIUOTTL,TIUNTTL) ;
+1 ;non cons title to cons title - already handled
+2 ;cons title to cons title - already handled
+3 ;cons title to non cons title
+4 NEW TIUCLASS
+5 SET TIUCLASS=$$CLASS^TIUCNSLT()
+6 IF +$$ISA^TIULX(TIUOTTL,TIUCLASS)
IF '+$$ISA^TIULX(TIUNTTL,TIUCLASS)
Begin DoDot:1
+7 ;Assume the confirmation has been taken care of already
+8 DO REMCNSLT(+TIUDA)
End DoDot:1
+9 QUIT
