- DIS2 ;SFISC/GFT-SEARCH, TEMPLATES & COMPUTED FIELDS;4JUN2005
- ;;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.
- ;
- K DISV G G:'DUZ
- 0 D K DIRUT,DIROUT I $D(DTOUT)!($D(DUOUT)) G Q
- . N DIS,DIS0,DA,DC,DE,DJ,DL D S3^DIBT1 Q
- I X="" G G:'$D(DIAR)
- I Y<0 G Q:X=U,0
- I $D(DIARU),DIARU-Y=0 W $C(7),!,"Archivers must not store results in the default template" G 0
- S (DIARI,DISV)=+Y,A=$D(^DIBT(DISV,"DL")) S:$D(DIS0)#2 ^("DL")=DIS0 S:$D(DA)#2 ^("DA")=DA S:$D(DJ)#2 ^("DJ")=DJ
- I $D(DIAR),'$D(DIARU) S $P(^DIAR(1.11,DIARC,0),U,3)=DISV
- S Z=-1,DIS0="^DIBT(+Y," F P="DIS","DA","DC","DE","DJ","DL" S %Y=DIS0_""""_P_""",",%X=P_"(" D %XY^%RCR
- S %X="^UTILITY($J,",%Y="^DIBT(DISV,""O"",",@(%X_"0)=U") D %XY^%RCR
- G N DISTXT S %X="^UTILITY($J,",%Y="DISTXT(" D %XY^%RCR
- W ! S Y=DI D Q S DIC=Y G EN1^DIP:$D(SF)!$D(L)&'$D(DIAR),EN^DIP
- ;
- TEM ;
- K DIC S X=$P($E(X,2,99),"]",1),DIC="^DIBT(",DIC(0)="EQ",DIC("S")="I "_$S($D(DIAR):"$P(^(0),U,8)",1:"'$P(^(0),U,8)")_",$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$D(^(""DIS""))"
- S DIC("W")="X ""F %=1:1 Q:'$D(^DIBT(Y,""""O"""",%,0)) W !?9 S I=^(0) W:$L(I)+$X>79 !?9 W I"""
- D ^DIC K DIC G F^DIS:Y<0
- S P="DIS",Z=-1,%X="^DIBT(+Y,P,",%Y="DIS(" D %XY^%RCR
- S %Y="^UTILITY($J,",P="O" D %XY^%RCR
- G DIS2
- ;
- COMP ;
- S E=X,DICMX="X DIS(DIXX)",DICOMP=N_"?",DQI="Y(",DA="DIS("""_$C(DC+64)_DL_"""," I $D(O(DC))[0 S O(DC)=X
- G COLON:X?.E1":"
- I X?.E1":.01",$D(O(DC))[0 S O(DC)=$E(X,1,$L(X)-4)
- D EN^DICOMP,XA G X:'$D(X),X:Y["m" ;I Y["m" S X=E_":" G COMP
- S DA(DC)=X,DU=-DC,E=$E("B",Y["B")_$E("D",Y["D") I Y["p" S E="p"_+$P(Y,"p",2)
- G G^DIS
- ;
- XA S %=0 F S %=$O(X(%)) Q:%="" S @(DA_%_")")=X(%)
- S %=-1 Q
- ;
- COLON D ^DICOMPW,XA G X:'$D(X)
- S R(DL)=R,N(DL)=N,N=+Y,DY=DY+1,DV(DL)=DV,DL(DL)=DK,DL=DL+1,DV=DV_-DY_C,DY(DY)=DP_U_$S(Y["m":DC_"."_DL,1:"")_U_X,R=U_$P(DP,U,2)
- K X G R^DIS
- ;
- Q ;
- K DIC,DA,DX,O,D,DC,DI,DK,DL,DQ,DU,DV,E,DE,DJ,N,P,Z,R,DY,DTOUT,DIRUT,DUOUT,DIROUT,^UTILITY($J)
- Q
- ;
- X K O(DC) G X^DIS
- ;
- DIS ;PUT SET LOGIC INTO DIS FOR SUBFILE
- S %X="" F %Y=1:1 S %X=$O(DIS(%X)) Q:'%X S %=$S($D(DIAR(DIARF,%X)):DIAR(DIARF,%X),1:DIS(%X)) S:%["X DIS(" %=$P(%,"X DIS(")_"X DIFG("_DIARF_","_$P(%,"X DIS(",2) S ^DIAR(1.11,DIARC,"S",%Y,0)=%X,^(1)=%
- S:%Y>1 %Y=%Y-1,^DIAR(1.11,DIARC,"S",0)="^1.1132^"_%Y_U_%Y G DIS2
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIS2 2538 printed Jan 18, 2025@03:54:59 Page 2
- DIS2 ;SFISC/GFT-SEARCH, TEMPLATES & COMPUTED FIELDS;4JUN2005
- +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 ;
- +7 KILL DISV
- if 'DUZ
- GOTO G
- 0 Begin DoDot:1
- +1 NEW DIS,DIS0,DA,DC,DE,DJ,DL
- DO S3^DIBT1
- QUIT
- End DoDot:1
- KILL DIRUT,DIROUT
- IF $DATA(DTOUT)!($DATA(DUOUT))
- GOTO Q
- +2 IF X=""
- if '$DATA(DIAR)
- GOTO G
- +3 IF Y<0
- if X=U
- GOTO Q
- GOTO 0
- +4 IF $DATA(DIARU)
- IF DIARU-Y=0
- WRITE $CHAR(7),!,"Archivers must not store results in the default template"
- GOTO 0
- +5 SET (DIARI,DISV)=+Y
- SET A=$DATA(^DIBT(DISV,"DL"))
- if $DATA(DIS0)#2
- SET ^("DL")=DIS0
- if $DATA(DA)#2
- SET ^("DA")=DA
- if $DATA(DJ)#2
- SET ^("DJ")=DJ
- +6 IF $DATA(DIAR)
- IF '$DATA(DIARU)
- SET $PIECE(^DIAR(1.11,DIARC,0),U,3)=DISV
- +7 SET Z=-1
- SET DIS0="^DIBT(+Y,"
- FOR P="DIS","DA","DC","DE","DJ","DL"
- SET %Y=DIS0_""""_P_""","
- SET %X=P_"("
- DO %XY^%RCR
- +8 SET %X="^UTILITY($J,"
- SET %Y="^DIBT(DISV,""O"","
- SET @(%X_"0)=U")
- DO %XY^%RCR
- G NEW DISTXT
- SET %X="^UTILITY($J,"
- SET %Y="DISTXT("
- DO %XY^%RCR
- +1 WRITE !
- SET Y=DI
- DO Q
- SET DIC=Y
- if $DATA(SF)!$DATA(L)&'$DATA(DIAR)
- GOTO EN1^DIP
- GOTO EN^DIP
- +2 ;
- TEM ;
- +1 KILL DIC
- SET X=$PIECE($EXTRACT(X,2,99),"]",1)
- SET DIC="^DIBT("
- SET DIC(0)="EQ"
- SET DIC("S")="I "_$SELECT($DATA(DIAR):"$P(^(0),U,8)",1:"'$P(^(0),U,8)")_",$P(^(0),U,4)=DK,$P(^(0),U,5)=DUZ!'$P(^(0),U,5),$D(^(""DIS""))"
- +2 SET DIC("W")="X ""F %=1:1 Q:'$D(^DIBT(Y,""""O"""",%,0)) W !?9 S I=^(0) W:$L(I)+$X>79 !?9 W I"""
- +3 DO ^DIC
- KILL DIC
- if Y<0
- GOTO F^DIS
- +4 SET P="DIS"
- SET Z=-1
- SET %X="^DIBT(+Y,P,"
- SET %Y="DIS("
- DO %XY^%RCR
- +5 SET %Y="^UTILITY($J,"
- SET P="O"
- DO %XY^%RCR
- +6 GOTO DIS2
- +7 ;
- COMP ;
- +1 SET E=X
- SET DICMX="X DIS(DIXX)"
- SET DICOMP=N_"?"
- SET DQI="Y("
- SET DA="DIS("""_$CHAR(DC+64)_DL_""","
- IF $DATA(O(DC))[0
- SET O(DC)=X
- +2 if X?.E1":"
- GOTO COLON
- +3 IF X?.E1":.01"
- IF $DATA(O(DC))[0
- SET O(DC)=$EXTRACT(X,1,$LENGTH(X)-4)
- +4 ;I Y["m" S X=E_":" G COMP
- DO EN^DICOMP
- DO XA
- if '$DATA(X)
- GOTO X
- if Y["m"
- GOTO X
- +5 SET DA(DC)=X
- SET DU=-DC
- SET E=$EXTRACT("B",Y["B")_$EXTRACT("D",Y["D")
- IF Y["p"
- SET E="p"_+$PIECE(Y,"p",2)
- +6 GOTO G^DIS
- +7 ;
- XA SET %=0
- FOR
- SET %=$ORDER(X(%))
- if %=""
- QUIT
- SET @(DA_%_")")=X(%)
- +1 SET %=-1
- QUIT
- +2 ;
- COLON DO ^DICOMPW
- DO XA
- if '$DATA(X)
- GOTO X
- +1 SET R(DL)=R
- SET N(DL)=N
- SET N=+Y
- SET DY=DY+1
- SET DV(DL)=DV
- SET DL(DL)=DK
- SET DL=DL+1
- SET DV=DV_-DY_C
- SET DY(DY)=DP_U_$SELECT(Y["m":DC_"."_DL,1:"")_U_X
- SET R=U_$PIECE(DP,U,2)
- +2 KILL X
- GOTO R^DIS
- +3 ;
- Q ;
- +1 KILL DIC,DA,DX,O,D,DC,DI,DK,DL,DQ,DU,DV,E,DE,DJ,N,P,Z,R,DY,DTOUT,DIRUT,DUOUT,DIROUT,^UTILITY($JOB)
- +2 QUIT
- +3 ;
- X KILL O(DC)
- GOTO X^DIS
- +1 ;
- DIS ;PUT SET LOGIC INTO DIS FOR SUBFILE
- +1 SET %X=""
- FOR %Y=1:1
- SET %X=$ORDER(DIS(%X))
- if '%X
- QUIT
- SET %=$SELECT($DATA(DIAR(DIARF,%X)):DIAR(DIARF,%X),1:DIS(%X))
- if %["X DIS("
- SET %=$PIECE(%,"X DIS(")_"X DIFG("_DIARF_","_$PIECE(%,"X DIS(",2)
- SET ^DIAR(1.11,DIARC,"S",%Y,0)=%X
- SET ^(1)=%
- +2 if %Y>1
- SET %Y=%Y-1
- SET ^DIAR(1.11,DIARC,"S",0)="^1.1132^"_%Y_U_%Y
- GOTO DIS2