- 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
