ORWDAL33 ;SLC/DAN - Allergy calls to support windows ;7/27/06 11:03
;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26
;
CLINUSER(ORY) ;can user mark allergy as entered in error
N DIC,X,PRM,Y,ORLST,ORX,PLIST,VALUE
S DIC=8989.51,DIC(0)="MX",X="OR ALLERGY ENTERED IN ERROR" D ^DIC
I Y=-1 S ORY=0 Q ;Parameter not found so quit
S PRM=+Y
;Check USER level
S ORY=$$GET^XPAR("USR",PRM) I ORY'="" Q
;Check USER CLASS
D ENVAL^XPAR(.ORLST,PRM)
I ORLST>0 D
. S ORX="" F S ORX=$O(ORLST(ORX)) Q:ORX="" D
. . Q:ORX'["USR(8930"
. . I $$ISA^USRLM(DUZ,+ORX) S VALUE(+ORX)=ORLST(ORX,1)
. S ORX=0 F S ORX=$O(VALUE(ORX)) Q:'+ORX D REMOVE(ORX)
. S ORX=0 F S ORX=$O(VALUE(ORX)) Q:'+ORX S VALUE=$G(VALUE)!(VALUE(ORX))
S ORY=$G(VALUE)
I ORY'="" Q
;Check division and system
S ORY=$$GET^XPAR("DIV^SYS",PRM) I ORY'="" Q
S ORY=0 Q
;
REMOVE(SUB) ;Remove values at higher level classes
N IEN
S IEN=0 F S IEN=$O(^USR(8930,"AD",SUB,IEN)) Q:'+IEN D
.I $D(^USR(8930,"AD",IEN)) D REMOVE(IEN) ;Recursive call
.K VALUE(IEN)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDAL33 1079 printed Nov 22, 2024@17:45:09 Page 2
ORWDAL33 ;SLC/DAN - Allergy calls to support windows ;7/27/06 11:03
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**215,260**;Dec 17, 1997;Build 26
+2 ;
CLINUSER(ORY) ;can user mark allergy as entered in error
+1 NEW DIC,X,PRM,Y,ORLST,ORX,PLIST,VALUE
+2 SET DIC=8989.51
SET DIC(0)="MX"
SET X="OR ALLERGY ENTERED IN ERROR"
DO ^DIC
+3 ;Parameter not found so quit
IF Y=-1
SET ORY=0
QUIT
+4 SET PRM=+Y
+5 ;Check USER level
+6 SET ORY=$$GET^XPAR("USR",PRM)
IF ORY'=""
QUIT
+7 ;Check USER CLASS
+8 DO ENVAL^XPAR(.ORLST,PRM)
+9 IF ORLST>0
Begin DoDot:1
+10 SET ORX=""
FOR
SET ORX=$ORDER(ORLST(ORX))
if ORX=""
QUIT
Begin DoDot:2
+11 if ORX'["USR(8930"
QUIT
+12 IF $$ISA^USRLM(DUZ,+ORX)
SET VALUE(+ORX)=ORLST(ORX,1)
End DoDot:2
+13 SET ORX=0
FOR
SET ORX=$ORDER(VALUE(ORX))
if '+ORX
QUIT
DO REMOVE(ORX)
+14 SET ORX=0
FOR
SET ORX=$ORDER(VALUE(ORX))
if '+ORX
QUIT
SET VALUE=$GET(VALUE)!(VALUE(ORX))
End DoDot:1
+15 SET ORY=$GET(VALUE)
+16 IF ORY'=""
QUIT
+17 ;Check division and system
+18 SET ORY=$$GET^XPAR("DIV^SYS",PRM)
IF ORY'=""
QUIT
+19 SET ORY=0
QUIT
+20 ;
REMOVE(SUB) ;Remove values at higher level classes
+1 NEW IEN
+2 SET IEN=0
FOR
SET IEN=$ORDER(^USR(8930,"AD",SUB,IEN))
if '+IEN
QUIT
Begin DoDot:1
+3 ;Recursive call
IF $DATA(^USR(8930,"AD",IEN))
DO REMOVE(IEN)
+4 KILL VALUE(IEN)
End DoDot:1
+5 QUIT
