- ORUPREF1 ; slc/dcm - Key allocation ;Jan 08, 2021@11:59:33
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**132,397,539**;Dec 17, 1997;Build 41
- ;;397 - WAT Add ORSUPPLY to KEY
- ;;539 - WAT Add OR CPRS TESTER to KEY
- EN ;
- K ORC W $C(27),"[44;37m"
- S ORC(1)="Black^0",ORC(2)="Red^1",ORC(3)="Green^2",ORC(4)="Yellow^3",ORC(5)="Blue^4",ORC(6)="Magenta^5",ORC(7)="Cyan^6",ORC(8)="White^7"
- S ORC("B","BLACK",1)="",ORC("B","RED",2)="",ORC("B","GREEN",3)="",ORC("B","YELLOW",4)="",ORC("B","BLUE",5)="",ORC("B","MAGENTA",6)="",ORC("B","CYAN",7)="",ORC("B","WHITE",8)=""
- K ORBACK D DISP,SEL S ORF=$S(Y'=-1:Y,1:37)
- S ORBACK=1 D DISP,SEL S ORB=$S(Y'=-1:Y,1:40)
- W !,$C(27),"["_(29+ORF)_";"_(39+ORB)_"m"
- END K ORBACK,ORF,ORB,ORC,ORI
- Q
- DISP F ORI=1:1:8 W !?10,$C(27),"["_($S($D(ORBACK):40+$P(ORC(ORI),"^",2),1:30+$P(ORC(ORI),"^",2))_"m"),ORI_" ",$P(ORC(ORI),"^")_$E(" ",1,7-$L($P(ORC(ORI),"^"))) W $C(27),"["_($S($D(ORBACK):"44;37",1:"44;37")_"m")
- Q
- SEL S Y=-1 W !!,"Select "_$S($D(ORBACK):"BACKGROUND",1:"FOREGROUND")_" COLOR: " R X:DTIME Q:'$T!(X["^")!(X="") D UP
- I X="BL" W !,"Please be more specific" G SEL
- I $D(ORC("B",X)) S X=$O(ORC("B",X,0)) G S1
- I $E($O(ORC("B",X)),1,$L(X))=X,X'="BL" S X=$O(ORC("B",X)),X=$O(ORC("B",X,0)) G S1
- I X'?1N!('$D(ORC(X))) W !,"Select a number for one of the choices shown" G SEL
- S1 W " ",$C(27),"["_($S($D(ORBACK):40+$P(ORC(X),"^",2),1:30+$P(ORC(X),"^",2))_"m"),$P(ORC(X),"^") S Y=X
- W $C(27),"["_($S($D(ORBACK):"44;37",1:"44;37")_"m")
- Q
- UP ;Upper case
- F %=1:1:$L(X) I $E(X,%)?1L S X=$E(X,1,%-1)_$C($A(X,%)-32)_$E(X,%+1,99)
- Q
- KEY ;Edit user security keys
- N I
- S OREND=0,ORVER=+($G(^DD(200,0,"VR")))
- F ORKEY="ORES","ORELSE","OREMAS","ORSUPPLY","OR CPRS TESTER" D K1 Q:OREND W ! F I=1:1:(IOM-1) W "="
- S OREND=0 K DLAYGO,DA,DR,DIE,DIC,OREND,ORK,ORKEY,ORHEAD,ORVER
- Q
- K1 N % I '$D(^DIC(19.1,"B",ORKEY)) W !,ORKEY_" is not in the Security Key file" Q
- S ORK=$O(^DIC(19.1,"B",ORKEY,0)) I 'ORK!('$D(^DIC(19.1,ORK))) W !,ORKEY_" is not in the Security Key file" Q
- W !!,"KEY: "_ORKEY,! S I=0 F S I=$O(^DIC(19.1,ORK,1,I)) Q:I<1 W !,^(I,0)
- K2 W !!,"Edit Holders" S %=1 D YN^DICN S:%=-1 OREND=1
- I %=0 W !!,"Enter YES to edit holders of this key, NO to quit." G K2
- Q:%'=1
- W ! D K7
- Q
- K7 ;edits holders for Kernel V7.0 in file #200
- N DIC,Y
- S DIC=200,DIC(0)="AEQM",DIC("A")="Select HOLDER: "
- F D ^DIC Q:Y<1 S ORDUZ=Y,ORHAVE=$D(^XUSEC(ORKEY,+ORDUZ)) D K7SET:'ORHAVE,K7DEL:ORHAVE Q:OREND
- K ORDUZ,ORHAVE Q
- K7DEL ;deletes ORKEY from person
- N DA,DIK
- W !?10,"Delete key" S %=1 D YN^DICN I (%<0) S OREND=1 Q
- I %=2 W !?15,"Nothing changed!",! Q
- I %=0 D G K7DEL
- .W !?7,"This person already holds the "_ORKEY_" key; answer YES"
- .W !?7,"to de-allocate this key from this user."
- .W !!?7,"HOLDER: "_$P(ORDUZ,"^",2)
- S DA=$O(^VA(200,+ORDUZ,51,"B",ORK,0)),DA(1)=+ORDUZ
- I DA S DIK="^VA(200,"_DA(1)_",51," D ^DIK
- W !?15,$S(DA:"DELETED!",1:"Error: ^XUSEC not consistent with keys in User file"),!
- Q
- K7SET ;allocates ORKEY to person
- N DIC,DA,DINUM,X
- I '$D(^VA(200,+ORDUZ,51,0)) S ^VA(200,+ORDUZ,51,0)="^200.051PA^^"
- S DA(1)=+ORDUZ,DIC="^VA(200,"_DA(1)_",51,",DIC(0)="L",(DINUM,X)=ORK
- D FILE^DICN W !?15,$S(Y>0:"Added.",1:"Error - not added."),!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORUPREF1 3243 printed Feb 19, 2025@00:01:02 Page 2
- ORUPREF1 ; slc/dcm - Key allocation ;Jan 08, 2021@11:59:33
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**132,397,539**;Dec 17, 1997;Build 41
- +2 ;;397 - WAT Add ORSUPPLY to KEY
- +3 ;;539 - WAT Add OR CPRS TESTER to KEY
- EN ;
- +1 KILL ORC
- WRITE $CHAR(27),"[44;37m"
- +2 SET ORC(1)="Black^0"
- SET ORC(2)="Red^1"
- SET ORC(3)="Green^2"
- SET ORC(4)="Yellow^3"
- SET ORC(5)="Blue^4"
- SET ORC(6)="Magenta^5"
- SET ORC(7)="Cyan^6"
- SET ORC(8)="White^7"
- +3 SET ORC("B","BLACK",1)=""
- SET ORC("B","RED",2)=""
- SET ORC("B","GREEN",3)=""
- SET ORC("B","YELLOW",4)=""
- SET ORC("B","BLUE",5)=""
- SET ORC("B","MAGENTA",6)=""
- SET ORC("B","CYAN",7)=""
- SET ORC("B","WHITE",8)=""
- +4 KILL ORBACK
- DO DISP
- DO SEL
- SET ORF=$SELECT(Y'=-1:Y,1:37)
- +5 SET ORBACK=1
- DO DISP
- DO SEL
- SET ORB=$SELECT(Y'=-1:Y,1:40)
- +6 WRITE !,$CHAR(27),"["_(29+ORF)_";"_(39+ORB)_"m"
- END KILL ORBACK,ORF,ORB,ORC,ORI
- +1 QUIT
- DISP FOR ORI=1:1:8
- WRITE !?10,$CHAR(27),"["_($SELECT($DATA(ORBACK):40+$PIECE(ORC(ORI),"^",2),1:30+$PIECE(ORC(ORI),"^",2))_"m"),ORI_" ",$PIECE(ORC(ORI),"^")_$EXTRACT(" ",1,7-$LENGTH($PIECE(ORC(ORI),"^")))
- WRITE $CHAR(27),"["_($SELECT($DATA(ORBACK):"44;37",1:"44;37")_"m")
- +1 QUIT
- SEL SET Y=-1
- WRITE !!,"Select "_$SELECT($DATA(ORBACK):"BACKGROUND",1:"FOREGROUND")_" COLOR: "
- READ X:DTIME
- if '$TEST!(X["^")!(X="")
- QUIT
- DO UP
- +1 IF X="BL"
- WRITE !,"Please be more specific"
- GOTO SEL
- +2 IF $DATA(ORC("B",X))
- SET X=$ORDER(ORC("B",X,0))
- GOTO S1
- +3 IF $EXTRACT($ORDER(ORC("B",X)),1,$LENGTH(X))=X
- IF X'="BL"
- SET X=$ORDER(ORC("B",X))
- SET X=$ORDER(ORC("B",X,0))
- GOTO S1
- +4 IF X'?1N!('$DATA(ORC(X)))
- WRITE !,"Select a number for one of the choices shown"
- GOTO SEL
- S1 WRITE " ",$CHAR(27),"["_($SELECT($DATA(ORBACK):40+$PIECE(ORC(X),"^",2),1:30+$PIECE(ORC(X),"^",2))_"m"),$PIECE(ORC(X),"^")
- SET Y=X
- +1 WRITE $CHAR(27),"["_($SELECT($DATA(ORBACK):"44;37",1:"44;37")_"m")
- +2 QUIT
- UP ;Upper case
- +1 FOR %=1:1:$LENGTH(X)
- IF $EXTRACT(X,%)?1L
- SET X=$EXTRACT(X,1,%-1)_$CHAR($ASCII(X,%)-32)_$EXTRACT(X,%+1,99)
- +2 QUIT
- KEY ;Edit user security keys
- +1 NEW I
- +2 SET OREND=0
- SET ORVER=+($GET(^DD(200,0,"VR")))
- +3 FOR ORKEY="ORES","ORELSE","OREMAS","ORSUPPLY","OR CPRS TESTER"
- DO K1
- if OREND
- QUIT
- WRITE !
- FOR I=1:1:(IOM-1)
- WRITE "="
- +4 SET OREND=0
- KILL DLAYGO,DA,DR,DIE,DIC,OREND,ORK,ORKEY,ORHEAD,ORVER
- +5 QUIT
- K1 NEW %
- IF '$DATA(^DIC(19.1,"B",ORKEY))
- WRITE !,ORKEY_" is not in the Security Key file"
- QUIT
- +1 SET ORK=$ORDER(^DIC(19.1,"B",ORKEY,0))
- IF 'ORK!('$DATA(^DIC(19.1,ORK)))
- WRITE !,ORKEY_" is not in the Security Key file"
- QUIT
- +2 WRITE !!,"KEY: "_ORKEY,!
- SET I=0
- FOR
- SET I=$ORDER(^DIC(19.1,ORK,1,I))
- if I<1
- QUIT
- WRITE !,^(I,0)
- K2 WRITE !!,"Edit Holders"
- SET %=1
- DO YN^DICN
- if %=-1
- SET OREND=1
- +1 IF %=0
- WRITE !!,"Enter YES to edit holders of this key, NO to quit."
- GOTO K2
- +2 if %'=1
- QUIT
- +3 WRITE !
- DO K7
- +4 QUIT
- K7 ;edits holders for Kernel V7.0 in file #200
- +1 NEW DIC,Y
- +2 SET DIC=200
- SET DIC(0)="AEQM"
- SET DIC("A")="Select HOLDER: "
- +3 FOR
- DO ^DIC
- if Y<1
- QUIT
- SET ORDUZ=Y
- SET ORHAVE=$DATA(^XUSEC(ORKEY,+ORDUZ))
- if 'ORHAVE
- DO K7SET
- if ORHAVE
- DO K7DEL
- if OREND
- QUIT
- +4 KILL ORDUZ,ORHAVE
- QUIT
- K7DEL ;deletes ORKEY from person
- +1 NEW DA,DIK
- +2 WRITE !?10,"Delete key"
- SET %=1
- DO YN^DICN
- IF (%<0)
- SET OREND=1
- QUIT
- +3 IF %=2
- WRITE !?15,"Nothing changed!",!
- QUIT
- +4 IF %=0
- Begin DoDot:1
- +5 WRITE !?7,"This person already holds the "_ORKEY_" key; answer YES"
- +6 WRITE !?7,"to de-allocate this key from this user."
- +7 WRITE !!?7,"HOLDER: "_$PIECE(ORDUZ,"^",2)
- End DoDot:1
- GOTO K7DEL
- +8 SET DA=$ORDER(^VA(200,+ORDUZ,51,"B",ORK,0))
- SET DA(1)=+ORDUZ
- +9 IF DA
- SET DIK="^VA(200,"_DA(1)_",51,"
- DO ^DIK
- +10 WRITE !?15,$SELECT(DA:"DELETED!",1:"Error: ^XUSEC not consistent with keys in User file"),!
- +11 QUIT
- K7SET ;allocates ORKEY to person
- +1 NEW DIC,DA,DINUM,X
- +2 IF '$DATA(^VA(200,+ORDUZ,51,0))
- SET ^VA(200,+ORDUZ,51,0)="^200.051PA^^"
- +3 SET DA(1)=+ORDUZ
- SET DIC="^VA(200,"_DA(1)_",51,"
- SET DIC(0)="L"
- SET (DINUM,X)=ORK
- +4 DO FILE^DICN
- WRITE !?15,$SELECT(Y>0:"Added.",1:"Error - not added."),!
- +5 QUIT