BDGSECL ; IHS/ANMC/LJF - LIST SENSITIVE PATIENTS ;
;;5.3;PIMS;;APR 26, 2002
;
EN ; -- main entry point for BDG SECURITY LIST
NEW VALMCNT
D TERM^VALM0
D EN^VALM("BDG SECURITY LIST")
D CLEAR^VALM1
Q
;
HDR ; -- header code
NEW X
S X="Patients stored in DG SECURITY LOG file as of "_$$FMTE^XLFDT(DT)
S VALMHDR(1)=$$SP(10)_X
Q
;
INIT ; -- init variables and list array
NEW DGN,NAME,STATUS,DATA,LINE,DGNUM
K ^TMP("BDGSECL",$J),^TMP("BDGSECL1",$J)
S VALMCNT=0
;
; find all entries and sort by status and then by name
S (DGN,DGNUM)=0
F S DGN=$O(^DGSL(38.1,DGN)) Q:'DGN D
. S NAME=$$GET1^DIQ(38.1,DGN,.01),STATUS=$$GET1^DIQ(38.1,DGN,2)
. Q:STATUS'="SENSITIVE"
. ; assigned by (initials)
. S X=$$GET1^DIQ(200,+$$GET1^DIQ(38.1,DGN,3,"I"),1)
. ; date assigned status
. S Y=$$FMTE^XLFDT($$GET1^DIQ(38.1,DGN,4,"I"))
. S ^TMP("BDGSECL1",$J,NAME,DGN)=X_U_Y
;
; if file is empty, set message and quit
I '$D(^TMP("BDGSECL1",$J)) D SET("No PATIENTS currently or previously defined as SENSITIVE",0,.VALMCNT,0) Q
;
; otherwise, set display lines per sorts
S NAME=0 F S NAME=$O(^TMP("BDGSECL1",$J,NAME)) Q:NAME="" D
. S DGN=0 F S DGN=$O(^TMP("BDGSECL1",$J,NAME,DGN)) Q:'DGN D
.. S DATA=^TMP("BDGSECL1",$J,NAME,DGN)
.. ; create display line
.. S DGNUM=DGNUM+1 ;entry # on display screen
.. S LINE=$J(DGNUM,3)_". "_$E(NAME,1,20) ;#. pat name
.. S LINE=$$PAD(LINE,28)_$P(DATA,U,2) ;date
.. S LINE=$$PAD(LINE,50)_$P(DATA,U) ;assigned by
.. D SET(LINE,DGN,.VALMCNT,.DGNUM) ;add display line to list global
;
K ^TMP("BDGSECL1",$J)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K VALMCNT,^TMP("BDGSECL",$J)
Q
;
EXPND ; -- expand code
Q
;
DISPLAY ;EP; -- called by protocol to display access records for patient
D FULL^VALM1
I '$D(^XUSEC("DG SECURITY OFFICER",DUZ)) W !!?3,*7,"You do not have the appropriate access privileges to display user access." D PAUSE^BDGF,RESET2 Q
NEW BDGI
S BDGI=$$GETITEM^BDGFL("BDGSECL","OS") ;choose entry to display
I 'BDGI D RESET2 Q ;or go back
S DFN=$$GET1^DIQ(38.1,+BDGI,.01,"I") ;set variable for call
D DTRNG^DGSEC2 I DGPOP D Q^DGSEC2,RESET2 Q ;ask date range
D ASKUSR^DGSEC2,RESET2 ;rest of code for report
Q
;
EDIT ;EP; -- called by protocol to edit sensitivity level
D FULL^VALM1
I '$D(^XUSEC("DG SENSITIVITY",DUZ)) W !!?3,$C(7),"You do not have the appropriate access privileges to assign security." D PAUSE^BDGF,RESET2 Q
NEW BDGI
S BDGI=$$GETITEM^BDGFL("BDGSECL","OS") ;choose entry to edit
I 'BDGI D RESET2 Q ;or go back
S DA=+BDGI,BDGSECL=1 ;calling rtn needs DA set, BDGSECL helps exit
D IHS^DGSEC1,RESET ;call 1^DGSEC1 after patient lookup
Q
;
SET(DATA,IEN,LINE,NUM) ; -- create ^tmp global for list template
S LINE=LINE+1
S ^TMP("BDGSECL",$J,LINE,0)=DATA
S ^TMP("BDGSECL",$J,"IDX",LINE,NUM)=IEN
Q
;
PAD(D,L) ;EP -- SUBRTN to pad length of data
; -- D=data L=length
Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
;
SP(N) ; -- SUBRTN to pad N number of spaces
Q $$PAD(" ",N)
;
RESET ; -- update partition for return to list manager
I $D(VALMQUIT) S VALMBCK="Q" Q
D TERM^VALM0 S VALMBCK="R"
D INIT,HDR
Q
;
RESET2 ; -- return to list manager; don't update list
I $D(VALMQUIT) S VALMBCK="Q" Q
D TERM^VALM0 S VALMBCK="R"
Q
BDGSECL ; IHS/ANMC/LJF - LIST SENSITIVE PATIENTS ;
+1 ;;5.3;PIMS;;APR 26, 2002
+2 ;
EN ; -- main entry point for BDG SECURITY LIST
+1 NEW VALMCNT
+2 DO TERM^VALM0
+3 DO EN^VALM("BDG SECURITY LIST")
+4 DO CLEAR^VALM1
+5 QUIT
+6 ;
HDR ; -- header code
+1 NEW X
+2 SET X="Patients stored in DG SECURITY LOG file as of "_$$FMTE^XLFDT(DT)
+3 SET VALMHDR(1)=$$SP(10)_X
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 NEW DGN,NAME,STATUS,DATA,LINE,DGNUM
+2 KILL ^TMP("BDGSECL",$JOB),^TMP("BDGSECL1",$JOB)
+3 SET VALMCNT=0
+4 ;
+5 ; find all entries and sort by status and then by name
+6 SET (DGN,DGNUM)=0
+7 FOR
SET DGN=$ORDER(^DGSL(38.1,DGN))
IF 'DGN
QUIT
Begin DoDot:1
+8 SET NAME=$$GET1^DIQ(38.1,DGN,.01)
SET STATUS=$$GET1^DIQ(38.1,DGN,2)
+9 IF STATUS'="SENSITIVE"
QUIT
+10 ; assigned by (initials)
+11 SET X=$$GET1^DIQ(200,+$$GET1^DIQ(38.1,DGN,3,"I"),1)
+12 ; date assigned status
+13 SET Y=$$FMTE^XLFDT($$GET1^DIQ(38.1,DGN,4,"I"))
+14 SET ^TMP("BDGSECL1",$JOB,NAME,DGN)=X_U_Y
End DoDot:1
+15 ;
+16 ; if file is empty, set message and quit
+17 IF '$DATA(^TMP("BDGSECL1",$JOB))
DO SET("No PATIENTS currently or previously defined as SENSITIVE",0,.VALMCNT,0)
QUIT
+18 ;
+19 ; otherwise, set display lines per sorts
+20 SET NAME=0
FOR
SET NAME=$ORDER(^TMP("BDGSECL1",$JOB,NAME))
IF NAME=""
QUIT
Begin DoDot:1
+21 SET DGN=0
FOR
SET DGN=$ORDER(^TMP("BDGSECL1",$JOB,NAME,DGN))
IF 'DGN
QUIT
Begin DoDot:2
+22 SET DATA=^TMP("BDGSECL1",$JOB,NAME,DGN)
+23 ; create display line
+24 ;entry # on display screen
SET DGNUM=DGNUM+1
+25 ;#. pat name
SET LINE=$JUSTIFY(DGNUM,3)_". "_$EXTRACT(NAME,1,20)
+26 ;date
SET LINE=$$PAD(LINE,28)_$PIECE(DATA,U,2)
+27 ;assigned by
SET LINE=$$PAD(LINE,50)_$PIECE(DATA,U)
+28 ;add display line to list global
DO SET(LINE,DGN,.VALMCNT,.DGNUM)
End DoDot:2
End DoDot:1
+29 ;
+30 KILL ^TMP("BDGSECL1",$JOB)
+31 QUIT
+32 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL VALMCNT,^TMP("BDGSECL",$JOB)
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
DISPLAY ;EP; -- called by protocol to display access records for patient
+1 DO FULL^VALM1
+2 IF '$DATA(^XUSEC("DG SECURITY OFFICER",DUZ))
WRITE !!?3,*7,"You do not have the appropriate access privileges to display user access."
DO PAUSE^BDGF
DO RESET2
QUIT
+3 NEW BDGI
+4 ;choose entry to display
SET BDGI=$$GETITEM^BDGFL("BDGSECL","OS")
+5 ;or go back
IF 'BDGI
DO RESET2
QUIT
+6 ;set variable for call
SET DFN=$$GET1^DIQ(38.1,+BDGI,.01,"I")
+7 ;ask date range
DO DTRNG^DGSEC2
IF DGPOP
DO Q^DGSEC2
DO RESET2
QUIT
+8 ;rest of code for report
DO ASKUSR^DGSEC2
DO RESET2
+9 QUIT
+10 ;
EDIT ;EP; -- called by protocol to edit sensitivity level
+1 DO FULL^VALM1
+2 IF '$DATA(^XUSEC("DG SENSITIVITY",DUZ))
WRITE !!?3,$CHAR(7),"You do not have the appropriate access privileges to assign security."
DO PAUSE^BDGF
DO RESET2
QUIT
+3 NEW BDGI
+4 ;choose entry to edit
SET BDGI=$$GETITEM^BDGFL("BDGSECL","OS")
+5 ;or go back
IF 'BDGI
DO RESET2
QUIT
+6 ;calling rtn needs DA set, BDGSECL helps exit
SET DA=+BDGI
SET BDGSECL=1
+7 ;call 1^DGSEC1 after patient lookup
DO IHS^DGSEC1
DO RESET
+8 QUIT
+9 ;
SET(DATA,IEN,LINE,NUM) ; -- create ^tmp global for list template
+1 SET LINE=LINE+1
+2 SET ^TMP("BDGSECL",$JOB,LINE,0)=DATA
+3 SET ^TMP("BDGSECL",$JOB,"IDX",LINE,NUM)=IEN
+4 QUIT
+5 ;
PAD(D,L) ;EP -- SUBRTN to pad length of data
+1 ; -- D=data L=length
+2 QUIT $EXTRACT(D_$$REPEAT^XLFSTR(" ",L),1,L)
+3 ;
SP(N) ; -- SUBRTN to pad N number of spaces
+1 QUIT $$PAD(" ",N)
+2 ;
RESET ; -- update partition for return to list manager
+1 IF $DATA(VALMQUIT)
SET VALMBCK="Q"
QUIT
+2 DO TERM^VALM0
SET VALMBCK="R"
+3 DO INIT
DO HDR
+4 QUIT
+5 ;
RESET2 ; -- return to list manager; don't update list
+1 IF $DATA(VALMQUIT)
SET VALMBCK="Q"
QUIT
+2 DO TERM^VALM0
SET VALMBCK="R"
+3 QUIT
