ORWDAL33.m

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

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