TIULRR ; SLC/JM - Restricted Record Library functions ;7/17/01
;;1.0;TEXT INTEGRATION UTILITIES;**58,121**;Jun 20, 1997
;
Q
;
INITRR(ASKONCE) ; Initializes Restricted Record List
; If ASKONCE is true, calls to PTRES will only ask once for any given
; patient. If they answer no it will not ask again. If ASKONCE is
; false, it will continue to ask on the same patient until they
; answer Yes (used when called from list manager)
N MSG
S MSG=$S('($D(DUZ)#2):"user code",'$D(^VA(200,DUZ,0)):"user name",1:"")
I MSG'="" D Q
.K TIURRECL
.I $D(VALMAR) D FULL^VALM1
.W !!?2,"Your ",MSG," is undefined. This must be defined to access"
.W !?2,"patient information.",!
I $G(TIURRECL("DUZ"))'=DUZ D ;DUZ has changed - start over
.K TIURRECL
.S TIURRECL("DUZ")=DUZ
S TIURRECL("RCNT")=+$G(TIURRECL("RCNT"))+1
I TIURRECL("RCNT")=1 D ; First reference call
.S TIURRECL=0
.I +$G(ASKONCE) S TIURRECL("ONCE")="X"
Q
;
KILLRR ; Kills the Restricted Record List
I '$D(TIURRECL) Q
S TIURRECL("RCNT")=+$G(TIURRECL("RCNT"))-1
I +TIURRECL("RCNT")<1 K TIURRECL
Q
;
DOCRES(TIUDA) ; Evaluate Restricted Record for a specific Document
N TIUY,TIUD0 S TIUY=0
S TIUD0=$G(^TIU(8925,TIUDA,0)) G:+$P(TIUD0,U,2)'>0 DOCRESX
S TIUY=$$PTRES(+$P(TIUD0,U,2))
DOCRESX Q TIUY
PTRES(DFN) ; Returns TRUE if patient is restricted
I '$D(TIURRECL) Q 0 ; Does not function if INITRR has not been called
N TIUBAD
S TIUBAD=0
I +$$GET1^DIQ(38.1,+$G(DFN),2,"I") D
.N DOCHECK
.S TIUBAD=1,DOCHECK=1
.I TIURRECL>0 D
..N I,IDX,SRCH,DONE
..S SRCH=U_DFN_"=",DONE=0
..F I=1:1:TIURRECL D Q:DONE
...S IDX=$F(TIURRECL(I),SRCH)
...I IDX D
....S DONE=1,DOCHECK=0
....I $D(TIURRECL("ONCE")) S TIUBAD=+$E(TIURRECL(I),IDX)
....E S TIUBAD=0
.I DOCHECK D
..I $D(VALMAR) D FULL^VALM1
..N Y,DTOUT,DUOUT,DOADD
..S Y=$$CHECK(DFN)
..I ($D(DTOUT))!($D(DUOUT)) S DOADD=0
..E D
...I Y'=-1 S TIUBAD=0
...S DOADD=(Y'=-1)!($D(TIURRECL("ONCE")))
..I DOADD D
...N ADD
...S ADD=0
...I TIURRECL=0 S ADD=1
...E I $L(TIURRECL(TIURRECL))>200 S ADD=1
...I ADD S TIURRECL=TIURRECL+1,TIURRECL(TIURRECL)=U
...S TIURRECL(TIURRECL)=TIURRECL(TIURRECL)_DFN_"="_TIUBAD_U
Q TIUBAD
DOCCHK(TIUDA) ; Wrap CHECK
Q +$$CHECK($P($G(^TIU(8925,TIUDA,0)),U,2))
CHECK(DFN) ; call ^DIC to execute check
N DIC,X,Y
S DIC=2,X="`"_DFN,DIC(0)="E"
W !! D ^DIC
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HTIULRR 2413 printed Dec 13, 2024@02:42:26 Page 2
TIULRR ; SLC/JM - Restricted Record Library functions ;7/17/01
+1 ;;1.0;TEXT INTEGRATION UTILITIES;**58,121**;Jun 20, 1997
+2 ;
+3 QUIT
+4 ;
INITRR(ASKONCE) ; Initializes Restricted Record List
+1 ; If ASKONCE is true, calls to PTRES will only ask once for any given
+2 ; patient. If they answer no it will not ask again. If ASKONCE is
+3 ; false, it will continue to ask on the same patient until they
+4 ; answer Yes (used when called from list manager)
+5 NEW MSG
+6 SET MSG=$SELECT('($DATA(DUZ)#2):"user code",'$DATA(^VA(200,DUZ,0)):"user name",1:"")
+7 IF MSG'=""
Begin DoDot:1
+8 KILL TIURRECL
+9 IF $DATA(VALMAR)
DO FULL^VALM1
+10 WRITE !!?2,"Your ",MSG," is undefined. This must be defined to access"
+11 WRITE !?2,"patient information.",!
End DoDot:1
QUIT
+12 ;DUZ has changed - start over
IF $GET(TIURRECL("DUZ"))'=DUZ
Begin DoDot:1
+13 KILL TIURRECL
+14 SET TIURRECL("DUZ")=DUZ
End DoDot:1
+15 SET TIURRECL("RCNT")=+$GET(TIURRECL("RCNT"))+1
+16 ; First reference call
IF TIURRECL("RCNT")=1
Begin DoDot:1
+17 SET TIURRECL=0
+18 IF +$GET(ASKONCE)
SET TIURRECL("ONCE")="X"
End DoDot:1
+19 QUIT
+20 ;
KILLRR ; Kills the Restricted Record List
+1 IF '$DATA(TIURRECL)
QUIT
+2 SET TIURRECL("RCNT")=+$GET(TIURRECL("RCNT"))-1
+3 IF +TIURRECL("RCNT")<1
KILL TIURRECL
+4 QUIT
+5 ;
DOCRES(TIUDA) ; Evaluate Restricted Record for a specific Document
+1 NEW TIUY,TIUD0
SET TIUY=0
+2 SET TIUD0=$GET(^TIU(8925,TIUDA,0))
if +$PIECE(TIUD0,U,2)'>0
GOTO DOCRESX
+3 SET TIUY=$$PTRES(+$PIECE(TIUD0,U,2))
DOCRESX QUIT TIUY
PTRES(DFN) ; Returns TRUE if patient is restricted
+1 ; Does not function if INITRR has not been called
IF '$DATA(TIURRECL)
QUIT 0
+2 NEW TIUBAD
+3 SET TIUBAD=0
+4 IF +$$GET1^DIQ(38.1,+$GET(DFN),2,"I")
Begin DoDot:1
+5 NEW DOCHECK
+6 SET TIUBAD=1
SET DOCHECK=1
+7 IF TIURRECL>0
Begin DoDot:2
+8 NEW I,IDX,SRCH,DONE
+9 SET SRCH=U_DFN_"="
SET DONE=0
+10 FOR I=1:1:TIURRECL
Begin DoDot:3
+11 SET IDX=$FIND(TIURRECL(I),SRCH)
+12 IF IDX
Begin DoDot:4
+13 SET DONE=1
SET DOCHECK=0
+14 IF $DATA(TIURRECL("ONCE"))
SET TIUBAD=+$EXTRACT(TIURRECL(I),IDX)
+15 IF '$TEST
SET TIUBAD=0
End DoDot:4
End DoDot:3
if DONE
QUIT
End DoDot:2
+16 IF DOCHECK
Begin DoDot:2
+17 IF $DATA(VALMAR)
DO FULL^VALM1
+18 NEW Y,DTOUT,DUOUT,DOADD
+19 SET Y=$$CHECK(DFN)
+20 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET DOADD=0
+21 IF '$TEST
Begin DoDot:3
+22 IF Y'=-1
SET TIUBAD=0
+23 SET DOADD=(Y'=-1)!($DATA(TIURRECL("ONCE")))
End DoDot:3
+24 IF DOADD
Begin DoDot:3
+25 NEW ADD
+26 SET ADD=0
+27 IF TIURRECL=0
SET ADD=1
+28 IF '$TEST
IF $LENGTH(TIURRECL(TIURRECL))>200
SET ADD=1
+29 IF ADD
SET TIURRECL=TIURRECL+1
SET TIURRECL(TIURRECL)=U
+30 SET TIURRECL(TIURRECL)=TIURRECL(TIURRECL)_DFN_"="_TIUBAD_U
End DoDot:3
End DoDot:2
End DoDot:1
+31 QUIT TIUBAD
DOCCHK(TIUDA) ; Wrap CHECK
+1 QUIT +$$CHECK($PIECE($GET(^TIU(8925,TIUDA,0)),U,2))
CHECK(DFN) ; call ^DIC to execute check
+1 NEW DIC,X,Y
+2 SET DIC=2
SET X="`"_DFN
SET DIC(0)="E"
+3 WRITE !!
DO ^DIC
+4 QUIT Y
