- 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 ---[H[J[2J[HDIS3 1129 printed Jan 18, 2025@03:55 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.'