ZIS31.m

%ZIS31 ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;10/13/89  13:51

 ;

 L ^%ZISL(3.54):1

 I '$T S POP=1 W:'$D(IOP) *7,"  [NOT AVAILABLE]" Q

 S X=$O(^%ZISL(3.54,"B",IO,0))

 I 'X  D FLST S ^%ZISL(3.54,"B",IO,L)="",X=L

 I '($D(^%ZISL(3.54,+X,0))#2) S ^(0)=IO_"^"_%ZISRL,A=^%ZISL(3.54,0),$P(A,"^",3)=+X,$P(A,"^",4)=$P(A,"^",4)+1,^(0)=A,IO(1,IO)="RES",%ZISD0=+X G R1

 S %ZISD0=+X

 S X=$P(^(0),"^",2) I 'X S POP=1 W:'$D(IOP) *7,"  [NOT AVAILABLE]" L  Q

 S X=X-1,$P(^(0),"^",2)=X,IO(1,IO)="RES"

 ;

R1 ;

 ;S %ZISROOT="^%ZISL(3.54,"_%ZISD0_",1," S:'$D(^%ZISL(3.54,%ZISD0,1,0)) ^(0)="^3.542^^" D FLST S ^%ZISL(3.54,%ZISD0,1,"B",L,L)="",X=L

 S:'$D(^%ZISL(3.54,%ZISD0,1,0)) ^(0)="^3.542^^"

 ;D FLST 

 F L=1:1:(%ZISRL+1) I '$D(^%ZISL(3.54,%ZISD0,1,L,0)) Q

 I '$T,L=(%ZISRL+1) S POP=1 K IO(1,IO) Q

 S ^%ZISL(3.54,%ZISD0,1,"B",L,L)="",X=L

 S ^%ZISL(3.54,%ZISD0,1,+X,0)=+X_"^"_%ZISV_"^"_$J,A=^%ZISL(3.54,%ZISD0,1,0),$P(A,"^",3)=+X,$P(A,"^",4)=$P(A,"^",4)+1,^(0)=A

 L  Q

 ;

FLST S:'$D(^%ZISL(3.54,0)) ^(0)="RESOURCE^3.54^^" S X=$P(^(0),"^",3),A=X

 F I=+X:0 S I=+$O(^%ZISL(3.54,I)) Q:I'>0  S A=I

 S L=A+1 Q

NTRMS ;

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ZIS31   1118     printed  Apr 09, 2024@21:13:33                                                                                                                                                                                                       Page 2

%ZIS31    ;SFISC/AC - DEVICE HANDLER -- RESOURCES ;10/13/89  13:51

 +1       ;

 +2        LOCK ^%ZISL(3.54):1

 +3        IF '$TEST

               SET POP=1

               if '$DATA(IOP)

                   WRITE *7,"  [NOT AVAILABLE]"

               QUIT 

 +4        SET X=$ORDER(^%ZISL(3.54,"B",IO,0))

 +5        IF 'X

               DO FLST

               SET ^%ZISL(3.54,"B",IO,L)=""

               SET X=L

 +6        IF '($DATA(^%ZISL(3.54,+X,0))#2)

               SET ^(0)=IO_"^"_%ZISRL

               SET A=^%ZISL(3.54,0)

               SET $PIECE(A,"^",3)=+X

               SET $PIECE(A,"^",4)=$PIECE(A,"^",4)+1

               SET ^(0)=A

               SET IO(1,IO)="RES"

               SET %ZISD0=+X

               GOTO R1

 +7        SET %ZISD0=+X

 +8        SET X=$PIECE(^(0),"^",2)

           IF 'X

               SET POP=1

               if '$DATA(IOP)

                   WRITE *7,"  [NOT AVAILABLE]"

               LOCK 

               QUIT 

 +9        SET X=X-1

           SET $PIECE(^(0),"^",2)=X

           SET IO(1,IO)="RES"

 +10      ;

R1        ;

 +1       ;S %ZISROOT="^%ZISL(3.54,"_%ZISD0_",1," S:'$D(^%ZISL(3.54,%ZISD0,1,0)) ^(0)="^3.542^^" D FLST S ^%ZISL(3.54,%ZISD0,1,"B",L,L)="",X=L

 +2        if '$DATA(^%ZISL(3.54,%ZISD0,1,0))

               SET ^(0)="^3.542^^"

 +3       ;D FLST 

 +4        FOR L=1:1:(%ZISRL+1)

               IF '$DATA(^%ZISL(3.54,%ZISD0,1,L,0))

                   QUIT 

 +5        IF '$TEST

               IF L=(%ZISRL+1)

                   SET POP=1

                   KILL IO(1,IO)

                   QUIT 

 +6        SET ^%ZISL(3.54,%ZISD0,1,"B",L,L)=""

           SET X=L

 +7        SET ^%ZISL(3.54,%ZISD0,1,+X,0)=+X_"^"_%ZISV_"^"_$JOB

           SET A=^%ZISL(3.54,%ZISD0,1,0)

           SET $PIECE(A,"^",3)=+X

           SET $PIECE(A,"^",4)=$PIECE(A,"^",4)+1

           SET ^(0)=A

 +8        LOCK 

           QUIT 

 +9       ;

FLST       if '$DATA(^%ZISL(3.54,0))

               SET ^(0)="RESOURCE^3.54^^"

           SET X=$PIECE(^(0),"^",3)

           SET A=X

 +1        FOR I=+X:0

               SET I=+$ORDER(^%ZISL(3.54,I))

               if I'>0

                   QUIT 

               SET A=I

 +2        SET L=A+1

           QUIT 

NTRMS     ;