AQAOUSA1 ; IHS/ORDC/LJF - PRINT ACCESS BY OCCURRENCE ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This rtn print the listing of users with access to a particular
;occurrence. It is called by ^AQAOUSA.
;
D INIT^AQAOUTIL S AQAOTY="USERS WITH ACCESS TO AN OCCURRENCE"
D HEADING^AQAOUTIL,HDG1
;
FIND ; >> find sorted user list
I '$D(^TMP("AQAOUSA",$J)) W !!,"NO DATA FOUND",! Q
S AQAOCAT=0
F S AQAOCAT=$O(^TMP("AQAOUSA",$J,AQAOCAT)) Q:AQAOCAT="" Q:AQAOSTOP=U D
.S X=$S(AQAOCAT="A":"QI STAFF",AQAOCAT="M":"QI TEAM MEMBERS",AQAOCAT="R":"PERSONAL REFERRALS",1:"TEAM REFERRALS")
.S X="*** "_X_" ***" W !!?AQAOIOMX-$L(X)/2,X,!! ;category title
.S AQAOUSN=0
.F S AQAOUSN=$O(^TMP("AQAOUSA",$J,AQAOCAT,AQAOUSN)) Q:AQAOUSN="" Q:AQAOSTOP=U D
..S AQAOUSR=0
..F S AQAOUSR=$O(^TMP("AQAOUSA",$J,AQAOCAT,AQAOUSN,AQAOUSR)) Q:AQAOUSR="" Q:AQAOSTOP=U D
...S AQAOS=^TMP("AQAOUSA",$J,AQAOCAT,AQAOUSN,AQAOUSR)
...I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG1
...W AQAOUSN
...I AQAOCAT="A" W ?40,AQAOS,! Q ;qi staff level
...I AQAOCAT="M" D Q
....F I=1:2 Q:$P(AQAOS,U,I)="" W ?40,"TEAM: ",$P(AQAOS,U,I),?60,$P(AQAOS,U,I+1),! I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG1 ;teams & access
...;
...;PATCH 4 BEGIN
...I AQAOCAT="R" D Q ;referred by name
....F I=1:1 Q:$P(AQAOS,U,I)="" Q:AQAOSTOP=U D
.....W ?40,"Referred By: ",$E($P(AQAOS,U,I),1,15),!
.....I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG1
...;
...F I=1:3 Q:$P(AQAOS,U,I)="" Q:AQAOSTOP=U D ;referred by team
....W ?40,"Referred By: ",$E($P(AQAOS,U,I),1,15),!
....W ?40,"Referred To: ",$E($P(AQAOS,U,I+1),1,15)
....W ?60," - ",$P(AQAOS,U,I+2),!!
....I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG1
...;PATCH 4 END
;
Q ;return to ^AQAOUSA
;
;
HDG1 ; >> SUBRTN to print 2nd half of heading
S X=$P(^AQAOC(AQAOIFN,0),U),X="Occurrence #"_X
W ?AQAOIOMX-$L(X)/2,X,!,AQAOLINE,!
Q
AQAOUSA1 ; IHS/ORDC/LJF - PRINT ACCESS BY OCCURRENCE ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This rtn print the listing of users with access to a particular
+4 ;occurrence. It is called by ^AQAOUSA.
+5 ;
+6 DO INIT^AQAOUTIL
SET AQAOTY="USERS WITH ACCESS TO AN OCCURRENCE"
+7 DO HEADING^AQAOUTIL
DO HDG1
+8 ;
FIND ; >> find sorted user list
+1 IF '$DATA(^TMP("AQAOUSA",$JOB))
WRITE !!,"NO DATA FOUND",!
QUIT
+2 SET AQAOCAT=0
+3 FOR
SET AQAOCAT=$ORDER(^TMP("AQAOUSA",$JOB,AQAOCAT))
IF AQAOCAT=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:1
+4 SET X=$SELECT(AQAOCAT="A":"QI STAFF",AQAOCAT="M":"QI TEAM MEMBERS",AQAOCAT="R":"PERSONAL REFERRALS",1:"TEAM REFERRALS")
+5 ;category title
SET X="*** "_X_" ***"
WRITE !!?AQAOIOMX-$LENGTH(X)/2,X,!!
+6 SET AQAOUSN=0
+7 FOR
SET AQAOUSN=$ORDER(^TMP("AQAOUSA",$JOB,AQAOCAT,AQAOUSN))
IF AQAOUSN=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:2
+8 SET AQAOUSR=0
+9 FOR
SET AQAOUSR=$ORDER(^TMP("AQAOUSA",$JOB,AQAOCAT,AQAOUSN,AQAOUSR))
IF AQAOUSR=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:3
+10 SET AQAOS=^TMP("AQAOUSA",$JOB,AQAOCAT,AQAOUSN,AQAOUSR)
+11 IF $Y>(IOSL-4)
DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HDG1
+12 WRITE AQAOUSN
+13 ;qi staff level
IF AQAOCAT="A"
WRITE ?40,AQAOS,!
QUIT
+14 IF AQAOCAT="M"
Begin DoDot:4
+15 ;teams & access
FOR I=1:2
IF $PIECE(AQAOS,U,I)=""
QUIT
WRITE ?40,"TEAM: ",$PIECE(AQAOS,U,I),?60,$PIECE(AQAOS,U,I+1),!
IF $Y>(IOSL-4)
DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HDG1
End DoDot:4
QUIT
+16 ;
+17 ;PATCH 4 BEGIN
+18 ;referred by name
IF AQAOCAT="R"
Begin DoDot:4
+19 FOR I=1:1
IF $PIECE(AQAOS,U,I)=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:5
+20 WRITE ?40,"Referred By: ",$EXTRACT($PIECE(AQAOS,U,I),1,15),!
+21 IF $Y>(IOSL-4)
DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HDG1
End DoDot:5
End DoDot:4
QUIT
+22 ;
+23 ;referred by team
FOR I=1:3
IF $PIECE(AQAOS,U,I)=""
QUIT
IF AQAOSTOP=U
QUIT
Begin DoDot:4
+24 WRITE ?40,"Referred By: ",$EXTRACT($PIECE(AQAOS,U,I),1,15),!
+25 WRITE ?40,"Referred To: ",$EXTRACT($PIECE(AQAOS,U,I+1),1,15)
+26 WRITE ?60," - ",$PIECE(AQAOS,U,I+2),!!
+27 IF $Y>(IOSL-4)
DO NEWPG^AQAOUTIL
IF AQAOSTOP=U
QUIT
DO HDG1
End DoDot:4
+28 ;PATCH 4 END
End DoDot:3
End DoDot:2
End DoDot:1
+29 ;
+30 ;return to ^AQAOUSA
QUIT
+31 ;
+32 ;
HDG1 ; >> SUBRTN to print 2nd half of heading
+1 SET X=$PIECE(^AQAOC(AQAOIFN,0),U)
SET X="Occurrence #"_X
+2 WRITE ?AQAOIOMX-$LENGTH(X)/2,X,!,AQAOLINE,!
+3 QUIT
