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

IBXS61.m

Go to the documentation of this file.

IBXS61 ; ;01/15/20

 S X=DG(DQ),DIC=DIE

 X ^DD(399,161,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X S DIH=$G(^DGCR(399,DIV(0),"U")),DIV=X S $P(^("U"),U,12)=DIV,DIH=399,DIG=162 D ^DICR

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBXS61   266     printed  Apr 09, 2024@21:23:24                                                                                                                                                                                                       Page 2

IBXS61    ; ;01/15/20

 +1        SET X=DG(DQ)

           SET DIC=DIE

 +2        XECUTE ^DD(399,161,1,1,1.3)

           IF X

               SET X=DIV

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

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

               SET X=X

               SET DIU=X

               KILL Y

               SET X=DIV

               DO DIS^IBCU

               SET X=X

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

               SET DIV=X

               SET $PIECE(^("U"),U,12)=DIV

               SET DIH=399

               SET DIG=162

               DO ^DICR