DIS3.m

DIS3 ;SFISC/SEARCH - PROGRAMMER ENTRY POINT ;12/16/93  13:16

 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42

 ;;Per VA Directive 6402, this routine should not be modified.

 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.

 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.

 ;;Licensed under the terms of the Apache License, Version 2.0.

 ;

EN ;

 N DIQUIET,DIFM S L=$G(L),DIFM=+L D CLEAN^DIEFU,INIT^DIP

 S:$G(DIC) DIC=$G(^DIC(DIC,0,"GL")) G QER1:$G(DIC)="" N DK S DK=+$P($G(@(DIC_"0)")),U,2) G QER1:'DK

 N DISV,Y D  S DISV=+Y I Y<0 S DIC="DISTEMP" G QER

 .N DIC,X,DIS S Y=-1,DIS=$G(DISTEMP) Q:DIS=""

 .S X=$S($E(DIS)="[":$P($E(DIS,2,99),"]"),1:DIS),DIC="^DIBT(",DIC(0)="Q",DIC("S")="I '$P(^(0),U,8),$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$D(^(""DIS""))"

 .D ^DIC Q

 N DISTXT S %X="^DIBT(DISV,""DIS"",",%Y="DIS(" D %XY^%RCR

 S %X="^DIBT(DISV,""O"",",%Y="DISTXT(" D %XY^%RCR

 K ^DIBT(DISV,1)

 D EN1^DIP G EXIT

 ;

QER1 S DIC="DIC"

QER D BLD^DIALOG(201,DIC) D:'$G(DIQUIET) MSG^DIALOG()

 D Q^DIP

EXIT K DIC,DISTEMP Q

 ;DIALOG #201  'The input variable...is missing or invalid.'

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DIS3   1129     printed  Apr 09, 2024@21:45:38                                                                                                                                                                                                        Page 2

DIS3      ;SFISC/SEARCH - PROGRAMMER ENTRY POINT ;12/16/93  13:16

 +1       ;;22.2;VA FileMan;;Jan 05, 2016;Build 42

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.

 +4       ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.

 +5       ;;Licensed under the terms of the Apache License, Version 2.0.

 +6       ;

EN        ;

 +1        NEW DIQUIET,DIFM

           SET L=$GET(L)

           SET DIFM=+L

           DO CLEAN^DIEFU

           DO INIT^DIP

 +2        if $GET(DIC)

               SET DIC=$GET(^DIC(DIC,0,"GL"))

           if $GET(DIC)=""

               GOTO QER1

           NEW DK

           SET DK=+$PIECE($GET(@(DIC_"0)")),U,2)

           if 'DK

               GOTO QER1

 +3        NEW DISV,Y

           Begin DoDot:1

 +4            NEW DIC,X,DIS

               SET Y=-1

               SET DIS=$GET(DISTEMP)

               if DIS=""

                   QUIT 

 +5            SET X=$SELECT($EXTRACT(DIS)="[":$PIECE($EXTRACT(DIS,2,99),"]"),1:DIS)

               SET DIC="^DIBT("

               SET DIC(0)="Q"

               SET DIC("S")="I '$P(^(0),U,8),$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$D(^(""DIS""))"

 +6            DO ^DIC

               QUIT 

           End DoDot:1

           SET DISV=+Y

           IF Y<0

               SET DIC="DISTEMP"

               GOTO QER

 +7        NEW DISTXT

           SET %X="^DIBT(DISV,""DIS"","

           SET %Y="DIS("

           DO %XY^%RCR

 +8        SET %X="^DIBT(DISV,""O"","

           SET %Y="DISTXT("

           DO %XY^%RCR

 +9        KILL ^DIBT(DISV,1)

 +10       DO EN1^DIP

           GOTO EXIT

 +11      ;

QER1       SET DIC="DIC"

QER        DO BLD^DIALOG(201,DIC)

           if '$GET(DIQUIET)

               DO MSG^DIALOG()

 +1        DO Q^DIP

EXIT       KILL DIC,DISTEMP

           QUIT 

 +1       ;DIALOG #201  'The input variable...is missing or invalid.'