- DIA ;SFISC/GFT-SELECT FIELDS TO EDIT ;8AUF2014
- ;;22.2;VA FileMan;**19**;Jan 05, 2016;Build 2
- ;;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.
- ;
- D DICS
- 1 D F W !?F*3,"EDIT WHICH "_X G ED:$G(DIAT)]""&DB ;When we are editing a Template, DB is non-zero
- S X=$$FIND^DIUCANON(.402,DI) I X S Y="["_$P(X,U,2)_"]" D RW(Y) G GO ;DI is FILE NUMBER
- R ": ALL// ",X:DTIME S:'$T X=U,DTOUT=1
- GO G ALL^DIA1:X=""!(X="ALL"),TEMP^DIA1:X?1"[".E&'F,L
- ED G NDB:DIAT=""
- GDB S Y=$P(DIAT,";",DB) I "Q"[Y G NDB:Y="" D DB G GDB
- I Y?.NP,$P(Y,":",2),Y'["/" S Y=+Y_"-"_$P(Y,":",2)
- S %=$G(DI(DB,DIARTLVL-1,DI,DIAO)) I %]"" S Y=%
- E I Y?1"^"1N1"."1.2N S DB=DB+1 G GDB ;WPB-0804-30857
- READ D RW(Y)
- S:X="" X=Y I X="ALL" G ALL^DIA1 ;p19
- L S DSC=X?1"^".E I DSC S X=$E(X,2,999) I U[X K DR Q
- I $A(X)=64 G X:X'?1P.N,P:$L(X)>1,X:'DB S DB=DB+1 G 2
- K DIC,DIAB D DICS S DV="",J=$P(X,"-",2) I +J=J,$P(X,"-",1)=+X,J>X S D(F)=J K DA D RANGE^DIA1 K D S Y=DA G X:Y="" D DB G 2
- DIC ;
- EGP S DIC(0)="EZI",DIC="^DD(DI,",Y=-1 G X^DIA3:X[";" D DICW^DIALOGZ(DI),^DIC Q:$D(DTOUT) ;**CCO/NI
- I Y>0 D SET S Y=$P(Y(0),U,2) G 2:'Y S L=L+1,(DI,J(L))=+Y,I(L)=""""_$P($P(Y(0),U,4),";")_"""" G DOWN
- I $E(X)="]" S DRS=9,X=$E(X,2,999) G DIC:X]"",2
- G DIA^DIQQQ:X?."?" I $D(^DD(DI,"GR")) K Y S Y=-1 D:$L(X)<31
- . N I,DIGRP,DTOUT,DUOUT,DIRUT,DIROUT,DIYN S DIGRP=X,DIYN=0
- . D:$D(^DD(DI,"GR",DIGRP)) Q:DIYN F S DIGRP=$O(^DD(DI,"GR",DIGRP)) Q:$E(DIGRP,1,$L(X))'=X D Q:DIYN
- .. N X,I
- .. F I=0:0 S I=$O(^DD(DI,"GR",DIGRP,I)) Q:'I I $G(^DD(DI,I,0))]"" S I(I)=I_U_$P(^(0),U)
- .. Q:'$O(I(0))
- .. W !!,"Fields in Group: ",DIGRP F I=0:0 S I=$O(I(I)) Q:'I W !,?2,I,?10,$P(I(I),U,2)
- .. D Q:DIYN'=1
- ... N X,Y S DIR(0)="Y",DIR("A")="Edit this GROUP of fields",DIR("B")="YES" D ^DIR S DIYN=$S(Y=1:1,$G(DIRUT):2,1:0) Q
- .. M Y=I S Y=0 Q
- . Q
- K DIYN G X^DIA3
- ;
- F S X=$P(^DD(DI,0),U) I F,X="FIELD" S X=$O(^(0,"NM",0))_" "_X
- Q
- ;
- X ;
- W $C(7),"??" D DICS
- 2 ;
- G 1:'$D(DR(F+1,DI)) D F W !?F*3,"THEN EDIT "_X G ED:DB
- R R ": ",X:DTIME E W $C(7) S X=U,DTOUT=1
- I X]"" G L
- UP ;
- G ^DIA1:'F K I(L),J(L) S L=L-1 I '$D(J(L)) F L=L-99:1 Q:'$D(J(L+1))
- I DB S DB=DB(F),DIARTLVL=DIARTLVL(F),DIAO=DIAO(F),DIAT=$S(DIAO<0:"",DIAO:$G(^DIE(DIAA,"DR",DIARTLVL,J(L),DIAO)),$D(^DIE(DIAA,"DR",DIARTLVL,J(L))):^(J(L)),1:"")
- S DIARLVL=DIARLVL(F),DIAP=DIAP(F),DI=J(L),F=F-1 G 2
- ;
- NDB I DB,DIAO'<0 S DIAO=DIAO+1 I $D(^DIE(DIAA,"DR",DIARLVL,DI,DIAO)) S DIAT=^(DIAO),DB=1 G GDB
- S DIAO=-1 G R
- ;
- ;
- ;
- EN ;Entry point from DIB routine
- N DIARTLVL,DIARLVL,DIAL,DIESP,DRR D OS^DII:'$D(DISYS)
- FILETOP D DICS ;Enter from DIA3 when there is a file jump
- DOWN S F=F+1,DIAL(F)=+$G(DIAL),DIARLVL(F)=+$G(DIARLVL) F %=F+1:.01 I '$D(DR(%,DI)) Q ;Find 2.01 if we have already gone down to DR(2,DI) -- WPB-0804-30857
- S:%["." @DRR=@DRR_U_%_";",DIAP=DIAP+1 S DIARLVL=%
- S DIAP(F)=DIAP,DIAP=0
- I DB S DIARTLVL(F)=DIARTLVL D S DB(F)=DB,DB=1,DIAO(F)=DIAO,DIAO=0,DIAT=$G(^DIE(DIAA,"DR",DIARTLVL,DI)),DIARTLVL(DIARTLVL,DI)=""
- .S %=$P(DIAT,";",DB) I %?1"^"1.NP S DIARTLVL=$P(%,U,2),DB=DB+1 Q
- .F DIARTLVL=F+1:.01 I '$D(DIARTLVL(DIARTLVL,DI)) Q
- G 1:$P(^DD(DI,.01,0),U,2)'["W",1:L#100=0,UP
- ;
- DICS ;
- S DIC("S")="I Y>.001,$P(^(0),U,2)'[""C"""_$S(DUZ(0)="@":"",1:",$P(^(0),U,2)'[""K""")_" Q:'$D(^(9)) I ^(9)'=U"_$S(DUZ(0)'="@":" F DW=1:1:$L(^(9)) I DUZ(0)[$E(^(9),DW) Q",1:"") Q
- ;
- P ;
- S DRS=99,Y=X D DB G 2
- ;
- SET S Y=+Y_DV
- DB ;
- I DB,'DSC S DB=DB+1
- D ;takes 'Y' and puts it into 'DR' array -- Also called from DIA3
- N %,B
- S (DRR,B)=$NA(DR(DIARLVL,DI)),%=$O(@DRR@(""),-1)
- I % S DRR=$NA(@DRR@(%))
- I '$D(@DRR) S @DRR="",DIAP=0
- E I $L(Y)+$L(@DRR)>230 S DRR=$NA(@B@(%+1)),DIAP=DIAP\1000+1*1000,@DRR=""
- S @DRR=@DRR_Y_";",DRS=$G(DRS)+1
- S DIAP=DIAP+1
- DIAB I $D(DIAB) S ^UTILITY($J,DIAP#1000,DIARLVL-1,DI,DIAP\1000)=DIAB K DIAB
- Q
- ;
- ;
- RW(Y) ;sets X, and maybe DTOUT
- W ": "_Y I $L(Y)>19 D RW^DIR2 Q
- W "// " R X:DTIME E S X=U,DTOUT=1 W $C(7) Q
- S:X="" X=Y Q
- ;
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIA 4171 printed Feb 19, 2025@00:10:47 Page 2
- DIA ;SFISC/GFT-SELECT FIELDS TO EDIT ;8AUF2014
- +1 ;;22.2;VA FileMan;**19**;Jan 05, 2016;Build 2
- +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 DO DICS
- 1 ;When we are editing a Template, DB is non-zero
- DO F
- WRITE !?F*3,"EDIT WHICH "_X
- if $GET(DIAT)]""&DB
- GOTO ED
- +1 ;DI is FILE NUMBER
- SET X=$$FIND^DIUCANON(.402,DI)
- IF X
- SET Y="["_$PIECE(X,U,2)_"]"
- DO RW(Y)
- GOTO GO
- +2 READ ": ALL// ",X:DTIME
- if '$TEST
- SET X=U
- SET DTOUT=1
- GO if X=""!(X="ALL")
- GOTO ALL^DIA1
- if X?1"[".E&'F
- GOTO TEMP^DIA1
- GOTO L
- ED if DIAT=""
- GOTO NDB
- GDB SET Y=$PIECE(DIAT,";",DB)
- IF "Q"[Y
- if Y=""
- GOTO NDB
- DO DB
- GOTO GDB
- +1 IF Y?.NP
- IF $PIECE(Y,":",2)
- IF Y'["/"
- SET Y=+Y_"-"_$PIECE(Y,":",2)
- +2 SET %=$GET(DI(DB,DIARTLVL-1,DI,DIAO))
- IF %]""
- SET Y=%
- +3 ;WPB-0804-30857
- IF '$TEST
- IF Y?1"^"1N1"."1.2N
- SET DB=DB+1
- GOTO GDB
- READ DO RW(Y)
- +1 ;p19
- if X=""
- SET X=Y
- IF X="ALL"
- GOTO ALL^DIA1
- L SET DSC=X?1"^".E
- IF DSC
- SET X=$EXTRACT(X,2,999)
- IF U[X
- KILL DR
- QUIT
- +1 IF $ASCII(X)=64
- if X'?1P.N
- GOTO X
- if $LENGTH(X)>1
- GOTO P
- if 'DB
- GOTO X
- SET DB=DB+1
- GOTO 2
- +2 KILL DIC,DIAB
- DO DICS
- SET DV=""
- SET J=$PIECE(X,"-",2)
- IF +J=J
- IF $PIECE(X,"-",1)=+X
- IF J>X
- SET D(F)=J
- KILL DA
- DO RANGE^DIA1
- KILL D
- SET Y=DA
- if Y=""
- GOTO X
- DO DB
- GOTO 2
- DIC ;
- EGP ;**CCO/NI
- SET DIC(0)="EZI"
- SET DIC="^DD(DI,"
- SET Y=-1
- if X[";"
- GOTO X^DIA3
- DO DICW^DIALOGZ(DI)
- DO ^DIC
- if $DATA(DTOUT)
- QUIT
- +1 IF Y>0
- DO SET
- SET Y=$PIECE(Y(0),U,2)
- if 'Y
- GOTO 2
- SET L=L+1
- SET (DI,J(L))=+Y
- SET I(L)=""""_$PIECE($PIECE(Y(0),U,4),";")_""""
- GOTO DOWN
- +2 IF $EXTRACT(X)="]"
- SET DRS=9
- SET X=$EXTRACT(X,2,999)
- if X]""
- GOTO DIC
- GOTO 2
- +3 if X?."?"
- GOTO DIA^DIQQQ
- IF $DATA(^DD(DI,"GR"))
- KILL Y
- SET Y=-1
- if $LENGTH(X)<31
- Begin DoDot:1
- +4 NEW I,DIGRP,DTOUT,DUOUT,DIRUT,DIROUT,DIYN
- SET DIGRP=X
- SET DIYN=0
- +5 if $DATA(^DD(DI,"GR",DIGRP))
- Begin DoDot:2
- +6 NEW X,I
- +7 FOR I=0:0
- SET I=$ORDER(^DD(DI,"GR",DIGRP,I))
- if 'I
- QUIT
- IF $GET(^DD(DI,I,0))]""
- SET I(I)=I_U_$PIECE(^(0),U)
- +8 if '$ORDER(I(0))
- QUIT
- +9 WRITE !!,"Fields in Group: ",DIGRP
- FOR I=0:0
- SET I=$ORDER(I(I))
- if 'I
- QUIT
- WRITE !,?2,I,?10,$PIECE(I(I),U,2)
- +10 Begin DoDot:3
- +11 NEW X,Y
- SET DIR(0)="Y"
- SET DIR("A")="Edit this GROUP of fields"
- SET DIR("B")="YES"
- DO ^DIR
- SET DIYN=$SELECT(Y=1:1,$GET(DIRUT):2,1:0)
- QUIT
- End DoDot:3
- if DIYN'=1
- QUIT
- +12 MERGE Y=I
- SET Y=0
- QUIT
- End DoDot:2
- if DIYN
- QUIT
- FOR
- SET DIGRP=$ORDER(^DD(DI,"GR",DIGRP))
- if $EXTRACT(DIGRP,1,$LENGTH(X))'=X
- QUIT
- Begin DoDot:2
- End DoDot:2
- if DIYN
- QUIT
- +13 QUIT
- End DoDot:1
- +14 KILL DIYN
- GOTO X^DIA3
- +15 ;
- F SET X=$PIECE(^DD(DI,0),U)
- IF F
- IF X="FIELD"
- SET X=$ORDER(^(0,"NM",0))_" "_X
- +1 QUIT
- +2 ;
- X ;
- +1 WRITE $CHAR(7),"??"
- DO DICS
- 2 ;
- +1 if '$DATA(DR(F+1,DI))
- GOTO 1
- DO F
- WRITE !?F*3,"THEN EDIT "_X
- if DB
- GOTO ED
- R READ ": ",X:DTIME
- IF '$TEST
- WRITE $CHAR(7)
- SET X=U
- SET DTOUT=1
- +1 IF X]""
- GOTO L
- UP ;
- +1 if 'F
- GOTO ^DIA1
- KILL I(L),J(L)
- SET L=L-1
- IF '$DATA(J(L))
- FOR L=L-99:1
- if '$DATA(J(L+1))
- QUIT
- +2 IF DB
- SET DB=DB(F)
- SET DIARTLVL=DIARTLVL(F)
- SET DIAO=DIAO(F)
- SET DIAT=$SELECT(DIAO<0:"",DIAO:$GET(^DIE(DIAA,"DR",DIARTLVL,J(L),DIAO)),$DATA(^DIE(DIAA,"DR",DIARTLVL,J(L))):^(J(L)),1:"")
- +3 SET DIARLVL=DIARLVL(F)
- SET DIAP=DIAP(F)
- SET DI=J(L)
- SET F=F-1
- GOTO 2
- +4 ;
- NDB IF DB
- IF DIAO'<0
- SET DIAO=DIAO+1
- IF $DATA(^DIE(DIAA,"DR",DIARLVL,DI,DIAO))
- SET DIAT=^(DIAO)
- SET DB=1
- GOTO GDB
- +1 SET DIAO=-1
- GOTO R
- +2 ;
- +3 ;
- +4 ;
- EN ;Entry point from DIB routine
- +1 NEW DIARTLVL,DIARLVL,DIAL,DIESP,DRR
- if '$DATA(DISYS)
- DO OS^DII
- FILETOP ;Enter from DIA3 when there is a file jump
- DO DICS
- DOWN ;Find 2.01 if we have already gone down to DR(2,DI) -- WPB-0804-30857
- SET F=F+1
- SET DIAL(F)=+$GET(DIAL)
- SET DIARLVL(F)=+$GET(DIARLVL)
- FOR %=F+1:.01
- IF '$DATA(DR(%,DI))
- QUIT
- +1 if %["."
- SET @DRR=@DRR_U_%_";"
- SET DIAP=DIAP+1
- SET DIARLVL=%
- +2 SET DIAP(F)=DIAP
- SET DIAP=0
- +3 IF DB
- SET DIARTLVL(F)=DIARTLVL
- Begin DoDot:1
- +4 SET %=$PIECE(DIAT,";",DB)
- IF %?1"^"1.NP
- SET DIARTLVL=$PIECE(%,U,2)
- SET DB=DB+1
- QUIT
- +5 FOR DIARTLVL=F+1:.01
- IF '$DATA(DIARTLVL(DIARTLVL,DI))
- QUIT
- End DoDot:1
- SET DB(F)=DB
- SET DB=1
- SET DIAO(F)=DIAO
- SET DIAO=0
- SET DIAT=$GET(^DIE(DIAA,"DR",DIARTLVL,DI))
- SET DIARTLVL(DIARTLVL,DI)=""
- +6 if $PIECE(^DD(DI,.01,0),U,2)'["W"
- GOTO 1
- if L#100=0
- GOTO 1
- GOTO UP
- +7 ;
- DICS ;
- +1 SET DIC("S")="I Y>.001,$P(^(0),U,2)'[""C"""_$SELECT(DUZ(0)="@":"",1:",$P(^(0),U,2)'[""K""")_" Q:'$D(^(9)) I ^(9)'=U"_$SELECT(DUZ(0)'="@":" F DW=1:1:$L(^(9)) I DUZ(0)[$E(^(9),DW) Q",1:"")
- QUIT
- +2 ;
- P ;
- +1 SET DRS=99
- SET Y=X
- DO DB
- GOTO 2
- +2 ;
- SET SET Y=+Y_DV
- DB ;
- +1 IF DB
- IF 'DSC
- SET DB=DB+1
- D ;takes 'Y' and puts it into 'DR' array -- Also called from DIA3
- +1 NEW %,B
- +2 SET (DRR,B)=$NAME(DR(DIARLVL,DI))
- SET %=$ORDER(@DRR@(""),-1)
- +3 IF %
- SET DRR=$NAME(@DRR@(%))
- +4 IF '$DATA(@DRR)
- SET @DRR=""
- SET DIAP=0
- +5 IF '$TEST
- IF $LENGTH(Y)+$LENGTH(@DRR)>230
- SET DRR=$NAME(@B@(%+1))
- SET DIAP=DIAP\1000+1*1000
- SET @DRR=""
- +6 SET @DRR=@DRR_Y_";"
- SET DRS=$GET(DRS)+1
- +7 SET DIAP=DIAP+1
- DIAB IF $DATA(DIAB)
- SET ^UTILITY($JOB,DIAP#1000,DIARLVL-1,DI,DIAP\1000)=DIAB
- KILL DIAB
- +1 QUIT
- +2 ;
- +3 ;
- RW(Y) ;sets X, and maybe DTOUT
- +1 WRITE ": "_Y
- IF $LENGTH(Y)>19
- DO RW^DIR2
- QUIT
- +2 WRITE "// "
- READ X:DTIME
- IF '$TEST
- SET X=U
- SET DTOUT=1
- WRITE $CHAR(7)
- QUIT
- +3 if X=""
- SET X=Y
- QUIT
- +4 ;
- +5 ;