- SROKEY ;B'HAM ISC/MAM - UPDATE KEYS RESTRICTING ENTRIES ; 9 JAN 1992
- ;;3.0; Surgery ;;24 Jun 93
- W @IOF,!,"Add 'PERSON' Field Restrictions: ",! S SRSOUT=0 K DIC,DA,DO S DIC=1,DIC(0)="QEAMZ",DIC("A")="Select File: " D ^DIC K DIC I Y<0 S SRSOUT=1 G END
- S SRFILE=Y,DI=+Y,N=0 D DI^DIU I Y<0 S SRSOUT=1 G END
- S SRFILE=DI,SRFIELD=+Y,SRENTRY=DI_","_SRFIELD
- I '$O(^SRP("B",SRENTRY,0)) D ADD G END
- S SRP=$O(^SRP("B",SRENTRY,0))
- EXIST ; edit existing entry
- I '$O(^SRP(SRP,1,0)) S ^SRP(SRP,1,0)="^131.03^^"
- I $O(^SRP(SRP,1,0)) W !!,"Keys Currently used to Restrict Entries: "
- I '$O(^SRP(SRP,1,0)) W !!,"There are no keys restricting entries in this field."
- S (CNT,KEY)=0 F S KEY=$O(^SRP(SRP,1,KEY)) Q:'KEY S CNT=CNT+1,SRKEY(CNT)=$P(^SRP(SRP,1,KEY,0),"^")_"^"_KEY W:CNT=1 ! W !,?2,CNT_".",?5,$P(SRKEY(CNT),"^")
- ANOTHER W !!,"Do you want to add a key ? YES// " R SRYN:DTIME I '$T!(SRYN["^") S SRSOUT=1 G END
- S SRYN=$E(SRYN) S:SRYN="" SRYN="Y"
- I "YyNn"'[SRYN W !!,"Enter 'YES' or RETURN to enter a key which will be used to restrict",!,"access to this field, or 'NO' if no additional keys are required." G ANOTHER
- I "Yy"[SRYN W ! S CNT=0,Y=1 F Q:Y<0 K DIC S DIC=19.1,DIC(0)="QEAMZ",DIC("A")="Select Additional Key: " D ^DIC I Y>0 S CNT=CNT+1,ADDKEY(CNT)=$P(Y,"^",2)
- I $D(ADDKEY(1)) W !!,"Entering Keys..."
- S CNT=0 F S CNT=$O(ADDKEY(CNT)) Q:'CNT K DA,DD,DO,DIC S DA(1)=SRP,DLAYGO=130.03,DIC(0)="L",DIC="^SRP("_SRP_",1,",X=ADDKEY(CNT) D FILE^DICN K DLAYGO,DIC
- END D ^SRSKILL W @IOF
- Q
- RET W !!,"Press RETURN to continue, or '^' to quit: " R X:DTIME I '$T!(X["^") S SRSOUT=1
- Q
- ADD ; add entry in PERSON FIELD RESTRICTION file
- W !!,"This field does not exist in the PERSON FIELD RESTRICTION file. Do you",!,"want to add it ? YES// " R SRYN:DTIME I '$T!(SRYN["^") S SRYN="N",SRSOUT=1 Q
- S SRYN=$E(SRYN) I "YyNn"'[SRYN W !!,"Enter RETURN or 'YES' to add this entry to the file so that restrictions may",!,"be applied, or 'NO' to quit this option." G ADD
- I "Yy"'[SRYN S SRSOUT=1 Q
- K DIC,DD,DINUM,DO,DA S DIC="^SRP(",DIC(0)="L",DLAYGO=131,X=SRENTRY D FILE^DICN S SRP=+Y
- W ! K DIE,DA,DR S DA=SRP,DIE=131,DR="5T;3T" D ^DIE K DR,DA
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROKEY 2167 printed Feb 19, 2025@00:10:30 Page 2
- SROKEY ;B'HAM ISC/MAM - UPDATE KEYS RESTRICTING ENTRIES ; 9 JAN 1992
- +1 ;;3.0; Surgery ;;24 Jun 93
- +2 WRITE @IOF,!,"Add 'PERSON' Field Restrictions: ",!
- SET SRSOUT=0
- KILL DIC,DA,DO
- SET DIC=1
- SET DIC(0)="QEAMZ"
- SET DIC("A")="Select File: "
- DO ^DIC
- KILL DIC
- IF Y<0
- SET SRSOUT=1
- GOTO END
- +3 SET SRFILE=Y
- SET DI=+Y
- SET N=0
- DO DI^DIU
- IF Y<0
- SET SRSOUT=1
- GOTO END
- +4 SET SRFILE=DI
- SET SRFIELD=+Y
- SET SRENTRY=DI_","_SRFIELD
- +5 IF '$ORDER(^SRP("B",SRENTRY,0))
- DO ADD
- GOTO END
- +6 SET SRP=$ORDER(^SRP("B",SRENTRY,0))
- EXIST ; edit existing entry
- +1 IF '$ORDER(^SRP(SRP,1,0))
- SET ^SRP(SRP,1,0)="^131.03^^"
- +2 IF $ORDER(^SRP(SRP,1,0))
- WRITE !!,"Keys Currently used to Restrict Entries: "
- +3 IF '$ORDER(^SRP(SRP,1,0))
- WRITE !!,"There are no keys restricting entries in this field."
- +4 SET (CNT,KEY)=0
- FOR
- SET KEY=$ORDER(^SRP(SRP,1,KEY))
- if 'KEY
- QUIT
- SET CNT=CNT+1
- SET SRKEY(CNT)=$PIECE(^SRP(SRP,1,KEY,0),"^")_"^"_KEY
- if CNT=1
- WRITE !
- WRITE !,?2,CNT_".",?5,$PIECE(SRKEY(CNT),"^")
- ANOTHER WRITE !!,"Do you want to add a key ? YES// "
- READ SRYN:DTIME
- IF '$TEST!(SRYN["^")
- SET SRSOUT=1
- GOTO END
- +1 SET SRYN=$EXTRACT(SRYN)
- if SRYN=""
- SET SRYN="Y"
- +2 IF "YyNn"'[SRYN
- WRITE !!,"Enter 'YES' or RETURN to enter a key which will be used to restrict",!,"access to this field, or 'NO' if no additional keys are required."
- GOTO ANOTHER
- +3 IF "Yy"[SRYN
- WRITE !
- SET CNT=0
- SET Y=1
- FOR
- if Y<0
- QUIT
- KILL DIC
- SET DIC=19.1
- SET DIC(0)="QEAMZ"
- SET DIC("A")="Select Additional Key: "
- DO ^DIC
- IF Y>0
- SET CNT=CNT+1
- SET ADDKEY(CNT)=$PIECE(Y,"^",2)
- +4 IF $DATA(ADDKEY(1))
- WRITE !!,"Entering Keys..."
- +5 SET CNT=0
- FOR
- SET CNT=$ORDER(ADDKEY(CNT))
- if 'CNT
- QUIT
- KILL DA,DD,DO,DIC
- SET DA(1)=SRP
- SET DLAYGO=130.03
- SET DIC(0)="L"
- SET DIC="^SRP("_SRP_",1,"
- SET X=ADDKEY(CNT)
- DO FILE^DICN
- KILL DLAYGO,DIC
- END DO ^SRSKILL
- WRITE @IOF
- +1 QUIT
- RET WRITE !!,"Press RETURN to continue, or '^' to quit: "
- READ X:DTIME
- IF '$TEST!(X["^")
- SET SRSOUT=1
- +1 QUIT
- ADD ; add entry in PERSON FIELD RESTRICTION file
- +1 WRITE !!,"This field does not exist in the PERSON FIELD RESTRICTION file. Do you",!,"want to add it ? YES// "
- READ SRYN:DTIME
- IF '$TEST!(SRYN["^")
- SET SRYN="N"
- SET SRSOUT=1
- QUIT
- +2 SET SRYN=$EXTRACT(SRYN)
- IF "YyNn"'[SRYN
- WRITE !!,"Enter RETURN or 'YES' to add this entry to the file so that restrictions may",!,"be applied, or 'NO' to quit this option."
- GOTO ADD
- +3 IF "Yy"'[SRYN
- SET SRSOUT=1
- QUIT
- +4 KILL DIC,DD,DINUM,DO,DA
- SET DIC="^SRP("
- SET DIC(0)="L"
- SET DLAYGO=131
- SET X=SRENTRY
- DO FILE^DICN
- SET SRP=+Y
- +5 WRITE !
- KILL DIE,DA,DR
- SET DA=SRP
- SET DIE=131
- SET DR="5T;3T"
- DO ^DIE
- KILL DR,DA
- +6 QUIT