- 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 Jan 18, 2025@03:43:35 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