AQAOSEC ; IHS/ORDC/LJF - SECURITY CHECK UTILITY ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;One of the most important routines in the package. Handles extra
;security levels needed for such sensitive data. Contains various
;entry points called by entry actions & screens on DIC calls.
;
Q
ENTRY ;EP; used by options to check AQAOPT variable
;called by entry actions; sets xquit if access not correct
;
K AQAOCHK("VAR")
I '$D(AQAOUA("USER")) D D CHECK Q
.S AQAOCHK("VAR")="***USER QI ACCESS INFO MISSING***"
I $P(AQAOUA("USER"),U,6)="",'$D(AQAOUA("USER","ACCESS")) D D CHECK Q
.S AQAOCHK("VAR")="***USER QI ACCESS INFO MISSING***"
D ACCESS
;
; >> quit option if check variable set
CHECK I $D(AQAOCHK("VAR")) W *7,!!,AQAOCHK("VAR") K AQAOCHK("VAR") S XQUIT=""
Q
;
ACCESS ; >>> SUBRTN to check user's access level
I '$D(AQAOCHK("ACTION")) S AQAOCHK("VAR")="***NO ACTION LEVEL SET***" Q
I AQAOCHK("ACTION")="INQUIRY" Q
I $P(AQAOUA("USER"),U,6)="QA" Q ;pkg admin access
I (AQAOCHK("ACTION")="ADMIN") D Q
.S AQAOCHK("VAR")="** YOU ARE NOT A DESIGNATED PACKAGE ADMINISTRATOR!"
I $P(AQAOUA("USER"),U,6)="QI" Q ;qi staff
I AQAOCHK("ACTION")="EDIT" Q ;PATCH 4
;I AQAOCHK("ACTION")="EDIT" D Q ;PATCH 4
;.S:(AQAOUA("USER","ACCESS")="1") AQAOCHK("VAR")="***YOU DO NOT HAVE ACCESS TO EDIT QI DATA, SEE YOUR SUPERVISOR***" ;PATCH 4
S AQAOCHK("VAR")="***ACTION LEVEL NOT SET CORRECTLY***"
Q
;
;
INDCHK ;EP; called by DIC("S") to screen indicators
N AQAOI K AQAOCHK("OK") Q:'$D(AQAOUA("USER"))
I $P(AQAOUA("USER"),U,6)["Q" S AQAOCHK("OK")="" D RESETI Q ;qi staff
I $O(^AQAO(2,Y,"QTM",0))="" S AQAOCHK("OK")="" D RESETI Q ;open indtr
;
S AQAOI=0 ;loop thru qi teams for indicator
F S AQAOI=$O(^AQAO(2,Y,"QTM",AQAOI)) Q:AQAOI'=+AQAOI D
.Q:'$D(^AQAO(2,Y,"QTM",AQAOI,0)) S AQAOIII=$P(^(0),U) ;team ifn
.I $D(AQAOUA("USER",AQAOIII)) D TEAMCHK ;check user's access level
;
RESETI K AQAOI,AQAOIII I ^AQAO(2,Y,0) ;reset naked ref
Q
;
;
OCCCHK ;EP; called by DIC("S") to screen occurrence
K AQAOCHK("OK") Q:'$D(AQAOUA("USER"))
I $P(^AQAOC(Y,0),U,9)'=DUZ(2) D RESETO Q ;another facility
I $P(AQAOUA("USER"),U,6)["Q" S AQAOCHK("OK")="" D RESETO Q ;qi staff
;
S AQAOI=$P(^AQAOC(Y,0),U,8) ;indicator
I '$O(^AQAO(2,AQAOI,"QTM",0)) S AQAOCHK("OK")="" D RESETO Q ;open ind
;
S AQAOII=0 ;check access via qi team
F S AQAOII=$O(^AQAO(2,AQAOI,"QTM",AQAOII)) Q:AQAOII'=+AQAOII D
.Q:'$D(^AQAO(2,AQAOI,"QTM",AQAOII,0)) S AQAOIII=$P(^(0),U)
.I $D(AQAOUA("USER",AQAOIII)) D
..I +$O(^AQAO1(1,AQAOIII,1,0)),$P(^(0),U,7)]"" Q:'$D(^AQAO1(1,"AB",$P(^AQAOC(Y,0),U,7),AQAOIII)) ;service specific occ
..D TEAMCHK ;check user access level
I $D(AQAOCHK("OK"))!('$D(AQAORVW)) D RESETO Q
;
;check for referrals
I $$INITIAL S AQAOCHK("OK")="" D RESETO Q ;on initial review
I $$REVW S AQAOCHK("OK")="" ;on other reviews
;
RESETO K AQAOI,AQAOII,AQAOIII I ^AQAOC(Y,0) ;reset naked ref
Q
;
INITIAL() ;EXTRN VAR to see if occ was referred on initial review
N AQAOI,X S X=0,AQAOI=$P($G(^AQAOC(Y,1)),U,9)
I AQAOI]"" D
.I AQAOI["AQAO(9" S:(+AQAOI=DUZ) X=1
.I AQAOI["AQAO1(1" S:$D(AQAOUA("USER",+AQAOI)) X=1
.I X=0 S X=$$IADDRV ;check additional ref
Q X
;
IADDRV() ;EXTRN VAR to see if any additional referrals made on initial review
N AQAOI,AQAOII,X S X=0
S AQAOI=0
F S AQAOI=$O(^AQAOC(Y,"IADDRV",AQAOI)) Q:AQAOI'=+AQAOI Q:X=1 D
.Q:'$D(^AQAOC(Y,"IADDRV",AQAOI,0)) S AQAOII=$P(^(0),U)
.Q:AQAOII="" I AQAOII["AQAO(9" S:+AQAOII=DUZ X=1
.I AQAOII["AQAO1(1" S:$D(AQAOUA("USER",+AQAOII)) X=1
Q X
;
REVW() ;EXTRN VAR to see if occ referred during other reviews
N AQAOI,AQAOII,X S X=0
S AQAOI=0
F S AQAOI=$O(^AQAOC(Y,"REV",AQAOI)) Q:AQAOI'=+AQAOI Q:X=1 D
.Q:'$D(^AQAOC(Y,"REV",AQAOI,0)) S AQAOII=$P(^(0),U,9) ;PATCH 4
.Q:AQAOII="" I AQAOII["AQAO(9" S:+AQAOII=DUZ X=1
.I AQAOII["AQAO1(1" S:$D(AQAOUA("USER",+AQAOII)) X=1
.I X=0 S X=$$ADDRV(AQAOI) ;additional referrals
Q X
;
ADDRV(AQAOI) ;EXTRN VAR to see if additional ref made on other reviews
N AQAOIII,AQAOII,X S X=0
S AQAOII=0
F S AQAOII=$O(^AQAOC(Y,"REV",AQAOI,"ADDRV",AQAOII)) Q:AQAOII'=+AQAOII Q:X=1 D
.Q:'$D(^AQAOC(Y,"REV",AQAOI,"ADDRV",AQAOII,0)) S AQAOIII=$P(^(0),U)
.Q:AQAOIII="" I AQAOIII["AQAO(9" S:+AQAOIII=DUZ X=1
.I AQAOIII["AQAO1(1" S:$D(AQAOUA("USER",+AQAOIII)) X=1
Q X
;
;
ACTCHK ;EP; called by DIC("S") to screen actions
K AQAOCHK("OK") Q:'$D(AQAOUA("USER"))
I $P(^AQAO(5,Y,0),U,12)'=DUZ(2) D RESETA Q ;another facility
I $P(AQAOUA("USER"),U,6)["Q" S AQAOCHK("OK")="" D RESETA Q ;qi staff
;
S AQAOI=$P(^AQAO(5,Y,0),U,14) ;indicator
I '$O(^AQAO(2,AQAOI,"QTM",0)) S AQAOCHK("OK")="" D RESETA Q ;open ind
;
S AQAOII=0 ;check access via qi team
F S AQAOII=$O(^AQAO(2,AQAOI,"QTM",AQAOII)) Q:AQAOII'=+AQAOII D
.Q:'$D(^AQAO(2,AQAOI,"QTM",AQAOII,0)) S AQAOIII=$P(^(0),U)
.I $D(AQAOUA("USER",AQAOIII)) D TEAMCHK ;check user access level
;
RESETA K AQAOI,AQAOII,AQAOIII I ^AQAO(5,Y,0) ;reset naked ref
Q
;
TEAMCHK ; >> SUBRTN called by INDCHK and OCCCHK
;checks access level by team
I AQAOUA("USER",AQAOIII)="1",(AQAOCHK("ACTION")="INQUIRY") S AQAOCHK("OK")="" Q
I AQAOUA("USER",AQAOIII)="2" S AQAOCHK("OK")="" Q
Q
AQAOSEC ; IHS/ORDC/LJF - SECURITY CHECK UTILITY ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;One of the most important routines in the package. Handles extra
+4 ;security levels needed for such sensitive data. Contains various
+5 ;entry points called by entry actions & screens on DIC calls.
+6 ;
+7 QUIT
ENTRY ;EP; used by options to check AQAOPT variable
+1 ;called by entry actions; sets xquit if access not correct
+2 ;
+3 KILL AQAOCHK("VAR")
+4 IF '$DATA(AQAOUA("USER"))
Begin DoDot:1
+5 SET AQAOCHK("VAR")="***USER QI ACCESS INFO MISSING***"
End DoDot:1
DO CHECK
QUIT
+6 IF $PIECE(AQAOUA("USER"),U,6)=""
IF '$DATA(AQAOUA("USER","ACCESS"))
Begin DoDot:1
+7 SET AQAOCHK("VAR")="***USER QI ACCESS INFO MISSING***"
End DoDot:1
DO CHECK
QUIT
+8 DO ACCESS
+9 ;
+10 ; >> quit option if check variable set
CHECK IF $DATA(AQAOCHK("VAR"))
WRITE *7,!!,AQAOCHK("VAR")
KILL AQAOCHK("VAR")
SET XQUIT=""
+1 QUIT
+2 ;
ACCESS ; >>> SUBRTN to check user's access level
+1 IF '$DATA(AQAOCHK("ACTION"))
SET AQAOCHK("VAR")="***NO ACTION LEVEL SET***"
QUIT
+2 IF AQAOCHK("ACTION")="INQUIRY"
QUIT
+3 ;pkg admin access
IF $PIECE(AQAOUA("USER"),U,6)="QA"
QUIT
+4 IF (AQAOCHK("ACTION")="ADMIN")
Begin DoDot:1
+5 SET AQAOCHK("VAR")="** YOU ARE NOT A DESIGNATED PACKAGE ADMINISTRATOR!"
End DoDot:1
QUIT
+6 ;qi staff
IF $PIECE(AQAOUA("USER"),U,6)="QI"
QUIT
+7 ;PATCH 4
IF AQAOCHK("ACTION")="EDIT"
QUIT
+8 ;I AQAOCHK("ACTION")="EDIT" D Q ;PATCH 4
+9 ;.S:(AQAOUA("USER","ACCESS")="1") AQAOCHK("VAR")="***YOU DO NOT HAVE ACCESS TO EDIT QI DATA, SEE YOUR SUPERVISOR***" ;PATCH 4
+10 SET AQAOCHK("VAR")="***ACTION LEVEL NOT SET CORRECTLY***"
+11 QUIT
+12 ;
+13 ;
INDCHK ;EP; called by DIC("S") to screen indicators
+1 NEW AQAOI
KILL AQAOCHK("OK")
IF '$DATA(AQAOUA("USER"))
QUIT
+2 ;qi staff
IF $PIECE(AQAOUA("USER"),U,6)["Q"
SET AQAOCHK("OK")=""
DO RESETI
QUIT
+3 ;open indtr
IF $ORDER(^AQAO(2,Y,"QTM",0))=""
SET AQAOCHK("OK")=""
DO RESETI
QUIT
+4 ;
+5 ;loop thru qi teams for indicator
SET AQAOI=0
+6 FOR
SET AQAOI=$ORDER(^AQAO(2,Y,"QTM",AQAOI))
IF AQAOI'=+AQAOI
QUIT
Begin DoDot:1
+7 ;team ifn
IF '$DATA(^AQAO(2,Y,"QTM",AQAOI,0))
QUIT
SET AQAOIII=$PIECE(^(0),U)
+8 ;check user's access level
IF $DATA(AQAOUA("USER",AQAOIII))
DO TEAMCHK
End DoDot:1
+9 ;
RESETI ;reset naked ref
KILL AQAOI,AQAOIII
IF ^AQAO(2,Y,0)
+1 QUIT
+2 ;
+3 ;
OCCCHK ;EP; called by DIC("S") to screen occurrence
+1 KILL AQAOCHK("OK")
IF '$DATA(AQAOUA("USER"))
QUIT
+2 ;another facility
IF $PIECE(^AQAOC(Y,0),U,9)'=DUZ(2)
DO RESETO
QUIT
+3 ;qi staff
IF $PIECE(AQAOUA("USER"),U,6)["Q"
SET AQAOCHK("OK")=""
DO RESETO
QUIT
+4 ;
+5 ;indicator
SET AQAOI=$PIECE(^AQAOC(Y,0),U,8)
+6 ;open ind
IF '$ORDER(^AQAO(2,AQAOI,"QTM",0))
SET AQAOCHK("OK")=""
DO RESETO
QUIT
+7 ;
+8 ;check access via qi team
SET AQAOII=0
+9 FOR
SET AQAOII=$ORDER(^AQAO(2,AQAOI,"QTM",AQAOII))
IF AQAOII'=+AQAOII
QUIT
Begin DoDot:1
+10 IF '$DATA(^AQAO(2,AQAOI,"QTM",AQAOII,0))
QUIT
SET AQAOIII=$PIECE(^(0),U)
+11 IF $DATA(AQAOUA("USER",AQAOIII))
Begin DoDot:2
+12 ;service specific occ
IF +$ORDER(^AQAO1(1,AQAOIII,1,0))
IF $PIECE(^(0),U,7)]""
IF '$DATA(^AQAO1(1,"AB",$PIECE(^AQAOC(Y,0),U,7),AQAOIII))
QUIT
+13 ;check user access level
DO TEAMCHK
End DoDot:2
End DoDot:1
+14 IF $DATA(AQAOCHK("OK"))!('$DATA(AQAORVW))
DO RESETO
QUIT
+15 ;
+16 ;check for referrals
+17 ;on initial review
IF $$INITIAL
SET AQAOCHK("OK")=""
DO RESETO
QUIT
+18 ;on other reviews
IF $$REVW
SET AQAOCHK("OK")=""
+19 ;
RESETO ;reset naked ref
KILL AQAOI,AQAOII,AQAOIII
IF ^AQAOC(Y,0)
+1 QUIT
+2 ;
INITIAL() ;EXTRN VAR to see if occ was referred on initial review
+1 NEW AQAOI,X
SET X=0
SET AQAOI=$PIECE($GET(^AQAOC(Y,1)),U,9)
+2 IF AQAOI]""
Begin DoDot:1
+3 IF AQAOI["AQAO(9"
IF (+AQAOI=DUZ)
SET X=1
+4 IF AQAOI["AQAO1(1"
IF $DATA(AQAOUA("USER",+AQAOI))
SET X=1
+5 ;check additional ref
IF X=0
SET X=$$IADDRV
End DoDot:1
+6 QUIT X
+7 ;
IADDRV() ;EXTRN VAR to see if any additional referrals made on initial review
+1 NEW AQAOI,AQAOII,X
SET X=0
+2 SET AQAOI=0
+3 FOR
SET AQAOI=$ORDER(^AQAOC(Y,"IADDRV",AQAOI))
IF AQAOI'=+AQAOI
QUIT
IF X=1
QUIT
Begin DoDot:1
+4 IF '$DATA(^AQAOC(Y,"IADDRV",AQAOI,0))
QUIT
SET AQAOII=$PIECE(^(0),U)
+5 IF AQAOII=""
QUIT
IF AQAOII["AQAO(9"
IF +AQAOII=DUZ
SET X=1
+6 IF AQAOII["AQAO1(1"
IF $DATA(AQAOUA("USER",+AQAOII))
SET X=1
End DoDot:1
+7 QUIT X
+8 ;
REVW() ;EXTRN VAR to see if occ referred during other reviews
+1 NEW AQAOI,AQAOII,X
SET X=0
+2 SET AQAOI=0
+3 FOR
SET AQAOI=$ORDER(^AQAOC(Y,"REV",AQAOI))
IF AQAOI'=+AQAOI
QUIT
IF X=1
QUIT
Begin DoDot:1
+4 ;PATCH 4
IF '$DATA(^AQAOC(Y,"REV",AQAOI,0))
QUIT
SET AQAOII=$PIECE(^(0),U,9)
+5 IF AQAOII=""
QUIT
IF AQAOII["AQAO(9"
IF +AQAOII=DUZ
SET X=1
+6 IF AQAOII["AQAO1(1"
IF $DATA(AQAOUA("USER",+AQAOII))
SET X=1
+7 ;additional referrals
IF X=0
SET X=$$ADDRV(AQAOI)
End DoDot:1
+8 QUIT X
+9 ;
ADDRV(AQAOI) ;EXTRN VAR to see if additional ref made on other reviews
+1 NEW AQAOIII,AQAOII,X
SET X=0
+2 SET AQAOII=0
+3 FOR
SET AQAOII=$ORDER(^AQAOC(Y,"REV",AQAOI,"ADDRV",AQAOII))
IF AQAOII'=+AQAOII
QUIT
IF X=1
QUIT
Begin DoDot:1
+4 IF '$DATA(^AQAOC(Y,"REV",AQAOI,"ADDRV",AQAOII,0))
QUIT
SET AQAOIII=$PIECE(^(0),U)
+5 IF AQAOIII=""
QUIT
IF AQAOIII["AQAO(9"
IF +AQAOIII=DUZ
SET X=1
+6 IF AQAOIII["AQAO1(1"
IF $DATA(AQAOUA("USER",+AQAOIII))
SET X=1
End DoDot:1
+7 QUIT X
+8 ;
+9 ;
ACTCHK ;EP; called by DIC("S") to screen actions
+1 KILL AQAOCHK("OK")
IF '$DATA(AQAOUA("USER"))
QUIT
+2 ;another facility
IF $PIECE(^AQAO(5,Y,0),U,12)'=DUZ(2)
DO RESETA
QUIT
+3 ;qi staff
IF $PIECE(AQAOUA("USER"),U,6)["Q"
SET AQAOCHK("OK")=""
DO RESETA
QUIT
+4 ;
+5 ;indicator
SET AQAOI=$PIECE(^AQAO(5,Y,0),U,14)
+6 ;open ind
IF '$ORDER(^AQAO(2,AQAOI,"QTM",0))
SET AQAOCHK("OK")=""
DO RESETA
QUIT
+7 ;
+8 ;check access via qi team
SET AQAOII=0
+9 FOR
SET AQAOII=$ORDER(^AQAO(2,AQAOI,"QTM",AQAOII))
IF AQAOII'=+AQAOII
QUIT
Begin DoDot:1
+10 IF '$DATA(^AQAO(2,AQAOI,"QTM",AQAOII,0))
QUIT
SET AQAOIII=$PIECE(^(0),U)
+11 ;check user access level
IF $DATA(AQAOUA("USER",AQAOIII))
DO TEAMCHK
End DoDot:1
+12 ;
RESETA ;reset naked ref
KILL AQAOI,AQAOII,AQAOIII
IF ^AQAO(5,Y,0)
+1 QUIT
+2 ;
TEAMCHK ; >> SUBRTN called by INDCHK and OCCCHK
+1 ;checks access level by team
+2 IF AQAOUA("USER",AQAOIII)="1"
IF (AQAOCHK("ACTION")="INQUIRY")
SET AQAOCHK("OK")=""
QUIT
+3 IF AQAOUA("USER",AQAOIII)="2"
SET AQAOCHK("OK")=""
QUIT
+4 QUIT
