Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: TIULRR

TIULRR.m

Go to the documentation of this file.
  1. TIULRR ; SLC/JM - Restricted Record Library functions ;7/17/01
  1. ;;1.0;TEXT INTEGRATION UTILITIES;**58,121**;Jun 20, 1997
  1. ;
  1. Q
  1. ;
  1. INITRR(ASKONCE) ; Initializes Restricted Record List
  1. ; If ASKONCE is true, calls to PTRES will only ask once for any given
  1. ; patient. If they answer no it will not ask again. If ASKONCE is
  1. ; false, it will continue to ask on the same patient until they
  1. ; answer Yes (used when called from list manager)
  1. N MSG
  1. S MSG=$S('($D(DUZ)#2):"user code",'$D(^VA(200,DUZ,0)):"user name",1:"")
  1. I MSG'="" D Q
  1. .K TIURRECL
  1. .I $D(VALMAR) D FULL^VALM1
  1. .W !!?2,"Your ",MSG," is undefined. This must be defined to access"
  1. .W !?2,"patient information.",!
  1. I $G(TIURRECL("DUZ"))'=DUZ D ;DUZ has changed - start over
  1. .K TIURRECL
  1. .S TIURRECL("DUZ")=DUZ
  1. S TIURRECL("RCNT")=+$G(TIURRECL("RCNT"))+1
  1. I TIURRECL("RCNT")=1 D ; First reference call
  1. .S TIURRECL=0
  1. .I +$G(ASKONCE) S TIURRECL("ONCE")="X"
  1. Q
  1. ;
  1. KILLRR ; Kills the Restricted Record List
  1. I '$D(TIURRECL) Q
  1. S TIURRECL("RCNT")=+$G(TIURRECL("RCNT"))-1
  1. I +TIURRECL("RCNT")<1 K TIURRECL
  1. Q
  1. ;
  1. DOCRES(TIUDA) ; Evaluate Restricted Record for a specific Document
  1. N TIUY,TIUD0 S TIUY=0
  1. S TIUD0=$G(^TIU(8925,TIUDA,0)) G:+$P(TIUD0,U,2)'>0 DOCRESX
  1. S TIUY=$$PTRES(+$P(TIUD0,U,2))
  1. DOCRESX Q TIUY
  1. PTRES(DFN) ; Returns TRUE if patient is restricted
  1. I '$D(TIURRECL) Q 0 ; Does not function if INITRR has not been called
  1. N TIUBAD
  1. S TIUBAD=0
  1. I +$$GET1^DIQ(38.1,+$G(DFN),2,"I") D
  1. .N DOCHECK
  1. .S TIUBAD=1,DOCHECK=1
  1. .I TIURRECL>0 D
  1. ..N I,IDX,SRCH,DONE
  1. ..S SRCH=U_DFN_"=",DONE=0
  1. ..F I=1:1:TIURRECL D Q:DONE
  1. ...S IDX=$F(TIURRECL(I),SRCH)
  1. ...I IDX D
  1. ....S DONE=1,DOCHECK=0
  1. ....I $D(TIURRECL("ONCE")) S TIUBAD=+$E(TIURRECL(I),IDX)
  1. ....E S TIUBAD=0
  1. .I DOCHECK D
  1. ..I $D(VALMAR) D FULL^VALM1
  1. ..N Y,DTOUT,DUOUT,DOADD
  1. ..S Y=$$CHECK(DFN)
  1. ..I ($D(DTOUT))!($D(DUOUT)) S DOADD=0
  1. ..E D
  1. ...I Y'=-1 S TIUBAD=0
  1. ...S DOADD=(Y'=-1)!($D(TIURRECL("ONCE")))
  1. ..I DOADD D
  1. ...N ADD
  1. ...S ADD=0
  1. ...I TIURRECL=0 S ADD=1
  1. ...E I $L(TIURRECL(TIURRECL))>200 S ADD=1
  1. ...I ADD S TIURRECL=TIURRECL+1,TIURRECL(TIURRECL)=U
  1. ...S TIURRECL(TIURRECL)=TIURRECL(TIURRECL)_DFN_"="_TIUBAD_U
  1. Q TIUBAD
  1. DOCCHK(TIUDA) ; Wrap CHECK
  1. Q +$$CHECK($P($G(^TIU(8925,TIUDA,0)),U,2))
  1. CHECK(DFN) ; call ^DIC to execute check
  1. N DIC,X,Y
  1. S DIC=2,X="`"_DFN,DIC(0)="E"
  1. W !! D ^DIC
  1. Q Y