Home Package List Routine Alphabetical List Global Alphabetical List FileMan Files List FileMan Sub-Files List Package Component Lists Package-Namespace Mapping
Routine: IBXS75

IBXS75.m

Go to the documentation of this file.

IBXS75 ; ;01/15/20

 S X=DE(53),DIC=DIE

 X ^DD(399,202,1,1,2.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U1")):^("U1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X="" S DIH=$G(^DGCR(399,DIV(0),"U1")),DIV=X S $P(^("U1"),U,3)=DIV,DIH=399,DIG=203 D ^DICR

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBXS75   250     printed  Feb 18, 2025@23:57:09                                                                                                                                                                                                       Page 2

IBXS75    ; ;01/15/20

 +1        SET X=DE(53)

           SET DIC=DIE

 +2        XECUTE ^DD(399,202,1,1,2.3)

           IF X

               SET X=DIV

               SET Y(1)=$SELECT($DATA(^DGCR(399,D0,"U1")):^("U1"),1:"")

               SET X=$PIECE(Y(1),U,3)

               SET X=X

               SET DIU=X

               KILL Y

               SET X=""

               SET DIH=$GET(^DGCR(399,DIV(0),"U1"))

               SET DIV=X

               SET $PIECE(^("U1"),U,3)=DIV

               SET DIH=399

               SET DIG=203

               DO ^DICR